From 56b743bbfe56823bfe482a4f4e579512041918d2 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Thu, 30 Jun 2022 06:57:43 -0500
Subject: [add] cached-application slot to unit; app-of-unit function

---
 src/core-units/unit.lisp | 34 ++++++++++++++++++++++++++--------
 1 file changed, 26 insertions(+), 8 deletions(-)

(limited to 'src/core-units/unit.lisp')

diff --git a/src/core-units/unit.lisp b/src/core-units/unit.lisp
index 6ccd31e..31f268c 100644
--- a/src/core-units/unit.lisp
+++ b/src/core-units/unit.lisp
@@ -3,13 +3,21 @@
 (in-package #:wheelwork)
 
 (defclass/std unit ()
-  ((cached-model cached-projected-matrix :a)
+  ((cached-model cached-projected-matrix cached-application :a)
    (container :with :a)
    (base-width base-height :r :std 1.0 :doc "Determined by content.")
    (scale-x scale-y :with :std 1.0)
    (rotation x y :with :std 0.0)
    (opacity :std 1.0 :doc "0.0 indicates it will not be rendred.")))
 
+(defmethod (setf closer-mop:slot-value-using-class) :after
+    (newval class (unit unit) slot)
+  (case (closer-mop:slot-definition-name slot)
+    ((x y scale-x scale-y rotation)
+     (setf (cached-model unit) nil
+           (cached-projected-matrix unit) nil))
+    (container
+     (setf (cached-application unit) nil))))
 
 (defun scale-by (unit amount)
   (with-slots (scale-x scale-y) unit
@@ -38,12 +46,7 @@
   (with-slots (scale-y base-height) unit
     (setf scale-y (coerce (/ newval base-height) 'single-float))))
 
-(defmethod (setf closer-mop:slot-value-using-class) :after
-    (newval class (unit unit) slot)
-  (case (closer-mop:slot-definition-name slot)
-    ((x y scale-x scale-y rotation)
-     (setf (cached-model unit) nil
-           (cached-projected-matrix unit) nil))))
+
 
 (defmethod model-matrix :around ((u unit))
   (or (cached-model u)
@@ -64,8 +67,23 @@
         (mat:nmscale m (vec:vec uw uh 1.0))))
     m))
 
+
+(defun app-of-unit (unit)
+  "Returns the APPLICATION instance, if any, of which this UNIT is a
+part. NIL indicates that the unit has not been added to any container
+in this application."
+  (or (cached-application unit) 
+      (setf (cached-application unit) 
+            (labels ((rec (u)
+                       (when-let (c (unit-container u))
+                         (etypecase c
+                           (application c)
+                           (unit (rec c))
+                           (null nil)))))
+              (rec unit)))))
+
 (defun projected-matrix (unit)
   (or (cached-projected-matrix unit)
       (setf (cached-projected-matrix unit)
-            (mat:marr (mat:m* (application-projection *application*)
+            (mat:marr (mat:m* (application-projection (app-of-unit unit))
                               (model-matrix unit))))))
-- 
cgit v1.2.3