;;; -*- 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 Menubar
;;;
;;;
;;;  Customizable slots:
;;;    1)  Left, top
;;;    3)  Title-font, item-font, accel-font
;;;    5)  Selection-function - a function to be executed when any item is
;;;           selected.  Takes the parameters (gadget menu-item submenu-item).
;;;    6)  Items - A list with the format
;;;           '(("m1" m1func ("m1,1"..."m1,N"))
;;;             ("m2" m2func (("m2,1" m2,1func)...("m2,N" m2,Nfunc)))
;;;             ...)
;;;           Where "mN" is a string or atom that is the title of a menu,
;;;        "mX,Y" is a string or atom in menu X, row Y,
;;;        mNfunc is executed when any item in menu N is selected,
;;;        mX,Yfunc is executed when item mX,Y is selected.
;;;           These two functions take the same parameters as the
;;;        selection-function.
;;;    7)  Accelerators - A list of accelerators, with the format
;;;             '((("s11" key11) .. ("s1N" key1N))
;;;               (("s21" key21) .. ("s2N" key2N))
;;;               ...)
;;;          where sXY is the accelarator string for the Yth submenu-item
;;;          in the Xth bar-item of the menubar; keyXY is the keyboard
;;;          event that starts the accelerator for the Yth submenu-item in
;;;          the Xth bar-item.
;;;    8)  Bar-Above-These-Items - A list of item-objs, with the format
;;;            '((ob11 ... ob1N)
;;;              (ob21 ... ob2N)
;;;              ...)
;;;           where obXY is the object in the Yth submenu-item of the Xth
;;;           bar-item above which a line should appear.
;;;    9)  Min-Menubar-Width - How big the menubar should be.  If it is too
;;;           small, or 0, this slot is ignored.
;;;
;;;  Programming interface (Garnet way):
;;;    1) Create an instance of motif-menubar with a value for the :items slot
;;;    2) Use opal:add-component to put the instance in a window
;;;
;;;  Caveats:
;;;     New motif-bar-items should be created with the :enable slot set to NIL
;;;  in order to keep their windows from being updated before they are added to
;;;  a menubar.

;;;  Pull Down Menus Demo:
;;;    The function below creates a window containing a pull down menu and
;;;    some text objects, as well as accelerators and bars.
;;;    Choosing an item from the pull-down menu will change the font of the
;;;    text objects.
;;;    To run it, enter (GARNET-GADGETS:motif-menubar-go).
;;;    To stop, enter (GARNET-GADGETS:motif-menubar-stop).
;;;
;;;  Designed and Implemented by Rajan Parthasarathy
;;;  Based heavily upon the GARNET menubar by Andrew Mickish & Pavan Reddy
;;;
;;;  CHANGE LOG:
;;;

;;;  06/22/93  Andrew Mickish - Set :rank slot in :add-item methods
;;;  06/15/93  Andrew Mickish - Removed references to :number-of-comps;
;;;             Added :do-not-dump-slots for BAR-ITEM; Called Check-Bar-Item
;;;             in Make-Bar-Item;  In :abort-action, check prev-baritem
;;;             is non-NIL before s-valuing it; Added :fix-update-slots method
;;;             for MOTIF-BAR-ITEM
;;;  06/10/93  Andrew Mickish - Moved MOTIF-MENU-ITEM modifications (like the
;;;             :active-p formula) into the MOTIF-SUBMENU definition
;;;  05/16/93  Andrew Mickish - Put :width and :height formulas in BAR-ITEM
;;;  04/23/93  Andrew Mickish - Added :do-not-dump-slots
;;;  04/22/93  Andrew Mickish - Added :active-p
;;;  04/18/93  Andrew Mickish - Removed ,@ from MOTIF-BAR-ITEM's :add-item
;;;             method
;;;  04/13/93  Andrew Mickish - Fixed bugs in change of 03/08/93
;;;  03/17/93  Brad Myers - add special-popdown functions for gilt, etc.
;;;  03/08/93  Andrew Mickish - Fixed :left and :top formulas of submenu-window
;;;             so that offset is correct when menubar is in a subwindow;
;;;             Type check :items with Check-Menubar-Items;  Added some slots
;;;             to type declarations.
;;;  03/03/93  Andrew Mickish - Fixed :string-set-func to work with bar-items
;;;  02/24/93  Andrew Mickish - Added :string-set-func
;;;  02/23/93  Andrew Mickish - Eliminated need to call notice-items-changed
;;;             on the menubar (but apparently must be called internally on
;;;             new submenus... Argh!)
;;;  02/10/93  Andrew Mickish - Fixed typo (:font ---> :item-font) in
;;;              MOTIF-SUBMENU, added :accel-font
;;;  02/08/93  Andrew Mickish - :notice-items-changed ---> :fix-update-slots
;;;  01/07/93  Rajan Parthasarathy - Created

(in-package "GARNET-GADGETS" :use '("LISP" "KR"))

(export '(MOTIF-MENUBAR MOTIF-BAR-ITEM MAKE-MOTIF-SUBMENU-WIN
	  
	  ; Creation Functions
	  Make-Motif-Menubar Make-Motif-Bar-Item Make-Motif-Submenu-Item))

; Demo things
#+garnet-debug
(export '(MOTIF-MENUBAR-GO MOTIF-MENUBAR-STOP DEMO-MOTIF-MENUBAR
	  MOTIF-MENUBAR-WIN MOTIF-MENUBAR-TOP-AGG))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; First function is to display the submenu from gilt, etc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Returns the new window if and only if a different bar-item is to be
