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-digitizer-svm.lisp < prev    next >
Encoding:
Text File  |  1992-06-04  |  4.7 KB  |  126 lines
  1. (in-package :oou)
  2. (oou-provide :video-digitizer-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; video-digitizer-svm.lisp
  5. ;;
  6. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixin for adding video digitizing to views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :video-digitizer
  16.  :simple-view-ce
  17.  )
  18.  
  19. (export '(video-digitizer-svm
  20.           digitizing-p start-digitizing stop-digitizing grab-one-frame
  21.           video-margins digitizer-object
  22.            ))
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (defclass video-digitizer-svm ()
  27.   ((digitizer-class        :initarg :digitizer-class)
  28.    (digitizer-object       :initarg :digitizer-object
  29.                            :accessor digitizer-object)
  30.    (dispose-vd-on-remove-p :initarg :dispose-vd-on-remove-p))
  31.   (:default-initargs
  32.     :digitizer-class 'video-digitizer
  33.     :dispose-vd-on-remove-p t
  34.     ))
  35.  
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;; digitizer control
  38.  
  39. (defmethod digitizing-p ((sv video-digitizer-svm))
  40.   (vd-digitizing-p (digitizer-object sv)))
  41.  
  42. (defmethod start-digitizing ((sv video-digitizer-svm))
  43.   (with-focused-view (focusing-view sv)
  44.     (vd-start-digitizing (digitizer-object sv))))
  45.  
  46. (defmethod stop-digitizing ((sv video-digitizer-svm))
  47.   (vd-stop-digitizing (digitizer-object sv)))
  48.  
  49. (defmethod grab-one-frame ((sv video-digitizer-svm))
  50.   (with-focused-view (focusing-view sv)
  51.     (vd-grab-one-frame (digitizer-object sv))))
  52.  
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54.  
  55. (defmethod initialize-instance :after ((sv video-digitizer-svm) &rest initargs
  56.                                        &key
  57.                                        dest-rect-topLeft
  58.                                        dest-rect-botRight
  59.                                        &allow-other-keys)
  60.   (declare (dynamic-extent initargs))
  61.   (unless (slot-boundp sv 'digitizer-object)
  62.     (setf (digitizer-object sv)
  63.           (apply 'make-instance (slot-value sv 'digitizer-class)
  64.                  :allow-other-keys t
  65.                  initargs))
  66.     (multiple-value-bind (topLeft botRight) (video-corners sv)
  67.       (unless dest-rect-topLeft
  68.         (setf (dest-rect-topLeft (digitizer-object sv)) topLeft))
  69.       (unless dest-rect-botRight
  70.         (setf (dest-rect-botRight (digitizer-object sv)) botRight)))))
  71.  
  72. (defmethod install-view-in-window :after ((sv video-digitizer-svm) window)
  73.   (with-slots (digitizer-object) sv
  74.     (vd-init digitizer-object)
  75.     (setf (slot-value digitizer-object 'dest-wptr) (wptr window)))
  76.   (when (subtypep (type-of window) 'video-wm)
  77.     (pushnew sv (slot-value window 'digitizer-subviews))))
  78.  
  79. (defmethod remove-view-from-window :before ((sv video-digitizer-svm))
  80.   (when (slot-value sv 'dispose-vd-on-remove-p)
  81.     (vd-dispose (digitizer-object sv)))
  82.   (let ((w (view-window sv)))
  83.     (when (subtypep (type-of w) 'video-wm)
  84.       (setf (slot-value w 'digitizer-subviews)
  85.             (delete sv (slot-value w 'digitizer-subviews))))))
  86.  
  87. (defmethod video-margins ((sv video-digitizer-svm))
  88.   (declare (ignore sv))
  89.   (values #@(0 0) #@(0 0)))
  90.  
  91. (defmethod video-corners ((sv video-digitizer-svm))
  92.   (multiple-value-bind (topLeft botRight) (focused-corners sv)
  93.     (multiple-value-bind (tl-margin br-margin) (video-margins sv)
  94.       (values (add-points topLeft tl-margin) (subtract-points botRight br-margin)))))
  95.  
  96. (defmethod view-default-size ((sv video-digitizer-svm))
  97.   (add-points (multiple-value-call #'add-points (video-margins sv))
  98.               #@(100 100)))
  99.  
  100. (defmethod set-view-size :around ((sv video-digitizer-svm) h &optional v)
  101.   (declare (ignore h v))
  102.   (erase-view sv)
  103.   (with-slots (digitizer-object) sv
  104.     (let ((on-p (vd-digitizing-p digitizer-object)))
  105.       (when on-p (vd-stop-digitizing digitizer-object))
  106.       (call-next-method)
  107.       (multiple-value-bind (topLeft botRight) (video-corners sv)
  108.         (setf (dest-rect-topLeft digitizer-object)  topLeft)
  109.         (setf (dest-rect-botRight digitizer-object) botRight))
  110.       (when on-p (vd-start-digitizing digitizer-object)))))
  111.  
  112. (defmethod set-view-position :around ((sv video-digitizer-svm) h &optional v)
  113.   (declare (ignore h v))
  114.   (with-slots (digitizer-object) sv
  115.     (let ((on-p (vd-digitizing-p digitizer-object)))
  116.       (when on-p (vd-stop-digitizing digitizer-object))
  117.       (call-next-method)
  118.       (multiple-value-bind (topLeft botRight) (video-corners sv)
  119.         (setf (dest-rect-topLeft  digitizer-object) topLeft)
  120.         (setf (dest-rect-botRight digitizer-object) botRight))
  121.       (when on-p (vd-start-digitizing digitizer-object)))))
  122.  
  123. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  124. #|
  125.    examples can be found in the board specific -vd files
  126. |#