;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Option button
;;;
;;;  Designed and written by Rajan Parthasarathy

;;;  CHANGE LOG:
;;;  09/28/92  Mickish - Formula --> o-formula in Put-Menu-In-Window
;;;  07/27/92  Rajan - Created

(in-package "GARNET-GADGETS" :use '("LISP" "KR"))
(defparameter motif-ob NIL)
(defparameter demo-ob NIL)

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is responsible for saying if the menu is out
;; of the screen or not.  If the menu is out of screen at
;; the top, it returns 'TOP.  If menu's bottom is out of
;; screen, it returns 'BOTTOM.  Otherwise, it returns NIL.
;; NOTE: It also returns NIL for the case when BOTH the
;; top and bottom are out of screen.  In this situation,
;; the user is SCREEEEEEEWEEEED... (-:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun Menu-Out-Of-Screen (button)
  (let ((menu (g-value button :parent :option-button-menu))
	(return-value NIL))
    (cond
      ((NULL (g-value menu :window :top)) NIL)
      ((AND (< (g-value menu :window :top) 0)
	    (> (+ (g-value menu :window :top)
		  (g-value menu :window :height))
	       opal:*screen-height*)) (setf return-value NIL))
      ((< (g-value menu :window :top) 0) (setf return-value 'top))
      ((> (+ (g-value menu :window :top)
	     (g-value menu :window :height))
	  opal:*screen-height*) (setf return-value 'bottom)))

    return-value))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is responsible for calculating and setting the
;; left and top of the menu's window.  It takes in the
;; button and its value.  The left of the window is
;; the left of the object window + the left of the button.
;;
;; The top is more complicated.  It initially sets the top
;; so that the item in the button is positioned where the
;; cursor is now.  Then, it checks to see if the menu is
;; out of the screen, by calling menu-out-of-screen.
;;
;; If the top of the menu is out of screen, it positions
;; the top at 0.  If the bottom is out, it positions the
;; bottom as far down as possible.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun Set-Menu-Top-And-Left (g v)
  (let ((menu (g-value g :parent :option-button-menu)))
    (s-value menu :win-left
	     (+ (g-value g :parent :window :left) (g-value g :left)))

    (s-value menu :win-top
	     (+ (g-value g :parent :window :top)
		(- (g-value g :top)
		   (* (g-value g :height)
		      (position v
				(g-value
				g :parent :real-items) 
				:test #'equalp)))))

    (opal:update (g-value menu :window))

    (when (g-value g :parent :keep-menu-in-screen-p)
      (if (eq (menu-out-of-screen g) 'top)
	  (s-value menu :win-top
		   (- (g-value g :parent :window :top-border-width)))
	  (if (eq (menu-out-of-screen g) 'bottom)
	      (s-value menu :win-top
		       (- opal:*screen-height*
			  (g-value menu :window :height)
			  (g-value g :parent :window :top-border-width))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function puts the cursor in the correct place.
;; It first calculates left-offset and top-offset, which
;; is the distance between the cursor and the left of the
;; button, and the distance between the cursor and the top
;; of the button.  It positions the cursor in the correct
;; place in the menu window, wherever the menu window may
;; be.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun warp-to-correct-place (butt val)
  (let* ((menu (g-value butt :parent :option-button-menu))
	 (left-offset (- (inter:event-x inter:*current-event*)
			 (g-value butt :left)))
	 (top-offset (- (inter:event-y inter:*current-event*)
			(g-value butt :top)))
	 (new-y (+ (* (g-value butt :height)
		      (position val (g-value butt :parent :real-items)
				:test #'equalp))
		   top-offset)))
    
    (inter:warp-pointer (g-value menu :window)
			left-offset
			new-y)
    (values left-offset new-y)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function is called when the button is clicked on.
;; It positions the menu at the right place, and moves
;; the cursor to the correct place, and pops up the menu
;; and starts the interactor.
;;
;; HOW it gets the positions of the menu and the cursor
;; are discussed in the next couple of functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun Option-Text-Button-Selection-Function (g v)
  (declare (ignore v))
  (let ((menu (g-value g :parent :option-button-menu))
	(win (g-value g :parent :window))
	(ev-x NIL) (ev-y NIL)
	(ev inter:*current-event*))

    (Set-Menu-Top-And-Left g (g-value g :string))
    (opal:update (g-value menu :window))
    
    (setf (inter:event-window ev) (g-value menu :window))
    (multiple-value-setq (ev-x ev-y)
      (warp-to-correct-place g (g-value g :string)))

    (setf (inter:event-x ev) ev-x)
    (setf (inter:event-y ev) ev-y)
    
    (inter:start-interactor (g-value menu :selector) ev)
    (s-value g :visible NIL)
    (opal:update win)
    (s-value (g-value menu :window) :visible T)
    (opal:update (g-value menu :window))
    (opal:raise-window (g-value menu :window))
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is the gadget itself.  It is basically a button
;; that, when pressed, pops up a menu.  The customizable
;; slots are explained below:
;;
;; :top, :left -> Top and left of the gadget in the window
;; :text-offset -> The text offset of the button and menu
;; :label -> The string that appears before the button
;; :button-offset -> The distance between the button and :label
;; :button-shadow-offset -> The button's shadow offset.
;;                          Menu doesn't have shadow
;; :items -> The contents of the menu
;; :initial-item -> The initial item that appears in the
;;                  button (HAS TO BE NON-NIL)
;; :button-font -> The font for the string in the button
;; :label-font -> The font for the label
;; :selection-function -> When one of the items in the menu
;;                        is selected, this is called
;; :value -> Current value (just the string in the button)
;; :button-fixed-width-p -> Button width stays constant
;; :v-spacing -> v-spacing for button and menu
;; :keep-menu-in-screen-p -> Whether menu should stay inside
;;                           the screen or be allowed to go out
;; :menu-h-align -> aligning for menu
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(create-instance 'option-button opal:aggregadget
  (:maybe-constant '(:left :top :text-offset :label :button-offset
		     :button-shadow-offset :items :initial-item :button-font
		     :label-font :button-fixed-width-p :v-spacing
		     :keep-menu-in-screen-p :menu-h-align))
;; Customizable slots

  (:top 40) (:left 40)
  (:text-offset 4)
  (:label "Option button:")
  (:button-offset 10)
  (:button-shadow-offset 5)
  (:items '("Item 1" "Item 2" "Item 3" "Item 4"))
  (:initial-item (o-formula (if (listp (first (gvl :items)))
				(first (first (gvl :items)))
				(first (gvl :items)))))
  (:button-font opal:default-font)
  (:label-font (opal:get-standard-font NIL :bold NIL))
  (:selection-function NIL)
  (:value (o-formula (gvl :option-text-button :string)))
  (:button-fixed-width-p T)
  (:v-spacing 0)
  (:keep-menu-in-screen-p T)
  (:menu-h-align :LEFT)
  
;; Non-customizable slots
  (:real-items (o-formula (let ((l NIL))
			    (if (listp (first (gvl :items)))
				(progn
				  (dolist (i (gvl :items))
				    (setf l (cons (first i) l)))
				  (setf l (reverse l)))
				(gvl :items)))))
  (:parts
   `((:option-button-label ,opal:text
      (:top ,(o-formula (gvl :parent :top)))
      (:left ,(o-formula (gvl :parent :left)))
      (:string ,(o-formula (gvl :parent :label)))
      (:font ,(o-formula (gvl :parent :label-font))))

     (:option-text-button ,gg:text-button
      (:top ,(o-formula (- (gvl :parent :top)
			  (floor
			   (- (gvl :height)
			      (gvl :parent :option-button-label :height))
			   2))))
      (:left ,(o-formula (+ (gvl :parent :left)
			    (gvl :parent :option-button-label :width)
			    (gvl :parent :button-offset))))
      (:button-height ,(o-formula (+ (gvl :parent :option-button-menu
					  :menu-item-list :tail :height)
				     (gvl :parent :option-button-menu :v-spacing))))
      (:button-width ,(o-formula (if (gvl :parent :button-fixed-width-p)
				     (gvl :parent :option-button-menu
					  :menu-item-list :width)
				     (+ (* 2 (gvl :text-offset))
					(gvl :text-width)))))
      (:final-feedback-p NIL)
      (:height ,(o-formula (gvl :button-height)))
      (:text-offset ,(o-formula (gvl :parent :text-offset)))
      (:gray-width 0)
      (:shadow-offset ,(o-formula (gvl :parent :button-shadow-offset)))
      (:font ,(o-formula (gvl :parent :button-font)))
      (:string ,(o-formula (gvl :parent :initial-item)))
      (:selection-function ,#'Option-Text-Button-Selection-Function)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function is called in the :initialize method.
;; It basically creates the menu, puts it in a window, and
;; puts the menu in a slot in the gadget called
;; :option-button-menu.  The hard part about this is trying
;; to understand the formulas.
;;
;; NOTE: For some wierd reason, the interactor crashes if
;; the last line is omitted.  I think this can be attributed
;; to the daemons being turned off during the initialize
;; method or something like that
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun Put-Menu-In-Window (opt)     
  (let* ((menu (create-instance NIL gg:menu
		 (:title NIL)
		 (:option-button-parent opt)
		 (:item-font (o-formula (gvl :option-button-parent :button-font)))
		 (:shadow-offset 0)
		 (:selection-function
		  #'(lambda (g v)
		      (when (g-value g :option-button-parent :selection-function)
			(funcall
			 (g-value g :option-button-parent :selection-function)
			 (g-value g :option-button-parent) v))))
		 (:items (o-formula (gvl :option-button-parent :items)))
		 (:v-spacing (o-formula (gvl :option-button-parent :v-spacing)))
		 (:text-offset (o-formula (gvl :option-button-parent :text-offset)))
		 (:h-align (o-formula (gvl :option-button-parent :menu-h-align)))
		 (:win-left 0) (:win-top 0)
		 (:interactors
		  `((:selector :modify
		     (:window ,(o-formula
				(let ((the-opt (gvl :operates-on
						    :option-button-parent)))
				  (list (gv the-opt :option-button-menu
					    :window)
					(gv the-opt :window)))))
; Allegro 3.1 does not like this dereference of opt		     
;		     (:window ,(formula 
;				`(list (gv ,opt :option-button-menu
;					:window)
;				  (gv ,opt :window))))
		     )))))
	 (win (create-instance NIL inter:interactor-window
		(:menu (o-formula (first (gvl :aggregate :components))))
		(:omit-title-bar-p T)
		(:double-buffered-p T)
		(:save-under T)
		(:border-width 0)
		(:left (o-formula
			(if (gvl :menu :option-button-parent :window)
			    (+ (gvl :menu :win-left)
			       (gvl :menu :option-button-parent :window
				   :left-border-width))
			    0)))
		(:top (o-formula
		       (if (gvl :menu :option-button-parent :window)
			   (+ (gvl :menu :win-top)
			      (gvl :menu :option-button-parent :window
				  :top-border-width))
			   0)))
		(:height (o-formula (gvl :menu :height)))
		(:width (o-formula (gvl :menu :width)))
		(:visible NIL))))
    (s-value win :aggregate (create-instance NIL opal:aggregate))
    (s-value menu :window win)
    (opal:add-component (g-value win :aggregate) menu)
    (s-value opt :option-button-menu menu)
    (g-value opt :option-button-menu :selector :window)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is the initialize method for the gadget.
;; It calls the Put-Menu-In-Window function.  It also
;; sets the initial item of the menu to be the item
;; in :initial-item slot.
;;
;; 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 button is made visible and the
;; menu, invisible, and also sets the button's string to
;; be the new value.
;;
;; Next, the running action is changed so that if the mouse
;; is released outside, nothing is selected.
;;
;; Then the continuous slot of the button is set to NIL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-method :initialize OPTION-BUTTON (opt)
   (call-prototype-method opt)
   (Put-Menu-In-Window opt)

   (let ((menu (g-value opt :option-button-menu))
	 (butt (g-value opt :option-text-button)))
	      
     (g-value menu :value)
     (s-value menu :value (g-value opt :initial-item))
     (s-value (g-value menu :selector) :stop-event :LEFTUP)
     (s-value (g-value menu :selector) :stop-action
	      #'(lambda (int val)
		  (call-prototype-method int val)
		  (let ((gad (g-value int :operates-on)))
		    (s-value (g-value gad :option-button-parent :option-text-button)
			     :string (g-value val :text :string))
		    (s-value (g-value gad :option-button-parent :option-text-button)
			     :font (g-value val :text :font))
		    (s-value (g-value gad :option-button-parent :option-text-button)
			     :visible T)
		    (opal:update (g-value gad :option-button-parent :window))
		    (s-value (g-value gad :window) :visible NIL)
		    (opal:update (g-value gad :window)))))
		    
     (s-value (g-value menu :selector) :running-action
	      #'(lambda (int cont prev)
		  (let ((gad (g-value int :operates-on)))
		    (when (AND (NULL prev)    ;; outside
			       (NOT (inter:event-downp inter:*current-event*)))
		      (s-value (g-value gad :option-button-parent
					:option-text-button)
			       :visible T)
		      (opal:update (g-value gad :option-button-parent :window))
		      (s-value (g-value gad :window) :visible NIL)
		      (opal:update (g-value gad :window)))
		    (call-prototype-method int cont prev))))
     (s-value (g-value butt :text-button-press) :continuous NIL)
     ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is the destroy method for the option button.
;; It first destroys the window in which the menu is
;; sitting, THEN it destroys the gadget.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-method :destroy-me Option-Button (ob &optional erase)
  (let ((window (g-value ob :option-button-menu :window)))
    (when (and window
	       (schema-p window)
	       (gethash (get-local-value window :drawable)
			opal::*drawable-to-window-mapping*))
      (opal:destroy window))
    (call-prototype-method ob erase)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is like the mini-demo function for this gadget.
;; It basically creates a window with an option button
;; and an opal:text box, that is the selected object.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+garnet-debug
(defun Option-Button-Go ()
  (create-instance 'demo-option-win inter:interactor-window
    (:title "Option Demo")
    (:left 100) (:top 100) (:height 90) (:width 180))
  (create-instance 'demo-option-agg opal:aggregate)
  (s-value demo-option-win :aggregate demo-option-agg)
  (opal:update demo-option-win T)

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

  (create-instance 'demo-ob-text opal:text
    (:top 50)
    (:left (o-formula (+ (g-value demo-ob-text-label :left)
			 (g-value demo-ob-text-label :width))))
    (:string (o-formula (g-value demo-ob :initial-item))))

  (create-instance 'demo-ob gg:option-button
	 (:left 15) (:top 15)
	 (:button-fixed-width-p NIL)
	 (:items '("Red" "Blue" "Green" "Yellow" "Aquamarine" "Cyan" "Fluorescent"))
	 (:initial-item "Cyan")
	 (:label "Color:")
	 (:button-font (opal:get-standard-font NIL :bold-italic NIL))
	 (:button-shadow-offset 2)
	 (:selection-function #'(lambda (g v)
				  (declare (ignore g))
				  (s-value demo-ob-text :string v)
				  (opal:update demo-option-win))))

  (opal:add-components demo-option-agg demo-ob-text demo-ob-text-label demo-ob)
  (opal:update demo-option-win T)
  )

#+garnet-debug
(defun Option-Button-Stop ()
  (opal:destroy demo-option-win))
    