;; displayed.  Gadget parameter is the top level menubar.
(defun Motif-Menubar-popup-item (gadget)
  (let (bar-item)
    ;; first, find the MOTIF-BAR-ITEM that is under the mouse
    (setq bar-item (opal:point-to-component (g-value gadget :menubar-items)
				      (inter:event-x inter:*current-event*)
				      (inter:event-y inter:*current-event*)))
    (when bar-item
      (DoSpecialPopUpMenubar gadget bar-item))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Returns a window that an instance of MOTIF-SUBMENU can be put into

(defun MAKE-MOTIF-SUBMENU-WIN (a-bar-item a-submenu)
  (let ((win
	 (create-instance NIL inter:interactor-window
	   (:bar-item a-bar-item)
	   (:aggregate a-submenu)
	   (:background-color (o-formula (gvl :bar-item :parent
					      :parent :foreground-color)))
	   (:border-width 0)
	   (:win-submenu a-submenu)
	   (:omit-title-bar-p T)
	   (:save-under T)         
	   (:double-buffered-p T)  
	   (:visible NIL)
	   (:height (o-formula
		     (gvl :win-submenu :height)))
	   (:width (o-formula
		    (gvl :win-submenu :width)))
	   (:left (o-formula
		   (let* ((bar-item (gvl :bar-item))
			  (win (gv bar-item :window))
			  (left-offset 0))
		     (cond
		       (win
			(do ((parent (gv win :parent) (gv parent :parent)))
			    ((null parent) left-offset)
			  (setf left-offset
				(+ left-offset (gv parent :left)
				   (or (gv parent :left-border-width) 0))))
			(+ (gv bar-item :left) (gv win :left)
			   (gv win :left-border-width) left-offset -5))
		       (t 0)))))
	   (:top (o-formula
		  (let* ((bar-item (gvl :bar-item))
			 (win (gv bar-item :window))
			 (top-offset 0))
		    (cond
		      (win
		       (do ((parent (gv win :parent) (gv parent :parent)))
			   ((null parent) top-offset)
			 (setf top-offset
			       (+ top-offset (gv parent :top)
				  (or (gv parent :top-border-width) 0))))
		       (+ (gv bar-item :top) (gv bar-item :height)
			  (gv win :top) (gv win :top-border-width) top-offset))
		      (t 0)))))
	   )))
    (s-value a-submenu :window win)
    win))




;; This object is a text field in the menu bar.  
;; An aggrelist of these items makes up the menu bar.
;;
(create-instance 'MOTIF-BAR-ITEM motif-gadget-prototype
   (:width (o-formula (gvl :text :width)))
   (:height (o-formula (gvl :text :height)))
   ; The mnemonic ":desc" is a description of a submenu.  The top-level :items
   ; slot is a list of desc's.
   (:desc (o-formula (nth (gvl :rank) (gvl :parent :parent :items))))
   (:accelerators (o-formula
		   (nth (gvl :rank) (gvl :parent :parent :accelerators))))
   (:bar-above-these-items
    (o-formula (nth (gvl :rank) (gvl :parent :parent :bar-above-these-items))))
   (:menu-obj (o-formula (first (gvl :desc))))
   (:action (o-formula (second (gvl :desc))))
   (:items (o-formula (third (gvl :desc))))
   (:string (o-formula (let ((menu-obj (gvl :menu-obj)))
			 (if (stringp menu-obj)
			     menu-obj
			     (string-capitalize
			      (string-trim ":" menu-obj))))))
   (:font (o-formula (gvl :parent :parent :title-font)))
   (:spacing 5)
   (:enabled (o-formula (when (gvl :parent :parent :active-p)
			  (if (= 4 (length (gvl :desc)))
			      (fourth (gvl :desc))
			      T))))
   (:disabled-line-style (o-formula (gvl :parent :parent :disabled-line-style)))
   (:foreground-color (o-formula (gvl :parent :parent :foreground-color)))
   ;; slot :submenu filled by :fix-update-slots with a SUBMENU
   ;; slot :submenu-window set with the window of the submenu
   (:parts
    `(
      (:text ,opal:text
       (:left ,(o-formula (gvl :parent :left)))
       (:top ,(o-formula (gvl :parent :top)))
       (:font ,(o-formula (gvl :parent :font)))
       (:string ,(o-formula (string (gvl :parent :string))))
       (:line-style ,(o-formula 
		      (if (gvl :parent :enabled)
			  opal:default-line-style
			  (gvl :parent :disabled-line-style))))
       ))))

;; This is the top level MOTIF-MENUBAR gadget -- the big mutha.
;; Basically, it contains 3 parts -> a motif-box that represents
;; the menubar, an aggrelist of bar-items, and a feedback object.
;; It also has two interactors -- menubar-select: used for selecting
;; stuff from the menubar, and menubar-accel, which does the 
;; accelerator thang.

(create-instance 'MOTIF-MENUBAR motif-gadget-prototype
   :declare ((:parameters :left :top :items :title-font :item-font :accel-font
			  :foreground-color :min-menubar-width :accelerators
			  :bar-above-these-items :accelerator-windows
			  :active-p :selection-function)
	     (:type ((satisfies Check-Menubar-Items) :items)
		    (list :accelerators :bar-above-these-items)
		    ((or list (satisfies schema-p)) :accelerator-windows)
		    (integer :min-menubar-width)
		    ((or (is-a-p opal:font) (is-a-p opal:font-from-file))
			 :title-font :item-font :accel-font)
		    ((is-a-p opal:color) :foreground-color)
		    (kr-boolean :active-p)
		    ((or null function symbol) :selection-function)))
   ; Customizable slots
   (:left 0)(:top 0)
   (:left-offset 0)
   (:items NIL)
   (:title-font (opal:get-standard-font NIL :bold NIL))
   (:item-font (opal:get-standard-font NIL :bold NIL))
   (:accel-font (opal:get-standard-font NIL :bold NIL))
   (:min-menubar-width 0)
   (:accelerators NIL)
   (:bar-above-these-items NIL)
   (:accelerator-windows (o-formula (gvl :window)))
   (:active-p T)
   
   ; Internal slots
   (:disabled-line-style (o-formula
			  (create-instance NIL opal:line-style
			    (:stipple opal::gray-fill-bitmap)
			    (:background-color (gvl :foreground-color)))))
   (:enabled-items
    (o-formula (when (gvl :active-p)
		 (let ((enabled-items NIL))
		   (dovalues (component (gvl :menubar-items) :components
					:in-formula T
					:result enabled-items)
		       (when (gv component :enabled)
			 (push component enabled-items)))))))
   (:list-of-all-enabled-objects
    (o-formula (let ((l (copy-list (gvl :enabled-items))))
		 (dolist (baritems (gvl :enabled-items))
		   (setf l (append l (copy-list
				     (gv-local baritems :submenu :enabled-items)))))
		 l)))
   (:running-where-list (o-formula (append (gvl :list-of-all-enabled-objects)
					   (gvl :submenu-window-list))))
   (:right (o-formula (+ (gvl :left) (gvl :width))))
   (:destroy-me 'MENUBAR-DESTROY)
   (:special-popup-func 'Motif-Menubar-popup-item)
   (:special-popdown-func 'Put-Down-MenuBar-Popups)
   (:update-slots (cons :visible (g-value opal:aggrelist :update-slots)))
   (:old-visible T)
   
   ;; slot :submenu-window-list set with list of all windows being used.

   (:parts
    ;; This is the box that appears behind the text and
    ;; represents the menubar
    `((:menubar-box ,motif-box
       (:left ,(o-formula (gvl :parent :left)))
       (:top ,(o-formula (gvl :parent :top)))
       (:height ,(o-formula (+ (gvl :parent :menubar-items :height) 14)))
       (:width ,(o-formula (max (+ (gvl :parent :menubar-items :width) 18)
				(gvl :parent :min-menubar-width)))))

      ;; These are the menubar items themselves
      (:menubar-items ,opal:aggrelist
       (:left ,(o-formula (+ (gvl :parent :left)
			     (gvl :parent :left-offset) 9)))
       (:top ,(o-formula (+ (gvl :parent :top) 7)))
       (:items ,(o-formula (gvl :parent :items)))
       (:h-spacing 8)
       (:direction :horizontal)
       (:item-prototype ,MOTIF-BAR-ITEM)
       (:selection-function NIL)
       (:h-align :center))

      ;; feedback-obj-topline and bottom-line represent the
      ;; feedback object that appears on the menubar.
      (:feedback-obj-topline ,opal:polyline
       (:point-list ,(o-formula
		      (if (gvl :prev-baritem)
			  (let* ((ob (gvl :prev-baritem))
				 (left (gv ob :left))
				 (top (gv ob :top))
				 (ht (gv ob :height))
				 (wt (gv ob :width)))
			    (list (- left 4) (+ top ht 3)
				  (- left 4) (- top 2)
				  (+ left wt 4) (- top 2))))))
       (:prev-baritem ,(o-formula
			(gvl :parent :menubar-select :prev-baritem)))
       (:visible ,(o-formula
		   (AND (gvl :prev-baritem)
			(gvl :prev-baritem :enabled))))
       (: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
		      (if (gvl :prev-baritem)
			(let* ((ob (gvl :prev-baritem))
			       (left (gv ob :left))
			       (top (gv ob :top))
			       (ht (gv ob :height))
			       (wt (gv ob :width)))
			  (list (- left 5) (+ top ht 2)
				(+ left wt 3) (+ top ht 2)
				(+ left wt 3) (- top 1))))))
       
       (:prev-baritem ,(o-formula
			(gvl :parent :feedback-obj-topline :prev-baritem)))
       (:visible ,(o-formula (gvl :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))))
      ))
       
   (:interactors
    ;; The accelerator interactor.  Its menus are set to be all the
    ;; menus in the menubar.
    `((:menubar-accel ,motif-menu-accelerator-inter
       (:active ,(o-formula (let ((o (gv-local :self :operates-on)))
			      (and (gv o :active-p)
				   (gv o :window)))))
       (:window ,(o-formula (gvl :operates-on :accelerator-windows)))
       (:menus ,(o-formula
		 (let ((l NIL))
		   (dolist (a-baritem (gvl :operates-on :menubar-items :components))
		     (push (gv a-baritem :submenu) l))
		   l))))
      ;; This is for clicking on a bar item, moving out of the submenu's window,
      ;; etc. etc.
      (:menubar-select ,inter:menu-interactor
       (:active ,(o-formula (gv-local :self :operates-on :window)))
       (:window ,(o-formula
		  (let ((main-win (gv-local :self :operates-on :window))
			(submenu-wins (gv-local :self :operates-on
						:submenu-window-list)))
		    (if main-win
			(if submenu-wins
			    (cons main-win (copy-list submenu-wins))
			    main-win)))
		  ))
       (:start-where ,(o-formula (list :list-element-of
				       (gvl :operates-on)
				       :list-of-all-enabled-objects)))
       (:running-where ,(o-formula (list :list-element-of
					 (gvl :operates-on)
					 :running-where-list)))
       (:feedback-obj ,(o-formula (gvl :operates-on :feedback-obj-topline)))
       (:outside NIL)
       (:start-action
	,#'(lambda (inter obj)
	     (call-prototype-method inter obj)
	     (s-value (g-value inter :operates-on) :*bar-item-popped-up NIL)))
       (:outside-action
	,#'(lambda (inter outside prev)
	     (call-prototype-method inter outside prev)
	     
	     ;; make sure the top level bar items stay selected since
	     ;; sub-menus are showing
	     
	     (when (is-a-p prev MOTIF-BAR-ITEM)
	       (s-value prev :interim-selected T))))
       (:running-action
	,#'(lambda (inter prev new)
	     (let* ((prev-baritem (g-value inter :prev-baritem))
		    (new-is-bar (is-a-p new MOTIF-BAR-ITEM))
		    (new-baritem (when new
				   (if new-is-bar
				     new
				     ;; else is a sub-item, get its bar-item
				     (g-local-value new :bar-item)))))
	       (call-prototype-method inter prev new)

	       ;; Now, when you get into a submenu window, you want to start
	       ;; that submenu's interactor.
	       
	       (let ((curr-win (inter:event-window inter::*current-event*))
		     (obj-wins (g-local-value inter :operates-on :submenu-window-list)))
		 (if  (member curr-win obj-wins :test #'equal)
		     (let* ((submenu (g-local-value prev-baritem :submenu))
			    (first-obj-over
			     (OR (g-value submenu :press :remembered-last-object)
				 (first (g-value submenu :menu-item-list :components))))
			    (ce inter::*current-event*)
			    (ev-x (inter:event-x ce))
			    (ev-y (inter:event-y ce))
			    (ev (inter:make-event :window curr-win
						  :code (inter:event-code ce)
						  :char :leftdown
						  :mousep T :downp T
						  :x ev-x
						  :y ev-y 
						  :timestamp (inter:event-timestamp ce))))
		       (when (eq (g-local-value prev-baritem :submenu :press :current-state)
				 :start)
			 (inter:start-interactor (g-value submenu :press) ev))

		       ;; For some weird reason, the first item that's been selected
		       ;; in the newly popped up window don't have a feedback object
		       ;; around them.  So here, we EXPLICITLY tell it to put a
		       ;; feedback object around the FIRST item it selects, unless
		       ;; that item is disabled.
		       
		       (when (AND
			      (opal:point-in-gob first-obj-over ev-x ev-y)
			      (g-value first-obj-over :enabled))
			 (s-value submenu :value (g-value first-obj-over :item-obj))
			 (s-value submenu :value-obj first-obj-over)
			 (s-value first-obj-over :interim-selected T)))

		     (unless (NULL prev-baritem)
		       (s-value (g-local-value prev-baritem :submenu) :value-obj NIL)))
		     )

	       ;; keep the interim selected of the bar item so it
	       ;; shows up as highlighted when items in sub-menu selected.
	       (if new-baritem
		   ;; this makes the subwindow NOT go away when move
		   ;; outside subwindow
		   (unless (eq new-baritem prev-baritem)
		     (s-value inter :prev-baritem new-baritem)
		     (if prev-baritem
			 (let ((win (g-local-value prev-baritem :submenu-window))
			       (prev-selected (g-local-value prev-baritem :submenu :press
						       :remembered-last-object)))
			   (s-value prev-baritem :interim-selected NIL)
			   (when prev-selected
			     (s-value prev-selected :interim-selected NIL))
			   (s-value win :visible NIL)
			   (opal:update win)))
		     (if new-baritem
			 (let ((win (g-value new-baritem :submenu-window)))
			   (s-value (g-value new-baritem :submenu)
				    :value-obj NIL)
			   (s-value win :visible T)
			   (opal:raise-window win)))))  ;; Call update
	       ;;; this needs to be after the call-prototype-method,
	       ;;; since that is where the :interim-selected will be
	       ;;; turned off.
	       (unless new-is-bar
		 (when new-baritem
		   (s-value new-baritem :interim-selected T))))
	     ))
       (:abort-action
	,#'(lambda (inter last)
	     (declare (ignore last))
	     (let ((prev-baritem (g-value inter :prev-baritem)))
	       (when prev-baritem
		 (let ((prev-selected (g-value prev-baritem :submenu :press
					       :remembered-last-object)))

		   (s-value prev-baritem :interim-selected NIL)
		   (when prev-selected
		     (s-value prev-selected :interim-selected NIL)))
		 (let ((win (g-value prev-baritem :submenu-window)))
		   (s-value inter :prev-baritem NIL)
		   (s-value win :visible NIL)
		   (opal:update win))))))

       ;; This hides the submenu's window after an item has been selected
       (:final-function
	,#'(lambda (inter last)
	     (declare (ignore last))
	     (when (g-value inter :prev-baritem)
	       (let ((win (g-value inter :prev-baritem :submenu :window)))
		 (s-value win :visible NIL)
		 (opal:update win))
	       (s-value inter :prev-baritem NIL))))
       ))))

(s-value MOTIF-MENUBAR :do-not-dump-slots
	 (append '(:submenu-window-list)
		 (g-value MOTIF-MENUBAR :do-not-dump-slots)))
(s-value MOTIF-BAR-ITEM :do-not-dump-slots
	 (append '(:submenu :submenu-window)
		 (g-value MOTIF-BAR-ITEM :do-not-dump-slots)))
(let ((menubar-select (g-value MOTIF-MENUBAR :menubar-select)))
  (s-value menubar-select :do-not-dump-slots
	   (append '(:prev-baritem)
		   (g-value menubar-select :do-not-dump-slots))))
	 


;; This function gets called when an item has been selected from
;; the submenu.  Basically, it hides the submenu's window and
;; calls the appropriate :selection-function and the item's
;; function

(defun SUBMENU-SELECTION-FUNCTION (submenu submenu-item)
  (let* ((baritem (g-value submenu :bar-item))
	 (bar-action (g-value baritem :action))
	 (bar-obj (g-value baritem :menu-obj))
	 (a-menubar (g-value baritem :parent :parent)))
    (s-value (g-value submenu :window) :visible NIL)
    (s-value (g-value a-menubar :menubar-select) :prev-baritem NIL)
    (opal:update (g-value submenu :window))
    (if bar-action
	(funcall bar-action a-menubar bar-obj
		 (g-value submenu-item :item-obj)))
    (if (schema-p a-menubar)
	(kr-send a-menubar :selection-function
		 a-menubar bar-obj (g-value submenu-item :item-obj)))
    ))
				   
;; This is a submenu for the motif-menubar (surprise surprise!)
;; Its a motif-menu that inherits some slots from the top level
;; menubar.  Also, the accelerators for the menubar are given
;; as lists of two items - the string and the key.  BUT!  The
;; motif-menu wants its accelerators to be lists of THREE items -
;; the underline, the string, and the key.  So, we have to insert
;; NILs for the underlines.  That's what the o-formula in the
;; :accelerators slot does.
;;
;; A submenu-item is just an instance of MOTIF-MENU-ITEM.  Which
;; means any MOTIF-MENU-ITEM can be added to the menubar.  

(create-instance 'MOTIF-SUBMENU motif-menu
  (:bar-item NIL)
  (:menubar (o-formula (gvl :bar-item :parent :parent)))
  (:foreground-color
   (o-formula (gvl :menubar :foreground-color)))
  (:final-feedback-p NIL)
  (:item-font (o-formula (gvl :menubar :item-font)))
  (:accel-font (o-formula (gvl :menubar :accel-font)))
  (:items (o-formula (gvl :bar-item :items)))
  (:keyboard-selection-p NIL)
  (:selection-function #'SUBMENU-SELECTION-FUNCTION)
  (:accelerators (o-formula
		  (let ((bar-acc (gvl :bar-item :accelerators))
			menu-acc temp)
		    (when bar-acc
		      (dolist (a-list bar-acc)
			(setf temp (push NIL a-list))
			(setf menu-acc
			      (append menu-acc (list temp)))))
		    menu-acc)))
  (:bar-above-these-items (o-formula (gvl :bar-item :bar-above-these-items)))
  (:text-offset (o-formula (if (gvl :accelerators) 4 0)))
  (:parts
   `(:frame
     (:menu-item-list :modify
      (:item-prototype
       (:modify
	(:enabled T)
	(:active-p ,(o-formula (gvl :enabled)))
	(:get-title-fn menubar-get-title-motif)
	(:set-title-fn menubar-set-title-motif)
	)))
     :bar-list :feedback-obj-topline :feedback-obj-bottomline :sel-box)))
  
;;; Auxiliary function for MOTIF-MENUBAR's :fix-update-slots method.
;;; This function is used to establish the links between a bar-item and its
;;; submenu.  A new submenu is created and put in a new window.  This new
;;; window is added to the :submenu-window-list slot of the interactor in the
;;; top-level menubar.

(defun ATTACH-MOTIF-SUBMENU (menubar-items a-bar-item)
  ; a-bar-item might have been taken from storage, so check to see whether
  ; it has a :submenu and :submenu-window before creating these
  (let* ((new-submenu (or (g-local-value a-bar-item :submenu)
			  (create-instance NIL MOTIF-SUBMENU
			    (:bar-item a-bar-item))))
	 (win (or (g-local-value a-bar-item :submenu-window)
		  (Make-Motif-Submenu-Win a-bar-item new-submenu)))
	 (a-menubar (g-value menubar-items :parent))
	 (submenu-window-list (g-local-value a-menubar :submenu-window-list)))

    ; if a-bar-item was taken from storage, then its :submenu-window is
    ; already on the :submenu-window-list
    (unless (member win submenu-window-list)
      (s-value a-menubar :submenu-window-list
	       (cons win (copy-list submenu-window-list))))
		     
    ; bookkeeping in case a-bar-item was not taken from storage
    (s-value a-bar-item :submenu new-submenu)
    (s-value a-bar-item :submenu-window win))
  a-bar-item)


;;;    This should be called when the number of items in the menu is changed
;;; manually (without calling add-item or remove-item).  This is basically an
;;; enhanced version of the default fix-update-slots method which reuses old
;;; components.
;;;    When the menubar instance is created, aggrelists creates components
;;; for it, but this function has to be called to create submenus for the
;;; components.  If the number of :items changes, then this function should be
;;; called to both create (or destroy) new components for the aggrelist and
;;; create (or destroy) corresponding submenus.
;;;
(define-method :fix-update-slots MOTIF-MENUBAR (a-menubar)
  ;; will be called when :items or :visible change
  (let ((old-visible (g-value a-menubar :old-visible))
	(new-visible (g-value a-menubar :visible)))
    (if (eq old-visible new-visible)
	;; then items must have changed -- Generate new bar-items
	(call-prototype-method a-menubar)
	(progn ;; else visible changed
	  (s-value a-menubar :old-visible new-visible)
	  (unless new-visible
	    (Put-Down-MenuBar-Popups a-menubar))))))

(define-method :fix-update-slots MOTIF-BAR-ITEM (a-bar-item)
  (let ((a-menubar (g-value a-bar-item :parent)))
    (unless (member (g-local-value a-bar-item :submenu-window)
		    (g-local-value a-menubar :submenu-window-list))
      ;; Generate new submenu window for the bar-item
      (ATTACH-MOTIF-SUBMENU a-menubar a-bar-item))))


;;;
;;;  DEMO FUNCTIONS
;;;


#+garnet-debug (defparameter *MOTIF-FONT-TO-SWAP* (create-instance NIL opal:font))
#+garnet-debug (defvar motif-family-text NIL)
#+garnet-debug (defvar motif-face-text NIL)
#+garnet-debug (defvar motif-size-text NIL)
#+garnet-debug (defvar motif-combo-text NIL)


;;; When we want to change an object's font, set the slots of *MOTIF-FONT-TO-SWAP*,
;;; then set the object to have that font.  (Opal does not notice when you
;;; just change the slots of a font.)
;;;
#+garnet-debug
(defun Motif-Change-Font (text-obj &key family face size)
  (let ((old-font (g-value text-obj :font))
	(new-font *MOTIF-FONT-TO-SWAP*))
    (setf *MOTIF-FONT-TO-SWAP* old-font)
    (if family
	(s-value new-font :family family)
	(s-value new-font :family :fixed))
    (if face
	(s-value new-font :face face)
	(s-value new-font :face :roman))
    (if size
	(s-value new-font :size size)
	(s-value new-font :size :medium))
    (s-value text-obj :font new-font)))


;;; Some functions to call when items are selected
;;;
#+garnet-debug
(defun Motif-Family-Fn (gadget slot value)
  (declare (ignore gadget))
  (motif-change-font motif-family-text slot value)
  (s-value motif-family-text :string (string-downcase value)))
#+garnet-debug
(defun Motif-Face-Fn (gadget slot value)
  (declare (ignore gadget))
  (motif-change-font motif-face-text slot value)
  (s-value motif-face-text :string (string-downcase value)))
#+garnet-debug
(defun Motif-Size-Fn (gadget slot value)
  (declare (ignore gadget))
  (motif-change-font motif-size-text slot value)
  (s-value motif-size-text :string (string-downcase value)))

#+garnet-debug
(defun Motif-Fixed-Fn (gadget bar-item submenu-item)
  (declare (ignore gadget bar-item submenu-item))
  (format t "Setting :family slot to :fixed.~%"))
#+garnet-debug
(defun Motif-Serif-Fn (gadget bar-item submenu-item)
  (declare (ignore gadget bar-item submenu-item))
  (format t "Setting :family slot to :serif.~%"))
#+garnet-debug
(defun Motif-Sans-Serif-Fn (gadget bar-item submenu-item)
  (declare (ignore gadget bar-item submenu-item))
  (format t "Setting :family slot to :sans-serif.~%"))


#+garnet-debug
(defun Motif-Menubar-Go (&key dont-enter-main-event-loop)

  (create-instance 'MOTIF-MENUBAR-WIN inter:interactor-window
    (:background-color opal:motif-green)
    (:top 5)(:left 700)(:height 360)(:width 300)
    
    (:aggregate (create-instance 'MOTIF-MENUBAR-TOP-AGG opal:aggregate)))
  (opal:update MOTIF-MENUBAR-WIN)

  (create-instance 'DEMO-MOTIF-MENUBAR MOTIF-MENUBAR
    (:foreground-color opal:motif-green)
    (:items
     '((:family motif-family-fn
	((:fixed motif-fixed-fn)(:serif motif-serif-fn)(:sans-serif motif-sans-serif-fn)))
       (:face motif-face-fn
	((:roman)(:bold)(:italic)(:bold-italic)))
       (:size motif-size-fn
	((:small)(:medium)(:large)(:very-large)))))
    (:accelerators
     '((("!f" :|META-f|) ("!e" :|META-e|) ("!a" :|META-a|))
       (("!r" :|META-r|) ("!b" :|META-b|) ("!i" :|META-i|) ("!B" :META-B))
       (("!s" :|META-s|) ("!m" :|META-m|) ("!l" :|META-l|) ("!v" :|META-v|))))
    (:bar-above-these-items
     '(NIL
       NIL
       (:large)))
    (:selection-function
     #'(lambda (gadget slot value)
	 (declare (ignore gadget slot value))
	 (let ((family (g-value motif-family-text :font :family))
	       (face (g-value motif-face-text :font :face))
	       (size (g-value motif-size-text :font :size)))
	   (motif-change-font motif-combo-text
			:family family :face face :size size)))))

  (create-instance 'motif-menubar-special-popup-inter inter:button-interactor
    (:start-event #\p)
    (:start-where (list :in DEMO-MOTIF-MENUBAR))
    (:continuous NIL)
    (:window MOTIF-MENUBAR-WIN)
    (:final-function #'(lambda (inter obj)
			 (declare (ignore inter obj))
			 (kr-send DEMO-MOTIF-MENUBAR :special-popup-func
				  DEMO-MOTIF-MENUBAR))))

  (opal:add-component MOTIF-MENUBAR-TOP-AGG DEMO-MOTIF-MENUBAR)
  (opal:update MOTIF-MENUBAR-WIN)

  (create-instance 'motif-family-text opal:text
     (:left 10)
     (:top 200)
     (:string "fixed")
     (:font (create-instance NIL opal:font)))
  (create-instance 'motif-face-text opal:text
     (:left 75)
     (:top 200)
     (:string "roman")
     (:font (create-instance NIL opal:font)))
  (create-instance 'motif-size-text opal:text
     (:left 160)
     (:top 200)
     (:string "medium")
     (:font (create-instance NIL opal:font)))
  (create-instance 'motif-combo-text opal:text
     (:left 75)
     (:top 230)
     (:string "combo")
     (:font (create-instance NIL opal:font)))

  (opal:add-components MOTIF-MENUBAR-TOP-AGG
		       motif-family-text motif-face-text motif-size-text motif-combo-text)
  
  (opal:update MOTIF-MENUBAR-WIN)
 (unless dont-enter-main-event-loop #-cmu (inter:main-event-loop))
 )



