diff options
Diffstat (limited to 'lisparuga/kernel.scm')
| -rw-r--r-- | lisparuga/kernel.scm | 303 |
1 files changed, 303 insertions, 0 deletions
diff --git a/lisparuga/kernel.scm b/lisparuga/kernel.scm new file mode 100644 index 0000000..f94b832 --- /dev/null +++ b/lisparuga/kernel.scm @@ -0,0 +1,303 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Lisparuga is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This is the core of the game engine, the root node, that is +;; responsible for starting up the game loop and passing along render, +;; update, and input events to the other parts of the game. +;; +;;; Code: + +(define-module (lisparuga kernel) + #:use-module (chickadee audio) + #:use-module (chickadee game-loop) + #:use-module (chickadee render) + #:use-module (chickadee render gpu) + #:use-module (chickadee render viewport) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2) + #:use-module (sdl2 events) + #:use-module (sdl2 input game-controller) + #:use-module (sdl2 input joystick) + #:use-module (sdl2 input text) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga config) + #:use-module (lisparuga node) + #:use-module (lisparuga repl) + #:use-module (lisparuga scene) + #:use-module (system repl command) + #:export (<window-config> + width + height + title + fullscreen? + + <kernel> + window-config + update-hz + window + gl-context + avg-frame-time + current-kernel + boot-kernel + elapsed-time + fps + reboot-current-scene) + #:re-export (abort-game)) + +(define-class <window-config> () + (width #:accessor width #:init-form 640 #:init-keyword #:width) + (height #:accessor height #:init-form 480 #:init-keyword #:height) + (title #:accessor title #:init-form "Lisparuga" + #:init-keyword #:title) + (fullscreen? #:accessor fullscreen? #:init-form #f + #:init-keyword #:fullscreen?)) + +(define-class <kernel> (<scene-mux>) + (name #:accessor name #:init-form "lisparuga-kernel" + #:init-keyword #:name) + (window-config #:accessor window-config #:init-form (make <window-config>) + #:init-keyword #:window-config) + (update-hz #:accessor update-hz #:init-form 60 + #:init-keyword #:update-hz) + (window #:accessor window) + (gl-context #:accessor gl-context) + (default-viewport #:accessor default-viewport) + (avg-frame-time #:accessor avg-frame-time #:init-form 0.0) + (controllers #:accessor controllers #:init-thunk make-hash-table) + (repl #:accessor repl)) + +(define current-kernel (make-parameter #f)) + +;; game controller bookkeeping. +(define (lookup-controller kernel joystick-id) + (hashv-ref (controllers kernel) joystick-id)) + +(define (add-controller kernel joystick-index) + (let ((controller (open-game-controller joystick-index))) + (hashv-set! (controllers kernel) + (joystick-instance-id + (game-controller-joystick controller)) + controller) + controller)) + +(define (remove-controller kernel joystick-id) + (hashv-remove! (controllers kernel) joystick-id)) + +(define (initialize-controllers kernel) + (let loop ((i 0)) + (when (< i (num-joysticks)) + (when (game-controller-index? i) + (add-controller kernel i)) + (loop (+ i 1))))) + +(define-method (on-boot (kernel <kernel>)) + (when developer-mode? + ;; Enable live asset reloading. + (watch-assets #t) + ;; Start REPL server. + (attach-to kernel (make <repl> #:name 'repl)))) + +(define-method (update-tree (kernel <kernel>) dt) + (define (invert-y y) + ;; SDL's origin is the top-left, but our origin is the bottom + ;; left so we need to invert Y coordinates that SDL gives us. + (match (window-size (window kernel)) + ((_ height) + (- height y)))) + (define (process-event event) + (cond + ((quit-event? event) + (on-quit kernel)) + ((keyboard-down-event? event) + (on-key-press kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event) + (keyboard-event-repeat? event))) + ((keyboard-up-event? event) + (on-key-release kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event))) + ((text-input-event? event) + (on-text-input kernel + (text-input-event-text event))) + ((mouse-button-down-event? event) + (on-mouse-press kernel + (mouse-button-event-button event) + (mouse-button-event-clicks event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-button-up-event? event) + (on-mouse-release kernel + (mouse-button-event-button event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-motion-event? event) + (on-mouse-move kernel + (mouse-motion-event-x event) + (invert-y (mouse-motion-event-y event)) + (mouse-motion-event-x-rel event) + (- (mouse-motion-event-y-rel event)) + (mouse-motion-event-buttons event))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'added)) + (let ((controller + (add-controller kernel + (controller-device-event-which event)))) + (on-controller-add kernel controller))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'removed)) + (let ((controller + (lookup-controller kernel + (controller-device-event-which event)))) + (on-controller-remove kernel controller) + (remove-controller kernel (controller-device-event-which event)) + (close-game-controller controller))) + ((controller-button-down-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-press kernel + controller + (controller-button-event-button event)))) + ((controller-button-up-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-release kernel + controller + (controller-button-event-button event)))) + ((controller-axis-event? event) + (let ((controller + (lookup-controller kernel + (controller-axis-event-which event)))) + (on-controller-move kernel + controller + (controller-axis-event-axis event) + (/ (controller-axis-event-value event) 32768.0)))))) + (define (poll-events) + (let ((event (poll-event))) + (when event + (process-event event) + (poll-events)))) + ;; Process all pending events before we update any other node. + (poll-events) + ;; Proceed with standard update procedure. + (next-method)) + +(define-method (update (kernel <kernel>) dt) + (update-audio) + (when developer-mode? + (reload-modified-assets)) + ;; Free any GPU resources that have been GC'd. + (gpu-reap!)) + +(define-method (render-tree (kernel <kernel>) alpha) + (let ((start-time (elapsed-time))) + ;; Switch to the null viewport to ensure that + ;; the default viewport will be re-applied and + ;; clear the screen. + (set-gpu-viewport! (current-gpu) null-viewport) + (with-viewport (default-viewport kernel) + (next-method)) + (swap-gl-window (window kernel)) + ;; Compute FPS. + (set! (avg-frame-time kernel) + (+ (* (- (elapsed-time) start-time) 0.1) + (* (avg-frame-time kernel) 0.9))))) + +(define-method (on-error (kernel <kernel>) stack key args) + (if developer-mode? + (let ((title (window-title (window kernel)))) + (set-window-title! (window kernel) (string-append "[ERROR] " title)) + (on-error (& kernel repl) stack key args) + (set-window-title! (window kernel) title)) + (apply throw key args))) + +(define-method (on-scenes-empty (kernel <kernel>)) + (abort-game)) + +(define (elapsed-time) + (sdl-ticks)) + +(define-method (fps kernel) + (/ 1000.0 (avg-frame-time kernel))) + +(define-method (boot-kernel (kernel <kernel>) thunk) + (sdl-init) + ;; This will throw an error if any audio subsystem is unavailable, + ;; but not every audio subsystem is needed so don't crash the + ;; program over it. + (start-text-input) + ;; Discover all game controllers that are already connected. New + ;; connections/disconnections will be handled by events as they occur. + (initialize-controllers kernel) + (init-audio) + (let ((wc (window-config kernel))) + (set! (window kernel) + (make-window #:opengl? #t + #:title (title wc) + #:size (list (width wc) (height wc)) + #:fullscreen? (fullscreen? wc))) + (set! (gl-context kernel) (make-gl-context (window kernel))) + (set! (default-viewport kernel) + (make-viewport 0 0 (width wc) (height wc))) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t + (lambda () + (set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-kernel kernel) + (current-gpu (make-gpu (gl-context kernel)))) + (activate kernel) + (push-scene kernel (thunk)) + (run-game* #:update (lambda (dt) (update-tree kernel dt)) + #:render (lambda (alpha) (render-tree kernel alpha)) + #:error (lambda (stack key args) + (on-error kernel stack key args)) + #:time elapsed-time + #:update-hz (update-hz kernel)))) + (lambda () + (deactivate kernel) + (quit-audio) + (delete-gl-context! (gl-context kernel)) + (close-window! (window kernel)))))) + +(define (reboot-current-scene) + "Reboot the currently active scene being managed by the game engine +kernel. A convenient procedure for developers." + (reboot (current-scene (current-kernel)))) + +(define-meta-command ((debug-game lisparuga) repl) + "debug-game +Enter a debugger for the current game loop error." + (debugger (& (current-kernel) repl))) + +(define-meta-command ((resume-game lisparuga) repl) + "resume-game +Resume the game loop without entering a debugger." + (set! (repl-debugging? (& (current-kernel) repl)) #f)) |