;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Popup Window
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/popup-window.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 12/14/92 09:51:22
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 07/24/90  [Kalle]   New Slot  hide-on-mouse-exit?  for popup-window
;;;
;;; 09/07/90  (Juergen) new slot popup-position for class popup-window
;;;
;;; 10/05/90  (Juergen) New value :if-needed for slot popup-part of class
;;;                     popup-part-connection
;;;
;;; 11/06/1990 (Juergen) resources are mostly defined in initforms instead of in
;;;                      define-resources, so that they are inherited much like
;;;                      defaults
;;;
;;; 03/18/1992 (Juergen) popup-part now may also be specified by a window class name
;;;                      or a list of window class name and initargs (cf. class
;;;                      window-icon-mixin).
;;;
;;; 07/24/1992 (Juergen) In popup-part-connection the value :self should be
;;;                      used instead of :contact for the slot
;;;                      popup-part-connection.  :contact may be no legal value
;;;                      in future releases.
;;;
;;; 12/14/1992 (Juergen) When hide-on-part-event? is set to t for a popup-window,
;;;                      a :part-event reactivity-entry is automatically created.
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________
;
;                             Popup Window
;_______________________________________________________________________________

(defcontact popup-window (interaction-window)
;; windows with popup behavior
;; Slots:
;; popup-position  determines the position where window pops up
;;                  :none  at the current position of the popup-window
;;                  :pointer  at the position of the pointer
;;                  :pointer-centered  centered relative to the pointer position

  ((state :type (member :withdrawn :managed :mapped)
	  :initform :managed)
   (border-width :initform 1)
   (popup-position :type (member :none :pointer :pointer-centered)
		   :accessor popup-position
		   :initform :pointer-centered)
   (hide-on-mouse-exit? :type boolean
		   :initform t
		   :accessor hide-on-mouse-exit? 
		   :initarg :hide-on-mouse-exit?)
   (hide-on-part-event? :type boolean
			:initform t
			:accessor hide-on-part-event?
			:initarg :hide-on-part-event?)
   (destroy-after? :type boolean
		   :initform nil
		   :accessor destroy-after?
		   :initarg :destroy-after?)
   (popped-up? :type boolean
	       :initform nil))
  (:resources
   (save-under :initform :on)
   (background :type (or (member :none :parent-relative) pixel pixmap)
	       :initform "white"))
  (:documentation "A window that may pop up at current pointer position,
                   e.g. for selection"))

(defmethod initialize-instance :after ((self popup-window) &rest init-list)
  (declare (ignore init-list))
  (change-reactivity self :mouse)
  (with-slots (hide-on-part-event?) self
    (when (and hide-on-part-event?
	       (not (reactivity-entry self :part-event)))
      (change-reactivity self :part-event))))

(defmethod (setf hide-on-part-event?) :after (new-value (self popup-window))
  (when (and new-value
	     (not (reactivity-entry self :part-event)))
    (change-reactivity self :part-event)))
  
(defmethod hide ((self popup-window))
  (with-slots (popped-up? destroy-after?) self
    (when popped-up?
      (if destroy-after?
	  (destroy self)
	  (bury-window self))
      (setf popped-up? nil))))

(defmethod mouse-exits :after ((self popup-window))
  (with-slots (hide-on-mouse-exit? state) self
    (when (and hide-on-mouse-exit?
	       (eq state :mapped)) ;; mouse-exit not triggered by 
                                   ;; setting the contact-state?
       (hide self))))

(defmethod part-event :before ((self popup-window)
			       (part interaction-window) part-value)
  (declare (ignore part-value))
  (with-slots (hide-on-part-event?) self
    (when hide-on-part-event? (hide self))))

(defmethod do-popup ((self popup-window))
  (with-slots (popped-up?) self
    (totop-window self)
    (setf popped-up? t)))

(defmethod popup-at ((self popup-window) x y)
  (move-window self x y)
  (do-popup self))

(defmethod popup ((self popup-window))
  (with-slots (popup-position display) self
    (if (eq popup-position :none)
	(do-popup self)
      (progn
	(update-state display) ; to update layout for unrealized windows
                               ; (e.g. in case of dynamic menus)
	(with-slots (parent width height) self
		    (with-slots
		     ((parent-width width) (parent-height height)) parent
		     (multiple-value-bind (pointer-x pointer-y)
			 (pointer-position parent)
		       (let ((popup-x (if (eq popup-position :pointer)
					  pointer-x
					(- pointer-x (round width 2))))
			     (popup-y (if (eq popup-position :pointer)
					  pointer-y
					(- pointer-y (round height 2)))))
			 (setq
			   popup-x
			   (max 0 (min popup-x (- parent-width width)))
			   popup-y
			   (max 0 (min popup-y (- parent-height height))))
			 (popup-at self popup-x popup-y)))))))))

(defmethod popup-for ((self popup-window) obj)
  (setf (view-of self) obj)
  (popup self))


(defmethod select-from-objects :after ((self popup-window) objects
				       &key view-of &allow-other-keys)
  ; cf. class basic-menu
  (if view-of
      (popup-for self view-of)
    (popup self)))				

;_______________________________________________________________________________
;
;                             Popup Part Connection
;_______________________________________________________________________________

;; popup-part-connection is a mixin class which associates a window with 
;; a popup-part, e.g. a popup menu.  A popup-part may be any instance of class
;; popup-window.  In certain cases described below the popup-part is determined
;; by the method get-popup-part, which may be specialized for subclasses of
;; popup-part-connection.
;;
;; Slots of popup-part-connection:
;;
;;  popup-part  bound to the popup-part (instance of popup-window)
;;
;; The popup-part may be specified by one of the following forms:
;;
;;     <popup window object>
;;     <window-class-name>
;;     (<window-class-name> <initform1> <initform2> ...)
;;     :default   popup-part is computed by method get-popup-part
;;                at initialization time
;;     :if-needed   popup-part is computed and set when needed for 
;;                  the first time
;;
;;  dynamic-popup-part?  when not-nil popup-part is computed dynamically,
;;                       i.e. popup-part is destroyed when it disappears
;;                       and gets newly computed when it pops up the next time
;;
;;  popup-part-connection  determines the view-of of the popup-part at popup time.
;;                         It may be any object (or nil) or one of the following
;;                         keywords:
;;
;;                          :self      window the popup-part belongs to
;;                                     (formerly :contact)
;;                          :part-of   part-of of the window
;;                          :view-of   view-of of the window
;;                          :parent    parent of the window (use part-of instead)

(defclass popup-part-connection (view)
  ((popup-part :type (or null (member :default :if-needed) popup-window)
	       :initform nil
	       :accessor popup-part)
   (dynamic-popup-part? :type boolean
		       :initform nil
		       :accessor dynamic-popup-part?
		       :initarg :dynamic-popup-part?)
   (popup-part-connection :type (or null (member :self :part-of :view-of :parent
						 :contact) ;; to be removed
				    standard-object)
			 :initform :self
			 :accessor popup-part-connection
			 :initarg :popup-part-connection))
  (:documentation "provides a popup-part that may for example be associated with a
                   window"))

(defmethod initialize-instance :after ((self popup-part-connection)
				       &rest init-list &key popup-part)
  (declare (ignore init-list))
  (with-slots ((popup popup-part)) self
    (let ((popup-part-descr (or popup-part popup))
	  (toplevel (popup-part-parent self)))
      (when popup-part-descr
	(cond ((window-p popup-part-descr)
	       (setf popup popup-part-descr))
	      ((eq popup-part-descr :default)
	       (set-popup-part self))
	      ((eq popup-part-descr :if-needed)
	       ;; instantiate popup-part later
	       )
	      ((symbolp popup-part-descr)
	       (setf popup
		   (funcall #'make-window popup-part-descr :parent toplevel)))
	      ((listp popup-part-descr)
	       (let ((popup-class (first popup-part-descr))
		     (popup-initlist (rest popup-part-descr)))
		 (unless (getf popup-initlist :parent)
		  (setq popup-initlist (list* :parent toplevel popup-initlist)))
		 (setf popup (apply #'make-window popup-class popup-initlist)))))))))

(defmethod popup-part-parent ((self popup-part-connection))
  (toplevel-window self)) ;; to be redefined if popup-part-connection is used with non-window classes
	       
(defmethod default-window-popup-menu ((self popup-part-connection))
  nil)                                        ; to be filled in file menus

(defmethod get-popup-part ((self popup-part-connection))
  ;;(setf (popup-part-connection self) :self) ; take slot-value instead
  (default-window-popup-menu self))           ; to be changed by subclasses
                                                         
(defmethod set-popup-part ((self popup-part-connection))
  (with-slots (dynamic-popup-part? popup-part) self
    (setf popup-part (get-popup-part self))
    (when (and dynamic-popup-part? popup-part)
      (setf (destroy-after? popup-part) t))))

(defmethod set-popup-part-if-needed ((self popup-part-connection))
  (with-slots (dynamic-popup-part? popup-part) self
    (when (or dynamic-popup-part?
	      (eq popup-part :default)
	      (eq popup-part :if-needed))
      (set-popup-part self))))
    
(defmethod select-from-popup-part ((self popup-part-connection))
  (with-slots (popup-part popup-part-connection) self
    (set-popup-part-if-needed self)
    (when popup-part
      (popup-for popup-part
		 (case popup-part-connection
		   (:self     self)
		   (:contact  self) ;; to be removed
		   (:parent   (contact-parent self))
		   (:view-of  (view-of self))
		   (t         popup-part-connection))))))

(defmethod destroy :before ((self popup-part-connection))
  (with-slots (popup-part) self
     (when (window-p popup-part)
       (destroy popup-part))))
