;;; 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:
;;
;; Fundamental mix-in classes.
;;
;;; Code:
(define-module (catbird mixins)
  #:use-module (catbird config)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 exceptions)
  #:use-module (oop goops)
  #:use-module (srfi srfi-9)
  #:export (<nameable>
            name

            <rankable>
            rank
            sort-by-rank/ascending

            <containable>
            parent
            attach
            detach
            on-enter
            on-exit
            on-attach
            on-detach

            <updatable>
            update
            update/around

            <scriptable>
            agenda
            on-pause
            on-resume
            paused?
            pause
            resume
            run-script
            stop-scripts

            <renderable>
            visible?
            on-show
            on-hide
            show
            hide
            render
            render/around
            render/before

            <movable-2d>
            <movable-3d>
            position
            position-x
            position-y
            position-y
            width
            height
            depth

            <listener>
            ignore
            listen
            responds-to?
            send)
  #:replace (listen pause send))

(define-class <nameable> ()
  (name #:accessor name #:init-keyword #:name #:init-value #f))

;; For Z sorting objects and such.
(define-class <rankable> ()
  (rank #:accessor rank #:init-keyword #:rank #:init-value 0))

(define (sort-by-rank/ascending lst)
  (sort lst
        (lambda (a b)
          (< (rank a) (rank b)))))


;;;
;;; Containable
;;;

(define-class <containable> ()
  (parent #:accessor parent #:init-form #f))

(define-method (on-enter (child <containable>))
  #t)

(define-method (on-exit (child <containable>))
  #t)

(define-method (on-attach parent (child <containable>))
  #t)

(define-method (on-detach parent (child <containable>))
  #t)

(define-method (attach (obj <containable>) container)
  (when (parent obj)
    (raise-exception
     (make-exception-with-message "object already has a parent")))
  (set! (parent obj) container)
  (on-enter obj)
  (on-attach container obj))

(define-method (detach (obj <containable>))
  (unless (parent obj)
    (raise-exception
     (make-exception-with-message "object has no parent")))
  (on-detach (parent obj) obj)
  (on-exit obj)
  (set! (parent obj) #f))


;;;
;;; Updatable
;;;

(define-class <updatable> ())

(define-method (update (obj <updatable>) dt)
  #t)

(define-method (update/around (obj <updatable>) dt)
  (update obj dt))


;;;
;;; Scriptable
;;;

(define-class <scriptable> (<updatable>)
  (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?)
  (agenda #:getter agenda #:init-thunk make-agenda))

(define-method (on-pause (obj <scriptable>))
  #t)

(define-method (on-resume (obj <scriptable>))
  #t)

(define-method (pause (obj <scriptable>))
  (unless (paused? obj)
    (set! (paused? obj) #t)
    (on-pause obj)))

(define-method (resume (obj <scriptable>))
  (when (paused? obj)
    (set! (paused? obj) #f)
    (on-resume obj)))

(define-method (update/around (obj <scriptable>) dt)
  (unless (paused? obj)
    (with-agenda (agenda obj)
      (update-agenda dt)
      (next-method))))

(define-syntax-rule (run-script obj body ...)
  (with-agenda (agenda obj) (script body ...)))

(define-method (stop-scripts obj)
  (with-agenda (agenda obj) (clear-agenda)))


;;;
;;; Renderable
;;;

(define-class <renderable> ()
  (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?))

(define-method (on-show (obj <renderable>))
  #t)

(define-method (on-hide (obj <renderable>))
  #t)

(define-method (show (obj <renderable>))
  (set! (visible? obj) #t)
  (on-show obj))

(define-method (hide (obj <renderable>))
  (set! (visible? obj) #f)
  (on-hide obj))

(define-method (render (obj <renderable>) alpha)
  #t)

(define-method (render/before (obj <renderable>) alpha)
  #t)

(define-method (render/around (obj <renderable>) alpha)
  (when (visible? obj)
    (render/before obj alpha)
    (render obj alpha)))


;;;
;;; Movable
;;;

(define-class <movable-2d> ()
  (position #:accessor position #:init-keyword #:position
            #:init-form (vec2 0.0 0.0)))

(define-class <movable-3d> ()
  (position #:accessor position #:init-keyword #:position
            #:init-form (vec3 0.0 0.0 0.0)))

(define-accessor position-x)
(define-accessor position-y)
(define-accessor position-z)
(define-accessor width)
(define-accessor height)
(define-accessor depth)



;;;
;;; Event listener
;;;

;; For per-instance message passing/event handling.
(define-class <listener> ()
  (event-handlers #:getter event-handlers #:init-thunk make-hash-table))

;; listen and send are built-in procedures, so make them generic.
(define-generic listen)
(define-generic send)

(define-method (listen (listener <listener>) message proc)
  (hashq-set! (event-handlers listener) message proc))

(define-method (ignore (listener <listener>) message)
  (hashq-remove! (event-handlers listener) message))

(define-method (event-handler (listener <listener>) message)
  (hashq-ref (event-handlers listener) message))

(define-method (responds-to? (listener <listener>) message)
  (procedure? (event-handler listener)))

(define-method (send (listener <listener>) message . args)
  (let ((handler (event-handler listener message)))
    (and (procedure? handler)
         (apply handler args))))