[refactor] containers have render bounds

11 files changed, 178 insertions, 150 deletions

diff --git a/src/application.lisp b/src/application.lisp
index d38cd8a..d2da8ef 100644
--- a/src/application.lisp
+++ b/src/application.lisp
@@ -3,7 +3,6 @@
 (in-package #:wheelwork)
 
 
-
 (defclass/std application (container interactive)
   ((title :with :std "Wheelwork App")
    (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
@@ -21,7 +20,6 @@
    (fps :std 30 :doc "Frames Per Second")
    (frame-wait :r)))
 
-
 (defun can-set-projection-p (app)
   (and (slot-boundp app 'width)
        (slot-boundp app 'height)
@@ -35,7 +33,13 @@
 
 (defmethod initialize-instance :after ((app application) &key)
   (set-projection app)
-  (setf (listener app) (make-instance 'listener)))
+  (with-slots (listener left right top bottom scale width height) app
+  (setf listener (make-instance 'listener)
+        left 0
+        bottom 0
+        top (/ height scale)
+        right (/ width scale)
+        )))
 
 (defun fire-blur-event-on (thing)
   (when-let (blur-handlers (and thing (get-handlers-for thing 'blur)))
@@ -96,7 +100,6 @@ 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 (thing (container-units app))
-    (render thing))
+  (call-next-method)
   (sdl2:gl-swap-window (application-window app))
   (sleep (frame-wait app)))
diff --git a/src/core/affine.lisp b/src/core/affine.lisp
index 7c87d16..7cfb805 100644
--- a/src/core/affine.lisp
+++ b/src/core/affine.lisp
@@ -3,7 +3,7 @@
 (in-package #:wheelwork)
 
 (defclass/std affine (unit)
-  ((cached-model cached-projected-matrix cached-application :a)
+  ((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)))
@@ -13,9 +13,8 @@
   (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-projected-matrix affine) nil
+           (cached-rectangle affine) nil))))
 
 (defun scale-by (affine amount)
   (with-accessors ((sx scale-x) (sy scale-y)) affine
@@ -69,3 +68,22 @@
       (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))))))))
+
diff --git a/src/core/container.lisp b/src/core/container.lisp
index af01ff1..1410310 100644
--- a/src/core/container.lisp
+++ b/src/core/container.lisp
@@ -4,11 +4,46 @@
 
 
 (defclass/std container (unit)
-  ((units :with :a))
+  ((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))
@@ -30,3 +65,18 @@ necessary."
 (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 (container-units container))
+             (when (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 fb02f08..e93ba56 100644
--- a/src/core/unit.lisp
+++ b/src/core/unit.lisp
@@ -21,11 +21,10 @@ 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)))))
+                       (etypecase u
+                         (application u)
+                         (unit (rec (unit-container u)))
+                         (nil nil))))
               (rec unit)))))
 
 
diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp
index e8fd4fa..87779f0 100644
--- a/src/interactive/button.lisp
+++ b/src/interactive/button.lisp
@@ -61,76 +61,25 @@
         (render up)
         (render down))))
 
