From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/kernel.scm | 394 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 394 insertions(+)
 create mode 100644 catbird/kernel.scm

(limited to 'catbird/kernel.scm')

diff --git a/catbird/kernel.scm b/catbird/kernel.scm
new file mode 100644
index 0000000..4ed642a
--- /dev/null
+++ b/catbird/kernel.scm
@@ -0,0 +1,394 @@
+(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 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (system repl coop-server)
+  #:export (all-regions
+            create-full-region
+            create-region
+            find-region-by-name
+            frames-per-second
+            kill-region
+            current-keyboard-focus
+            take-keyboard-focus
+            current-controller-focus
+            take-controller-focus
+            bind-input/global
+            unbind-input/global
+            run-catbird
+            exit-catbird))
+
+
+;;;
+;;; 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)
+  (keyboard-focus #:accessor keyboard-focus #:init-value #f)
+  (controller-focus #:getter controller-focus #:init-thunk make-hash-table)
+  (repl #:accessor repl #: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))))
+
+;; Add the system notification and debugging overlay.
+(define-method (add-overlay (kernel <kernel>))
+  (let ((region (create-full-region #:name 'overlay #:rank 9999)))
+    (set! (camera region)
+          (make <camera-2d>
+            #:width (rect-width (area region))
+            #:height (rect-height (area region))))
+    ;; Use resolve-module to avoid a circular dependency.
+    (replace-scene region
+                   ((module-ref (resolve-module '(catbird overlay))
+                                'make-overlay)))))
+
+(define-method (overlay-scene (kernel <kernel>))
+  (scene (lookup-region kernel 'overlay)))
+
+(define-method (notify (kernel <kernel>) message)
+  (let ((notify (module-ref (resolve-module '(catbird overlay)) 'notify)))
+    (notify (overlay-scene kernel) message)))
+
+(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 (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-method (bind-input (kernel <kernel>) spec handler)
+  (set! (input-map kernel) (add-input (input-map kernel) spec handler)))
+
+(define-method (unbind-input (kernel <kernel>) spec)
+  (set! (input-map kernel) (remove-input (input-map kernel) spec)))
+
+
+;;;
+;;; 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 kernel (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 kernel (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))))))
+
+
+;;;
+;;; 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 (bind-input/global spec handler)
+  (bind-input (current-kernel) spec handler))
+
+(define (unbind-input/global spec handler)
+  (unbind-input (current-kernel) spec handler))
+
+(define (frames-per-second)
+  (/ 1.0 (average-frame-time (current-kernel))))
+
+(define* (run-catbird thunk #:key (width 1366) (height 768)
+                      (title "^~Catbird~^") (fullscreen? #f)
+                      (resizable? #t) (update-hz 60))
+  (let ((kernel (make <kernel>)))
+    (parameterize ((current-kernel kernel))
+      (run-game #:window-title title
+                #:window-width width
+                #:window-height height
+                #:window-fullscreen? fullscreen?
+                #:window-resizable? resizable?
+                #:update-hz update-hz
+                #:load
+                (lambda ()
+                  (load* kernel)
+                  (thunk)
+                  (add-overlay kernel))
+                #:draw
+                (lambda (alpha)
+                  (render kernel alpha))
+                #:update
+                (lambda (dt)
+                  (update kernel dt))
+                #:key-press
+                (lambda (key modifiers repeat?)
+                  (on-key-press kernel key modifiers))
+                #:key-release
+                (lambda (key modifiers)
+                  (on-key-release kernel key modifiers))
+                #:text-input
+                (lambda (text)
+                  (on-text-input kernel text))
+                #:mouse-press
+                ;; TODO: Handle click counter?
+                (lambda (button clicks x y)
+                  (on-mouse-press kernel button x y))
+                #:mouse-release
+                (lambda (button x y)
+                  (on-mouse-release kernel button x y))
+                #:mouse-move
+                (lambda (x y x-rel y-rel buttons)
+                  (on-mouse-move kernel x y x-rel y-rel buttons))
+                #:mouse-wheel
+                (lambda (x y)
+                  (on-mouse-wheel kernel x y))
+                #:controller-add
+                (lambda (controller)
+                  (on-controller-add kernel controller))
+                #:controller-remove
+                (lambda (controller)
+                  (on-controller-remove kernel controller))
+                #:controller-press
+                (lambda (controller button)
+                  (on-controller-press kernel controller button))
+                #:controller-release
+                (lambda (controller button)
+                  (on-controller-release kernel controller button))
+                #:controller-move
+                (lambda (controller axis value)
+                  (on-controller-move kernel controller axis value))))))
+
+(define (exit-catbird)
+  "Stop the Catbird engine."
+  (abort-game))
-- 
cgit v1.2.3