;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GARNET-GADGETS; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Motif Menu ;;; ;;; Features and operation of Motif-Menu: ;;; 1) Click the left mouse button on a menu item to select the item, ;;; or if keyboard-selection is enabled, use the arrow keys to ;;; move the keyboard-selection box. ;;; 2) If the final-feedback is enabled, a selection box will appear ;;; around the selected item. ;;; 3) The top level :value slot contains a list of strings of the ;;; currently selected items. ;;; 5) The :items slot may contain functions to be executed as each ;;; item is selected, and :menu-selection-function may contain a ;;; function to be executed when there is a change in the currently ;;; selected items. ;;; 6) The :accelerators slot may contain a list of character/string ;;; pairs that determine which character in the item string to ;;; underline and a description of the key sequence that will ;;; execute a menu selection directly. ;;; ;;; Customizable slots: ;;; 1) Left, top ;;; 2) Min-frame-width ;;; 3) Text-offset -- The distance from the longest string to the frame. ;;; 4) V-spacing -- The distance between items. ;;; 5) H-align -- How to align items horizontally (:left, :center, or ;;; :right). ;;; 6) Items -- This can be: ;;; A list of strings, as in '("Large" ...), or ;;; a list of atoms, as in '(:center ...), or ;;; a list of string/function pairs, '(("Cut" Cut-FN)...)), or ;;; a list of atom/function pairs, '((:center Center-FN)...)). ;;; Each function will be executed when the associated button ;;; becomes selected. The parameters are the top-level ;;; GADGET and the ITEM-STRING. ;;; 7) Inactive-items -- A list of strings that determines which items ;;; should be gray and non-selectable. ;;; 8) Accelerators -- A list of character/string/character triples, equal ;;; in length to the :items list (or NIL). Each triple consists of ;;; the character in the corresponding item string to be underlined, ;;; a string which describes the key sequence to select the menu ;;; item directly, and the corresponding key sequence in character ;;; form. ;;; 9) Bar-above-these-items -- A bar will apear before each item in ;;; this list. ;;; 10) Item-To-String-Function -- a function which takes an ITEM and ;;; returns a string to be displayed in the menu corresponding to ;;; that item. For example, if the :items slot contains a list of ;;; Garnet schemas, then the function would return the name of a ;;; schema. If each item is a string/fn or atom/fn pair, only the ;;; CAR of the pair is sent to the :item-to-string-function. ;;; The default function assumes that :items contains a list of ;;; strings. ;;; 11) Final-feedback-p -- whether to border the selected item with a ;;; selection box. ;;; 12) Item-font, accel-font ;;; 13) Keyboard-selection-p -- Whether to allow selections by the keyboard ;;; 14) Value -- The currently selected string ;;; Foreground-Color ;;; 15) Selection-function -- Global function to be executed whenever ;;; there is a change in the list of currently selected items. ;;; Parameters are the top-level MOTIF-MENU gadget and the ;;; ITEM-OBJ that was just selected. (The name of the item that ;;; was just selected can be obtained by g-value'ing the :item slot ;;; of the ITEM-OBJ.) ;;; ;;; Motif-Menu demo: ;;; This module contains a function which creates a window and a ;;; menu. To run it, enter (GARNET-GADGETS:motif-menu-go). ;;; To stop, enter (GARNET-GADGETS:motif-menu-stop). ;;; ;;; NOTE: This module requires several schemata defined in motif-parts. ;;; Thus, motif-parts.fasl must be loaded before this module. ;;; ;;; Written by Andrew Mickish ;;; Change Log: ;;; 08/19/93 Rajan Parthasarathy - Modified :underline's :x1 & :width ;;; slots (as suggested by Poelman) in MOTIF-MENU-ITEM to consider ;;; variable width fonts. ;;; 07/26/93 Andrew Mickish - Added special proclamation to eliminate warning ;;; 06/30/93 Andrew Mickish - Fixed :fast-redraw-filling-style formula ;;; 06/22/93 Andrew Mickish - Added checks for NIL :items list in formulas ;;; for :max-item-width and :items-height. ;;; 06/16/93 Andrew Mickish - Fixed more :visible formulas to look at parent's ;;; visibility; set :old-items of aggrelist in *-local-item methods ;;; 02/23/93 Andrew Mickish - Added :string-set-func ;;; 02/22/93 Andrew Mickish - Made MOTIF-MENU-TEXT-LABEL-PROTOTYPE a stand- ;;; alone object for use in the MOTIF-MENUBAR ;;; 02/10/93 Andrew Mickish - Added items-type and accelerators-type ;;; 02/09/93 Andrew Mickish - Added dependency on :items list so that ;;; the aggrelist's :fix-update-slots method will be invoked; ;;; Removed kr-path calls from MOTIF-MENU-ITEM ;;; 01/05/93 Rajan Parthasarathy - Created MOTIF-MENU-ITEM and set it ;;; to be the prototype of MOTIF-MENU-ITEM-LIST. Also, the ;;; way to check to see if an item is active is to look at ;;; the :active-p slot of the item. Previously, it was to ;;; look up the item in the :inactive-items slot of the menu ;;; 12/15/92 Andrew Mickish - Added type and parameter declarations ;;; 06/16/92 Andrew Mickish - Added objects in :items list ;;; 04/30/92 Andrew Micksih - Called get-standard-font for fonts ;;; 02/27/92 Andrew Mickish - Removed :leftdown from MOTIF-MENU-KEY-INTER ;;; 02/11/92 Andrew Mickish - Added :maybe-constant list ;;; 11/06/91 Andrew Mickish - Changed the feedback object from a MOTIF-BOX ;;; to two fast redraw polylines ;;; 10/13/91 Andrew Mickish - Added :leftdown case in MOTIF-MENU-KEY-INTER ;;; so the keyboard selection will follow the mouse ;;; 10/08/91 Andrew Mickish - Turned off fast-redraw in selection box ;;; 05/09/91 Andrew Mickish - In MOTIF-MENU, changed :global-accel-chars, ;;; :global-accel-strings, and :local-accel-chars to contiain NIL ;;; elements when some accelerator characters are not supplied; and ;;; changed :start-event in MOTIF-MENU-ACCELERATOR-INTER to delete ;;; these NIL elements from its list ;;; 03/01/91 Andrew Mickish - Created (in-package "GARNET-GADGETS") (eval-when (eval load compile) (export '(Motif-Menu Motif-Menu-Accelerator-Inter)) #+garnet-debug (export '(Motif-Menu-Go Motif-Menu-Stop Demo-Motif-Menu Motif-Menu-Win Motif-Menu-Top-Agg)) (proclaim '(special MOTIF-BAR-ITEM))) (create-instance 'MOTIF-MENU-TEXT-LABEL-PROTOTYPE opal:text (:constant '(:actual-heightp)) (:left (o-formula (let* ((p0 (gvl :parent)) (p1 (gvl :parent :parent :parent)) (text-offset (+ (gv p1 :text-offset) (if (gv p1 :accelerators) 0 4)))) (case (gv p1 :h-align) (:left (+ (gv p0 :left) text-offset)) (:center (- (+ (gv p0 :left) (floor (gv p0 :width) 2)) (floor (gvl :width) 2))) (:right (- (+ (gv p0 :left) (gv p0 :width)) (gvl :width) text-offset)))))) (:top (o-formula (opal:gv-center-y-is-center-of (gvl :parent)))) (:string (o-formula (gv (kr-path 0 :parent) :string))) (:font (o-formula (gv (kr-path 0 :parent :parent :parent) :item-font))) (:line-style (o-formula (gv (kr-path 0 :parent) :line-style))) (:fast-redraw-p :rectangle) (:fast-redraw-filling-style (o-formula (gv (kr-path 0 :parent :parent :parent) :foreground-fill)))) ;;; ;;; Can't use kr-path in ouside references from MOTIF-MENU-ITEM because ;;; instances can be manipulated as independent components in the menubar. ;;; (create-instance 'MOTIF-MENU-ITEM opal:aggregadget (:left (o-formula (gvl :parent :left))) (:top (o-formula (+ (gvl :parent :top) (* (gvl :rank) (gvl :parent :parent :item-height))))) (:width (o-formula (gvl :parent :width))) (:height (o-formula (gvl :parent :parent :item-height))) (:char (o-formula (let ((chars (gvl :parent :parent :local-accel-chars))) (if chars (nth (gvl :rank) chars))))) (:accel-string (o-formula (let ((strings (gvl :parent :parent :global-accel-strings))) (if strings (nth (gvl :rank) strings))))) ;; Conditional formulas are required to allow either a list of ;; strings or a list of string/function pairs in the :items slot. (:item-obj (o-formula (nth (gvl :rank) (gvl :parent :parent :item-objs)))) (:string (o-formula (progn ;; Invoke invalidate-demon on aggrelist's :items slot ;; so that :fix-update-slots method will be called (gvl :parent :items) (nth (gvl :rank) (gvl :parent :parent :strings))))) (:action (o-formula (nth (gvl :rank) (gvl :parent :parent :actions)))) (:active-p (o-formula (not (member (gvl :item-obj) (gvl :parent :parent :inactive-items) :test #'equal)))) (:line-style (o-formula (if (gvl :active-p) opal:default-line-style (gvl :parent :parent :stippled-line-style)))) (:visible (o-formula (let ((parent (gvl :parent))) (and (or (null parent) (gv parent :visible)) (not (equal (gvl :string) "")))))) (:parts `((:item-text ,#'opal::Panel-Get-Label) (:accel-text ,opal:text (:constant (:actual-heightp)) (:left ,(o-formula (let ((p (gvl :parent :parent :parent))) (- (gv p :right) (gv p :text-offset) (gvl :width) 4)))) (:top ,(o-formula (gv (kr-path 0 :parent :item-text) :top))) (:string ,(o-formula (or (gv (kr-path 0 :parent) :accel-string) ""))) (:font ,(o-formula (gvl :parent :parent :parent :accel-font))) (:visible ,(o-formula (and (gv (kr-path 0 :parent) :visible) (not (string= "" (gvl :string)))))) (:line-style ,(o-formula (gv (kr-path 0 :parent) :line-style))) (:fast-redraw-p :rectangle) (:fast-redraw-filling-style ,(o-formula (gvl :parent :parent :foreground-fill)))) (:underline ,opal:line (:width ,(o-formula (opal:string-width (gv (kr-path 0 :parent :item-text) :font) (string (gv (kr-path 1 :parent) :char))))) (:x1 ,(o-formula (+ (gv (kr-path 0 :parent :item-text) :left) (opal:string-width (gv (kr-path 0 :parent :item-text) :font) (gv (kr-path 0 :parent :item-text) :string) :end (position (gv (kr-path 1 :parent) :char) (gv (kr-path 0 :parent :item-text) :string)))))) (:y1 ,(o-formula (- (+ (gv (kr-path 0 :parent :item-text) :top) (gv (kr-path 0 :parent :item-text) :height)) 1))) (:x2 ,(o-formula (+ (gvl :x1) (gvl :width)))) (:y2 ,(o-formula (gvl :y1))) (:visible ,(o-formula (and (gv (kr-path 0 :parent) :visible) (gv (kr-path 0 :parent) :char)))) (:line-style ,(o-formula (gv (kr-path 0 :parent) :line-style))) (:fast-redraw-p :rectangle) (:fast-redraw-filling-style ,(o-formula (gvl :parent :parent :foreground-fill)))) ))) (create-instance 'MOTIF-MENU-ITEM-LIST opal:aggrelist (:constant '(:rank-margin :pixel-margin :fixed-width-p :fixed-height-p :direction)) (:left (o-formula (+ 2 (gv (kr-path 0 :parent) :left)))) (:top (o-formula (+ 2 (gv (kr-path 0 :parent) :top)))) (:width (o-formula (- (gv (kr-path 0 :parent) :frame-width) 4))) (:height (o-formula (gv (kr-path 0 :parent) :items-height))) (:direction NIL) (:items (o-formula (gv (kr-path 0 :parent) :items))) (:item-to-string-function (o-formula (gv (kr-path 0 :parent) :item-to-string-function))) (:item-prototype MOTIF-MENU-ITEM)) (create-instance 'MOTIF-MENU-BAR-LIST opal:aggrelist (:constant '(:rank-margin :pixel-margin :fixed-width-p :fixed-height-p :direction)) (:left (o-formula (+ 4 (gv (kr-path 0 :parent) :left)))) (:top (o-formula (+ 4 (gv (kr-path 0 :parent) :top)))) (:width (o-formula (- (gv (kr-path 0 :parent) :frame-width) 8))) (:height (o-formula (gv (kr-path 0 :parent) :items-height))) (:direction NIL) (:items (o-formula (gv (kr-path 0 :parent) :bar-above-these-items))) (:item-prototype `(,opal:aggregadget (:left ,(o-formula (gv (kr-path 0 :parent) :left))) (:top ,(o-formula (gvl :obj-after :top))) (:width ,(o-formula (gv (kr-path 0 :parent) :width))) (:height ,(o-formula (gv (kr-path 0 :parent) :height))) (:item-after ,(o-formula (nth (gvl :rank) (gv (kr-path 0 :parent) :items)))) (:obj-after ,(o-formula (let* ((menu (kr-path 0 :parent :parent)) (components (gv menu :menu-item-list :components)) (item (gvl :item-after)) (item-rank (position item (gv menu :item-objs) :test #'equal))) (nth item-rank components)))) (:parts ((:top-line ,opal:line (:x1 ,(o-formula (gv (kr-path 0 :parent) :left))) (:y1 ,(o-formula (gv (kr-path 0 :parent) :top))) (:x2 ,(o-formula (+ (gvl :x1) (gv (kr-path 0 :parent) :width)))) (:y2 ,(o-formula (gvl :y1))) (:line-style ,(o-formula (gv (kr-path 0 :parent :parent :parent) :thin-shadow-line-style)))) (:bot-line ,opal:line (:x1 ,(o-formula (gv (kr-path 0 :parent) :left))) (:y1 ,(o-formula (+ 1 (gv (kr-path 0 :parent) :top)))) (:x2 ,(o-formula (+ (gvl :x1) (gv (kr-path 0 :parent) :width)))) (:y2 ,(o-formula (gvl :y1))) (:line-style ,(o-formula (gv (kr-path 0 :parent :parent :parent) :thin-highlight-line-style))))))))) (create-instance 'MOTIF-MENU-KEY-INTER inter:button-interactor (:active (o-formula (and (gvl :window) (gvl :operates-on :keyboard-selection-p)))) (:window (o-formula (gv-local :self :operates-on :window))) (:continuous NIL) (:start-where T) (:start-event (list #\return :uparrow :rightarrow :downarrow :leftarrow)) (:final-function #'(lambda (interactor obj) (declare (ignore obj)) (let* ((char (inter:event-char inter:*Current-Event*)) (gadget (g-value interactor :operates-on)) (selection (g-value gadget :keyboard-selection-obj)) ;; Multiple selection not implemented (prev-sel (g-value gadget :value-obj))) (case char (#\return (let ((item-obj (g-value gadget :keyboard-selection)) (action (g-value selection :action))) ;; Propagate new selection toward :value slot (s-value gadget :value-obj selection) ;; Make interim feedback flash (s-value selection :interim-selected T) (s-value selection :selected T) (if (and prev-sel (not (eq prev-sel selection))) (s-value prev-sel :selected NIL)) (opal:update (g-value gadget :window)) (sleep .25) (s-value selection :interim-selected NIL) ;; Global function for all items (kr-send gadget :selection-function gadget selection) ;; Local function assigned to item (when action (funcall action gadget item-obj)))) #| (:leftdown (let ((obj (motif-element-of-not-illegal (g-value gadget :menu-item-list) interactor inter:*Current-Event*))) (when (and obj (g-value obj :active-p)) (s-value gadget :keyboard-selection (g-value obj :item-obj))))) |# ((:downarrow :rightarrow) (let* ((prev-rank (g-value selection :rank)) (menu-item-list (g-value gadget :menu-item-list)) (items (g-value menu-item-list :components)) (max-rank (g-value menu-item-list :tail :rank))) (do* ((rank (if (= prev-rank max-rank) 0 (+ 1 prev-rank)) (if (= rank max-rank) 0 (+ 1 rank))) (item (nth rank items) (nth rank items))) ((g-value item :active-p) (s-value gadget :keyboard-selection (g-value item :item-obj)))))) ((:uparrow :leftarrow) (let* ((prev-rank (g-value selection :rank)) (menu-item-list (g-value gadget :menu-item-list)) (items (g-value menu-item-list :components)) (max-rank (g-value menu-item-list :tail :rank))) (do* ((rank (if (> prev-rank 0) (- prev-rank 1) max-rank) (if (> rank 0) (- rank 1) max-rank)) (item (nth rank items) (nth rank items))) ((g-value item :active-p) (s-value gadget :keyboard-selection (g-value item :item-obj))))))))))) (create-instance 'MOTIF-MENU-ACCEL-INTER inter:button-interactor (:active (o-formula (and (gvl :window) (gvl :operates-on :keyboard-selection-p)))) (:window (o-formula (gv-local :self :operates-on :window))) (:continuous NIL) (:start-where T) (:start-event (list :any-keyboard :except #\return :uparrow :rightarrow :downarrow :leftarrow)) (:final-function #'(lambda (interactor obj) (declare (ignore obj)) (let* ((gadget (g-value interactor :operates-on)) (char (inter:event-char inter:*Current-Event*)) (accel-chars (g-value gadget :local-accel-chars)) (rank (position char accel-chars))) (when (and rank (g-value gadget :keyboard-selection-p)) (let* ((selection (nth rank (g-value gadget :menu-item-list :components))) (action (g-value selection :action)) (prev-sel (g-value gadget :value-obj))) (when (g-value (nth rank (g-value gadget :menu-item-list :components)) :active-p) ;; Propagate new selection toward :value slot (s-value gadget :value-obj selection) (s-value selection :selected T) (if (and prev-sel (not (eq prev-sel selection))) (s-value prev-sel :selected NIL)) ;; Make interim feedback flash if no final-feedback (unless (g-value gadget :final-feedback-p) (s-value selection :interim-selected T) (opal:update (g-value gadget :window)) (sleep .25) (s-value selection :interim-selected NIL)) ;; Global function for all items (kr-send gadget :selection-function gadget selection) ;; Local function assigned to item. ;; If this is in a menubar, you have to call the item ;; function with THREE arguments. Otherwise, with 2 args (when action (if (AND (g-value gadget :bar-item) (boundp 'MOTIF-BAR-ITEM) (is-a-p (g-value gadget :bar-item) MOTIF-BAR-ITEM)) (funcall action (g-value gadget :bar-item :parent :parent) ;; The menubar (g-value gadget :bar-item :menu-obj) ;; The bar-item (g-value selection :item-obj)) ;; The item (funcall action gadget (g-value selection :item-obj))))))))))) (create-instance 'MOTIF-MENU-PRESS-INTER inter:menu-interactor (:window (o-formula (gv-local :self :operates-on :window))) (:start-where (o-formula (list :custom (gvl :operates-on :menu-item-list) #'Motif-Element-Of-Not-Illegal))) (:feedback-obj (o-formula (gvl :operates-on :feedback-obj-topline))) (:how-set :set) ;; I don't know why this was here ; (:start-action ; #'(lambda (interactor first-obj) ; (let* ((gadget (g-value interactor :operates-on))) ; (s-value gadget :value-obj NIL)) ; (call-prototype-method interactor first-obj))) (:stop-action #'(lambda (interactor obj-under-mouse) (let* ((gadget (g-value interactor :operates-on)) (action (g-value obj-under-mouse :action))) (s-value obj-under-mouse :interim-selected NIL) (s-value gadget :value-obj obj-under-mouse) ;; Global function executed whenever selections change (kr-send gadget :selection-function gadget obj-under-mouse) ;; Local function assigned to item ;; If this is in a menubar, you have to call the item ;; function with THREE arguments. Otherwise, with 2 args (when action (if (AND (g-value gadget :bar-item) (boundp 'MOTIF-BAR-ITEM) (is-a-p (g-value gadget :bar-item) MOTIF-BAR-ITEM)) (funcall action (g-value gadget :bar-item :parent :parent) ;; The menubar (g-value gadget :bar-item :menu-obj) ;; The bar-item (g-value obj-under-mouse :item-obj)) ;; The item (funcall action gadget (g-value obj-under-mouse :item-obj)))))))) (create-instance 'MOTIF-MENU MOTIF-GADGET-PROTOTYPE :declare ((:parameters :left :top :min-frame-width :text-offset :v-spacing :h-align :items :accelerators :bar-above-these-items :inactive-items :item-font :accel-font :item-to-string-function :final-feedback-p :foreground-color :value :selection-function :visible) (:type ((integer 0) :min-frame-width) (integer :text-offset :v-spacing) ((member :left :center :right) :h-align) (accelerators-type :accelerators) (items-type :items :inactive-items :bar-above-these-items) ((or function symbol) :item-to-string-function) (kr-boolean :keyboard-selection-p) ((or null string keyword (satisfies schema-p)) :keyboard-selection :value) ((or null (satisfies schema-p)) :keyboard-selection-obj :value-obj) ((or (is-a-p opal:font) (is-a-p opal:font-from-file)) :item-font :accel-font) ((is-a-p opal:color) :foreground-color) ((or null function symbol) :selection-function)) (:maybe-constant :left :top :min-frame-width :text-offset :h-align :v-spacing :items :accelerators :bar-above-these-items :item-to-string-function :final-feedback-p :foreground-color :item-font :accel-font :visible)) (:left 0) (:top 0) (:min-frame-width 0) (:text-offset 6) (:v-spacing 8) (:h-align :left) (:items '("Menu 1" "Menu 2" "Menu 3" "Menu 4" "Menu 5")) (:inactive-items NIL) (:accelerators NIL) (:bar-above-these-items NIL) (:item-to-string-function #'(lambda (item) (if item (if (or (stringp item) (schema-p item)) item (string-capitalize (string-trim ":" item))) ""))) (:final-feedback-p T) (:foreground-color opal:MOTIF-GRAY) (:item-font opal:default-font) (:accel-font opal:default-font) (:keyboard-selection-p NIL) (:keyboard-selection (o-formula (first (last (set-exclusive-or (gvl :item-objs) (gvl :inactive-items) :test #'equal))))) (:keyboard-selection-obj (o-formula (let ((rank (position (gvl :keyboard-selection) (gvl :item-objs) :test #'equal))) (nth rank (g-value (gvl :menu-item-list) :components))))) (:selection-function NIL) (:value-obj NIL) (:value (o-formula (let ((obj (gvl :value-obj))) (if obj (g-value obj :item-obj))))) (:item-objs (o-formula (let ((items (gvl :items))) (if (listp (first items)) (mapcar #'car items) items)))) (:strings (o-formula (let ((fn (gvl :item-to-string-function))) (declare (ignore fn)) (mapcar #'(lambda (item-obj) (kr-send (gv :self) :item-to-string-function item-obj)) (gvl :item-objs))))) (:actions (o-formula (let ((items (gvl :items))) (when (listp (first items)) (mapcar #'cadr items))))) (:local-accel-chars (o-formula (let ((accels (gvl :accelerators))) (if accels (mapcar #'first accels))))) (:global-accel-strings (o-formula (let ((accels (gvl :accelerators))) (if accels (mapcar #'second accels))))) (:global-accel-chars (o-formula (let ((accels (gvl :accelerators))) (if accels (mapcar #'third accels))))) (:max-item-width (o-formula (do* ((item-strings (gvl :strings)) (number-of-items (length item-strings)) (accels (if (gvl :accelerators) (gvl :global-accel-strings) (make-list number-of-items :initial-element ""))) (item-font (gvl :item-font)) (accel-font (gvl :accel-font)) (i 0 (+ i 1)) (item-str (nth i item-strings) (nth i item-strings)) (accel-str (nth i accels) (nth i accels)) (str-width (if (schema-p item-str) (g-value item-str :width) (if item-str (opal:string-width item-font item-str) ;; The case for a NULL :items list 0)) (if (schema-p item-str) (g-value item-str :width) (if item-str (opal:string-width item-font item-str) 0))) (accel-width (if accel-str (opal:string-width accel-font accel-str) 0) (if accel-str (opal:string-width accel-font accel-str) 0)) (max-width (+ str-width accel-width) (let ((width (+ str-width accel-width))) (if (> width max-width) width max-width)))) ((= i number-of-items) (+ max-width (* 2 (gvl :text-offset)) (if (gvl :accelerators) (gvl :text-offset) 0)))))) (:frame-width (o-formula (+ 12 (MAX (gvl :max-item-width) (gvl :min-frame-width))))) (:frame-height (o-formula (+ 4 (gvl :items-height)))) (:item-height (o-formula (+ (gvl :v-spacing) (MAX (let ((max-schema-height 0)) (dolist (s (gvl :strings)) (if (schema-p s) (setq max-schema-height (MAX max-schema-height (g-value s :height))))) max-schema-height) (opal:string-height (gvl :item-font) "X") (if (gvl :accelerators) (opal:string-height (gvl :accel-font) "X") 0))))) (:items-height (o-formula (let ((items (gvl :items))) (if items (* (length items) (gvl :item-height)) 0)))) (:width (o-formula (gvl :frame-width))) (:height (o-formula (gvl :frame-height))) (:right (o-formula (+ (gvl :left) (gvl :width)))) (:active-p (o-formula (> (length (gvl :items)) (length (gvl :inactive-items))))) (:text-label-prototype MOTIF-MENU-TEXT-LABEL-PROTOTYPE) (:parts `((:FRAME ,MOTIF-BOX (:constant (:depressed-p)) (:left ,(o-formula (gv (kr-path 0 :parent) :left))) (:top ,(o-formula (gv (kr-path 0 :parent) :top))) (:width ,(o-formula (gv (kr-path 0 :parent) :frame-width))) (:height ,(o-formula (gv (kr-path 0 :parent) :frame-height))) (:depressed-p NIL)) (:MENU-ITEM-LIST ,MOTIF-MENU-ITEM-LIST) (:BAR-LIST ,MOTIF-MENU-BAR-LIST) (:FEEDBACK-OBJ-TOPLINE ,opal:polyline (:feedback-width ,(o-formula (- (gv (kr-path 0 :parent) :frame-width) 10))) (:feedback-height ,(o-formula (- (gv (kr-path 0 :parent) :item-height) 6))) (:point-list ,(o-formula (let* ((p (kr-path 0 :parent)) (left (+ 5 (gv p :left))) (top (+ 3 (gvl :obj-over :top)))) (list left (+ top (gvl :feedback-height)) left top (+ left (gvl :feedback-width)) top)))) ;; Set by interactors -- guarantee NIL if no menu-items are active (:obj-over ,(o-formula (let* ((p (kr-path 0 :parent)) (value (gv p :value))) (unless (member value (gv p :inactive-items) :test #'equal) (gv p :value-obj))))) (:visible ,(o-formula (let ((obj-over (gvl :obj-over))) (and obj-over (or (gv obj-over :interim-selected) (gv (kr-path 0 :parent) :final-feedback-p)) (gv (kr-path 0 :parent) :visible))))) (:line-style ,(o-formula (gv (kr-path 0 :parent) :highlight-line-style))) (:fast-redraw-p :redraw) (:fast-redraw-line-style ,(o-formula (gv (kr-path 0 :parent) :foreground-line-style)))) (:FEEDBACK-OBJ-BOTTOMLINE ,opal:polyline (:point-list ,(o-formula (let* ((left (+ 5 (gv (kr-path 0 :parent) :left))) (top (+ 3 (gvl :obj-over :top))) (p1 (kr-path 1 :parent :feedback-obj-topline)) (bottom (+ top (gv p1 :feedback-height))) (right (+ left (gv p1 :feedback-width)))) (list right top right bottom left bottom)))) (:obj-over ,(o-formula (gv (kr-path 0 :parent :feedback-obj-topline) :obj-over))) (:visible ,(o-formula (gv (kr-path 0 :parent :feedback-obj-topline) :visible))) (:line-style ,(o-formula (gv (kr-path 0 :parent) :shadow-line-style))) (:fast-redraw-p :redraw) (:fast-redraw-line-style ,(o-formula (gv (kr-path 0 :parent) :foreground-line-style)))) (:SEL-BOX ,MOTIF-SELECTION-BOX (:fast-redraw-p NIL) (:draw-function :copy) (:fast-redraw-line-style NIL)))) (:interactors `((:PRESS ,motif-menu-press-inter) (:ACCEL ,motif-menu-accel-inter) (:KEY ,motif-menu-key-inter)))) ;;; This interactor is used in conjunction with a set of motif-menu gadgets ;;; to implement the global accelerator feature. An instance of this ;;; interactor is supplied with a list of motif-menu instances and the window ;;; in which those menus appear. Then, whenever a global accelerator key ;;; is pressed in the window, the corresponding item functions will be ;;; executed. (create-instance 'MOTIF-MENU-ACCELERATOR-INTER inter:button-interactor :declare ((:parameters :window :menus :start-where :start-event :accel-chars :waiting-priority :running-priority :stop-action :final-function) (:type ((or list (is-a-p inter:interactor-window)) :window) (list :menus :accel-chars) ((or list (member T)) :start-where) ((or keyword character list) :start-event) ((is-a-p inter:priority-level) :waiting-priority :running-priority) ((or null function symbol) :stop-action :final-function))) (:window NIL) (:menus NIL) (:continuous NIL) (:start-where T) (:start-event (o-formula (remove NIL (multiple-value-call #'append (values-list (gvl :accel-chars)))))) (:accel-chars (o-formula (mapcar #'(lambda (menu) (gv menu :global-accel-chars)) (gvl :menus)))) (:waiting-priority MOTIF-TAB-PRIORITY-LEVEL) (:running-priority MOTIF-TAB-PRIORITY-LEVEL) (:stop-action #'(lambda (interactor obj-over) ;; First get the menu and item ranks corresponding to the accelerator (let ((menu-rank NIL) (char-rank NIL)) (do* ((char (g-value interactor :start-char)) (accel-chars (g-value interactor :accel-chars)) (local-menu-rank 0 (+ 1 local-menu-rank)) (menu-chars (nth local-menu-rank accel-chars) (nth local-menu-rank accel-chars)) (local-char-rank (position char menu-chars) (position char menu-chars))) (local-char-rank (progn (setf menu-rank local-menu-rank) (setf char-rank local-char-rank)))) (let* ((menu (nth menu-rank (g-value interactor :menus))) (selection (nth char-rank (g-value menu :menu-item-list :components))) (action (g-value selection :action)) (prev-sel (g-value menu :value-obj))) ;; Check to see whether corresponding item is inactive (when (g-value selection :active-p) ;; Propagate new selection toward :value slot (s-value menu :value-obj selection) (s-value selection :selected T) (if (and prev-sel (not (eq prev-sel selection))) (s-value prev-sel :selected NIL)) ;; Make interim feedback flash if no final-feedback (unless (g-value menu :final-feedback-p) (s-value selection :interim-selected T) (opal:update (g-value menu :window)) (sleep .25) (s-value selection :interim-selected NIL)) ;; Execute associated functions (kr-send menu :selection-function menu selection) ;; Local item function. ;; If this is in a menubar, you have to call the item ;; function with THREE arguments, otherwise, with 2 args. (when action (if (AND (g-value menu :bar-item) (boundp 'MOTIF-BAR-ITEM) (is-a-p (g-value menu :bar-item) MOTIF-BAR-ITEM)) (funcall action (g-value menu :bar-item :parent :parent) ;; The menubar (g-value menu :bar-item :menu-obj) ;; The bar-item (g-value selection :item-obj)) ;; The item (funcall action menu (g-value selection :item-obj)))))) ;; Gotta check this to see that the interactor wasn't already ;; destroyed. (when (schema-p interactor) ;; Now execute the user's :final-function (kr-send interactor :final-function interactor obj-over)))))) (define-method :add-local-item MOTIF-MENU (gadget item &rest args) (let ((accel NIL) where locator key) ;; Strip off and bind the accelerator (if there is one) (when (eq :accelerator (first args)) ;; accel will be the user's new accelerator character (setf accel (second args)) (setf args (cddr args))) ;; Get where as usual (multiple-value-setq (where locator key) (opal::get-wheres args)) (let* ((old-items (or (g-local-value gadget :items) (copy-list (g-value gadget :items)))) (items (opal::insert-item item old-items where locator key)) (rank (position item items :test #'(lambda (x y) (equal x (funcall key y))))) (alist (g-value gadget :menu-item-list))) (s-value alist :old-items (s-value gadget :items items)) (if accel (s-value gadget :accelerators (opal::insert-item accel (g-value gadget :accelerators) :at rank #'opal:no-func))) (opal::Add-The-Component (g-value gadget :menu-item-list) rank)))) (define-method :add-item MOTIF-MENU (gadget item &rest args) "This function takes an :accelerator key, and also takes the standard 'where' keywords. The :accelerator key must appear before the 'where' keys, since all keyword parameters are handled manually within the function." (let ((accel NIL) where locator key) ;; Strip off and bind the accelerator (if there is one) (when (eq :accelerator (first args)) ;; accel will be the list of the :accelerator keyword and the user's ;; new accelerator character (setf accel args) (setf args (cddr args)) (setf (cddr accel) NIL)) ;; Get where as usual (multiple-value-setq (where locator key) (opal::get-wheres args)) ;; Insert the item in the items list as usual (eval `(opal:add-local-item ,gadget ,item ,@accel ,where ,locator ,key)) (let ((rank (position item (g-value gadget :items) :test #'(lambda (x y) (equal x (funcall key y)))))) (dolist (inst (g-value gadget :is-a-inv)) (unless (has-slot-p inst :items) (opal::Recursive-Add-Component (g-value inst :menu-item-list) rank)))))) (define-method :remove-local-item MOTIF-MENU (gadget &optional item &key (key #'opal:no-func)) (let* ((items (or (g-local-value gadget :items) (copy-list (g-value gadget :items)))) (accels (or (g-local-value gadget :accelerators) (copy-list (g-value gadget :accelerators)))) (rank (if item (position item items :test #'(lambda (x y) (equal x (funcall key y)))) (1- (length items)))) (alist (g-value gadget :menu-item-list))) ;; Gadgets always have lists for their :items values, so don't consider ;; the case where the value of :items is a number. (s-value alist :old-items (s-value gadget :items (opal::delete-elt (or item (nth rank items)) items key))) (if accels (s-value gadget :accels (opal::delete-elt (nth rank accels) items key))) ;; Before destroying the component, remove the item from it (let* ((comp-to-destroy (nth rank (g-value alist :components)))) (if (and (schema-p item) (g-value item :parent) (opal::Is-In-Hierarchy comp-to-destroy item)) (let ((kr::*constants-disabled* T)) (opal:remove-local-component (g-value item :parent) item))) (if (g-value comp-to-destroy :parent) (opal:remove-local-component alist comp-to-destroy)) (opal:destroy comp-to-destroy)))) (define-method :remove-item MOTIF-MENU (gadget &optional item &key (key #'opal::no-func)) (opal::Gadget-Remove-Item gadget item :menu-item-list key)) (s-value MOTIF-MENU :change-item (g-value opal:aggrelist :change-item)) (s-value MOTIF-MENU :remove-nth-item (g-value opal:aggrelist :remove-nth-item)) (define-method :string-set-func MOTIF-MENU (gadget-obj str-obj final-event final-string) (let ((aggrel (g-value gadget-obj :MENU-ITEM-LIST))) (opal::Aggrelist-Edit-String-Func gadget-obj aggrel str-obj final-event final-string :rank))) ;;; ;;; DEMO FUNCTION ;;; #+garnet-debug (defvar BOLD-FONT (opal:get-standard-font NIL :bold NIL)) #+garnet-debug (defun MOTIF-MENU-GO (&key dont-enter-main-event-loop not-double-buffered-p) (create-instance 'MOTIF-MENU-WIN inter:interactor-window (:double-buffered-p (not not-double-buffered-p)) (:title "Motif Menu") (:left 750)(:top 10)(:width 210)(:height 200) (:background-color opal:motif-blue)) (s-value MOTIF-MENU-WIN :aggregate (create-instance 'MOTIF-MENU-TOP-AGG opal:aggregate)) (create-instance 'DEMO-MOTIF-MENU MOTIF-MENU (:left 34) (:top 20) (:foreground-color opal:MOTIF-BLUE) (:items `(("Restore size" Restore-Size-Fn) ("Move window" Move-Window-Fn) ("Resize window" Resize-Window-Fn) ("Iconify window" Iconify-Window-Fn) ("Full-zoom" Full-Zoom-Fn) ("Lower window" Lower-Window-Fn) ("Kill window" Kill-Window-Fn))) (:inactive-items '("Restore size")) (:accelerators '((#\R "F2" :F2) (#\M "F3" :F3) (#\s "F4" :F4) (#\I "F5" :F5) (#\F "F6" :F6) (#\L "F7" :F7) (#\K "F8" :F8))) (:bar-above-these-items '("Kill window")) (:item-font BOLD-FONT) (:accel-font BOLD-FONT) (:keyboard-selection-p T) (:selection-function #'(lambda (gadget item-obj) (declare (ignore gadget)) (format t "Selected ~S.~%" (g-value item-obj :item-obj))))) (create-instance 'DEMO-MOTIF-MENU-ACCELERATOR-INTER MOTIF-MENU-ACCELERATOR-INTER (:window MOTIF-MENU-WIN) (:menus (list DEMO-MOTIF-MENU))) (opal:add-components MOTIF-MENU-TOP-AGG DEMO-MOTIF-MENU) (opal:update MOTIF-MENU-WIN) (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop)) ) #+garnet-debug (defun MOTIF-MENU-STOP () (opal:destroy MOTIF-MENU-WIN)) #+garnet-debug (defun Restore-Size-Fn (g v) (declare (ignore g v)) (format t "Restore-Size-Fn called~%~%")) #+garnet-debug (defun Move-Window-Fn (g v) (declare (ignore g v)) (format t "Move-Window-Fn called~%~%")) #+garnet-debug (defun Resize-Window-Fn (g v) (declare (ignore g v)) (format t "Resize-Window-Fn called~%~%")) #+garnet-debug (defun Iconify-Window-Fn (g v) (declare (ignore g v)) (format t "Iconify-Window-Fn called~%~%")) #+garnet-debug (defun Full-Zoom-Fn (g v) (declare (ignore g v)) (format t "Full-Zoom-Fn called~%~%")) #+garnet-debug (defun Lower-Window-Fn (g v) (declare (ignore g v)) (format t "Lower-Window-Fn called~%~%")) #+garnet-debug (defun Kill-Window-Fn (g v) (declare (ignore g v)) (format t "Kill-Window-Fn called~%~%"))