;;; -*- mode:lisp; package: tv; base:10.; -*- ;;; ;;; $Header: /ct/window/leftmenu.l,v 1.2 84/08/14 12:14:29 bill Exp $ ;;; $Log: /ct/window/leftmenu.l,v $ ;;; ;;; Hacked 14 August 1985 by Richard Mark Soley for Lambda port ;;; ;;;Revision 1.2 84/08/14 12:14:29 bill ;;;Fix up for Release 5: add compile flavor methods. Soley ;;; ;;;Revision 1.1 83/07/20 10:41:15 john ;;;Initial revision ;;; ;;; #| LEFT-MENUS This file contains code to implement left-menus, which display their items left-centered in the field. Not real exciting, but someone asked for the feature. =John Shelton= Computer*Thought Corp. 22-Apr-83. |# ;;; The basic flavor. Mix this in with other things as you like. (defflavor left-menu-mixin () () (:required-flavors basic-menu)) ;;; an instantiable flavor. (defflavor left-menu () (left-menu-mixin momentary-menu)) ;;; This is how left menus are drawn. This code is stolen from basic-menu. (DEFMETHOD (LEFT-MENU-MIXIN :MENU-DRAW) (&AUX ind (FILL-P (GEOMETRY-FILL-P GEOMETRY))) ;; Make sure the mouse knows we're changing (AND EXPOSED-P (MOUSE-WAKEUP)) (PREPARE-SHEET (SELF) (FUNCALL-SELF ':CLEAR-SCREEN) (DO ((ROW TOP-ROW (1+ ROW)) (Y-POS 0 (+ Y-POS ROW-HEIGHT)) (LIM (MIN TOTAL-ROWS (+ TOP-ROW SCREEN-ROWS)))) (( ROW LIM)) (DO ((ITEMS (AREF ROW-MAP ROW) (CDR ITEMS)) (END-ITEM-LIST (AREF ROW-MAP (1+ ROW))) (STR) (FONT) (FLAG) (X-POS 0)) ((EQ ITEMS END-ITEM-LIST)) (MULTIPLE-VALUE (STR FONT) (MENU-ITEM-STRING (CAR ITEMS))) (setq ind (or (get (cons nil (cdar items)) ':indent) 0)) (UNWIND-PROTECT (PROGN (AND (SETQ FLAG (AND font (NEQ FONT CURRENT-FONT) CURRENT-FONT)) (FUNCALL-SELF ':SET-CURRENT-FONT FONT)) (COND (FILL-P ;Filled, put string followed by spacing (FUNCALL-SELF ':SET-CURSORPOS X-POS Y-POS) (FUNCALL-SELF ':STRING-OUT STR) (SETQ X-POS (+ (FUNCALL-SELF ':READ-CURSORPOS) MENU-INTERWORD-SPACING))) (T ;Columnated, center text within column ;; Here is the only change made. Instead of calling ;; centered string, we just print the string. Note above that ;; left menus work the same for filled- geometry. (funcall-self ':set-cursorpos (+ x-pos ind) y-pos) (setq x-pos (+ x-pos column-width)) (funcall-self ':string-out str)))) (AND FLAG (FUNCALL-SELF ':SET-CURRENT-FONT FLAG))))))) ;;; Taken from: ;;; John Shelton's patches to menu mouse-moves. The code here causes menu ;;; items to be boxed in correctly, regardless of font. ;;; Copyright (C) 1983, Computer Thought Corporation. ;;; This is the guts. Given a menu and a set of coordinates, it finds ;;; the corresponding item, if any, sets CURRENT-ITEM to it, and sets up ;;; the blinker to mark that item. If no item, the blinker is shut off. ;;;*** This tvobish code should be rewritten *** (DEFMETHOD (LEFT-MENU-MIXIN :MOUSE-MOVES) (X Y &AUX ITEM ITEMS ROW XREL BLINKER BLX (BLWIDTH 0) COLN STOP-ITEM ind (FILL-P (GEOMETRY-FILL-P GEOMETRY))) (MOUSE-SET-BLINKER-CURSORPOS) (SETQ ROW (// (- Y (SHEET-INSIDE-TOP)) ROW-HEIGHT) XREL (- X (SHEET-INSIDE-LEFT)) BLINKER (CAR BLINKER-LIST)) (COND ((AND ( XREL 0) ;If inside the menu (< X (SHEET-INSIDE-RIGHT)) ( Y (SHEET-INSIDE-TOP)) (< Y (SHEET-INSIDE-BOTTOM))) ;;If mouse is past the last displayed row, blink item on that row. (AND (OR (>= (+ TOP-ROW ROW) TOTAL-ROWS) (>= ROW SCREEN-ROWS)) (SETQ ROW (1- (MIN SCREEN-ROWS (- TOTAL-ROWS TOP-ROW))))) (IF (MINUSP ROW) (SETQ ITEMS NIL STOP-ITEM NIL) ;No items visible (SETQ ITEMS (AREF ROW-MAP (+ TOP-ROW ROW)) STOP-ITEM (AREF ROW-MAP (+ TOP-ROW ROW 1)))) (COND (FILL-P ;Fill mode, cogitate (SETQ BLX 0) (DO ((L ITEMS (CDR L)) (ITM) (OITM NIL ITM) (X 0 (+ X (SETQ BLWIDTH (MENU-ITEM-STRING-WIDTH ITM)) MENU-INTERWORD-SPACING))) ((OR (NULL L) (> X XREL)) ;If this string crosses the mouse, it's the one (SETQ ITEM OITM BLX (1- BLX) BLWIDTH (+ BLWIDTH 1))) (AND (EQ L STOP-ITEM) ;; The next item on next line -- punt (RETURN NIL)) (SETQ ITM (CAR L) BLX X))) (T ;Columnated, find which column (SETQ COLN (// XREL COLUMN-WIDTH)) ;Column selected (SETQ ITEM (CAR (NTHCDR COLN ITEMS))) ;This may be NIL (SETQ BLWIDTH (1+ (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH))) (SETQ BLX (+ (* COLN COLUMN-WIDTH) ;Start of column -1 )))))) ;; Find out how much to indent. (setq ind (or (get (cons nil (cdr item)) ':indent) 0)) ;; If this item is non-selectable, don't select it. (AND (NOT (ATOM ITEM)) (NOT (ATOM (CDR ITEM))) (NOT (ATOM (CDDR ITEM))) (EQ (CADR ITEM) ':NO-SELECT) (SETQ ITEM NIL)) ;; Now make the blinker be where and what we have just found it should be. (BLINKER-SET-VISIBILITY BLINKER (NOT (NULL ITEM))) (SETQ CURRENT-ITEM ITEM) ;; The height of the ;; blinker (box) is changed to be the height of the item (plus on pixel on ;; each side). The Y location is (* row row-height) like it used to be, ;; PLUS A FUDGE FACTOR, which is never negative. The fudge factor takes into ;; account the difference in height of the font on this item and the row-height ;; which is actually the height of the largest font in the menu, plus a little ;; bit more. Little bit more is one-fifth of the row height, which was randomly ;; chosen to work on many menus. (COND (ITEM (FUNCALL BLINKER ':SET-SIZE-AND-CURSORPOS BLWIDTH (+ (johns-font-char-height item font-map) 2) (+ BLX ind) ;add in indentation. (1- (+ (* ROW ROW-HEIGHT) (- (send self ':vsp)) (max 0 (- row-height ;; (johns-font-baseline item font-map) (// row-height 6) )))))))) ;;; This returns the font-char-height of the font used for a menu item. ;;; We look at the item to see if it has a font property, and if so, examine ;;; that font. If not, we use the default font for this menu. (defun johns-font-char-height (item font-map) (FONT-CHAR-HEIGHT (if (and (listp item) (listp (cdr item)) (get (cddr item) ':FONT)) (if (symbolp (get (cddr item) ':font)) (symeval (get (cddr item) ':FONT)) (get (cddr item) ':font)) (AREF FONT-MAP 0)))) (defun johns-font-baseline (item font-map) (FONT-BASELINE (if (and (listp item) (listp (cdr item)) (get (cddr item) ':FONT)) (if (symbolp (get (cddr item) ':font)) (symeval (get (cddr item) ':FONT)) (get (cddr item) ':font)) (AREF FONT-MAP 0)))) (DEFMETHOD (LEFT-MENU-MIXIN :ITEM-RECTANGLE) (ITEM &AUX (X 0) SWIDTH ind (ALEN (ARRAY-LENGTH ROW-MAP))) ind (DO ((ROW (1- (MIN (+ TOP-ROW SCREEN-ROWS) ;last row on screen ALEN)) ;last row that exists (1- ROW))) ((< ROW TOP-ROW) NIL) (COND ((AND (MEMQ ITEM (AREF ROW-MAP ROW)) (OR (= ROW (1- ALEN)) (NOT (MEMQ ITEM (AREF ROW-MAP (1+ ROW)))))) ;; Find out how much to indent. ;; (setq ind (or (get (cons nil (cdr item)) ':indent) 0)) (IF (NOT (GEOMETRY-FILL-P GEOMETRY)) (SETQ SWIDTH (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH) X (+ (* (FIND-POSITION-IN-LIST ITEM (AREF ROW-MAP ROW)) COLUMN-WIDTH) 0.)) (DOLIST (IT (AREF ROW-MAP ROW)) (SETQ SWIDTH (MENU-ITEM-STRING-WIDTH IT)) (AND (EQ IT ITEM) (RETURN)) (SETQ X (+ X SWIDTH MENU-INTERWORD-SPACING)))) (RETURN (1- X) (1- (* (- ROW TOP-ROW) ROW-HEIGHT)) (+ X SWIDTH 1) (1- (* (1+ (- ROW TOP-ROW)) ROW-HEIGHT))))))) ;;(// (- COLUMN-WIDTH MENU-INTERCOLUMN-SPACING SWIDTH) 2) (defflavor left-highlighting-menu () (left-menu-mixin menu-highlighting-mixin menu)) ;;; Left or centered menus. These work like left menus for items with ':LEFT ;;; somewhere in them, and like centered menus if no ':LEFT is in them. ;;; In the future, we may add ':RIGHT capabilities. ;;; The basic flavor. Mix this in with other things as you like. (defflavor left-or-right-menu-mixin () () (:required-flavors basic-menu)) ;;; an instantiable flavor. (defflavor left-or-right-menu () (left-or-right-menu-mixin momentary-menu)) (DEFMETHOD (LEFT-OR-RIGHT-MENU-MIXIN :MENU-DRAW) (&AUX ind (FILL-P (GEOMETRY-FILL-P GEOMETRY))) ;; Make sure the mouse knows we're changing (AND EXPOSED-P (MOUSE-WAKEUP)) (PREPARE-SHEET (SELF) (FUNCALL-SELF ':CLEAR-SCREEN) (DO ((ROW TOP-ROW (1+ ROW)) (Y-POS 0 (+ Y-POS ROW-HEIGHT)) (LIM (MIN TOTAL-ROWS (+ TOP-ROW SCREEN-ROWS)))) (( ROW LIM)) (DO ((ITEMS (AREF ROW-MAP ROW) (CDR ITEMS)) (END-ITEM-LIST (AREF ROW-MAP (1+ ROW))) (STR) (FONT) (FLAG) (X-POS 0)) ((EQ ITEMS END-ITEM-LIST)) (MULTIPLE-VALUE (STR FONT) (MENU-ITEM-STRING (CAR ITEMS))) (setq ind (or (get (cons nil (cdar items)) ':indent) 0)) (UNWIND-PROTECT (PROGN (AND (SETQ FLAG (AND font (NEQ FONT CURRENT-FONT) CURRENT-FONT)) (FUNCALL-SELF ':SET-CURRENT-FONT FONT)) (COND (FILL-P ;Filled, put string followed by spacing (FUNCALL-SELF ':SET-CURSORPOS X-POS Y-POS) (FUNCALL-SELF ':STRING-OUT STR) (SETQ X-POS (+ (FUNCALL-SELF ':READ-CURSORPOS) MENU-INTERWORD-SPACING))) ((memq ':LEFT (car items)) (funcall-self ':set-cursorpos (+ x-pos ind) y-pos) (setq x-pos (+ x-pos column-width)) (funcall-self ':string-out str)) ((memq ':right (car items)) (funcall-self ':set-cursorpos (+ x-pos (- column-width menu-intercolumn-spacing (send self ':string-length str))) y-pos) (setq x-pos (+ x-pos column-width)) (funcall-self ':string-out str)) (t (FUNCALL-SELF ':DISPLAY-CENTERED-STRING STR X-POS (- (SETQ X-POS (+ X-POS COLUMN-WIDTH)) MENU-INTERCOLUMN-SPACING) Y-POS)))) (AND FLAG (FUNCALL-SELF ':SET-CURRENT-FONT FLAG))))))) (DEFMETHOD (LEFT-OR-RIGHT-MENU-MIXIN :MOUSE-MOVES) (X Y &AUX ITEM ITEMS ROW XREL BLINKER BLX (BLWIDTH 0) COLN STOP-ITEM ind (FILL-P (GEOMETRY-FILL-P GEOMETRY))) (MOUSE-SET-BLINKER-CURSORPOS) (SETQ ROW (// (- Y (SHEET-INSIDE-TOP)) ROW-HEIGHT) XREL (- X (SHEET-INSIDE-LEFT)) BLINKER (CAR BLINKER-LIST)) (COND ((AND ( XREL 0) ;If inside the menu (< X (SHEET-INSIDE-RIGHT)) ( Y (SHEET-INSIDE-TOP)) (< Y (SHEET-INSIDE-BOTTOM))) ;;If mouse is past the last displayed row, blink item on that row. (AND (OR (>= (+ TOP-ROW ROW) TOTAL-ROWS) (>= ROW SCREEN-ROWS)) (SETQ ROW (1- (MIN SCREEN-ROWS (- TOTAL-ROWS TOP-ROW))))) (IF (MINUSP ROW) (SETQ ITEMS NIL STOP-ITEM NIL) ;No items visible (SETQ ITEMS (AREF ROW-MAP (+ TOP-ROW ROW)) STOP-ITEM (AREF ROW-MAP (+ TOP-ROW ROW 1)))) (COND (FILL-P ;Fill mode, cogitate (SETQ BLX 0) (DO ((L ITEMS (CDR L)) (ITM) (OITM NIL ITM) (X 0 (+ X (SETQ BLWIDTH (MENU-ITEM-STRING-WIDTH ITM)) MENU-INTERWORD-SPACING))) ((OR (NULL L) (> X XREL)) ;If this string crosses the mouse, it's the one (SETQ ITEM OITM BLX (1- BLX) BLWIDTH (+ BLWIDTH 1))) (AND (EQ L STOP-ITEM) ;; The next item on next line -- punt (RETURN NIL)) (SETQ ITM (CAR L) BLX X))) (T ;Columnated, find which column (SETQ COLN (// XREL COLUMN-WIDTH)) ;Column selected (SETQ ITEM (CAR (NTHCDR COLN ITEMS))) ;This may be NIL (SETQ BLWIDTH (1+ (MENU-ITEM-STRING-WIDTH ITEM COLUMN-WIDTH))) (SETQ BLX (cond ((memq ':left item) (+ (* COLN COLUMN-WIDTH) ;Start of column -1)) ((memq ':right item) (+ (* COLN COLUMN-WIDTH) ;Start of column -1 (MAX 0 (- COLUMN-WIDTH ;Centering MENU-INTERCOLUMN-SPACING BLWIDTH)))) (t (+ (* COLN COLUMN-WIDTH) ;Start of column -1 (MAX 0 (// (- COLUMN-WIDTH ;Centering MENU-INTERCOLUMN-SPACING BLWIDTH) 2)))))))))) ;; Find out how much to indent. (setq ind (or (get (cons nil (cdr item)) ':indent) 0)) ;; If this item is non-selectable, don't select it. (AND (NOT (ATOM ITEM)) (NOT (ATOM (CDR ITEM))) (NOT (ATOM (CDDR ITEM))) (EQ (CADR ITEM) ':NO-SELECT) (SETQ ITEM NIL)) ;; Now make the blinker be where and what we have just found it should be. (BLINKER-SET-VISIBILITY BLINKER (NOT (NULL ITEM))) (SETQ CURRENT-ITEM ITEM) ;; The height of the ;; blinker (box) is changed to be the height of the item (plus on pixel on ;; each side). The Y location is (* row row-height) like it used to be, ;; PLUS A FUDGE FACTOR, which is never negative. The fudge factor takes into ;; account the difference in height of the font on this item and the row-height ;; which is actually the height of the largest font in the menu, plus a little ;; bit more. Little bit more is one-fifth of the row height, which was randomly ;; chosen to work on many menus. (COND (ITEM (FUNCALL BLINKER ':SET-SIZE-AND-CURSORPOS BLWIDTH (+ (johns-font-char-height item font-map) 2) (+ BLX ind) ;add in indentation. (1- (+ (* ROW ROW-HEIGHT) (- (send self ':vsp)) (max 0 (- row-height ;; (johns-font-baseline item font-map) (// row-height 6) )))))))) (setq items '(("foo" :value 1 :left) ("bar" :value 1) ("TESTING" :value 3 :right) ("now is the time for all good" :value 2) ("mumble" :value 3 :indent 2 :left) ("Goo" :no-select t :right))) (setq menu (tv:make-window 'left-or-right-menu ':item-list items)) (compile-flavor-methods left-or-right-menu left-highlighting-menu left-menu)