-(defmethod x ((button button))
-  (x (button-up button)))
-
-(defmethod (setf x) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (x bg) newval))
-    (setf (x up) newval
-          (x down) newval)))
-
-(defmethod y ((button button))
-  (y (button-up button)))
-
-(defmethod (setf y) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (y bg) newval))
-    (setf (y up) newval
-          (y down) newval)))
-
-(defmethod scale-x ((thing button))
-  (scale-x (button-up thing)))
-
-(defmethod (setf scale-x) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (scale-x bg) newval))
-    (setf (scale-x up) newval
-          (scale-x down) newval)))
-
-
-(defmethod scale-y ((thing button))
-  (scale-y (button-up thing)))
-
-(defmethod (setf scale-y) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (scale-y bg) newval))
-    (setf (scale-y up) newval
-          (scale-y down) newval)))
-
-(defmethod rotation ((thing button))
-  (rotation (button-up thing)))
-
-(defmethod (setf rotation) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (rotation bg) newval))
-    (setf (rotation up) newval
-          (rotation down) newval)))
-
-(defmethod width ((thing button))
-  (width (button-up thing)))
-
-(defmethod (setf width) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (width bg) newval))
-    (setf (width up) newval
-          (width down) newval)))
-
-(defmethod height ((thing button))
-  (height (button-up thing)))
-
-(defmethod (setf height) (newval (button button))
-  (with-slots (up down bg) button
-    (when bg
-      (setf (height bg) newval))
-    (setf (height up) newval
-          (height down) newval)))
+(macrolet
+    ((def-accessors (&rest accessor-names)
+       (let ((defs 
+               (loop for accessor-name in accessor-names
+                     collect 
+                     `(defmethod ,accessor-name ((button button))
+                        (,accessor-name (button-up button)))
+
+                     collect
+                     `(defmethod (setf ,accessor-name) (newval (button button))
+                        (setf (,accessor-name (button-up button)) newval
+                              (,accessor-name (button-down button)) newval
+                              (,accessor-name (button-bg button)) newval)))))
+         `(progn ,@defs))))
+
+  (def-accessors x y scale-x scale-y width height rotation))
+
+(defmethod get-rect ((button button))
+  (get-rect (button-up button)))
 
 (defun make-texture-button (up down &key pressed released)
   "UP and DOWN should be strings naming assets to use as the up and
diff --git a/src/interactive/frameset.lisp b/src/interactive/frameset.lisp
index 51c7ecd..a8ba079 100644
--- a/src/interactive/frameset.lisp
+++ b/src/interactive/frameset.lisp
@@ -67,6 +67,9 @@
   (def-frameset-accessors x y scale-x scale-y width height rotation))
 
 
+(defmethod get-rect ((fs frameset))
+  (get-rect (current-frame-unit fs)))
+
 (defun make-frameset (sequenced-assets &key (fps 2) asset-args)
   (let* ((asset-names
            (remove-duplicates sequenced-assets :test #'equal))
diff --git a/src/interactive/sprite.lisp b/src/interactive/sprite.lisp
index 81f5715..03bba8d 100644
--- a/src/interactive/sprite.lisp
+++ b/src/interactive/sprite.lisp
@@ -40,3 +40,6 @@
          `(progn ,@defs))))
 
   (def-sprite-accessors x y scale-x scale-y width height rotation))
+
+(defmethod get-rect ((sprite sprite))
+  (get-rect (current-frameset sprite)))
diff --git a/src/protocol.lisp b/src/protocol.lisp
index 58120cd..df3c170 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -56,3 +56,7 @@
 (defgeneric (setf scale-x) (newvval thing))
 (defgeneric scale-y (thing))
 (defgeneric (setf scale-y) (newval thing))
+(defgeneric get-rect (affine)
+  (:documentation "Returns a list of vectors representing the path of
+   the smallest rectangle that encloses the affine-unit. The rectangle
+   is scaled and rotated."))
diff --git a/src/utils.lisp b/src/utils.lisp
index 3598ec3..7024a8d 100644
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -14,3 +14,51 @@
                     (slot-value object slot)))
     val
     default))
