;-*- 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 MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN () () (:INCLUDED-FLAVORS MARGIN-SCROLL-MIXIN MARGIN-REGION-MIXIN FLASHY-SCROLLING-MIXIN) (:DEFAULT-INIT-PLIST :FLASHY-SCROLLING-REGION '((32. 0.40s0 0.60s0) (32. 0.40s0 0.60s0)))) (DEFMETHOD (MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN :OVERRIDE :WHO-LINE-DOCUMENTATION-STRING) () (AND FLASHY-SCROLLING-BLINKER (IF (= (FUNCALL MOUSE-BLINKER ':CHARACTER) 10) ;; Character 10 is upward pointing arrow for top of window "Bump blinker against top to scroll down by one line. Any button to scroll one page." "Bump blinker against bottom to scroll up by one line. Any button to scroll one page."))) (DEFFLAVOR SCROLL-STUFF-ON-OFF-MIXIN ((MAKING-SCROLL-DECISION NIL)) ;Internal, prevents infinite recursion (MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXIN 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))) (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 :OVERRIDE :WHO-LINE-DOCUMENTATION-STRING) () (AND CURRENT-REGION (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':WHO-LINE-DOCUMENTATION-STRING CURRENT-REGION))) (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) ))) (DEFMETHOD (MARGIN-REGION-MIXIN :MOUSE-CLICK) (BUTTON X Y) (COND ((AND CURRENT-REGION ( BUTTON #\MOUSE-3-2)) (FUNCALL (MARGIN-REGION-FUNCTION CURRENT-REGION) ':MOUSE-CLICK X Y CURRENT-REGION BUTTON) 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) (:REQUIRED-FLAVORS 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) (SHEET-FORCE-ACCESS (SELF) (AND OLD-VALID (%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-CLICK (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))) (:WHO-LINE-DOCUMENTATION-STRING (IGNORE) "Any button to scroll one page."))) (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-CLICK (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))) (:WHO-LINE-DOCUMENTATION-STRING (IGNORE) "Select a line."))) (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)) (PREPARE-SHEET (SELF) (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-CLICK (X Y REGION IGNORE) (HANDLE-CHOICE-BUTTON MARGIN-CHOICES X Y REGION)) (:WHO-LINE-DOCUMENTATION-STRING (IGNORE) (LET ((X (- MOUSE-X (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET)))) (DOLIST (BOX MARGIN-CHOICES) (AND ( X (CHOICE-BOX-X1 BOX)) (< X (CHOICE-BOX-X2 BOX)) (RETURN "Any button to select choice."))))))) (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-CLICK) (BUTTON X Y &AUX LINE-NO ITEM) (COND ((OR (= BUTTON #\MOUSE-1-1) (= BUTTON #\MOUSE-3-1)) (SETQ LINE-NO (SHEET-LINE-NO NIL Y)) (COND ((AND ( Y (SHEET-INSIDE-TOP)) (< Y (+ (SHEET-INSIDE-TOP) (* (SHEET-NUMBER-OF-INSIDE-LINES) LINE-HEIGHT))) (SETQ ITEM (AREF DISPLAYED-ITEMS LINE-NO))) (HANDLE-CHOICE-BUTTON (CHOICE-ITEM-BOXES ITEM) X Y ITEM) T))))) (DEFMETHOD (BASIC-MULTIPLE-CHOICE :WHO-LINE-DOCUMENTATION-STRING) () "Any button an a box to complement its state") (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) (DEFWINDOW-RESOURCE TEMPORARY-MULTIPLE-CHOICE-WINDOW () :MAKE-WINDOW (TEMPORARY-MULTIPLE-CHOICE-WINDOW) :REUSABLE-WHEN :DEACTIVATED :INITIAL-COPIES 0) (DEFUN MULTIPLE-CHOOSE (ITEM-NAME ITEM-LIST KEYWORD-ALIST &OPTIONAL (NEAR-MODE '(:MOUSE)) (MAXLINES 20.) SUP) "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)." ;; Decide what superior to use (OR SUP (SETQ SUP (IF (EQ (CAR NEAR-MODE) ':WINDOW) (SHEET-SUPERIOR (CADR NEAR-MODE)) MOUSE-SHEET))) (DO L KEYWORD-ALIST (CDR L) (NULL L) (AND (< (LENGTH (CAR L)) 3) (SETF (CAR L) (NCONC (CAR L) (LIST NIL T NIL NIL))))) (USING-RESOURCE (WINDOW TEMPORARY-MULTIPLE-CHOICE-WINDOW SUP) (FUNCALL WINDOW ':SETUP ITEM-NAME KEYWORD-ALIST DEFAULT-FINISHING-CHOICES ITEM-LIST MAXLINES) (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 ; ; If :DOCUMENTATION appears where the keyword is expected, it is followed by ; a string to display when the mouse is pointing here, and then by the keyword. ; This is implemented by :DECODE-VARIABLE-TYPE (see below) so that you can ; change it. ; ; 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 6 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 who-line mouse documentation string. If this is a symbol, then NIL means ; use the default documentation, and any other symbol is the name of a function ; which translates a value to its documentation. ; The two functions only apply when there are choices. ; The default handler looks for a TV:CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION property which ; is a function to call or a TV:CHOOSE-VARIABLE-VALUES-KEYWORD property which is ; (print-func read-func choices ptransfn vtransfn mouse-documentation) ;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-WITHOUT-CLICK) (: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)) (DEFPROP :SEXP (PRIN1 READ) CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFPROP :PRINC (PRINC READ) CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFPROP :STRING (PRINC READLINE) CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFPROP :CHOOSE CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (DEFPROP :ASSOC CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (DEFUN CHOOSE-VARIABLE-VALUES-DECODE-CHOOSE (KWD-AND-ARGS) (VALUES (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))) (DEFPROP :BOOLEAN (CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT NIL (T NIL)) CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN CHOOSE-VARIABLE-VALUES-BOOLEAN-PRINT (VALUE STREAM) (FUNCALL STREAM ':STRING-OUT (IF VALUE "Yes" "No"))) (DEFPROP :CHARACTER (CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (TYI) NIL NIL NIL "Click left to input a new character from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN CHOOSE-VARIABLE-VALUES-CHARACTER-PRINT (VALUE STREAM) (FORMAT STREAM "~:@C" VALUE)) (DEFPROP :CHARACTER-OR-NIL (CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-PRINT CHOOSE-VARIABLE-VALUES-CHARACTER-OR-NIL-READ NIL NIL NIL "Click left to input a new character from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (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))) (DEFPROP :NUMBER (PRIN1 READ-NUMBER NIL NIL NIL "Click left to input a new number from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN READ-NUMBER (STREAM) (LET ((VAL (READ STREAM))) (OR (NUMBERP VAL) (FERROR NIL "A number is required")) VAL)) (DEFPROP :DATE (TIME:PRINT-UNIVERSAL-TIME READ-DATE NIL NIL NIL "Click left to input a new date from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN READ-DATE (STREAM) (LET ((VAL (TIME:PARSE-UNIVERSAL-TIME (READLINE STREAM)))) (AND (STRINGP VAL) (FERROR NIL "A date is required: ~A" VAL)) VAL)) (DEFPROP :DATE-OR-NEVER (PRINT-UNIVERSAL-TIME-OR-NEVER READ-DATE-OR-NEVER NIL NIL NIL "Click left to input a new date from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN PRINT-UNIVERSAL-TIME-OR-NEVER (TIME STREAM) (IF (NULL TIME) (PRINC "never" STREAM) (TIME:PRINT-UNIVERSAL-TIME TIME STREAM))) (DEFUN READ-DATE-OR-NEVER (STREAM) (LET ((STRING (READLINE STREAM))) (IF (EQUAL STRING "never") NIL (LET ((VAL (TIME:PARSE-UNIVERSAL-TIME STRING))) (AND (STRINGP VAL) (FERROR NIL "A date is required: ~A" VAL)) VAL)))) (DEFPROP :NUMBER-OR-NIL (PRIN1 READ NIL NIL NIL "Click left to enter a new number, or NIL, from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN (:MENU-ALIST CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (KWD-AND-ARGS) (VALUES 'PRINC NIL (SECOND KWD-AND-ARGS) 'CAR 'MENU-EXECUTE-NO-SIDE-EFFECTS 'MENU-ITEM-WHO-LINE-DOCUMENTATION)) (DEFPROP :STRING-LIST (PRINT-STRING-LIST READ-STRING-LIST) CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN PRINT-STRING-LIST (STRING-LIST STREAM) (FORMAT STREAM "~{~A~^, ~}" STRING-LIST)) (DEFUN READ-STRING-LIST (STREAM) (DO ((STRING (READLINE STREAM)) (I 0 (1+ J)) (J) (STRING-LIST NIL)) (NIL) (SETQ J (STRING-SEARCH-CHAR #/, STRING I)) (PUSH (STRING-TRIM '(#\SP #\TAB) (NSUBSTRING STRING I J)) STRING-LIST) (OR J (RETURN (NREVERSE STRING-LIST))))) (DEFPROP :PATHNAME-OR-NIL (PRINC READ-PATHNAME-OR-NIL NIL NIL NIL "Click left to enter a new pathname from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN READ-PATHNAME-OR-NIL (STREAM &AUX STRING) (SETQ STRING (READLINE STREAM)) (AND (PLUSP (STRING-LENGTH STRING)) (STRING (FS:MERGE-PATHNAME-DEFAULTS STRING)))) (DEFPROP :PATHNAME (PRINC READ-PATHNAME NIL NIL NIL "Click left to enter a new pathname from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN READ-PATHNAME (STREAM) (STRING (FS:MERGE-PATHNAME-DEFAULTS (READLINE STREAM)))) (DEFPROP :PATHNAME-LIST (PRINT-STRING-LIST READ-PATHNAME-LIST NIL NIL NIL "Click left to enter new pathnames from the keyboard.") CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN READ-PATHNAME-LIST (STREAM) (MAPCAR #'STRING (PARSE-PATHNAME-LIST (READLINE STREAM)))) (DEFUN PARSE-PATHNAME-LIST (STRING) (DO ((I 0 (1+ J)) (J) (STRING-LIST NIL)) (NIL) (SETQ J (STRING-SEARCH-CHAR #/, STRING I)) (PUSH (FS:MERGE-PATHNAME-DEFAULTS (NSUBSTRING STRING I J)) STRING-LIST) (OR J (RETURN (NREVERSE STRING-LIST))))) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :DECODE-VARIABLE-TYPE) (KWD-AND-ARGS &AUX KEY TEM) (SETQ KEY (CAR KWD-AND-ARGS)) (COND ((EQ KEY ':DOCUMENTATION) (MULTIPLE-VALUE-BIND (PF RF CHOICES GPVF GVVF) (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR (CDDR KWD-AND-ARGS) '(:SEXP))) (VALUES PF RF CHOICES GPVF GVVF (CADR KWD-AND-ARGS)))) ((SETQ TEM (GET KEY 'CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION)) (FUNCALL TEM KWD-AND-ARGS)) ((SETQ TEM (GET KEY 'CHOOSE-VARIABLE-VALUES-KEYWORD)) (VALUES-LIST TEM)) (T (FERROR NIL "~S bad keyword in a CHOOSE-VARIABLE-VALUES-WINDOW" KEY)))) ;So lines can wrap around when reading (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :END-OF-LINE-EXCEPTION) () (IF LINE-OVERFLOW-ALLOWED (FUNCALL #'(:METHOD SHEET :END-OF-LINE-EXCEPTION) ':END-OF-LINE-EXCEPTION) ;<-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 CVAL) 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) (IF VAR (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) CVAL (IF GVVF (FUNCALL GVVF CHOICE) CHOICE)) (SHEET-SET-FONT SELF (AREF FONT-MAP (IF (EQUAL CVAL VAL) 4 3))) (FUNCALL-SELF ':ITEM CHOICE ':VARIABLE-CHOICE 'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF PVAL) (SHEET-SPACE SELF))))))) (DEFUN CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION (ITEM WINDOW PF PVAL) ITEM ;ignored (FUNCALL PF PVAL WINDOW)) ;Modified from the :PRINT-ITEM method. Hard to be completely modular about this. ;Extra-width is amount of space to allow for non-menu items to grow (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :ITEM-WIDTH) (ITEM &OPTIONAL (EXTRA-WIDTH 0) &AUX VAR VAL STR FONTNO CHOICES PF RF K&A GPVF GVVF PVAL (X 0)) ;; 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 (SETQ X (FUNCALL-SELF ':STRING-LENGTH STR 0 NIL NIL (AREF FONT-MAP FONTNO) X)) (SETQ X (FUNCALL-SELF ':STRING-LENGTH ": " 0 NIL NIL (AREF FONT-MAP FONTNO) X)))) ;; 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) (SETQ X (+ (FUNCALL-SELF ':STRING-LENGTH (WITH-OUTPUT-TO-STRING (S) (FUNCALL PF VAL S)) 0 NIL NIL (AREF FONT-MAP 2) X) EXTRA-WIDTH))) (T (DOLIST (CHOICE CHOICES) (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE) CHOICE (IF GVVF (FUNCALL GVVF CHOICE) CHOICE)) (SETQ X (FUNCALL-SELF ':STRING-LENGTH (WITH-OUTPUT-TO-STRING (S) (FUNCALL PF PVAL S)) 0 NIL NIL (AREF FONT-MAP (IF (EQUAL CHOICE VAL) 4 3)) X)) (INCF X CHAR-WIDTH)))))) X) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :APPROPRIATE-WIDTH) (&OPTIONAL EXTRA-WIDTH) "Returns the inside-width appropriate to accommodate the current set of variables with their current values. If EXTRA-WIDTH is specified that much room for expansion, which can be a number of characters or a string, is left after non-menu items." (SETQ EXTRA-WIDTH (COND ((STRINGP EXTRA-WIDTH) (FUNCALL-SELF ':STRING-LENGTH EXTRA-WIDTH)) ((NUMBERP EXTRA-WIDTH) (* CHAR-WIDTH EXTRA-WIDTH)) (T 0))) (MIN (MAX (FUNCALL-SELF ':LABEL-SIZE) (LOOP FOR ITEM BEING THE ARRAY-ELEMENTS OF ITEMS MAXIMIZE (FUNCALL-SELF ':ITEM-WIDTH ITEM EXTRA-WIDTH))) (+ (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE))) ;This is quite a bit slower than it needs to be. However these windows aren't used much. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :WHO-LINE-DOCUMENTATION-STRING) () (MULTIPLE-VALUE-BIND (WINDOW-X-OFFSET WINDOW-Y-OFFSET) (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET) (LET ((X (- MOUSE-X WINDOW-X-OFFSET)) (Y (- MOUSE-Y WINDOW-Y-OFFSET))) (MULTIPLE-VALUE-BIND (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y) (AND TYPE (LET ((ITEM (AREF ITEMS (+ TOP-ITEM (// (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT))))) (IF (ATOM ITEM) "Click left to input a new value from the keyboard." (SETQ ITEM (CDR ITEM)) (AND (OR (STRINGP (CAR ITEM)) (NULL (CAR ITEM))) (SETQ ITEM (CDR ITEM))) (MULTIPLE-VALUE-BIND (IGNORE RF IGNORE IGNORE IGNORE DOC) (FUNCALL-SELF ':DECODE-VARIABLE-TYPE (OR ITEM '(:SEXP))) (COND ((STRINGP DOC) DOC) ((AND DOC (FUNCALL DOC VALUE))) ((NULL RF) "Click left to change to this value.") (T "Click left to input a new value from the keyboard.")))))))))) (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :MOUSE-CLICK) (BUTTON X Y &AUX VALUE TYPE LINE-NO) (COND ((= BUTTON #\MOUSE-1-1) (MULTIPLE-VALUE (VALUE TYPE) (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y)) (COND (TYPE (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))))) ;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 ERROR) (MULTIPLE-VALUE (VAL ERROR) (CATCH-ERROR (FUNCALL RF STREAM))) (COND (ERROR (SETQ REDISPLAY-FLAG T) (*THROW 'EH:ERRSET-CATCH NIL))) VAL) 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))))) (T (SETQ NEWVAL CHOICE))) (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-MIXIN () (PANE-MIXIN)) (DEFFLAVOR CHOOSE-VARIABLE-VALUES-PANE () (CHOOSE-VARIABLE-VALUES-PANE-MIXIN CHOOSE-VARIABLE-VALUES-WINDOW)) ;;; Let it be determined by the superior (DEFMETHOD (CHOOSE-VARIABLE-VALUES-PANE-MIXIN :ADJUSTABLE-SIZE-P) () NIL) ;;; Even though we the vertical and horizontal dimensions are independent, this gives ;;; what we prefer. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING) (SELECTQ STACKING (:VERTICAL (MIN REM-HEIGHT (+ TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE (* (ARRAY-ACTIVE-LENGTH ITEMS) LINE-HEIGHT)))) (:HORIZONTAL (MIN REM-WIDTH (+ LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE (FUNCALL-SELF ':APPROPRIATE-WIDTH)))))) (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) (DEFWINDOW-RESOURCE TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW () :MAKE-WINDOW (TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW) :INITIAL-COPIES 0) ;; 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)) ;; :WIDTH Desired width of window. Default is to set wide enough for items. ;; :EXTRA-WIDTH Amount of extra width to allow for growing items. Default 10 characters. ;; Both of the above widths may be a number of characters or a string. ;; :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. ;; :SUPERIOR Window to put under, default is MOUSE-SHEET or the superior ;; of the window it is supposed to be near, like MENU-CHOOSE (DEFUN CHOOSE-VARIABLE-VALUES (VARIABLES &REST OPTIONS &AUX OP VAL (LABEL "Choose Variable Values") FUNCTION MARGIN-CHOICES (NEAR-MODE '(:MOUSE)) SUP OSW WIDTH (EXTRA-WIDTH 10.)) (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)) (:WIDTH (SETQ WIDTH VAL)) (:EXTRA-WIDTH (SETQ EXTRA-WIDTH VAL)) (:MARGIN-CHOICES (SETQ MARGIN-CHOICES VAL)) (:SUPERIOR (SETQ SUP VAL)) (OTHERWISE (FERROR NIL "~S invalid option keyword" OP)))) ;; Decide what superior to use (OR SUP (SETQ SUP (IF (EQ (CAR NEAR-MODE) ':WINDOW) (SHEET-SUPERIOR (CADR NEAR-MODE)) MOUSE-SHEET))) ;; 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))))) (USING-RESOURCE (WINDOW TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW SUP) (FUNCALL WINDOW ':SETUP VARIABLES LABEL FUNCTION MARGIN-CHOICES) (COND ((STRINGP WIDTH) (SETQ WIDTH (FUNCALL WINDOW ':STRING-LENGTH WIDTH))) ((NUMBERP WIDTH) (SETQ WIDTH (* (SHEET-CHAR-WIDTH WINDOW) WIDTH))) ((NULL WIDTH) (SETQ WIDTH (FUNCALL WINDOW ':APPROPRIATE-WIDTH EXTRA-WIDTH)))) (FUNCALL WINDOW ':SET-INSIDE-SIZE WIDTH (SHEET-INSIDE-HEIGHT WINDOW)) (SETQ OSW SELECTED-WINDOW) (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)))) (AND OSW (FUNCALL OSW ':SELECT NIL)) (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)))) ;;; Site dependent versions (DEFMACRO DEFINE-SITE-USER-OPTION ((OPTION ALIST) KEYWORD &OPTIONAL TYPE NAME &REST ARGS) `(PROGN 'COMPILE (DEFINE-USER-OPTION-1 ',OPTION ',ALIST NIL ',(OR TYPE ':SEXP) ',(OR NAME (ZWEI:MAKE-COMMAND-NAME OPTION)) . ,ARGS) (DEFVAR ,OPTION) (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" OPTION) `(RESET-USER-OPTION ',',OPTION (SI:GET-SITE-OPTION ',',KEYWORD)) '(SITE)))) ;;; Change the default value of an option (DEFUN RESET-USER-OPTION (OPTION VALUE) (SET OPTION VALUE) (PUTPROP OPTION VALUE 'DEFAULT-VALUE)) ;;; A :MENU-ALIST type variable whose alist changes (DEFMACRO DEFINE-SITE-ALIST-USER-OPTION ((OPTION ALIST) NAME MENU-ALIST &OPTIONAL DEFAULT) `(PROGN 'COMPILE (DEFINE-USER-OPTION-1 ',OPTION ',ALIST NIL ':MENU-ALIST ',(OR NAME (ZWEI:MAKE-COMMAND-NAME OPTION)) ,MENU-ALIST) (DEFVAR ,OPTION) (ADD-INITIALIZATION ,(FORMAT NIL "SITE:~A" OPTION) `(RESET-ALIST-USER-OPTION ',',OPTION ,',ALIST ,',MENU-ALIST ',',DEFAULT) '(SITE)))) (DEFUN RESET-ALIST-USER-OPTION (OPTION ALIST MENU-ALIST DEFAULT) (AND DEFAULT (SETQ DEFAULT (SI:GET-SITE-OPTION DEFAULT))) (LOOP FOR ELEM IN MENU-ALIST AS SITE-KEYWORD = (OR (AND (LISTP (CDR ELEM)) (GET ELEM ':SITE-KEYWORD)) (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM)) AS DEFAULT-SITE-KEYWORD = (OR (AND (LISTP (CDR ELEM)) (GET ELEM ':DEFAULT-SITE-KEYWORD)) SITE-KEYWORD) WHEN (NOT (NULL (SI:GET-SITE-OPTION SITE-KEYWORD))) COLLECT ELEM INTO NEW-ALIST WITH DEFAULT-ELEM WHEN (EQ DEFAULT-SITE-KEYWORD DEFAULT) DO (SETQ DEFAULT-ELEM ELEM) FINALLY (AND DEFAULT-ELEM (SETQ NEW-ALIST (CONS DEFAULT-ELEM (DELQ DEFAULT-ELEM NEW-ALIST)))) (SETQ MENU-ALIST NEW-ALIST)) (LET ((ELEM (ASSQ OPTION ALIST))) (SETF (FOURTH ELEM) MENU-ALIST)) (RESET-USER-OPTION OPTION (AND MENU-ALIST (TV:MENU-EXECUTE-NO-SIDE-EFFECTS (CAR MENU-ALIST))))) (DEFMACRO RESTRICT-USER-OPTION (OPTION RESTRICTION-TYPE &REST SITE-KEYWORDS &AUX IF IF-NOT) (SETQ SITE-KEYWORDS (COPYLIST SITE-KEYWORDS)) (SELECTQ RESTRICTION-TYPE (:IF (SETQ IF SITE-KEYWORDS)) (:UNLESS (SETQ IF-NOT SITE-KEYWORDS)) (:NEVER (SETQ IF-NOT T))) `(DEFPROP ,OPTION ,(OR IF IF-NOT) ,(IF IF 'SITE-KEYWORDS-RESTRICTION 'NOT-SITE-KEYWORDS-RESTRICTION))) ;;; This removes all user options that are restricted or choices with less than two ;;; possibilities. (DEFUN PRUNE-USER-OPTION-ALIST (ALIST) (LOOP FOR ELEM IN ALIST AS OPTION = (CAR ELEM) WITH TEM UNLESS (OR (AND (NOT (NULL (SETQ TEM (GET OPTION 'NOT-SITE-KEYWORDS-RESTRICTION)))) (OR (EQ TEM T) (LOOP FOR KEY IN TEM THEREIS (SI:GET-SITE-OPTION KEY)))) (AND (NOT (NULL (SETQ TEM (GET OPTION 'SITE-KEYWORDS-RESTRICTION)))) (NOT (LOOP FOR KEY IN TEM ALWAYS (SI:GET-SITE-OPTION KEY)))) (AND (MEMQ (THIRD ELEM) '(:ASSOC :MENU-ALIST)) (NULL (CDR (FOURTH ELEM))))) COLLECT ELEM))