;;;
;;;  MOTIF-MENUBAR-STOP
;;;

#+garnet-debug
(defun Motif-Menubar-Stop ()
  (opal:destroy MOTIF-MENUBAR-WIN))


;;;
;;;  UTILITY FUNCTIONS USED BY EXPORTED FUNCTIONS
;;;

(defun Confirm-Motif-Menubar (a-menubar)
  (unless (is-a-p a-menubar MOTIF-MENUBAR)
    (error "~S is not an instance of ~S.~%" a-menubar MOTIF-MENUBAR))
  T)

(defun Confirm-Motif-Bar-Item (a-bar-item)
  (unless (is-a-p a-bar-item MOTIF-BAR-ITEM)
    (error "~S is not an instance of ~S.~%" a-bar-item MOTIF-BAR-ITEM))
  T)


(defun confirm-motif-bar-or-submenu-item (menubar-component)
  (unless (or (is-a-p menubar-component MOTIF-BAR-ITEM)
	      (is-a-p menubar-component MOTIF-MENU-ITEM))
    (error "~S is not an instance of ~S or ~S.~%" menubar-component
	   MOTIF-BAR-ITEM MOTIF-MENU-ITEM))
  T)

(defun Insert-Item-At-N (a-list item n)
  (let ((new-list (copy-list a-list))
	(len (1- (length a-list))))

    (when (< len n)
      (dotimes (i (- n len 1))
	(setf new-list
	      (append new-list (list NIL)))))
    
    (append (subseq new-list 0 n) (list item)
	  (subseq new-list n))))

