(FILECREATED "15-Dec-85 13:04:43" {FLOPPY}FLAGBROWSER.;1
 3974   

      previous date: "11-Oct-85 13:23:09" {DSK}<USERFILES>LISPUSERS>FLAGBROWSER.;6)


(* Copyright (c) 1984, 1985 by Applied Expert Systems, Inc.. All rights reserved.)

(PRETTYCOMPRINT FLAGBROWSERCOMS)

(RPAQQ FLAGBROWSERCOMS
 ((* Browser for setting and unsetting flags.)
			(FNS MAKEFLAGBROWSER)
			(* * Internal functions.)
			(FNS FLAGBROWSERFN FLAGBROWSERMSG FLAGBROWSERSHADE)
			(INITVARS (FLAGBROWSERGRAYSHADE 32767))
			(* Compiler)
			(LOCALVARS . T)
			(GLOBALVARS FLAGBROWSERGRAYSHADE)))



(* Browser for setting and unsetting flags.)


(DEFINEQ

(MAKEFLAGBROWSER

  [LAMBDA (FLAGLST MENUPROPS POSITION)                       (* M.Model "22-Aug-84 16:24")


          (* Create a Flag Browser using flags on FLAGLST. -

	  MENUPROPS is a proplist of menu properties. -

	  For elements of FLAGLST that are themselves lists, the CAR is the FLAG and the CDR is a list of allowable values 

	  other than NIL and T, or, if the CDR is an atom, a function to call with CAR as its argument.

	  -

	  Flags that are unbound will be initialized to NIL.)



    (LET [(FLAGMENU (create
 MENU
			    ITEMS ← FLAGLST
			    WHENSELECTEDFN ←(
QUOTE
 FLAGBROWSERFN)
			    WHENHELDFN ←(
QUOTE
 FLAGBROWSERMSG]
      (for
 PROP on
 MENUPROPS by
 (
CDDR
 PROP) bind
 (MENUDECL ←(
RECLOOK
 (
QUOTE
 MENU)))
	 do
 (
RECORDACCESS
 (
CAR
 PROP)
			  FLAGMENU MENUDECL (
QUOTE
 REPLACE)
			  (
CADR
 PROP)))
      [
COND

	((
EQ
 T POSITION)
	  (
PROMPTPRINT
 "Indicate where the menu should go.")
	  (
SETQ
 POSITION (
GETBOXPOSITION
 FLAGMENU:IMAGEWIDTH FLAGMENU:IMAGEHEIGHT]
      (
ADDMENU
 FLAGMENU NIL POSITION)
      (for
 ITEM in
 FLAGLST bind
 FLAG eachtime
 (
SETQ
 FLAG (
COND

						  ((
LISTP
 ITEM)
						    (
CAR
 ITEM))
						  (ITEM)))
	 do
 (
OR
 (
BOUNDP
 FLAG)
		(
SET
 FLAG))
	    (FLAGBROWSERSHADE
 ITEM FLAGMENU))
      FLAGMENU])
)
(* * Internal functions.)


(DEFINEQ

(FLAGBROWSERFN

  [LAMBDA (ITEM MENU KEY)                                    (* M.Model "22-Aug-84 16:51")

    (LET [(FLAG (
COND

		  ((
LISTP
 ITEM)
		    (
CAR
 ITEM))
		  (ITEM]
      [
SELECTQ
 KEY
	       [MIDDLE (
COND

			 [(
LISTP
 ITEM)
			   (
SET
 FLAG (
COND

				  [(
LISTP
 (
CDR
 ITEM))
				    (
MENU
 (create
 MENU
						  ITEMS ←(
APPEND
 (
QUOTE
 (NIL T))
								 (
CDR
 ITEM]
				  (T (
APPLY*
 (
CDR
 ITEM)
					     (
CAR
 ITEM]
			 (T (
SET
 FLAG (
MKATOM
 (
PROMPTFORWORD
 "New value for flag: " NIL NIL 
							     PROMPTWINDOW]
	       (
SET
 FLAG (
NOT
 (
EVALV
 FLAG]
      (FLAGBROWSERSHADE
 ITEM MENU])

(FLAGBROWSERMSG

  [LAMBDA (ITEM MENU KEY)                                    (* M.Model "17-MAY-84 18:34")

    (
PROMPTPRINT
 (
COND

		   ((
AND
 (
EQ
 KEY (
QUOTE
 MIDDLE))
			 (
LISTP
 ITEM))
		     "Puts up a menu of allowable values and sets the flag to the selected one.")
		   ((
EQ
 KEY (
QUOTE
 MIDDLE))
		     "Prompts for a new value for the flag.")
		   (T "Inverts the selected flag."])

(FLAGBROWSERSHADE

  [LAMBDA (ITEM MENU)                                        (* M.Model "17-MAY-84 11:55")


          (* Shade a flag in a flagbrowser according to its value: WHITE = NIL, BLACK = T, and the value of 

	  FLAGBROWSERGRAYSHADE is used for anything else.)



    (
SHADEITEM
 ITEM MENU (
SELECTQ
 (
EVALV
 (
COND

					   ((
LISTP
 ITEM)
					     (
CAR
 ITEM))
					   (ITEM)))
				  (T BLACKSHADE)
				  (NIL WHITESHADE)
				  FLAGBROWSERGRAYSHADE])
)

(RPAQ? FLAGBROWSERGRAYSHADE
 32767)



(* Compiler)


(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS FLAGBROWSERGRAYSHADE)
)
(PUTPROPS FLAGBROWSER COPYRIGHT ("Applied Expert Systems, Inc." 1984 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (628 2032 (MAKEFLAGBROWSER 638 . 2030)) (2065 3691 (FLAGBROWSERFN 2075 . 2769) (
FLAGBROWSERMSG 2771 . 3194) (FLAGBROWSERSHADE 3196 . 3689)))))
STOP