(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)
  #:replace (pause))

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