[version] [refactor] [redesign] removed containers

1 files changed, 95 insertions, 21 deletions

diff --git a/src/core/unit.lisp b/src/core/unit.lisp
index e93ba56..e56c01f 100644
--- a/src/core/unit.lisp
+++ b/src/core/unit.lisp
@@ -1,33 +1,107 @@
-;;;; units/unit.lisp
+;;;; unit.lisp
 
 (in-package #:wheelwork)
 
 (defclass/std unit ()
-  ((cached-application :a)
-   (container :with :a)
-   (visiblep :with :std t)))
+  ((cached-model cached-projected-matrix cached-rectangle :a)
+   (visiblep :with :std t)
+   (in-scene-p :with :a :std nil)
+   (region :with :std *application*
+                 :doc "The screen region where the unit will be visible.")
+   (base-width base-height :r :std 1.0 :doc "Determined by content.")
+   (scale-x scale-y :std 1.0)
+   (rotation x y :std 0.0)))
+
+(defmethod render :around ((unit unit))
+  (when (unit-visiblep unit)
+    (let ((sb
+            (gl:get* :scissor-box))
+          (scale
+            (application-scale *application*)))
+      (with-slots (left right top bottom) (unit-region unit)
+        (gl:scissor (* left scale) (* bottom scale) (* scale (- right left)) (* scale (- top bottom)))
+        (call-next-method))
+      (gl:scissor (aref sb 0) (aref sb 1) (aref sb 2) (aref sb 3)))))
 
 (defmethod (setf closer-mop:slot-value-using-class) :after
     (newval class (unit unit) slot)
   (case (closer-mop:slot-definition-name slot)
-    (container
-     (setf (cached-application unit) nil))))
+    ((x y scale-x scale-y rotation)
+     (setf (cached-model unit) nil
+           (cached-projected-matrix unit) nil
+           (cached-rectangle unit) nil))))
 
+(defun scale-by (unit amount)
+  (with-accessors ((sx scale-x) (sy scale-y)) unit
+    (setf sx (* amount sx)
+          sy (* amount sy))))
 
-(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)
-                       (etypecase u
-                         (application u)
-                         (unit (rec (unit-container u)))
-                         (nil nil))))
-              (rec unit)))))
+(defun set-width-preserve-aspect (unit new-width)
+  (scale-by unit (/ new-width (width unit))))
 
+(defun set-height-preserve-aspect (unit new-height)
+  (scale-by unit (/ new-height (height unit) )))
 
-(defmethod render :around ((unit unit))
-  (when (unit-visiblep unit)
-    (call-next-method)))
+(defmethod width ((unit unit))
+  (with-slots (scale-x base-width) unit
+    (* scale-x base-width)))
+
+(defmethod height ((unit unit))
+  (with-slots (scale-y base-height) unit
+    (* scale-y base-height)))
+
+(defmethod (setf width) (newval (unit unit))
+  (with-slots (scale-x base-width) unit
+    (setf scale-x (coerce (/ newval base-width) 'single-float))))
+
+(defmethod (setf height) (newval (unit unit))
+  (with-slots (scale-y base-height) unit
+    (setf scale-y (coerce (/ newval base-height) 'single-float))))
+
+(defmethod model-matrix :around ((u unit))
+  (or (cached-model u)
+      (setf (cached-model u)
+            (call-next-method))))
+
+(defmethod model-matrix ((u unit))
+  (let ((m (mat:meye 4)))
+    (with-slots (x y base-width scale-x base-height scale-y rotation) u 
+      (let ((uw (* base-width scale-x))
+            (uh (* base-height scale-y)))
+        (mat:nmtranslate m (vec:vec x y 0.0))
+
+        (mat:nmtranslate m (vec:v* 0.5 (vec:vec uw uh 0.0)))
+        (mat:nmrotate  m vec:+vz+ rotation)
+        (mat:nmtranslate m (vec:v* -0.5 (vec:vec uw uh 0.0)))
+        
+        (mat:nmscale m (vec:vec uw uh 1.0))))
+    m))
+
+
+(defun projected-matrix (unit)
+  (or (cached-projected-matrix unit)
+      (setf (cached-projected-matrix unit)
+            (mat:marr (mat:m* (application-projection *application*)
+                              (model-matrix unit))))))
+
+(defmethod get-rect ((unit unit))
+  (or (cached-rectangle unit)
+      (setf (cached-rectangle unit)
+            (with-accessors ((x x) (y y) (w width) (h height) (r rotation)) unit
+              (let ((m
+                      (mat:meye 4))
+                    (tr
+                      (vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0)))
+                (mat:nmtranslate m tr)
+                (mat:nmrotate  m vec:+vz+ r)
+                (mat:nmtranslate m (vec:v* -1.0 tr))
+                
+                (list (mat:m* m (vec:vec x y 0.0 1.0))
+                      (mat:m* m (vec:vec x (+ y h) 0.0 1.0))
+                      (mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0))
+                      (mat:m* m (vec:vec (+ x w) y 0.0 1.0))
+                      (mat:m* m (vec:vec x y 0.0 1.0))))))))
+
+(defun  units-intersect-p (au1 au2)
+  "Returns T if the two units AU1 an AU2 intersect. Both must implement GET-RECT."
+  (paths-intersect-p (get-rect au1) (get-rect au2)))