path: root/lisparuga/node.scm

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