aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-07-15 16:35:06 -0500
committerColin Okay <colin@cicadas.surf>2022-07-15 16:35:06 -0500
commitb70a404c640785010ecad52af29b4a96184b2c7e (patch)
tree939b271a963786e649eb0fc1c8aa7e640eb4c89f
parentf2f49f3beae4fb62292e9a80e7ddda64de098771 (diff)
[add] working canvas demo!
-rw-r--r--examples/10-canvas.lisp47
-rw-r--r--src/gl/texture.lisp2
-rw-r--r--src/interactive/bitmap.lisp2
-rw-r--r--src/interactive/canvas.lisp227
-rw-r--r--src/package.lisp2
-rw-r--r--wheelwork-examples.asd3
-rw-r--r--wheelwork.asd3
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")))