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-players / Pioneer-vp.lisp < prev    next >
Encoding:
Text File  |  1992-02-06  |  7.8 KB  |  232 lines
  1. (in-package :oou)
  2. (oou-provide :Pioneer-vp)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; Pioneer-vp.lisp
  5. ;;
  6. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; video player class for controling Pioneer laserdisc players
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :video-player
  15.                   :serial-port
  16.                   :Pioneer-u
  17.                   )
  18.  
  19. (export '(Pioneer-vp))
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. (defclass Pioneer-vp (serial-port video-player)
  24.   ((disk-format :reader disk-format))
  25.   (:default-initargs
  26.     :open-on-init-p nil))
  27.  
  28. (defmethod initialize-instance ((vp Pioneer-vp) &rest initargs &key model)
  29.   ;this method exists solely to allow the :model keyword to be passed in from
  30.   ;Pioneer-player-info plists
  31.   (declare (ignore initargs model))
  32.   (call-next-method))
  33.  
  34. (defmethod vp-init :after ((vp Pioneer-vp))
  35.   (sport-open vp :flush-p nil))
  36.  
  37. (defmethod vp-dispose :after ((vp Pioneer-vp))
  38.   (sport-close vp))
  39.  
  40. (defmethod vp-load ((vp Pioneer-vp) &key)
  41.   (when (char-equal #\1 (char (pld-cmd vp "?D") 0))
  42.    (pld-cmd vp "SA")
  43.    (setf (slot-value vp 'disk-format) (pld-disk-format vp))
  44.    t))
  45.  
  46. (defmethod vp-loaded-p ((vp Pioneer-vp))
  47.   (and (slot-boundp vp 'disk-format)
  48.        (eq (disk-format vp) (pld-disk-format vp))))
  49.  
  50. (defmethod vp-max-frame ((vp Pioneer-vp))
  51.   (ecase (disk-format vp)
  52.     (:CAV   65535)
  53.     (:CLV   863970)
  54.     (:CLV-E 863970)))
  55.  
  56. (defmethod vp-min-frame ((vp Pioneer-vp))
  57.   0)
  58.  
  59. (defmethod vp-current-frame ((vp Pioneer-vp))
  60.   (flet ((parse-int (frame-str)
  61.            ;sometimes address strings are returned as "<00000" or ">XXXXXX"
  62.            ;which I assume means your at the extreme addresses of the disk
  63.            ;The Pioneer manuals don't document this feature.
  64.            ;This fn safely handles these cases.
  65.            (parse-integer frame-str
  66.                           :start (if (digit-char-p (char frame-str 0)) 0 1))))
  67.   (ecase (pld-address-format vp (disk-format vp))
  68.     (:frame   (parse-int (pld-cmd vp "FR?F")))
  69.     (:hmmss   (hmmss-to-frame (parse-int (pld-cmd vp "TM?T"))))
  70.     (:hmmssff (hmmssff-to-frame (parse-int (pld-cmd vp "FR?F")))))))
  71.  
  72. (defmethod vp-seek ((vp Pioneer-vp) frame &key &allow-other-keys)
  73.   (pld-cmd vp "SE" :frame frame)
  74.   t)
  75.  
  76. (defmethod vp-play ((vp Pioneer-vp))
  77.   (if (frame-limit-p vp)
  78.     (pld-cmd vp "SM" :frame (max-frame-limit vp))
  79.     (pld-cmd vp "CL"))
  80.   (pld-cmd vp "PL")
  81.   t)
  82.  
  83. (defmethod vp-stop ((vp Pioneer-vp))
  84.   (pld-cmd vp "PA")
  85.   t)
  86.  
  87. (defmethod vp-freeze ((vp Pioneer-vp))
  88.   (pld-cmd vp "ST")
  89.   t)
  90.  
  91. (defmethod vp-step ((vp Pioneer-vp) direction)
  92.   (pld-cmd vp (ecase direction (:forward "SF") (:reverse "SR")))
  93.   t)
  94.  
  95. (defmethod vp-scan ((vp Pioneer-vp) direction speed-x)
  96.   (let ((speed (max (min (* speed-x  60) 255) 1)))
  97.     (ecase direction
  98.       (:forward
  99.        (if (frame-limit-p vp)
  100.          (pld-cmd vp "SM" :frame (max-frame-limit vp))
  101.          (pld-cmd vp "CL"))
  102.        (pld-cmd vp "SPMF" :arg speed))
  103.       (:reverse
  104.        (if (frame-limit-p vp)
  105.          (pld-cmd vp "SM" :frame (min-frame-limit vp))
  106.          (pld-cmd vp "CL"))
  107.        (pld-cmd vp "SPMR" :arg speed))))
  108.   t)
  109.  
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111.  
  112. (defgeneric pld-address-format (vp disk-format))
  113.  
  114. (defmethod pld-disk-format ((vp Pioneer-vp))
  115.   (let ((response (pld-cmd vp "?D")))
  116.     (if (char-equal #\1 (char response 0))
  117.       (ecase (char response 1)
  118.         (#\0 :CAV)
  119.         (#\1 (ecase (char (pld-cmd vp "FR" :error-p nil) 0)
  120.                (#\R :CLV-E)
  121.                (#\E :CLV)))
  122.         (#\X :unknown))
  123.       :no-disk)))
  124.  
  125. (defmethod pld-address ((vp Pioneer-vp) frame disk-format)
  126.   (setf frame (min (max frame 0) (vp-max-frame vp)))
  127.   (ecase (pld-address-format vp disk-format)
  128.     (:frame   (values frame                    :FR))
  129.     (:hmmss   (values (frame-to-hmmss frame)   :TM))
  130.     (:hmmssff (values (frame-to-hmmssff frame) :FR))))
  131.  
  132.  
  133. (defmethod pld-cmd ((vp Pioneer-vp) code-string
  134.                     &key
  135.                     (arg "")
  136.                     (frame nil)
  137.                     (response-p t)
  138.                     (error-p t)
  139.                     (flush-p t))
  140.   (let ((cmd-string (if frame
  141.                       (multiple-value-bind (addr fmt) (pld-address vp frame (disk-format vp))
  142.                         (format nil "~a~a~a" fmt addr code-string))
  143.                       (format nil "~a~a" arg code-string))))
  144.     (when (or flush-p response-p) (pld-flush vp))
  145.     (sport-write-line vp cmd-string)
  146.     (when response-p
  147.       (let ((response (pld-read vp :wait-p t)))
  148.         (when (char-equal #\E (char response 0))
  149.           (when error-p (error "~a : Pioneer error code ~a" cmd-string response)))
  150.         response))))
  151.  
  152. (defmethod pld-read ((vp Pioneer-vp) &key (wait-p nil))
  153.   (multiple-value-bind (str eoln-p) (sport-read-line vp :wait-p wait-p)
  154.     (if eoln-p str (error "partial response (~s) read" str))))
  155.  
  156. (defmethod pld-flush ((vp Pioneer-vp))
  157.   (sport-flush vp))
  158.  
  159. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  160.  
  161. #|
  162. ;a modest example - primative video controller for a Pioneer 8000
  163.  
  164. (oou-dependencies :P8000-vp)
  165.  
  166. (defparameter *vp*
  167.   (make-instance
  168.    'P8000-vp
  169.    :framehook-fn
  170.    #'(lambda (frame)
  171.        (set-dialog-item-text (view-named :cur-frame *w*) (princ-to-string frame)))
  172.    ))
  173.  
  174. (vp-init *vp*)
  175. (vp-load *vp*)
  176.  
  177. (setf
  178.  *w*
  179.  (make-instance
  180.   'dialog
  181.   :view-size #@(360 60)
  182.   :view-subviews
  183.   `(
  184.     ,(make-instance 'button-dialog-item
  185.                     :view-size #@(30 20)
  186.                     :dialog-item-text "<<<"
  187.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-jump *vp* :reverse 500)))
  188.     ,(make-instance 'button-dialog-item
  189.                     :view-size #@(30 20)
  190.                     :dialog-item-text "<<"
  191.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-scan *vp* :reverse 4)))
  192.     ,(make-instance 'button-dialog-item
  193.                     :view-size #@(30 20)
  194.                     :dialog-item-text "|<"
  195.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-step *vp* :reverse)))
  196.     ,(make-instance 'button-dialog-item
  197.                     :view-size #@(30 20)
  198.                     :dialog-item-text "Ñ"
  199.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-stop *vp*)))
  200.     ,(make-instance 'button-dialog-item
  201.                     :view-size #@(30 20)
  202.                     :dialog-item-text ""
  203.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-freeze *vp*)))
  204.     ,(make-instance 'button-dialog-item
  205.                     :view-size #@(30 20)
  206.                     :dialog-item-text ">|"
  207.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-step *vp* :forward)))
  208.     ,(make-instance 'button-dialog-item
  209.                     :view-size #@(30 20)
  210.                     :dialog-item-text ">"
  211.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-play *vp*)))
  212.     ,(make-instance 'button-dialog-item
  213.                     :view-size #@(30 20)
  214.                     :dialog-item-text ">>"
  215.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-scan *vp* :forward 4)))
  216.     ,(make-instance 'button-dialog-item
  217.                     :view-size #@(30 20)
  218.                     :dialog-item-text ">>>"
  219.                     :dialog-item-action #'(lambda (di) (declare (ignore di)) (vp-jump *vp* :forward 500)))
  220.     ,(make-instance 'static-text-dialog-item
  221.                     :dialog-item-text "current frame number:")
  222.     ,(make-instance 'static-text-dialog-item
  223.                     :view-nick-name :cur-frame
  224.                     :view-size #@(100 20)
  225.                     :dialog-item-text "????????"))))
  226.  
  227. ;(vp-dispose *vp*)
  228.  
  229. ;(vp-limit *vp* nil nil)
  230. ;(vp-limit *vp* 1401 1500)
  231.  
  232. |#