;-*- Mode:LISP; Package:TV; Base:8 -*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;This file contains stuff that goes along with TSCROL for letting the ;user choose things in various ways other than menus. (DEFFLAVOR SCROLL-STUFF-ON-OFF-MIXIN ((MAKING-SCROLL-DECISION NIL)) ;Internal, prevents infinite recursion (MARGIN-SCROLL-MIXIN MARGIN-REGION-MIXIN FLASHY-SCROLLING-MIXIN BASIC-SCROLL-BAR) (:REQUIRED-METHODS :SCROLL-BAR-P ;T if scrolling needed :ADJUSTABLE-SIZE-P) ;T if outside size can change ; to preserve inside size, ; NIL if something like a pane (:DOCUMENTATION :MIXIN "Scroll bar, flashy scrolling, and margin scrolling, which turn on and off with :SCROLL-BAR-P") (:DEFAULT-INIT-PLIST :SCROLL-BAR 2 ;This 2 is unmodular, sigh. :MARGIN-SCROLL-REGIONS '(:TOP :BOTTOM) :FLASHY-SCROLLING-REGION '((32. 0.40s0 0.60s0) (32. 0.40s0 0.60s0)))) (DEFMETHOD (SCROLL-STUFF-ON-OFF-MIXIN :BEFORE :REDEFINE-MARGINS) (PLIST &AUX TEM) (COND ((SETQ TEM (GETL PLIST '(:SCROLL-BAR))) ;If changing the scroll-bar (SETQ TEM (CADR TEM)) (DOLIST (R REGION-LIST) (AND (EQ (MARGIN-REGION-FUNCTION R) 'MARGIN-SCROLL-REGION) (SETF (MARGIN-REGION-SIZE R) (IF (NULL TEM) 0 (+ 2 (FONT-CHAR-HEIGHT (MARGIN-SCROLL-REGION-MSG-FONT R))))))) (PUTPROP PLIST REGION-LIST ':REGION-LIST)))) ;Cause those changes to get parsed (DEFMETHOD (SCROLL-STUFF-ON-OFF-MIXIN :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE) (OR MAKING-SCROLL-DECISION (FUNCALL-SELF ':DECIDE-IF-SCROLLING-NECESSARY))) ;;; Window should send this message to itself after changing the ;;; number of displayable items, but before doing the associated ;;; redisplay. This method will decide whether to turn the scroll ;;; bar, flashy scrolling, and margin-scroll regions on and off. ;;; If :ADJUSTABLE-SIZE-P, then if changing the number of displayable ;;; items changes the height of the window, that should be done ;;; before sending this message. ;;; This can change the inside-height of the window, unless the ;;; :ADJUSTABLE-SIZE-P message returns T. ;;; Note that redisplay can happen inside this method, you may want ;;; to do a WITH-SHEET-DEEXPOSED to avoid letting the user see ;;; gratuitous double redisplays, or to suppress the redisplay ;;; entirely if there is no bit-save-array. (DEFMETHOD (SCROLL-STUFF-ON-OFF-MIXIN :DECIDE-IF-SCROLLING-NECESSARY) () (BIND (LOCATE-IN-INSTANCE SELF 'MAKING-SCROLL-DECISION) T) (LET ((IW (SHEET-INSIDE-WIDTH)) (IH (SHEET-INSIDE-HEIGHT)) (CHANGEP NIL)) (COND ((FUNCALL-SELF ':SCROLL-BAR-P) ;Need scrolling? (COND ((NOT SCROLL-BAR) ;If scroll stuff not on, turn on (SETQ CHANGEP T) (FUNCALL-SELF ':SET-SCROLL-BAR 2)))) (T ;Doesn't need scrolling (MULTIPLE-VALUE-BIND (IGNORE N-ITEMS IGNORE) (FUNCALL-SELF ':SCROLL-POSITION) (COND ((ZEROP N-ITEMS)) ;Obviously not set up yet ((NULL SCROLL-BAR)) ;Already off (T (SETQ CHANGEP T) ;Turn scroll stuff off (FUNCALL-SELF ':SET-SCROLL-BAR NIL)))))) (AND CHANGEP (FUNCALL-SELF ':ADJUSTABLE-SIZE-P) (FUNCALL-SELF ':SET-INSIDE-SIZE IW IH)))) ;;; Margin region windows, various special areas can be defined within the window's ;;; margins that are allowed to handle the mouse (DEFFLAVOR MARGIN-REGION-MIXIN ((REGION-LIST NIL) ;A list of active regions (CURRENT-REGION NIL) ;The one currently owning the mouse ) () (:INCLUDED-FLAVORS MARGIN-HACKER-MIXIN MOUSE-MOVES-MIXIN) (:INITABLE-INSTANCE-VARIABLES REGION-LIST) (:DOCUMENTATION :MIXIN "Allows separate mouse handling in parts of the margins")) (DEFSTRUCT (MARGIN-REGION :LIST (:CONSTRUCTOR NIL)) MARGIN-REGION-FUNCTION ;A DTP-SELECT-METHOD for this one MARGIN-REGION-MARGIN ;Name of the margin occupied MARGIN-REGION-SIZE ;Amount of that to occupy MARGIN-REGION-LEFT ;Its area of the screen MARGIN-REGION-TOP MARGIN-REGION-RIGHT MARGIN-REGION-BOTTOM) (DEFMETHOD (MARGIN-REGION-MIXIN :BEFORE :INIT) (INIT-PLIST) (ADJUST-MARGINS 'REGION-LIST ':PARSE-REGION-LIST INIT-PLIST NIL)) (DEFMETHOD (MARGIN-REGION-MIXIN :SET-REGION-LIST) (NEW-REGION-LIST &AUX (PLIST (LIST ':REGION-LIST NEW-REGION-LIST))) (FUNCALL-SELF ':REDEFINE-MARGINS (LOCF PLIST))) (DEFMETHOD (MARGIN-REGION-MIXIN :BEFORE :REDEFINE-MARGINS) (PLIST) (ADJUST-MARGINS 'REGION-LIST ':PARSE-REGION-LIST PLIST ':REGION-LIST)) (DEFMETHOD (MARGIN-REGION-MIXIN :PARSE-REGION-LIST) (SPEC LM TM RM BM) (DO ((SPEC SPEC (CDR SPEC)) (REGION) (SIZE) (LEFT) (TOP) (RIGHT) (BOTTOM)) ((NULL SPEC)) (SETQ REGION (CAR SPEC) SIZE (MARGIN-REGION-SIZE REGION) LEFT LM TOP TM RIGHT (- RM) BOTTOM (- BM)) (SELECTQ (MARGIN-REGION-MARGIN REGION) (:LEFT (SETQ RIGHT (SETQ LM (+ LM SIZE)))) (:TOP (SETQ BOTTOM (SETQ TM (+ TM SIZE)))) (:RIGHT (SETQ LEFT (- (SETQ RM (+ RM SIZE))))) (:BOTTOM (SETQ TOP (- (SETQ BM (+ BM SIZE)))))) (SETF (MARGIN-REGION-LEFT REGION) LEFT) (SETF (MARGIN-REGION-TOP REGION) TOP) (SETF (MARGIN-REGION-RIGHT REGION) RIGHT) (SETF (MARGIN-REGION-BOTTOM REGION) BOTTOM)) (PROG () (RETURN SPEC LM TM RM BM))) (DEFMETHOD (MARGIN-REGION-MIXIN :AFTER :REFRESH-MARGINS) () (DOLIST (REGION REGION-LIST) (FUNCALL (MARGIN-REGION-FUNCTION REGION) ':REFRESH REGION))) ;(DEFWRAPPER (MARGIN-REGION-MIXIN :MOUSE-MOVES) (IGNORE . BODY) ; `(*CATCH 'REGION-HANDLED-MOUSE ; (PROGN . ,BODY))) (DEFMETHOD (MARGIN-REGION-MIXIN :AFTER :MOUSE-MOVES) (X Y &AUX REGION) (DOLIST (REG REGION-LIST) (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (MARGIN-REGION-AREA REG) (AND ( X LEFT) (< X RIGHT) ( Y TOP) (< Y BOTTOM) (RETURN (SETQ REGION REG))))) (COND ((NEQ REGION CURRENT-REGION) (IF CURRENT-REGION (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-LEAVES-REGION CURRENT-REGION) (FUNCALL-SELF ':MOUSE-LEAVES-REGION)) (IF REGION (FUNCALL (MARGIN-REGION-FUNCTION REGION) ':MOUSE-ENTERS-REGION REGION) (FUNCALL-SELF ':MOUSE-ENTERS-REGION)))) (COND ((SETQ CURRENT-REGION REGION) ; (MOUSE-SET-BLINKER-CURSORPOS) (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-MOVES X Y CURRENT-REGION) ; (*THROW 'REGION-HANDLED-MOUSE T) ))) (DEFWRAPPER (MARGIN-REGION-MIXIN :MOUSE-BUTTONS) (IGNORE . BODY) `(*CATCH 'REGION-HANDLED-MOUSE (PROGN . ,BODY))) (DEFMETHOD (MARGIN-REGION-MIXIN :BEFORE :MOUSE-BUTTONS) (BD X Y) (COND ((AND CURRENT-REGION (BIT-TEST BD 3)) ;; Mouse in some region -- left or middle button ;; The right button is usually reserved for menus and the like so is not ;; intercepted here (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-BUTTONS X Y CURRENT-REGION (MOUSE-BUTTON-ENCODE BD)) (*THROW 'REGION-HANDLED-MOUSE T)))) (DEFMETHOD (MARGIN-REGION-MIXIN :MOUSE-ENTERS-REGION) ()) (DEFMETHOD (MARGIN-REGION-MIXIN :MOUSE-LEAVES-REGION) ()) (DECLARE-FLAVOR-INSTANCE-VARIABLES (MARGIN-REGION-MIXIN) (DEFUN MARGIN-REGION-AREA (REGION &AUX LEFT TOP RIGHT BOTTOM) (SETQ LEFT (MARGIN-REGION-LEFT REGION) TOP (MARGIN-REGION-TOP REGION) RIGHT (MARGIN-REGION-RIGHT REGION) BOTTOM (MARGIN-REGION-BOTTOM REGION)) (AND (< LEFT 0) (SETQ LEFT (+ WIDTH LEFT))) (AND (< TOP 0) (SETQ TOP (+ HEIGHT TOP))) (AND ( RIGHT 0) (SETQ RIGHT (+ WIDTH RIGHT))) (AND ( BOTTOM 0) (SETQ BOTTOM (+ HEIGHT BOTTOM))) (PROG () (RETURN LEFT TOP RIGHT BOTTOM)))) ;;; Special scrolling windows that tell when there is more above or below and scroll if ;;; you click there (DEFFLAVOR MARGIN-SCROLL-MIXIN () () (:INCLUDED-FLAVORS MARGIN-REGION-MIXIN BASIC-SCROLL-BAR) (:INIT-KEYWORDS :MARGIN-SCROLL-REGIONS) (:DOCUMENTATION :MIXIN "Shows if there is more above or below")) (DEFSTRUCT (MARGIN-SCROLL-REGION :LIST (:INCLUDE MARGIN-REGION) (:CONSTRUCTOR NIL)) MARGIN-SCROLL-REGION-EMPTY-MSG ;Message when nothing more to scroll MARGIN-SCROLL-REGION-MORE-MSG ;Other message MARGIN-SCROLL-REGION-MSG-FONT ;Font for that MARGIN-SCROLL-REGION-MORE-P ;Is there more to scroll to? ) (DEFMETHOD (MARGIN-SCROLL-MIXIN :BEFORE :INIT) (INIT-PLIST &AUX TOP-P FONT) (DOLIST (REGION (GET INIT-PLIST ':MARGIN-SCROLL-REGIONS)) (COND ((MEMQ REGION '(:TOP :BOTTOM)) (SETQ TOP-P (EQ REGION ':TOP) REGION (LIST 'MARGIN-SCROLL-REGION REGION 0 0 0 0 0 NIL NIL NIL NIL))) ((MEMQ (CAR REGION) '(:TOP :BOTTOM)) (SETQ TOP-P (EQ (CAR REGION) ':TOP) REGION (LIST 'MARGIN-SCROLL-REGION (CAR REGION) 0 0 0 0 0 (CADR REGION) (CADDR REGION) (CADDDR REGION) NIL))) (T (SETQ TOP-P (EQ (MARGIN-REGION-MARGIN REGION) ':TOP)))) (OR (MARGIN-SCROLL-REGION-EMPTY-MSG REGION) (SETF (MARGIN-SCROLL-REGION-EMPTY-MSG REGION) (IF TOP-P "Top" "Bottom"))) (OR (MARGIN-SCROLL-REGION-MORE-MSG REGION) (SETF (MARGIN-SCROLL-REGION-MORE-MSG REGION) (IF TOP-P "More above" "More below"))) (SETQ FONT (OR (MARGIN-SCROLL-REGION-MSG-FONT REGION) FONTS:TR10I)) (SETF (MARGIN-SCROLL-REGION-MSG-FONT REGION) (SETQ FONT (FUNCALL (SHEET-GET-SCREEN SELF) ':PARSE-FONT-DESCRIPTOR FONT))) (SETF (MARGIN-REGION-SIZE REGION) (+ 2 (FONT-CHAR-HEIGHT FONT))) (PUSH REGION REGION-LIST))) (DEFMETHOD (MARGIN-SCROLL-MIXIN :AFTER :NEW-SCROLL-POSITION) (&REST IGNORE) (DOLIST (REGION REGION-LIST) (AND (EQ (MARGIN-REGION-FUNCTION REGION) 'MARGIN-SCROLL-REGION) (MARGIN-SCROLL-REGION ':REFRESH REGION T)))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (MARGIN-SCROLL-MIXIN) (DEFSELECT MARGIN-SCROLL-REGION (:REFRESH (REGION &OPTIONAL OLD-VALID &AUX MORE-P LEFT TOP RIGHT BOTTOM MSG MSGL) (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM) (MARGIN-REGION-AREA REGION)) (SETQ MORE-P (FUNCALL-SELF (IF (EQ (MARGIN-REGION-MARGIN REGION) ':TOP) ':SCROLL-MORE-ABOVE ':SCROLL-MORE-BELOW))) (COND ((ZEROP (MARGIN-REGION-SIZE REGION))) ;Turned off ((OR (NOT OLD-VALID) (NEQ MORE-P (MARGIN-SCROLL-REGION-MORE-P REGION))) (SETF (MARGIN-SCROLL-REGION-MORE-P REGION) MORE-P) (AND OLD-VALID (PREPARE-SHEET (SELF) (%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ERASE-ALUF SELF))) (SETQ MSG (IF MORE-P (MARGIN-SCROLL-REGION-MORE-MSG REGION) (MARGIN-SCROLL-REGION-EMPTY-MSG REGION)) MSGL (SHEET-STRING-LENGTH SELF MSG 0 NIL NIL (MARGIN-SCROLL-REGION-MSG-FONT REGION))) (SHEET-STRING-OUT-EXPLICIT SELF MSG (MAX (// (- (+ RIGHT LEFT) MSGL) 2) LEFT) TOP RIGHT (MARGIN-SCROLL-REGION-MSG-FONT REGION) CHAR-ALUF)))) ((:MOUSE-ENTERS-REGION :MOUSE-LEAVES-REGION :MOUSE-MOVES) (&REST IGNORE)) (:MOUSE-BUTTONS (IGNORE IGNORE REGION IGNORE) (IF (MARGIN-SCROLL-REGION-MORE-P REGION) (LET ((FROM (MARGIN-REGION-MARGIN REGION))) (FUNCALL-SELF ':SCROLL-RELATIVE FROM (IF (EQ FROM ':TOP) ':BOTTOM ':TOP))) (BEEP))))) (DEFFLAVOR MARGIN-SCROLL-REGION-ON-AND-OFF-WITH-SCROLL-BAR-MIXIN () () (:INCLUDED-FLAVORS MARGIN-SCROLL-MIXIN BASIC-SCROLL-BAR) (:DOCUMENTATION :MIXIN "Makes the margin-scroll-regions disappear if the scroll-bar is set to NIL")) (DEFMETHOD (MARGIN-SCROLL-REGION-ON-AND-OFF-WITH-SCROLL-BAR-MIXIN :BEFORE :REDEFINE-MARGINS) (PLIST &AUX TEM) (COND ((SETQ TEM (GETL PLIST '(:SCROLL-BAR))) ;If changing the scroll-bar (SETQ TEM (CADR TEM)) (DOLIST (R REGION-LIST) (AND (EQ (MARGIN-REGION-FUNCTION R) 'MARGIN-SCROLL-REGION) (SETF (MARGIN-REGION-SIZE R) (IF (NULL TEM) 0 (+ 2 (FONT-CHAR-HEIGHT (MARGIN-SCROLL-REGION-MSG-FONT R))))))) (PUTPROP PLIST REGION-LIST ':REGION-LIST)))) ;Cause those changes to get parsed (DEFFLAVOR LINE-AREA-TEXT-SCROLL-WINDOW () () (:INCLUDED-FLAVORS MARGIN-REGION-MIXIN TEXT-SCROLL-WINDOW) (:INIT-KEYWORDS :LINE-AREA-WIDTH) (:DOCUMENTATION :MIXIN "Allows selection of a line from the left margin")) (DEFMETHOD (LINE-AREA-TEXT-SCROLL-WINDOW :BEFORE :INIT) (INIT-PLIST) (PUSH (LIST 'LINE-AREA-REGION ':LEFT (OR (GET INIT-PLIST ':LINE-AREA-WIDTH) 30) 0 0 0 0) REGION-LIST)) (DECLARE-FLAVOR-INSTANCE-VARIABLES (LINE-AREA-TEXT-SCROLL-WINDOW) (DEFSELECT LINE-AREA-REGION ((:REFRESH :MOUSE-MOVES) (&REST IGNORE)) (:MOUSE-ENTERS-REGION (IGNORE) (MOUSE-SET-BLINKER-DEFINITION ':CHARACTER 15 6 ':ON ':SET-CHARACTER #/)) (:MOUSE-LEAVES-REGION (IGNORE) (MOUSE-STANDARD-BLINKER)) (:MOUSE-BUTTONS (IGNORE Y IGNORE BD &AUX ITEM) (IF (AND ( Y (SHEET-INSIDE-TOP)) (LET ((LINE (+ TOP-ITEM (SHEET-LINE-NO NIL Y)))) (AND (< LINE (ARRAY-ACTIVE-LENGTH ITEMS)) (SETQ ITEM (AREF ITEMS LINE))))) (FUNCALL-SELF ':FORCE-KBD-INPUT `(:LINE-AREA ,ITEM ,SELF ,BD)) (BEEP))))) (DEFFLAVOR LINE-AREA-MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW () (BORDERS-MIXIN BASIC-SCROLL-BAR) (:INCLUDED-FLAVORS LINE-AREA-TEXT-SCROLL-WINDOW MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW) (:DOCUMENTATION :COMBINATION)) (DEFMETHOD (LINE-AREA-MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW :MOUSE-LEAVES-REGION) () (BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)) (DEFFLAVOR CURRENT-ITEM-MIXIN ((CURRENT-ITEM NIL)) () (:INCLUDED-FLAVORS LINE-AREA-TEXT-SCROLL-WINDOW) (:GETTABLE-INSTANCE-VARIABLES CURRENT-ITEM) (:DOCUMENTATION :MIXIN "Provides an arrow in the line-area pointing to current-item")) (DEFMETHOD (CURRENT-ITEM-MIXIN :SET-CURRENT-ITEM) (NEW-CURRENT-ITEM) (COND ((NEQ NEW-CURRENT-ITEM CURRENT-ITEM) (SETQ CURRENT-ITEM NEW-CURRENT-ITEM) (UPDATE-CURRENT-ITEM)))) (DEFMETHOD (CURRENT-ITEM-MIXIN :AFTER :REFRESH-MARGINS) UPDATE-CURRENT-ITEM) (DEFMETHOD (CURRENT-ITEM-MIXIN :AFTER :NEW-SCROLL-POSITION) UPDATE-CURRENT-ITEM) (DECLARE-FLAVOR-INSTANCE-VARIABLES (CURRENT-ITEM-MIXIN) (DEFUN UPDATE-CURRENT-ITEM (&REST IGNORE) (LET ((REGION (ASSQ 'LINE-AREA-REGION REGION-LIST)) (ITEM-NO (DOTIMES (I (ARRAY-ACTIVE-LENGTH ITEMS)) (AND (EQ (AREF ITEMS I) CURRENT-ITEM) (RETURN I))))) (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (MARGIN-REGION-AREA REGION) (MULTIPLE-VALUE-BIND (TOP-ITEM TOTAL-ITEMS ITEM-HEIGHT) (FUNCALL-SELF ':SCROLL-POSITION) (LET ((CURRENT-ITEM-Y (AND ITEM-NO ( ITEM-NO TOTAL-ITEMS) ;Can be 1 off end (+ (* (- ITEM-NO TOP-ITEM) ITEM-HEIGHT) (SHEET-INSIDE-TOP)))) (FONT (SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SELF)))) (SHEET-FORCE-ACCESS (SELF) (%DRAW-RECTANGLE (- RIGHT LEFT) (- BOTTOM TOP) LEFT TOP ERASE-ALUF SELF) (AND CURRENT-ITEM-Y ( CURRENT-ITEM-Y TOP) ( (+ CURRENT-ITEM-Y (FONT-CHAR-HEIGHT FONT)) BOTTOM) (%DRAW-CHAR FONT #/ (- RIGHT (FONT-CHAR-WIDTH FONT) 1) CURRENT-ITEM-Y CHAR-ALUF SELF))))))))) (DEFFLAVOR MARGIN-CHOICE-MIXIN ((MARGIN-CHOICES NIL)) () (:INITABLE-INSTANCE-VARIABLES MARGIN-CHOICES) (:INCLUDED-FLAVORS MARGIN-REGION-MIXIN) (:DOCUMENTATION :MIXIN "Provides a few boxes in the bottom margin")) (DEFSTRUCT (CHOICE-BOX :LIST (:CONSTRUCTOR NIL)) CHOICE-BOX-NAME CHOICE-BOX-STATE CHOICE-BOX-FUNCTION CHOICE-BOX-X1 CHOICE-BOX-X2) (DEFUN DRAW-CHOICE-BOX (SHEET X Y ON-P &OPTIONAL (SIZE (FONT-BLINKER-HEIGHT (SHEET-CURRENT-FONT SHEET))) &AUX (WIDTH (// SIZE 4))) (PREPARE-SHEET (SHEET) (LET ((CHAR-ALUF (SHEET-CHAR-ALUF SHEET)) (ERASE-ALUF (SHEET-ERASE-ALUF SHEET))) (%DRAW-RECTANGLE SIZE SIZE X Y CHAR-ALUF SHEET) (LET ((TEM (- SIZE (* WIDTH 2))) (X1 (+ X WIDTH)) (Y1 (+ Y WIDTH))) (%DRAW-RECTANGLE TEM TEM X1 Y1 ERASE-ALUF SHEET) (AND ON-P (LET ((X2 (+ X1 TEM)) (Y2 (+ Y1 TEM))) ;; This is a diagonal hexagon (%DRAW-TRIANGLE (1- X2) Y1 (1+ X1) Y2 X1 (1- Y2) CHAR-ALUF SHEET) (%DRAW-TRIANGLE (1- X2) Y1 X2 Y1 X2 (1+ Y1) CHAR-ALUF SHEET) (%DRAW-TRIANGLE (1- X2) Y1 X2 (1+ Y1) (1+ X1) Y2 CHAR-ALUF SHEET) (%DRAW-TRIANGLE (1+ X1) Y2 X1 Y2 X1 (1- Y2) CHAR-ALUF SHEET) ;; So is this (%DRAW-TRIANGLE (1+ X1) Y1 X2 (1- Y2) (1- X2) Y2 CHAR-ALUF SHEET) (%DRAW-TRIANGLE X2 (1- Y2) X2 Y2 (1- X2) Y2 CHAR-ALUF SHEET) (%DRAW-TRIANGLE (1- X2) Y2 X1 (1+ Y1) (1+ X1) Y1 CHAR-ALUF SHEET) (%DRAW-TRIANGLE X1 (1+ Y1) X1 Y1 (1+ X1) Y1 CHAR-ALUF SHEET) ))))) (PROG () (RETURN (+ X SIZE) Y))) (DEFMETHOD (MARGIN-CHOICE-MIXIN :BEFORE :INIT) (IGNORE) (PUSH (LIST 'MARGIN-CHOICE-REGION ':BOTTOM (IF (NULL MARGIN-CHOICES) 0 (1+ (SHEET-LINE-HEIGHT SUPERIOR))) 0 0 0 0) REGION-LIST)) (DEFMETHOD (MARGIN-CHOICE-MIXIN :SET-MARGIN-CHOICES) (NEW-MARGIN-CHOICES) (SETQ MARGIN-CHOICES NEW-MARGIN-CHOICES) (LET ((REGION (ASSQ 'MARGIN-CHOICE-REGION REGION-LIST)) (SIZE (IF (NULL MARGIN-CHOICES) 0 (1+ (SHEET-LINE-HEIGHT SUPERIOR))))) (IF (= (MARGIN-REGION-SIZE REGION) SIZE) (SHEET-FORCE-ACCESS (SELF T) (FUNCALL (MARGIN-REGION-FUNCTION REGION) ':REFRESH REGION T)) (SETF (MARGIN-REGION-SIZE REGION) SIZE) (FUNCALL-SELF ':REDEFINE-MARGINS (LIST NIL ':REGION-LIST REGION-LIST))))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (MARGIN-CHOICE-MIXIN) (DEFSELECT MARGIN-CHOICE-REGION (:REFRESH (REGION &OPTIONAL ERASE-P &AUX LEFT TOP RIGHT BOTTOM) (COND ((NOT (ZEROP (MARGIN-REGION-SIZE REGION))) (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM) (MARGIN-REGION-AREA REGION)) (AND ERASE-P (%DRAW-RECTANGLE (- RIGHT LEFT) (- TOP BOTTOM) LEFT TOP ERASE-ALUF SELF)) (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT TOP CHAR-ALUF SELF) (SETQ TOP (+ TOP 2)) (DO ((CHOICES MARGIN-CHOICES (CDR CHOICES)) (SHARE (AND MARGIN-CHOICES (// (- RIGHT LEFT) (LENGTH MARGIN-CHOICES)))) (X LEFT (+ X SHARE)) (FONT (AREF FONT-MAP 0)) (CHOICE) (X0)) ((NULL CHOICES)) (SETQ CHOICE (CAR CHOICES)) (SETQ X0 (+ (SHEET-STRING-OUT-EXPLICIT SELF (CHOICE-BOX-NAME CHOICE) X TOP RIGHT FONT CHAR-ALUF) CHAR-WIDTH)) (SETF (CHOICE-BOX-X1 CHOICE) X0) (SETF (CHOICE-BOX-X2 CHOICE) (DRAW-CHOICE-BOX SELF X0 TOP (CHOICE-BOX-STATE CHOICE) (FONT-BLINKER-HEIGHT FONT))))))) (:MOUSE-MOVES (&REST IGNORE)) ((:MOUSE-ENTERS-REGION :MOUSE-LEAVES-REGION) (IGNORE)) (:MOUSE-BUTTONS (X Y REGION IGNORE) (HANDLE-CHOICE-BUTTON MARGIN-CHOICES X Y REGION)))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (MARGIN-CHOICE-MIXIN) (DEFUN HANDLE-CHOICE-BUTTON (BOXES X Y THING &AUX CHOSEN) (IF (SETQ CHOSEN (DOLIST (BOX BOXES) (AND ( X (CHOICE-BOX-X1 BOX)) (< X (CHOICE-BOX-X2 BOX)) (RETURN BOX)))) (PROCESS-RUN-FUNCTION "Choice" SELF ':FUNCALL-INSIDE-YOURSELF (CHOICE-BOX-FUNCTION CHOSEN) CHOSEN THING Y) (BEEP)))) (DEFFLAVOR MULTIPLE-CHOICE () (BORDERS-MIXIN TOP-BOX-LABEL-MIXIN BASIC-MULTIPLE-CHOICE WINDOW)) (DEFFLAVOR BASIC-MULTIPLE-CHOICE ((ITEM-NAME NIL) (CHOICE-TYPES NIL) (MARGIN-CHOICES DEFAULT-FINISHING-CHOICES) (CHOICE-VALUE)) (SCROLL-STUFF-ON-OFF-MIXIN MARGIN-CHOICE-MIXIN DISPLAYED-ITEMS-TEXT-SCROLL-WINDOW) (:SETTABLE-INSTANCE-VARIABLES ITEM-NAME CHOICE-TYPES) (:INIT-KEYWORDS :CHOICES) (:DEFAULT-INIT-PLIST :BLINKER-P NIL :MORE-P NIL :SCROLL-BAR 2)) (DEFSTRUCT (CHOICE-TYPE :LIST (:CONSTRUCTOR NIL)) CHOICE-TYPE-KEYWORD CHOICE-TYPE-NAME CHOICE-TYPE-ON-POSITIVE-IMPLICATIONS CHOICE-TYPE-ON-NEGATIVE-IMPLICATIONS CHOICE-TYPE-OFF-POSITIVE-IMPLICATIONS CHOICE-TYPE-OFF-NEGATIVE-IMPLICATIONS) (DEFSTRUCT (CHOICE-ITEM :LIST (:CONSTRUCTOR NIL)) CHOICE-ITEM-ITEM CHOICE-ITEM-NAME CHOICE-ITEM-BOXES) (DEFVAR DEFAULT-FINISHING-CHOICES '(("Do It" NIL MULTIPLE-CHOICE-DONE NIL NIL) ("Abort" NIL MULTIPLE-CHOICE-ABORT NIL NIL))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :AFTER :INIT) (INIT-PLIST &AUX CHOICES) (AND (SETQ CHOICES (GET INIT-PLIST ':CHOICES)) (FUNCALL-SELF ':SET-CHOICES CHOICES))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :ADJUSTABLE-SIZE-P) () T) ;;; This method is a kludge to make SCROLL-STUFF-ON-OFF-MIXIN work. What ;;; is the right thing here? (DEFMETHOD (BASIC-MULTIPLE-CHOICE :SCROLL-BAR-P) () SCROLL-BAR-ALWAYS-DISPLAYED) ;I don't think the user is supposed to call this directly; use :SETUP (DEFMETHOD (BASIC-MULTIPLE-CHOICE :SET-CHOICES) (NEW-CHOICES &AUX NAME-LENGTH CHOICE-BOXES MAX-X NITEMS NEW-LABEL) ;; Substitute the name of all types where needed (DECLARE (RETURN-LIST INSIDE-WIDTH INSIDE-HEIGHT NEW-LABEL)) (LET ((ALLTYPES (MAPCAR 'CAR CHOICE-TYPES))) (DOLIST (CHOICE-TYPE CHOICE-TYPES) (AND (EQ (CHOICE-TYPE-ON-POSITIVE-IMPLICATIONS CHOICE-TYPE) T) (SETF (CHOICE-TYPE-ON-POSITIVE-IMPLICATIONS CHOICE-TYPE) ALLTYPES)) (AND (EQ (CHOICE-TYPE-ON-NEGATIVE-IMPLICATIONS CHOICE-TYPE) T) (SETF (CHOICE-TYPE-ON-NEGATIVE-IMPLICATIONS CHOICE-TYPE) ALLTYPES)) (AND (EQ (CHOICE-TYPE-OFF-POSITIVE-IMPLICATIONS CHOICE-TYPE) T) (SETF (CHOICE-TYPE-OFF-POSITIVE-IMPLICATIONS CHOICE-TYPE) ALLTYPES)) (AND (EQ (CHOICE-TYPE-OFF-NEGATIVE-IMPLICATIONS CHOICE-TYPE) T) (SETF (CHOICE-TYPE-OFF-NEGATIVE-IMPLICATIONS CHOICE-TYPE) ALLTYPES)))) ;; Now compute the length of the name needed (SETQ NITEMS 0 NAME-LENGTH (IF ITEM-NAME (+ CHAR-WIDTH (SHEET-STRING-LENGTH SELF ITEM-NAME)) 0)) (DOLIST (CHOICE NEW-CHOICES) (SETQ NITEMS (1+ NITEMS)) (LET ((NAME (CHOICE-ITEM-NAME CHOICE))) (AND NAME (SETQ NAME-LENGTH (MAX NAME-LENGTH (+ (SHEET-STRING-LENGTH SELF NAME) CHAR-WIDTH)))))) ;; Make prototype boxes (DO ((X NAME-LENGTH (+ X TYPE-WIDTH)) (TYPES CHOICE-TYPES (CDR TYPES)) (TYPE) (TYPE-WIDTH)) ((NULL TYPES) (SETQ MAX-X (+ X CHAR-WIDTH))) (SETQ TYPE (CAR TYPES) TYPE-WIDTH (+ (SHEET-STRING-LENGTH SELF (CHOICE-TYPE-NAME TYPE)) CHAR-WIDTH)) (PUSH (LIST (CHOICE-TYPE-KEYWORD TYPE) NIL 'MULTIPLE-CHOICE-CHOOSE (+ X (// TYPE-WIDTH 2)) 177777) CHOICE-BOXES)) ;; Compute the new label (SETQ NEW-LABEL (MAKE-ARRAY NIL 'ART-STRING (// MAX-X CHAR-WIDTH) NIL '(0))) (AND ITEM-NAME (SETQ NEW-LABEL (STRING-NCONC NEW-LABEL ITEM-NAME))) (DO ((I (STRING-LENGTH NEW-LABEL) (1+ I)) (LIM (// NAME-LENGTH CHAR-WIDTH))) (( I LIM) (STORE-ARRAY-LEADER I NEW-LABEL 0)) (ASET #\SP NEW-LABEL I)) (DOLIST (CHOICE-TYPE CHOICE-TYPES) (SETQ NEW-LABEL (STRING-NCONC NEW-LABEL #\SP (CHOICE-TYPE-NAME CHOICE-TYPE)))) ;; Now fill in the items (AND (> NITEMS (ARRAY-LENGTH ITEMS)) (ADJUST-ARRAY-SIZE ITEMS NITEMS)) (STORE-ARRAY-LEADER NITEMS ITEMS 0) (DO ((CHOICES NEW-CHOICES (CDR CHOICES)) (I 0 (1+ I)) (CHOICE) (CHOICE-ITEM)) ((NULL CHOICES)) (SETQ CHOICE (CAR CHOICES) CHOICE-ITEM (LIST (CHOICE-ITEM-ITEM CHOICE) (CHOICE-ITEM-NAME CHOICE) NIL)) (DO ((BOXES (CHOICE-ITEM-BOXES CHOICE) (CDR BOXES)) (BOX) (TYPE) (INITIAL-STATE)) ((NULL BOXES)) (SETQ BOX (CAR BOXES)) (IF (SYMBOLP BOX) (SETQ TYPE BOX INITIAL-STATE NIL) (SETQ TYPE (CHOICE-BOX-NAME BOX) INITIAL-STATE (CHOICE-BOX-STATE BOX))) (SETQ BOX (COPYLIST (ASSQ TYPE CHOICE-BOXES))) (SETF (CHOICE-BOX-STATE BOX) INITIAL-STATE) (PUSH BOX (CHOICE-ITEM-BOXES CHOICE-ITEM))) (ASET CHOICE-ITEM ITEMS I)) ;; Now we return some reasonable sizes (PROG () (RETURN MAX-X (* NITEMS LINE-HEIGHT) NEW-LABEL))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :SETUP) (NEW-ITEM-NAME NEW-CHOICE-TYPES NEW-FINISHING-CHOICES NEW-CHOICES &OPTIONAL (MAXLINES 20.) &AUX WID HGT LBL) (SETQ ITEM-NAME NEW-ITEM-NAME CHOICE-TYPES NEW-CHOICE-TYPES) (MULTIPLE-VALUE (WID HGT LBL) (FUNCALL-SELF ':SET-CHOICES NEW-CHOICES)) (SETQ TOP-ITEM 0) ;Un-scroll (FUNCALL-SELF ':SET-LABEL LBL) (SETQ SCROLL-BAR-ALWAYS-DISPLAYED (< (* MAXLINES LINE-HEIGHT) HGT)) (FUNCALL-SELF ':SET-INSIDE-SIZE WID (MIN (* MAXLINES LINE-HEIGHT) HGT)) (FUNCALL-SELF ':DECIDE-IF-SCROLLING-NECESSARY) (FUNCALL-SELF ':SET-MARGIN-CHOICES NEW-FINISHING-CHOICES) (SHEET-FORCE-ACCESS (SELF T) (FUNCALL-SELF ':REFRESH))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :PRINT-ITEM) (ITEM LINE-NO ITEM-NO) ITEM-NO ;Not used (SHEET-STRING-OUT SELF (CHOICE-ITEM-NAME ITEM)) (DOLIST (BOX (CHOICE-ITEM-BOXES ITEM)) (SETF (CHOICE-BOX-X2 BOX) (DRAW-CHOICE-BOX SELF (CHOICE-BOX-X1 BOX) CURSOR-Y (CHOICE-BOX-STATE BOX)))) (ASET ITEM DISPLAYED-ITEMS LINE-NO)) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :MOUSE-BUTTONS) (BD X Y &AUX LINE-NO ITEM) (SETQ LINE-NO (SHEET-LINE-NO NIL Y)) (AND ( Y (SHEET-INSIDE-TOP)) (< Y (+ (SHEET-INSIDE-TOP) (* (SHEET-NUMBER-OF-INSIDE-LINES) LINE-HEIGHT))) (SETQ ITEM (AREF DISPLAYED-ITEMS LINE-NO))) (COND ((= (SETQ BD (MOUSE-BUTTON-ENCODE BD)) #\MOUSE-3-2) (MOUSE-CALL-SYSTEM-MENU)) ((AND (= BD #\MOUSE-1-1) ITEM) (HANDLE-CHOICE-BUTTON (CHOICE-ITEM-BOXES ITEM) X Y ITEM)) (T (BEEP)))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MULTIPLE-CHOICE) (DEFUN MULTIPLE-CHOICE-CHOOSE (BOX ITEM Y) (SETQ Y (+ (SHEET-INSIDE-TOP) (* (SHEET-LINE-NO NIL Y) LINE-HEIGHT))) (FUNCALL-SELF ':SET-ITEM-BOX-STATE ITEM Y (CHOICE-BOX-NAME BOX) (NOT (CHOICE-BOX-STATE BOX))))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :SET-ITEM-BOX-STATE) (ITEM Y KEYWORD NEW-STATE &AUX BOX TYP) (COND ((AND (SETQ BOX (ASSQ KEYWORD (CHOICE-ITEM-BOXES ITEM))) (NEQ NEW-STATE (CHOICE-BOX-STATE BOX))) (SETF (CHOICE-BOX-STATE BOX) NEW-STATE) (AND Y (DRAW-CHOICE-BOX SELF (CHOICE-BOX-X1 BOX) Y NEW-STATE)) (SETQ TYP (ASSQ KEYWORD CHOICE-TYPES)) (DOLIST (POS (IF NEW-STATE (CHOICE-TYPE-ON-POSITIVE-IMPLICATIONS TYP) (CHOICE-TYPE-OFF-POSITIVE-IMPLICATIONS TYP))) (OR (EQ POS KEYWORD) (FUNCALL-SELF ':SET-ITEM-BOX-STATE ITEM Y POS T))) (DOLIST (NEG (IF NEW-STATE (CHOICE-TYPE-ON-NEGATIVE-IMPLICATIONS TYP) (CHOICE-TYPE-OFF-NEGATIVE-IMPLICATIONS TYP))) (OR (EQ NEG KEYWORD) (FUNCALL-SELF ':SET-ITEM-BOX-STATE ITEM Y NEG NIL)))))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :CHOOSE) (&OPTIONAL (NEAR-MODE '(:MOUSE)) &AUX OLD-STATUS) (SETQ CHOICE-VALUE NIL) (SETQ OLD-STATUS (FUNCALL-SELF ':STATUS)) (UNWIND-PROTECT (PROGN (EXPOSE-WINDOW-NEAR SELF NEAR-MODE) (PROCESS-WAIT "Choose" #'CAR (LOCATE-IN-INSTANCE SELF 'CHOICE-VALUE))) (FUNCALL-SELF ':SET-STATUS OLD-STATUS)) (AND (NEQ CHOICE-VALUE 'ABORT) CHOICE-VALUE)) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MULTIPLE-CHOICE) (DEFUN MULTIPLE-CHOICE-DONE (&REST IGNORE) (SETQ CHOICE-VALUE (DO ((I 0 (1+ I)) (LIM (ARRAY-ACTIVE-LENGTH ITEMS)) (ITEM) (RET NIL)) (( I LIM) (NREVERSE RET)) (SETQ ITEM (AREF ITEMS I)) (PUSH (CONS (CHOICE-ITEM-ITEM ITEM) (DO ((BOXES (CHOICE-ITEM-BOXES ITEM) (CDR BOXES)) (BOX) (RET NIL)) ((NULL BOXES) (NREVERSE RET)) (AND (CHOICE-BOX-STATE (SETQ BOX (CAR BOXES))) (PUSH (CHOICE-BOX-NAME BOX) RET)))) RET))))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-MULTIPLE-CHOICE) (DEFUN MULTIPLE-CHOICE-ABORT (&REST IGNORE) (SETQ CHOICE-VALUE 'ABORT))) (DEFFLAVOR TEMPORARY-MULTIPLE-CHOICE-WINDOW () (TEMPORARY-WINDOW-MIXIN MULTIPLE-CHOICE)) (DEFMETHOD (TEMPORARY-MULTIPLE-CHOICE-WINDOW :AFTER :DEEXPOSE) (&REST IGNORE) (OR CHOICE-VALUE (SETQ CHOICE-VALUE 'ABORT))) (COMPILE-FLAVOR-METHODS TEMPORARY-MULTIPLE-CHOICE-WINDOW) (DEFRESOURCE TEMPORARY-MULTIPLE-CHOICE-WINDOW (WINDOW-CREATE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW)) (SYSTEM-WINDOW-ADD-TYPE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW #'(LAMBDA (SUPERIOR) (TV:WINDOW-CREATE 'TEMPORARY-MULTIPLE-CHOICE-WINDOW ':SUPERIOR SUPERIOR)) T ':DEACTIVATED) (DEFUN MULTIPLE-CHOOSE (ITEM-NAME ITEM-LIST KEYWORD-ALIST &OPTIONAL (NEAR-MODE '(:MOUSE))) "ITEM-NAME is a string of the name of the type of item, e.g. /"Buffer/". ITEM-LIST is an alist, (ITEM NAME CHOICES). ITEM is the item itself, NAME a string of its name, and CHOICES a list of possible keywords, either KEYWORD or (KEYWORD DEFAULT), where if DEFAULT is non-NIL the KEYWORD is initially on. KEYWORD-ALIST is a list of the possible keywords, (KEYWORD NAME . IMPLICATIONS). KEYWORD is a symbol, the same as in ITEM-LIST's CHOICES. NAME is a string of its name. IMPLICATIONS is a list of on-positive, on-negative, off-positive, and off-negative implications for when the keyword is selected, each one either a list of (other) keywords or T for all other keywords. The default for IMPLICATIONS is (NIL T NIL NIL)." (DO L KEYWORD-ALIST (CDR L) (NULL L) (AND (< (LENGTH (CAR L)) 3) (SETF (CAR L) (NCONC (CAR L) (LIST NIL T NIL NIL))))) (LET ((WINDOW (GET-A-SYSTEM-WINDOW 'TEMPORARY-MULTIPLE-CHOICE-WINDOW))) (FUNCALL WINDOW ':SETUP ITEM-NAME KEYWORD-ALIST DEFAULT-FINISHING-CHOICES ITEM-LIST) (UNWIND-PROTECT (FUNCALL WINDOW ':CHOOSE NEAR-MODE) (FUNCALL WINDOW ':DEACTIVATE)))) ;Choose-variable-values stuff. ;Basic idea is that the program has a list of special variables, and ;the user is asked to confirm and possibly modify their values. Values ;can be either general expressions, or a choice from a list (menu like). ; ;The printing of the display is not actually done in the user's stack group, ;but it acts as if it were. The reading of new values is done in the user's stack group. ;Thus you can bind BASE, PRINLEVEL, READTABLE, etc. ;The user can point at a displayed value and click the mouse, to modify it. ;The new value is input from the keyboard; over-rubbing-out restores the ;old value. For values chosen from a list, clicking the mouse selects ;the value pointed-to. ;VARIABLES is a list of elements, each describing one line of the display ; These become text-scroll items. Kinds of elements allowed are: ; string - just displayed ; special-variable - value is printed, and if the user clicks on it ; with the mouse a new value is read. ; Otherwise a list whose car is the variable, optionally ; followed by a string to use as label instead of the var, or nil for ; no label, followed by a keyword for the type of variable, followed by ; args to the keyword. The default keyword is :SEXP ; Keywords are: ; :SEXP - value of variable is a Lisp S-expression, printed with PRIN1, ; read in with READ ; :PRINC - same as :SEXP but print it with PRINC instead of PRIN1 ; :STRING - print with PRINC, read with READLINE ; :NUMBER - print with PRIN1, read with READ but must be a number ; :CHOOSE values-list print-function - value of variable is one of the ; elements of values-list (EQUAL testing is used). Printed ; by printing all the value choices, with the current one in ; boldface, read in by the user pointing and clicking. ; print-function is optional and defaults to PRINC ; :ASSOC values-list print-function - like :CHOOSE, but car of ; values-list element is displayed, cdr is variable-value ; :BOOLEAN - value is T or NIL, but displays as Yes or No ; :CHARACTER - value is a character, prints with ~:@C, reads as one keystroke ; :CHARACTER-OR-NIL - same but can also be NIL, displays as "none", inputs as CLEAR ; Should there also be ones which are constrained to be lists of chars? ; Keywords automatically forced into the keyword package? ; Should there be a provision for documentation of a variable, and a way ; to make that print somewhere? (As in ZMACS Alter Options) ; ; The :DECODE-VARIABLE-TYPE message to the window is used to look at the ; keyword and options and return information about how to print and change ; the variable's value. The argument to this message is ; the tail of a VARIABLES element starting with the keyword, and it ; returns 5 values: ; The print function (args are object and stream). ; The read function, or NIL if it works by pointing (arg is stream). ; Crockishness: usually this is called inside a rubout-handler, with the ; feature supplied that over-rubout causes the variable to left at its old ; value. But with a list here the car of the list is the function which ; just gets called directly. ; The choices to be printed (NIL if just print current value). ; The function which translates a value to its printed form (NIL for identity). ; The function which translates a value to the form ; which goes in the variable (NIL for identity). ; The last two only apply when there are choices. ; The default handler looks up the keyword in TV:CHOOSE-VARIABLE-VALUES-KEYWORDS, ; which is (kwd . function-to-call) or (kwd print-func read-func choices ptransfn vtransfn) ;FUNCTION can be NIL or a function called on window, special-variable, old-value, new-value ; when a variable is changed. It may make other changes. Returns T if it did ; its own redisplay (typically by sending a :SET-VARIABLES), ; NIL if that variable's new value needs to be displayed. ; Typically this function implements constraints among the variable ; values and sends a refresh message and returns T. ; ;STACK-GROUP is the stack-group in which the variables may be evaluated. ;Height of window is chosen automatically upon creation if not specified ; in the init-plist. Also is automatically adjustable if you send ; a :SET-VARIABLES. ;The following messages can come back through the io-buffer: ; (:CHOICE-BOX window box) ; (:VARIABLE-CHOICE window VARIABLES-element value line-no) ;Font-map: ; 0 string ; 1 name ; 2 value ; 3 unselected-choice ; 4 selected-choice (DEFFLAVOR BASIC-CHOOSE-VARIABLE-VALUES ((FUNCTION NIL) STACK-GROUP (LINE-OVERFLOW-ALLOWED T) (RECURSION NIL)) (MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW) (:INCLUDED-FLAVORS ANY-TYI-MIXIN) :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES (:INIT-KEYWORDS :VARIABLES :NAME-FONT :VALUE-FONT :STRING-FONT :UNSELECTED-CHOICE-FONT :SELECTED-CHOICE-FONT) (:DEFAULT-INIT-PLIST :SAVE-BITS NIL :CHARACTER-WIDTH 50. :BLINKER-P '(:VISIBILITY NIL) :BLINKER-DESELECTED-VISIBILITY NIL :NAME-FONT FONTS:CPTFONT :VALUE-FONT FONTS:CPTFONT :STRING-FONT FONTS:CPTFONT :UNSELECTED-CHOICE-FONT FONTS:HL10 :SELECTED-CHOICE-FONT FONTS:HL10B)) (DEFFLAVOR CHOOSE-VARIABLE-VALUES-WINDOW () (BASIC-CHOOSE-VARIABLE-VALUES BORDERS-MIXIN TOP-BOX-LABEL-MIXIN SCROLL-STUFF-ON-OFF-MIXIN MARGIN-CHOICE-MIXIN ANY-TYI-MIXIN WINDOW) (:DEFAULT-INIT-PLIST :MARGIN-CHOICES '(("Exit" NIL CHOOSE-VARIABLE-VALUES-CHOICE-BOX-HANDLER NIL NIL)))) (DEFUN CHOOSE-VARIABLE-VALUES-CHOICE-BOX-HANDLER (BOX REGION YPOS) REGION YPOS ;ignored (FUNCALL-SELF ':FORCE-KBD-INPUT `(:CHOICE-BOX ,SELF ,BOX))) ;;; I don't know if this function's list of options is up to date... (DEFUN HEIGHT-SPECIFIED-IN-INIT-PLIST (PLIST) "Returns T if the PLIST contains anything that specifies the window height" (OR (GETL PLIST '(:EDGES-FROM :EDGES :HEIGHT :CHARACTER-HEIGHT)) (AND (GETL PLIST '(:TOP :Y)) (GET PLIST ':BOTTOM)))) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :BEFORE :INIT) (PLIST) ;; Default the height according to the number of variables, unless ;; it was specified explicitly. (OR (HEIGHT-SPECIFIED-IN-INIT-PLIST PLIST) (PUTPROP PLIST (MAX (MIN (LENGTH (GET PLIST ':VARIABLES)) 25.) 1) ':CHARACTER-HEIGHT)) ;; Set up font map according to fonts specified by name (SETQ FONT-MAP (LIST (GET PLIST ':STRING-FONT) (GET PLIST ':NAME-FONT) (GET PLIST ':VALUE-FONT) (GET PLIST ':UNSELECTED-CHOICE-FONT) (GET PLIST ':SELECTED-CHOICE-FONT)))) ;;; This sets the variables and adjusts the scrolling but never changes the height ;;; which was set either by the before-init method or by the creator. ;;; Except that the outside height may be changed to preserve what the creator ;;; is thought to have specified as the inside height. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :AFTER :INIT) (PLIST &AUX ELEMS) (AND (SETQ ELEMS (GET PLIST ':VARIABLES)) (FUNCALL-SELF ':SET-VARIABLES ELEMS T))) ;;; Default is that size adjusts according to the number of items present, ;;; provided that the window is de-exposed. This is because if it was ;;; exposed the user would see it spastically redisplay several times. ;;; Also it probably looks very bad for it to change size while it's exposed. ;;; You are welcome to redefine this method. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :ADJUSTABLE-SIZE-P) () (NOT EXPOSED-P)) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :SET-VARIABLES) (ELEMS &OPTIONAL NO-SET-HEIGHT &AUX (NELEM (LENGTH ELEMS))) (SETQ TOP-ITEM 0) ;Unscroll (AND (< (ARRAY-LENGTH ITEMS) NELEM) (SETQ ITEMS (ADJUST-ARRAY-SIZE ITEMS NELEM))) (STORE-ARRAY-LEADER 0 ITEMS 0) (DOLIST (ELEM ELEMS) (ARRAY-PUSH ITEMS ELEM)) (LET ((DESIRED-HEIGHT (* (MIN 25. NELEM) LINE-HEIGHT))) (AND ( (SHEET-INSIDE-HEIGHT) DESIRED-HEIGHT) (NOT NO-SET-HEIGHT) (FUNCALL-SELF ':ADJUSTABLE-SIZE-P) ( (+ DESIRED-HEIGHT TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE) (SHEET-INSIDE-HEIGHT SUPERIOR)) (FUNCALL-SELF ':SET-INSIDE-SIZE (SHEET-INSIDE-WIDTH) DESIRED-HEIGHT)) (FUNCALL-SELF ':DECIDE-IF-SCROLLING-NECESSARY) (FUNCALL-SELF ':SET-ITEMS ITEMS))) ;Redisplay (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :SETUP) (ELEMS NEW-LABEL NEW-FUNCTION NEW-MARGIN-CHOICES) (SETQ FUNCTION NEW-FUNCTION) (SETQ STACK-GROUP %CURRENT-STACK-GROUP) (SETF (IO-BUFFER-LAST-OUTPUT-PROCESS IO-BUFFER) CURRENT-PROCESS) ;Kludge (FUNCALL-SELF ':SET-LABEL NEW-LABEL) (FUNCALL-SELF ':SET-MARGIN-CHOICES NEW-MARGIN-CHOICES) (FUNCALL-SELF ':SET-VARIABLES ELEMS)) (DEFVAR CHOOSE-VARIABLE-VALUES-KEYWORDS '( (:SEXP PRIN1 READ) (:PRINC PRINC READ) (:STRING PRINC READLINE) (:NUMBER PRIN1 READ-NUMBER) (:CHOOSE . CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE) (:ASSOC . CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE) (:BOOLEAN CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT NIL (T NIL)) (:CHARACTER CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (TYI)) (:CHARACTER-OR-NIL CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT (CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-READ)) )) (DEFUN CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE (KWD-AND-ARGS) (PROG () (RETURN (OR (THIRD KWD-AND-ARGS) 'PRINC) NIL (SECOND KWD-AND-ARGS) (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CAR) (AND (EQ (FIRST KWD-AND-ARGS) ':ASSOC) 'CDR)))) (DEFUN CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT (VALUE STREAM) (FUNCALL STREAM ':STRING-OUT (IF VALUE "Yes" "No"))) (DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (VALUE STREAM) (FORMAT STREAM "~:@C" VALUE)) (DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT (VALUE STREAM) (FORMAT STREAM (IF VALUE "~:@C" "none") VALUE)) (DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-READ (STREAM &AUX CH) (IF (= (SETQ CH (FUNCALL STREAM ':TYI)) #\CLEAR) NIL (FUNCALL STREAM ':UNTYI CH) (TYI STREAM))) (DEFUN READ-NUMBER (STREAM) (LET ((VAL (READ STREAM))) (OR (NUMBERP VAL) (FERROR NIL "A number is required")) VAL)) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :DECODE-VARIABLE-TYPE) (KWD-AND-ARGS &AUX TEM) (SETQ TEM (OR (ASSQ (CAR KWD-AND-ARGS) CHOOSE-VARIABLE-VALUES-KEYWORDS) (FERROR NIL "~S bad keyword in a CHOOSE-VARIABLE-VALUES-WINDOW" (CAR KWD-AND-ARGS)))) (IF (ATOM (CDR TEM)) (FUNCALL (CDR TEM) KWD-AND-ARGS) (PROG () (RETURN-LIST (CDR TEM))))) ;So lines can wrap around when reading (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :END-OF-LINE-EXCEPTION) () (IF LINE-OVERFLOW-ALLOWED (SHEET-END-OF-LINE-EXCEPTION-METHOD NIL) ;<-AS (*THROW 'LINE-OVERFLOW T))) ;;; Make printing work in environment of owning stack group (DEFWRAPPER (BASIC-CHOOSE-VARIABLE-VALUES :REDISPLAY) (IGNORE . BODY) `(LET ((PACKAGE (SYMEVAL-IN-STACK-GROUP 'PACKAGE STACK-GROUP)) (BASE (SYMEVAL-IN-STACK-GROUP 'BASE STACK-GROUP)) (*NOPOINT (SYMEVAL-IN-STACK-GROUP '*NOPOINT STACK-GROUP)) (PRINLEVEL (SYMEVAL-IN-STACK-GROUP 'PRINLEVEL STACK-GROUP)) (PRINLENGTH (SYMEVAL-IN-STACK-GROUP 'PRINLENGTH STACK-GROUP)) (READTABLE (SYMEVAL-IN-STACK-GROUP 'READTABLE STACK-GROUP))) (BIND (LOCATE-IN-INSTANCE SELF 'LINE-OVERFLOW-ALLOWED) NIL) . ,BODY)) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :PRINT-ITEM) (ITEM LINE-NO ITEM-NO &AUX VAR VAL STR FONTNO CHOICES PF RF K&A GPVF GVVF PVAL) LINE-NO ITEM-NO ;ignored ;; Parse ITEM into label string, font to print that in, variable, and keyword-&-arguments (COND ((STRINGP ITEM) (SETQ STR ITEM FONTNO 0)) ((SYMBOLP ITEM) (SETQ VAR ITEM STR (GET-PNAME VAR) FONTNO 1)) (T (SETQ VAR (CAR ITEM) STR (IF (OR (STRINGP (CADR ITEM)) (NULL (CADR ITEM))) (CAR (SETQ ITEM (CDR ITEM))) (GET-PNAME VAR)) FONTNO 1 K&A (CDR ITEM)))) ;; If any label string, print it and a colon (COND (STR (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO)) (SHEET-STRING-OUT SELF STR) (SHEET-STRING-OUT SELF ": "))) ;; If any variable, get its value and decide how to print it (COND (VAR (SETQ VAL (SYMEVAL-IN-STACK-GROUP VAR STACK-GROUP)) (MULTIPLE-VALUE (PF RF CHOICES GPVF GVVF) (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR K&A '(:SEXP)))) (COND ((NOT CHOICES) (SHEET-SET-FONT SELF (AREF FONT-MAP 2)) (FUNCALL-SELF ':ITEM VAL ':VARIABLE-CHOICE PF)) (T (DOLIST (CHOICE CHOICES) (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE) CHOICE (IF GVVF (FUNCALL GVVF CHOICE) CHOICE)) (SHEET-SET-FONT SELF (AREF FONT-MAP (IF (EQUAL CHOICE VAL) 4 3))) (FUNCALL-SELF ':ITEM PVAL ':VARIABLE-CHOICE PF) (SHEET-SPACE SELF))))))) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :MOUSE-BUTTONS) (BD X Y &AUX VALUE TYPE LINE-NO) (MULTIPLE-VALUE (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y)) (COND ((BIT-TEST 4 BD) ;Mouse right (MOUSE-CALL-SYSTEM-MENU)) ((AND (BIT-TEST 1 BD) TYPE) ;Mouse left (SETQ LINE-NO (// (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT)) (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST TYPE SELF (AREF ITEMS (+ TOP-ITEM LINE-NO)) VALUE LINE-NO))) (T (BEEP)))) ;Called when a :VARIABLE-CHOICE message comes back through the io-buffer ;This is not a message, so that instance-variables won't be bound in it ;This is assumed to be called in the relevant stack group and binding environment (DEFUN CHOOSE-VARIABLE-VALUES-CHOICE (WINDOW ITEM CHOICE LINE-NO &AUX FCN STR VAR OLDVAL NEWVAL NO-CHANGE K&A PF RF GPVF GVVF CHOICES REDIS) ;; Parse ITEM into label string, variable, and keyword-&-arguments (COND ((STRINGP ITEM) (SETQ STR ITEM)) ;Can't happen ((SYMBOLP ITEM) (SETQ VAR ITEM STR (GET-PNAME VAR))) (T (SETQ VAR (CAR ITEM) STR (IF (OR (STRINGP (CADR ITEM)) (NULL (CADR ITEM))) (CAR (SETQ ITEM (CDR ITEM))) (GET-PNAME VAR)) K&A (CDR ITEM)))) (MULTIPLE-VALUE (PF RF CHOICES GPVF GVVF) (FUNCALL WINDOW ':DECODE-VARIABLE-TYPE (OR K&A '(:SEXP)))) (COND ((NOT (NULL RF)) ;Not "menu" case (SHEET-SET-FONT WINDOW (AREF (SHEET-FONT-MAP WINDOW) 1)) (LET ((BL (SHEET-FOLLOWING-BLINKER WINDOW)) (WS (FUNCALL WINDOW ':STATUS))) (UNWIND-PROTECT (PROGN (FUNCALL WINDOW ':SELECT) ;; Next line makes the mouse highlight go away (FUNCALL WINDOW ':SET-SENSITIVE-ITEM-TYPES NIL) (BLINKER-SET-VISIBILITY BL ':BLINK) (FUNCALL WINDOW ':SET-CURSORPOS (IF (NULL STR) 0 (+ (SHEET-STRING-LENGTH WINDOW (STRING STR)) (SHEET-CHAR-WIDTH WINDOW))) (* LINE-NO (SHEET-LINE-HEIGHT WINDOW))) (FUNCALL WINDOW ':CLEAR-EOL) (IF (LISTP RF) (SETQ NEWVAL (FUNCALL (CAR RF) WINDOW)) ;; Hair for over-rubout => save old value (LOCAL-DECLARE ((SPECIAL REDISPLAY-FLAG)) (DO ((CH) (FULL-RUBOUT T) (REDISPLAY-FLAG NIL) (TERMINAL-IO WINDOW)) ;Should be ERROR-OUTPUT ((NOT FULL-RUBOUT)) (AND (= (SETQ CH (FUNCALL WINDOW ':TYI)) #\RUBOUT) (RETURN (SETQ NO-CHANGE T))) (FUNCALL WINDOW ':UNTYI CH) (MULTIPLE-VALUE (NEWVAL FULL-RUBOUT) (FUNCALL WINDOW ':RUBOUT-HANDLER '((:FULL-RUBOUT T)) #'(LAMBDA (RF STREAM &AUX VAL) (IF (SETQ VAL (ERRSET (FUNCALL RF STREAM))) (SETQ VAL (CAR VAL)) (SETQ REDISPLAY-FLAG T) (*THROW 'EH:ERRSET-CATCH NIL))) RF WINDOW)) ;; If we got a read error, try to avoid garbage in the display ;; This is really a kludge, is there a better way? (SETQ REDIS REDISPLAY-FLAG))))) (BLINKER-SET-VISIBILITY BL NIL) (FUNCALL WINDOW ':SET-SENSITIVE-ITEM-TYPES T) (OR (EQ WS ':SELECTED) (FUNCALL WINDOW ':SET-STATUS WS))))) ((NULL GPVF) (SETQ NEWVAL CHOICE)) (T (SETQ NEWVAL (DOLIST (X CHOICES) (AND (EQUAL (FUNCALL GPVF X) CHOICE) (RETURN X)))))) (AND GVVF (SETQ NEWVAL (FUNCALL GVVF NEWVAL))) (SETQ OLDVAL (SYMEVAL VAR)) (AND NO-CHANGE (SETQ NEWVAL OLDVAL)) (SET VAR NEWVAL) (OR (AND (SETQ FCN (FUNCALL WINDOW ':FUNCTION)) (FUNCALL FCN WINDOW VAR OLDVAL NEWVAL)) ;; Redisplay (LET ((LAST-LINE-CLOBBERED (1+ (IF (NULL RF) LINE-NO ;If menu always one line, otherwise could have cr'ed (// (- (SHEET-CURSOR-Y WINDOW) (SHEET-INSIDE-TOP WINDOW)) (SHEET-LINE-HEIGHT WINDOW))))) (N-LINES (// (SHEET-INSIDE-HEIGHT WINDOW) (SHEET-LINE-HEIGHT WINDOW)))) (AND (OR ( LAST-LINE-CLOBBERED LINE-NO) ;wrap-around => full redisplay REDIS) (SETQ LAST-LINE-CLOBBERED N-LINES LINE-NO 0)) (SHEET-FORCE-ACCESS (WINDOW T) ;; :REDISPLAY doesn't erase first, so erase those lines (FUNCALL WINDOW ':DRAW-RECTANGLE (SHEET-INSIDE-WIDTH WINDOW) (* (- LAST-LINE-CLOBBERED LINE-NO) (SHEET-LINE-HEIGHT WINDOW)) 0 (* LINE-NO (SHEET-LINE-HEIGHT WINDOW)) (SHEET-ERASE-ALUF WINDOW)) (FUNCALL WINDOW ':REDISPLAY LINE-NO LAST-LINE-CLOBBERED))))) ;;; Redisplay a single choice item, when you know its value has been changed elsewhere (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :REDISPLAY-VARIABLE) (VARIABLE) (DO ((I 0 (1+ I)) (NITEMS (ARRAY-ACTIVE-LENGTH ITEMS)) (ITEM)) (( I NITEMS) (FERROR NIL "~S is not a variable in ~S" VARIABLE SELF)) (AND (EQ VARIABLE (IF (ATOM (SETQ ITEM (AREF ITEMS I))) ITEM (CAR ITEM))) (LET ((LINE-NO (- I TOP-ITEM))) (COND ((AND ( I 0) (< I (SHEET-NUMBER-OF-INSIDE-LINES))) (FUNCALL-SELF ':DRAW-RECTANGLE (SHEET-INSIDE-WIDTH) LINE-HEIGHT 0 (* LINE-NO LINE-HEIGHT) ERASE-ALUF) (FUNCALL-SELF ':REDISPLAY LINE-NO (1+ LINE-NO)))) (RETURN))))) (DEFFLAVOR CHOOSE-VARIABLE-VALUES-PANE () (PANE-MIXIN CHOOSE-VARIABLE-VALUES-WINDOW)) ;;; Let it be determined by the superior (DEFMETHOD (CHOOSE-VARIABLE-VALUES-PANE :ADJUSTABLE-SIZE-P) () NIL) ;;; Doesn't need a :PANE-SIZE method since the horizontal and vertical dimensions ;;; are not inter-dependent. (DEFFLAVOR TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW () (TEMPORARY-WINDOW-MIXIN CHOOSE-VARIABLE-VALUES-WINDOW)) ;Should this send itself a "exit" if it gets deexposed? I think probably not. (DEFMETHOD (TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW :NAME-FOR-SELECTION) () NIL) (COMPILE-FLAVOR-METHODS CHOOSE-VARIABLE-VALUES-WINDOW TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW CHOOSE-VARIABLE-VALUES-PANE) (DEFRESOURCE TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW (WINDOW-CREATE 'TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW)) ;; This is the handy-dandy user interface to the above ;; Options are: ;; :LABEL Window label (default is "Choose Variable Values") ;; :FUNCTION Function called if user changes anything (default is NIL) ;; :NEAR-MODE Where to appear the window (default is (:MOUSE)) ;; :MARGIN-CHOICES List of elements. A string is the label for the ;; box which means "exit" (Default is "Exit"), cons of ;; a string and a form means eval that form if box clicked upon. (DEFUN CHOOSE-VARIABLE-VALUES (VARIABLES &REST OPTIONS &AUX OP VAL (LABEL "Choose Variable Values") FUNCTION MARGIN-CHOICES (NEAR-MODE '(:MOUSE))) (DO OPTIONS OPTIONS (CDDR OPTIONS) (NULL OPTIONS) (SETQ OP (CAR OPTIONS) VAL (CADR OPTIONS)) (SELECTQ OP (:LABEL (SETQ LABEL VAL)) (:FUNCTION (SETQ FUNCTION VAL)) (:NEAR-MODE (SETQ NEAR-MODE VAL)) (:MARGIN-CHOICES (SETQ MARGIN-CHOICES VAL)) (OTHERWISE (FERROR NIL "~S invalid option keyword" OP)))) ;; MARGIN-CHOICES must always contain a "exit" box so user can stop choosing (DO ((L MARGIN-CHOICES (CDR L))) ((NULL L) (PUSH "Exit" MARGIN-CHOICES)) (COND ((STRINGP (CAR L)) (RETURN)) ((OR (ATOM (CAR L)) (NOT (STRINGP (CAAR L)))) (FERROR NIL "~S garbage in MARGIN-CHOICES" (CAR L))))) (SETQ MARGIN-CHOICES (MAPCAR #'(LAMBDA (X) (LIST (IF (ATOM X) X (CAR X)) NIL 'CHOOSE-VARIABLE-VALUES-CHOICE-BOX-HANDLER NIL NIL (IF (ATOM X) NIL (CADR X)))) MARGIN-CHOICES)) (DOLIST (ELEM VARIABLES) ;Make sure all variables are bound, while in caller's environment (AND (NOT (STRINGP ELEM)) (SYMEVAL (IF (ATOM ELEM) ELEM (CAR ELEM))))) (WITH-RESOURCE (TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW WINDOW) (FUNCALL WINDOW ':SETUP VARIABLES LABEL FUNCTION MARGIN-CHOICES) (UNWIND-PROTECT (LET ((IOB (FUNCALL WINDOW ':IO-BUFFER))) (IO-BUFFER-CLEAR IOB) (DELAYING-SCREEN-MANAGEMENT (EXPOSE-WINDOW-NEAR WINDOW NEAR-MODE) (FUNCALL WINDOW ':SELECT)) ;For who-line (DO () (NIL) (PROCESS-WAIT "Choose" #'(LAMBDA (IOB) (NOT (IO-BUFFER-EMPTY-P IOB))) IOB) (AND (CHOOSE-VARIABLE-VALUES-PROCESS-MESSAGE WINDOW (FUNCALL WINDOW ':ANY-TYI)) (RETURN)))) (FUNCALL WINDOW ':DEACTIVATE)))) (DEFUN CHOOSE-VARIABLE-VALUES-PROCESS-MESSAGE (WINDOW MSG) ;; Returns T if message is "exit", else does variable-changing or special action ;; and returns NIL. msg is either a list that came in whose cadr is ;; this window, or it is a regular character; only #\FORM is used. (PROG () (COND ((LISTP MSG) (SELECTQ (CAR MSG) (:CHOICE-BOX (SETQ MSG (SIXTH (THIRD MSG))) ;NIL if done or form to eval (IF (NULL MSG) (RETURN T) (EVAL MSG))) (:VARIABLE-CHOICE (APPLY #'CHOOSE-VARIABLE-VALUES-CHOICE (CDR MSG))) (OTHERWISE (FERROR NIL "~S unknown message from ~S" MSG WINDOW)))) ((EQ MSG #\FORM) (FUNCALL WINDOW ':REFRESH))))) ;;; User program macro interface (DEFMACRO DEFINE-USER-OPTION-ALIST (ALIST &OPTIONAL CONSTRUCTOR) `(PROGN 'COMPILE ,(AND CONSTRUCTOR `(DEFMACRO ,CONSTRUCTOR (OPTION DEFAULT &OPTIONAL TYPE NAME &REST ARGS) `(DEFINE-USER-OPTION (,OPTION ,',ALIST) ,DEFAULT ,TYPE ,NAME . ,ARGS))) (DEFVAR ,ALIST NIL))) (DEFMACRO DEFINE-USER-OPTION ((OPTION ALIST) DEFAULT &OPTIONAL TYPE NAME &REST ARGS) `(PROGN 'COMPILE (DEFINE-USER-OPTION-1 ',OPTION ',ALIST ,DEFAULT ',(OR TYPE ':SEXP) ',(OR NAME (ZWEI:MAKE-COMMAND-NAME OPTION)) . ,ARGS) (DEFVAR ,OPTION ,DEFAULT))) (DEFUN DEFINE-USER-OPTION-1 (OPTION ALIST DEFAULT TYPE NAME &REST ARGS) (PUTPROP OPTION DEFAULT 'DEFAULT-VALUE) (LET ((ELEM (ASSQ OPTION (SYMEVAL ALIST)))) (AND ELEM (SET ALIST (DELQ ELEM (SYMEVAL ALIST))))) (PUSH (LIST* OPTION NAME TYPE (COPYLIST ARGS)) (SYMEVAL ALIST))) (DEFUN RESET-USER-OPTIONS (ALIST) (DO ((X ALIST (CDR X)) (SYM)) ((NULL X)) (SETQ SYM (CAAR X)) (SET SYM (GET SYM 'DEFAULT-VALUE)))) (DEFUN CHOOSE-USER-OPTIONS (ALIST &REST ARGS) (LEXPR-FUNCALL #'CHOOSE-VARIABLE-VALUES ALIST ARGS)) ;;; Output all values that aren't the default (DEFUN WRITE-USER-OPTIONS (ALIST STREAM &AUX (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T)) (DO ((ALIST ALIST (CDR ALIST)) (OPTION) (DEFAULT) (VALUE)) ((NULL ALIST)) (SETQ OPTION (CAAR ALIST) DEFAULT (GET OPTION 'DEFAULT-VALUE) VALUE (SYMEVAL OPTION)) (OR (EQUAL VALUE DEFAULT) (GRIND-TOP-LEVEL `(LOGIN-SETQ ,OPTION ,(IF (OR (NUMBERP VALUE) (MEMQ VALUE '(T NIL))) VALUE `',VALUE)) 95. STREAM))))