From 11f8d6dad0078464ccbc29cab57908a0923ca447 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Wed, 27 Jul 2022 12:07:10 -0500
Subject: [refactor] represent scene as a vector; [refactor] shared text shader

---
 examples/01-click-and-drag-image.lisp |  2 +-
 examples/09-ghoulspree.lisp           | 12 +++++-
 src/application.lisp                  | 20 +++++-----
 src/interactive/text.lisp             | 69 ++++++++++++++++++++---------------
 src/wheelwork.lisp                    | 20 ++++++----
 wheelwork-examples.asd                |  2 +-
 6 files changed, 77 insertions(+), 48 deletions(-)

diff --git a/examples/01-click-and-drag-image.lisp b/examples/01-click-and-drag-image.lisp
index e895d24..da6a12f 100644
--- a/examples/01-click-and-drag-image.lisp
+++ b/examples/01-click-and-drag-image.lisp
@@ -11,7 +11,7 @@
 (ww::defhandler dragging-unit
     (ww::on-mousemotion (app x y)
       (let ((unit
-              (first (ww::application-scene app))))
+              (elt (ww::application-scene app) 0)))
         (setf (ww:x unit) x
               (ww:y unit) y))))
 
diff --git a/examples/09-ghoulspree.lisp b/examples/09-ghoulspree.lisp
index b3c0106..a92299a 100644
--- a/examples/09-ghoulspree.lisp
+++ b/examples/09-ghoulspree.lisp
@@ -58,6 +58,16 @@ on which boundary VAL is outside of."
     `(loop for (,a . ,more-a) on ,ls do
       (loop for ,b in ,more-a do (progn ,@body)) )))
 
+(defmacro with-pairs ((a b) vector &rest body)
+  (alexandria:with-gensyms (idxa idxb vec)
+    `(loop
+       with ,vec = ,vector
+       for ,idxa from 0 to (- (length ,vec) 2)
+       for ,a = (aref ,vec ,idxa) do
+         (loop for ,idxb from (1+ ,idxa) to (1- (length ,vec))
+               for ,b = (aref ,vec ,idxb) do
+                 (progn ,@body)))))
+
 (defun handle-collision (g1 g2 &optional (friction 0.99))
   (with-slots ((dx1 dx) (dy1 dy) (dr1 dr)) g1
     (with-slots ((dx2 dx) (dy2 dy) (dr2 dr)) g2
@@ -93,7 +103,7 @@ on which boundary VAL is outside of."
               (gravity-on-p app))
             (accelleration
               (/ 9.8 (ww:fps app)))) 
-        (loop for ghoul in (ww::application-scene app)
+        (loop for ghoul across (ww::application-scene app)
               do (advance-pos ghoul)
               when gravity
                 do (apply-gravity-to ghoul accelleration)
diff --git a/src/application.lisp b/src/application.lisp
index 3b531c9..62849c9 100644
--- a/src/application.lisp
+++ b/src/application.lisp
@@ -48,12 +48,13 @@
 
 (defmethod initialize-instance :after ((app application) &key)
   (set-projection app)
-  (with-slots (listener left right top bottom scale width height) app
+  (with-slots (listener left right top bottom scale width height scene ) app
   (setf listener (make-instance 'listener)
         left 0
         bottom 0
         top (/ height scale)
-        right (/ width scale))))
+        right (/ width scale)
+        scene (make-array 0 :adjustable t :fill-pointer t :initial-element nil))))
 
 (defun fire-blur-event-on (thing)
   (when-let (blur-handlers (and thing (get-handlers-for thing 'blur)))
@@ -93,14 +94,14 @@
   (let ((listener (listener app))) 
     (dolist (table +listener-table-slot-names+)
       (setf (slot-value listener table) (make-hash-table :synchronized t))))
-  (dolist (unit (application-scene app))
-    (drop-unit unit)
-    (cleanup unit))
+  (loop for unit across (application-scene app)
+        do
+           (drop-unit unit)
+           (cleanup unit))
   (pre-exit-hooks))
 
 (defun run-perframe (app)
-  "Runs all of the handlers objects listening for perframe events, if
-those objects are currently part of the scene tree."
+  "Runs all of the handlers objects listening for perframe events if they are in the scene."
   (let ((table (perframe-table (listener app)))
         (time (sdl2:get-ticks)))
     (loop for target being the hash-key of table
@@ -116,8 +117,9 @@ those objects are currently part of the scene tree."
   (gl:clear :color-buffer-bit)
   (gl:enable :blend)
   (gl:blend-func :src-alpha :one-minus-src-alpha )
-  (dolist (unit (reverse (application-scene app)))
-    (render unit))
+  (with-slots (scene) app 
+    (when (plusp (length scene)) 
+      (loop for unit across scene do (render unit))))
   (sdl2:gl-swap-window (application-window app))
   (sleep (frame-wait app)))
 
diff --git a/src/interactive/text.lisp b/src/interactive/text.lisp
index dd99653..d79f7bf 100644
--- a/src/interactive/text.lisp
+++ b/src/interactive/text.lisp
@@ -9,6 +9,7 @@
    (vao elem-count newlines :r)
    (shader :with :static :r)))
 
+
 (defmethod model-matrix ((text text))
   (let ((m (mat:meye 4)))
     (with-slots (font newlines x y base-width base-height scale-x scale-y rotation) text 
@@ -36,22 +37,34 @@
       (mat:nmscale m (vec:vec scale-x scale-y 1.0))
       m)))
 
+(defvar *text-shader-program* nil)
+
+(defun make-shared-text-gpu-objects ()
+  (unless *text-shader-program*
+    (setf *text-shader-program*
+          (create-shader
+           '(:vertex
+             ((vert :vec2) (col :vec2))
+             ((transform :mat4))
+             ((values
+               (* transform (vari:vec4 vert 0.0 1.0))
+               col)))
+           '(:fragment
+             ((tc :vec2))
+             ((tex :sampler-2d)
+              (color :vec4))
+             ((* color (aref (vari:texture tex tc) 0)))))))
+  (unless (pre-exit-hook-exists-p :text-gpu-resources)
+    (pre-exit-hook
+     :text-gpu-resources
+     (lambda ()
+       (when *text-shader-program*
+         (gl:delete-program *text-shader-program*)
+         (setf *text-shader-program* nil))))))
+
 (defmethod initialize-instance :after ((text text) &key)
-  (with-slots (content newlines font vao elem-count shader base-width base-height scale-x scale-y) text
-    (unless shader
-      (setf shader
-            (create-shader
-             '(:vertex
-               ((vert :vec2) (col :vec2))
-               ((transform :mat4))
-               ((values
-                 (* transform (vari:vec4 vert 0.0 1.0))
-                 col)))
-             '(:fragment
-               ((tc :vec2))
-               ((tex :sampler-2d)
-                (color :vec4))
-               ((* color (aref (vari:texture tex tc) 0)))))))
+  (with-slots (content newlines font vao elem-count base-width base-height scale-x scale-y) text
+    (make-shared-text-gpu-objects)
     (multiple-value-bind (vao% count%) (cl-fond:compute-text (font-object font) content)
       (setf vao vao%
             elem-count count%))
@@ -67,29 +80,27 @@
                            (1+ newlines))))))
 
 (defmethod cleanup ((text text))
-  (with-slots (vao shader) text
-    (gl:delete-vertex-arrays (list vao))
-    (when shader
-      (gl:delete-program shader))
-    (setf vao nil
-          shader nil)))
+  (with-slots (vao) text
+    (when vao 
+      (gl:delete-vertex-arrays (list vao)))
+    (setf vao nil)))
 
 (defmethod render ((text text))
-  (with-slots (shader font vao elem-count color) text
-    (gl:use-program shader)
+  (with-slots (font vao elem-count color) text
+    (gl:use-program *text-shader-program*)
     (gl:active-texture 0)
     (gl:bind-texture :texture-2d (cl-fond:texture (font-object font)))
     (gl:program-uniform-matrix-4fv
-     shader
-     (gl:get-uniform-location shader "TRANSFORM")
+     *text-shader-program* 
+     (gl:get-uniform-location *text-shader-program* "TRANSFORM")
      (projected-matrix text))
     (gl:program-uniformi
-     shader
-     (gl:get-uniform-location shader "TEX")
+     *text-shader-program*
+     (gl:get-uniform-location *text-shader-program* "TEX")
      0)
     (gl:program-uniformfv
-     shader
-     (gl:get-uniform-location shader "COLOR")
+     *text-shader-program*
+     (gl:get-uniform-location *text-shader-program* "COLOR")
      color)
     (gl:bind-vertex-array vao)
     (%gl:draw-elements :triangles elem-count :unsigned-int 0)
diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp
index 8a534ed..ab432d5 100644
--- a/src/wheelwork.lisp
+++ b/src/wheelwork.lisp
@@ -10,7 +10,7 @@
 (defmethod add-unit ((unit unit))
   "Adds a unit to the display."
   (assert *application*)
-  (push unit (application-scene *application*))
+  (vector-push-extend unit (application-scene *application*) (1+ (length (application-scene *application*))))
   (setf (unit-in-scene-p unit) t))
 
 (defgeneric drop-unit (unit))
@@ -109,15 +109,21 @@ position.  The list always contains the app itself as the last element."
 (defun unit-under (app x y)
   "Finds the visible unit that contains the point x y, returns it as a
 single elemtn list, or nil if none found"
-  (loop for u in (application-scene app)
-        when (unit-visibly-contains-p u x y)
-          return (list u)))
+  (with-slots (scene) app 
+    (loop
+      for idx from (1- (length scene)) downto 0 
+      for u = (elt scene idx)
+      when (unit-visibly-contains-p u x y)
+        return (list u))))
 
 (defun all-units-under (app x y)
   "Finds all units under the point x y"
-  (loop for u in (application-scene app)
-        when (unit-visibly-contains-p u x y)
-          collect u))
+  (with-slots (scene) app 
+    (loop
+      for idx from (1- (length scene)) downto 0 
+      for u = (elt scene idx)
+      when (unit-visibly-contains-p u x y)
+        collect u)))
 
 (defvar *event-still-bubbling-p* nil
   "Controls whether an event is bubbling")
diff --git a/wheelwork-examples.asd b/wheelwork-examples.asd
index 75d7ef4..81fb76d 100644
--- a/wheelwork-examples.asd
+++ b/wheelwork-examples.asd
@@ -7,7 +7,7 @@
   :depends-on (#:wheelwork #:wheelwork-gui)
   :pathname "examples/"
   :components ((:file "01-click-and-drag-image")
-               (:file "02-moving-bitmp")
+               (:file "02-image-transforms-and-events")
                (:file "03-font-render")
                (:file "04-a-button")
                (:file "05-frameset-animation")
-- 
cgit v1.2.3