diff options
Diffstat (limited to 'lisparuga/node.scm')
| -rw-r--r-- | lisparuga/node.scm | 281 |
1 files changed, 281 insertions, 0 deletions
diff --git a/lisparuga/node.scm b/lisparuga/node.scm new file mode 100644 index 0000000..2dbbd41 --- /dev/null +++ b/lisparuga/node.scm @@ -0,0 +1,281 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Base class for all game objects. +;; +;;; Code: + +(define-module (lisparuga node) + #:use-module (chickadee scripting) + #:use-module (oop goops) + #:use-module (lisparuga config) + #:export (<node> + name + rank + parent + children + agenda + booted? + active? + visible? + paused? + on-boot + on-enter + on-exit + reboot + activate + deactivate + show + hide + pause + resume + update + update-tree + render + render-tree + child-ref + & + on-attach + on-detach + attach-to + detach + run-script + stop-scripts + blink) + #:replace (pause)) + +(define-class <node> () + ;; Symbolic name. Used for easy lookup of children within a parent. + (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name) + ;; An integer value that determines priority order for + ;; updating/rendering. + (rank #:accessor rank #:init-value 0 #:init-keyword #:rank) + ;; The node that this node is attached to. A node may only have one + ;; parent. + (parent #:accessor parent #:init-form #f) + ;; List of children ordered by rank. + (children #:accessor children #:init-form '()) + ;; Children indexed by name for fast lookup. + (children-map #:getter children-map #:init-form (make-hash-table)) + ;; Script scheduler. + (agenda #:getter agenda #:init-form (make-agenda)) + ;; Flips to #t upon first entering a scene. + (booted? #:accessor booted? #:init-form #f) + ;; Flips to #t when node is part of current scene. + (active? #:accessor active? #:init-form #f) + ;; Determines whether or not the node and all of its children are + ;; rendered. + (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?) + ;; Determines whether or not updates happen. + (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?) + ;; Use redefinable classes when in dev mode. + #:metaclass (if developer-mode? + <redefinable-class> + <class>)) + +(define (for-each-child proc node) + (for-each proc (children node))) + + +;;; +;;; Life cycle event handlers +;;; + +(define-method (update (node <node>) dt) + "Advance simulation of NODE by the time delta DT." + #t) + +(define-method (update-tree (node <node>) dt) + "Update NODE and all of its children. DT is the amount of time +passed since the last update, in milliseconds." + (unless (paused? node) + ;; Update children first, recursively. + (for-each-child (lambda (child) (update-tree child dt)) node) + ;; Scripts take precedence over the update method. + (with-agenda (agenda node) + (update-agenda 1) + (update node dt)))) + +(define-method (render (node <node>) alpha) + "Render NODE. ALPHA is the distance between the previous update and +the next update represented as a ratio in the range [0, 1]." + #t) + +(define-method (render-tree (node <node>) alpha) + "Render NODE and all of its children, recursively. +ALPHA is the distance between the previous update and the next update +represented as a ratio in the range [0, 1]." + (when (visible? node) + (render node alpha) + (for-each-child (lambda (child) (render-tree child alpha)) node))) + +(define-method (on-boot (node <node>)) + "Perform initialization tasks for NODE." + #t) + +(define-method (on-enter (node <node>)) + "Perform task now that NODE has entered the current scene." + #t) + +(define-method (on-exit (node <node>)) + "Perform task now that NODE has left the current scene." + #t) + + +;;; +;;; Life cycle state management +;;; + +(define-method (boot (node <node>)) + "Prepare NODE to enter the game world for the first time." + (set! (booted? node) #t) + (on-boot node)) + +(define-method (reboot (node <node>)) + (define (do-reboot) + (for-each detach (children node)) + (with-agenda (agenda node) (reset-agenda)) + (on-boot node)) + (cond + ;; Never booted before, so do nothing. + ((not (booted? node)) + #t) + ;; Currently active, so reactivate after reboot. + ((active? node) + (do-reboot) + (activate node)) + ;; Not active. + (else + (do-reboot)))) + +(define-method (activate (node <node>)) + "Mark NODE and all of its children as active." + ;; First time activating? We must boot! + (unless (booted? node) (boot node)) + (set! (active? node) #t) + (on-enter node) + (for-each-child activate node)) + +(define-method (deactivate (node <node>)) + "Mark NODE and all of its children as inactive." + (set! (active? node) #f) + (on-exit node) + (for-each-child deactivate node)) + +(define-method (show (node <node>)) + "Mark NODE as visible." + (set! (visible? node) #t)) + +(define-method (hide (node <node>)) + "Mark NODE as invisible." + (set! (visible? node) #f)) + +(define-method (pause (node <node>)) + (set! (paused? node) #t)) + +(define-method (resume (node <node>)) + (set! (paused? node) #f)) + + +;;; +;;; Child management +;;; + +(define-method (child-ref (parent <node>) name) + "Return the child node of PARENT whose name is NAME." + (hashq-ref (children-map 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 (on-attach (parent <node>) (child <node>)) + #t) + +(define-method (on-detach (parent <node>) (child <node>)) + #t) + +(define-method (attach-to (new-parent <node>) . new-children) + "Attach NEW-CHILDREN to NEW-PARENT." + ;; Validate all children first. The whole operation will fail if + ;; any of them cannot be attached. + (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) + ;; Adopt the children and sort them by their rank so that + ;; updating/rendering happens in the desired order. + (set! (children new-parent) + (sort (append new-children (children new-parent)) + (lambda (a b) + (< (rank a) (rank b))))) + ;; Mark the children as having parents and add them to the name + ;; index for quick lookup later. + (for-each (lambda (child) + (set! (parent child) new-parent) + (hashq-set! (children-map new-parent) (name child) child) + ;; If the parent is active, that means the new children + ;; must also be active. + (when (active? new-parent) + (activate child))) + new-children) + ;; Notify parent of attach event. + (for-each (lambda (child) + (on-attach new-parent child)) + new-children)) + +(define-method (detach (node <node>)) + "Detach NODE from its parent." + (let ((p (parent node))) + (when p + (set! (children p) (delq node (children p))) + (hashq-remove! (children-map p) (name node)) + ;; Detaching deactives the node and all of its children. + (when (active? node) + (deactivate node)) + (set! (parent node) #f) + (on-detach p node)))) + +(define-method (detach . nodes) + "Detach all NODES from their respective parents." + (for-each detach nodes)) + + +;;; +;;; Scripting +;;; + +(define-syntax-rule (run-script node body ...) + (with-agenda (agenda node) (script body ...))) + +(define-method (stop-scripts node) + (with-agenda (agenda node) (clear-agenda))) + +(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))))) |