;;; 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:
;;
;; Manager of the Catbird game engine.
;;
;;; Code:
(define-module (catbird kernel)
  #:use-module (catbird asset)
  #:use-module (catbird camera)
  #:use-module (catbird config)
  #:use-module (catbird input-map)
  #:use-module (catbird mixins)
  #:use-module (catbird mode)
  #:use-module (catbird region)
  #:use-module (catbird scene)
  #:use-module (chickadee)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee math rect)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (system repl command)
  #:use-module (system repl coop-server)
  #:use-module (system repl debug)
  #:use-module (system repl repl)
  #:export (<kernel>
            all-regions
            bind-input/global
            create-full-region
            create-region
            current-controller-focus
            current-kernel
            current-keyboard-focus
            find-region-by-name
            frames-per-second
            kill-region
            load*
            on-controller-add
            on-controller-remove
            on-error
            take-controller-focus
            take-keyboard-focus
            unbind-input/global))


;;;
;;; Kernel
;;;

(define-root-class <kernel> ()
  (controllers #:getter controllers #:init-thunk make-array-list)
  (regions #:accessor regions #:init-value '())
  (input-map #:accessor input-map #:init-thunk make-input-map
             #:allocation #:class)
  (keyboard-focus #:accessor keyboard-focus #:init-value #f)
  (controller-focus #:getter controller-focus #:init-thunk make-hash-table)
  (repl #:accessor repl #:init-value #f)
  (stack #:accessor stack #:init-value #f)
  (exception #:accessor exception #:init-value #f)
  (debugging? #:accessor debugging? #:init-value #f)
  (frame-start-time #:accessor frame-start-time #:init-value 0.0)
  (average-frame-time #:accessor average-frame-time #:init-value 0.0))

(define-method (load* (kernel <kernel>))
  (when developer-mode?
    (set! (repl kernel) (spawn-coop-repl-server))))

(define-method (update (kernel <kernel>) dt)
  (when developer-mode?
    (poll-coop-repl-server (repl kernel))
    (reload-modified-assets))
  (for-each (lambda (region) (update/around region dt))
            (regions kernel)))

(define-method (render (kernel <kernel>) alpha)
  (for-each (lambda (region)
              (render/around region alpha))
            (regions kernel))
  ;; Compute FPS.
  (let ((current-time (elapsed-time)))
    (set! (average-frame-time kernel)
          (+ (* (- current-time (frame-start-time kernel)) 0.1)
             (* (average-frame-time kernel) 0.9)))
    (set! (frame-start-time kernel) current-time)))

(define-method (frames-per-second (kernel <kernel>))
  (/ 1.0 (average-frame-time kernel)))

(define-method (lookup-region (kernel <kernel>) region-name)
  (find (lambda (region)
          (eq? (name region) region-name))
        (regions kernel)))

(define-method (add-region (kernel <kernel>) (region <region>))
  (let ((r (regions kernel)))
    ;; The first region added gets keyboard focus by default.
    (when (null? r)
      (set! (keyboard-focus kernel) region))
    (set! (regions kernel)
          (sort-by-rank/ascending (cons region (regions kernel))))))

(define-generic notify)


;;;
;;; Keyboard
;;;

(define-method (on-key-press (kernel <kernel>) key modifiers)
  (or (let ((handler (key-press-handler (input-map kernel) key modifiers)))
        (and handler (handler)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-key-press s key modifiers)))))

(define-method (on-key-release (kernel <kernel>) key modifiers)
  (or (let ((handler (key-release-handler (input-map kernel) key modifiers)))
        (and handler (handler)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-key-release s key modifiers)))))

(define-method (on-text-input (kernel <kernel>) text)
  (or (let ((handler (text-input-handler (input-map kernel))))
        (and handler (handler text)))
      (let* ((r (keyboard-focus kernel))
             (s (and r (scene r))))
        (and s (on-text-input s text)))))


;;;
;;; Mouse
;;;

(define (mouse-search kernel proc)
  (let loop ((regions* (regions kernel)))
    (match regions*
      (() #f)
      ((r . rest)
       (or (loop rest)
           (let ((s (scene r)))
             (and s (proc s))))))))

(define-method (on-mouse-press (kernel <kernel>) button x y)
  (or (let ((handler (mouse-press-handler (input-map kernel) button)))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-press s button x y)))))

(define-method (on-mouse-release (kernel <kernel>) button x y)
  (or (let ((handler (mouse-release-handler (input-map kernel) button)))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-release s button x y)))))

(define-method (on-mouse-move (kernel <kernel>) x y x-rel y-rel buttons)
  (or (let ((handler (mouse-move-handler (input-map kernel) buttons)))
        (and handler (handler x y x-rel y-rel)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-move s x y x-rel y-rel buttons)))))

(define-method (on-mouse-wheel (kernel <kernel>) x y)
  (or (let ((handler (mouse-wheel-handler (input-map kernel))))
        (and handler (handler x y)))
      (mouse-search kernel
                    (lambda (s)
                      (on-mouse-wheel s x y)))))


;;;
;;; Controllers
;;;

(define-method (controller-focus (kernel <kernel>) slot)
  (hashv-ref (controller-focus kernel) (controller-slot-id slot)))

(define (make-controller-slot id)
  (vector id #f))

(define (controller-slot-id slot)
  (vector-ref slot 0))

(define (controller-slot-controller slot)
  (vector-ref slot 1))

(define (controller-slot-empty? slot)
  (not (controller-slot-controller slot)))

(define (fill-controller-slot! slot controller)
  (vector-set! slot 1 controller))

(define (clear-controller-slot! slot)
  (fill-controller-slot! slot #f))

(define-method (empty-controller-slot (kernel <kernel>))
  (let* ((c (controllers kernel))
         (n (array-list-size c)))
    (let loop ((i 0))
      (if (= i n)
          (let ((slot (make-controller-slot i)))
            (array-list-push! c slot)
            slot)
          (let ((slot (array-list-ref c i)))
            (if (controller-slot-empty? slot)
                slot
                (loop (+ i 1))))))))

(define-method (find-controller-slot (kernel <kernel>) controller)
  (let* ((c (controllers kernel))
         (n (array-list-size c)))
    (let loop ((i 0))
      (if (= i n)
          #f
          (let ((slot (array-list-ref c i)))
            (if (eq? (controller-slot-controller slot) controller)
                slot
                (loop (+ i 1))))))))

(define-method (on-controller-add (kernel <kernel>) controller)
  (let ((slot (empty-controller-slot kernel)))
    (notify (string-append "Controller "
                           (number->string
                            (+ (controller-slot-id slot) 1))
                           " connected: "
                           (controller-name controller)))
    (fill-controller-slot! slot controller)))

(define-method (on-controller-remove (kernel <kernel>) controller)
  (let ((slot (find-controller-slot kernel controller)))
    (notify (string-append "Controller "
                           (number->string
                            (+ (controller-slot-id slot) 1))
                           " disconnected: "
                           (controller-name controller)))
    (clear-controller-slot! (find-controller-slot kernel controller))))

(define-method (on-controller-press (kernel <kernel>) controller button)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-press-handler (input-map kernel)
                                                 (controller-slot-id slot)
                                                 button)))
          (and handler (handler)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and r (on-controller-press s
                                      (controller-slot-id slot)
                                      button))))))

(define-method (on-controller-release (kernel <kernel>) controller button)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-release-handler (input-map kernel)
                                                   (controller-slot-id slot)
                                                   button)))
          (and handler (handler)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and s (on-controller-release s
                                        (controller-slot-id slot)
                                        button))))))

