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-digitizers / MR-vd.lisp next >
Encoding:
Text File  |  1992-02-10  |  22.8 KB  |  615 lines
  1. (in-package :oou)
  2. (oou-provide :MR-vd)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; MR-vd.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 MACL 1.32 written by Mike Engber & Mike Korcuska
  11. ;;
  12. ;; video digitizer object for controling MoonRaker video digitizer boards
  13. ;; Note: MoonRaker boards require the WTI-VideoMgr init
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. (oou-dependencies
  17.  :video-digitizer
  18.  :+Devices
  19.  :traps-u
  20.  :records-u
  21.  )
  22.  
  23. (export '(MR-vd
  24.           use-gray-p sync-on-green-p ctSize MRvd-optimize-colors
  25.            ))
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (eval-when (:compile-toplevel :load-toplevel :execute)
  30.  
  31.   (defrecord (MRCsParam :pointer)
  32.     ;;MRCsParam records are passed into Control calls to the MoonRaker
  33.     ;;driver. This argument is a pointer to a 22 block of memory which
  34.     ;;corresponds to the csParam field of a ParamBlockRec which is
  35.     ;;defined as: array[0..10] of integer. The use of these 22 bytes
  36.     ;;varies, depending on the csCode.
  37.     (variant
  38.      ((csParam (array :integer 11)))
  39.      ((ptr pointer))
  40.      ((sv2-in1 integer) (sv2-in2 integer) (sv2-dst1 pointer) (sv2-dst2 pointer))
  41.      ((cv2-src1 pointer) (cv2-dst1 pointer) (cv2-scr2 pointer) (cv2-dst2 pointer))
  42.      ((cc-src pointer) (cc-dst pointer) (cc-offs longint) (cc-fcnt longint))
  43.      ))
  44.   
  45.   (defrecord (MR_Status :pointer)
  46.     (signalThere  boolean)
  47.     (boardBusy    boolean)
  48.     (oddField     boolean)
  49.     (hasConverter boolean)
  50.     (hasAudio     boolean)
  51.     (slot         integer))
  52.   
  53.   (defrecord (MR_TheMRCtl :pointer)
  54.     (UseGray     boolean)
  55.     (VideoStd    boolean)
  56.     (VideoSource integer)
  57.     (SyncOnGreen boolean)
  58.     (Contrast    integer)
  59.     (Hue         integer)
  60.     (Saturation  integer))
  61.   
  62.   (defrecord (MR_ScanLinRec :pointer)
  63.     (srcbegin  point)
  64.     (srcLength integer)
  65.     (dstbegin  point)
  66.     (dstLength integer)
  67.     (reverse   boolean))
  68.   
  69.   (defrecord (MR_ScanTable :pointer)
  70.     (numLines integer)
  71.     (scanList longint))
  72.   
  73.   (defconstant MR_cSetVidPort     22)
  74.   (defconstant MR_cNumofCards     23)
  75.   (defconstant MR_cSetActCard     24)
  76.   (defconstant MR_cGetActCard     25)
  77.   (defconstant MR_cGetVidControls 26)
  78.   (defconstant MR_cGetOptCTab     27)
  79.   (defconstant MR_cUploadITab     28)
  80.   (defconstant MR_cCopyVideo      29)
  81.   (defconstant MR_cStopVideo      30)
  82.   (defconstant MR_cSetMaskPort    32)
  83.   (defconstant MR_cSetVid2Port    33)
  84.   (defconstant MR_cCpy2Videos     34)
  85.   (defconstant MR_cSetVidControls 35)
  86.   (defconstant MR_cVideoStatus    36)
  87.   (defconstant MR_cSetIntVector   37)
  88.   (defconstant MR_cMREffect       38)
  89.   
  90.   (defconstant MR-error-code-alist
  91.     '((-10001 . "PmapErr - CGrafPort's pixMap's pixel resolution not supported")
  92.       (-10002 . "StructErr - can't understand the CGrafPort's structure")
  93.       (-10003 . "badCardNo - trying to switch to nonexistent card")
  94.       (-10004 . "memFullErr - not enough memory")
  95.       (-10005 . "noSignal - no detectable video signal on the input(s)")
  96.       (-10006 . "noColrSrc - B/W input was specified or mixing B/W & color inputs")
  97.       (-10007 . "badres - the count value is out of range or the inverse table resolution <> 5")
  98.       (-10008 . "noGrafPort - Moonraker does not know the CGrafPort into which to xfer video")
  99.       (-10009 . "ScaleErr - a dimension of the dstRect is bigger than a dimension of the srcRect")
  100.       (-10010 . "SrcErr - srcRect inconsistent with video rect or not specified")
  101.       (-10011 . "BadFrameCnt - FrameCnt<0  or FrameCnt=0 & Offset<>0")
  102.       (-10012 . "wrongInt - requested interrupt does not exist")
  103.       (-10013 . "Wrong_Input - the input specification is not understood")
  104.       (-10014 . "Busy - board is busy & cannot respond")
  105.       ))
  106.   )
  107.  
  108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  109.  
  110. (defclass MR-vd (video-digitizer)
  111.   ((drvr-refnum     :reader      drvr-refnum
  112.                     :allocation :class)
  113.    (ref-count       :initform    0
  114.                     :allocation :class)
  115.    (use-gray-p      :initarg :use-gray-p
  116.                     :accessor use-gray-p)
  117.    (sync-on-green-p :initarg :sync-on-green-p
  118.                     :accessor sync-on-green-p)
  119.    (ctSize          :initarg :ctSize
  120.                     :reader   ctSize))
  121.   (:default-initargs
  122.     :use-gray-p      nil
  123.     :sync-on-green-p nil
  124.     :ctSize          255
  125.     :hue             #.(ash  8 12)
  126.     :saturation      #.(ash  8 12)
  127.     :contrast        #.(ash 12 12)
  128.     ))
  129.  
  130. (defmethod initialize-instance :after ((vd MR-vd) &rest initargs)
  131.   (declare (dynamic-extent initargs)
  132.            (ignore initargs))
  133.   (when (minusp (slot-value vd 'ref-count))
  134.     (setf (slot-value vd 'ref-count) 0)
  135.     (error "ref-count class slot went negative - now reset to zero")))
  136.  
  137. (defmethod vd-error-code-alist ((vd MR-vd))
  138.   (declare (ignore vd))
  139.   MR-error-code-alist)
  140.  
  141. (defmethod vd-init :before ((vd MR-vd))
  142.   (when (zerop (slot-value vd 'ref-count))
  143.     (setf (slot-value vd 'drvr-refnum) (MRvd-open-driver)))
  144.   (incf (slot-value vd 'ref-count)))
  145.  
  146. (defmethod vd-dispose :after ((vd MR-vd))
  147.   (decf (slot-value vd 'ref-count))
  148.   (when (zerop (slot-value vd 'ref-count))
  149.     (let ((refnum (slot-value vd 'drvr-refnum)))
  150.       (slot-makunbound vd 'drvr-refnum)
  151.       (trap-nz-echeck (#~CloseDriver refnum)))))
  152.  
  153. (defmethod vd-GDevice ((vd MR-vd))
  154.   (#_GetMainDevice))
  155.  
  156. (defmethod vd-max-src-rect-corners ((vd MR-vd))
  157.   (ecase (input-standard vd)
  158.     (:NTSC (values #@(0 0) #@(640 484)))
  159.     (:PAL  (values #@(0 0) #@(768 512)))))
  160.  
  161. (defmethod vd-digitizing-p ((vd MR-vd))
  162.   (and (call-next-method) (MRvd-board-busy-p vd)))
  163.  
  164. (defmethod vd-start-digitizing :after ((vd MR-vd))
  165.   (rlet ((dig-rect  :Rect
  166.                     :topLeft (dig-rect-topLeft vd)
  167.                     :botRight (dig-rect-botRight vd))
  168.          (dest-rect :Rect
  169.                     :topLeft (dest-rect-topLeft vd)
  170.                     :botRight (dest-rect-botRight vd)))
  171.     (MRvd-copy-video vd dig-rect dest-rect 0 0)))
  172.  
  173. (defmethod vd-stop-digitizing :after ((vd MR-vd))
  174.   (MRvd-stop-video vd))
  175.  
  176. (defmethod vd-grab-one-frame :after ((vd MR-vd))
  177.   (rlet ((dig-rect  :Rect
  178.                     :topLeft (dig-rect-topLeft vd)
  179.                     :botRight (dig-rect-botRight vd))
  180.          (dest-rect :Rect
  181.                     :topLeft (dest-rect-topLeft vd)
  182.                     :botRight (dest-rect-botRight vd)))
  183.     (MRvd-copy-video vd dig-rect dest-rect 0 1)))
  184.  
  185. (defmethod vd-install-settings :after ((vd MR-vd))
  186.   (MRvd-set-active-card   vd (card-num vd))
  187.   (MRvd-set-use-gray      vd (use-gray-p vd))
  188.   (MRvd-set-sync-on-green vd (sync-on-green-p vd))
  189.   (#_ActivatePalette (dest-wptr vd))
  190.   (MRvd-set-vid-port      vd (dest-wptr vd)))
  191.  
  192. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  193. ;;; set functions for video control values
  194.  
  195. ;;MoonRaker doesn't store away the various rect's so these calls don't
  196. ;;really make sense, except in the case that the board is currently
  197. ;;digitizing - you want to see the changes right away.
  198.  
  199.  
  200. ;;vd-set-src-rect
  201. ;;MoonRaker doesn't support a distinct a source & digitizer rect
  202.  
  203. (defmethod vd-set-dig-rect ((vd MR-vd) topLeft botRight)
  204.   (when (vd-digitizing-p vd)
  205.     (rlet ((dig-rect  :Rect
  206.                       :topLeft topLeft
  207.                       :botRight botRight)
  208.            (dest-rect :Rect
  209.                       :topLeft (dest-rect-topLeft vd)
  210.                       :botRight (dest-rect-botRight vd)))
  211.       (MRvd-copy-video vd dig-rect dest-rect 0 0))))
  212.  
  213. (defmethod vd-set-dest-rect ((vd MR-vd) topLeft botRight)
  214.   (when (vd-digitizing-p vd)
  215.     (rlet ((dig-rect  :Rect
  216.                       :topLeft (dig-rect-topLeft vd)
  217.                       :botRight (dig-rect-botRight vd))
  218.            (dest-rect :Rect
  219.                       :topLeft topLeft
  220.                       :botRight botRight))
  221.       (MRvd-copy-video vd dig-rect dest-rect 0 0))))
  222.  
  223. (defmethod vd-set-input-format ((vd MR-vd) format)
  224.   (MRvd-set-video-source vd format)
  225.   format)
  226.  
  227. (defmethod vd-get-input-format ((vd MR-vd))
  228.   (MRvd-get-video-source vd))
  229.  
  230. (defmethod vd-set-input-standard ((vd MR-vd) standard)
  231.   (MRvd-set-video-standard vd standard)
  232.   standard)
  233.  
  234. (defmethod vd-get-input-standard ((vd MR-vd))
  235.   (MRvd-get-video-standard vd))
  236.  
  237. (defmethod vd-set-contrast ((vd MR-vd) contrast)
  238.   (MRvd-set-contrast vd (ash contrast -12))
  239.   contrast)
  240.  
  241. ;;;;;;;;;;
  242. ;;MoonRaker uses a 0-15 range for contrast,hue,saturation
  243. ;; ash +/- 12 converts to/from the QuickTime range (0-65535)
  244.  
  245. (defmethod vd-get-contrast ((vd MR-vd))
  246.   (ash (MRvd-get-contrast vd) 12))
  247.  
  248. (defmethod vd-set-hue ((vd MR-vd) hue)
  249.   (MRvd-set-hue vd (ash hue -12))
  250.   hue)
  251.  
  252. (defmethod vd-get-hue ((vd MR-vd))
  253.   (ash (MRvd-get-hue vd) 12))
  254.  
  255. (defmethod vd-set-saturation ((vd MR-vd) saturation)
  256.   (MRvd-set-saturation vd (ash saturation -12))
  257.   saturation)
  258.  
  259. (defmethod vd-get-saturation ((vd MR-vd))
  260.   (ash (MRvd-get-saturation vd) 12))
  261.  
  262.  
  263. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  264. ;;MR specific settings
  265.  
  266. (defmethod (setf sync-on-green-p) :after (new-sync-on-green (vd MR-vd))
  267.   (when (vd-digitizing-p vd)
  268.     (MRvd-set-sync-on-green vd new-sync-on-green)))
  269.  
  270. (defmethod (setf use-gray-p) :after (new-use-gray (vd MR-vd))
  271.   (when (vd-digitizing-p vd)
  272.     (MRvd-set-use-gray vd new-use-gray)))
  273.  
  274. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  275. ;; MR functions
  276.  
  277. (defun MRvd-open-driver ()
  278. ;opens the MoonRaker driver and returns its refNum
  279.   (with-pstrs ((MR-drvr-name_p ".MOONRAKER"))
  280.     (rlet ((refNum_p :integer))
  281.       (unless (zerop (#~OpenDriver MR-drvr-name_p refNum_p))
  282.         (error "Unable to open MoonRaker driver.~%Make sure the WTI-VideoMgr init is installed."))
  283.       (%get-signed-word refNum_p))))
  284.  
  285.  
  286. (defmethod MRvd-set-vid-port ((vd MR-vd) cPort)
  287. ;sets the CGrafPtr the MR board uses. Needs to be called whenever changes to
  288. ;the color window which contains the MR-video-view changes. e.g. new color table,
  289. ;repositioning, new clip region, etc. Note: it causes digitizing to stop
  290.   (rlet ((csParamPtr :MRCsParam
  291.                      :ptr cPort))
  292.       (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cSetVidPort csParamPtr))))
  293.  
  294.  
  295. (defmethod MRvd-number-of-cards ((vd MR-vd)) ()
  296. ;returns the number of MR cards (#1 in the lowest numbered slot, ...)
  297.   (rlet ((card-count_p :integer)
  298.          (csParamPtr :MRCsParam
  299.                      :ptr card-count_p))
  300.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cNumofCards csParamPtr))
  301.     (%get-signed-word card-count_p)))
  302.  
  303.  
  304. (defmethod MRvd-set-active-card ((vd MR-vd) active-card-num)
  305. ;sets the card the MR driver is using
  306.   (rlet ((csParamPtr :MRCsParam
  307.                      :sv2-in1 active-card-num))
  308.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cSetActCard csParamPtr))))
  309.  
  310. (defmethod MRvd-get-active-card ((vd MR-vd) )
  311. ;sets the card the MR driver is using
  312.   (rlet ((active-card-num_p :integer)
  313.          (csParamPtr :MRCsParam
  314.                      :ptr active-card-num_p))
  315.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cGetActCard csParamPtr))
  316.     (%get-signed-word active-card-num_p)))
  317.  
  318.  
  319. (defmethod MRvd-get-opt-ctab ((vd MR-vd) color-table_h)
  320.   (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cGetOptCTab color-table_h)))
  321.  
  322.  
  323. (defmethod MRvd-optimize-colors ((vd MR-vd))
  324.   ;;assumes the destination CGrafPort is current & it's window is selected
  325.   (with-slots (dest-wptr ctSize) vd
  326.     (let ((on-p (vd-digitizing-p vd)))
  327.       (when on-p (vd-stop-digitizing vd))
  328.  
  329.       (with-macptrs ((color-table_h (#_NewHandle (+ (* (rlength :ColorSpec) (1+ ctSize)) 8)))
  330.                      (palette_h (#_GetPalette dest-wptr)))
  331.         (when (%null-ptr-p color-table_h)
  332.           (error "unable to allocate color table (ctSize = ~a)" ctSize))
  333.  
  334.         (unwind-protect
  335.           (progn
  336.             (hset color-table_h :ColorTable.ctSize ctSize)
  337.             (with-dereferenced-handles ((color-table_p color-table_h))
  338.               (with-macptrs ((ctTable (pref color-table_p :ColorTable.ctTable)))
  339.                 
  340.                 (if (MRvd-get-use-gray vd)
  341.                   ;;if use gray mode - hand calculate the optimal color table
  342.                   (with-macptrs ((color-spec ctTable))
  343.                     (dotimes (i (1+ ctSize))
  344.                       (pset color-spec :colorSpec.value i)
  345.                       (let ((rgb-val (ash (- 255 i) 8)))
  346.                         (pset color-spec :colorSpec.rgb.red   rgb-val)
  347.                         (pset color-spec :colorSpec.rgb.green rgb-val)
  348.                         (pset color-spec :colorSpec.rgb.blue  rgb-val))
  349.                       (%incf-ptr color-spec (rlength :ColorSpec))))
  350.                   ;; else, color mode - MoonRaker computes optimal color table via get-opt-ctab
  351.                   (with-macptrs ((last-color-spec (%inc-ptr ctTable (* (rlength :ColorSpec) ctSize))))
  352.                     (MRvd-get-opt-ctab vd color-table_h)
  353.                     ;; set last color table entry to green (used by text overlay function)
  354.                     (pset last-color-spec :colorSpec.rgb.red   16384)
  355.                     (pset last-color-spec :colorSpec.rgb.green #xFFFF)
  356.                     (pset last-color-spec :colorSpec.rgb.blue  10000)))))
  357.             
  358.             (when (%null-ptr-p palette_h)
  359.               (%setf-macptr palette_h (#_NewPalette (1+ ctSize) color-table_h #.#$pmTolerant 0))
  360.               (when (%null-ptr-p palette_h)
  361.                 (error "unable to allocate new palette (~a entries)" (1+ ctSize)))
  362.               (#_SetPalette dest-wptr palette_h t))
  363.  
  364.             (#_CTab2Palette color-table_h palette_h #.#$pmTolerant 0))
  365.  
  366.           (#_DisposeHandle color-table_h))
  367.  
  368.         (when on-p
  369.           (#_ActivatePalette dest-wptr)
  370.           (MRvd-set-vid-port vd dest-wptr)
  371.           (vd-start-digitizing vd))))))
  372.  
  373.  
  374. (defmethod MRvd-upload-itable ((vd MR-vd) inverse-table_h)
  375.   (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cUploadITab inverse-table_h)))
  376.  
  377.  
  378. (defmethod MRvd-copy-video ((vd MR-vd) dig-rect dest-rect offset frame-count)
  379. ;start digitizing video from scr-rect into dest-rect. Frame-count specifies
  380. ;how many frames to digitize (0 for continuous). Offset can be used along with
  381. ;a non-zero frame-count capture video sequences in Mac memory at successive
  382. ;offsets in the CGRapPort's portPix.
  383.   (rlet ((csParamPtr :MRCsParam
  384.                      :cc-src  dig-rect
  385.                      :cc-dst  dest-rect
  386.                      :cc-offs offset
  387.                      :cc-fcnt frame-count))
  388.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cCopyVideo csParamPtr))))
  389.  
  390.  
  391. (defmethod MRvd-stop-video ((vd MR-vd) )
  392. ;stops a continuous video stream started by copy-video
  393.   (rletz ((csParamPtr :MRCsParam))
  394.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cStopVideo csParamPtr))))
  395.  
  396.  
  397. (defmethod MRvd-set-mask-port ((vd MR-vd) )
  398. ;make the masking GrafPort the current port
  399.   (rletz ((csParamPtr :MRCsParam))
  400.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cSetMaskPort csParamPtr))))
  401.  
  402.  
  403. (defmethod MRvd-set-vid-controls ((vd MR-vd) control-record)
  404. ;set the MR control values. (stored in non-volatile RAM)
  405.   (rlet ((csParamPtr :MRCsParam
  406.                      :ptr control-record))
  407.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cSetVidControls csParamPtr))))
  408.  
  409.  
  410. (defmethod MRvd-get-vid-controls ((vd MR-vd) control-record)
  411. ;fills the supplied control-record with the current MR control values
  412.   (rlet ((csParamPtr :MRCsParam
  413.                      :ptr control-record))
  414.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cGetVidControls csParamPtr))))
  415.  
  416.  
  417. (defmethod MRvd-get-video-status ((vd MR-vd) status-record)
  418. ;fills the supplied status-record with the current MR status values
  419.   (rlet ((csParamPtr :MRCsParam
  420.                      :ptr status-record))
  421.     (vd-nz-error-check vd (#~Control (drvr-refnum vd) MR_cVideoStatus csParamPtr))))
  422.  
  423.  
  424. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  425. ;;; predicate functions for individual control values
  426.  
  427. (defmethod MRvd-set-use-gray ((vd MR-vd) use-gray-p)
  428.   (rlet ((control-record :MR_TheMRCtl))
  429.     (MRvd-get-vid-controls vd control-record)
  430.     (pset control-record :MR_theMRCtl.useGray use-gray-p)
  431.     (MRvd-set-vid-controls vd control-record))
  432.   use-gray-p)
  433.  
  434. (defmethod MRvd-get-use-gray ((vd MR-vd))
  435.   (rlet ((control-record :MR_TheMRCtl))
  436.     (MRvd-get-vid-controls vd control-record)
  437.     (pref control-record :MR_TheMRCtl.useGray)))
  438.  
  439. (defmethod MRvd-set-video-standard ((vd MR-vd) standard)
  440.   (rlet ((control-record :MR_TheMRCtl))
  441.     (MRvd-get-vid-controls vd control-record)
  442.     (pset control-record :MR_theMRCtl.videoStd (ecase standard (:NTSC t) (:PAL nil)))
  443.     (MRvd-set-vid-controls vd control-record))
  444.   standard)
  445.  
  446. (defmethod MRvd-get-video-standard ((vd MR-vd))
  447.   (rlet ((control-record :MR_TheMRCtl))
  448.     (MRvd-get-vid-controls vd control-record)
  449.     (if (pref control-record :MR_TheMRCtl.videoStd) :NTSC :PAL)))
  450.  
  451. (defmethod MRvd-set-video-source ((vd MR-vd) format)
  452.   (rlet ((control-record :MR_TheMRCtl))
  453.     (MRvd-get-vid-controls vd control-record)
  454.     (pset control-record :MR_theMRCtl.videoSource
  455.           (ecase format (:RGB 0) (:RGB1 0) (:RGB2 1) (:s-video 2) (:composite 3)))
  456.     (MRvd-set-vid-controls vd control-record))
  457.   format)
  458.  
  459. (defmethod MRvd-get-video-source ((vd MR-vd))
  460.   (rlet ((control-record :MR_TheMRCtl))
  461.     (MRvd-get-vid-controls vd control-record)
  462.     (ecase (pref control-record :MR_TheMRCtl.videoSource)
  463.            (0 :RGB1)
  464.            (1 :RGB2)
  465.            (2 :s-video)
  466.            (3 :composite))))
  467.  
  468. (defmethod MRvd-set-sync-on-green ((vd MR-vd) sync-on-green-p)
  469.   (ecase (input-format vd)
  470.     ((:RGB1 :RGB2)
  471.      (rlet ((control-record :MR_TheMRCtl))
  472.        (MRvd-get-vid-controls vd control-record)
  473.        (pset control-record :MR_theMRCtl.SyncOnGreen sync-on-green-p)
  474.        (MRvd-set-vid-controls vd control-record)))
  475.     ((:S-Video :Composite)
  476.      (when sync-on-green-p (error "Sync-on-green requires RGB input"))))
  477.   sync-on-green-p)
  478.  
  479. (defmethod MRvd-get-sync-on-green ((vd MR-vd))
  480.   (rlet ((control-record :MR_TheMRCtl))
  481.     (MRvd-get-vid-controls vd control-record)
  482.     (pref control-record :MR_TheMRCtl.syncOnGreen)))
  483.  
  484. ;;;;;;;;;;
  485. ;;MoonRaker uses a 0-15 range for contrast,hue,saturation
  486.  
  487. (defmethod MRvd-set-contrast ((vd MR-vd) contrast)
  488.   (rlet ((control-record :MR_TheMRCtl))
  489.     (MRvd-get-vid-controls vd control-record)
  490.     (pset control-record :MR_theMRCtl.contrast contrast)
  491.     (MRvd-set-vid-controls vd control-record))
  492.   contrast)
  493.  
  494. (defmethod MRvd-get-contrast ((vd MR-vd))
  495.   (rlet ((control-record :MR_TheMRCtl))
  496.     (MRvd-get-vid-controls vd control-record)
  497.     (pref control-record :MR_TheMRCtl.contrast)))
  498.  
  499. (defmethod MRvd-set-hue ((vd MR-vd) hue)
  500.   (rlet ((control-record :MR_TheMRCtl))
  501.     (MRvd-get-vid-controls vd control-record)
  502.     (pset control-record :MR_theMRCtl.hue hue)
  503.     (MRvd-set-vid-controls vd control-record))
  504.   hue)
  505.  
  506. (defmethod MRvd-get-hue ((vd MR-vd))
  507.   (rlet ((control-record :MR_TheMRCtl))
  508.     (MRvd-get-vid-controls vd control-record)
  509.     (pref control-record :MR_TheMRCtl.hue)))
  510.  
  511. (defmethod MRvd-set-saturation ((vd MR-vd) saturation)
  512.   (rlet ((control-record :MR_TheMRCtl))
  513.     (MRvd-get-vid-controls vd control-record)
  514.     (pset control-record :MR_theMRCtl.saturation saturation)
  515.     (MRvd-set-vid-controls vd control-record))
  516.   saturation)
  517.  
  518. (defmethod MRvd-get-saturation ((vd MR-vd))
  519.   (rlet ((control-record :MR_TheMRCtl))
  520.     (MRvd-get-vid-controls vd control-record)
  521.     (pref control-record :MR_TheMRCtl.saturation)))
  522.  
  523.  
  524. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  525. ;;; predicate functions for individual status values
  526.  
  527. (defmethod MRvd-signal-there-p ((vd MR-vd))
  528.   (rlet ((status-record :MR_Status))
  529.     (MRvd-get-video-status vd status-record)
  530.     (pref status-record :MR_Status.signalThere)))
  531.  
  532. (defmethod MRvd-board-busy-p ((vd MR-vd))
  533.   (rlet ((status-record :MR_Status))
  534.     (MRvd-get-video-status vd status-record)
  535.     (pref status-record :MR_Status.boardBusy)))
  536.  
  537. (defmethod MRvd-odd-field-p ((vd MR-vd))
  538.   (rlet ((status-record :MR_Status))
  539.     (MRvd-get-video-status vd status-record)
  540.     (pref status-record :MR_Status.oddField)))
  541.  
  542. (defmethod MRvd-has-converter-p ((vd MR-vd))
  543.   (rlet ((status-record :MR_Status))
  544.     (MRvd-get-video-status vd status-record)
  545.     (pref status-record :MR_Status.hasConverter)))
  546.  
  547. (defmethod MRvd-has-audio-p ((vd MR-vd))
  548.   (rlet ((status-record :MR_Status))
  549.     (MRvd-get-video-status vd status-record)
  550.     (pref status-record :MR_Status.hasAudio)))
  551.  
  552. (defmethod MRvd-get-slot ((vd MR-vd))
  553.   ;;slots are numbered #x9 to #xE (see IM V - Device Mgr)
  554.   (rlet ((status-record :MR_Status))
  555.     (MRvd-get-video-status vd status-record)
  556.     (pref status-record :MR_Status.slot)))
  557.  
  558. #|
  559.  
  560. ;; a modest example - which currently illustrate a bug in the MR driver.
  561. ;; the left two video are incorrectly clipped.
  562.  
  563. (oou-dependencies :video-digitizer-svm)
  564.  
  565. (defclass vview (video-digitizer-svm view) () )
  566. (defclass vsview (video-digitizer-svm simple-view) () )
  567.  
  568. (progn
  569.   (defvar *MR-test-w*)
  570.   (setf *MR-test-w*
  571.         (make-instance 'window
  572.                        :window-type :document
  573.                        :view-position #@(10 40)
  574.                        :view-size #@(400 200)
  575.                        :window-title "video demo"
  576.                        :color-p t
  577.                        ))
  578.   
  579.   (add-subviews *MR-test-w* (make-instance 'view
  580.                                         :view-position #@(20 20)
  581.                                         :view-size #@(345 175)                  
  582.                                         :view-nick-name :v
  583.                                         ))
  584.   
  585.   (add-subviews (view-named :v *MR-test-w*) (make-instance 'vview
  586.                                                         :view-position #@(20 5)
  587.                                                         :view-size #@(100 150)                  
  588.                                                         :view-nick-name :vview
  589.                                                         :digitizer-class 'mr-vd
  590.                                                         ))
  591.   (add-subviews (view-named :v *MR-test-w*) (make-instance 'vsview
  592.                                                         :view-position #@(130 5)
  593.                                                         :view-size #@(100 150)                  
  594.                                                         :view-nick-name :vview2
  595.                                                         :digitizer-class 'mr-vd
  596.                                                         ))
  597.   (add-subviews *MR-test-w* (make-instance 'vsview
  598.                                         :view-position #@(260 25)
  599.                                         :view-size #@(100 150)                  
  600.                                         :view-nick-name :vview3
  601.                                         :digitizer-class 'mr-vd
  602.                                         )))
  603.  
  604. (let* ((v (view-named :vview (view-named :v *MR-test-w*)))
  605.        (v2 (view-named :vview2 (view-named :v *MR-test-w*)))
  606.        (v3 (view-named :vview3 *MR-test-w*)))
  607.   (grab-one-frame v)
  608.   (grab-one-frame v2)
  609.   (grab-one-frame v3))
  610.  
  611. (start-digitizing (view-named :vview3 *MR-test-w*))
  612.   
  613. (stop-digitizing (view-named :vview3 *MR-test-w*))
  614.  
  615. |#