(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
            reboot
            child-ref &
            attach-to
            replace
            blink)
  #:re-export (agenda
               detach
               hide
               name
               parent
               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> <asset-container>)
  ;; An integer value that determines priority order for
  ;; updating/rendering.
  (rank #:getter rank #:init-value 0 #:init-keyword #:rank)
  ;; 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)
  (on-boot node))

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

(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)
        (sort-by-rank/ascending (append new-children (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 (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)))))