Re: picking up mouse-drag events

["Mark A. Tapia" <markt@dgp.toronto.edu>]

On Friday Nov 12, christian e. crone writes:
  are there variables that holds the beginning and current position of a drag
  event (for example, as in selecting a group of objects)?  it seems like
  *mouse-view*, etc. are bound to the click-down point.
 
  is there a method which handles such "selections" (which can be specialized)?
  if i were to try to make my own multi-view selection routine, where would it
  best fit?
The code from Michael S. Engber (available  by anonymous ftp from
cambridge.apple.com in the oodles-of-utils contains an example of a draggable
view in the file /oodles-of-utiles/mixin-madness/simple-view-mixins/
draggable-svm.lisp. This code restrains the rectangle for dragging the view.
Examples use the code to create draggable and droppable views.

There used to be code in the examples folder to create a mondrian crawing
(of overlapping squares).

Here's code that creates a grey drag rectangle within a window. I've
also included code for handling a scrolling window.

mark

|#                                            
(in-package ccl)
;; define a new class of views, called a drag view. The drag view-allows the
;; user to sweep out a rectangle within the view. When the view is a
scrolling-window,
;; the rectangle is confined to the scrolling area.
;;
;; For drag-views, the drag-end-action  slot is a either nil or it is a function 
;; of the form (drag-end-action top-left bottom-right) where the points
;; define the boundary of the rectangle swept out. You can use the
drag-end-action
;; to record the top left and bottom right regions of the rectangle.

(require 'scrolling-windows "ccl:examples;scrolling-windows")
(require 'quickdraw)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; QuickDraw-u.lisp
;;
;; Copyright  1991 Northwestern University Institute for the Learning Sciences
;; All Rights Reserved
;;
;; author: Michael S. Engber
;;
;; utilities for quickdraw
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  (let ((state (gensym)))
    `(rlet ((,state :PenState))
       (require-trap #_GetPenState :ptr ,state)
       (unwind-protect
         (progn
           ,@(when pnLoc    `((require-trap #_MoveTo :long ,pnLoc)))
           ,@(when pnSize   `((require-trap #_PenSize :long ,pnSize)))
           ,@(when pnMode   `((require-trap #_PenMode :signed-integer ,pnMode)))
           ,@(when pnPat    `((require-trap #_PenPat :ptr ,pnPat)))
           ,@(when pnPixPat `((require-trap #_PenPixPat :ptr ,pnPixPat)))
           ,@body)
         (require-trap #_SetPenState :ptr ,state)))))

;;; end of extract from quickdraw-u

(defclass drag-view (view) 
  ((dragging :initform nil)
   (drag-end-action :initarg :drag-end-action)))

(defclass dragger-window (drag-view window) ())

(defclass drag-scroller (drag-view scroller) ())

(defclass scroll-dragger-window (scrolling-window drag-view)
  ()
  (:default-initargs
    :scroller-class 'drag-scroller))

(defmethod track-drag-view ((view drag-view) where)
  (when (mouse-down-p)
    (with-focused-view view
      (if (double-click-p)
        nil
        (track-and-hilite view where)))
    t))

(defmethod drag-corners ((self view))
  (view-corners self))

(defmethod drag-corners ((self scrolling-window))
  (drag-corners (my-scroller self)))

(defmethod track-and-hilite ((view drag-view) start-point)
  ;; Draws a grey outline around the rectangle with the top left and
  ;; bottom right corners at start-point and the current point
  ;; continue until the mouse botton is released.
  ;; constrain-point1 ensures that point remains inside the drag rectangle.
  ;; 
  (multiple-value-bind (topLeft bottomRight)
                       (drag-corners view)
    (rlet ((drag-rect :rect)
           (r :rect :topLeft start-point :bottomRight start-point))
      (points-to-rect topLeft bottomRight drag-rect)
      (let* ((last-point (constrain-point1 drag-rect start-point nil))
             (point last-point)
             (corner-point last-point))
        (with-pen-state (:pnMode #$patxor :pnpat *gray-pattern*)
          (loop with continue = t
                unless (require-trap #_WaitMouseUp)
                do (setq continue nil)
                while continue
                finally (when last-point
                          (require-trap #_frameRect r)
                          ;(require-trap #_invertRect r)
                          )
                do (setq point (mouse-position view))
                
                unless (equal last-point point)
                do (when last-point
                     (without-interrupts 
                      (setq point (constrain-point1 drag-rect point last-point))
                      (unless (equal point last-point)
                        (when last-point
                          (require-trap #_frameRect r))
                        ;(require-trap #_invertRect r)
                        (when point
                          (points-to-rect corner-point point r)
                          (require-trap #_frameRect r))
                        ;(require-trap #_invertRect r)
                        ))
                     (setq last-point point))))
        (drag-end-action view (rref r :rect.topLeft) (rref r :rect.bottomRight))
        t))))

(defmethod drag-end-action ((view drag-view) topLeft bottomRight)
  (if (and (slot-exists-p view 'drag-end-action)
           (slot-boundp view 'drag-end-action))
    (funcall (slot-value view 'drag-end-action) topLeft bottomRight)
    (values topLeft bottomRight)))

(defmethod mouse-position ((self view) &optional point)
  ;; returns either point or the current view mouse position in view coordinates
  (or point (view-mouse-position self)))

(defmethod constrain-point ((view drag-view) point last-point)
  (multiple-value-bind (topLeft bottomRight)
                       (drag-corners view)
    (let* ((top (point-v topLeft))
           (bottom (point-v bottomRight))
           (left (point-h topLeft))
           (right (point-h bottomRight))
           (h (point-h point))
           (v (point-v point))
           (real-h h)
           (real-v v)
           (last-h (point-h last-point))
           (last-v (point-v last-point)))
      (cond ((< v top) (setq real-v top))
            ((> v bottom) (setq real-v bottom)))
      (cond ((< h left) (setq real-h left))
            ((> h right) (setq real-h right)))
      (cond ((and (= h real-h) (= v real-v)) point)
            ((and (= real-h last-h) (= real-v last-v)) last-point)
            (t (make-point real-h real-v))))))

(defun constrain-point1 (drag-rect point last-point)
  (let* ((topLeft (rref drag-rect :rect.topLeft))
         (bottomRight (rref drag-rect :rect.bottomRight))
         (top (point-v topLeft))
         (bottom (point-v bottomRight))
         (left (point-h topLeft))
         (right (point-h bottomRight))
         (h (point-h point))
         (v (point-v point))
         (real-h h)
         (real-v v)
         (last-h (when last-point
                   (point-h last-point)))
         (last-v (when last-point
                   (point-v last-point))))
    (cond ((< v top) (setq real-v top))
          ((> v bottom) (setq real-v bottom)))
    (cond ((< h left) (setq real-h left))
          ((> h right) (setq real-h right)))
    (cond ((and (= h real-h) (= v real-v)) point)
          ((null last-point) (make-point real-h real-v))
          ((and (= real-h last-h) (= real-v last-v)) last-point)
          (t (make-point real-h real-v)))))

(defmethod within-active-area ((self view) where)
  (declare (ignore where))
  t)

(defmethod within-active-area ((self scroller) where)
  (multiple-value-bind (top-left bottom-right)
                       (drag-corners self)
    (declare (ignore top-left))
    (and (< (point-h where) (point-h bottom-right))
         (< (point-v where) (point-v bottom-right)))))

(defmethod within-active-area ((window scrolling-window) where)
  (within-active-area (my-scroller window) where))

(defmethod view-click-event-handler ((view drag-view) where)
  (if (and (within-active-area view where)
           (or (not (slot-boundp view 'dragging))
               (null (slot-value view 'dragging))))
    (track-drag-view view where)
    (call-next-method)))

(defmethod view-click-event-handler ((scrolling-window drag-view) where)
  (unless (with-slots (my-scroller) scrolling-window
            (view-click-event-handler my-scroller where)))
  
  (defmethod view-click-event-handler ((scroller drag-scroller) where)
    (if (within-active-area scroller where)
      (track-drag-view scroller where)
      (call-next-method)))
  
#|
(defun echo-points (top-left bottom-right)
  (declare (ignore view))
  (print-db (point-string top-left)
            (point-string bottom-right)))
(setq that (make-instance 'dragger-window 
             :window-title "Drag Window"
             :drag-end-action #'echo-points))
(window-close that)
(setq that (make-instance 'scroll-dragger-window
             :window-title "Scroll Drag"
             :drag-end-action #'echo-points))
(window-close that)
|#