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

(limited to 'catbird/node.scm')

diff --git a/catbird/node.scm b/catbird/node.scm
new file mode 100644
index 0000000..99a6da3
--- /dev/null
+++ b/catbird/node.scm
@@ -0,0 +1,160 @@
+(define-module (catbird node)
+  #:use-module (catbird asset)
+  #:use-module (catbird cached-slots)
+  #:use-module (catbird config)
+  #:use-module (catbird mixins)
+  #:use-module (catbird observer)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 format)
+  #:use-module (oop goops)
+  #:export (<node>
+            in-view?
+            tree-in-view?
+            children
+            for-each-child
+            on-boot
+            reboot
+            child-ref &
+            attach-to
+            replace
+            blink)
+  #:re-export (agenda
+               detach
+               hide
+               name
+               parent
+               on-enter
+               on-hide
+               on-exit
+               on-pause
+               on-resume
+               on-show
+               pause
+               paused?
+               rank
+               render
+               resume
+               run-script
+               show
+               stop-scripts
+               visible?
+               update))
+
+(define-class <node>
+  (<renderable> <scriptable> <containable> <nameable> <rankable>
+                <observer> <asset-container>)
+  ;; An integer value that determines priority order for
+  ;; updating/rendering.
+  (rank #:getter rank #:init-value 0 #:init-keyword #:rank)
+  ;; List of children, sorted by rank.
+  (children #:accessor children #:init-value '())
+  ;; Children indexed by name for fast lookup.
+  (children-by-name #:getter children-by-name #:init-thunk make-hash-table))
+
+(define-method (initialize (node <node>) initargs)
+  (next-method)
+  (on-boot node))
+
+(define-method (on-boot (node <node>))
+  #t)
+
+(define-method (reboot (node <node>))
+  (for-each-child detach node)
+  (with-agenda (agenda node) (reset-agenda))
+  (on-boot node))
+
+(define-method (write (node <node>) port)
+  (define (strip-angle-brackets str)
+    (let ((start (if (string-prefix? "<" str) 1 0))
+          (end (if (string-suffix? ">" str)
+                   (- (string-length str) 1)
+                   (string-length str))))
+      (substring str start end)))
+  (format port "#<~a name: ~a>"
+          (strip-angle-brackets
+            (symbol->string
+             (class-name (class-of node))))
+          (name node)))
+
+(define (for-each-child proc node)
+  (for-each proc (children node)))
+
+(define-method (update/around (node <node>) dt)
+  (unless (paused? node)
+    ;; Update children first, recursively.
+    (for-each-child (lambda (child) (update/around child dt)) node)
+    (next-method)))
+
+(define-method (tree-in-view? (node <node>))
+  #t)
+
+(define-method (in-view? (node <node>))
+  #t)
+
+(define-method (render/around (node <node>) alpha)
+  (when (and (visible? node) (tree-in-view? node))
+    (next-method)
+    (for-each-child (lambda (child) (render/around child alpha)) node)))
+
+(define-method (child-ref (parent <node>) name)
+  (hashq-ref (children-by-name parent) name))
+
+(define-syntax &
+  (syntax-rules ()
+    ((_ parent child-name)
+     (child-ref parent 'child-name))
+    ((_ parent child-name . rest)
+     (& (child-ref parent 'child-name) . rest))))
+
+(define-method (attach-to (new-parent <node>) . new-children)
+  ;; Validate all the nodes first.  The whole operation will fail if
+  ;; any of them cannot be attached.
+  (for-each (lambda (child)
+              (when (parent child)
+                (raise-exception
+                 (make-exception-with-message "node already has a parent")))
+              (when (child-ref new-parent (name child))
+                (raise-exception
+                 (make-exception-with-message "node name taken"))))
+            new-children)
+  ;; Add named children to the name index for quick lookup later.
+  (for-each (lambda (child)
+              (when (name child)
+                (hashq-set! (children-by-name new-parent) (name child) child)))
+            new-children)
+  ;; Add the new children and sort them by their rank so that
+  ;; updating/rendering happens in the desired order.
+  (set! (children new-parent)
+        (sort-by-rank/ascending (append new-children (children new-parent))))
+  ;; Attach children to the parent, triggering initial enter/attach
+  ;; hooks.
+  (for-each (lambda (child)
+              (attach child new-parent))
+            new-children))
+
+(define-method (replace (parent-node <node>) . replacements)
+  (for-each (lambda (replacement)
+              (let ((old (child-ref parent-node (name replacement))))
+                (when old
+                  (detach old))))
+            replacements)
+  (apply attach-to parent-node replacements))
+
+(define-method (detach (node <node>))
+  (let ((p (parent node)))
+    ;; Remove child from parent.
+    (set! (children p) (delq node (children p)))
+    ;; Remove from name index.
+    (when (name node)
+      (hashq-remove! (children-by-name p) (name node)))
+    (next-method)))
+
+(define-method (blink (node <node>) times interval)
+  (let loop ((i 0))
+    (when (< i times)
+      (set! (visible? node) #f)
+      (sleep interval)
+      (set! (visible? node) #t)
+      (sleep interval)
+      (loop (+ i 1)))))
-- 
cgit v1.2.3