home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / mixin-madness / simple-view-mixins / selectable-svm.lisp < prev    next >
Encoding:
Text File  |  1992-03-03  |  9.4 KB  |  258 lines
  1. (in-package :oou)
  2. (oou-provide :selectable-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; selectable-svm.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixins for selecting views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :simple-view-ce)
  16.  
  17.  
  18. (export '(selectable-svm selectable-rb-svm selectable-cb-svm
  19.           selected-items hilite-selected-item
  20.           ))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defclass selectable-svm ()
  25.   ((selection-cluster      :initarg :selection-cluster
  26.                            :accessor selection-cluster)
  27.    (selected-p             :initarg :selected-p
  28.                            :accessor selected-p)
  29.    (all-drag-actions-p     :initarg :all-drag-actions-p
  30.                            :accessor all-drag-actions-p)
  31.    (all-drag-end-actions-p :initarg :all-drag-end-actions-p
  32.                            :accessor all-drag-end-actions-p)
  33.    (all-drop-actions-p     :initarg :all-drop-actions-p
  34.                            :accessor all-drop-actions-p))
  35.   (:default-initargs
  36.     :selection-cluster nil
  37.     :selected-p nil
  38.     :all-drag-actions-p t
  39.     :all-drag-end-actions-p t
  40.     :all-drop-actions-p t
  41.     ))
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44. ;; click handling
  45.  
  46. (defmethod view-click-event-handler :before ((sv selectable-svm) where)
  47.   (declare (ignore where))
  48.   (with-focused-view (focusing-view sv)
  49.     (if (selected-p sv)
  50.       (click-selected-item sv (shift-key-p))
  51.       (click-unselected-item sv (shift-key-p)))))
  52.  
  53. (defmethod click-unselected-item ((sv selectable-svm) shift-p)
  54.   (unless shift-p (deselect-all sv :draw-now-p t))
  55.   (select-item sv :draw-now-p t))
  56.  
  57. (defmethod click-selected-item ((sv selectable-svm) shift-p)
  58.   (when shift-p (deselect-item sv :draw-now-p t)))
  59.  
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61. ;; drawing (hiliting)
  62.  
  63. (defmethod view-draw-contents :after ((sv selectable-svm))
  64.   (when (selected-p sv) (hilite-selected-item sv t)))
  65.  
  66. (defmethod hilite-selected-item ((sv selectable-svm) hilite-flag)
  67.   (with-focused-view (focusing-view sv)
  68.     (hilite-view sv hilite-flag)))
  69.  
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71. ;; handling the current selection
  72.  
  73. (defmethod mapc-selectable-cluster ((sv selectable-svm) fn &optional selected-only-p)
  74.   ;;search starts from the item's container
  75.   (with-slots (selection-cluster) sv
  76.     (flet ((map-fn (i) (when (and (eq (selection-cluster i) selection-cluster)
  77.                                   (or (selected-p i) (not selected-only-p)))
  78.                          (funcall fn i))))
  79.       (declare (dynamic-extent #'map-fn))
  80.       (map-subviews (view-container sv) #'map-fn 'selectable-svm))))
  81.                                
  82.  
  83. (defmethod selected-items ((sv selectable-svm))
  84.   ;;Returns a list of all the selected items in di's cluster
  85.   (let ((item-list nil))
  86.     (flet ((fn (i) (push i item-list)))
  87.       (declare (dynamic-extent #'fn))
  88.       (mapc-selectable-cluster sv #'fn t)
  89.       (nreverse item-list))))
  90.  
  91. (defmethod (setf selected-items) (items (sv selectable-svm))
  92.   (without-interrupts
  93.    (deselect-all sv)
  94.    (dolist (i items) (select-item i))))
  95.  
  96. ;;;;;;;;;;
  97. ;;Note: the draw-now-p is provided for using these methods at
  98. ;;interrupt time (e.g. during click event handling). Normally you
  99. ;;should let draw-now-p default to nil. If you use a non-nil
  100. ;;draw-now-p, make sure the current view is focused to the item's
  101. ;;container.
  102.  
  103. (defmethod select-item ((sv selectable-svm) &key draw-now-p)
  104.   (unless (selected-p sv)
  105.     (setf (selected-p sv) t)
  106.     (if draw-now-p
  107.       (hilite-selected-item sv t)
  108.       (invalidate-view sv t))))
  109.  
  110. (defmethod deselect-item ((sv selectable-svm) &key draw-now-p)
  111.   (when (selected-p sv)
  112.     (setf (selected-p sv) nil)
  113.     (if draw-now-p
  114.       (hilite-selected-item sv nil)
  115.       (invalidate-view sv t))))
  116.  
  117. (defmethod deselect-all ((sv selectable-svm) &key draw-now-p)
  118.   (flet ((fn (i) (deselect-item i :draw-now-p draw-now-p)))
  119.     (declare (dynamic-extent #'fn))
  120.     (mapc-selectable-cluster sv #'fn t)))
  121.  
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123. ;;specializations for handling dragging selections
  124.  
  125. (declaim (ftype (function (&rest t) t)
  126.                 drop-action
  127.                 drag-action
  128.                 drag-end-action
  129.                 set-drag-outline-rgn))
  130.  
  131. (defmethod set-DragGrayRgn-areas :after ((sv selectable-svm) where drag-rgn limitRect slopRect)
  132.   ;;specialize the drag-rgn to be the union of all selected items
  133.   (declare (ignore where limitRect slopRect))
  134.   (with-macptrs ((temp-rgn (#_NewRgn)))
  135.     (flet ((add-rgn (i)
  136.              (set-drag-outline-rgn i temp-rgn)
  137.              (#_UnionRgn temp-rgn drag-rgn drag-rgn)))
  138.       (declare (dynamic-extent #'add-rgn))
  139.       (mapc-selectable-cluster sv #'add-rgn t))
  140.     (#_DisposeRgn temp-rgn)))
  141.  
  142. (defmethod draggable-p ((sv selectable-svm))
  143.   ;;Must check if the item is selected before allowing dragging. Normally this
  144.   ;;isn't needed cause the click selects the item, but a shift-click can de-select.
  145.   (and (selected-p sv) (call-next-method)))
  146.  
  147. (defmethod pre-drag-hilite ((sv selectable-svm) hilite-flag)
  148.   ;;selectable items already hilite when clicked - so do nothing
  149.   (declare (ignore sv hilite-flag)))
  150.  
  151. (defmethod drag-item ((sv selectable-svm) where)
  152.   ;;*current-drag-selection* is bound for the duration of the drag, 
  153.   ;;so droppable-p won't have to repeatedly compute the current selection.
  154.   (declare (ignore where))
  155.   (let ((*current-drag-selection* (selected-items sv)))
  156.     (declare (special *current-drag-selection*))
  157.     (call-next-method)))
  158.  
  159. (defmethod droppable-p ((sv selectable-svm) (target simple-view))
  160.   ;;disallow dropping on any member of current selection
  161.   (declare (special *current-drag-selection*))
  162.   (unless (find target *current-drag-selection*)
  163.     (call-next-method)))
  164.  
  165. ;;;;;;;;;;
  166. ;;3 call action functions specialized to use entire selection
  167.  
  168. (defmethod call-drag-action ((sv selectable-svm))
  169.   (declare (special *current-drag-selection*))
  170.     (if (slot-value sv 'all-drag-actions-p)
  171.       (dolist (i *current-drag-selection*) (drag-action i))
  172.       (drag-action sv)))
  173.  
  174. (defmethod call-drag-end-action ((sv selectable-svm) drag-offset dest-point)
  175.   (if (slot-value sv 'all-drag-end-actions-p)
  176.     (flet ((fn (i) (drag-end-action i drag-offset dest-point)))
  177.       (declare (dynamic-extent #'fn))
  178.       (mapc-selectable-cluster sv #'fn t))
  179.     (drag-end-action sv drag-offset dest-point)))
  180.  
  181. (defmethod call-drop-action ((sv selectable-svm) (target simple-view) drag-offset dest-point)
  182.   (if (slot-value sv 'all-drag-end-actions-p)
  183.     (flet ((fn (i) (drop-action i target drag-offset dest-point)))
  184.       (declare (dynamic-extent #'fn))
  185.       (mapc-selectable-cluster sv #'fn t))
  186.     (drop-action sv target drag-offset dest-point)))
  187.  
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190. ;; selectable views with radio button behavior
  191.  
  192. (defclass selectable-rb-svm (selectable-svm) ())
  193.  
  194. (defmethod click-unselected-item ((sv selectable-rb-svm) shift-p)
  195.   (declare (ignore shift-p))
  196.   (deselect-all sv :draw-now-p t)
  197.   (select-item sv :draw-now-p t))
  198.  
  199. (defmethod click-selected-item ((sv selectable-rb-svm) shift-p)
  200.   (declare (ignore sv shift-p)))
  201.  
  202.  
  203. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  204. ;; selectable views with check box behavior
  205.  
  206. (defclass selectable-cb-svm (selectable-svm) ())
  207.  
  208. (defmethod click-unselected-item ((sv selectable-cb-svm) shift-p)
  209.   (declare (ignore shift-p))
  210.   (select-item sv :draw-now-p t))
  211.  
  212. (defmethod click-selected-item ((sv selectable-cb-svm) shift-p)
  213.   (declare (ignore shift-p))
  214.   (deselect-item sv :draw-now-p t))
  215.  
  216. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  217.  
  218. #|
  219.  
  220. ;;; a modest example - adding select behavior to static text dialog items
  221.  
  222. (defclass stsel (selectable-svm static-text-dialog-item) ())
  223. ;(defclass stsel (selectable-rb-svm static-text-dialog-item) ())
  224. ;(defclass stsel (selectable-cb-svm static-text-dialog-item) ())
  225.  
  226. (setf *test-w*
  227.       (make-instance 'dialog
  228.                      :window-type :document
  229.                      :view-position :centered
  230.                      :view-size #@(200 100)
  231.                      :window-title "selectable-svm demo"
  232.                      :close-box-p t
  233.                      :color-p t
  234.                      :view-subviews
  235.                      (list (make-instance 'stsel
  236.                                              :view-position #@(20 20)
  237.                                              :dialog-item-text "item 1"
  238.                                              :view-nick-name :i1
  239.                                              :selection-cluster 1
  240.                                              )
  241.                            (make-instance 'stsel
  242.                                              :view-position #@(20 40)
  243.                                              :dialog-item-text "item 2"
  244.                                              :view-nick-name :i2
  245.                                              :selection-cluster 1
  246.                                              )
  247.                            (make-instance 'stsel
  248.                                              :view-position #@(20 60)
  249.                                              :dialog-item-text "Item 3"
  250.                                              :view-nick-name :i2
  251.                                              :selection-cluster 1
  252.                                              )
  253.  
  254.                            )))
  255.  
  256. ;(selected-items (view-named :i1 *test-w*))
  257.  
  258. |#