;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Menus
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/menus.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 12/14/92 13:01:40
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 5/15/90 (Juergen)  the part-descriptions for menus may have an additional
;;;                    keyword parameter action-docu which specifies the
;;;                    left-button mouse-documentation for the menu item
;;;
;;; 5/15/90 (Juergen)  the optional parameter for part-actions in 
;;;                    select-from-popup-parts changed to a more general
;;;                    parameter for part-init-list
;;;
;;; 9/12/90 (Juergen)  New classes single-choice-menu and multiple-choice-menu
;;;                    and corresponding subclasses for text- and bitmap-menus
;;;
;;; 9/12/90 (Juergen)  Basic window has got :part-event as default reactivity.
;;;                    Menu items always get a "(call :part-event ...)"-action for
;;;                    :select - reactivity.
;;;                    Classes single-choice-menu and multiple-choice-menu
;;;                    use this feature.
;;;
;;; 9/13/90 (Juergen)  Class slot part-event-type for class basic-menu added
;;;
;;; 10/2/90 (Juergen)  lambda list of #'select-from-objects changed
;;;
;;; [Juergen  Tue Nov  6 11:18:31 1990] resources are mostly defined in 
;;;   initforms instead of in define-resources, so that they are inherited
;;;   much like defaults
;;;
;;; [Juergen  Tue Nov 27 11:19:18 1990] Default reactivity for single-choice-menu 
;;;   and multiple-choice-menu changed to (:part-event (call :write)).  
;;;   Thus menus should specify a :write-event reactivity instead-of a new 
;;;   :part-event reactivity.
;;;
;;; 01/30/1991 (Hubertus)  replaced with-final-layout by without-layouting in
;;;                        method select-from-objects.
;;;
;;; 02/05/1991 (Juergen)  The selected part of a single-choice-menu may be set
;;;                       to nil, which makes no part being selected.
;;;
;;; 07/17/1991 (Hubertus) added default SELECTED-CHOICE-BOX-BITMAP and 
;;;                       DESELECTED-CHOICE-BOX-BITMAP methods for 
;;;                       class labelled-choice-box.
;;;
;;; 07/19/1991 (Hubertus) introduced SINGLE-CHOICE-BOX-MENU, a single choice 
;;;                       menu which by default uses radio buttons for choice 
;;;                       boxes 
;;;
;;; 12/14/1992 (Juergen)  action-mixin has been added to the superclasses of
;;;                       basic-menu, i.e. :action is a valid keyword for
;;;                       menus, specifying the :part-event reactivity entry.
;;;
;;; 12/14/1992 (Juergen)  New function select-from, which lets the user
;;;                       interactively select a value from a popup menu.
;;;_____________________________________________________________________________


(in-package :xit)

;;;_____________________________________________________________________________
;;;
;;;                               BASIC MENU
;;;_____________________________________________________________________________

;; basic-menu implements an interaction object for selection
;; from a set of choices.
;; (class menu is already defined in clue examples)

