path: root/starling/node.scm

;;; Starling Game Engine
;;; 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 Starling.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Base class for all game objects.
;;
;;; Code:

(define-module (starling node)
  #:use-module (chickadee scripting)
  #:use-module (oop goops)
  #:export (<node>
            name
            rank
            parent
            children
            agenda
            booted?
            active?
            visible?
            on-boot
            on-enter
            on-exit
            activate
            deactivate
            show
            hide
            update
            update*
            render
            render*
            child-ref
            &
            attach-to
            detach
            blink))

(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 #:getter 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?)
  ;; So that live coding works nicely...
  #:metaclass <redefinable-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* (node <node>) dt)
  "Update NODE and all of its children.  DT is the amount of time
passed since the last update, in milliseconds."
  ;; Update children first, recursively.
  (for-each-child (lambda (child) (update* child 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 (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* (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* 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 (activate (node <node>))
  "Mark NODE and all of its children as active."
  ;; First time activating?  We must boot!
  (with-agenda (agenda node)
    (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."
  (with-agenda (agenda node)
    (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))


;;;
;;; 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 (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))

(define-method (detach (node <node>))
  "Detach NODE from its parent."
  (let ((p (parent node)))
    (unless p
      (error "node has no parent" node))
    (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)))

(define-method (detach . nodes)
  "Detach all NODES from their respective parents."
  (for-each detach nodes))


;;;
;;; Simple Script Actions
;;;

(define-method (blink (node <node>) times interval)
  (let ((orig (visible? node)))
    (let loop ((i 0))
      (when (< i times)
        (set! (visible? node) #f)
        (sleep interval)
        (set! (visible? node) #t)
        (sleep interval)
        (loop (+ i 1))))
    (set! (visible? node) orig)))