Handle window resizing in a somewhat reasonable way.

8 files changed, 109 insertions, 30 deletions

diff --git a/catbird.scm b/catbird.scm
index cdb9e39..cdd3313 100644
--- a/catbird.scm
+++ b/catbird.scm
@@ -118,7 +118,10 @@
                   (on-controller-release kernel controller button))
                 #:controller-move
                 (lambda (controller axis value)
-                  (on-controller-move kernel controller axis value))))))
+                  (on-controller-move kernel controller axis value))
+                #:window-resize
+                (lambda (width height)
+                  (on-window-resize kernel width height))))))
 
 (define (exit-catbird)
   "Stop the Catbird engine."
diff --git a/catbird/camera.scm b/catbird/camera.scm
index a3d8fd3..e4463be 100644
--- a/catbird/camera.scm
+++ b/catbird/camera.scm
@@ -45,8 +45,8 @@
   #:re-export (width height))
 
 (define-root-class <camera> ()
-  (width #:accessor width #:init-keyword #:width)
-  (height #:accessor height #:init-keyword #:height)
+  (width #:accessor width #:init-keyword #:width #:init-value 0.0)
+  (height #:accessor height #:init-keyword #:height #:init-value 0.0)
   (projection-matrix #:getter projection-matrix #:init-thunk make-identity-matrix4)
   (view-matrix #:getter view-matrix #:init-thunk make-identity-matrix4))
 
@@ -58,6 +58,11 @@
   (refresh-projection camera)
   (refresh-view camera))
 
+(define-method (resize (camera <camera>) w h)
+  (set! (width camera) w)
+  (set! (height camera) h)
+  (refresh-projection camera))
+
 (define current-camera (make-parameter #f))
 
 
@@ -70,6 +75,13 @@
 
 (define-method (initialize (camera <camera-2d>) initargs)
   (next-method)
+  (refresh-bounding-box-size camera))
+
+(define-method (resize (camera <camera-2d>) w h)
+  (next-method)
+  (refresh-bounding-box-size camera))
+
+(define-method (refresh-bounding-box-size (camera <camera-2d>))
   (let ((bb (view-bounding-box camera)))
     (set-rect-width! bb (width camera))
     (set-rect-height! bb (height camera))))
diff --git a/catbird/kernel.scm b/catbird/kernel.scm
index 6560d47..448b168 100644
--- a/catbird/kernel.scm
+++ b/catbird/kernel.scm
@@ -303,6 +303,15 @@
                                      (controller-slot-id slot)
                                      axis
                                      value))))))
+
+;;;
+;;; Windows
+;;;
+
+(define-method (on-window-resize (kernel <kernel>) width height)
+  (for-each (lambda (r)
+              (on-window-resize r width height))
+            (regions kernel)))
 
 
 ;;;
@@ -336,14 +345,23 @@
   (gensym "region-"))
 
 (define* (create-region area #:key (rank 0) (name (unique-region-name)))
-  (let ((region (make-region area name rank)))
+  (let* ((window (current-window))
+         (w (window-width window))
+         (h (window-height window)))
+    (when (or (< (rect-left area) 0.0)
+              (< (rect-bottom area) 0.0)
+              (> (rect-right area) w)
+              (> (rect-top area) h))
+      (raise-exception
+       (make-exception-with-message "region area exceeds window area"))))
+  (let ((region (make <region> #:area area #:name name #:rank rank)))
     (add-region (current-kernel) region)
     region))
 
 (define* (create-full-region #:key (rank 0) (name (unique-region-name)))
-  (let ((w (window-width (current-window)))
-        (h (window-height (current-window))))
-    (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name)))
+  (let ((region (make <full-region> #:name name #:rank rank)))
+    (add-region (current-kernel) region)
+    region))
 
 (define (kill-region region)
   (let ((k (current-kernel)))
diff --git a/catbird/mixins.scm b/catbird/mixins.scm
index 6e1cd4a..520e12f 100644
--- a/catbird/mixins.scm
+++ b/catbird/mixins.scm
@@ -75,6 +75,8 @@
             height
             depth
 
+            resize
+
             <listener>
             ignore
             listen
@@ -245,6 +247,12 @@
 (define-accessor height)
 (define-accessor depth)
 
+
+;;;
+;;; Resizable
+;;;
+
+(define-generic resize)
 
 
 ;;;
diff --git a/catbird/node-2d.scm b/catbird/node-2d.scm
index 44a31f9..12014f1 100644
--- a/catbird/node-2d.scm
+++ b/catbird/node-2d.scm
@@ -88,7 +88,6 @@
             place-right
             position-x
             position-y
-            resize
             rotate-by
             rotate-to
             rotation
diff --git a/catbird/overlay.scm b/catbird/overlay.scm
index 2833e87..1cdabd4 100644
--- a/catbird/overlay.scm
+++ b/catbird/overlay.scm
@@ -70,6 +70,11 @@
         (lambda (exception stack)
           (handle-error overlay exception stack))))
 
+(define-method (on-region-resize (overlay <overlay>))
+  (let ((repl (child-ref overlay 'repl))
+        (region (car (regions overlay))))
+    (when repl (resize-repl repl (width region) (height region)))))
+
 (define-method (notify (scene <overlay>) message)
   (run-script scene
     (let* ((padding 8.0)
diff --git a/catbird/region.scm b/catbird/region.scm
index 7e9f9df..a117a2e 100644
--- a/catbird/region.scm
+++ b/catbird/region.scm
@@ -36,31 +36,32 @@
   #:use-module (ice-9 exceptions)
   #:use-module (oop goops)
   #:export (<region>
-            make-region
+            <full-region>
             area
             area-x
             area-y
             area-width
             area-height
             camera
+            set-camera
             freeze
             frozen?
             scene
             replace-scene
             push-scene
             pop-scene
-            unfreeze)
+            unfreeze
+            on-window-resize)
   #:re-export (name
                rank
                render
                update))
 
 (define-root-class <region> (<renderable> <updatable> <nameable> <rankable>)
-  (area #:accessor area #:init-keyword #:area)
+  (area #:getter area #:init-keyword #:area)
   (camera #:accessor camera #:init-keyword #:camera #:init-value #f)
   (scene-state #:accessor scene-state #:init-thunk make-pushdown-state)
   (framebuffer #:accessor framebuffer)
-  (framebuffer-rect #:accessor framebuffer-rect)
   ;; Regions can be frozen for debugging purposes, so that the scene
   ;; they contain isn't updated or rendered.
   (frozen? #:accessor frozen? #:init-value #f))
@@ -88,26 +89,37 @@
 
 (define-method (initialize (region <region>) args)
   (next-method)
+  (refresh-framebuffer region)
+  (refresh-camera region))
+
+(define-method (set-camera (region <region>) new-camera)
+  (set! (camera region) new-camera)
+  (refresh-camera region))
+
+(define-method (refresh-camera (region <region>))
+  (let ((c (camera region)))
+    (when c (resize c (width region) (height region)))))
+
+(define-method (refresh-framebuffer (region <region>))
   (let ((r (area region)))
     (set! (framebuffer region)
           (make-framebuffer (float->int (rect-width r))
-                            (float->int (rect-height r))))
-    (set! (framebuffer-rect region)
-          (make-rect 0.0 0.0
-                     (float->int (rect-width r))
-                     (float->int (rect-height r))))))
-
-(define (make-region area name rank)
-  (let* ((window (current-window))
-         (w (window-width window))
-         (h (window-height window)))
-    (when (or (< (rect-left area) 0.0)
-              (< (rect-bottom area) 0.0)
-              (> (rect-right area) w)
-              (> (rect-top area) h))
-      (raise-exception
-       (make-exception-with-message "region area exceeds window area")))
-    (make <region> #:area area #:name name #:rank rank)))
+                            (float->int (rect-height r))))))
+
+(define-method (resize (region <region>) width height)
+  (let ((r (area region))
+        (c (camera region))
+        (s (scene region)))
+    (set-rect-width! r width)
+    (set-rect-height! r height)
+    (refresh-framebuffer region)
+    (refresh-camera region)
+    (when s (on-region-resize s))))
+
+(define-method (move (region <region>) x y)
+  (let ((r (area region)))
+    (set-rect-x! r x)
+    (set-rect-y! r y )))
 
 (define-method (freeze (region <region>))
   (set! (frozen? region) #t))
@@ -161,5 +173,23 @@
             (with-projection (projection-matrix (camera region))
               (render/around s alpha))))
         (draw-sprite* (framebuffer-texture fb)
-                      (framebuffer-rect region)
+                      (area region)
                       %identity-matrix)))))
+
+(define-method (on-window-resize (region <region>) width height)
+  #t)
+
+
+;;;
+;;; Full region
+;;;
+
+(define (current-window-area)
+  (let ((window (current-window)))
+    (make-rect 0.0 0.0 (window-width window) (window-height window))))
+
+(define-class <full-region> (<region>)
+  (area #:getter area #:init-thunk current-window-area))
+
+(define-method (on-window-resize (region <full-region>) width height)
+  (resize region width height))
diff --git a/catbird/scene.scm b/catbird/scene.scm
index a1bcffa..69a0b1d 100644
--- a/catbird/scene.scm
+++ b/catbird/scene.scm
@@ -41,6 +41,7 @@
             regions
             major-mode
             minor-modes
+            on-region-resize
             replace-major-mode
             push-major-mode
             pop-major-mode
@@ -194,6 +195,9 @@
                 (lambda (mode)
                   (on-controller-move mode controller-id axis value))))
 
+(define-method (on-region-resize (scene <scene>))
+  #t)
+
 (define-method (update (scene <scene>) dt)
   (with-scene scene
     (update (major-mode scene) dt)