;;;; 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)))) (defun pixel-offset (x y pixels) (* 4 (+ x (* y (pixel-width pixels))))) (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)))) (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))))))) (defun clear-canvas (canvas &key (r 0) (g 0) (b 0) (a 255)) (with-pixels-rect (x y pr pg pb pa) (canvas) (setf pr r pg g pb b pa a))) (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-grid-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 (unit 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-sub-image-2d :texture-2d 0 0 0 pixel-width pixel-height :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)))