;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Popup menu from a button
;;;
;;;  Slots: (like those of menu and text-button)
;;;    :left - default 0
;;;    :top  - default 0
;;;    :string  - default GG:LINES-BITMAP; the string or object in the
;;;               button.  Default is a small bitmap showing a few lines
;;;            Another useful bitmap is GG:DOWNARROW-BITMAP
;;;     NOTE: do not use these bitmaps directly, but rather use something like
;;;        (:string (create-instance NIL GG:DOWNARROW-BITMAP))
;;;    :items  - Items in the pop-up menu
;;;    :v-spacing  - default 0 ; of the menu
;;;    :h-align  - default :LEFT ; of the menu
;;;    :item-font  - default opal:default-font ; for the menu strings
;;;    :selection-function  - default NIL ; called with the menu selection
;;;    :keep-menu-in-screen-p  - default T ; if T, then menu will be
;;;                        adjusted if it would go offscreen
;;;    :position  - default :below; where menu pops up.  Choices are
;;;                 :below, :left, :right or a list of two numbers
;;;                 (can be computed with a formula)
;;;    :min-menu-width - default 0; the minimum width for the menu
;;;    :shadow-offset  - default 2 ; for the button
;;;    :text-offset  - default 3 ; for the button
;;;    :gray-width  - default 2 ; for the button
;;;
;;; Read-Only
;;;    :value  - The value selected in the menu
;;;
;;;
;;;  Designed and written by Richard McDaniel who stole most
;;;    of the code from Rajan Parthasarathy
;;;
;;;  CHANGE LOG:
;;;  10/28/92  Andrew Mickish - Now :min-menu-width takes advantage of the
;;;              menu's new :min-menu-width slot
;;;  10/06/92  Brad Myers - support min-width and fix bugs
;;;  10/05/92  Andrew Mickish - Moved load of needed gadgets into loader file
;;;  10/04/92  Brad Myers - made work
;;;  09/17/92  Rich McDaniel - Created

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

