home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / MCLs-funniest-home-videos / video-wm.lisp < prev   
Encoding:
Text File  |  1992-03-03  |  4.3 KB  |  125 lines
  1. (in-package :oou)
  2. (oou-provide :video-wm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; video-wm.lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixin for making windows video aware
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :video-digitizer-svm
  16.  :window-ce
  17.  :records-u
  18.  )
  19.  
  20. (export '(video-wm video-window video-dialog
  21.            ))
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24.  
  25. (defclass video-wm ()
  26.   ((digitizer-subviews :initform nil)
  27.    (vw-drag-rect       :accessor vw-drag-rect)
  28.    )
  29.   (:default-initargs
  30.     :color-p t
  31.     ))
  32.  
  33. (defclass video-window (video-wm window) ())
  34. (defclass video-dialog (video-wm dialog) ())
  35.  
  36. (defmethod initialize-instance :after ((w video-wm) &rest initargs &key view-position)
  37.   (declare (ignore initargs))
  38.   (when (and (vw-GDevice w) (null view-position))
  39.     (window-center-on-screen w :specified-GD :GDevice (vw-GDevice w)))
  40.   (vw-check-GDevices w)
  41.   (setf (vw-drag-rect w) (#_NewPtr (rlength :Rect)))
  42.   (when (%null-ptr-p (vw-drag-rect w))
  43.     (error "unable to allocate drag Rect for video window.")))
  44.  
  45. (defmethod window-close :after ((w video-wm))
  46.   (#_DisposePtr (vw-drag-rect w)))
  47.  
  48. (defmethod add-subviews :after ((w video-wm) &rest subviews)
  49.   (declare (ignore subviews))
  50.   (vw-check-GDevices w))
  51.  
  52. (defmethod window-drag-rect ((w video-wm))
  53.   (with-macptrs ((gd_h      (vw-GDevice w))
  54.                  (struct-rgn  (pref (wptr w) :windowRecord.strucRgn)))
  55.     (when gd_h
  56.       (rlet ((mouse-pos_p :point))
  57.         (#_GetMouse mouse-pos_p)
  58.         (#_LocalToGlobal mouse-pos_p)
  59.         (let* ((win-tl    (href struct-rgn :Region.rgnBBox.topLeft))
  60.                (win-br    (href struct-rgn :Region.rgnBBox.botRight))
  61.                (mouse-pos (%get-point mouse-pos_p))
  62.                (r         (vw-drag-rect w)))
  63.           
  64.           (with-dereferenced-handles ((gd_p gd_h))
  65.             (pset r :Rect (pref gd_p :GDevice.gdRect))
  66.             (incf (rref r :Rect.top)    (- (point-v mouse-pos) (point-v win-tl)))
  67.             (incf (rref r :Rect.left)   (- (point-h mouse-pos) (point-h win-tl)))
  68.             (incf (rref r :Rect.bottom) (- (point-v mouse-pos) (point-v win-br)))
  69.             (incf (rref r :Rect.right)  (- (point-h mouse-pos) (point-h win-br)))
  70.             (when (eql gd_h (#_GetMainDevice))
  71.               (incf (rref r :Rect.top) (#_GetMBarHeight)))
  72.             r))))))
  73.  
  74. (defmethod window-hide :before ((w video-wm))
  75.   (vw-stop-digitizing  w (vw-on-list w)))
  76.  
  77. (defmethod set-view-position :around ((w video-wm) h &optional v)
  78.   (declare (ignore h v))
  79.   (let ((on-list (vw-on-list w)))
  80.     (prog2
  81.      (vw-stop-digitizing  w on-list)
  82.      (call-next-method)
  83.      (vw-start-digitizing w on-list))))
  84.  
  85. (defmethod set-view-position :after ((w video-wm) h &optional v)
  86.   (declare (ignore h v))
  87.   (when (window-shown-p w) (vw-check-GDevices w)))
  88.  
  89.  
  90. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91.  
  92. (defmethod vw-GDevice ((w video-wm))
  93.   (let ((dviews (slot-value w 'digitizer-subviews)))
  94.     (when dviews
  95.       (vd-GDevice (digitizer-object (first dviews))))))
  96.  
  97. (defmethod vw-on-list ((w video-wm))
  98.   (flet ((on-p (v) (when (digitizing-p v) (list v))))
  99.     (declare (dynamic-extent #'on-p))
  100.     (mapcan #'on-p (slot-value w 'digitizer-subviews))))
  101.  
  102. (defmethod vw-stop-digitizing ((w video-wm) on-list)
  103.   (dolist (v on-list) (stop-digitizing v)))
  104.  
  105. (defmethod vw-start-digitizing ((w video-wm) on-list)
  106.   (dolist (v on-list) (start-digitizing v)))
  107.  
  108. (defmethod vw-check-GDevices ((w video-wm))
  109.   (let ((gd_h (vw-GDevice w)))
  110.     (when gd_h
  111.       (with-dereferenced-handles ((gd_p gd_h))
  112.         (with-macptrs ((gd-rect (pref gd_p :GDevice.gdRect)))
  113.           (dolist (v (slot-value w 'digitizer-subviews))
  114.             (unless (eql gd_h (vd-GDevice (digitizer-object v)))
  115.               (error "digitizer views requiring different GDevices used in the same window."))
  116.             (multiple-value-bind (topLeft botRight) (view-global-corners v)
  117.               (unless (and (#_PtInRect topLeft  gd-rect)
  118.                            (#_PtInRect botRight gd-rect))
  119.                 (error "digitizer view not on required GDevice."))))))))
  120.   t)
  121.  
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123. #|
  124. an example can be found in video-example.lisp
  125. |#