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 / draggable-svm.lisp next >
Encoding:
Text File  |  1992-07-15  |  10.0 KB  |  234 lines
  1. (in-package :oou)
  2. (oou-provide :draggable-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; draggable-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 views
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (oou-dependencies
  16.  :simple-view-ce
  17.  :WMgr-view
  18.  :QuickDraw-u
  19.  :kinesis-u)
  20.  
  21. (export '(draggable-svm pre-drag-hilite draggable-p point-in-drag-region-p set-drag-outline-rgn))
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24.  
  25. (defclass draggable-svm ()
  26.   ((drag-bounds        :initarg :drag-bounds
  27.                        :accessor drag-bounds)
  28.    (h-drag-slop        :initarg :h-drag-slop
  29.                        :accessor h-drag-slop)
  30.    (v-drag-slop        :initarg :v-drag-slop
  31.                        :accessor v-drag-slop)
  32.    (drag-axis          :initarg :drag-axis
  33.                        :accessor drag-axis)
  34.    (drag-outline-p     :initarg  :drag-outline-p
  35.                        :accessor drag-outline-p)
  36.    (drag-pre-hilite-p  :initarg :drag-pre-hilite-p
  37.                        :accessor drag-pre-hilite-p)
  38.    (drag-pre-erase-p   :initarg :drag-pre-erase-p
  39.                        :accessor drag-pre-erase-p)
  40.    (drag-post-erase-p  :initarg :drag-post-erase-p
  41.                        :accessor drag-post-erase-p)
  42.    (drag-start-tol     :initarg :drag-start-tol
  43.                        :accessor drag-start-tol)
  44.    (drag-action-fn     :initarg :drag-action-fn
  45.                        :accessor drag-action-fn)
  46.    (drag-end-action-fn :initarg :drag-end-action-fn
  47.                        :accessor drag-end-action-fn))
  48.   (:default-initargs
  49.     :drag-bounds      :none
  50.     :h-drag-slop       20
  51.     :v-drag-slop       20
  52.     :drag-axis        :both
  53.     :drag-start-tol    #@(2 2)
  54.     :drag-outline-p    t
  55.     :drag-pre-hilite-p t
  56.     :drag-pre-erase-p  nil
  57.     :drag-post-erase-p t
  58.     ))
  59.  
  60. (defmethod view-click-event-handler ((sv draggable-svm) where)
  61.   (unless (view-drag-handler sv where)
  62.     (call-next-method)))
  63.  
  64. (defmethod view-drag-handler ((sv draggable-svm) where)
  65.   (when (and (draggable-p sv) (point-in-drag-region-p sv where))
  66.     (when (drag-pre-hilite-p sv) (pre-drag-hilite sv t))
  67.     (multiple-value-bind (drag-offset end-action-p) (when (drag-start-p sv where)
  68.                                                       (drag-item sv where))
  69.       (when (drag-pre-hilite-p sv) (pre-drag-hilite sv nil))
  70.       (when end-action-p
  71.         (call-drag-end-action sv drag-offset (add-points where drag-offset)))
  72.       drag-offset)))
  73.  
  74. (defmethod draggable-p ((sv draggable-svm))
  75.   (declare (ignore sv))
  76.   ;;specialize to control when an item can be dragged
  77.   t)
  78.  
  79. (defmethod point-in-drag-region-p ((sv draggable-svm) pt)
  80.   ;;specialize to control from where an item can be dragged
  81.   ;;defaults to any area not also contained by a subview
  82.   (eq sv (find-clicked-subview sv pt)))
  83.  
  84. (defmethod call-drag-action ((sv draggable-svm))
  85.   ;;exists primarily to be specialized by selectable-svm
  86.   (drag-action sv))
  87.  
  88. (defmethod drag-action ((sv draggable-svm))
  89.   (when (slot-boundp sv 'drag-action-fn)
  90.     (funcall (drag-action-fn sv) sv)))
  91.  
  92. (defmethod call-drag-end-action ((sv draggable-svm) drag-offset dest-point)
  93.   ;;exists primarily to be specialized by selectable-svm
  94.   (drag-end-action sv drag-offset dest-point))
  95.  
  96. (defmethod drag-end-action ((sv draggable-svm) drag-offset dest-point)
  97.   (when (slot-boundp sv 'drag-end-action-fn)
  98.     (funcall (drag-end-action-fn sv) sv drag-offset dest-point)))
  99.  
  100. (defmethod pre-drag-hilite ((sv draggable-svm) hilite-flag)
  101.   (with-focused-view (focusing-view sv)
  102.     (hilite-view sv hilite-flag)))
  103.  
  104. (defmethod drag-start-p ((sv draggable-svm) where)
  105.   ;;tracks the mouse to see if the user breaks the item loose
  106.   (rlet ((r :Rect
  107.             :topLeft (subtract-points where (drag-start-tol sv))
  108.             :botRight (add-points where (drag-start-tol sv))))
  109.     (loop (unless (#_WaitMouseUp) (return nil))
  110.           (unless (#_PtInRect (view-mouse-position (focusing-view sv)) r)
  111.             (return t)))))
  112.  
  113. (defpascal drag-action-proc ()
  114.   ;;pascal style fn passed to DragGrayRgn, the call-drag-action method does the
  115.   ;;real work. *current-draggable-di* is bound for the duration of the drag, to
  116.   ;;communicate the item being dragged to drag-action-proc.
  117.   (declare (special *current-draggable-di*))
  118.   (call-drag-action *current-draggable-di*))
  119.  
  120.  
  121. (defmethod drag-proc ((sv draggable-svm) drag-rgn start-pt bounds-rect slop-rect)
  122.   (if (drag-outline-p sv)
  123.     (let ((axis-const (ecase (drag-axis sv)
  124.                         (:both       #.#$noConstraint)
  125.                         (:horizontal #.#$hAxisOnly)
  126.                         (:vertical   #.#$vAxisOnly))))
  127.       (#_DragGrayRgn drag-rgn start-pt bounds-rect slop-rect axis-const drag-action-proc))
  128.     (flet ((action-fn () (call-drag-action sv)))
  129.       (drag-region drag-rgn start-pt
  130.                    :bounds-rect      bounds-rect
  131.                    :slop-rect        slop-rect
  132.                    :drag-axis        (drag-axis sv)
  133.                    :action-fn        #'action-fn
  134.                    :erase-at-start-p (drag-pre-erase-p sv)
  135.                    :erase-at-end-p   (drag-post-erase-p sv)))))
  136.  
  137. (defmethod drag-item ((sv draggable-svm) where)
  138.   ;;returns 2 values: the drag-offset and whether to call the drag-end-action
  139.   (setf where (view-to-global (focusing-view sv) where))
  140.   (rlet ((limitRect :Rect)
  141.          (slopRect :Rect))
  142.     (with-macptrs ((dragRgn (#_NewRgn)))
  143.       (unwind-protect
  144.         (let ((*current-draggable-di* sv))
  145.           (declare (special *current-draggable-di*))
  146.           (set-DragGrayRgn-areas sv where dragRgn limitRect slopRect)
  147.           (shrink-wrap-limitRect where dragRgn limitRect)
  148.           (with-focused-view *WMgr-view*
  149.             (setf where (drag-proc sv dragRgn where limitRect slopRect)))
  150.           (if (eql #@(-32768 -32768) where)
  151.             (values nil nil)
  152.             (values where t)))
  153.         (#_DisposeRgn dragRgn)))))
  154.  
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156. ;; these routines use GLOBAL coordinates
  157.  
  158. (defmethod set-DragGrayRgn-areas ((sv draggable-svm) where drag-rgn limitRect slopRect)
  159.   (declare (ignore where))
  160.   (set-drag-limit-rect sv limitRect)
  161.   (set-drag-slop-rect sv slopRect)
  162.   (set-drag-outline-rgn sv drag-rgn))
  163.  
  164. (defmethod set-drag-outline-rgn ((sv draggable-svm) drag-rgn)
  165.   (multiple-value-bind (topLeft botRight) (view-global-corners sv)
  166.     (rlet ((r :Rect :topLeft topLeft :botRight botRight))
  167.       (#_RectRgn drag-rgn r))))
  168.  
  169. (defmethod set-drag-limit-rect ((sv draggable-svm) r)
  170.   (ecase (drag-bounds sv)
  171.     (:container (multiple-value-bind (c-topLeft c-botRight) (view-global-corners (view-container sv))
  172.                   (pset r :Rect.topLeft c-topLeft)
  173.                   (pset r :Rect.botRight c-botRight))
  174.                 (multiple-value-bind (w-topLeft w-botRight) (view-global-corners (view-window sv))
  175.                   (rlet ((wRect :Rect :topLeft w-topLeft :botRight w-botRight))
  176.                     (#_SectRect r wRect r))))
  177.     (:window  (multiple-value-bind (w-topLeft w-botRight) (view-global-corners (view-window sv))
  178.                 (pset r :Rect.topLeft w-topLeft)
  179.                 (pset r :Rect.botRight w-botRight)))
  180.     (:none (pset r :Rect.topLeft #@(-16384 -16384))
  181.            (pset r :Rect.botRight #@(16384 16384)))))
  182.  
  183. (defmethod set-drag-slop-rect ((sv draggable-svm) r)
  184.     (set-drag-limit-rect sv r)
  185.     (#_InsetRect r  (- (h-drag-slop sv)) (- (v-drag-slop sv))))
  186.  
  187. (defun shrink-wrap-limitRect (where dragRgn limitRect)
  188.   (let ((h (point-h where))
  189.         (v (point-v where)))
  190.     (pset limitRect :Rect.top    (- v (max 0 (- (href dragRgn :Region.rgnBBox.top)
  191.                                                 (pref limitRect :Rect.top)))))
  192.     (pset limitRect :Rect.left   (- h (max 0 (- (href dragRgn :Region.rgnBBox.left)
  193.                                                 (pref limitRect :Rect.left)))))
  194.     (pset limitRect :Rect.bottom (+ v (max 0 (- (pref limitRect :Rect.bottom)
  195.                                                 (href dragRgn :Region.rgnBBox.bottom)))))
  196.     (pset limitRect :Rect.right  (+ h (max 0 (- (pref limitRect :Rect.right)
  197.                                                 (href dragRgn :Region.rgnBBox.right)))))))
  198.  
  199. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  200.  
  201. #|
  202. ;;; a modest example - adding drag behavior to static text dialog items
  203.  
  204. (defclass stdrg (draggable-svm static-text-dialog-item) ())
  205.  
  206.  
  207. (setf *test-w*
  208.       (make-instance 'dialog
  209.                      :window-type :document
  210.                      :view-position :centered
  211.                      :view-size #@(200 100)
  212.                      :window-title "draggable-svm demo"
  213.                      :close-box-p t
  214.                      :color-p t
  215.                      :view-subviews
  216.                      (list (make-instance 'stdrg
  217.                                           :view-position #@(10 20)
  218.                                           :dialog-item-text "change my position"
  219.                                           :view-nick-name :i1
  220.                                           :drag-end-action-fn #'(lambda (sv delta pt)
  221.                                                            (declare (ignore pt))
  222.                                                            (offset-view-position sv delta))
  223.                                           :drag-bounds :window
  224.                                           )
  225.                            (make-instance 'stdrg
  226.                                           :view-position #@(10 50)
  227.                                           :dialog-item-text "drag me anywhere"
  228.                                           :view-nick-name :i2
  229.                                           :dialog-item-action #'(lambda (di) (declare (ignore di)) (ed-beep))
  230.                                           :drag-action-fn #'(lambda (di) (declare (ignore di)) (ed-beep))
  231.                                           :drag-bounds :none
  232.                                           ))))
  233.  
  234. |#