From 773a0ab4cc8ce76fa8ea4c819c34033960436f76 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 14 Apr 2021 21:07:36 -0400
Subject: node-2d: Add bounding boxes.

---
 starling/node-2d.scm | 200 ++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 174 insertions(+), 26 deletions(-)

diff --git a/starling/node-2d.scm b/starling/node-2d.scm
index d66615c..00d909a 100644
--- a/starling/node-2d.scm
+++ b/starling/node-2d.scm
@@ -50,6 +50,8 @@
             position
             resolution
             viewport
+            point-within-camera-viewport?
+            window-space->camera-space
 
             <canvas>
             cameras
@@ -73,6 +75,10 @@
             skew-y
             local-matrix
             world-matrix
+            width
+            height
+            bounding-box
+            on-child-resize
             dirty!
             move-by
             move-to
@@ -82,6 +88,7 @@
             scale-by
             scale-to
             follow-bezier-path
+            pick
 
             <sprite>
             texture
@@ -182,6 +189,42 @@
                            (projection-matrix camera))
         body ...))))
 
+(define-method (point-within-camera-viewport? (camera <camera-2d>) p)
+  (let* ((vp (viewport camera))
+         (x (viewport-x vp))
+         (y (viewport-y vp))
+         (w (viewport-width vp))
+         (h (viewport-height vp))
+         (px (vec2-x p))
+         (py (vec2-y p)))
+    (and (>= px x)
+         (< px (+ x w))
+         (>= py y)
+         (< py (+ y h)))))
+
+(define-method (window-space->camera-space (camera <camera-2d>) p)
+  ;; To translate a coordinate in window space to camera space, we
+  ;; do the following:
+  ;;
+  ;; - transform p into viewport space by subtracting the viewport
+  ;; position
+  ;;
+  ;; - transform the result of the previous step into camera space by
+  ;; multiplying by the ratio of the viewport size / camera resolution
+  ;;
+  ;; - finally, translate the result of the previous step to the
+  ;; correct position relative to the camera's current location by
+  ;; adding the camera position
+  (let* ((vp (viewport camera))
+         (r (resolution camera))
+         (pos (position camera)))
+    (vec2 (+ (* (- (vec2-x p) (viewport-x vp))
+                (/ (vec2-x r) (viewport-width vp)))
+             (vec2-x pos))
+          (+ (* (- (vec2-y p) (viewport-y vp))
+                (/ (vec2-y r) (viewport-height vp)))
+             (vec2-y pos)))))
+
 
 ;;;
 ;;; 2D Canvas