+
+(defun counterclockwisep (a b c)
+  "A B and C are vectors created by 3d-vectors:vec, each representing
+a 2d point.  Returns T if the three are supplied in counterclockwise
+order, nil if not."
+  (> (* (- (vec:vx b) (vec:vx a))
+        (- (vec:vy c) (vec:vy a)))
+     (* (- (vec:vy b) (vec:vy a))
+        (- (vec:vx c) (vec:vx a)))))
+
+
+(defun intersectp (a b c d)
+  "A B C and D are vectors of the sort created by 3d-vectors:vec,
+each representing a 2d point.  Returns T if the line segment between A
+and B intersects the linesegment between C and D, NIL otherwise."
+  (or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d)
+      (and (not (eq (counterclockwisep a c d) (counterclockwisep b c d)))
+           (not (eq (counterclockwisep a b c) (counterclockwisep a b d))))))
+
+(defun path-bounds (path)
+  "Path is a list of vectors representing 2d points. Returns the
+bounds and width and height as a plist of the form 
+
+(:top N :left N :right N :bottom N :width N :height N)
+
+This is the smallest UNROTATED RECTANGLE that contains the points in
+the path."
+  (loop
+    with max-x = nil
+    and max-y = nil
+    and min-x = nil
+    and min-y = nil
+    for vec in path
+    for x = (vec:vx vec)
+    for y = (vec:vy vec)
+    when (or (null max-x) (< max-x x))
+      do (setf max-x x)
+    when (or (null min-x) (< x min-x))
+      do (setf min-x x)
+    when (or (null max-y) (< max-y y))
+      do (setf max-y y)
+    when (or (null min-y) (< y min-y))
+      do (setf min-y y)
+    finally
+       (return (list :top max-y :left min-x :right max-x :bottom min-y
+                     :width (- max-x min-x)
+                     :height (- max-y min-y)))))
+
diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp
index ffcb242..cc70053 100644
--- a/src/wheelwork.lisp
+++ b/src/wheelwork.lisp
@@ -23,7 +23,8 @@
       (sdl2:with-gl-context (ctx window)
         (sdl2:gl-make-current window ctx)
         (gl:viewport 0 0 (application-width app) (application-height app))
-        ;(gl:enable :depth-test)
+                                        ;(gl:enable :depth-test)
+        (gl:enable :scissor-test)
         (let ((*application* app)) 
           (unwind-protect
                (progn 
@@ -64,64 +65,8 @@ TARGET is FOCUSABLEP"
                (sdl2:scancode sdl-keysym)
                (sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))))
 
-(defun get-rect (unit)
-  "Returns a list of vectors representing the path of the smallest
-rectangle that encloses the unit. The rectangle is scaled and rotated."
-  (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 counterclockwisep (a b c)
-  (> (* (- (vec:vx b) (vec:vx a))
-        (- (vec:vy c) (vec:vy a)))
-     (* (- (vec:vy b) (vec:vy a))
-        (- (vec:vx c) (vec:vx a)))))
-
-
-(defun intersectp (a b c d)
-  (or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d)
-      (and (not (eq (counterclockwisep a c d) (counterclockwisep b c d)))
-           (not (eq (counterclockwisep a b c) (counterclockwisep a b d))))))
-
-(defun path-bounds (path)
-  "Path is a list of vectors representing 2d points. Returns the
-bounds and width and height as a plist of the form 
-
-(:top N :left N :right N :bottom N :width N :height N)
-
-This is the smallest UNROTATED RECTANGLE that contains the points in
-the path."
-  (loop
-    with max-x = nil
-    and max-y = nil
-    and min-x = nil
-    and min-y = nil
-    for vec in path
-    for x = (vec:vx vec)
-    for y = (vec:vy vec)
-    when (or (null max-x) (< max-x x))
-      do (setf max-x x)
-    when (or (null min-x) (< x min-x))
-      do (setf min-x x)
-    when (or (null max-y) (< max-y y))
-      do (setf max-y y)
-    when (or (null min-y) (< y min-y))
-      do (setf min-y y)
-    finally
-       (return (list :top max-y :left min-x :right max-x :bottom min-y
-                     :width (- max-x min-x)
-                     :height (- max-y min-y)))))
+
+
 
 (defun contains-point-p (unit px py)
   (let* ((pt
@@ -144,17 +89,22 @@ the path."
                (return (oddp intersection-count))))))
 
 (defun unit-under (app x y)
+  "Finds the visible unit that contains the point x y."
   (labels
       ((finder (thing)
-         (etypecase thing
-           (container
-            (find-if #'finder (container-units thing) :from-end t))
-           (unit
-            (when (contains-point-p thing x y)
-              (return-from unit-under thing))))))
+         (when (unit-visiblep thing) 
+           (etypecase thing
+             (container
+              (find-if #'finder (container-units thing) :from-end t))
+             (unit
+              (when (contains-point-p thing x y)
+                (return-from unit-under thing)))))))
     (finder app)))
 
 (defun screen-to-world (x y &optional (app *application*))
+  "Scales the screen point - the literal pixel position relative to
+the top corner of the application window - to reflect the
+application's scaling factor."
   (with-slots (height scale) app
     (list (/ x scale) (/ (- height y) scale))))
 
diff --git a/wheelwork.asd b/wheelwork.asd
index 095c949..5de81de 100644
--- a/wheelwork.asd
+++ b/wheelwork.asd
@@ -30,6 +30,7 @@
                (:module "core"
                 :components ((:file "unit")
                              (:file "container")
+                             (:file "clipped")
                              (:file "affine")))
                (:module "events"
                 :components ((:file "event-handler")