;;; Lisp Game Jam 2018
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;;
;;; 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 this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (engine node)
  #:use-module (chickadee)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math quaternion)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:export (<node>
            name
            parent
            children
            started?
            active?
            visible?
            agenda
            rank
            each-child
            activate
            deactivate
            update
            update/children
            draw
            draw/children
            on-start
            on-enter
            on-exit
            on-quit
            on-key-press
            on-text-edit
            child-ref
            node-let
            attach
            detach
            populate
            root-node
            set-root-node!
            reset-root-node!
            run-node))

(define-syntax-rule (cons! item var)
  (set! var (cons item var)))

(define-class <node> ()
  (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name)
  (parent #:accessor parent #:init-form #f)
  (children #:accessor children #:init-form '())
  (children-map #:getter children-map #:init-form (make-hash-table))
  (started? #:accessor started? #:init-form #f)
  (active? #:accessor active? #:init-form #f)
  (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?)
  (agenda #:getter agenda #:init-form (make-agenda))
  (rank #:getter rank #:init-value 0 #:init-keyword #:rank))

(define (visit proc node)
  "Apply PROC to NODE and all child nodes, recursively."
  (with-agenda (agenda node) (proc node))
  (for-each (cut visit proc <>) (children node)))

(define (visit-while proc node)
  "Apply PROC to NODE and all child nodes, recursively, stopping when
PROC returns #f."
  (and (with-agenda (agenda node) (proc node))
       (let loop ((children (children node)))
         (match children
           (() #t)
           ((head . tail)
            (and (visit-while proc head)
                 (loop tail)))))))

(define (each-child proc node)
  "Apply PROC to each child of NODE."
  (for-each proc (children node)))

(define-method (update/children (node <node>) dt)
  "Update NODE, then update all children.  DT is the time-delta since
the last update."
  ;; Update children first.
  (each-child (cut update/children <> dt) node)
  ;; Update script, then "physics" (or whatever the update method is
  ;; doing).
  (with-agenda (agenda node)
    (update-agenda 1)
    (update node dt)))

(define-method (draw/children (node <node>) alpha)
  "Draw NODE, then draw all children.  ALPHA is a number between 0 and
1 representing how far in between two updates the drawing is taking
place."
  (when (visible? node)
    (draw node alpha)
    (each-child (cut draw/children <> alpha) node)))

(define-method (activate (node <node>))
  "Start scripts for NODE and all its children."
  (with-agenda (agenda node)
    (unless (started? node)
      (on-start node)
      (set! (started? node) #t))
    (on-enter node)
    (set! (active? node) #t))
  (each-child activate node))

(define-method (deactivate (node <node>))
  "Stop scripts for NODE and all its children."
  (on-exit node)
  (set! (active? node) #f)
  (with-agenda (agenda node)
    (reset-agenda))
  (each-child deactivate node))

(define-method (update (node <node>) dt) #t)
(define-method (draw (node <node>) alpha) #t)
(define-method (on-start (node <node>)) #t)
(define-method (on-enter (node <node>)) #t)
(define-method (on-exit (node <node>)) #t)
(define-method (on-quit (node <node>)) #t)
(define-method (on-key-press (node <node>) key modifiers repeat?) #t)
(define-method (on-text-edit (node <node>) text) #t)

(define-method (child-ref (node <node>) child-path)
  "Return child node of NODE named CHILD-NAME, or #f if there isn't
one."
  (define (lookup node child-name)
    (hashq-ref (children-map node) child-name))
  (match child-path
    ((or (child-name) (? symbol? child-name))
     (lookup node child-name))
    ((child-name . rest)
     (child-ref (lookup node child-name) rest))))

(define-syntax-rule (node-let node ((var child-name) ...) body ...)
  (let ((var (child-ref node 'child-name)) ...)
    body ...))

(define-method (attach (new-parent <node>) . new-children)
  "Attach NEW-CHILDREN to NEW-PARENT."
  ;; Validate all children first, then add them to the parent node.
  (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)
  (set! (children new-parent)
        (sort (append new-children (children new-parent))
              (lambda (a b)
                (< (rank a) (rank b)))))
  (for-each (lambda (child)
              (set! (parent child) new-parent)
              (when (active? new-parent)
                (activate child))
              (hashq-set! (children-map new-parent) (name child) child))
            new-children))

(define-method (detach . nodes)
  "Detach NODE from its parent."
  (for-each (lambda (node)
              (let ((parent (parent node)))
                (unless parent
                  (error "node has no parent" node))
                (set! (children parent) (delq node (children parent)))
                (hashq-remove! (children-map parent) (name node))
                (when (active? node)
                  (deactivate node)))
              (set! (parent node) #f))
            nodes))

(define-method (populate (node <node>))
  '())

(define-method (initialize (node <node>) args)
  (let ((children (let loop ((args args))
                    (match args
                      (() '())
                      ((#:children children . _)
                       children)
                      ((key value . rest)
                       (loop rest))))))
    (next-method)
    (apply attach node (append (populate node) children))))


;;;
;;; State management
;;;

(define *root-node* #f)

(define (root-node)
  "Return the current root node."
  *root-node*)

(define (set-root-node! new-root)
  "Change the root node to NEW-ROOT."
  (set! *root-node* new-root)
  (activate new-root))

(define (reset-root-node!)
  "Restart the currently active node."
  (deactivate (root-node))
  (set-root-node! (root-node)))

(define* (run-node make-root-node
                   #:key
                   (window-title "Chickadee Engine")
                   (window-width 640)
                   (window-height 480)
                   window-fullscreen?
                   (update-hz 60))
  (add-hook! load-hook
             (lambda ()
               (set-root-node! (make-root-node))))
  (add-hook! draw-hook (cut draw/children *root-node* <>))
  (add-hook! update-hook (cut update/children *root-node* <>))
  (add-hook! quit-hook
             (lambda ()
               (visit-while (cut on-quit <>) *root-node*)))
  (add-hook! key-press-hook
             (lambda (key sc mods repeat?)
               (visit-while (cut on-key-press <> key mods repeat?)
                            *root-node*)))
  (add-hook! text-input-hook
             (lambda (text)
               (visit-while (cut on-text-edit <> text)
                            *root-node*)))
  (run-game #:window-title window-title
            #:window-width window-width
            #:window-height window-height
            #:window-fullscreen? window-fullscreen?
            #:update-hz update-hz))