video.lisp

(in-package #:org.shirakumo.fraf.trial)

(defclass video ()
  ((generator :initarg :generator :accessor generator)))

;; (defgeneric width (video))
;; (defgeneric height (video))
;; (defgeneric update (video dt tt fc))
;; (defgeneric clock (video))
(defgeneric duration (video))
(defgeneric seek (video to))
(defgeneric done-p (video))
(defgeneric framerate (video))

(defmethod resource ((video video) name)
  (resource (generator video) name))

;;; YUV video only for now.
(define-shader-entity video-display (vertex-entity)
  ((textures :initform NIL :accessor textures)
   (asset :initarg :asset :initform NIL)
   (video :accessor video)))

(defmethod shared-initialize :after ((entity video-display) slots &key video)
  (when video (setf (video entity) video)))

(defmethod (setf video) :after ((video video) (entity video-display))
  (setf (textures entity) (list (resource video :y) (resource video :u) (resource video :v)))
  (setf (vertex-array entity) (resource video :mesh)))

(defmethod stage :after ((entity video-display) (area staging-area))
  (when (slot-value entity 'asset)
    (register-load-observer area entity (slot-value entity 'asset))
    (stage (slot-value entity 'asset) area))
  (stage (textures entity) area))

(defmethod observe-load-state ((entity video-display) asset (state (eql :loaded)) (area staging-area))
  (setf (video entity) (video asset))
  (restage entity area))

(defmethod bind-textures :after ((entity video-display))
  (destructuring-bind (y u v) (textures entity)
    (bind y :texture0)
    (bind u :texture1)
    (bind v :texture2)))

(defmethod render :before ((entity video-display) (program shader-program))
  (setf (uniform program "Y_plane") 0)
  (setf (uniform program "U_plane") 1)
  (setf (uniform program "V_plane") 2))

(defmethod clock ((entity video-display))
  (clock (video entity)))

(defmethod duration ((entity video-display))
  (duration (video entity)))

(defmethod seek ((entity video-display) to)
  (seek (video entity) to))

(defmethod done-p ((entity video-display))
  (done-p (video entity)))

(define-class-shader (video-display :vertex-shader)
  "layout (location = TRIAL_V_UV) in vec2 in_uv;
out vec2 uv;

void main(){
  maybe_call_next_method();
  uv = in_uv;
}")

(define-class-shader (video-display :fragment-shader)
  "in vec2 uv;
out vec4 color;
uniform sampler2D Y_plane, U_plane, V_plane;
void main() {
  vec3 yuv = vec3(texture(Y_plane, vec2(uv.x, 1-uv.y)).r - 0.0625,
                  texture(U_plane, vec2(uv.x, 1-uv.y)).r - 0.5,
                  texture(V_plane, vec2(uv.x, 1-uv.y)).r - 0.5);
  vec3 rgb = vec3(dot(yuv, vec3(+1.164, +0.000, +1.793)),
                  dot(yuv, vec3(+1.164, -0.213, -0.533)),
                  dot(yuv, vec3(+1.164, +2.112, +0.000)));
  color = vec4(rgb, 1.0);
}")

(define-shader-entity video-player (video-display listener)
  ((state :initarg :state :initform :paused :accessor state)
   (loop-p :initform NIL :accessor loop-p)))

(define-handler ((entity video-player) tick) (tt dt fc)
  (when (eql :playing (state entity))
    (update (video entity) tt dt fc)
    (when (done-p entity)
      (typecase (loop-p entity)
        (integer
         (if (<= 0 (decf (loop-p entity)))
             (seek entity 0.0)
             (setf (state entity) :paused)))
        (null
         (setf (state entity) :paused))
        (T
         (seek entity 0.0))))))