From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/region.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 102 insertions(+)
 create mode 100644 catbird/region.scm

(limited to 'catbird/region.scm')

diff --git a/catbird/region.scm b/catbird/region.scm
new file mode 100644
index 0000000..4ae4bc9
--- /dev/null
+++ b/catbird/region.scm
@@ -0,0 +1,102 @@
+(define-module (catbird region)
+  #:use-module (catbird camera)
+  #:use-module (catbird config)
+  #:use-module (catbird mixins)
+  #:use-module (catbird node)
+  #:use-module (catbird scene)
+  #:use-module (chickadee)
+  #:use-module (chickadee data array-list)
+  #:use-module (chickadee graphics engine)
+  #:use-module (chickadee graphics viewport)
+  #:use-module (chickadee math rect)
+  #:use-module (ice-9 exceptions)
+  #:use-module (oop goops)
+  #:export (<region>
+            make-region
+            area
+            area-x
+            area-y
+            area-width
+            area-height
+            camera
+            scene
+            replace-scene
+            push-scene
+            pop-scene)
+  #:re-export (name
+               rank
+               render
+               update))
+
+(define-root-class <region> (<renderable> <updatable> <nameable> <rankable>)
+  (area #:accessor area #:init-keyword #:area)
+  (camera #:accessor camera #:init-keyword #:camera #:init-value #f)
+  (scene #:accessor scene #:init-keyword #:scene #:init-value #f)
+  (scene-stack #:getter scene-stack #:init-thunk make-array-list)
+  (viewport #:accessor viewport))
+
+(define-method (area-x (region <region>))
+  (rect-x (area region)))
+
+(define-method (area-y (region <region>))
+  (rect-y (area region)))
+
+(define-method (area-width (region <region>))
+  (rect-width (area region)))
+
+(define-method (area-height (region <region>))
+  (rect-height (area region)))
+
+(define (float->int x)
+  (inexact->exact (round x)))
+
+(define-method (initialize (region <region>) args)
+  (next-method)
+  (let ((r (area region)))
+    (set! (viewport region)
+          (make-viewport (float->int (rect-x r))
+                         (float->int (rect-y r))
+                         (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)))
+
+(define-method (replace-scene (r <region>) (new-scene <scene>))
+  (let ((old-scene (scene r)))
+    (when old-scene (on-exit old-scene))
+    (set! (scene r) new-scene)
+    (set! (regions new-scene) (cons r (regions new-scene)))
+    (on-enter new-scene)))
+
+(define-method (push-scene (region <region>) (new-scene <scene>))
+  (let ((old-scene (scene region)))
+    (when old-scene
+      (array-list-push! (scene-stack region) old-scene))
+    (replace-scene region new-scene)))
+
+(define-method (pop-scene (region <region>))
+  (let ((stack (scene-stack region)))
+    (unless (array-list-empty? stack)
+      (replace-scene (array-list-pop! stack)))))
+
+(define-method (update (region <region>) dt)
+  (let ((s (scene region)))
+    (when s (update/around s dt))))
+
+(define-method (render (region <region>) alpha)
+  (let ((s (scene region))
+        (c (camera region)))
+    (when (and s c)
+      (parameterize ((current-camera c))
+        (with-projection (projection-matrix (camera region))
+          (render/around s alpha))))))
-- 
cgit v1.2.3