From 3c1df8b7807f772887dc3d85725059c4dbe75cca Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Tue, 19 Jul 2022 06:45:16 -0500
Subject: [rename] bitmap/image

---
 src/interactive/image.lisp | 86 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)
 create mode 100644 src/interactive/image.lisp

(limited to 'src/interactive/image.lisp')

diff --git a/src/interactive/image.lisp b/src/interactive/image.lisp
new file mode 100644
index 0000000..7c84df3
--- /dev/null
+++ b/src/interactive/image.lisp
@@ -0,0 +1,86 @@
+;;;; image.lisp
+
+(in-package #:wheelwork)
+
+(defvar *image-shader-program* nil
+  "Cached for later cleanup.")
+(defvar *image-vao* nil)
+
+(defvar *image-count* 0
+  "Used by finalizers to determin if the shader should be destroyed.")
+
+(defun image-finalizer ()
+  "executed after a image has been reclaimed by gc. decrements image
+count and destroys shader-program if necessary."
+  (decf *image-count*)
+  (unless (plusp *image-count*)
+    (when *image-vao*
+      (gl:delete-vertex-arrays (list *image-vao*))
+      (setf *image-vao* nil))
+    (when *image-shader-program*
+      (gl:delete-program *image-shader-program*)
+      (setf *image-shader-program* nil))))
+
+(defclass/std image (affine interactive)
+  ((texture :ri :std (error "A image requires a texture."))))
+
+(defmethod initialize-instance :after ((image image) &key)
+  (incf *image-count*)
+  (trivial-garbage:finalize image #'image-finalizer)
+  (with-slots (base-width base-height texture) image
+    (setf base-height (texture-height texture)
+          base-width (texture-width texture))
+    (unless *image-shader-program*
+      (setf *image-shader-program*
+            (create-shader
+             '(:vertex
+               ((vert :vec2))
+               ((transform :mat4))
+               ((values
+                 (* transform (vari:vec4 vert 0.0 1.0))
+                 vert))) ;color
+             '(:fragment
+               ((tc :vec2))
+               ((tex :sampler-2d))
+               ((let ((frag  (vari:texture tex tc)))
+                  (if (< (aref frag 3) 0.01)
+                      (vari:discard)
+                      frag))))))
+      (gl:program-uniformi
+       *image-shader-program*
+       (gl:get-uniform-location *image-shader-program* "TEX")
+       0))
+    (unless *image-vao*
+      (setf *image-vao* (gl:gen-vertex-array))
+      (gl:bind-vertex-array *image-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))))
+
+(defmethod cleanup ((image image))
+  (image-finalizer))
+
+(defmethod render ((image image))
+  (with-slots (texture) image
+    (gl:active-texture 0)
+    (gl:bind-texture :texture-2d (texture-id texture))
+    (gl:use-program *image-shader-program*)
+    (gl:program-uniform-matrix-4fv
+     *image-shader-program*
+     (gl:get-uniform-location *image-shader-program* "TRANSFORM")
+     (projected-matrix image))
+    (gl:bind-vertex-array *image-vao*)    
+    (gl:draw-arrays :triangles 0 6)
+    (gl:bind-vertex-array 0)))
-- 
cgit v1.2.3