(defun Remove-Item-At-N (a-list n)
  (if (< n (length a-list))
      (append (subseq a-list 0 n) (subseq a-list (1+ n)))
      a-list))
	  
;;;
;;;  EXPORTED FUNCTIONS
;;;

; Menubar Functions


;
; The parameter item may be either 
; 1) An instance of MOTIF-BAR-ITEM, or
; 2) A sublist of an :items list
;
; NOTE NOTE NOTE NOTE:  THE :ACCELERATOR KEYWORD *MUST* APPEAR BEFORE THE
; :WHEREs IF YOU WANT TO ADD ANY ACCELERATORS
;
; Locator should be a sublist of an :items list or an installed bar-item.
; Or, you can use the key feature of add-item and make locator the title of
; an installed bar-item:
;    (add-item demo-motif-menubar new-bar :after "Bar2" :key #'car)
;
; Implementation note:  The reason that we do not just set the :items list
; and let the fix-update-slots method deal with the components is that the
; item parameter can be an actual component to be added, so you should not
; generate a new component via fix-update-slots.
;
(define-method :add-item MOTIF-MENUBAR (a-menubar item &rest args)
  (let* ((a-bar-item (if (is-a-p item MOTIF-BAR-ITEM)
			 item
			 (or (let ((old-bi (pop (g-value a-menubar :storage))))
			       (when old-bi
				 (g-value old-bi :desc)  ; initialize formula
				 (s-value old-bi :desc item)
				 old-bi))
			     (Make-Motif-Bar-Item :desc item))))
	 (a-list (g-value a-bar-item :parent)) ; parent should be NIL
	 where locator key accel)

    ;; with the motif-menubar, you can specify accelerators
    ;; to be added as well.
    
    (when (eq :accelerators (first args))
      ;; accel will be the user's new accelerator character
      (setf accel (second args))
      (setf args (cddr args)))
    
    (when a-list
      (error "~S is already installed in ~S.~%" a-bar-item a-list))
    
    (multiple-value-setq (where locator key) (opal::get-wheres args))
    
    ; Add the bar-item as a component of the menubar
    (let* ((locator-comp (if (is-a-p locator MOTIF-BAR-ITEM)
			    locator
			    (get-bar-component a-menubar locator)))
	   (locator-desc (when locator-comp
			   (g-value locator-comp :desc)))
	   (items (copy-list (g-value a-menubar :items)))
	   (desc (g-value a-bar-item :desc))
	   (menubar-items (g-value a-menubar :menubar-items))
	   rank)

      (opal:add-local-component menubar-items
				a-bar-item where locator-comp)
      (setf rank
	    (s-value a-bar-item :rank
		     (position a-bar-item (g-value menubar-items :components))))
      (s-value (g-value a-menubar :menubar-items) :old-items
         (s-value a-menubar
		  :items
		  (opal::insert-item desc items where locator-desc key)))

    ;; Adjust the accelerators and bar-above-these-items lists to
    ;; recognize that a new bar-item has been added

    (s-value a-menubar :accelerators
	     (insert-item-at-n (g-value a-menubar :accelerators) accel rank))

    (s-value a-menubar :bar-above-these-items
	     (insert-item-at-n (g-value a-menubar :bar-above-these-items)
			       NIL rank))
    )
    
    ; Do additional bookkeeping that attaches the bar-item to the menubar
    (let* ((win (g-value a-bar-item :submenu-window))
	   (top-inter (g-value a-menubar :menubar-select))
	   (cur-wins (g-value top-inter :window)))
      ; Make sure win is destroyed along with a-menubar
      (unless (member win (g-local-value a-menubar :submenu-window-list))
	(s-value a-menubar :submenu-window-list
	       (append (list win) (g-local-value a-menubar :submenu-window-list))))
      ; Add win to the top-level interactor's :window slot
      (if (listp cur-wins)
	  (append (list win) (g-value top-inter :window))
	  (s-value top-inter :window (list win cur-wins)))
      (mark-as-changed top-inter :window))

    a-bar-item))


;
;
; The a-bar-item parameter can either be
; 1) An instance of MOTIF-BAR-ITEM, or
; 2) A sublist of the :items list
;
(define-method :remove-item MOTIF-MENUBAR (a-menubar item)
  (let ((a-bar-item (if (is-a-p item MOTIF-BAR-ITEM)
			item
			(get-bar-component a-menubar item)))
	(rank NIL))
    (unless (and a-bar-item
		 (eq a-menubar (and
				(g-value a-bar-item :parent)  ;;Check if it has a parent
				(g-value a-bar-item :parent :parent)))) ;;Get the menubar
      (error "~S does not have ~S as its menubar.~%"
	     a-bar-item a-menubar))
    (setf rank (position a-bar-item (g-value a-menubar :menubar-items :components)))

    ; Remove the appropriate accelerators
    (s-value a-menubar :accelerators
	     (remove-item-at-n (g-value a-menubar :accelerators) rank))
    ; Remove the appropriate bars
    (s-value a-menubar :bar-above-these-items
	     (remove-item-at-n (g-value a-menubar :bar-above-these-items) rank))

    ; Remove the bar-item from the menubar
    (s-value a-menubar :submenu-window-list
	     (remove (g-local-value a-bar-item :submenu-window)
		     (g-local-value a-menubar :submenu-window-list)))
    (opal:remove-local-component (g-value a-menubar :menubar-items) a-bar-item)
    (unless (eq a-bar-item item)
      (push a-bar-item (g-value a-menubar :storage)))
      
    ; Change the top-level :items list
    (let ((old-desc (if (is-a-p a-bar-item MOTIF-BAR-ITEM)
			(g-value a-bar-item :desc)
			a-bar-item)))
      (s-value (g-value a-menubar :menubar-items) :old-items
	 (s-value a-menubar :items (remove old-desc (g-value a-menubar :items)
					   :test #'equal))))))

(defun Make-Motif-Menubar ()
  (create-instance NIL MOTIF-MENUBAR))

(define-method :Menubar-Components MOTIF-MENUBAR (a-menubar)
  (g-value a-menubar :menubar-items :components))

(define-method :Set-Menubar MOTIF-MENUBAR (a-menubar new-menus)
  ; Can't use dovalues and destructive operation on :components together
  (let ((components (copy-list (Menubar-Components a-menubar))))
    (dolist (old-comp components)
      (opal:remove-item (g-value a-menubar :menubar-items) old-comp))
    (dolist (new-menu new-menus)
      (opal:add-item (g-value a-menubar :menubar-items) new-menu))))



; Bar-Item functions
;
; The item parameter can either be
; 1) An instance of MOTIF-MENU-ITEM, or
; 2) A description of a submenu-item: (list string action) where "string" is
;    a string or atom and "action" is a function
;
; NOTE NOTE NOTE NOTE:  THE :ACCELERATOR KEYWORD *MUST* APPEAR BEFORE THE
; :WHEREs IF ANY ACCELERATORS ARE TO BE ADDED

(define-method :add-item MOTIF-BAR-ITEM (a-bar-item item &rest args)
  (let ((a-menubar
	 (and
	  (g-value a-bar-item :parent)
	  (g-value a-bar-item :parent :parent)))
	(submenu (g-value a-bar-item :submenu))
	(old-desc (or (g-local-value a-bar-item :desc)
		      (copy-list (g-value a-bar-item :desc))))
	where locator key accel rank)

    ;; when adding a submenu item to a bar item, you can also
    ;; provide it with an accelerator
    (when (eq :accelerator (first args))
      ;; accel will be the user's new accelerator character
      (setf accel (second args))
      (setf args (cddr args)))

    (multiple-value-setq (where locator key) (opal::get-wheres args))
    
    ;; item can be either a submenu-item or a list
    (if (schema-p item)
	(let* ((new-item `(,(g-value item :item-obj)
			   ,(g-value item :action)))
	       (new-sub-desc (opal::insert-item new-item (third old-desc)
						where locator key))
	       (new-desc (list (first old-desc) (second old-desc) new-sub-desc)))

	  (setf rank
		(s-value item :rank
			 (position new-item new-sub-desc :test #'equal)))
	  (if a-menubar
	      (s-value a-menubar :items
		       (substitute new-desc old-desc
				   (or (g-local-value a-menubar :items)
				       (copy-list (g-value a-menubar :items)))
				   :test #'equal))
	      (s-value a-bar-item :desc new-desc))
	  (s-value (g-value submenu :menu-item-list) :old-items new-sub-desc)
	  
	  (kr:with-constants-disabled
	      (opal:add-local-component (g-value submenu :menu-item-list)
					item :at rank))
	  )

	(let* ((new-sub-desc (opal::insert-item item (third old-desc)
						where locator key))
	       (new-desc (list (first old-desc) (second old-desc)
			       new-sub-desc)))
	  
	  (setf rank (position item new-sub-desc
			       :test #'(lambda (x y)
					 (equal x (funcall key y)))))
	  (if a-menubar
	      (s-value a-menubar
		       :items
		       (substitute new-desc old-desc
				   (or (g-local-value a-menubar :items)
				       (copy-list (g-value a-menubar :items)))
				   :test #'equal))
	      (s-value a-bar-item :desc new-desc))
	  (s-value (g-value submenu :menu-item-list) :items new-sub-desc)
	  ))

    ;; Now you have to set the :accelerators list of the top-level menubar
    ;; to understand that a new item has been added to the submenu, and if
    ;; necessary, insert the new accelerator into the list.  You do this
    ;; ONLY IF A MENUBAR EXISTS

    (when a-menubar
      (let* ((a-list (g-value a-menubar :accelerators))
	     (old-acc-list (nth (g-value submenu :bar-item :rank) a-list)))
	(when old-acc-list 
	  (let ((new-acc-list (Insert-Item-At-N old-acc-list accel rank)))
	    (s-value a-menubar :accelerators
		     (substitute new-acc-list old-acc-list a-list))
	  ))))
    ))


;
;
; The item parameter can be either
; 1) An instance of MOTIF-MENU-ITEM, or
; 2) A string or atom
;
(define-method :remove-item MOTIF-BAR-ITEM (a-bar-item &optional item
						 &key (key #'opal:no-func))
  (let* ((a-submenu-item (if (is-a-p item MOTIF-MENU-ITEM)
			     (get-submenu-component a-bar-item
							  (g-value item :item-obj))
			     (get-submenu-component a-bar-item item)))
	 (submenu (g-value a-bar-item :submenu))
	 (Submenu-Components (g-value submenu :menu-item-list :components))
	 (rank (if item
		   (position a-submenu-item Submenu-Components
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   (1- (length Submenu-Components))))
	 action item-obj)
    
    (unless rank
      (error "~S does not have ~S as its bar-item.~%"
	     a-submenu-item a-bar-item))
    ; If the user did not supply an item, then just remove the last component
    (unless a-submenu-item
      (setf a-submenu-item (nth rank Submenu-Components)))
    (setf action (g-value a-submenu-item :action))
    (setf item-obj (g-value a-submenu-item :item-obj))

    (opal:remove-local-component (g-value a-submenu-item :parent) a-submenu-item)

    ; Update the :items or :desc list
    (let* ((a-menubar (and
		       (g-value a-bar-item :parent)
		       (g-value a-bar-item :parent :parent)))
	   (old-desc (g-value a-bar-item :desc))
	   (old-sub-desc (third old-desc))
	   (item-obj (g-value a-submenu-item :item-obj))
	   (action (g-value a-submenu-item :action))
	   (new-sub-desc (remove (if action
				     (list item-obj action)
				     (list item-obj))
				 old-sub-desc :test #'equal))
	   (new-desc (substitute new-sub-desc old-sub-desc old-desc
				 :test #'equal)))

      (if a-menubar
	  (s-value (g-value submenu :menu-item-list) :old-items
	     (s-value a-menubar :items
		      (substitute new-desc old-desc (g-value a-menubar :items)
				  :test #'equal)))
	  (s-value a-bar-item :desc new-desc))
      (s-value (g-value submenu :menu-item-list) :old-items new-sub-desc)
      
      ;; Now you have to remove the accelerator from the menubar
      (when a-menubar
	(let* ((accels (g-value a-menubar :accelerators))
	       (a-list (nth (g-value a-bar-item :rank) accels)))
	  (when a-list
	    (let ((new-a-list (remove-item-at-n a-list rank)))
	      (s-value a-menubar :accelerators
		       (substitute new-a-list a-list accels))))))
      )))

(s-value MOTIF-MENUBAR :change-item (g-value opal:aggrelist :change-item))
(s-value MOTIF-MENUBAR :remove-nth-item
	 (g-value opal:aggrelist :remove-nth-item))
(s-value MOTIF-BAR-ITEM :change-item #'menubar-change-item)
(s-value MOTIF-BAR-ITEM :remove-nth-item (g-value opal:aggrelist :remove-nth-item))
(s-value MOTIF-BAR-ITEM :set-submenu-fn #'set-submenu-fn)
(s-value MOTIF-MENUBAR :get-bar-component-fn #'get-bar-component-fn)


;; Returns an instance of a motif-bar-item

(defun Make-Motif-Bar-Item (&key desc font title)
  ;; Type-check the argument before creating an object for it.
  (when desc (Check-Bar-Item desc))
  (let* ((new-bar-item (create-instance NIL MOTIF-BAR-ITEM))
	 (new-submenu (create-instance NIL MOTIF-SUBMENU
			 (:bar-item new-bar-item)
			 (:font (or font opal:default-font))))
	 (win (Make-Motif-Submenu-Win new-bar-item new-submenu)))
    (s-value new-bar-item :submenu new-submenu)
    (s-value new-bar-item :submenu-window win)
    ; Put in initial value of :desc slot
    (g-value new-bar-item :desc) ; to initialize the default formula
    (if desc
	(s-value new-bar-item :desc desc)
	(s-value new-bar-item :desc (list title NIL NIL)))
    new-bar-item))

;; Returns the title of a menubar-component, which could
;; be a bar-item or a submenu-item

(defun Menubar-Get-Title-Motif (menubar-component)
  (if (is-a-p menubar-component MOTIF-BAR-ITEM)
      (g-value menubar-component :menu-obj)
      (g-value menubar-component :item-obj)))

(s-value MOTIF-BAR-ITEM :get-title-fn #'menubar-get-title-motif)

; If the menubar-component is installed in a menubar, then the :items list is
; changed.  Otherwise, the object's :desc slot is set.
;
(defun Menubar-Set-Title-Motif (menubar-component string)
  (cond

    ;; The parameter is a MOTIF-BAR-ITEM
    ((is-a-p menubar-component MOTIF-BAR-ITEM)
     (let* ((a-bar-item menubar-component)
	    (a-menubar (and
			(g-value a-bar-item :parent)
			(g-value a-bar-item :parent :parent))))
       (cond
	 (a-menubar
	  ; a-bar-item is installed, so set the :items list
	  (rplaca (find (g-value a-bar-item :desc)
			(g-value a-menubar :items) :test #'equal)
		  string)
	  (mark-as-changed a-menubar :items))
	 
	 (t
	  ; not installed, so just set local :desc list
	  (rplaca (g-value a-bar-item :desc) string)
	  (mark-as-changed a-bar-item :desc)))))

    ;; The parameter is a MOTIF-MENU-ITEM
    ((or
      (is-a-p menubar-component MOTIF-MENU-ITEM))
     (let* ((a-submenu-item menubar-component)
	    (a-submenu-agg (g-value menubar-component :parent :parent)))
       (cond
	 (a-submenu-agg
	  ; a-submenu-item is installed in a bar-item
	  (let* ((a-bar-item (g-value a-submenu-agg :bar-item))
		 (a-menubar (when a-bar-item
			      (g-value a-bar-item :parent :parent))))
	    (cond

	      ; a-submenu-item is installed in a menubar
	      (a-menubar
	       (let* ((old-desc (g-value a-bar-item :desc))
		      (old-items-desc
		       (find old-desc (g-value a-menubar :items))))
		 (dolist (desc (third old-items-desc))
		   (when (and (equal (first desc)
				     (g-value a-submenu-item :item-obj))
			      (equal (second desc)
				     (g-value a-submenu-item :action)))
		     (rplaca desc string)
		     (mark-as-changed a-menubar :items)))))

	      ; a-submenu-item is not installed in a menubar
	      (t
	       (let* ((old-desc (g-value a-bar-item :desc)))
		 (dolist (desc (third old-desc))
		   (when (and (equal (first desc)
				     (g-value a-submenu-item :item-obj))
			      (equal (second desc)
				     (g-value a-submenu-item :action)))
		     (rplaca desc string)
		     (mark-as-changed a-bar-item :items))))))))

	 ; a-submenu-item is not installed in a bar-item
	 (t
	  (g-value a-submenu-item :desc)
	  (s-value a-submenu-item :desc (list string))))))
	  
    ; Else, print error message
    (t (error "~S is not an instance of ~S or ~S.~%" menubar-component
	   MOTIF-BAR-ITEM MOTIF-MENU-ITEM)))
  string)

(s-value MOTIF-BAR-ITEM :set-title-fn #'menubar-set-title-motif)

(define-method :Submenu-Components MOTIF-BAR-ITEM (a-bar-item)
  (g-value a-bar-item :submenu :menu-item-list :components))

;
; The args parameter will (optionally) include the where, locator, and key
; parameters that are sent to add-item.  The where refers to the placement
; of the new submenu item among the current submenu items within b-item.
;
(define-method :Add-Submenu-Item MOTIF-MENUBAR (a-menubar b-item s-item &rest args)
  (let* ((a-bar-item (if (is-a-p b-item MOTIF-BAR-ITEM)
			 b-item
			 (get-bar-component a-menubar b-item)))
	 where locator key accel)
    (when (eq :accelerator (first args))
      ;; accel will be the user's new accelerator character
      (setf accel (second args))
      (setf args (cddr args)))

    (multiple-value-setq (where locator key) (opal::get-wheres args))
    (opal:add-item a-bar-item s-item :accelerator accel where locator key)))

;
; After looking up the b-item to get a bar-item object, call opal:remove-item.
;
(define-method :Remove-Submenu-Item MOTIF-MENUBAR (a-menubar b-item s-item)
  (let* ((a-bar-item (if (is-a-p b-item MOTIF-BAR-ITEM)
			 b-item
			 (get-bar-component a-menubar b-item))))
    (opal:remove-item a-bar-item s-item)))

; new-desc can have two forms:
;   1) A list of MOTIF-MENU-ITEM instances, or
;   2) A list of MOTIF-MENU-ITEM descriptions, such as
;      ((item1 action1) (item2) (item3 action3)))
;

;; Gets the submenu-component corresponding to a given title in a
;; bar-item

(define-method :Get-Submenu-Component MOTIF-BAR-ITEM (a-bar-item item)
  (find-if #'(lambda (a-submenu-item)
	       (if (listp item)
		   (equal item (list (g-value a-submenu-item :item-obj)))
		   (equal item (g-value a-submenu-item :item-obj))
		   ))
	   (Submenu-Components a-bar-item)))

;; Finds a submenu component, given a menubar, the title of the bar-item,
;; and the title of the submenu-item

(define-method :Find-Submenu-Component MOTIF-MENUBAR (a-menubar submenu-title submenu-item)
  (let ((a-bar-item (if (is-a-p submenu-title MOTIF-BAR-ITEM)
			submenu-title
			(get-bar-component a-menubar submenu-title))))
    (get-submenu-component a-bar-item submenu-item)))


; Submenu-item functions

;
; This function returns an instance of MOTIF-MENU-ITEM.  If the :desc key is
; supplied, then the accompanying parameter should be the string/function or
; atom/function pair that describes a submenu-item.
;

(defun Make-Motif-Submenu-Item (&key desc (enabled T))
  (let ((new-submenu-item (create-instance NIL MOTIF-MENU-ITEM
			    (:desc NIL)
			    (:item-obj (o-formula (first (gvl :desc))))
			    (:action (o-formula (second (gvl :desc))))
			    (:enabled T)
			    (:active-p (o-formula (gvl :enabled)))
			    (:get-title-fn #'menubar-get-title-motif)
			    (:set-title-fn #'menubar-set-title-motif)
			    (:parts
			     `((:item-text ,MOTIF-MENU-TEXT-LABEL-PROTOTYPE)
			       :accel-text
			       :underline)))))
    (unless (listp desc)
      (error "Expected a list description of a submenu-item, but got ~S.~%"
	     desc))
    (when desc
      (s-value new-submenu-item :desc desc))
    (s-value new-submenu-item :enabled enabled)
    new-submenu-item))



;;;
;;;  Methods for editing the strings of the menubar and submenus
;;;

(define-method :new-item-label gg::MOTIF-MENUBAR (obj)
  (let ((val (1+ (or (g-value obj :last-menubar-label-used)
		     (length (g-value obj :items))))))
    (s-value obj :last-menubar-label-used val)
    (list (format NIL "Label~a" val) NIL '(("sub-item1")))))

(define-method :new-item-label gg::MOTIF-BAR-ITEM (obj)
  (let ((val (1+ (or (g-value obj :last-bar-item-label-used)
		     (length (g-value obj :items))))))
    (s-value obj :last-bar-item-label-used val)
    (list (format NIL "Label~a" val))))

(define-method :string-set-func gg::MOTIF-MENUBAR
  (gadget-obj str-obj final-event final-string)
  ;; First test if we are editing the string of a bar-item
  (let ((a-bar-item (g-value str-obj :parent)))
    (if (is-a-p a-bar-item gg::MOTIF-BAR-ITEM)
	(let* ((agglist (g-value gadget-obj :menubar-items))
	       (old-desc (g-value a-bar-item :desc))
	       (new-desc (push final-string (cdr (copy-tree old-desc)))))
	  (Put-Down-MenuBar-Popups gadget-obj)
	  (opal::Aggrelist-Edit-String-Func gadget-obj agglist str-obj
					    final-event new-desc :rank))
	;; It wasn't the string of a bar-item.  It was a submenu item.
	(let ((agglist (g-value str-obj :parent :parent)))
	  (setf a-bar-item (g-value agglist :parent :bar-item))
	  (opal::Aggrelist-Edit-String-Func a-bar-item agglist str-obj
					    final-event (list final-string)
					    :rank))
	)))

