path: root/starling/node.scm

;;; Starling Game Engine
;;; Copyright © 2018-2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; 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 (ice-9 format)
  #:use-module (oop goops)
  #:use-module (starling asset)
  #:use-module (starling config)
  #:export (<meta-node>
            <developer-meta-node>
            <node>
            name
            rank
            parent
            children
            agenda
            booted?
            active?
            visible?
            paused?
            for-each-child
            on-change
            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
            replace
            detach
            run-script
            stop-scripts
            blink)
  #:replace (pause))

(define-class <meta-node> (<class>))

(define-method (asset-slot? (slot <slot>))
  (get-keyword #:asset? (slot-definition-options slot)))

(define-method (watch-slot? (slot <slot>))
  (get-keyword #:watch? (slot-definition-options slot)))

(define-method (compute-getter-method (class <meta-node>) slot)
  (if (asset-slot? slot)
      ;; Wrap the original getter procedure with a new procedure that
      ;; extracts the current value from the asset object.
      (make <method>
        #:specializers (list class)
        #:procedure (let ((slot-name (slot-definition-name slot))
                          (proc (method-procedure (next-method))))
                      (lambda (obj)
                        (let ((value (proc obj)))
                          (if (is-a? value <asset>)
                              (asset-ref value)
                              value)))))
      (next-method)))

(define-generic on-change)

(define-method (compute-setter-method (class <meta-node>) slot)
  (if (watch-slot? slot)
      ;; Wrap the original setter procedure with a new procedure that
      ;; calls the on-change method.
      (make <method>
        #:specializers (list class <top>)
        #:procedure (let ((slot-name (slot-definition-name slot))
                          (proc (method-procedure (next-method))))
                      (lambda (obj new)
                        (let ((old (and (slot-bound? obj slot-name)
                                        (slot-ref obj slot-name))))
                          (proc obj new)
                          (on-change obj slot-name old new)))))
      (next-method)))

(define-class <developer-meta-node> (<meta-node> <redefinable-class>))

(define-method (compute-setter-method (class <developer-meta-node>) slot)
  (if (asset-slot? slot)
      ;; Wrap the original setter procedure with a new procedure that
      ;; manages asset update notifications.
      (make <method>
        #:specializers (list class <top>)
        #:procedure (let ((slot-name (slot-definition-name slot))
                          (proc (method-procedure (next-method))))
                      (lambda (obj new)
                        (let ((old (and (slot-bound? obj slot-name)
                                        (slot-ref obj slot-name))))
                          (when (is-a? old <asset>)
                            (remove-subscriber old obj slot-name))
                          (when (is-a? new <asset>)
                            (add-subscriber new obj slot-name))
                          (proc obj new)))))
      (next-method)))

(define-method (make (class <developer-meta-node>) . initargs)
  (let ((instance (next-method)))
    ;; Subscribe for updates to all asset slots.
    (for-each (lambda (slot)
                (when (asset-slot? slot)
                  (let* ((slot-name (slot-definition-name slot))
                         (value (and (slot-bound? instance slot-name)
                                     (slot-ref instance slot-name))))
                    (when (is-a? value <asset>)
                      (add-subscriber value instance slot-name)))))
              (class-slots class))
    instance))

(define make-id
  (let ((n -1))
    (lambda ()
      (set! n (+ n 1))
      n)))

(define-class <node> ()
  ;; Auto-generated process-unique identifier.  As of now I don't see
  ;; a need for globally unique identifiers and this is much faster.
  ;; Maybe if/when there's a serialization system this will need to be
  ;; more robust so as to preserve ids across processes.
  (id #:getter id #:init-thunk make-id)
  ;; Global index of all nodes by their unique id.
  (nodes-by-id #:getter nodes-by-id #:allocation #:class
               #:init-thunk make-weak-value-hash-table)
  ;; Symbolic name.  Used for easy lookup of children within a parent.
  (name #:getter name #:init-form #f #: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, sorted by rank.
  (children #:accessor children #:init-form '())
  ;; Children indexed by name for fast lookup.
  (children-by-name #:getter children-by-name #:init-thunk make-hash-table)
  ;; Script scheduler.
  (agenda #:getter agenda #:init-thunk 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?
                  <developer-meta-node>
                  <meta-node>))

(define-method (write (node <node>) port)
  (define (strip-angle-brackets str)
    (let ((start (if (string-prefix? "<" str) 1 0))
          (end (if (string-suffix? ">" str)
                   (- (string-length str) 1)
                   (string-length str))))
      (substring str start end)))
  (format port "#<~a name: ~a id: ~d>"
          (strip-angle-brackets
            (symbol->string
             (class-name (class-of node))))
          (name node)
          (id node)))

(define-method (initialize (node <node>) initargs)
  (next-method)
  ;; Add node to global index.
  (hashv-set! (nodes-by-id node) (id node) node)
  ;; Add children.
  (apply attach-to node (get-keyword #:children initargs '())))

(define (for-each-child proc node)
  (for-each proc (children node)))


;;;
;;; Life cycle event handlers
;;;

(define-method (update (node <node>) dt)
  #t)

(define-method (update-tree (node <node>) dt)
  (unless (or (paused? node) (not (booted? 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 dt)
                 (update node dt))))

(define-method (render (node <node>) alpha)
  #t)

(define-method (render-tree (node <node>) alpha)
  (when (visible? node)
    (render node alpha)
    (for-each-child (lambda (child) (render-tree child alpha)) node)))

(define-method (on-boot (node <node>))
  #t)

(define-method (on-enter (node <node>))
  #t)

(define-method (on-exit (node <node>))
  #t)

(define-method (on-asset-reload (node <node>) slot-name asset)
  #t)


;;;
;;; Life cycle state management
;;;

(define-method (boot (node <node>))
  (unless (booted? node)
    (set! (booted? node) #t)
    (on-boot node)))

(define-method (reboot (node <node>))
  (define (do-reboot)
    (for-each-child detach 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>))
  ;; First time activating?  We must boot!
  (unless (booted? node) (boot node))
  (set! (active? node) #t)
  (for-each-child activate node)
  ;; Activate all children, recursively, before calling on-enter hook.
  (on-enter node))

(define-method (deactivate (node <node>))
  (set! (active? node) #f)
  (on-exit node)
  (for-each-child deactivate node))

(define-method (show (node <node>))
  (set! (visible? node) #t))

(define-method (hide (node <node>))
  (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)
  (hashq-ref (children-by-name 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)
  ;; 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)
  ;; Add the new 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 rank and
  ;; name indexes for quick lookup later.
  (for-each (lambda (child)
              (set! (parent child) new-parent)
              ;; Add to name index.
              (when (name child)
                (hashq-set! (children-by-name new-parent) (name child) child))
              ;; If the parent is booted or active, that means the new
              ;; children must also be booted or activated.
              (when (booted? new-parent)
                (boot child))
              (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 (replace (parent-node <node>) . replacements)
  (for-each (lambda (replacement)
              (let ((old (child-ref parent-node (name replacement))))
                (when old
                  (detach old))))
            replacements)
  (apply attach-to parent-node replacements))

(define-method (detach (node <node>))
  (let ((p (parent node)))
    (when p
      ;; Remove child from parent.
      (set! (children p) (delq node (children p)))
      ;; Remove from name index.
      (when (name node)
        (hashq-remove! (children-by-name p) (name node)))
      ;; Detaching deactivates the node and all of its children.
      (when (active? node)
        (deactivate node))
      (set! (parent node) #f)
      (on-detach p node))))

(define-method (detach . nodes)
  (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)))))