;;; 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:
;;
;; Game scenes encapsulate a tree of nodes and the state machine
;; (modes) that manipulate those nodes to create a playable game.
;;
;;; Code:
(define-module (catbird scene)
  #:use-module (catbird config)
  #:use-module (catbird mixins)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:export (<scene>
            current-scene
            with-scene
            add-to-scene
            scene-script
            $
            regions
            major-mode
            minor-modes
            replace-major-mode
            push-major-mode
            pop-major-mode
            add-minor-mode
            remove-minor-mode))

(define-root-class <scene> (<node>)
  (regions #:accessor regions #:init-value '())
  (major-mode #:accessor major-mode #:init-keyword #:major-mode
              #:init-form (make <nothing-mode>))
  (major-mode-stack #:getter major-mode-stack #:init-thunk make-array-list)
  (minor-modes #:accessor minor-modes #:init-value '())
  (input-map #:getter input-map #:init-value '()))

(define current-scene (make-parameter #f))

(define-syntax-rule (with-scene scene body ...)
  (parameterize ((current-scene scene)) body ...))

(define-syntax $
  (syntax-rules ()
    ((_) (current-scene))
    ((_ names ...)
     (& (current-scene) names ...))))

(define-method (add-to-scene . nodes)
  (apply attach-to (current-scene) nodes))

(define-syntax-rule (scene-script body ...)
  (run-script (current-scene) body ...))

(define-method (initialize (scene <scene>) args)
  (next-method)
  (with-scene scene
    (attach (major-mode scene) scene)))

(define-method (replace-major-mode (scene <scene>) (mode <major-mode>))
  (let ((old-mode (major-mode scene)))
    (when old-mode
      (detach old-mode))
    (set! (major-mode scene) mode)
    (attach mode scene)))

(define-method (replace-major-mode (mode <major-mode>))
  (replace-major-mode (current-scene) mode))

(define-method (push-major-mode (scene <scene>) (mode <major-mode>))
  (let ((old-mode (major-mode scene)))
    (array-list-push! (major-mode-stack scene) old-mode)
    (when old-mode
      (pause old-mode))
    (set! (major-mode scene) mode)
    (attach mode scene)))

(define-method (push-major-mode (mode <major-mode>))
  (push-major-mode (current-scene) mode))

(define-method (pop-major-mode (scene <scene>))
  (let ((stack (major-mode-stack scene)))
    (unless (array-list-empty? stack)
      (let ((mode (major-mode scene))
            (prev-mode (array-list-pop! stack)))
        (when mode
          (detach mode))
        (set! (major-mode scene) prev-mode)
        (resume prev-mode)))))

(define-method (pop-major-mode)
  (pop-major-mode (current-scene)))

(define-method (add-minor-mode (scene <scene>) (mode <minor-mode>))
  (when (parent mode)
    (raise-exception
     (make-exception-with-message "mode already attached to a scene")))
  (set! (minor-modes scene) (cons mode (minor-modes scene)))
  (attach mode scene))

(define-method (add-minor-mode (mode <minor-mode>))
  (add-minor-mode (current-scene) mode))

(define-method (remove-minor-mode (scene <scene>) (mode <minor-mode>))
  (unless (eq? scene (parent mode))
    (raise-exception
     (make-exception-with-message "mode not attached to scene")))
  (let ((modes (minor-modes scene)))
    (set! (minor-modes scene) (delq mode modes))
    (detach mode)))

(define-method (remove-minor-mode (mode <minor-mode>))
  (remove-minor-mode (current-scene) mode))

(define-method (remove-minor-mode (scene <scene>) (mode-class <class>))
  (with-scene scene
    (let ((mode (find (lambda (mode)
                        (eq? (class-of mode) mode-class))
                      (minor-modes scene))))
      (when mode
        (remove-minor-mode scene mode)))))

(define-method (search-modes (scene <scene>) proc)
  (with-scene scene
    (or (proc (major-mode scene))
        (find (lambda (mode)
                (proc mode))
              (minor-modes scene)))))

(define-method (on-key-press (scene <scene>) key modifiers)
  (search-modes scene
                (lambda (mode)
                  (on-key-press mode key modifiers))))

(define-method (on-key-release (scene <scene>) key modifiers)
  (search-modes scene
                (lambda (mode)
                  (on-key-release mode key modifiers))))

(define-method (on-text-input (scene <scene>) text)
  (search-modes scene
                (lambda (mode)
                  (on-text-input mode text))))

(define-method (on-mouse-press (scene <scene>) button x y)
  (search-modes scene
                (lambda (mode)
                  (on-mouse-press mode button x y))))

(define-method (on-mouse-release (scene <scene>) button x y)
  (search-modes scene
                (lambda (mode)
                  (on-mouse-release mode button x y))))

(define-method (on-mouse-move (scene <scene>) x y x-rel y-rel buttons)
  (search-modes scene
                (lambda (mode)
                  (on-mouse-move mode x y x-rel y-rel buttons))))

(define-method (on-mouse-wheel (scene <scene>) x y)
  (search-modes scene
                (lambda (mode)
                  (on-mouse-wheel mode x y))))

(define-method (on-controller-press (scene <scene>) controller-id button)
  (search-modes scene
                (lambda (mode)
                  (on-controller-press mode controller-id button))))

(define-method (on-controller-release (scene <scene>) controller-id button)
  (search-modes scene
                (lambda (mode)
                  (on-controller-release mode controller-id button))))

(define-method (on-controller-move (scene <scene>) controller-id axis value)
  (search-modes scene
                (lambda (mode)
                  (on-controller-move mode controller-id axis value))))

(define-method (update (scene <scene>) dt)
  (with-scene scene
    (update (major-mode scene) dt)
    (for-each (lambda (mode) (update mode dt))
              (minor-modes scene))))

(define-method (pause (scene <scene>))
  (for-each-child pause scene)
  (next-method))

(define-method (resume (scene <scene>))
  (for-each-child resume scene)
  (next-method))

(define-method (width (scene <scene>))
  (fold (lambda (r w) (max w (width r))) 0.0 (regions scene)))

(define-method (height (scene <scene>))
  (fold (lambda (r h) (max h (height r))) 0.0 (regions scene)))

(define-method (pick (scene <scene>) p)
  (let loop ((kids (children scene)))
    (match kids
      (() #f)
      ((node . rest)
       (or (pick node p)
           (loop rest))))))