;;;; canvas.lisp

(in-package #:wheelwork)

(defclass/std pixels ()
  ((pixel-width pixel-height  :std (error "pixel-width and pixel-height are required"))
   (data :a :with :doc "Array of RGBA data representing an image of pixel-width X pixel-height")))

(defmethod initialize-instance :after ((pixels pixels) &key)
  (with-slots (pixel-width pixel-height data) pixels
    (setf data  (make-array (* pixel-height pixel-height 4)
                            :element-type 'unsigned-byte
                            :initial-element 255))))

(let ((cached-pixel))
  (defun pixel (pixels x y &optional (use-cached t))
    "When USE-CACHED is NIL, return a fresh array displaced to
     PIXELS. Otherwise, PIXEL resets the offset on an internal
     displaced array and returns it.

     I.E. If you are are wanting to manipulate more than one pixel at
     a time, you should get those pixels with USE-CACHED set to NIL."
    (with-slots (pixel-width pixel-height data) pixels 
      (cond
        ((and use-cached cached-pixel)
         (adjust-array cached-pixel 4
                       :displaced-to data
                       :displaced-index-offset (* 4 (+ x (* pixel-width y)))))
        (use-cached
         (setf cached-pixel
               (make-array 4
                           :displaced-to data
                           :displaced-index-offset (* 4 (+ x (* pixel-width y))))))
        (t
         (make-array 4
                     :displaced-to data
                     :displaced-index-offset (* 4 (+ x (* pixel-width y)))))))))

(defmacro with-pixel ((r g b a) pixel &body body)
  "R G B and A are symbols that hold the components of the pixel being
  manipulated for this operation. 

  PIXEL is any form that evaluates to a 4 element array of unsigned bytes"
  (let ((pixel-var
          (gensym)))
    `(let ((,pixel-var ,pixel))
       (symbol-macrolet ((,r (aref ,pixel-var 0))
                         (,g (aref ,pixel-var 1))
                         (,b (aref ,pixel-var 2))
                         (,a (aref ,pixel-var 3)))
         ,@body))))

(defun pixel-offset (x y pixels)
  (* 4 (+ x (* y (pixel-width pixels)))))

(defmacro with-pixels-rect ((x y r g b a) (pixels &key left right top bottom) &body body)
  "Executes BODY on all pixels in the box bounded by LEFT RIGHT TOP and BOTTOM of PIXELS.
   If the any bound is NIL then its minimum (left and bottom) or
   maximum (right and top) value is assumed. 

   Pixels is any expression that evaluates to an instance of PIXELS."
  (with-gensyms (pxs px lv rv tv bv)
    `(let* ((,pxs ,pixels)
            (,px (make-array 4 :displaced-to (pixels-data ,pxs) :displaced-index-offset 0))
            (,lv ,left)
            (,rv ,right)
            (,tv ,top)
            (,bv ,bottom))
       (symbol-macrolet ((,r (aref ,px 0))
                         (,g (aref ,px 1))
                         (,b (aref ,px 2))
                         (,a (aref ,px 3)))
         (loop for ,x from (if ,lv ,lv 0) below (if ,rv ,rv (pixel-width ,pxs)) do
           (loop for ,y from (if ,bv ,bv 0) below (if ,tv ,tv (pixel-height ,pxs))
                 do (progn
                      (setf  ,px (adjust-array ,px 4
                                               :displaced-to (pixels-data ,pxs)
                                               :displaced-index-offset (pixel-offset ,x ,y ,pxs)))
                      ,@body)))))))

(defmacro with-pixels-line ((x y r g b a) (pixels start-x start-y end-x end-y) &body body)
  "A convenience macro for doing something to a whole line of pixels -
e.g., drawing a line in a particular color."
  (let ((pxs (gensym))) 
    `(let ((,pxs ,pixels))
       (with-line (,x ,y) (,start-x ,start-y) (,end-x ,end-y)
         (with-pixel (,r ,g ,b ,a) (pixel ,pxs ,x ,y) ,@body)))))


(defvar *canvas-shader-program* nil)
(defvar *canvas-render-vao* nil)
(defvar *canvas-count* 0)

(defun canvas-finalizer ()
  (decf *canvas-count*)
  (unless (plusp *canvas-count*)
    (when *canvas-render-vao*
      (gl:delete-vertex-arrays (list *canvas-render-vao*)))
    (when *canvas-shader-program*
      (gl:delete-program *canvas-shader-program*))
    (setf-many *canvas-fbo-vao*
               *canvas-render-vao*
               *canvas-shader-program*
               nil)))


(defun make-shared-canvas-render-objects ()
  (setf
   ;; compile shader program
   *canvas-shader-program*
   (create-shader
    '(:vertex
      ((vert :vec2))
      ((transform :mat4))
      ((values
        (* transform (vari:vec4 vert 0.0 1.0))
        vert)))
    '(:fragment
      ((tc :vec2))
      ((tex :sampler-2d))
      ((let ((frag (vari:texture tex tc)))
         frag))))
   ;; allocate vertex array
   *canvas-render-vao*
   (gl:gen-vertex-array))

  (gl:program-uniformi
   *canvas-shader-program*
   (gl:get-uniform-location *canvas-shader-program* "TEX")
   0)

  (gl:bind-vertex-array *canvas-render-vao*)
  (let ((vbo (gl:gen-buffer)))
    (with-gl-array (verts :float
                    0.0 1.0 
                    1.0 0.0 
                    0.0 0.0 
                    
                    0.0 1.0 
                    1.0 1.0 
                    1.0 0.0 )
      (gl:bind-buffer :array-buffer vbo)
      (gl:buffer-data :array-buffer :static-draw verts)))
  (gl:enable-vertex-attrib-array 0)
  (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0)
  (gl:bind-buffer :array-buffer 0)
  (gl:bind-vertex-array 0))

(defclass/std canvas (affine interactive pixels)
  ((fbo :with :r :doc "framebuffer object for use in off-screen-rendering of this canvas to a texture")
   (texture :with :a :doc "texture instance")))

(defmethod cleanup ((canvas canvas))
  (cleanup (canvas-texture canvas))
  (gl:delete-framebuffers (list (canvas-fbo canvas)))
  (canvas-finalizer))

(defmethod initialize-instance :after ((canvas canvas) &key)
  (unless *canvas-shader-program*
    (make-shared-canvas-render-objects))
  (incf *canvas-count*)
  (trivial-garbage:finalize canvas #'canvas-finalizer)
  (with-slots (texture fbo base-width base-height) canvas
    (setf texture   (make-instance
                     'texture
                     :width (pixel-width canvas)
                     :height (pixel-height canvas))
          fbo       (gl:gen-framebuffer)
          base-width (pixel-width canvas)
          base-height (pixel-height canvas))
    (gl:bind-framebuffer :framebuffer fbo)
    (with-slots
          (width height id  min-filter mag-filter internal-format image-format)
        texture
      (setf id (gl:gen-texture)
            width (pixel-width canvas)
            height (pixel-height canvas))
      (gl:bind-texture :texture-2d id)
      (gl:tex-parameter :texture-2d :texture-min-filter min-filter)
      (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter)
      (gl:tex-image-2d :texture-2d
                       0
                       internal-format
                       width
                       height
                       0
                       image-format
                       :unsigned-byte
                       (pixels-data canvas)))
    (gl:framebuffer-texture-2d
     :framebuffer
     :color-attachment0
     :texture-2d
     (texture-id texture)
     0)
                                        ; (gl:bind-texture :texture-2d 0)
    (gl:bind-framebuffer :framebuffer 0)))

(defun blit (canvas)
  "Blits a canvas to the its texture"
  (with-slots (fbo texture data pixel-width pixel-height) canvas
    (gl:bind-framebuffer :framebuffer fbo)
    (gl:bind-texture :texture-2d (texture-id texture))
    (gl:tex-image-2d :texture-2d
                     0
                     :rgba
                     pixel-width
                     pixel-height
                     0
                     :rgba
                     :unsigned-byte
                     data)
    (gl:bind-texture :texture-2d 0)
    (gl:bind-framebuffer :framebuffer 0)))

(defmethod render ((canvas canvas))
  (with-slots (texture) canvas
    (gl:active-texture 0)
    (gl:bind-texture :texture-2d (texture-id texture))
    (gl:use-program *canvas-shader-program*)
    (gl:program-uniform-matrix-4fv
     *canvas-shader-program*
     (gl:get-uniform-location *canvas-shader-program* "TRANSFORM")
     (projected-matrix canvas))
    (gl:bind-vertex-array *canvas-render-vao*)    
    (gl:draw-arrays :triangles 0 6)
    (gl:bind-vertex-array 0)))