home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / kinesis-u.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  12.0 KB  |  282 lines
  1. (in-package  :oou)
  2. (oou-provide :kinesis-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; kinesis-u.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for moving images around    
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :screen-3buf
  15.                   :QuickDraw-u
  16.                   :GWorld-u)
  17.  
  18. (export '(drag-region move-region))
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21.  
  22. ;;default drag over function
  23. (defun drag-over-p () (not (#_WaitMouseUp)))
  24.  
  25. ;;default drag position function
  26. (defun drag-cur-pos ()
  27.   (rlet ((pt_p :Point))
  28.     (#_GetMouse pt_p)
  29.     (#_LocalToGlobal pt_p)
  30.     (%get-point pt_p)))
  31.  
  32. (defun drag-region (drag-rgn start-pt
  33.                              &key
  34.                              (bounds-rect        nil)
  35.                              (slop-rect          nil)
  36.                              (drag-axis         :both)
  37.                              (action-fn          nil)
  38.                              (erase-at-start-p   nil)
  39.                              (erase-at-end-p     t)
  40.                              (border-size        #@(50 50))
  41.                              (saved-bits-init-fn nil)
  42.                              (drag-over-p-fn     #'drag-over-p)
  43.                              (drag-cur-pos-fn    #'drag-cur-pos))
  44.   (declare (dynamic-extent drag-rgn start-pt bounds-rect slop-rect drag-axis action-fn erase-at-start-p erase-at-end-p border-size saved-bits-init-fn))
  45.   (let* ((rgn-pos  (href drag-rgn :Region.rgnBBox.topLeft))
  46.          (rgn-size (subtract-points (href drag-rgn :Region.rgnBBox.botRight)
  47.                                     (href drag-rgn :Region.rgnBBox.topLeft)))
  48.          (s3b      (make-instance 'screen-3buf
  49.                      :s3buf-position (subtract-points rgn-pos border-size)
  50.                      :s3buf-size     (add-points rgn-size (add-points border-size border-size))))
  51.          (cur-pos start-pt)
  52.          (last-pos start-pt)
  53.          (s3b-tl (s3buf-position s3b))
  54.          (s3b-br (add-points (s3buf-position s3b) (s3buf-size s3b)))
  55.          (hidden-p nil))
  56.     (declare (dynamic-extent rgn-pos rgn-size s3b last-pos s3b-tl s3b-br hidden-p))
  57.     
  58.     (rlet ((cached-r :Rect
  59.                      :topLeft  (add-points s3b-tl (subtract-points start-pt rgn-pos))
  60.                      :botRight (add-points s3b-br (subtract-points start-pt (href drag-rgn :Region.rgnBBox.botRight))))
  61.            (bounds-r :Rect
  62.                      :topLeft  #@(-32767 -32767)
  63.                      :botRight #@(32767 32767))
  64.            (slop-r   :Rect))
  65.       
  66.       ;set up the bounds and slop rects
  67.       (when (pointerp bounds-rect) (pset bounds-r :Rect bounds-rect))
  68.       (pset slop-r :Rect (if (pointerp slop-rect) slop-rect bounds-r))
  69.       
  70.       (s3buf-alloc s3b)
  71.       
  72.       (unwind-protect
  73.         (progn
  74.           (when erase-at-start-p
  75.             (erase-screen-buf-gWorld (saved-GW-view s3b) :region drag-rgn))
  76.  
  77.           (when saved-bits-init-fn
  78.             (flet ((draw-fn (s3b r)
  79.                      (declare (ignore s3b))
  80.                      (funcall saved-bits-init-fn drag-rgn r)))
  81.               (declare (dynamic-extent #'draw-fn))
  82.               (s3buf-draw-to-saved s3b #'draw-fn)))
  83.           
  84.           (loop
  85.             (when (funcall drag-over-p-fn) (return (values (subtract-points cur-pos start-pt) cur-pos)))
  86.             (when action-fn (funcall action-fn))
  87.             (setf cur-pos (ecase drag-axis
  88.                             (:both (funcall drag-cur-pos-fn))
  89.                             (:vertical   (make-point (point-h start-pt)
  90.                                                      (point-v (funcall drag-cur-pos-fn))))
  91.                             (:horizontal (make-point (point-h (funcall drag-cur-pos-fn))
  92.                                                      (point-h start-pt)))))
  93.             (if (#_PtInRect cur-pos slop-r)
  94.               (unless (eql cur-pos last-pos)
  95.                 (let ((delta-rgn-pos (subtract-points (setf cur-pos (#_PinRect bounds-r cur-pos)) last-pos)))
  96.                   (declare (dynamic-extent delta-rgn-pos))
  97.                   (setf hidden-p nil)
  98.                   (setf rgn-pos (add-points rgn-pos delta-rgn-pos))
  99.                   (if (#_PtInRect cur-pos cached-r)
  100.                     (s3buf-reposition s3b s3b-tl s3b-br
  101.                                       :restore-old-rgn-p nil
  102.                                       :saved-xfer-mode  :none
  103.                                       :image-xfer-mode  :move
  104.                                       :image-sub-rgn     drag-rgn
  105.                                       :sub-rgn-new-pos   rgn-pos)
  106.                     
  107.                     (let ((delta-buf-pos (subtract-points (subtract-points rgn-pos border-size) s3b-tl)))
  108.                       (declare (dynamic-extent delta-buf-pos))
  109.                       (setf s3b-tl (add-points s3b-tl delta-buf-pos))
  110.                       (setf s3b-br (add-points s3b-br delta-buf-pos))
  111.                       (s3buf-reposition s3b s3b-tl s3b-br
  112.                                         :restore-old-rgn-p t
  113.                                         :saved-xfer-mode  :slip
  114.                                         :image-sub-rgn     drag-rgn
  115.                                         :sub-rgn-new-pos   rgn-pos)
  116.                       (#_OffsetRect :pointer cached-r :long delta-buf-pos)))
  117.                   (setf last-pos cur-pos)
  118.                   (s3buf-image-to-screen s3b)))
  119.               (unless hidden-p
  120.                 (setf hidden-p t)
  121.                 (s3buf-saved-to-screen s3b)))))
  122.         (when erase-at-end-p (s3buf-saved-to-screen s3b))
  123.         (s3buf-dispose s3b)))))
  124.  
  125.  
  126.  
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130.  
  131. (defun move-region (the-rgn point-list
  132.                            &key
  133.                            (erase-at-start-p nil)
  134.                            (erase-at-end-p t)
  135.                            (border-size #@(50 50))
  136.                            (saved-bits-init-fn nil))
  137.   (declare (dynamic-extent the-rgn point-list erase-at-start-p erase-at-end-p border-size saved-bits-init-fn))
  138.   (let* ((rgn-pos  (href the-rgn :Region.rgnBBox.topLeft))
  139.          (rgn-size (subtract-points (href the-rgn :Region.rgnBBox.botRight)
  140.                                     (href the-rgn :Region.rgnBBox.topLeft)))
  141.          (s3b (make-instance 'screen-3buf
  142.                 :s3buf-position (subtract-points rgn-pos border-size)
  143.                 :s3buf-size     (add-points rgn-size (add-points border-size border-size))))
  144.          (start-pt (first point-list))
  145.          (last-pos start-pt)
  146.          (s3b-tl (s3buf-position s3b))
  147.          (s3b-br (add-points (s3buf-position s3b) (s3buf-size s3b))))
  148.     (declare (dynamic-extent rgn-pos rgn-size s3b last-pos s3b-tl s3b-br))
  149.     (rlet ((cached-r :Rect
  150.                      :topLeft  (add-points s3b-tl (subtract-points last-pos rgn-pos))
  151.                      :botRight (add-points s3b-br (subtract-points last-pos (href the-rgn :Region.rgnBBox.botRight)))))
  152.       
  153.       (s3buf-alloc s3b)
  154.       
  155.       (unwind-protect
  156.         (progn
  157.           (when erase-at-start-p
  158.             (erase-screen-buf-gWorld (saved-GW-view s3b) :region the-rgn))
  159.  
  160.           (when saved-bits-init-fn
  161.             (flet ((draw-fn (s3b r)
  162.                      (declare (ignore s3b))
  163.                      (funcall saved-bits-init-fn the-rgn r)))
  164.               (declare (dynamic-extent #'draw-fn))
  165.               (s3buf-draw-to-saved s3b #'draw-fn)))
  166.           
  167.           (dolist (cur-pos point-list (values (subtract-points last-pos start-pt) last-pos))
  168.             (setf rgn-pos (add-points rgn-pos (subtract-points cur-pos last-pos)))
  169.             (if (#_PtInRect cur-pos cached-r)
  170.               (s3buf-reposition s3b s3b-tl s3b-br
  171.                                 :restore-old-rgn-p nil
  172.                                 :saved-xfer-mode  :none
  173.                                 :image-xfer-mode  :move
  174.                                 :image-sub-rgn     the-rgn
  175.                                 :sub-rgn-new-pos rgn-pos)
  176.               (let ((delta-buf-pos (subtract-points (subtract-points rgn-pos border-size) s3b-tl)))
  177.                 (declare (dynamic-extent delta-buf-pos))
  178.                 (setf s3b-tl (add-points s3b-tl delta-buf-pos))
  179.                 (setf s3b-br (add-points s3b-br delta-buf-pos))
  180.                 (s3buf-reposition s3b s3b-tl s3b-br
  181.                                   :restore-old-rgn-p t
  182.                                   :saved-xfer-mode  :slip
  183.                                   :image-sub-rgn     the-rgn
  184.                                   :sub-rgn-new-pos   rgn-pos)
  185.                 (#_OffsetRect :pointer cached-r :long delta-buf-pos)))
  186.             (setf last-pos cur-pos)
  187.             (s3buf-image-to-screen s3b)))
  188.         (when erase-at-end-p (s3buf-saved-to-screen s3b))
  189.         (s3buf-dispose s3b)))))
  190.  
  191. #|
  192.  
  193. (oou-dependencies :simple-view-ce)
  194.  
  195. (progn
  196.   (defparameter *test-w* (make-instance 'window
  197.                            :view-position #@(5 40)
  198.                            :view-size #@(200 200)
  199.                            ;:color-p t
  200.                            ))
  201.   (with-focused-view *test-w* (#_BackPat *light-gray-pattern*))
  202.   ;(set-back-color *test-w* *red-color*)
  203.   ;(set-fore-color *test-w* *blue-color*)
  204.   (invalidate-view *test-w* t))
  205.  
  206. (with-focused-view *test-w*
  207.   (rlet ((r :Rect
  208.             :topLeft #@(20 20)
  209.             :botRight #@(150 150)))
  210.     (with-macptrs ((rgn (#_NewRgn)))
  211.       (#_OpenRgn)
  212.       (#_FrameOval r)
  213.       (#_InsetRect r 10 10)
  214.       (#_FrameOval r)
  215.       (#_InsetRect r 20 20)
  216.       (#_OffsetRect r -10 -5)
  217.       (#_FrameOval r)
  218.       (#_OffsetRect r 20 0)
  219.       (#_FrameOval r)
  220.       (#_CloseRgn rgn)
  221.       (#_FillRgn rgn *dark-gray-pattern*)
  222.       
  223.       ;convert region to global coords
  224.       (move-region-to rgn (view-to-global *test-w* (href rgn :region.rgnBBox.topLeft)))
  225.       
  226.       (loop
  227.         (when (mouse-down-p)
  228.           
  229.           (#_FlushEvents #$mDownMask 0)
  230.           (let ((pt (view-mouse-position nil)))
  231.             (rlet ((bounds-r :Rect
  232.                              :topLeft  (view-position *test-w*)
  233.                              :botRight (add-points (view-position *test-w*) (view-size *test-w*)))
  234.                    (slop-r :Rect))
  235.               (pset slop-r :Rect bounds-r)
  236.               (incf (pref bounds-r :Rect.topLeft)  (subtract-points pt (href rgn :region.rgnBBox.topLeft)))
  237.               (incf (pref bounds-r :Rect.botRight) (subtract-points pt (href rgn :region.rgnBBox.botRight)))
  238.               (#_InsetRect slop-r -20 -20)
  239.               (return
  240.                (multiple-value-bind (delta final)
  241.                                     (drag-region rgn pt
  242.                                                  :border-size #@(50 50)
  243.                                                  :erase-at-start-p t
  244.                                                  ;:bounds-rect bounds-r
  245.                                                  ;:slop-rect slop-r
  246.                                                  )
  247.                  (#_DisposeRgn rgn)
  248.                  (values (point-string delta) (point-string final)))))))))))
  249.  
  250.  
  251. (with-focused-view *test-w*
  252.   (rlet ((r :Rect
  253.             :topLeft #@(20 20)
  254.             :botRight #@(150 150)))
  255.     (with-macptrs ((rgn (#_NewRgn)))
  256.       (#_OpenRgn)
  257.       (#_FrameOval r)
  258.       (#_InsetRect r 10 10)
  259.       (#_FrameOval r)
  260.       (#_InsetRect r 20 20)
  261.       (#_OffsetRect r -10 -5)
  262.       (#_FrameOval r)
  263.       (#_OffsetRect r 20 0)
  264.       (#_FrameOval r)
  265.       (#_CloseRgn rgn)
  266.       (#_FillRgn rgn *dark-gray-pattern*)
  267.       
  268.       ;convert region to global coords
  269.       (move-region-to rgn (view-to-global *test-w* (href rgn :region.rgnBBox.topLeft)))
  270.       
  271.       (let ((pt-list (list (href rgn :Region.rgnBBox.topLeft))))
  272.         (dotimes (i 50)
  273.           (push (make-point (+ 3  (point-h (first pt-list)))
  274.                             (+ 2  (point-v (first pt-list))))
  275.                 pt-list))
  276.           (setf pt-list (nreverse pt-list))
  277.         (move-region rgn pt-list
  278.                      :border-size #@(50 50)
  279.                      :erase-at-start-p t)
  280.         (#_DisposeRgn rgn)
  281.         ))))
  282. |#