;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; 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
            pick
            child-ref &
            attach-to
            replace
            clear
            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 '())))

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

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

;; Optimized recursive update that does not allocate a closure.
(define (update-nodes nodes dt)
  (unless (null? nodes)
    (update/around (car nodes) dt)
    (update-nodes (cdr nodes) dt)))

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

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

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

;; Optimized recursive render that does not allocate a closure.
(define (render-nodes nodes alpha)
  (unless (null? nodes)
    (render/around (car nodes) alpha)
    (render-nodes (cdr nodes) alpha)))

(define-method (render/around (node <node>) alpha)
  (when (and (visible? node) (tree-in-view? node))
    (next-method)
    (render-nodes (children node) alpha)))

(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 (clear (node <node>))
  (for-each detach (children node)))

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