[version] [refactor] [redesign] removed containers

3 files changed, 95 insertions, 194 deletions

diff --git a/src/core/affine.lisp b/src/core/affine.lisp
deleted file mode 100644
index 671c184..0000000
--- a/src/core/affine.lisp
+++ /dev/null
@@ -1,92 +0,0 @@
-;;;; affine.lisp
-
-(in-package #:wheelwork)
-
-(defclass/std affine (unit)
-  ((cached-model cached-projected-matrix cached-application cached-rectangle :a)
-   (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 (setf closer-mop:slot-value-using-class) :after
-    (newval class (affine affine) slot)
-  (case (closer-mop:slot-definition-name slot)
-    ((x y scale-x scale-y rotation)
-     (setf (cached-model affine) nil
-           (cached-projected-matrix affine) nil
-           (cached-rectangle affine) nil))))
-
-(defun scale-by (affine amount)
-  (with-accessors ((sx scale-x) (sy scale-y)) affine
-    (setf sx (* amount sx)
-          sy (* amount sy))))
-
-(defun set-width-preserve-aspect (affine new-width)
-  (scale-by affine (/ new-width (width affine))))
-
-(defun set-height-preserve-aspect (affine new-height)
-  (scale-by affine (/ new-height (height affine) )))
-
-(defmethod width ((affine affine))
-  (with-slots (scale-x base-width) affine
-    (* scale-x base-width)))
-
-(defmethod height ((affine affine))
-  (with-slots (scale-y base-height) affine
-    (* scale-y base-height)))
-
-(defmethod (setf width) (newval (affine affine))
-  (with-slots (scale-x base-width) affine
-    (setf scale-x (coerce (/ newval base-width) 'single-float))))
-
-(defmethod (setf height) (newval (affine affine))
-  (with-slots (scale-y base-height) affine
-    (setf scale-y (coerce (/ newval base-height) 'single-float))))
-
-(defmethod model-matrix :around ((u affine))
-  (or (cached-model u)
-      (setf (cached-model u)
-            (call-next-method))))
-
-(defmethod model-matrix ((u affine))
-  (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 (affine)
-  (or (cached-projected-matrix affine)
-      (setf (cached-projected-matrix affine)
-            (mat:marr (mat:m* (application-projection (app-of-unit affine))
-                              (model-matrix affine))))))
-
-(defmethod get-rect ((affine-unit affine))
-  (or (cached-rectangle affine-unit)
-      (setf (cached-rectangle affine-unit)
-            (with-accessors ((x x) (y y) (w width) (h height) (r rotation)) affine-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)))
diff --git a/src/core/container.lisp b/src/core/container.lisp
deleted file mode 100644
index a9e6caf..0000000
--- a/src/core/container.lisp
+++ /dev/null
@@ -1,81 +0,0 @@
-;;;; units/container.lisp
-
-(in-package #:wheelwork)
-
-
-(defclass/std container (unit)
-  ((units :with :a)
-   (cached-rect :with)
-   (left right top bottom :with :std 0 :doc "container's box coordinates."))
-  (:documentation "Just a list of units. Made into a class so that
-  transformation affine transformations methods can be specialzied on
-  whole groups of units"))
-
-(defmethod (setf closer-mop:slot-value-using-class)
-    (newval class (container container) slot)
-  (case (closer-mop:slot-definition-name slot)
-    ((left right top bottom)
-     (setf (container-cached-rect container) nil))))
-
-(defmethod get-rect ((container container))
-  (with-slots (cached-rect left right top bottom) container
-    (or cached-rect
-        (setf cached-rect 
-              (list (vec:vec left bottom 0 1.0)
-                     (vec:vec left top 0 1.0)
-                     (vec:vec right top 0 1.0)
-                     (vec:vec right bottom 0 1.0)
-                     (vec:vec left bottom 0 1.0))))))
-
-
-(defun point-in-contanier-box-p (c x y)
-  "Returns T if the ponit X Y is inside the bounds of the container."
-  (and (<= (container-left c) x (container-right c))
-       (<= (container-bottom c) y (container-top c))))
-
-(defun visible-in-container-p (unit)
-  "Returns T if UNIT is VISIBLEP, if it is inside a CONTAINER, if any
-  of the corners of its bounding rectangle are inside that CONTAINER.
-
-  UNIT must implement the affine protocol."
-  (when (unit-visiblep unit) 
-    (when-let ((container
-                (unit-container unit)))
-      (loop for pt in (get-rect unit)
-            thereis (point-in-contanier-box-p container (vec:vx pt) (vec:vy pt))))))
-
-(defmethod drop-unit ((unit unit))
-  "Removes a unit from its container. Returns T if the unit actually was removed."
-  (when-let (container (unit-container unit))
-    (setf
-     (container-units container) (delete unit (container-units container))
-     (unit-container unit) nil)
-    t))
-
-(defmethod add-unit ((container container) (unit unit))
-  "Adds a unit to the end of a container (thus affecting render
-order). Also removes the unit from its current container if
-necessary."
-  (when (unit-container unit)
-    (drop-unit unit))
-  (push unit  (container-units container))
-  (setf (unit-container unit) container)
-  unit)
-
-(defmethod cleanup ((container container))
-  (dolist (u (container-units container))
-    (cleanup u)))
-
-(defmethod render ((container container))
-  (let ((current
-          (gl:get* :scissor-box))
-        (scale
-          (application-scale
-           (app-of-unit container)))) 
-    (with-slots (left right top bottom) container 
-      (gl:scissor (* left scale) (* scale bottom) (* scale (- right left)) (* scale (- top bottom)))
-      (unwind-protect  
-           (dolist (u (reverse (container-units container)))
-             (if (visible-in-container-p u)
-               (render u)))
-        (gl:scissor (aref current 0) (aref current 1) (aref current 2) (aref current 3))))))
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)))