diff options
Diffstat (limited to 'src/interactive/canvas.lisp')
| -rw-r--r-- | src/interactive/canvas.lisp | 227 |
1 files changed, 227 insertions, 0 deletions
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))) |