;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Pull Down Menus
;;;
;;;
;;;  Customizable slots:
;;;    1)  Left, top
;;;    2)  Title-font, item-font
;;;    4)  Selection-function - a function to be executed when any item is
;;;           selected.  Takes the parameters (gadget menu-item submenu-item).
;;;    5)  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.
;;;
;;;  Programming interface (Garnet way):
;;;    1) Create an instance of menubar with a value for the :items slot
;;;    2) Use opal:add-component to put the instance in a window
;;;    3) Call opal:notice-items-changed on the instance
;;;
;;;  Caveats:
;;;     New 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.  Choosing an item from the pull-down menu will
;;;    change the font of the text objects.
;;;    To run it, enter (GARNET-GADGETS:menubar-go).
;;;    To stop, enter (GARNET-GADGETS:menubar-stop).
;;;
;;;  Written by Pavan Reddy and Andrew Mickish

;;;
;;; CHANGE LOG:
;;; 06/26/92  Andrew Mickish - Rewrote :notice-items-changed, :add-item, and
;;;             :remove-item methods so objects can appear in the :items list
;;; 06/22/92  Ed Pervin - It is necessary to call notice-items-changed on
;;;		menubars during the execution of opal:reconnect-garnet.
;;; 05/22/92  Brad Myers - new way to use menu-interactor that uses multiple
;;;                        windows.
;;; 04/15/92  Andrew Mickish - Gave BAR-ITEM text a white line style and put
;;;             it on top of the "cover"
;;; 04/14/92  Andrew Mickish - Added schema-p check in final-function so you
;;;             can destroy the menubar in an item function
;;; 02/19/92  Andrew Mickish - Fixed reuse of old bar-items by adding a push
;;;             in the remove-item method and a pop in the add-item method
;;; 06/10/91  Ed Pervin - Call opal:raise-window on subwindows so
;;;		they won't be covered by main window in twm.
;;; 05/15/91  Andrew Mickish - Added defvar's
;;; 05/01/91  Andrew Mickish - Put in Garnet-Gadgets package


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

(export '(MENUBAR BAR-ITEM SUBMENU SUBMENU-ITEM MAKE-SUBMENU-WIN

	  ; Creation Functions
	  Make-Menubar Make-Bar-Item Make-Submenu-Item
	  
	  ; Adding and Removing Items/Components
	  Set-Menubar Set-Submenu Add-Submenu-Item Remove-Submenu-Item

	  ; Enabling and Disabling Components
	  Menubar-Enable-Component Menubar-Disable-Component
	  Menubar-Enabled-P

	  ; Finding Components of the Menubar
	  Menubar-Components Submenu-Components Get-Bar-Component
	  Get-Submenu-Component Find-Submenu-Component

	  ; Other Menubar Functions
	  MENUBAR-GET-TITLE MENUBAR-SET-TITLE MENUBAR-INSTALLED-P))

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



(defun Menubar-Get-Label (agg)
  (let ((alist (g-value agg :parent)))
    (if alist  ;; Must check because the item-prototype
               ;; has no parent!
	(let ((item (nth (g-value agg :rank)
			 (g-value alist :items)))
	      (text-label-prototype (g-value alist :text-label-prototype)))
	  ;; Don't forget that item functions are allowed!
	  (if (consp item) (setq item (first item)))
	  ;; Don't forget that menus have item conversion functions!
	  (if (g-value alist :item-to-string-function)
	      (setf item (kr-send alist :item-to-string-function item)))
	  (cond
	    ((schema-p item)
	     (let ((new-label (if (g-value item :parent)
				  ;; The item has been used already --
				  ;; Use it as a prototype
				  (create-instance NIL item)
				  ;; Use the item itself
				  item))
		   (leftform (get-value text-label-prototype :left))
		   (topform (get-value text-label-prototype :top)))
	       ;; Automatically set the :left and :top of the label
	       (unless (is-a-p (get-local-value item :left) leftform)
		 (s-value new-label :left (formula leftform)))
	       (unless (is-a-p (get-local-value item :top) topform)
		 (s-value new-label :top (formula topform)))
	       new-label))
	    (t (create-instance NIL text-label-prototype))))
	;; Give the item-prototype a bogus part
	(create-instance NIL opal:null-object))))


