path: root/catbird/kernel.scm

;;; 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 pushdown)
  #: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
            default-error-handler
            error-handler
            find-region-by-name
            frames-per-second
            kill-region
            load*
            on-controller-add
            on-controller-remove
            on-error
            restore-keyboard-focus
            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-state #:getter keyboard-focus-state
                        #:init-thunk make-pushdown-state)
  (controller-focus #:getter controller-focus #:init-thunk make-hash-table)
  (repl #:accessor repl #:init-value #f)
  (error-handler #:accessor error-handler #:init-form default-error-handler)
  (frame-start-time #:accessor frame-start-time #:init-value 0.0)
  (average-frame-time #:accessor average-frame-time #:init-value 0.0))

(define-method (keyboard-focus (kernel <kernel>))
  (state-current (keyboard-focus-state kernel)))

(define-method (push-keyboard-focus (kernel <kernel>) (region <region>))
  ;; Stealing keyboard multiple times is a no-op.
  (unless (eq? (keyboard-focus kernel) region)
    (state-push! (keyboard-focus-state kernel) region)))

(define-method (pop-keyboard-focus (kernel <kernel>))
  (state-pop! (keyboard-focus-state kernel)))

(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)
      (push-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))))))

;;;
;;; Windows
;;;

(define-method (on-window-resize (kernel <kernel>) width height)
  (for-each (lambda (r)
              (on-window-resize r width height))
            (regions kernel)))


;;;
;;; Error handling
;;;

(define (default-error-handler exception stack)
  (when (quit-exception? exception)
    (raise-exception exception))
  (let ((port (current-error-port))
        (key (exception-kind exception))
        (args (exception-args exception)))
    (print-exception port (stack-ref stack 0) key args)
    (display "Backtrace:\n" port)
    (display-backtrace stack port)
    (newline port)))

(define-method (on-error (kernel <kernel>) exception stack)
  (if developer-mode?
      ((error-handler kernel) exception stack)
      (raise-exception exception)))


;;;
;;; 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* ((window (current-window))
         (w (window-width window))
         (h (window-height window)))
    (when (or (< (rect-left area) 0.0)
              (< (rect-bottom area) 0.0)
              (> (rect-right area) w)
              (> (rect-top area) h))
      (raise-exception
       (make-exception-with-message "region area exceeds window area"))))
  (let ((region (make <region> #:area area #:name name #:rank rank)))
    (add-region (current-kernel) region)
    region))

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

(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)
  (push-keyboard-focus (current-kernel) region))

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

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