;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
;;;                                  P.O. BOX 149149                                 |
;;;                                AUSTIN, TEXAS 78714                               |
;;;                                                                                  |
;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
;;;                                                                                  |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that  this complete copyright and  permission |
;;; notice is maintained, intact, in all copies and supporting documentation.        |
;;;                                                                                  |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty.                                                                |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(in-package "CLIO-OPEN")

(export '(
	  make-menu
	  menu
	  menu-choice
	  menu-title
	  )
	'clio-open)


;================================================================;
;		           THE PUSHPIN CONTACT  		 ;
;================================================================;





(defcontact pushpin-button (button)
  ((pointer-pressed   :type      boolean
		      :initform  nil))
  (:resources
    (border-width :initform 0)
    
    (switch       :type (member :in :out)
		  :initform :out)))

(defun make-pushpin-button (&rest initargs)
  (apply #'make-contact 'pushpin-button initargs))



(defvar ol-last-scale '())      ;These state variables are used to cache the menu spec for the
(defvar ol-last-spec '())      ;most recent scale requested.

(defun get-OL-menu-spec (self)
  (declare (type (or NULL contact) self))
  (if (null self)
      (setf ol-last-scale NIL)		;This is just in case anyone ever needs to reset state
      (let ((this-scale (contact-scale self)))
	(if (eq this-scale ol-last-scale)
	    ol-last-spec
	    (let ((spec (cdr (assoc this-scale *OL-menu-spec-alist*))))
	      (setf ol-last-scale this-scale)
	      (setf ol-last-spec spec))))))

(defun get-pushpin-spec (self)
  (declare (type pushpin-button self))
  (OL-menu-spec-pushpin (get-OL-menu-spec self)))
  

(defmethod initialize-instance :after ((self pushpin-button)
				       &key switch &allow-other-keys)

  (with-slots (border-width selected) self
    (setf border-width 0)

    (when (eq switch :in)
      (setf selected 2))))





(DEFMETHOD preferred-size ((self pushpin-button) &key width height border-width)
  (declare (ignore width height border-width))
  
  (DECLARE (VALUES preferred-width preferred-height
		   preferred-border-width))
  (let*
    ((menu-spec (get-OL-menu-spec self))
     (pushpin-spec (OL-menu-spec-pushpin menu-spec)))
    
    (with-slots (preferred-width) self
      (VALUES				      
	(OR preferred-width
	    (SETF preferred-width
		  (+ (pushpin-spec-box-width pushpin-spec)
		     (- (OL-menu-spec-pushpin-dx menu-spec)	;Spec left margin
			(pushpin-spec-left-margin pushpin-spec)))))	;Account for (possible) padding in image
	(+ (OL-menu-spec-pushpin-dy menu-spec)	;menu top to pushpin baseline distance
	   (OL-menu-spec-title-bar-dy menu-spec))	;pushpin (title) baseline to title bar
	0))))



;;; =================================================================================== ;;;
;;;											;;;
;;;    	                      Display a Pushpin Button...				;;;
;;;											;;;
;;; =================================================================================== ;;;

(defmethod display-pushpin-button ((self pushpin-button) menu-spec spec 
				   &optional completely-p)
  (with-slots (font background foreground width height label)
    self
    (WHEN (realized-p self)			
      (using-gcontext (gc
		       :drawable 	self
		       :exposures  :off
		       ;;			    :foreground foreground
		       ;;			    :background background
		       :font 	font
		       :line-width	1)
	    
	 (WHEN completely-p
	   (clear-area self
		       :x 0
		       :y 0
		       :width  width
		       :height height))
	      

	 (let* ((lab-width (drawable-width label))
		(lab-height (drawable-height label))
		(x (- (OL-menu-spec-pushpin-dx menu-spec) ;desired dx to left of pin
		      (pushpin-spec-left-margin spec)))	  ;left margin padding in pixmap
		(y (- (OL-menu-spec-pushpin-dy menu-spec) ;desired baseline relative menu
		      (pushpin-spec-baseline spec)	  ;pin baseline relative box
		      (pushpin-spec-top-margin spec))))	  ;top margin padding in pixmap
	   (copy-area label gc 0 0 lab-width lab-height self x y)
	   )))))


(DEFMETHOD display-button-highlighted ((self pushpin-button) &optional completely-p)
  (with-slots (last-displayed-as label)
    self
    (let*
	((menu-spec (get-OL-menu-spec self))
	 (spec (OL-menu-spec-pushpin menu-spec))
	 (screen (contact-screen self)))
      (setf label
	    (contact-image-mask
	     self
	     (pushpin-spec-image-in spec)
	     :foreground (screen-black-pixel screen)
	     :background (screen-white-pixel screen)))
      (display-pushpin-button self menu-spec spec completely-p))
    (SETF last-displayed-as :highlighted)))


(DEFMETHOD display-button-unhighlighted ((self pushpin-button) &optional completely-p)
  (with-slots (last-displayed-as highlight-default-p label)
    self
    (let*
	((menu-spec (get-OL-menu-spec self))
	 (spec (OL-menu-spec-pushpin menu-spec))
	 (screen (contact-screen self)))
      (setf label
	    (contact-image-mask
	     self
	     (pushpin-spec-image-out spec)
	     :foreground (screen-black-pixel screen)
	     :background (screen-white-pixel screen)))
      (display-pushpin-button self menu-spec spec completely-p))
    (SETF last-displayed-as :unhighlighted)))

;;; NOTE: The following choice item methods for pushpins should invoke the choice 
;;; item callbacks, but I haven't done this yet.

(defmethod choice-item-press ((pushpin-button pushpin-button))
  (with-slots (selected) pushpin-button
    (LET((to-selected-p (= selected 1)))
      (SETF selected (- selected))
      (IF to-selected-p
	  (display-button-highlighted pushpin-button)
	  (display-button-unhighlighted pushpin-button))
      T)))

(defmethod choice-item-release ((pushpin-button pushpin-button))
  (with-slots (selected) pushpin-button
    (apply-callback pushpin-button 
		    (IF (= 2 (SETF selected (+ 3 selected))) :on :off))))

(defmethod choice-item-leave ((pushpin-button pushpin-button))
  (display-button-unhighlighted pushpin-button))

(defmethod menu-leave-pushpin-button ((self pushpin-button))
   (declare (type pushpin-button self))
   (with-slots (pointer-pressed) self
     (when pointer-pressed
       (choice-item-leave self)
       (setq pointer-pressed nil))))

(defmethod menu-release-pushpin-button ((self pushpin-button))
   (declare (type pushpin-button self))

   ;; Eventually this is where the logic associated with pinning a menu will exist.
;     (format t "~%Sorry - Pinning of menus not yet implemented.")
;     ;; For now we treat a release just like a leave 'cause pinning
;     ;; isn't implemented yet.
;     (menu-leave-pushpin-button self)

   ;;  +++ For now we hack pushpins to just change the pushpin state, and let
   ;;      menu-dismissal fake pinning by not dismissing if the pushpin is in.
   ;;      So, do press-and-release and delete the events.
   (with-slots (pointer-pressed) self
     (when pointer-pressed
       (choice-item-release self)
       (setq pointer-pressed nil))))

(DEFMETHOD press-select ((self pushpin-button))
   (WHEN (choice-item-press self)
     (with-slots (pointer-pressed) self
       (setq pointer-pressed t))))

(DEFMETHOD release-select ((self pushpin-button))
   (with-event (state)
     (with-slots (selected pointer-pressed) self
       (WHEN (AND (> 0 selected)
		  (NOT (ZEROP (LOGAND #.(make-state-mask :button-1) state))))
	 (UNWIND-PROTECT 
	     (choice-item-release self)
	   (setq pointer-pressed nil))))))

(DEFMETHOD menu-enter-pushpin-button ((self pushpin-button))
   (with-event (state)
     (unless (zerop (logand #.(make-state-mask :button-3) state))
       (when (choice-item-press self)
	 ;(display-button-highlighted self)
	 (with-slots (pointer-pressed) self
	   (setq pointer-pressed t))))))

(DEFMETHOD (SETF choice-item-selected-p) (new-value (self pushpin-button))
   ;; Identical to (SETF button-switch) except returns boolean in/out indicator.
   (DECLARE (VALUES new-value))
   (EQ (SETF (button-switch self) (if new-value :in :out)) :in))

;;; ========================================================================== ;;;
;;;									       ;;;
;;;        ( P u s h p i n )   B u t t o n   P r o t o c o l   M e t h o d s   ;;;
;;;									       ;;;
;;; ========================================================================== ;;;

(DEFMETHOD button-switch ((self pushpin-button))
   (with-slots (selected) self
     (NTH (1- (ABS selected)) '(:out :in))))

(DEFMETHOD (SETF button-switch) (new-state (self pushpin-button))
   (check-type new-state (member :in :out))
   (LET ((current-state (button-switch self)))
     (WHEN (NOT (EQ current-state new-state))
       ;; We simulate a button press and release to implement identical
       ;; semantics whether done via API or via gesture.
       (WHEN (choice-item-press self)
	 ;; When toggle press succeeded we follow it
	 ;; with a release.
	 (choice-item-release self)))
     (button-switch self)))


(DEFEVENT pushpin-button
	  :enter-notify
  	  menu-enter-pushpin-button)

(defevent pushpin-button
	  :leave-notify
   menu-leave-pushpin-button)

(defevent pushpin-button
	  (:button-release :button-1)
   pp-maybe-release-select)

(defun pp-maybe-release-select (button)
   (with-slots (pointer-pressed) (the pushpin-button button)
     (when pointer-pressed
       (release-select button))))

;;  These two translations are for Open Look menus, which allow item selection
;;  on both button-1 and button-3 presses.
(DEFEVENT pushpin-button
	  (:button-press :button-3)
   press-select)

(DEFEVENT pushpin-button
	  (:button-release :button-3)
   menu-release-pushpin-button)


;================================================================;
;			   MENU  CONTACT			 ;
;================================================================;

(defcontact menu (core-shell core override-shell)
  ()
  (:resources
    (title 	  :type     (or null string)
	  	  :initform nil)
    (pushpin      :type     switch
		  :initform :off)
    (save-under   :initform :on)
    (border-width :initform 0))
  (:documentation "A shell which presents a set of choice items."))
  
(defun make-menu (&rest initargs)
  "Creates and returns a menu instance."
  (declare (values menu)) 
  (apply #'make-contact 'menu initargs))

(defmethod initialize-instance :after ((menu menu) &rest args
				       &key (choice 'make-choices) &allow-other-keys)
  (with-slots (background border-width width height) menu    

;;  Can't do this now that the choice arg is a constructor rather than a type.
;    (let ((choice-class (if (consp choice) (first choice) choice))) 
;      (assert (subtypep choice-class 'composite) nil
;	      "~s is not a composite subclass name." choice-class)) 
    
    (apply #'make-contact
	   'drop-shadow
	   :parent menu
	   :x 0
	   :y 0
	   :width width
	   :height height
	   :content choice
	   args)

    ;; Now that content is created with initial attributes,
    ;; reset background, border-width to accommodate drop-shadow.
    (setf background   :none
	  border-width 0)))

;;  When asked for background, give the background of the container.
(defmethod contact-background ((menu menu))
   (with-slots (children) menu
     (let ((container (and children (menu-container menu))))
       (if container
	   (contact-background container)
	   :none))))

(defmethod (setf contact-background) (new-value (menu menu))
  (setf (contact-background (menu-container menu)) new-value))

(defmethod (setf contact-foreground) (new-value (menu menu))
  (setf (contact-foreground (menu-container menu)) new-value))

(defmethod menu-choice ((menu menu))
  (find :content (composite-children (menu-container menu)) :key #'contact-name))

(defun menu-container (menu)
  (first (composite-children (first (composite-children menu)))))

(defmethod (setf menu-title) (new-title (menu menu))
  (let
    ((title-field (find :menu-title
			(composite-children (menu-container menu))
			:key 'contact-name))
     (title       (convert menu new-title 'string)))
    
    (assert title nil "~a cannot be converted to a title string." new-title)

    (cond
      (title-field
       (change-geometry
	 title-field
	 :width    (text-width (display-text-font title-field) title)
	 :accept-p t)       
       (setf (display-text-source title-field) title))

      (t
       (make-display-text-field
	  :name            :menu-title
	  :parent          (menu-container menu)
	  :display-gravity :center
	  :source          title)))
    title))

(defmethod menu-title ((menu menu))
  (let ((title-field (find :menu-title
			   (composite-children (menu-container menu))
			   :key 'contact-name)))
    (when title-field
      (display-text-source title-field))))


(defmethod preferred-size ((self menu) &key width height border-width)
  (declare (ignore width height border-width))

  (declare (values preferred-width preferred-height
		   preferred-border-width))
  (preferred-size (first (composite-children self))))


(defmethod shell-mapped ((self menu))
  "Invokes :initialize callback function."
  (apply-callback self :map)
  (apply-callback-else (self :initialize)
    (with-slots ((members children)) (menu-choice self)
      (dolist (member members)
	(apply-callback member :initialize)))))


;================================================================;
;			DROP SHADOW CONTACT			 ;
;================================================================;

(defcontact drop-shadow (core composite)
  ((compress-exposures :initform :on))
  (:documentation "A composite containing a content and a drop-shadow.")
  (:resources (event-mask :initform #.(make-event-mask :exposure))))

(defmethod initialize-instance :after ((drop-shadow drop-shadow) &rest args)
  (with-slots (background border-width) drop-shadow
    ;; Ignore background, border-width
    (setf background :none)
    (setf border-width 0))

  ;; Make the menu container to hold the content, title, & pushpin components.
  (apply #'make-contact 'menu-container
    :name :menu-container
    :parent drop-shadow
    args))

(defmethod preferred-size ((self drop-shadow) &key width height border-width)
  (declare (ignore width height border-width))
  (let*
    ((spec (get-OL-menu-spec self))
     (dsw (OL-menu-spec-drop-shadow-width spec)))
    (multiple-value-bind (pw ph pbw)
	(preferred-size (first (composite-children self)))
      (values
	(+ dsw pbw pbw pw)
	(+ dsw pbw pbw ph)
	0))))

(defmethod display ((drop-shadow drop-shadow) &optional x y width height &key)
  (declare (ignore x y width height))
  (with-slots (children) drop-shadow
    (when children
      (with-slots (width height border-width) (first children)
	(let*
	  ((spec (get-OL-menu-spec drop-shadow))
	   (dsw (OL-menu-spec-drop-shadow-width spec))
	   (dso (OL-menu-spec-drop-shadow-offset spec))
	   (menu-container-width (+ width border-width border-width))
	   (menu-container-height (+ height border-width border-width)))
	  (using-gcontext (gc :drawable drop-shadow
			      :foreground (contact-foreground drop-shadow)
			      :fill-style :stippled
			      :stipple (contact-image-mask drop-shadow 50%gray :depth 1))
            ;; We draw a full rectangle, depending on the server to clip the
	    ;; portion covered by the menu container.
	    (draw-rectangle drop-shadow gc
	                    dso dso
			    (- (+ menu-container-width dsw) dso)
			    (- (+ menu-container-height dsw) dso)
			    :fill-p)))))))

(defmethod manage-geometry ((self drop-shadow) child x y width height border-width &key)
  (let*
    ((spec (get-OL-menu-spec self))
     (dsw (OL-menu-spec-drop-shadow-width spec))
     (child-bw (or border-width (contact-border-width child)))
     (width (or width (contact-width child)))
     (height (or height (contact-height child)))
     (drop-shadow-contact-width (+ width child-bw child-bw dsw))
     (drop-shadow-contact-height (+ height child-bw child-bw dsw))

     (self-change-not-required-p
       (and (= (contact-width self) drop-shadow-contact-width)
	    (= (contact-height self) drop-shadow-contact-height)))
     (approved-p
       (and
	 (or (null x) (= x 0))
	 (or (null y) (= y 0))
	 (or self-change-not-required-p
	     (change-geometry self
			      :width drop-shadow-contact-width
			      :height drop-shadow-contact-height
			      :accept-p t)))))

    (values
      approved-p
      0 0
      (- (contact-width self) child-bw child-bw dsw)
      (- (contact-height self) child-bw child-bw dsw)
      child-bw)))

(defmethod change-layout ((self drop-shadow) &optional newly-managed)
  (declare (ignore newly-managed))
  (let((children (composite-children self)))
    (when children
      (let*
	((spec (get-OL-menu-spec self))
	 (dsw (OL-menu-spec-drop-shadow-width spec))
	 (menu-container (first children))
	 (border-width (contact-border-width menu-container))
	 (width (contact-width menu-container))
	 (height (contact-height menu-container)))
	(change-geometry
	  self
	  :width (+ width border-width border-width dsw)
	  :height (+ height border-width border-width dsw)
	  :accept-p t)))))

(defmethod add-child :before ((self drop-shadow) child &key)
  (let((children (composite-children self)))
    (when children
      (error "~s already has child ~s; cannot add child ~s."
	     self
	     (first children)
	     child))))

(defmethod resize :after ((self drop-shadow) width height border-width)
  (declare (ignore border-width))
  (let*
    ((children (composite-children self))
     (menu-container (first children))
     (spec (get-OL-menu-spec self))
     (dsw (OL-menu-spec-drop-shadow-width spec))
     (bw (contact-border-width menu-container)))
    (resize menu-container
	    (max 1 (- width bw bw dsw))
	    (max 1 (- height bw bw dsw))
	    bw)))
    

;================================================================;
;			MENU-CONTAINER CONTACT			 ;
;================================================================;

(defcontact menu-container (core composite)
  ((compress-exposures :initform :on))
  (:resources
    (event-mask :initform #.(make-event-mask :exposure)))
  (:documentation 
    "A composite containing a content and (optionally) a title and pushpin"))

(defmethod initialize-instance :after ((self menu-container)
				       &rest args
				       &key content (pushpin :off) title
				       &allow-other-keys) 

  (let ((menu      (contact-parent (contact-parent self)))
	(menu-spec (get-OL-menu-spec self)))

    ;; Initialize container window attributes.
    (with-slots (background border-width) self
      ;; Inherit background from menu, not drop-shadow.
      (when (eq :parent-relative background)
	(setf background (contact-current-background menu)))

      ;; Inherit border-width from menu
      (setf border-width (max (contact-border-width menu)
			      (point-pixels (contact-screen self)))))
      
      
      ;; Initialize content
      (multiple-value-bind (content-constructor content-args)
	  (if (consp content) (values (first content) (rest content)) content)
	
	(add-callback
	  (if (null content-args)
	      
	      ;; Default choice initialization 
	      (funcall content-constructor
		:name          :content
		:parent        self
		:border-width  0 
		:left-margin   (OL-menu-spec-pushpin-dx menu-spec)
		:right-margin  (OL-menu-spec-pushpin-dx menu-spec)
		:bottom-margin (OL-menu-spec-drop-shadow-offset menu-spec) 
		:top-margin    (OL-menu-spec-drop-shadow-offset menu-spec)
		:columns       1
		:same-width-in-column :on)
	      
	      ;; Else use given content initargs
	      (apply content-constructor
		     :name          :content
		     :parent        self
		     :border-width  0 
		     content-args))
	  
	  :new-choice-item
	  #'add-menu-item-callbacks menu))

      ;; Initialize title field
      (when title
	(setf (menu-title menu) title))

      ;; Initialize pushpin
      (when (eq pushpin :on)
	(add-callback
	  (make-pushpin-button
	    :name :pushpin
	    :parent self
	    :label (pushpin-spec-image-out (get-pushpin-spec self)))
	  :off
	  #'dismiss-menu menu))))

;;  A method so dialog-button can add daemons.
(defmethod add-menu-item-callbacks (item menu)
   (when (typep item 'toggle-button)
     (add-callback item :on #'dismiss-menu menu))
   (add-callback item :off #'dismiss-menu menu))

(defun dismiss-menu (menu)
   (unless (eq (contact-state menu) :withdrawn)	;i.e., already dismissed
     ;;  +++ Pushpin hack:  If the menu has a pushpin and it's :in, don't
     ;;      withdraw the menu.  It doesn't clone, but it does stay up.
     (let ((pushpin (find :pushpin (composite-children
				     (contact-parent (menu-choice menu)))
			  :key #'contact-name)))
       (unless (and pushpin
		    (eq :in (button-switch pushpin)))
	 (setf (contact-state menu) :withdrawn)))))
     

(defmethod display ((self menu-container)
		    &optional exposed-x exposed-y exposed-width exposed-height &key)
  (declare (ignore exposed-x exposed-y exposed-width exposed-height))
  (with-slots (children width foreground) self
    (when (find :menu-title children :key #'contact-name)
      (let ((tbar-x 4) ; Kludge! this is actually a function of scale.
	    (tbar-y (- (contact-y (find :content children :key #'contact-name)) 1)))
	(using-gcontext (gc :drawable self :foreground foreground)
	  (draw-line self gc tbar-x tbar-y (- width tbar-x) tbar-y))))))	


;================================================================;
;		  MENU-CONTAINER GEOMETRY MANAGEMENT		 ;
;================================================================;

(defun mcgm-disapprove () NIL)
   
(defun mcgm-fail () (error "Unable to layout menu-container." ))

(defun shrink/expand-title (title pw ph tw th cw ch failure-thunk)
  (multiple-value-bind (tw1 th1)
      (preferred-size title :width 0 :height 0)
    (if (<= tw1 tw)
	;; We assume it's OK to make title *wider* than preferred width,
	;; but avoid making it narrower.
	(values
	 (+ 2 (max (or (and pw tw (+ pw
				     (ol-menu-spec-title-dx (get-ol-menu-spec title))
				     (ol-menu-spec-title-dx (get-ol-menu-spec title))
				     tw))
		       (and tw
			    (+ tw
			       (ol-menu-spec-title-dx (get-ol-menu-spec title))
			       (ol-menu-spec-title-dx (get-ol-menu-spec title))))
		       0)
		   (+ cw (ol-menu-spec-title-dx (get-ol-menu-spec title))
		      (ol-menu-spec-title-dx (get-ol-menu-spec title))))) ;Allow 2 pixels for left & right border
	 (+ 2						  ;Allow 2 pixels for top & bottom border
	    (or (and ph (max ph th1)) th1)
	    1						  ;Allow 1 pixel for title bar
	    ch)
	 pw
	 ph
	 tw
	 th
	 cw
	 ch)
	(funcall failure-thunk))))

(defun shrink/expand-content (content pw ph tw th cw ch failure-thunk)
  (multiple-value-bind (cw1 ch1)
      (preferred-size content :width 0 :height 0) 
    (if (<= cw1 cw)
	;; We assume it's OK to make content *wider* than preferred width,
	;; but avoid making it narrower.
	(values
	 (+ 2 (max (or (and pw tw (+ pw
				     (ol-menu-spec-title-dx (get-ol-menu-spec content))
				     (ol-menu-spec-title-dx (get-ol-menu-spec content))
				     tw))
		       (and tw
			    (+ tw
			       (ol-menu-spec-title-dx (get-ol-menu-spec content))
			       (ol-menu-spec-title-dx (get-ol-menu-spec content))))
		       0)
		   (+ cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
		      (ol-menu-spec-title-dx (get-ol-menu-spec content)))
		   ))					  ;Allow 2 pixels for left & right border ;; jba 
	 (+ 2						  ;Allow 2 pixels for top & bottom border
	    (or (and ph th (max ph th)) ph th 0)
	    (if th 1 0)					  ;Title bar only if title
	    ch1)
	 pw
	 ph
	 tw
	 th
	 cw1
	 ch)
	(funcall failure-thunk))))

(defun reposition&resize (component cx cy cw ch)
  (let
      ((x (contact-x component))
       (y (contact-y component))
       (w (contact-width component))
       (h (contact-height component)))
    (unless (and (= x cx) (= y cy)) (move component cx cy))
    (unless (and (= w cw) (= h ch)) (resize component cw ch 0))))
	
(defun execute-layout (self width height ppin pw ph title tw th content cw ch) 
  (assert
   (change-geometry self :width width :height height)
   ()
   "Unable to layout menu ~a" self)
	
  (multiple-value-bind (px py tx ty cx cy)
      (locate-menu-components pw ph tw th width self)
    (when ppin (reposition&resize ppin px py pw ph))
    (when title 
      (reposition&resize title tx ty tw th))
    (when content (reposition&resize content cx cy cw ch))) )

(defun locate-menu-components (pw ph tw th width self) 
  (cond
    ((and pw tw)
     (values
      0 0						  ; x & y for pushpin
      (+ pw (ol-menu-spec-title-dx (get-ol-menu-spec self)) ) 0	; x & y for title
      (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
	   (pixel-round (- width
			   (contact-width (find :content (composite-children self) :key #'contact-name)))
			2))
      (+ (max ph th) 1)))				  ;x & y for content
    (pw
     (values
      0 0
      NIL NIL
      (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
	   (pixel-round (- width
			   (contact-width (find :content (composite-children self) :key #'contact-name)))
			2))
      ph))
    (tw
     (values
      NIL NIL 
      (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
	   (pixel-round (- width
			   (contact-width (find :menu-title (composite-children self) :key #'contact-name)))
			2))
      0
      (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
	   (pixel-round (- width
			   (contact-width (find :content (composite-children self) :key #'contact-name)))
			2))
      (+ 1 th)))
    (t
     (values
      NIL NIL
      NIL NIL
      0 0))))
      
(defun layout-menu-container (ppin pw ph title tw th content cw ch) 
  (cond
    ((and title ppin)
							  ; Menu has title and pushpin in addition to content
     (let ((title-area-height (max ph th)))
       (if (= (+ tw pw) cw)
	   (values
	    (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
	       (ol-menu-spec-title-dx (get-ol-menu-spec content)))
	    (+ 2 title-area-height 1 ch)
	    pw title-area-height
	    tw title-area-height
	    cw ch)
	   ;; We must expand/shrink title or shrink/expand content.
	   (let((newtw (- cw pw)))
	     (if (< newtw 0)
		 (shrink/expand-content content pw ph tw th (+ tw pw) ch #'mcgm-fail)
		 (shrink/expand-title
		  title
		  pw
		  title-area-height
		  newtw
		  title-area-height
		  cw
		  ch
		  #'(lambda()
		      (shrink/expand-content
		       content
		       pw
		       title-area-height
		       tw
		       title-area-height
		       (+ tw pw)			  ; Will fail when title is bigger, so width is title width.
		       ch
		       #'mcgm-fail))))))))
       
    (title
							  ;Menu has title, but no pushpin
     (if (= tw cw)
	 (values
	  (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
	     (ol-menu-spec-title-dx (get-ol-menu-spec content)))
	  (+ 2 th 1 ch)
	  pw ph
	  tw th
	  cw ch)
	 (shrink/expand-title
	  title
	  pw
	  ph
	  tw
	  th
	  cw
	  ch
	  #'(lambda()
	      (shrink/expand-content content pw ph tw th tw ch #'mcgm-fail)))
	 ))
       
    (ppin
							  ;Menu has pushpin, but no title
     (if (> cw pw)
	 (values (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
		    (ol-menu-spec-title-dx (get-ol-menu-spec content)))
		 (+ 2 ph ch) pw ph tw th cw ch)
	 (shrink/expand-content content pw ph tw th pw ch #'mcgm-fail)))
       
    (t
							  ;Menu has neither pushpin nor title
     (values (+ 2 cw) (+ 2 ch) pw ph tw th cw ch))))


(defmethod change-layout ((self menu-container) &optional newly-managed)
  (declare (ignore newly-managed))
  (let* ((children (composite-children self))
       
	 (content (find :content children :key #'contact-name))
	 (cw (contact-width content))
	 (ch (contact-height content))
       
	 (title (find :menu-title children :key #'contact-name))
	 (tw (and title (contact-width title)))
	 (th (and title (contact-height title)))
       
	 (ppin (find :pushpin children :key #'contact-name))
	 (pw (and ppin (contact-width ppin)))
	 (ph (and ppin (contact-height ppin))))
    (multiple-value-bind (width height pw1 ph1 tw1 th1 cw1 ch1)
	(layout-menu-container ppin pw ph title tw th content cw ch)
      (execute-layout self width height ppin pw1 ph1 title tw1 th1 content cw1 ch1))))

(defmethod preferred-size ((self menu-container) &key width height border-width)
  (declare (ignore width height border-width))
  (let* ((children (composite-children self))
	 (content (find :content children :key #'contact-name))
	 (title (find :menu-title children :key #'contact-name))
	 (ppin (find :pushpin children :key #'contact-name)))

    (MULTIPLE-VALUE-BIND (cw ch)
	(preferred-size content :width 0 :height 0)
      (MULTIPLE-VALUE-BIND (tw th)
	  (AND title (preferred-size title :width 0 :height 0))
	(MULTIPLE-VALUE-BIND (pw ph)
	    (AND ppin (preferred-size ppin))
	  (MULTIPLE-VALUE-BIND (preferred-width preferred-height)
	      (layout-menu-container ppin pw ph title tw th content cw ch)
	    (VALUES preferred-width preferred-height 0)))))))

(defmethod manage-geometry ((self menu-container) child x y width height bw &key)
  (let* ((children (composite-children self))
       
	 (content (find :content children :key #'contact-name))
	 (cw (contact-width content))
	 (ch (contact-height content))
       
	 (title (find :menu-title children :key #'contact-name))
	 (tw (and title (contact-width title)))
	 (th (and title (contact-height title)))
       
	 (ppin (find :pushpin children :key #'contact-name))
	 (pw (and ppin (contact-width ppin)))
	 (ph (and ppin (contact-height ppin)))

	 (x (or x (contact-x child)))
	 (y (or y (contact-y child)))
	 (width (or width (contact-width child)))
	 (height (or height (contact-height child))))


    (multiple-value-bind (self-width self-height pw1 ph1 tw1 th1 cw1 ch1)
	(cond
	  ((eq child content)
	   (cond
	     (title
	      ;; If there is a title then try to adjust it
	      (shrink/expand-title
	       title
	       pw
	       ph
	       (if pw (- width pw) width)
	       th
	       width
	       height
	       ;; If title adjust fails then try to adjust content
	       ;; so can at least offer compromise.
	       #'(lambda()
		   (shrink/expand-content
		    content
		    pw
		    ph
		    tw
		    th
		    (or (and pw (+ pw tw)) tw)
		    height
		    #'mcgm-disapprove))))
	     (ppin
	      ;; If ppin exists must make sure content is at least as wide
	      (if (> width pw)
		  (values (+ 2 width) (+ 2 height ph 1) pw ph tw th width height)
		  (shrink/expand-content
		   content
		   pw
		   ph
		   tw
		   th
		   pw
		   height
		   #'mcgm-disapprove)))
	     (t
	      ;; Menu has neither pushpin nor title
	      (values
	       (+ 2 width) (+ 2 height) pw ph tw th width height))))
	  ((eq child title)
	   (shrink/expand-content
	    content
	    pw
	    ph
	    width
	    height
	    (if ppin (+ pw tw) tw)
	    ch
	    #'(lambda()
		(shrink/expand-title
		 title
		 pw
		 ph
		 (if ppin (- cw pw) width)
		 height
		 cw
		 ch
		 #'mcgm-disapprove))))
	  ;; It must be the pushpin which has changed
	  (title    
	   (shrink/expand-title
	    title
	    width
	    height
	    (- cw width)
	    th
	    cw
	    ch
	    #'(lambda()
		(shrink/expand-content
		 content
		 width
		 height
		 tw
		 th
		 (+ width tw)
		 ch
		 #'mcgm-disapprove))))
	  ;; Pushpin is being managed, but no title to adjust, so must adjust content.
	  ((< cw width)
	   ;; If the content width is less than the requested pushpin width we try to
	   ;; shrink the content accordingly. (Pretty unlikely case, eh?)
	   (shrink/expand-content
	    content
	    width
	    height
	    tw
	    th
	    width
	    ch
	    #'mcgm-disapprove))
	  (t
	   ;; Else the content is at least as wide as the pushpin and we can simply
	   ;; accept the pushpin change without any ripple effects.
	   (values
	    (+ 2 cw) (+ 2 ch ph)
	    width height
	    tw th
	    cw ch)))

      (and
       self-width					  ;Width = NIL implies failure without suggesting compromise.
       (multiple-value-bind (px1 py1 tx1 ty1 cx1 cy1)
	   (locate-menu-components pw1 ph1 tw1 th1 self-width self)
	 (let
	     ((self-change-approved
	       (or
		(and
		 (= self-width (contact-width self))
		 (= self-height (contact-height self)))
		(change-geometry self
				 :width self-width
				 :height self-height
				 :accept-p nil)))
	      (approve-p
	       (and
		(or (null bw) (= 0 bw))
		(cond
		  ((eq child ppin) (and (= pw1 width) (= ph1 height)
					(= px1 x)     (= py1 y)))
		  ((eq child title) (and (= tw1 width) (= th1 height)
					 (= tx1 x)     (= ty1 y)
					 )
		   )
		  (t (and (= cw1 width) (= ch1 height)
			  (= cx1 x)     (= cy1 y)))))))
	   (and
	    self-change-approved
	    (progn
	      (when approve-p
		(execute-layout
		 self self-width self-height
		 ppin pw1 ph1
		 title tw1 th1
		 content cw1 ch1))
	      (cond
		((eq child ppin) (values approve-p px1 py1 pw1 ph1 0))
		((eq child title) (values approve-p tx1 ty1 tw1 th1 0))
		(t (values approve-p cx1 cy1 cw1 ch1 0)))))))))))