;; This is an item in the vertical menus that appear below the menu bar.
;;
(create-instance 'SUBMENU-ITEM opal:aggregadget
   ; 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 :items))))
   (:item-obj (o-formula (first (gvl :desc))))
   (:action (o-formula (second (gvl :desc))))
   (:string (o-formula (let ((item-obj (gvl :item-obj)))
			 (if (stringp item-obj)
			     item-obj
			     (string-capitalize
			      (string-trim ":" item-obj))))))
   (:text-offset (o-formula (gvl :parent :text-offset)))
   (:enabled (o-formula (if (= 4 (length (gvl :desc)))
			    (fourth (gvl :desc)) T)))
   (:font (o-formula (gvl :parent :font)))
   (:text-offset2 (o-formula (gvl :parent :text-offset2)))
   (:h-align (o-formula (gvl :parent :h-align)))
   (:max-text-width-thus-far
       (o-formula (if (gvl :prev-visible)
		      (MAX (gvl :prev-visible :max-text-width-thus-far)
			   (gvl :text :width))
		      (gvl :text :width))))
   (:height (o-formula (+ (gvl :text :height) (gvl :text-offset2))))
   (:width (o-formula (+ (gvl :parent :tail :max-text-width-thus-far)
			      (gvl :text-offset2))))
   ;; parent is a submenu
   (:bar-item (o-formula (gvl :parent :bar-item)))
   (:parts
    `((:text ,#'Menubar-Get-Label)
      (:cover ,opal:rectangle
	     (:left ,(o-formula (gvl :parent :text :left)))
	     (:top ,(o-formula (gvl :parent :text :top)))
	     (:height ,(o-formula (- (gvl :parent :height)
				     (gvl :parent :text-offset2))))
	     (:width ,(o-formula (- (gvl :parent :width)
				    (gvl :parent :text-offset2))))
	     (:visible ,(o-formula (or (not (gvl :parent :enabled))
				       (gvl :parent :interim-selected))))
	     (:draw-function ,(o-formula (if (gvl :parent :enabled)
					    :xor :and)))
	     (:line-style NIL)
	     (:filling-style ,(o-formula (if (gvl :parent :enabled)
					    opal:black-fill
					    opal:gray-fill)))))))


;; Menu that pops up when you click on the menubar
;; A window for this object is created in Attach-Submenu
;;
(create-instance 'SUBMENU opal:aggrelist
   (:left 0)
   (:top 0)
   (:height (o-formula (let ((total-height 0))
			 (dolist (c (gvl :components))
			   (incf total-height (g-value c :height)))
			 total-height)))
   (:h-align :left)
   (:text-offset 5)
   (:text-offset2 6)
   (:v-spacing 0)
   (:font NIL)  ; Set during notice-items-changed or add-item
   (:my-baritem NIL)
   (:enabled-items
    (o-formula (let ((enabled-items NIL))
		 (dovalues (component :self :components
				      :in-formula T
				      :result enabled-items)
		    (when (gv component :enabled)
		      (push component enabled-items))))))
   (:items (o-formula (gvl :bar-item :items)))
   (:item-prototype submenu-item)
   (:text-label-prototype
    (create-instance NIL opal:text
      (:left (o-formula
	      (case (gvl :parent :h-align)
		(:left (+ (gvl :parent :left) (gvl :parent :text-offset)))
		(:center (opal:gv-center-x-is-center-of (gvl :parent)))
		(:right (- (+ (gvl :parent :left) (gvl :parent :width))
			   (gvl :width) (gvl :parent :text-offset))))))
      (:top (o-formula (+ (gvl :parent :top) (gvl :parent :text-offset))))
      (:string (o-formula (gvl :parent :string)))
      (:font (o-formula (gvl :parent :font))))))




;; Returns a window that an instance of SUBMENU can be put into
;;
(defun MAKE-SUBMENU-WIN (a-bar-item a-submenu)
  (create-instance NIL inter:interactor-window
     (:bar-item a-bar-item)
     (:aggregate a-submenu)
     (:omit-title-bar-p T)
     (:save-under T)         
     (:double-buffered-p T)  
     (:visible NIL)
     (:height (o-formula
	       (gvl :aggregate :height)))
     (:width (o-formula
	      (gvl :aggregate :width)))
     (:left (o-formula (let* ((bar-item (gvl :bar-item))
			      (win (gv bar-item :window)))
			 (if win 
			     (+ (gv bar-item :left) (gv win :left)
				(gv win :left-border-width))
			     0))))
     (:top (o-formula (let* ((bar-item (gvl :bar-item))
			     (window (gv bar-item :window)))
			(if window
			    (+ (gv bar-item :top) (gv bar-item :height)
			       (gv window :top) (gv window :top-border-width))
			    0))))))



;; This object is a text field in the menu bar covered by a black rectangle.
;; An aggrelist of these items makes up the menu bar.
;;
(create-instance 'BAR-ITEM opal:aggregadget
   ; 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 :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 :title-font)))
   (:spacing 5)
   (:enabled (o-formula (if (= 4 (length (gvl :desc)))
			    (fourth (gvl :desc))
			    T)))
   ;; slot :submenu filled by notice-items-changed with a SUBMENU
   ;; slot :submenu-window set with the window of the submenu

   (:parts
    `((:cover ,opal:rectangle
	     (:left ,(o-formula (gvl :parent :left)))
	     (:top ,(o-formula (gvl :parent :top)))
	     (:height ,(o-formula (gvl :parent :text :height)))
             (:width ,(o-formula (+ (* 2 (gvl :parent :spacing))
				    (gvl :parent :text :width))))
	     (:line-style NIL)
	     (:filling-style ,(o-formula
			       (if (gvl :parent :enabled)
				   (if (gvl :parent :interim-selected)
				       opal:white-fill
				       opal:black-fill)
				   opal:gray-fill))))
      (:text ,opal:text
       (:top ,(o-formula (gvl :parent :top)))
       (:left ,(o-formula (+ (gvl :parent :left) (gvl :parent :spacing))))
       (:font ,(o-formula (gvl :parent :font)))
       (:string ,(o-formula (string (gvl :parent :string))))
       (:line-style ,(o-formula (if (gvl :parent :interim-selected)
				    opal:default-line-style
				    opal:white-line)))))))


