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/scene.scm | 147 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 147 insertions(+)
 create mode 100644 catbird/scene.scm

(limited to 'catbird/scene.scm')

diff --git a/catbird/scene.scm b/catbird/scene.scm
new file mode 100644
index 0000000..b46a176
--- /dev/null
+++ b/catbird/scene.scm
@@ -0,0 +1,147 @@
+(define-module (catbird scene)
+  #:use-module (catbird config)
+  #:use-module (catbird mixins)
+  #:use-module (catbird mode)
+  #:use-module (catbird node)
+  #:use-module (chickadee data array-list)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 format)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<scene>
+            regions
+            major-mode
+            minor-modes
+            replace-major-mode
+            push-major-mode
+            pop-major-mode
+            add-minor-mode
+            remove-minor-mode))
+
+(define-root-class <scene> (<node>)
+  (regions #:accessor regions #:init-value '())
+  (major-mode #:accessor major-mode #:init-keyword #:major-mode
+              #:init-form (make <nothing-mode>))
+  (major-mode-stack #:getter major-mode-stack #:init-thunk make-array-list)
+  (minor-modes #:accessor minor-modes #:init-value '())
+  (input-map #:getter input-map #:init-value '()))
+
+(define-method (initialize (scene <scene>) args)
+  (next-method)
+  (attach (major-mode scene) scene))
+
+(define-method (replace-major-mode (scene <scene>) (mode <major-mode>))
+  (let ((old-mode (major-mode scene)))
+    (when old-mode
+      (detach old-mode))
+    (set! (major-mode scene) mode)
+    (attach mode scene)))
+
+(define-method (push-major-mode (scene <scene>) (mode <major-mode>))
+  (let ((old-mode (major-mode scene)))
+    (array-list-push! (major-mode-stack scene) old-mode)
+    (when old-mode
+      (pause old-mode))
+    (set! (major-mode scene) mode)
+    (attach mode scene)))
+
+(define-method (pop-major-mode (scene <scene>))
+  (let ((stack (major-mode-stack scene)))
+    (unless (array-list-empty? stack)
+      (let ((mode (major-mode scene))
+            (prev-mode (array-list-pop! stack)))
+        (when mode
+          (detach mode))
+        (set! (major-mode scene) prev-mode)
+        (resume prev-mode)))))
+
+(define-method (add-minor-mode (scene <scene>) (mode <minor-mode>))
+  (when (parent mode)
+    (raise-exception
+     (make-exception-with-message "mode already attached to a scene")))
+  (set! (minor-modes scene) (cons mode (minor-modes scene)))
+  (attach mode scene))
+
+(define-method (remove-minor-mode (scene <scene>) (mode <minor-mode>))
+  (unless (eq? scene (parent mode))
+    (raise-exception
+     (make-exception-with-message "mode not attached to scene")))
+  (let ((modes (minor-modes scene)))
+    (set! (minor-modes scene) (delq mode modes))
+    (detach mode)))
+
+(define-method (remove-minor-mode (scene <scene>) (mode-class <class>))
+  (let ((mode (find (lambda (mode)
+                      (eq? (class-of mode) mode-class))
+                    (minor-modes scene))))
+    (when mode
+      (remove-minor-mode scene mode))))
+
+(define-method (search-modes (scene <scene>) proc)
+  (or (proc (major-mode scene))
+      (find (lambda (mode)
+              (proc mode))
+            (minor-modes scene))))
+
+(define-method (on-key-press (scene <scene>) key modifiers)
+  (search-modes scene
+                (lambda (mode)
+                  (on-key-press mode key modifiers))))
+
+(define-method (on-key-release (scene <scene>) key modifiers)
+  (search-modes scene
+                (lambda (mode)
+                  (on-key-release mode key modifiers))))
+
+(define-method (on-text-input (scene <scene>) text)
+  (search-modes scene
+                (lambda (mode)
+                  (on-text-input mode text))))
+
+(define-method (on-mouse-press (scene <scene>) button x y)
+  (search-modes scene
+                (lambda (mode)
+                  (on-mouse-press mode button x y))))
+
+(define-method (on-mouse-release (scene <scene>) button x y)
+  (search-modes scene
+                (lambda (mode)
+                  (on-mouse-release mode button x y))))
+
+(define-method (on-mouse-move (scene <scene>) x y x-rel y-rel buttons)
+  (search-modes scene
+                (lambda (mode)
+                  (on-mouse-move mode x y x-rel y-rel buttons))))
+
+(define-method (on-mouse-wheel (scene <scene>) x y)
+  (search-modes scene
+                (lambda (mode)
+                  (on-mouse-wheel mode x y))))
+
+(define-method (on-controller-press (scene <scene>) controller-id button)
+  (search-modes scene
+                (lambda (mode)
+                  (on-controller-press mode controller-id button))))
+
+(define-method (on-controller-release (scene <scene>) controller-id button)
+  (search-modes scene
+                (lambda (mode)
+                  (on-controller-release mode controller-id button))))
+
+(define-method (on-controller-move (scene <scene>) controller-id axis value)
+  (search-modes scene
+                (lambda (mode)
+                  (on-controller-move mode controller-id axis value))))
+
+(define-method (update (scene <scene>) dt)
+  (update (major-mode scene) dt)
+  (for-each (lambda (mode) (update mode dt))
+            (minor-modes scene)))
+
+(define-method (pause (scene <scene>))
+  (for-each-child pause scene)
+  (next-method))
+
+(define-method (resume (scene <scene>))
+  (for-each-child resume scene)
+  (next-method))
-- 
cgit v1.2.3