;; -*- MODE:LISP; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); 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.                                                                |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

;;; CHOICES:


(in-package "CLIO-OPEN")

(EXPORT '(
	  choices
	  choice-default
	  choice-font
	  choice-policy
	  choice-selection
	  make-choices
	  ))


;;;  ============================================================================
;;;	              T h e   C H O I C E S   C o n t a c t
;;;  ============================================================================

(defcontact choices (table)
  
  ((font 	:type 		fontable
	 	:accessor	choice-font
		:initarg	:font
	 	:initform 	nil)

   (selection   :type           (or null contact)
                :accessor       choice-selection
                :initform       nil)

   (default	:type		(or null contact symbol)
                :accessor       choice-default
		:initform	nil
		:initarg	:default-selection)

   (policy	:type		(member :always-one :one-or-none)
		:accessor	choice-policy
		:initarg	:choice-policy
		:initform	:one-or-none))
  
  (:resources
    font
    (default-selection :type symbol :initform nil)
    (choice-policy     :type (member :always-one :one-or-none)
		       :initform :one-or-none) 
    (horizontal-space  :initform -1)
    (vertical-space    :initform -1))

  (:documentation
    "Allows a user to choose at most one choice item."))


(DEFUN make-choices (&rest initargs &key &allow-other-keys)
  (DECLARE (VALUES choices))
  (APPLY #'make-contact 'choices initargs))

;;  Add our callbacks to each child as it is added, before anybody else gets in ahead of us...
(DEFMETHOD add-child :after ((choices choices) this-child &key)
  (flet
    (
     ;;; ===============================================================================
     ;;;
     ;;;                   Our :change-allowed-p callback function...
     ;;;	Applied by a choice-item child when the user tries to change its state
     ;;;		Tells the child whether or not the change may occur
     ;;;
     ;;;
     (choices-change-allowed-p (to-selected-p choices)
       (ECASE (choice-policy choices)
	 (:always-one (or to-selected-p
			  ;; Following allows deselection of old selection
			  ;; when transitioning to new selection. [See
			  ;; (SETF choice-selection) for details.]
			  (boundp '*within-setf-choice-selection*))) 
	 (:one-or-none t)))

     ;;; ===============================================================================
     ;;;
     ;;;       Our :changing and :canceling-change callback functions...
     ;;;
     (choices-changing (to-selected-p choices self)
       (LET((selection (choice-selection choices))
	    (default (choice-default choices)))

	 (WHEN (and to-selected-p selection (not (eq selection self)))
	   ;; When transitioning to selected state we must turn off
	   ;; the highlighting of the current choice selection, if any.
	   (SETF (choice-item-highlight-selected-p selection) nil))

	 (WHEN (AND default (NOT (EQ self default)))
	   ;; If there is a current choice default then we *may* have
	   ;; to temporarily inhibit display of the default ring.
	   (UNLESS (and selection to-selected-p)
	     ;; If there is a current selection already and we are
	     ;; transitioning *to* selected state then the current
	     ;; selection must be a toggle button (or some other
	     ;; button whose state is sticky.) In that case the
	     ;; default ring will already have been inhibited by
	     ;; that button's selection. Otherwise we inhibit the
	     ;; the default ring now.
	     (SETF (choice-item-highlight-default-p default) (not to-selected-p))))))

     (choices-canceling-change (to-selected-p choices self)
       (LET((selection (choice-selection choices))
	    (default (choice-default choices)))

	 (WHEN (and to-selected-p selection)
	   ;; If canceling change to selected state we must restore
	   ;; highlight of old selection (if any)
	   (SETF (choice-item-highlight-selected-p selection) t))

	 (WHEN (AND default (NOT (EQ default self)))
	   ;; If we are canceling a transition to "selected" then we
	   ;; must restore the inhibited default ring display.
	   ;; If, on the other hand, we are canceling a transition
	   ;; back to "unselected" then we must once again inhibit
	   ;; default ring display.
	   (UNLESS (and selection to-selected-p)
	     ;; As in choices-changing, if there is a current selection
	     ;; already inhibiting default ring display then we need not
	     ;; restore display here.
	     (SETF (choice-item-highlight-default-p default) to-selected-p)))))


     ;;; ================================================================================
     ;;;	This :off callback deselects currently selected child and
     ;;;        resets the choice selection to NIL. We assume choice policy
     ;;;        enforcement is done elsewhere and so allow deselection even
     ;;         if :always-one.
     ;;;
     (choices-off (choices self)
       (DECLARE (IGNORE self))
       ;;  +++ Gross hack until I find out what's really wrong.
       (unless (boundp '*within-setf-choice-selection*)
	 (SETF (choice-selection choices) nil)))

     ;; ================================================================================
     ;;	This :on callback deselects currently selected child (if any) and
     ;;        resets the choice selection to point to the specified child. 
     ;;
     (choices-on (choices self)
	(change-choices-selection choices self)))

    (let((font (choice-font choices)))
      (WHEN font (SETF (choice-item-font this-child) font)))

    ;;  Make this child the default if the child's name is currently the default...
    (with-slots (default) choices
      (when (and (symbolp default) (eq default (contact-name this-child)))
	(setf default nil)
	(setf (choice-default choices) this-child)))

    (add-callback this-child :change-allowed-p #'choices-change-allowed-p choices)
    (add-callback this-child :changing #'choices-changing choices this-child)
    (add-callback this-child :canceling-change #'choices-canceling-change choices this-child)
    (add-callback this-child :on #'choices-on choices this-child)
    (add-callback this-child :off #'choices-off choices this-child)

    ;;  This callback provides a hook used by the menu code.
    (apply-callback choices :new-choice-item this-child)))


(defmethod change-layout :after ((choices choices) &optional newly-managed)
  (declare (ignore newly-managed))
  (with-slots (policy selection children) choices
    (unless (realized-p choices)
      (when (and (eq policy :always-one) (not selection) children)
	(setf (choice-selection choices) (first children))))))


;;; ===============================================================================
;;;
;;;              Method to set the default choice item...
;;;

(DEFMETHOD (SETF choice-default) (new-default-choice-item (choices choices))
  (with-slots (default children) choices
    (UNLESS (EQ new-default-choice-item default)
      (ASSERT (MEMBER new-default-choice-item children)
	      NIL
	"New default choice-item ~a is not a child of ~a."
	new-default-choice-item choices)
      (when default (setf (choice-item-highlight-default-p default) NIL))
      (setf default new-default-choice-item)
      (setf (choice-item-highlight-default-p default) T)))
  new-default-choice-item)




;;; ===============================================================================
;;;
;;;            Method to set the selected choice-items...
;;;

;;  Assume ALL programmatic changes to the set of selected children come through here so all
;;  enforcement of the choice-policy is done here...

(defun change-choices-selection (choices child-to-be-selected)
  (declare (type (or null contact) child-to-be-selected))
  (declare (values child-to-be-selected))
  
  (with-slots (children selection) (the choices choices)
    (unless (eq selection child-to-be-selected)   
      
      ;;  Don't check for compliance while we're in the middle of a change...
      (unless (boundp '*within-setf-choice-selection*)
	(assert
	  (or child-to-be-selected (eq (choice-policy choices) :one-or-none)) nil
	  "Violating :always-one choice policy of choices contact ~a." choices))
      
      (let ((*within-setf-choice-selection* t))
	(declare (special *within-setf-choice-selection*))
	
	;;  Make sure the caller's selection is indeed a child of ours...
	(assert
	  (or (null child-to-be-selected) (member child-to-be-selected children)) nil
	  "Selection ~a is not a child of ~a." child-to-be-selected choices)            
	
	;; We must do things in just the right order here in case choice
	;; policy is :always-one, in which case turning off the old
	;; choice-item-selected-p is a bit tricky. In particular, the
	;; :change-allowed callback will fail unless we first update the
	;; current choices selection with the new value so it knows the
	;; choice policy will not be violated. 
	
	(let ((old-selection selection)) 
	  (when old-selection (setf (choice-item-selected-p old-selection) nil))
	  (setf selection child-to-be-selected)))))
      
  child-to-be-selected)

(defmethod (setf choice-selection) (child-to-be-selected (choices choices))
  (change-choices-selection choices child-to-be-selected)
  (when child-to-be-selected
    (setf (choice-item-selected-p child-to-be-selected) t))
  child-to-be-selected)



;;; ===============================================================================
;;;
;;;                   Method to force the font of all children...
;;;

(DEFMETHOD (SETF choice-font) (new-value (choices choices))
  
  (with-slots (children font) choices
    (IF new-value
	(PROGN
	  (SETF font (find-font choices new-value))
	  (DOLIST (child children)
	    (SETF (choice-item-font child) new-value)))
	;; Setting font to NIL allows the children to have distinct fonts
	;; so we skip resetting choice-item font slots on children.
	(SETF font NIL))
  new-value))  ;; grh 7/27


;;; ===============================================================================
;;;
;;;                   Method to set the choice-policy...
;;;

(DEFMETHOD (SETF choice-policy) (new-policy (choices choices))
  (with-slots (policy children selection default) choices
    (ECASE new-policy
      (:always-one				; Make sure one child is selected...
       (when (null selection)
	 (if default 
	     (setf (choice-selection choices)  default)
	     (if children
		 (setf (choice-selection choices) (first children))
		 (assert nil nil "~s choices does not have a default or children")))))
      (:one-or-none				; Nothing more to do...
       nil))
    (SETF policy new-policy)
    new-policy))