;; -*- 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. | ;;; | ;;;----------------------------------------------------------------------------------+ (in-package "CLIO-OPEN") (EXPORT '( choice-default choice-font choice-selection make-multiple-choices multiple-choices )) ;;; ============================================================================ ;;; T h e M U L T I P L E - C H O I C E S C o n t a c t ;;; ============================================================================ (DEFCONTACT multiple-choices (table) ((font :type fontable :reader choice-font :initarg :font :initform nil) (selection :type list :accessor choice-selection :initform nil) (default :type list :accessor choice-default :initarg :default-selection :initform nil) ) (:resources font default (horizontal-space :initform 3) (vertical-space :initform 3)) (:documentation "Provides a mechanism for displaying N choices to a user of which the user may select M, where N >= M >= 0.")) (DEFUN make-multiple-choices (&rest initargs &key &allow-other-keys) (DECLARE (VALUES multiple-choices)) (APPLY #'make-contact 'multiple-choices initargs)) (DEFMETHOD add-child :after ((choices multiple-choices) this-child &key) (flet ( ;;; =============================================================================== ;;; ;;; Our :changing and :canceling-change callback functions... ;;; (choices-changing (to-selected-p choices self) (DECLARE (IGNORE self)) (LET((selection (choice-selection choices)) (default (choice-default choices))) (WHEN 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 default ring(s) ;; are already inhibited. Otherwise, there are two possibilites: ;; (1) No selection, transitioning *to* selected. ;; We must inhibit ring display on all defaults. ;; (2) Have selection, transitioning *from* selected. ;; If there is only one selection and it is transitioning to ;; unselected, then we must restore default ring(s) display. (let ((highlighted-p (not to-selected-p))) (when (or to-selected-p (null (cdr selection))) (DOLIST (item default) (SETF (choice-item-highlight-default-p item) highlighted-p)))))))) (choices-canceling-change (to-selected-p choices self) (DECLARE (IGNORE self)) (LET((selection (choice-selection choices)) (default (choice-default choices))) (WHEN default ;; 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. (when (or to-selected-p (null (cdr selection))) (DOLIST (item default) (SETF (choice-item-highlight-default-p item) to-selected-p))))))) ;;; ================================================================================ ;;; This :off callback (destructively) removes the item from the current ;;; selection set for this multiple-choices contact. ;;; (choices-off (choices self) (WITH-SLOTS (selection) choices (WHEN selection (SETF selection (DELETE self selection))))) ;;; ================================================================================ ;;; This :on callback adds the item to the current selection set ;;; for this multiple-choices contact. ;;; (choices-on (choices self) (WITH-SLOTS (selection) choices ;; It is important to *not* use the SETF method here since doing so would ;; potentially cause a loop. [SETF method invokes this callback!] (SETF selection (cons self selection)))) ) ; ... end of flet ... (let((font (choice-font choices))) (WHEN font (SETF (choice-item-font this-child) font))) ;; ===================================================================================== ;; If this child's name is on the default-selection list, replace it with this child. ;; (with-slots (default) choices (DO ((defaults default (REST defaults))) ((NULL defaults)) (WHEN (EQ (FIRST defaults) (contact-name this-child)) (RPLACA defaults this-child) (SETF (choice-item-highlight-default-p this-child) T) (RETURN)))) (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))) ;;; =============================================================================== ;;; ;;; Method to set the default choice item set ;;; (DEFMETHOD (SETF choice-default) (new-default-choice-items (choices multiple-choices)) (with-slots (default children) choices (let ((new-defaults (set-difference new-default-choice-items default)) (no-longer-defaults (set-difference default new-default-choice-items))) (WHEN new-defaults (ASSERT (subsetp new-defaults children) NIL "New default choice-items ~a are not children of ~a." (set-difference new-defaults children) choices) (DOLIST (item new-defaults) (SETF (choice-item-highlight-default-p item) T)) (DOLIST (item no-longer-defaults) (SETF (choice-item-highlight-default-p item) NIL)) (SETF default new-default-choice-items)))) new-default-choice-items) ;;; =============================================================================== ;;; ;;; Methods to set the selected choice-items set ;;; (DEFMETHOD (SETF choice-selection) (children-to-be-selected (choices multiple-choices)) (DECLARE (TYPE list children-to-be-selected)) (DECLARE (VALUES children-to-be-selected)) (with-slots (children selection) choices (let ((new-selections (set-difference children-to-be-selected selection)) (no-longer-selected (set-difference selection children-to-be-selected))) ;; Make sure the caller's selection are indeed a children of ours... (ASSERT (subsetp new-selections children) NIL "Selections ~a are not children of ~a." (set-difference new-selections selection) choices) ;; Clear selected status of items no longer selected (DOLIST (item no-longer-selected) (SETF (choice-item-selected-p item) NIL)) ;; Set selected status of items newly selected (DOLIST (item new-selections) (SETF (choice-item-selected-p item) T)))) children-to-be-selected) ;;; =============================================================================== ;;; ;;; Method to force the font of all children... ;;; (DEFMETHOD (SETF choice-font) (new-value (multiple-choices multiple-choices)) (with-slots (children font) multiple-choices (if new-value (progn (SETF font (find-font multiple-choices new-value)) (DOLIST (child children) (SETF (choice-item-font child) new-value))) (SETF font NIL)) new-value))