(export '(Popup-Menu-Button lines-bitmap downarrow-bitmap))

#+garnet-debug
(export '(Popup-Menu-Button-Go Popup-Menu-Button-Stop))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is responsible for determining if the menu is out
;; of the screen or not.  If the menu is out of screen at
;; any of the sides, it will reset the :top and :left
;; attributes of the window to place it on the screen.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Fix-Menu-Out-Of-Screen (menuwin)
   (if (< (g-value menuwin :top) 0)
      (s-value menuwin :top 0)
      (if (> (+ (g-value menuwin :top) (g-value menuwin :height))
	     opal:*screen-height*)
         (s-value menuwin :top (- opal:*screen-height*
				(g-value menuwin :height)))
      )
   )
   (if (< (g-value menuwin :left) 0)
      (s-value menuwin :left 0)
      (if (> (+ (g-value menuwin :left) (g-value menuwin :width))
	     opal:*screen-height*)
         (s-value menuwin :left (- opal:*screen-width*
				 (g-value menuwin :width)))
      )
   )
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Call this function to show the popup-menu.
;; It positions the menu at the given place, pops up the
;; menu, and starts the interactor.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Pop-Up-Pop-Up (popupbutton)
  (let* ((event inter:*current-event*)
	 (pos (g-value popupbutton :position))
	 (menu (g-value popupbutton :menu))
	 (menuwin (g-value popupbutton :menu-window))
	 (shadowoffset (g-value popupbutton :shadow-offset))
	 x y)
    (cond ((eq pos :below)
	   (setq x (+ (g-value popupbutton :left)
		      shadowoffset))
	   (setq y (+ (g-value popupbutton :top)
		      (g-value popupbutton :height))))
	  ((eq pos :right)
	   (setq x (opal:right popupbutton))
	   (setq y (- (g-value popupbutton :top)
		      (floor (- (g-value menu :height)
				(g-value popupbutton :height)) 2)
		      1)))
	  ((eq pos :left)
	   (setq x (+ (- (g-value popupbutton :left)
			 (g-value menu :width))
		      shadowoffset
		      1))
	   (setq y (- (g-value popupbutton :top)
		      (floor (- (g-value menu :height)
				(g-value popupbutton :height)) 2))))
	  ((listp pos)
	   (setq x (car pos))
	   (setq y (cadr pos)))
	  (T (error ":position argument for ~s must
 be :below :right :left or list of (x y), but it is ~s" popupbutton pos)))
    (multiple-value-bind (wx wy)
	(opal:convert-coordinates (g-value popupbutton :window) x y NIL)
      (s-value menuwin :left wx)
      (s-value menuwin :top wy)
      (when (g-value popupbutton :keep-menu-in-screen-p)
         (Fix-Menu-Out-Of-Screen menuwin))

      (s-value menuwin :visible T)
      (opal:raise-window menuwin)  ;; raise calls update
      (setf (inter:event-window event) menuwin)
      (setf (inter:event-x event) -10)
      (setf (inter:event-y event) -10) ; make sure is :outside
      (inter:start-interactor (g-value menu :selector) event)
      ;; make sure the menu interactor processes the event, so will be :outside
      (inter::general-go (g-value menu :selector) event))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is the popup menu gadget itself.  Really it's
;; just a window.  A menu gets put inside on
;; initialization.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(create-instance 'lines-bitmap opal:bitmap
    (:image (opal:read-image (merge-pathnames "pop-up-icon-no-border.bm"
					     user::Garnet-Bitmap-Pathname))))
(create-instance 'downarrow-bitmap opal:bitmap
    (:image (opal:read-image (merge-pathnames "downarrow.bm"
					     user::Garnet-Bitmap-Pathname))))

(create-instance 'Popup-Menu-Button gg:text-button
  (:left 0)
  (:top 0)
  (:string lines-bitmap)
  (:items '("Item 1" "Item 2" "Item 3" "Item 4"))
  (:v-spacing 0)
  (:h-align :LEFT)
  (:title NIL)
  (:item-font opal:default-font)
  (:selection-function NIL)
  (:value-obj (o-formula (gvl :menu :value-obj)))
  (:value (o-formula (gvl :value-obj :string)))
  (:keep-menu-in-screen-p T)
  (:position :below)
  (:min-menu-width 0) 

  (:SHADOW-OFFSET 2)
  (:TEXT-OFFSET 3)
  (:GRAY-WIDTH 2)

  ;; internal slots
  (:final-feedback-p NIL)
  
  (:menu NIL) ; filled in by initialize with the menu
  (:menu-window NIL)  ; filled in by initialize with the menu's window

  (:interactors
      `((:text-button-press :modify
	 (:running-where T)
	 (:window ,(o-formula (let* ((oper (gvl :operates-on))
				     (my-win (gv oper :window))
				     (menu-win (gv oper :menu-window)))
				(if (and my-win menu-win)
				    (list my-win menu-win)
				    my-win))))
	 (:start-action
	      ,#'(lambda (inter button)
		    (call-prototype-method inter button)
		    (pop-up-pop-up button)))
	 (:final-function
	  ,#'(lambda (int val)
	      (declare (ignore val))
	      (let* ((oper (g-value int :operates-on))
		     (menu (g-value oper :menu))
		     (menuinter (g-value menu :selector))
		     (outside (g-value menuinter :current-state))
		     val)
		(inter:stop-interactor menuinter) ; in case still running
		;; when menuinter is outside, then will abort, so don't do
		;; selection function, etc.
		(unless (eq outside :outside)
		  (setq val (g-value menu :value)) ; do this after stop-inter
		  (s-value oper :value val)
		  (kr-send oper :selection-function oper val)))))
	 ))))

(create-instance 'popupbuttonmenuproto gg:menu
  (:left 0) (:top 0)
  (:popup NIL)
  (:v-spacing (o-formula (gvl :popup :v-spacing)))
  (:h-align (o-formula (gvl :popup :h-align)))
  (:shadow-offset 0)
  (:text-offset (o-formula (gvl :popup :text-offset)))
  (:title NIL)
  (:items (o-formula (gvl :popup :items)))
  (:item-font (o-formula (gvl :popup :item-font)))
  (:min-menu-width (o-formula (gvl :popup :min-menu-width)))
  (:interactors
   `((:selector :modify
      (:window ,(o-formula
		 (let* ((oper (gvl :operates-on))
			(my-win (gv oper :window))
			(button-win (gv oper :popup :window)))
		   (if button-win
		       (list my-win button-win)
		       my-win))))
      (:stop-action ,#'(lambda (int val)
			 (call-prototype-method int val)
			 (let ((window (g-value int :operates-on :window)))
			   (s-value window :visible NIL))))
      (:abort-action ,#'(lambda (int val)
			  (call-prototype-method int val)
			  (let ((window (g-value int :operates-on :window)))
			    (s-value window :visible NIL))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is the initialize method for the popup menu.
;; It automatically creates a menu gadget inside the
;; popup window.
;;
;; Then, it fixes up the interactors in the menu.  First,
;; the stop event is set to be leftup, which is releasing
;; the mouse button.  Then, it sets up the stop action of
;; the menu so that the window is made invisible.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-method :initialize Popup-Menu-Button (popup)
 (let (popmenu window)
   (call-prototype-method popup)
   (let ((kr::*demons-disabled* NIL)) ; turn on all demons
     (setq popmenu (create-instance NIL popupbuttonmenuproto
		     (:popup popup)))
     ;; change the formula so the menu's width will be bigger if necessary
     (setq window (create-instance NIL inter:interactor-window
		  (:omit-title-bar-p T)
		  (:double-buffered-p T)
		  (:save-under T)
		  (:border-width 0)
		  (:menu popmenu)
		  (:aggregate popmenu)
		  (:height (o-formula (gvl :menu :height)))
		  (:width (o-formula (gvl :menu :width)))
		  (:visible NIL)))
       (s-value popup :menu popmenu)
       (s-value popup :menu-window window)
       (opal:Update window))))

(define-method :destroy-me Popup-Menu-Button (popup &optional erase)
  (let ((menu-win (g-value popup :menu-window)))
    (when menu-win
      (opal:destroy menu-win))
    (call-prototype-method popup erase)))


(define-method :add-local-item Popup-Menu-Button (gadget item &rest args)
  (opal::Gadget-Add-Local-Item (g-value gadget :menu)
			       item :text-button-list args)
  (opal:update (g-value gadget :menu-window)))
(define-method :add-item Popup-Menu-Button (gadget item &rest args)
  (opal::Gadget-Add-Item (g-value gadget :menu) item :text-button-list args)
  (opal:update (g-value gadget :menu-window)))
(define-method :remove-local-item Popup-Menu-Button
               (gadget &optional item &key (key #'opal:no-func))
  (opal::Gadget-Remove-Local-Item (g-value gadget :menu)
				  item :text-button-list key)
  (opal:update (g-value gadget :menu-window)))
(define-method :remove-item Popup-Menu-Button
               (gadget &optional item &key (key #'opal:no-func))
  (opal::Gadget-Remove-Item (g-value gadget :menu) item :text-button-list key)
  (opal:update (g-value gadget :menu-window)))
(define-method :notice-items-changed Popup-Menu-Button
               (gadget &optional no-propagation)
  (opal:notice-items-changed (g-value gadget :menu) no-propagation)
  (opal:update (g-value gadget :menu-window)))
(define-method :change-item Popup-Menu-Button (gadget newitem n)
  (let ((menu (g-value gadget :menu))
	(menuwin (g-value gadget :menu-window)))
    (kr-send menu :change-item menu newitem n)
    (opal:update menuwin)))

(s-value Popup-Menu-Button :remove-nth-item
	 (g-value opal:aggrelist :remove-nth-item))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is like the mini-demo function for this gadget.
;; It basically creates a window with a button.  Pressing
;; the button will cause a popup window to appear.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+garnet-debug
(defun Popup-Menu-Button-Go ()
   (create-instance 'demo-popup-win inter:interactor-window
         (:title "Popup Menu Button Demo")
         (:left 100) (:top 100) (:height 90) (:width 180))
   (create-instance 'demo-popup-agg opal:aggregate)
   (s-value demo-popup-win :aggregate demo-popup-agg)
   (opal:update demo-popup-win)

   (create-instance 'demo-popup-text-label opal:text
         (:top 50) (:left 15)
	 (:string "Selected: "))

   (create-instance 'demo-popup-button Popup-Menu-Button
	 (:left 15)
	 (:top 10)
	 (:items '("Red" "Blue" "Green" "Yellow" "Aquamarine"
		   "Cyan" "Fluorescent"))
	 (:selection-function #'(lambda (g v)
				  (declare (ignore g))
				  (format T "Selected is ~s~%" v))))

   (create-instance 'demo-popup-text opal:text
        (:top 50)
	(:left (o-formula (+ (g-value demo-popup-text-label :left)
			     (g-value demo-popup-text-label :width))))
	(:string (o-formula (format NIL "~s" (gv demo-popup-button :value)))))


   (opal:add-components demo-popup-agg demo-popup-button demo-popup-text
			demo-popup-text-label)

   (opal:update demo-popup-win)
   )

#+garnet-debug
(defun Popup-Menu-Button-Stop ()
   (opal:destroy demo-popup-win)
   )
