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 / droppable-svm.lisp < prev    next >
Encoding:
Text File  |  1992-07-15  |  6.5 KB  |  155 lines
  1. (in-package :oou)
  2. (oou-provide :droppable-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; droppable-svm.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;          based on an idea originally implemented for MACL 1.32 by Rich Lynch
  11. ;;
  12. ;; mixin for dragging & dropping views
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (oou-dependencies
  16.  :draggable-svm
  17.  :simple-view-ce)
  18.  
  19.  
  20. (export '(droppable-svm pre-drop-hilite droppable-p))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defclass droppable-svm (draggable-svm)
  25.   ((drop-target-class :initarg :drop-target-class
  26.                       :accessor drop-target-class)
  27.    (drop-targets      :initarg :drop-targets
  28.                       :accessor drop-targets)
  29.    (drop-action-fn    :initarg :drop-action-fn
  30.                       :accessor drop-action-fn))
  31.   (:default-initargs 
  32.     :drop-target-class 'dialog-item
  33.     ))
  34.  
  35. (defmethod call-drag-action :before ((sv droppable-svm))
  36.   (declare (special *current-droppable-target*))
  37.   (let* ((where (%stack-block ((p 4)) (#_GetMouse p) (#_LocalToGlobal p) (%get-point p)))
  38.          (new-target (find-droppable-view-containing-point sv where)))
  39.     (unless (eq new-target *current-droppable-target*)
  40.       (when *current-droppable-target*
  41.         (pre-drop-hilite *current-droppable-target* nil))
  42.       (when new-target
  43.         (pre-drop-hilite new-target t))
  44.       (setf *current-droppable-target* new-target))))
  45.  
  46. (defmethod drag-item ((sv droppable-svm) where)
  47.   (let ((*current-droppable-target*))
  48.     (declare (special *current-droppable-target*))
  49.     (multiple-value-bind (drag-offset end-action-p) (call-next-method)
  50.       (when *current-droppable-target*
  51.         (pre-drop-hilite *current-droppable-target* nil)
  52.         (when drag-offset
  53.           (call-drop-action sv *current-droppable-target* drag-offset (add-points where drag-offset))
  54.           (setf end-action-p nil)))
  55.       (values drag-offset end-action-p))))
  56.  
  57. (defmethod call-drop-action ((sv droppable-svm) (target simple-view) drag-offset dest-point)
  58.   ;;exists primarily to be specialized by selectable-svm
  59.   (drop-action sv target drag-offset dest-point))
  60.  
  61. (defmethod drop-action ((sv droppable-svm) (target simple-view) drag-offset dest-point)
  62.   (when (slot-boundp sv 'drop-action-fn)
  63.     (funcall (drop-action-fn sv) sv target drag-offset dest-point)))
  64.  
  65. (defmethod pre-drop-hilite ((sv simple-view) hilite-flag)
  66.   (with-focused-view (focusing-view sv)
  67.     (with-hilite-color *black-color*
  68.     (hilite-view sv hilite-flag))))
  69.  
  70. (defmethod droppable-p ((sv droppable-svm) (target simple-view))
  71.   (unless (eq sv target)
  72.     (when (typep target (drop-target-class sv))
  73.       (if (slot-boundp sv 'drop-targets)
  74.         (when (find (view-nick-name target) (drop-targets sv)) target)
  75.         target))))
  76.  
  77. (defmethod find-droppable-view-containing-point ((sv droppable-svm) where)
  78.   (let ((v (root-drop-target-view sv where)))
  79.     (when v
  80.       (droppable-p sv (find-view-containing-point v (global-to-view v where))))))
  81.  
  82. (defmethod root-drop-target-view ((sv droppable-svm) where)
  83.   (ecase (drag-bounds sv)
  84.     (:container (view-container sv))
  85.     (:window (view-window sv))
  86.     (:none (find-view-containing-point nil where nil t))))
  87.  
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89.  
  90.  
  91. #|
  92.  
  93. ;;; a modest example - adding drop AND select behavior to static text dialog items
  94. ;;; (use shift to select multiple items to drop)
  95.  
  96. (oou-dependencies :selectable-svm)
  97.  
  98. (defclass st-sel-drop (selectable-svm droppable-svm static-text-dialog-item) ())
  99. ;note that selectable-svm precedes droppable-svm
  100.  
  101. (defun print-target (di target offset where)
  102.   (format t "dropped ~s onto ~s at ~a (delta = ~a)~%"
  103.           (dialog-item-text di)
  104.           (dialog-item-text target)
  105.           (point-string where)
  106.           (point-string offset)))
  107.  
  108. (setf *test-w*
  109.       (make-instance 'dialog
  110.                      :window-type :document
  111.                      :view-position :centered
  112.                      :view-size #@(200 150)
  113.                      :window-title "droppable demo"
  114.                      :close-box-p t
  115.                      :view-subviews
  116.                      (list (make-instance 'st-sel-drop
  117.                                           :view-position #@(20 20)
  118.                                           :dialog-item-text "drop/select me"
  119.                                           :view-nick-name :i1
  120.                                           :selection-cluster 1
  121.                                           :drop-targets '(:i4 :i5)
  122.                                           :drag-bounds :window
  123.                                           :drop-action-fn #'print-target
  124.                                           )
  125.                            (make-instance 'st-sel-drop
  126.                                           :view-position #@(20 40)
  127.                                           :dialog-item-text "me too"
  128.                                           :view-nick-name :i2
  129.                                           :selection-cluster 1
  130.                                           :drop-targets '(:i4 :i5)
  131.                                           :drag-bounds :none
  132.                                           :drop-action-fn #'print-target
  133.                                           )
  134.                            (make-instance 'st-sel-drop
  135.                                           :view-position #@(20 60)
  136.                                           :dialog-item-text "me 3"
  137.                                           :view-nick-name :i3
  138.                                           :selection-cluster 1
  139.                                           :drop-targets '(:i4 :i5)
  140.                                           :drag-bounds :window
  141.                                           :drop-action-fn #'print-target
  142.                                           )
  143.                            (make-instance 'static-text-dialog-item
  144.                                           :view-position #@(20 100)
  145.                                           :dialog-item-text "hit me"
  146.                                           :view-nick-name :i4
  147.                                           )
  148.                            (make-instance 'static-text-dialog-item
  149.                                           :view-position #@(20 120)
  150.                                           :dialog-item-text "hit me too"
  151.                                           :view-nick-name :i5
  152.                                           )
  153.                            )))
  154.  
  155. |#