path: root/catbird/node.scm

;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Catbird 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.
;;;
;;; Catbird 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 Catbird.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Base game node class.
;;
;;; Code:
(define-module (catbird node)
  #:use-module (catbird asset)
  #:use-module (catbird cached-slots)
  #:use-module (catbird config)
  #:use-module (catbird mixins)
  #:use-module (catbird observer)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 format)
  #:use-module (oop goops)
  #:export (<node>
            in-view?
            tree-in-view?
            children
            for-each-child
            on-boot
            pick
            reboot
            child-ref &
            attach-to
            replace
            blink)
  #:re-export (agenda
               detach
               hide
               name
               parent
               on-change
               on-enter
               on-hide
               on-exit
               on-pause
               on-resume
               on-show
               pause
               paused?
               rank
               render
               resume
               run-script
               show
               stop-scripts
               visible?
               update))

(define-class <node>
  (<renderable> <scriptable> <containable> <nameable> <rankable>
                <observer> <listener> <asset-container>)
  ;; An integer value that determines priority order for
  ;; updating/rendering.
  (rank #:accessor rank #:init-value 0 #:init-keyword #:rank #:observe? #t)
  ;; List of children, sorted by rank.
  (children #:accessor children #:init-value '())
  ;; Children indexed by name for fast lookup.
  (children-by-name #:getter children-by-name #:init-thunk make-hash-table))

(define-method (initialize (node <node>) initargs)
  (next-method)
  (apply attach-to node (get-keyword #:children initargs '()))
  (on-boot node))

(define-method (sort-children (node <node>))
  (set! (children node) (sort-by-rank/ascending (children node))))

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

(define-method (on-change (node <node>) slot-name old new)
  (case slot-name
    ((rank)
     ;; Re-sort parent when rank of child node changes.
     (and=> (parent node) sort-children))))

(define-method (reboot (node <node>))
  (for-each-child detach node)
  (with-agenda (agenda node) (reset-agenda))
  (on-boot 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>"
          (strip-angle-brackets
            (symbol->string
             (class-name (class-of node))))
          (name node)))

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

(define-method (update/around (node <node>) dt)
  (unless (paused? node)
    ;; Update children first, recursively.
    (for-each-child (lambda (child) (update/around child dt)) node)
    (next-method)))

(define-method (tree-in-view? (node <node>))
  #t)

(define-method (in-view? (node <node>))
  #t)

(define-method (render/around (node <node>) alpha)
  (when (and (visible? node) (tree-in-view? node))
    (next-method)
    (for-each-child (lambda (child) (render/around child alpha)) node)))

(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 (attach-to (new-parent <node>) . new-children)
  ;; Validate all the nodes first.  The whole operation will fail if
  ;; any of them cannot be attached.
  (for-each (lambda (child)
              (when (parent child)
                (raise-exception
                 (make-exception-with-message "node already has a parent")))
              (when (child-ref new-parent (name child))
                (raise-exception
                 (make-exception-with-message "node name taken"))))
            new-children)
  ;; Add named children to the name index for quick lookup later.
  (for-each (lambda (child)
              (when (name child)
                (hashq-set! (children-by-name new-parent) (name child) 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) (append new-children (children new-parent)))
  (sort-children new-parent)
  ;; Attach children to the parent, triggering initial enter/attach
  ;; hooks.
  (for-each (lambda (child)
              (attach child new-parent))
            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)))
    ;; 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)))
    (next-method)))

(define-method (send (node <node>) message . args)
  ;; Move up the tree to look for a handler for the message if the
  ;; current node does not handle or consume the message.
  (or (next-method)
      (let ((p (parent node)))
        (and p (apply send p message args)))))

;; The base node class has no spatial awareness, so all attempts to
;; pick such a node will fail.
(define-method (pick (node <node>) p)
  #f)

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