(define-method (on-controller-move (kernel <kernel>) controller axis value)
  (let ((slot (find-controller-slot kernel controller)))
    (or (let ((handler (controller-move-handler (input-map kernel)
                                                (controller-slot-id slot)
                                                axis)))
          (and handler (handler value)))
        (let* ((r (controller-focus kernel slot))
               (s (and r (scene r))))
          (and s (on-controller-move s
                                     (controller-slot-id slot)
                                     axis
                                     value))))))


;;;
;;; Error handling
;;;

(define-method (on-error (kernel <kernel>) e s)
  (if developer-mode?
      (let* ((window (current-window))
             (title (window-title window)))
        (set-window-title! window (string-append "[ERROR] " title))
        (set! (stack kernel) s)
        (set! (exception kernel) e)
        (set! (debugging? kernel) #t)
        (let ((port (current-error-port)))
          (display "an error has occurred!\n\n" port)
          (display "Backtrace:\n" port)
          (display-backtrace s port)
          (newline port)
          (display (error-message kernel) port)
          (newline port))
        (display "waiting for developer to debug..." (current-error-port))
        (while (debugging? kernel)
          (poll-coop-repl-server (repl kernel))
          (usleep 160000)
          #t)
        (set-window-title! window title)
        (set! (stack kernel) #f)
        (set! (exception kernel) #f))
      (raise-exception e)))

(define-method (error-message (kernel <kernel>))
  (let* ((s (stack kernel))
         (e (exception kernel))
         (frame (stack-ref s 0)))
    (format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%"
            (match (frame-source frame)
              ((_ file-name line . column)
               (format #f "~a:~a:~a"
                       (if file-name
                           (basename file-name)
                           "unknown file")
                       line column))
              (_ "unknown"))
            (or (frame-procedure-name frame)
                "unknown")
            (or (and (exception-with-origin? e)
                     (exception-origin e))
                "unknown")
            (if (and (exception-with-message? e)
                     (exception-with-irritants? e))
                (apply format #f (exception-message e)
                       (exception-irritants e))
                ""))))

(define-method (debugger (kernel <kernel>))
  (let ((s (stack kernel))
        (e (exception kernel)))
    (if (and s e)
        (let ((debug (make-debug (narrow-stack->vector s 0)
                                 0
                                 (error-message kernel))))
          (format #t "~a~%" (debug-error-message debug))
          (format #t "Entering a new prompt.  ")
          (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
          (start-repl #:debug debug)
          (set! (debugging? kernel) #f))
        (display "nothing to debug!\n"))))

(define-meta-command ((debug-game catbird) repl)
  "debug-game
Enter a debugger for the current game loop error."
  (debugger (current-kernel)))

(define-meta-command ((resume-game catbird) repl)
  "resume-game
Resume the game loop without entering a debugger."
  (set! (debugging? (current-kernel)) #f))

;;;
;;; Global kernel API
;;;

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

(define (unique-region-name)
  (gensym "region-"))

(define* (create-region area #:key (rank 0) (name (unique-region-name)))
  (let ((region (make-region area name rank)))
    (add-region (current-kernel) region)
    region))

(define* (create-full-region #:key (rank 0) (name (unique-region-name)))
  (let ((w (window-width (current-window)))
        (h (window-height (current-window))))
    (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name)))

(define (kill-region region)
  (let ((k (current-kernel)))
    (set! (regions k) (delq region (regions k)))))

(define (all-regions)
  (regions (current-kernel)))

(define (find-region-by-name name)
  (lookup-region (current-kernel) name))

(define (current-keyboard-focus)
  (keyboard-focus (current-kernel)))

(define (take-keyboard-focus region)
  (set! (keyboard-focus (current-kernel)) region))

(define (current-controller-focus controller-id)
  (hashv-ref (controller-focus (current-kernel)) controller-id))

(define (take-controller-focus controller-id region)
  (hashv-set! (controller-focus (current-kernel)) controller-id region))

(define (global-input-map)
  (class-slot-ref <kernel> 'input-map))

(define (global-input-map-set! input-map)
  (class-slot-set! <kernel> 'input-map input-map))

(define (bind-input/global spec handler)
  (global-input-map-set! (add-input (global-input-map) spec handler)))

(define (unbind-input/global spec)
  (global-input-map-set! (remove-input (global-input-map) spec)))