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

(limited to 'catbird/mixins.scm')

diff --git a/catbird/mixins.scm b/catbird/mixins.scm
new file mode 100644
index 0000000..8f4ec7c
--- /dev/null
+++ b/catbird/mixins.scm
@@ -0,0 +1,195 @@
+(define-module (catbird mixins)
+  #:use-module (catbird config)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 exceptions)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-9)
+  #:export (<nameable>
+            name
+
+            <rankable>
+            rank
+            sort-by-rank/ascending
+
+            <containable>
+            parent
+            attach
+            detach
+            on-enter
+            on-exit
+            on-attach
+            on-detach
+
+            <updatable>
+            update
+            update/around
+
+            <scriptable>
+            agenda
+            on-pause
+            on-resume
+            paused?
+            pause
+            resume
+            run-script
+            stop-scripts
+
+            <renderable>
+            visible?
+            on-show
+            on-hide
+            show
+            hide
+            render
+            render/around
+            render/before
+
+            <movable-2d>
+            <movable-3d>
+            position)
+  #:replace (pause))
+
+(define-class <nameable> ()
+  (name #:accessor name #:init-keyword #:name #:init-value #f))
+
+;; For Z sorting objects and such.
+(define-class <rankable> ()
+  (rank #:accessor rank #:init-keyword #:rank #:init-value 0))
+
+(define (sort-by-rank/ascending lst)
+  (sort lst
+        (lambda (a b)
+          (< (rank a) (rank b)))))
+
+
+;;;
+;;; Containable
+;;;
+
+(define-class <containable> ()
+  (parent #:accessor parent #:init-form #f))
+
+(define-method (on-enter (child <containable>))
+  #t)
+
+(define-method (on-exit (child <containable>))
+  #t)
+
+(define-method (on-attach parent (child <containable>))
+  #t)
+
+(define-method (on-detach parent (child <containable>))
+  #t)
+
+(define-method (attach (obj <containable>) container)
+  (when (parent obj)
+    (raise-exception
+     (make-exception-with-message "object already has a parent")))
+  (set! (parent obj) container)
+  (on-enter obj)
+  (on-attach container obj))
+
+(define-method (detach (obj <containable>))
+  (unless (parent obj)
+    (raise-exception
+     (make-exception-with-message "object has no parent")))
+  (on-detach (parent obj) obj)
+  (on-exit obj)
+  (set! (parent obj) #f))
+
+
+;;;
+;;; Updatable
+;;;
+
+(define-class <updatable> ())
+
+(define-method (update (obj <updatable>) dt)
+  #t)
+
+(define-method (update/around (obj <updatable>) dt)
+  (update obj dt))
+
+
+;;;
+;;; Scriptable
+;;;
+
+(define-class <scriptable> (<updatable>)
+  (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?)
+  (agenda #:getter agenda #:init-thunk make-agenda))
+
+(define-method (on-pause (obj <scriptable>))
+  #t)
+
+(define-method (on-resume (obj <scriptable>))
+  #t)
+
+(define-method (pause (obj <scriptable>))
+  (unless (paused? obj)
+    (set! (paused? obj) #t)
+    (on-pause obj)))
+
+(define-method (resume (obj <scriptable>))
+  (when (paused? obj)
+    (set! (paused? obj) #f)
+    (on-resume obj)))
+
+(define-method (update/around (obj <scriptable>) dt)
+  (unless (paused? obj)
+    (with-agenda (agenda obj)
+      (update-agenda dt)
+      (next-method))))
+
+(define-syntax-rule (run-script obj body ...)
+  (with-agenda (agenda obj) (script body ...)))
+
+(define-method (stop-scripts obj)
+  (with-agenda (agenda obj) (clear-agenda)))
+
+
+;;;
+;;; Renderable
+;;;
+
+(define-class <renderable> ()
+  (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?))
+
+(define-method (on-show (obj <renderable>))
+  #t)
+
+(define-method (on-hide (obj <renderable>))
+  #t)
+
+(define-method (show (obj <renderable>))
+  (set! (visible? obj) #t)
+  (on-show obj))
+
+(define-method (hide (obj <renderable>))
+  (set! (visible? obj) #f)
+  (on-hide obj))
+
+(define-method (render (obj <renderable>) alpha)
+  #t)
+
+(define-method (render/before (obj <renderable>) alpha)
+  #t)
+
+(define-method (render/around (obj <renderable>) alpha)
+  (when (visible? obj)
+    (render/before obj alpha)
+    (render obj alpha)))
+
+
+;;;
+;;; Movable
+;;;
+
+(define-class <movable-2d> ()
+  (position #:accessor position #:init-keyword #:position
+            #:init-form (vec2 0.0 0.0)))
+
+(define-class <movable-3d> ()
+  (position #:accessor position #:init-keyword #:position
+            #:init-form (vec3 0.0 0.0 0.0)))
-- 
cgit v1.2.3