@@ -209,6 +252,21 @@
     ((camera . _) camera)
     (() #f)))
 
+(define-method (pick (canvas <canvas>) p)
+  (let camera-loop ((cams (cameras canvas)))
+    (match cams
+      (() #f)
+      ((camera . rest)
+       (if (point-within-camera-viewport? camera p)
+           (let ((p* (window-space->camera-space camera p)))
+             (let loop ((kids (reverse (children canvas))))
+               (match kids
+                 (() #f)
+                 ((child . rest)
+                  (or (pick child p*)
+                      (loop rest))))))
+           (camera-loop rest))))))
+
 
 ;;;
 ;;; 2D Scene
@@ -283,12 +341,16 @@
   (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4))
   (dirty-matrix? #:accessor dirty-matrix? #:init-form #t)
   ;; Bounding box for render culling, mouse selection, etc.
-  (bounding-box #:accessor bounding-box #:init-form (make-null-rect)))
+  (width #:accessor width #:init-keyword #:width #:init-form 0.0 #:watch? #t)
+  (height #:accessor height #:init-keyword #:height #:init-form 0.0 #:watch? #t)
+  (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0))
+  (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t))
 
 (define-method (dirty! (node <node-2d>))
-  (set! (dirty-matrix? node) #t))
+  (set! (dirty-matrix? node) #t)
+  (set! (dirty-bounding-box? node) #t))
 
-(define-method (compute-matrices! (node <node-2d>))
+(define-method (refresh-matrices (node <node-2d>))
   (let ((local (local-matrix node))
         (world (world-matrix node)))
     (matrix4-2d-transform! local
@@ -305,8 +367,33 @@
           (matrix4-identity! world)
           (matrix4-mult! world world local)))))
 
-;; Animation helpers
+(define-method (on-child-resize (node <node-2d>) child)
+  #t)
+
+;; TODO: Take rotation and skew into consideration.
+(define-method (refresh-bounding-box (node <node-2d>))
+  (let ((bb (bounding-box node))
+        (p (position node))
+        (o (origin node))
+        (s (scale node)))
+    (set-rect-x! bb (- (vec2-x p) (vec2-x o)))
+    (set-rect-y! bb (- (vec2-y p) (vec2-y o)))
+    (set-rect-width! bb (* (width node) (vec2-x s)))
+    (set-rect-height! bb (* (height node) (vec2-y s)))
+    (set! (dirty-bounding-box? node) #f)))
+
+(define-method (on-change (node <node-2d>) slot old new)
+  (case slot
+    ((origin position rotation scale skew)
+     (set! (dirty-bounding-box? node) #t)
+     (dirty! node))
+    ((width height)
+     (let ((np (parent node)))
+       (when (is-a? np <node-2d>)
+         (on-child-resize (parent node) node)))
+     (set! (dirty-bounding-box? node) #t))))
 
+;; Animation helpers
 
 (define-method (move-to (node <node-2d>) x y)
   (set! (position-x node) x)
@@ -355,7 +442,7 @@
   (set-vec2! (position node) x y)
   (set-vec2! (last-position node) x y)
   (set-vec2! (render-position node) x y)
-  (compute-matrices! node))
+  (refresh-matrices node))
 
 (define-method (rotate-to (node <node-2d>) theta)
   (set! (rotation node) theta))
@@ -429,10 +516,24 @@
 (define-method (follow-bezier-path (node <node-2d>) path duration)
   (follow-bezier-path node path duration #t))
 
+(define-method (pick (node <node-2d>) p)
+  (let ((bb (bounding-box node)))
+    (let loop ((kids (reverse (children node))))
+      (match kids
+        (()
+         (and (rect-contains-vec2? bb p)
+              node))
+        ((child . rest)
+         (let ((o (origin node)))
+           (or (pick child (vec2- p (position node)))
+               (loop rest))))))))
+
 ;; Events
 
 (define-method (update-tree (node <node-2d>) dt)
   (vec2-copy! (position node) (last-position node))
+  (when (dirty-bounding-box? node)
+    (refresh-bounding-box node))
   (next-method))
 
 (define-method (render-tree (node <node-2d>) alpha)
@@ -449,7 +550,7 @@
         (set! (dirty-matrix? node) #t)))
     ;; Recompute dirty matrices.
     (when (dirty-matrix? node)
-      (compute-matrices! node)
+      (refresh-matrices node)
       (set! (dirty-matrix? node) #f)
       ;; If the parent is dirty, all the children need to be marked as
       ;; dirty, too.
@@ -483,6 +584,26 @@
               #:init-keyword #:blend-mode
               #:init-form 'alpha))
 
+(define-method (refresh-sprite-size (sprite <sprite>))
+  (let ((t (texture sprite)))
+    (set! (width sprite) (texture-width t))
+    (set! (height sprite) (texture-height t))))
+
+(define-method (on-asset-reload (sprite <sprite>) slot-name asset)
+  (case slot-name
+    ((texture)
+     (refresh-sprite-size sprite))))
+
+(define-method (on-change (sprite <sprite>) slot-name old new)
+  (case slot-name
+    ((texture)
+     (refresh-sprite-size sprite))
+    (else
+     (next-method))))
+
+(define-method (on-boot (sprite <sprite>))
+  (refresh-sprite-size sprite))
+
 (define-method (render (sprite <sprite>) alpha)
   (let* ((tex (texture sprite))
          (rect (texture-gl-rect tex))
@@ -597,35 +718,55 @@
 
 
 ;;;
-;;; Text
+;;; Label
 ;;;
 
 (define-class <label> (<node-2d>)
-  (font #:accessor font #:init-keyword #:font #:init-thunk default-font #:asset? #t)
+  (font #:accessor font #:init-keyword #:font #:init-thunk default-font
+        #:asset? #t #:watch? #t)
   (text #:accessor text #:init-form "" #:init-keyword #:text #:watch? #t)
-  (align #:accessor align #:init-value 'left #:init-keyword #:align)
+  (align #:accessor align #:init-value 'left #:init-keyword #:align #:watch? #t)
   (vertical-align #:accessor vertical-align #:init-value 'bottom
-                  #:init-keyword #:vertical-align))
+                  #:init-keyword #:vertical-align #:watch? #t))
 
-(define-method (initialize (label <label>) initargs)
-  (next-method)
+(define-method (realign (label <label>))
+  (set! (origin-x label)
+        (match (align label)
+          ('left 0.0)
+          ('right (width label))
+          ('center (/ (width label) 2.0))))
+  (set! (origin-y label)
+        (match (vertical-align label)
+          ('bottom 0.0)
+          ('top (height label))
+          ('center (/ (height label) 2.0)))))
+
+(define-method (refresh-label-size (label <label>))
+  (let ((f (font label))
+        (t (text label)))
+    (set! (width label) (font-line-width f t))
+    (set! (height label) (font-line-height f))))
+
+(define-method (on-boot (label <label>))
+  (refresh-label-size label)
   (realign label))
 
-(define-method (on-change (label <label>) slot-name old new)
-  (realign label))
+(define-method (on-asset-reload (label <label>) slot-name asset)
+  (case slot-name
+    ((font)
+     (refresh-label-size label))))
 
-(define-method (realign (label <label>))
-  (let ((font (font label)))
-    (set-vec2! (origin label)
-               (match (align label)
-                 ('left 0.0)
-                 ('right (font-line-width font (text label)))
-                 ('center (/ (font-line-width font (text label)) 2.0)))
-               (match (vertical-align label)
-                 ('bottom 0.0)
-                 ('top (font-line-height font))
-                 ('center (/ (font-line-height font) 2.0)))))
-  (dirty! label))
+(define-method (on-change (label <label>) slot-name old new)
+  (case slot-name
+    ;; TODO: Minor performance improvement: Realignment is not
+    ;; necessary when changing the text of a left-aligned label.
+    ((font text)
+     (refresh-label-size label)
+     (realign label))
+    ((align vertical-align)
+     (realign label))
+    (else
+     (next-method))))
 
 (define-method (render (label <label>) alpha)
   (draw-text* (font label) (text label) (world-matrix label)))
@@ -655,6 +796,13 @@
 (define-class <particles> (<node-2d>)
   (particles #:accessor particles #:init-keyword #:particles))
 
+(define-method (on-boot (particles <particles>))
+  ;; Default bounding box size.
+  (when (zero? (width particles))
+    (set! (width particles) 32.0))
+  (when (zero? (height particles))
+    (set! (height particles) 32.0)))
+
 (define-method (update (node <particles>) dt)
   (update-particles (particles node)))
 
-- 
cgit v1.2.3