From 2c5b19226815a406c60cc1a49c59864922364c55 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 10 Apr 2020 08:55:50 -0400 Subject: Add project skeleton and import engine code. --- lisparuga/node.scm | 281 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 281 insertions(+) create mode 100644 lisparuga/node.scm (limited to 'lisparuga/node.scm') 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 +;;; +;;; 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 . + +;;; 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 ( + 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 () + ;; 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? + + )) + +(define (for-each-child proc node) + (for-each proc (children node))) + + +;;; +;;; Life cycle event handlers +;;; + +(define-method (update (node ) dt) + "Advance simulation of NODE by the time delta DT." + #t) + +(define-method (update-tree (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 ) 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 ) 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 )) + "Perform initialization tasks for NODE." + #t) + +(define-method (on-enter (node )) + "Perform task now that NODE has entered the current scene." + #t) + +(define-method (on-exit (node )) + "Perform task now that NODE has left the current scene." + #t) + + +;;; +;;; Life cycle state management +;;; + +(define-method (boot (node )) + "Prepare NODE to enter the game world for the first time." + (set! (booted? node) #t) + (on-boot node)) + +(define-method (reboot (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 )) + "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 )) + "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 )) + "Mark NODE as visible." + (set! (visible? node) #t)) + +(define-method (hide (node )) + "Mark NODE as invisible." + (set! (visible? node) #f)) + +(define-method (pause (node )) + (set! (paused? node) #t)) + +(define-method (resume (node )) + (set! (paused? node) #f)) + + +;;; +;;; Child management +;;; + +(define-method (child-ref (parent ) 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 ) (child )) + #t) + +(define-method (on-detach (parent ) (child )) + #t) + +(define-method (attach-to (new-parent ) . 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 )) + "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 ) 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