From b70a404c640785010ecad52af29b4a96184b2c7e Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Fri, 15 Jul 2022 16:35:06 -0500 Subject: [add] working canvas demo! --- examples/10-canvas.lisp | 47 +++++++++ src/gl/texture.lisp | 2 +- src/interactive/bitmap.lisp | 2 +- src/interactive/canvas.lisp | 227 ++++++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 2 + wheelwork-examples.asd | 3 +- wheelwork.asd | 3 +- 7 files changed, 282 insertions(+), 4 deletions(-) create mode 100644 examples/10-canvas.lisp create mode 100644 src/interactive/canvas.lisp 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"))) -- cgit v1.2.3