(defcontact basic-menu (action-mixin uniform-part-intel)
  ((name :initform :menu)
   (part-options :allocation :class
		 :initform '((part-mouse-feedback . :mouse-feedback)))
   (layouter :initform 'distance-layouter)
   (part-mouse-feedback :type (member :none :border :inverse)
			:initform :border
			:accessor part-mouse-feedback
			:initarg :part-mouse-feedback)
   (reactivity :initform '((:part-event))))
  (:documentation "Basic menu class which implements selection from a set 
                   of choices"))

(defmethod action-event-type ((self basic-menu))
  :part-event)

(defmethod add-part :around ((self basic-menu) &rest part-init-list &key)
  (let* ((new-part (call-next-method))
	(part-event-type (part-event-type self))
	(action   (getf part-init-list :action))
	(action-docu (getf part-init-list :action-docu)))
    (unless (reactivity-entry new-part part-event-type)
      (unless (and (listp action) (listp (car action)))
	      ;; (listp nil) is t !
	(setq action (list action)))
					
      (let ((action-list 
	     (if (some #'(lambda (act) (and (eq (first act) 'call)
					    (eq (second act) :part-event)))
		       action)
		 action
	       (cons `(call :part-event (identification *self*))
		     ;; formerly: `(call :part-event ',(identification new-part))
		     action))))
	(apply #'change-reactivity new-part part-event-type
	       (if action-docu
		   (cons action-docu action-list)
		 action-list))))
    new-part))

(defmethod part-event-type ((self basic-menu))
  :select)

(defmethod (setf part-mouse-feedback) :after (feedback (self basic-menu))
  (declare (ignore feedback))
  (with-slots (part-mouse-feedback) self
    (broadcast-setf self 'mouse-feedback part-mouse-feedback)))


(defmethod add-part-at-level ((self basic-menu) level &rest part-init-list &key)
  (set-indentation (layouter self)
		   (apply #'add-part self part-init-list)
		   level))

(defmethod add-object-parts-at-level ((self basic-menu) objects level
				      &optional part-init-list)
  (dolist (object objects)
    (let ((next-object (car object))
	  (rest-objects (cdr object)))
      (apply #'add-part-at-level self level :view-of next-object
	       part-init-list)
      (add-object-parts-at-level self rest-objects (1+ level)
				 part-init-list))))

(defmethod add-object-parts ((self basic-menu) objects
			     &optional part-init-list)
  (if (typep (layouter self) 'selective-indent-distance-layouter)
      (apply #'add-object-parts-at-level self objects 0 part-init-list)
    (dolist (object objects)
      (apply #'add-part self :view-of object part-init-list))))

(defmethod select-from-objects ((self basic-menu) objects
				&key part-init-list action &allow-other-keys)
    (without-layouting self	 ; change-layout might be triggered from
		                 ; initialize-instance :after of parts.
      (if part-init-list
	  (add-object-parts self objects part-init-list)
	  (add-object-parts self objects)))
    (when action (change-reactivity self :part-event action)))

(defun select-from (&rest entries)
  (let ((menu
	 (make-gio 'shadow-borders-popup-container
	    :border-width 1
	    :hide-on-mouse-exit? nil
	    :client-window
	    `(text-menu
	      :action ((call :pass-part-event)
		       (call :synchronize-event *part-value*))
	      :parts ,(mapcar #'(lambda (entry)
				  (let* ((listp (listp entry))
					 (text (if listp (car entry)
						 (convert-to-string entry)))
					 (view-of (if listp (cdr entry) entry)))
				    `(:text ,text
				      :view-of ,view-of)))
			      entries)))))
    (with-synchronous-mode (menu)
      (popup menu))))
				 
;;;_____________________________________________________________________________
;;;
;;;                           SINGLE CHOICE MENU
;;;_____________________________________________________________________________

;; A single-choice-menu is a menu which always has one selected menu item
;; (cf. radio buttons)

(defcontact single-choice-menu (basic-menu)
  ((name :initform :single-choice-menu)
   (reactivity :initform '((:part-event (call :write)))))
  (:documentation "Menu which always has one selected menu item"))

(defmethod selected-part ((self single-choice-menu))
  (find-part self #'selected?))

(defmethod (setf selected-part) (new-part (self single-choice-menu))
  (let ((old-part (selected-part self)))
    (when old-part (setf (selected? old-part) nil))
    (when new-part (setf (selected? new-part) t)))
  new-part)

(defmethod selection ((self single-choice-menu))
  (let ((selected-part (selected-part self)))
    (when selected-part (identification selected-part))))

(defmethod (setf selection) (identification (self single-choice-menu))
  (setf (selected-part self) (part-with-identification self identification))
  identification)

(defmethod initialize-instance :after ((self single-choice-menu)
				       &rest init-list
				       &key (selection nil selection-p))
  (if selection-p
    (setf (selection self) selection)
    (read-from-application self)))

(defmethod part-event :before ((self single-choice-menu)
			       (part interaction-window) part-value)
  (declare (ignore part-value))
  (setf (selected-part self) part))   

(defmethod identification ((self single-choice-menu))
  (selection self))

(defmethod (setf identification) (value (self single-choice-menu))
  (setf (selection self) value))

(defmethod select-from-objects :after ((self single-choice-menu) objects
				       &key selection &allow-other-keys)
  (when selection (setf (selection self) selection)))


;;;_____________________________________________________________________________
;;;
;;;                  SINGLE CHOICE BOX MENU 
;;;                  (using radio buttons as choice boxes)
;;;_____________________________________________________________________________


(defcontact single-choice-box-menu (single-choice-menu)
  ((name :initform :single-choice-box-menu)
   (part-class :initform 'labelled-radio-choice-box)
   (part-mouse-feedback :initform :none)
   (selected-choice-box-bitmap :type (or image pixmap)
			       :accessor selected-choice-box-bitmap)
   (deselected-choice-box-bitmap :type (or image pixmap)
				 :accessor deselected-choice-box-bitmap))
  (:resources
    (selected-choice-box-bitmap :initform "radio-choice-box-set")
    (deselected-choice-box-bitmap :initform "radio-choice-box-clear"))
  (:documentation "A Single Choice Menu whose items may be selected by e.g. radio buttons."))


(defmethod (setf selected-choice-box-bitmap) :after (bitmap (self single-choice-box-menu))
  (broadcast self #'selection-changed))

(defmethod (setf deselected-choice-box-bitmap) :after (bitmap (self single-choice-box-menu))
  (broadcast self #'selection-changed))



;;;_____________________________________________________________________________
;;;
;;;                          MULTIPLE CHOICE MENU
;;;_____________________________________________________________________________

;; A multiple-choice-menu is a menu which may have an arbitrary number of 
;; selected menu items

(defcontact multiple-choice-menu (basic-menu)
  ((name :initform :multiple-choice-menu)
   (reactivity :initform '((:part-event (call :write)))))
  (:documentation "Menu whith arbitrary number of selected menu items"))

(defmethod initialize-instance :after ((self multiple-choice-menu)
				       &rest init-list
				       &key (selection nil selection-p))
  (if selection-p
      (setf (selection self) selection)
    (read-from-application self)))

(defmethod selected-parts ((self multiple-choice-menu))
  (find-parts self #'selected?))

(defmethod (setf selected-parts) (new-parts (self multiple-choice-menu))
  (let ((old-parts (selected-parts self)))
    (dolist (old-part old-parts)
      (unless (member old-part new-parts :test #'eq)
	(setf (selected? old-part) nil)))
    (dolist (new-part new-parts)
      (unless (member new-part old-parts :test #'eq)
	(setf (selected? new-part) t))))
  new-parts)

(defmethod deselected-parts ((self multiple-choice-menu))
  (find-parts self #'(lambda (part) (not (selected? part)))))

(defmethod selection ((self multiple-choice-menu))
  (mapcar #'identification (selected-parts self)))

(defmethod deselection ((self multiple-choice-menu))
  (mapcar #'identification (deselected-parts self)))

(defmethod (setf selection) (identifications (self multiple-choice-menu))
  (setf (selected-parts self)
    (mapcan #'(lambda (identification)
		(let ((part 
		(part-with-identification self identification)))
		  (when part (list part))))
            identifications)))

(defmethod part-event :before ((self multiple-choice-menu)
			       (part interaction-window) part-value)
  (declare (ignore part-value))
  (setf (selected? part) (not (selected? part))))

(defmethod identification ((self multiple-choice-menu))
  (selection self))

(defmethod (setf identification) (value (self multiple-choice-menu))
  (setf (selection self) value))

(defmethod select-from-objects :after ((self multiple-choice-menu)objects
				       &key selection &allow-other-keys)
  (when selection (setf (selection self) selection)))


;;;_____________________________________________________________________________
;;;
;;;                          MULTIPLE CHOICE BOX MENU
;;;_____________________________________________________________________________

(defcontact multiple-choice-box-menu (multiple-choice-menu)
  ((name :initform :multiple-choice-box-menu)
   (part-class :initform 'labelled-choice-box)
   (part-mouse-feedback :initform :none)
   (selected-choice-box-bitmap :type (or image pixmap)
			       :accessor selected-choice-box-bitmap)
   (deselected-choice-box-bitmap :type (or image pixmap)
				 :accessor deselected-choice-box-bitmap))
  (:resources
    (selected-choice-box-bitmap :initform "choice-box-set")
    (deselected-choice-box-bitmap :initform "choice-box-clear"))
  (:documentation "A Multiple Choice Menu whose items may be selected by choice boxes."))


(defmethod (setf selected-choice-box-bitmap) :after (bitmap (self multiple-choice-box-menu))
  (broadcast self #'selection-changed))

(defmethod (setf deselected-choice-box-bitmap) :after (bitmap (self multiple-choice-box-menu))
  (broadcast self #'selection-changed))


;;;___________________________
;;;  
;;;   Labelled Choice Boxes
;;;___________________________

(defcontact labelled-choice-box (intel)
  ((layouter :initform '(aligning-distance-layouter :alignment :center
						    :orientation :right)))
  )

;;; default methods to get the choice-box bitmaps
;;;
(defmethod selected-choice-box-bitmap ((self labelled-choice-box))
  (selected-choice-box-bitmap (part-of self)))

(defmethod deselected-choice-box-bitmap ((self labelled-choice-box))
  (deselected-choice-box-bitmap (part-of self)))

(defmethod initialize-instance :after ((self labelled-choice-box) &rest initargs &key
				       choice-box-part text-part (text nil textp) (font nil fontp))
  (apply #'add-part self
	 :name :choice-box
	 :class (or (getf choice-box-part :class) 'bitmap-dispel)
	 :bitmap (deselected-choice-box-bitmap self)
	 :reactivity '((:mouse :none))
	 (append choice-box-part
		 (list :mouse-feedback :border
		       :adjust-size? nil)))
  (apply #'add-part self
	 :class (or (getf text-part :class) 'text-dispel)
	 (append text-part
		 (when textp `(:text ,text))
		 (when fontp `(:font ,font))
		 (list :mouse-feedback :none
		       :name :choice-box-label))))

(defmethod mouse-exits-to-inferior :around ((self labelled-choice-box))
  nil)		   ; prevent :after trigger that does hide-mouse-documentation

(defmethod mouse-feedback-on :after ((self labelled-choice-box))
  (mouse-feedback-on (part self :choice-box)))

(defmethod mouse-feedback-off :after ((self labelled-choice-box))
  (mouse-feedback-off (part self :choice-box)))

(defmethod selection-changed ((self labelled-choice-box))
  (with-slots (selected?) self
    (setf (bitmap (part self :choice-box))
	  (if selected?
	      (selected-choice-box-bitmap self)
	      (deselected-choice-box-bitmap self)))))



(defcontact labelled-radio-choice-box (labelled-choice-box)
  ())

(defmethod initialize-instance :around ((self labelled-radio-choice-box)
					&rest initargs &key
					choice-box-part)
  (apply #'call-next-method self
	 :choice-box-part `(,@choice-box-part
			    :class masked-bitmap-dispel
			    :clipmask "radio-choice-box-mask"
			    :feedback-border-bitmap
			    "radio-choice-box-feedback-border"
			    :feedback-inverse-bitmap
			    "radio-choice-box-feedback-inverse")
	 initargs))



;;;_____________________________________________________________________________
;;;
;;;                       POPUP MENUS (obsolete classes)
;;;_____________________________________________________________________________

(defcontact popup-menu (popup-window basic-menu)
  ())

(defcontact tree-popup-menu (popup-menu)
  ((layouter :initform 'selective-indent-distance-layouter)))

; class defintions are obsolete, do not use them anymore - may be removed in
; future release!


;;;_____________________________________________________________________________
;;;
;;;                               TEXT MENU
;;;_____________________________________________________________________________

(defcontact text-menu (basic-menu)
  ((name :initform :text-menu)
   (part-class :initform 'text-dispel)
   (part-options :allocation :class
		 :initform '((part-mouse-feedback . :mouse-feedback)
			     (part-font . :font)))
   (part-font :type font :reader part-font :initarg :part-font))
  (:resources
    (part-font :initform :default))
  (:documentation "a menu with text-dispels as its parts"))

(defmethod (setf part-font) (font-spec (self text-menu))
  (with-slots (part-font) self
    ;; (setf part-font (convert self string 'font))
    ;; 03/19/1991 (Hubertus) font conversion should be done in the
    ;; individual parts to allow merging against font defaults! 
    (broadcast-setf self 'font font-spec)
    (setf part-font (convert self font-spec 'font)))
  font-spec)

(defcontact single-choice-text-menu (single-choice-menu text-menu)
  ())

(defcontact multiple-choice-text-menu (multiple-choice-menu text-menu)
  ())

(defcontact popup-text-menu (popup-window text-menu) ; order of superclasses is obligatory
  ())

(defmethod default-window-popup-menu ((self popup-part-connection))
  (make-window 'popup-text-menu
	       :parent (toplevel-window self)
	       :view-of self
	       :inside-border 10
	       :action '(call :eval (funcall *part-value* (view-of *self*)))
	       :parts '((:view-of update
			 :text "refresh"
			 :action-docu "Refresh window")
			(:view-of move-window
			 :text "move"
			 :action-docu "Move window")
			(:view-of resize-window
			 :text "resize"
			 :action-docu "Resize window")
			(:view-of totop-window
			 :text "totop"
			 :action-docu "Put window on top")
			(:view-of tobottom-window
			 :text "tobottom"
			 :action-docu "Put window to bottom")
			(:view-of destroy
			 :text "close"
			 :action-docu "Remove window"))))


(defmethod default-window-popup-menu ((self window-icon-mixin))
  (make-window 'popup-text-menu
	       :parent (toplevel-window self)
	       :view-of self
	       :inside-border 10
	       :action '(call :eval (funcall *part-value* (view-of *self*)))
	       :parts '((:view-of update
			 :text "refresh"
			 :action-docu "Refresh window")
			(:view-of move-window
			 :text "move"
			 :action-docu "Move window")
			(:view-of resize-window
			 :text "resize"
			 :action-docu "Resize window")
			(:view-of totop-window
			 :text "totop"
			 :action-docu "Put window on top")
			(:view-of tobottom-window
			 :text "tobottom"
			 :action-docu "Put window to bottom")
			(:view-of shrink
			 :text "shrink"
			 :action-docu "Shrink window to icon")
			(:view-of destroy
			 :text "close"
			 :action-docu "Remove window"))))


;;;_____________________________________________________________________________
;;;
;;;                               BITMAP MENU
;;;_____________________________________________________________________________

(defcontact bitmap-menu (basic-menu)
  ((name :initform :bitmap-menu)
   (part-class :initform 'bitmap-dispel)
   (layouter :initform '(distance-layouter :distance 2)))
  (:documentation "a menu with bitmap-dispels as its parts"))

(defcontact single-choice-bitmap-menu (single-choice-menu bitmap-menu)
  ())

(defcontact multiple-choice-bitmap-menu (multiple-choice-menu bitmap-menu)
  ())

(defcontact popup-bitmap-menu (popup-window bitmap-menu)
  ())

;;;___________________________________________________________________________
;;;
;;;                           SYSTEM MENU
;;;____________________________________________________________________________

(defun add-system-menu-entry (&rest initargs)
  nil ;; redefined in file system-menu
  )

(defun add-system-menu-entries (&rest entries)
  nil ;; redefined in file system-menu
  )
(defun add-tools-menu-entry (&rest initargs)
  nil ;; redefined in file system-menu
  )

(defun add-tools-menu-entries (&rest entries)
  nil ;; redefined in file system-menu
  )