[add] working canvas demo!

7 files changed, 282 insertions, 4 deletions

diff --git a/examples/10-canvas.lisp b/examples/10-canvas.lisp
new file mode 100644
index 0000000..cdade2b
--- /dev/null
+++ b/examples/10-canvas.lisp
@@ -0,0 +1,47 @@
+;;;; examples/10-canvas.lisp
+
+(defpackage #:ww.examples/10
+  (:use #:cl)
+  (:export #:start)
+  (:import-from #:defclass-std #:defclass/std))
+
+(in-package #:ww.examples/10)
+
+;;; CLASSES
+
+(defclass/std canvas-example (ww::application)
+  ())
+
+(defmethod ww::boot ((app canvas-example))
+  "Adds the intro text and sets up the start button handler."
+  (let ((c (make-instance
+            'ww::canvas
+            :x 100 :y 100
+            :pixel-height 100
+            :pixel-width 100)))
+    
+    (ww::with-pixels-rect (x y r g b a) (c)
+      (setf r (- 255 x)
+            g (- 255 y)
+            b (+ x y)))
+    
+    (ww::blit c)
+    ;(ww:scale-by c 100)
+    (ww:add-unit app c)))
+
+(defun start (&optional (scale 1.0))
+  (ww::start
+   (make-instance
+    'canvas-example 
+    :fps 30
+    :width (round (* 800 scale))
+    :height (round (* 600 scale))
+    :scale scale
+    :refocus-on-mousedown-p nil
+    :title "canvas demo"
+    :asset-root
+    (merge-pathnames
+     "examples/"
+     (asdf:system-source-directory :wheelwork)))))
+
+
diff --git a/src/gl/texture.lisp b/src/gl/texture.lisp
index ad753a1..0aa698f 100644
--- a/src/gl/texture.lisp
+++ b/src/gl/texture.lisp
@@ -3,7 +3,7 @@
 (in-package #:wheelwork)
 
 (defclass/std texture ()
-  ((width height id mipmap :with :r)
+  ((width height id mipmap :with :r :i)
    (internal-format image-format :ri :with :std :rgba)
    (wrap-s wrap-t :ri :with :std :repeat)
    (min-filter mag-filter :ri :with :std :nearest)))
diff --git a/src/interactive/bitmap.lisp b/src/interactive/bitmap.lisp
index 06f081e..96d8e07 100644
--- a/src/interactive/bitmap.lisp
+++ b/src/interactive/bitmap.lisp
@@ -13,7 +13,7 @@
   "executed after a bitmap has been reclaimed by gc. decrements bitmap
 count and destroys shader-program if necessary."
   (decf *bitmap-count*)
-  (when (zerop *bitmap-count*)
+  (unless (plusp *bitmap-count*)
     (when *bitmap-vao*
       (gl:delete-vertex-arrays (list *bitmap-vao*))
       (setf *bitmap-vao* nil))
diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp
new file mode 100644
index 0000000..2fa341c
--- /dev/null
+++ b/src/interactive/canvas.lisp
@@ -0,0 +1,227 @@
+;;;; 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)))
diff --git a/src/package.lisp b/src/package.lisp
index 73ff610..eef6173 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -94,6 +94,8 @@
    #:button-on-release
    #:button-up
 
+   #:canvas
+   
    #:frameset 
    #:frameset-index
    #:make-frameset
diff --git a/wheelwork-examples.asd b/wheelwork-examples.asd
index 9680e85..80fd4a6 100644
--- a/wheelwork-examples.asd
+++ b/wheelwork-examples.asd
@@ -14,4 +14,5 @@
                (:file "06-sprite")
                (:file "07-renderarea")
                (:file "08-pong")
-               (:file "09-ghoulspree")))
+               (:file "09-ghoulspree")
+               (:file "10-canvas")))
diff --git a/wheelwork.asd b/wheelwork.asd
index 095c949..06fa686 100644
--- a/wheelwork.asd
+++ b/wheelwork.asd
@@ -40,6 +40,7 @@
                              (:file "text")
                              (:file "button")
                              (:file "frameset")
-                             (:file "sprite")))
+                             (:file "sprite")
+                             (:file "canvas")))
                (:file "application")
                (:file "wheelwork")))