Initial commit.

1 files changed, 251 insertions, 0 deletions

diff --git a/engine/node.scm b/engine/node.scm
new file mode 100644
index 0000000..d95cfd9
--- /dev/null
+++ b/engine/node.scm
@@ -0,0 +1,251 @@
+;;; Lisp Game Jam 2018
+;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (engine node)
+  #:use-module (chickadee)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee math quaternion)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:export (<node>
+            name
+            parent
+            children
+            started?
+            active?
+            visible?
+            agenda
+            rank
+            each-child
+            activate
+            deactivate
+            update
+            update/children
+            draw
+            draw/children
+            on-start
+            on-enter
+            on-exit
+            on-quit
+            on-key-press
+            on-text-edit
+            child-ref
+            node-let
+            attach
+            detach
+            populate
+            root-node
+            set-root-node!
+            reset-root-node!
+            run-node))
+
+(define-syntax-rule (cons! item var)
+  (set! var (cons item var)))
+
+(define-class <node> ()
+  (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name)
+  (parent #:accessor parent #:init-form #f)
+  (children #:accessor children #:init-form '())
+  (children-map #:getter children-map #:init-form (make-hash-table))
+  (started? #:accessor started? #:init-form #f)
+  (active? #:accessor active? #:init-form #f)
+  (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?)
+  (agenda #:getter agenda #:init-form (make-agenda))
+  (rank #:getter rank #:init-value 0 #:init-keyword #:rank))
+
+(define (visit proc node)
+  "Apply PROC to NODE and all child nodes, recursively."
+  (with-agenda (agenda node) (proc node))
+  (for-each (cut visit proc <>) (children node)))
+
+(define (visit-while proc node)
+  "Apply PROC to NODE and all child nodes, recursively, stopping when
+PROC returns #f."
+  (and (with-agenda (agenda node) (proc node))
+       (let loop ((children (children node)))
+         (match children
+           (() #t)
+           ((head . tail)
+            (and (visit-while proc head)
+                 (loop tail)))))))
+
+(define (each-child proc node)
+  "Apply PROC to each child of NODE."
+  (for-each proc (children node)))
+
+(define-method (update/children (node <node>) dt)
+  "Update NODE, then update all children.  DT is the time-delta since
+the last update."
+  ;; Update children first.
+  (each-child (cut update/children <> dt) node)
+  ;; Update script, then "physics" (or whatever the update method is
+  ;; doing).
+  (with-agenda (agenda node)
+    (update-agenda 1)
+    (update node dt)))
+
+(define-method (draw/children (node <node>) alpha)
+  "Draw NODE, then draw all children.  ALPHA is a number between 0 and
+1 representing how far in between two updates the drawing is taking
+place."
+  (when (visible? node)
+    (draw node alpha)
+    (each-child (cut draw/children <> alpha) node)))
+
+(define-method (activate (node <node>))
+  "Start scripts for NODE and all its children."
+  (with-agenda (agenda node)
+    (unless (started? node)
+      (on-start node)
+      (set! (started? node) #t))
+    (on-enter node)
+    (set! (active? node) #t))
+  (each-child activate node))
+
+(define-method (deactivate (node <node>))
+  "Stop scripts for NODE and all its children."
+  (on-exit node)
+  (set! (active? node) #f)
+  (with-agenda (agenda node)
+    (reset-agenda))
+  (each-child deactivate node))
+
+(define-method (update (node <node>) dt) #t)
+(define-method (draw (node <node>) alpha) #t)
+(define-method (on-start (node <node>)) #t)
+(define-method (on-enter (node <node>)) #t)
+(define-method (on-exit (node <node>)) #t)
+(define-method (on-quit (node <node>)) #t)
+(define-method (on-key-press (node <node>) key modifiers repeat?) #t)
+(define-method (on-text-edit (node <node>) text) #t)
+
+(define-method (child-ref (node <node>) child-path)
+  "Return child node of NODE named CHILD-NAME, or #f if there isn't
+one."
+  (define (lookup node child-name)
+    (hashq-ref (children-map node) child-name))
+  (match child-path
+    ((or (child-name) (? symbol? child-name))
+     (lookup node child-name))
+    ((child-name . rest)
+     (child-ref (lookup node child-name) rest))))
+
+(define-syntax-rule (node-let node ((var child-name) ...) body ...)
+  (let ((var (child-ref node 'child-name)) ...)
+    body ...))
+
+(define-method (attach (new-parent <node>) . new-children)
+  "Attach NEW-CHILDREN to NEW-PARENT."
+  ;; Validate all children first, then add them to the parent node.
+  (for-each (lambda (child)
+              (when (parent child)
+                (error "node already has a parent:" child))
+              (when (child-ref new-parent (name child))
+                (error "node name taken:" (name child))))
+            new-children)
+  (set! (children new-parent)
+        (sort (append new-children (children new-parent))
+              (lambda (a b)
+                (< (rank a) (rank b)))))
+  (for-each (lambda (child)
+              (set! (parent child) new-parent)
+              (when (active? new-parent)
+                (activate child))
+              (hashq-set! (children-map new-parent) (name child) child))
+            new-children))
+
+(define-method (detach . nodes)
+  "Detach NODE from its parent."
+  (for-each (lambda (node)
+              (let ((parent (parent node)))
+                (unless parent
+                  (error "node has no parent" node))
+                (set! (children parent) (delq node (children parent)))
+                (hashq-remove! (children-map parent) (name node))
+                (when (active? node)
+                  (deactivate node)))
+              (set! (parent node) #f))
+            nodes))
+
+(define-method (populate (node <node>))
+  '())
+
+(define-method (initialize (node <node>) args)
+  (let ((children (let loop ((args args))
+                    (match args
+                      (() '())
+                      ((#:children children . _)
+                       children)
+                      ((key value . rest)
+                       (loop rest))))))
+    (next-method)
+    (apply attach node (append (populate node) children))))
+
+
+;;;
+;;; State management
+;;;
+
+(define *root-node* #f)
+
+(define (root-node)
+  "Return the current root node."
+  *root-node*)
+
+(define (set-root-node! new-root)
+  "Change the root node to NEW-ROOT."
+  (set! *root-node* new-root)
+  (activate new-root))
+
+(define (reset-root-node!)
+  "Restart the currently active node."
+  (deactivate (root-node))
+  (set-root-node! (root-node)))
+
+(define* (run-node make-root-node
+                   #:key
+                   (window-title "Chickadee Engine")
+                   (window-width 640)
+                   (window-height 480)
+                   window-fullscreen?
+                   (update-hz 60))
+  (add-hook! load-hook
+             (lambda ()
+               (set-root-node! (make-root-node))))
+  (add-hook! draw-hook (cut draw/children *root-node* <>))
+  (add-hook! update-hook (cut update/children *root-node* <>))
+  (add-hook! quit-hook
+             (lambda ()
+               (visit-while (cut on-quit <>) *root-node*)))
+  (add-hook! key-press-hook
+             (lambda (key sc mods repeat?)
+               (visit-while (cut on-key-press <> key mods repeat?)
+                            *root-node*)))
+  (add-hook! text-input-hook
+             (lambda (text)
+               (visit-while (cut on-text-edit <> text)
+                            *root-node*)))
+  (run-game #:window-title window-title
+            #:window-width window-width
+            #:window-height window-height
+            #:window-fullscreen? window-fullscreen?
+            #:update-hz update-hz))