(create-instance 'MENUBAR opal:aggrelist
   ; Customizable slots
   (:left 0)(:top 0)
   (:items NIL)
   (:title-font opal:default-font)
   (:item-font opal:default-font)

   ; Internal slots
   (:h-spacing 0)
   (:direction :horizontal)
   (:item-prototype BAR-ITEM)
   (:selection-function NIL)
   (:enabled-items
    (o-formula (let ((enabled-items NIL))
		 (dovalues (component :self :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 baritems :submenu :enabled-items)))))
		 l)))
   (:right (o-formula (+ (gvl :left) (gvl :width))))
   (:destroy-me 'MENUBAR-DESTROY)
   
   ;; slot :submenu-window-list set with list of all windows being used.
   (:interactors
    `((:menubar-select ,inter:menu-interactor
       ;; the window slot is destructively modified to also contain
       ;; the other windows.
       (:window ,(o-formula (gv-local :self :operates-on :window)))
       (:start-where ,(o-formula (list :list-element-of
				       (gvl :operates-on)
				       :list-of-all-enabled-objects)))
       (:outside 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 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 BAR-ITEM))
		    (new-baritem (when new
				   (if new-is-bar
				     new
				     ;; else is a sub-item, get its bar-item
				     (g-value new :bar-item)))))
	       ;; keep the interim selected of the bar item so it
	       ;; shows up as highlighted when items in sub-menu selected.
	       (when 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)
		   (when prev-baritem
		     (let ((win (g-value prev-baritem :submenu-window)))
		       (s-value prev-baritem :interim-selected NIL)
		       (s-value win :visible NIL)
		       (opal:update win)))
		   (when new-baritem
		     (let ((win (g-value new-baritem :submenu-window)))
		       (s-value win :visible T)
		       (opal:raise-window win)))))  ;; calls update
	       (call-prototype-method inter prev new)
	       ;;; 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
		 (s-value prev-baritem :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))))))
       (:final-function
	,#'(lambda (inter obj)
	     (let* ((is-bar (is-a-p obj BAR-ITEM))
		    (baritem (if is-bar obj
				 ;; else is a sub-item, get its bar-item
				 (g-value obj :bar-item)))
		    (bar-action (g-value baritem :action))
		    (bar-obj (g-value baritem :menu-obj))
		    (item-action (unless is-bar (g-value obj :action)))
		    (item-obj (unless is-bar (g-value obj :item-obj)))
		    (gadget (g-value inter :operates-on))
		    (prev-baritem (g-value inter :prev-baritem))
		    )
	       (when baritem
		 (s-value baritem :interim-selected NIL)
		 (let ((win (g-value baritem :submenu-window)))
		   (when win
		     (s-value win :visible NIL)
		     (opal:update win))))
	       (when prev-baritem
		 (s-value inter :prev-baritem NIL))
	       (if bar-action
		   (funcall bar-action gadget bar-obj item-obj))
	       ;; The schema-p check allows you to destroy the menubar gadget
	       ;; in the menu-action or item-action and avoid passing the
	       ;; destroyed object to KR-SEND
	       (if (and item-action
			(schema-p gadget))
		   (funcall item-action gadget bar-obj item-obj))
	       (if (schema-p gadget)
		   (kr-send gadget :selection-function
			    gadget bar-obj item-obj)))))
       ))))


(defun MENUBAR-DESTROY (a-menubar &optional erase)
  ; Destroy each window that is associated with this menubar
  (dolist (win (g-value a-menubar :submenu-window-list))
    (opal:destroy win))
  ; Destroy the menubar itself
  (call-prototype-method a-menubar erase))


;;; Auxiliary function for MENUBAR's :notice-items-changed 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 :window slot of the interactor in the top-level
;;; menubar.
(defun ATTACH-SUBMENU (a-menubar 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-value a-bar-item :submenu)
			  (create-instance NIL SUBMENU
			     (:bar-item a-bar-item)
			     (:font (g-value a-menubar :item-font)))))
	 (win (or (g-value a-bar-item :submenu-window)
		  (Make-Submenu-Win a-bar-item new-submenu)))
	 (top-inter (g-value a-menubar :menubar-select))
	 (menu-windows (g-value top-inter :window)))
      (if (listp menu-windows)
	  (s-value top-inter :window
		   (append (g-value top-inter :window) (list win)))
	  (s-value top-inter :window (list menu-windows win)))
      ; if a-bar-item was taken from storage, then its :submenu-window is
      ; already on the :submenu-window-list
      (pushnew win (g-value a-menubar :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 notice-items-changed 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 :notice-items-changed MENUBAR (a-menubar &optional no-prop)
  ;; Remove submenu windows from the top-level interactor's :window list
  (let* ((top-inter (g-value a-menubar :menubar-select))
	 (window (or (g-local-value top-inter :window)
		     (if (listp (g-value top-inter :window))
			 (copy-list (g-value top-inter :window))
			 (g-value top-inter :window)))))
    ;; The menubar's window is first in the list, the rest are submenu windows
    (if (listp window) (setf (cdr window) NIL))
    (s-value top-inter :window window))
  ;; Generate new bar-items
  (call-prototype-method a-menubar no-prop)
  ;; Generate new submenu windows for the bar-items
  (dolist (c (Menubar-Components a-menubar))
    (ATTACH-SUBMENU a-menubar c)))

;;;
;;;  DEMO FUNCTIONS
;;;


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


;;; When we want to change an object's font, set the slots of *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 Change-Font (text-obj &key family face size)
  (let ((old-font (g-value text-obj :font))
	(new-font *FONT-TO-SWAP*))
    (setf *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 Family-Fn (gadget slot value)
  (declare (ignore gadget))
  (change-font family-text slot value)
  (s-value family-text :string (string-downcase value)))
#+garnet-debug
(defun Face-Fn (gadget slot value)
  (declare (ignore gadget))
  (change-font face-text slot value)
  (s-value face-text :string (string-downcase value)))
#+garnet-debug
(defun Size-Fn (gadget slot value)
  (declare (ignore gadget))
  (change-font size-text slot value)
  (s-value size-text :string (string-downcase value)))

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

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

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

  (create-instance 'DEMO-MENUBAR MENUBAR
     (:items
      '((:family family-fn
	 ((:fixed fixed-fn)(:serif serif-fn)(:sans-serif sans-serif-fn)))
	(:face face-fn
	 ((:roman)(:bold)(:italic)(:bold-italic)))
	(:size size-fn
	 ((:small)(:medium)(:large)(:very-large)))))
     (:selection-function
      #'(lambda (gadget slot value)
	  (declare (ignore gadget slot value))
	  (let ((family (g-value family-text :font :family))
		(face (g-value face-text :font :face))
		(size (g-value size-text :font :size)))
	    (change-font combo-text
			 :family family :face face :size size)))))

  ; NOTE: It is essential to add the MENUBAR instance to an aggregate _before_
  ; calling Opal:notice-items-changed (so that the :window slot of the
  ; aggregate is set)
  (opal:add-component MENUBAR-TOP-AGG DEMO-MENUBAR)
  (opal:notice-items-changed DEMO-MENUBAR)
  (opal:update MENUBAR-WIN)

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

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


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

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


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

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

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


(defun Confirm-Submenu-Item (a-submenu-item)
  (unless (is-a-p a-submenu-item SUBMENU-ITEM)
    (error "~S is not an instance of ~S.~%" a-submenu-item SUBMENU-ITEM))
  T)

(defun Confirm-Bar-or-Submenu-Item (menubar-component)
  (unless (or (is-a-p menubar-component BAR-ITEM)
	      (is-a-p menubar-component SUBMENU-ITEM))
    (error "~S is not an instance of ~S or ~S.~%" menubar-component
	   BAR-ITEM SUBMENU-ITEM))
  T)


;;;
;;;  EXPORTED FUNCTIONS
;;;

; Menubar Functions


;
; The parameter item may be either 
; 1) An instance of BAR-ITEM, or
; 2) A sublist of an :items list
;
; 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-menubar new-bar :after "Bar2" :key #'car)
;
; Implementation note:  The reason that we do not just set the :items list
; and call notice-items-changed is that the item parameter can be an actual
; component to be added, so you should not generate a new component via
; notice-items-changed.
;
(define-method :add-item MENUBAR (a-menubar item &rest args)
  (let* ((a-bar-item (if (is-a-p item 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-bar-item :desc item))))
	 (parent (g-value a-bar-item :parent)) ; parent should be NIL
	 where locator key)

    (when parent
      (error "~S is already installed in ~S.~%" a-bar-item parent))
    
    (multiple-value-setq (where locator key) (opal::get-wheres args))
    
    ; Add the description to the menubar's :items list
    (let ((items (copy-list (g-value a-menubar :items)))
	  (desc (g-value a-bar-item :desc)))
      (s-value a-menubar
	       :items
	       (opal::insert-item desc items where locator key)))
      
    ; Add the bar-item as a component of the menubar
    (let ((locator-comp (if (is-a-p locator BAR-ITEM)
			    locator
			    (get-bar-component a-menubar locator))))
      (opal:add-local-component a-menubar a-bar-item where locator-comp)
      (incf (g-value a-menubar :number-of-comps)))

    ; 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
      (pushnew win (g-value a-menubar :submenu-window-list))
      ; Add win to the top-level interactor's :window slot
      (if (listp cur-wins)
	  (push 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 BAR-ITEM, or
; 2) A sublist of the :items list
;
(define-method :remove-item MENUBAR (a-menubar item)
  (let ((a-bar-item (if (is-a-p item BAR-ITEM)
			item
			(get-bar-component a-menubar item))))
    (unless (and a-bar-item
		 (eq a-menubar (g-value a-bar-item :parent)))
      (error "~S does not have ~S as its menubar.~%"
	     a-bar-item a-menubar))
      
    ; Remove the bar-item from the menubar
    (let ((top-inter (g-value a-menubar :menubar-select)))
      (s-value top-inter
	       :window
	       (remove (g-value a-bar-item :submenu-window)
		       (g-value top-inter :window)))
      (opal:remove-local-component a-menubar a-bar-item)
      (unless (eq a-bar-item item)
	(push a-bar-item (g-value a-menubar :storage)))
      (decf (g-value a-menubar :number-of-comps)))
      
    ; Change the top-level :items list
    (let ((old-desc (if (is-a-p a-bar-item BAR-ITEM)
			(g-value a-bar-item :desc)
			a-bar-item)))
      (s-value a-menubar :items (remove old-desc (g-value a-menubar :items)
					:test #'equal)))))

(defun Make-Menubar ()
  (create-instance NIL menubar))

(defun Menubar-Components (a-menubar)
  (and (Confirm-Menubar a-menubar)
       (g-value a-menubar :components)))

(defun Set-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 a-menubar old-comp))
    (dolist (new-menu new-menus)
      (opal:add-item a-menubar new-menu))))



; Bar-Item functions

;
; The item parameter can either be
; 1) An instance of SUBMENU-ITEM, or
; 2) A description of a submenu-item: (list string action) where "string" is
;    a string or atom and "action" is a function
;
(define-method :add-item BAR-ITEM (a-bar-item item &rest args)
  (let ((a-menubar (g-value a-bar-item :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)
    (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))
	       (rank (position new-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))
    	    (opal:add-local-component submenu 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))
	       (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))
	    (opal::Add-The-Component submenu rank)))))



;
;
; The item parameter can be either
; 1) An instance of SUBMENU-ITEM, or
; 2) A string or atom
;
(define-method :remove-item BAR-ITEM (a-bar-item &optional item
						 &key (key #'opal:no-func))
  (let* ((a-submenu-item (if (is-a-p item SUBMENU-ITEM)
			     item
			     (get-submenu-component a-bar-item item)))
	 (submenu (g-value a-bar-item :submenu))
	 (submenu-components (g-value submenu :components))
	 (rank (if item
		   (position a-submenu-item submenu-components
			     :test #'(lambda (x y)
				       (equal x (funcall key y))))
		   (1- (length submenu-components)))))

    (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)))
    ; Remove the submenu-item from the bar-item
    (opal:remove-local-component submenu a-submenu-item)
    
    ; Update the :items or :desc list
    (let* ((a-menubar (g-value a-bar-item :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 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 BAR-ITEM :change-item (g-value opal:aggrelist :change-item))
(s-value BAR-ITEM :remove-nth-item (g-value opal:aggrelist :remove-nth-item))



(defun Get-Bar-Component (a-menubar item)
  (Confirm-Menubar a-menubar)
  (find-if #'(lambda (a-bar-item)
	       (if (listp item)
		   (equal item (g-value a-bar-item :desc))
		   (equal item (g-value a-bar-item :menu-obj))))
	   (Menubar-Components a-menubar)))

(defun Make-Bar-Item (&key desc font title)
  (let* ((new-bar-item (create-instance NIL BAR-ITEM))
	 (new-submenu (create-instance NIL SUBMENU
			 (:bar-item new-bar-item)
			 (:font (or font opal:default-font))))
	 (win (Make-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)))
    (opal:notice-items-changed new-submenu)
    new-bar-item))


(defun Menubar-Get-Title (menubar-component)
  (cond ((is-a-p menubar-component BAR-ITEM)
	 (g-value menubar-component :menu-obj))
	((is-a-p menubar-component SUBMENU-ITEM)
	 (g-value menubar-component :item-obj))
	; Else, print error message
	(t (Confirm-Bar-or-Submenu-Item menubar-component))))
		

; 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 (menubar-component string)
  (cond

    ;; The parameter is a BAR-ITEM
    ((is-a-p menubar-component BAR-ITEM)
     (let* ((a-bar-item menubar-component)
	    (a-menubar (g-value a-bar-item :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 SUBMENU-ITEM
    ((is-a-p menubar-component SUBMENU-ITEM)
     (let* ((a-submenu-item menubar-component)
	    (a-submenu-agg (g-value menubar-component :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))))
	    (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 (Confirm-Bar-or-Submenu-Item menubar-component)))
  
  string)


(defun Menubar-Disable-Component (menubar-component)
  (Confirm-Bar-or-Submenu-Item menubar-component)
  (s-value menubar-component :enabled NIL))

(defun Menubar-Enable-Component (menubar-component)
  (Confirm-Bar-or-Submenu-Item menubar-component)
  (s-value menubar-component :enabled T))

(defun Menubar-Enabled-P (menubar-component)
  (Confirm-Bar-or-Submenu-Item menubar-component)
  (g-value menubar-component :enabled))


(defun Menubar-Installed-P (menubar-component)
  (Confirm-Bar-or-Submenu-Item menubar-component)
  (g-value menubar-component :parent))





(defun Submenu-Components (a-bar-item)
  (Confirm-Bar-Item a-bar-item)
  (g-value a-bar-item :submenu :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.
;
(defun Add-Submenu-Item (a-menubar b-item s-item &rest args)
  (let* ((a-bar-item (if (is-a-p b-item BAR-ITEM)
			 b-item
			 (get-bar-component a-menubar b-item)))
	 where locator key)
    (multiple-value-setq (where locator key) (opal::get-wheres args))
    (opal:add-item a-bar-item s-item where locator key)))

;
; After looking up the b-item to get a bar-item object, call opal:remove-item.
;
(defun Remove-Submenu-Item (a-menubar b-item s-item)
  (let* ((a-bar-item (if (is-a-p b-item 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 SUBMENU-ITEM instances, or
;   2) A list of submenu-item descriptions, such as
;      ((item1 action1) (item2) (item3 action3)))
;
(defun Set-Submenu (a-bar-item new-desc)
  (let ((components (copy-list (Submenu-Components a-bar-item))))
    (dolist (old-comp components)
      (opal:remove-item a-bar-item old-comp)))
  (dolist (comp new-desc)
    (opal:add-item a-bar-item comp)))

(defun Get-Submenu-Component (a-bar-item item)
  (Confirm-Bar-Item a-bar-item)
  (find-if #'(lambda (a-submenu-item)
	       (if (listp item)
		   (equal item (g-value a-submenu-item :desc))
		   (equal item (g-value a-submenu-item :item-obj))))
	   (Submenu-Components a-bar-item)))

(defun Find-Submenu-Component (a-menubar submenu-title submenu-item)
  (Confirm-Menubar a-menubar)
  (let ((a-bar-item (if (is-a-p submenu-title 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 SUBMENU-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-Submenu-Item (&key desc (enabled T))
  (let ((new-submenu-item (create-instance NIL SUBMENU-ITEM)))
    (unless (listp desc)
      (error "Expected a list description of a submenu-item, but got ~S.~%"
	     desc))
    (when desc
      (g-value new-submenu-item :desc)
      (s-value new-submenu-item :desc desc))
    (g-value new-submenu-item :enabled)
    (s-value new-submenu-item :enabled enabled)
    new-submenu-item))

#|
***** PROBLEMS: Asynchronous window errors
***** disabled items not going grey
|#
