;;; 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:
;;
;; 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 (catbird pushdown)
  #: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-state #:getter major-mode-state #:init-thunk make-pushdown-state)
  (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
    (replace-major-mode scene (make <nothing-mode>))))

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

(define-method (replace-major-mode (scene <scene>) (mode <major-mode>))
  (let ((old-mode (major-mode scene)))
    (when old-mode
      (detach old-mode))
    (state-replace! (major-mode-state 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)))
    (when old-mode
      (pause old-mode))
    (state-push! (major-mode-state 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>))
  (when (state-previous (major-mode-state scene))
    (let ((mode (major-mode scene)))
      (when mode
        (detach mode))
      (resume (state-pop! (major-mode-state scene))))))

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