summaryrefslogtreecommitdiff
path: root/starling/kernel.scm
diff options
context:
space:
mode:
Diffstat (limited to 'starling/kernel.scm')
-rw-r--r--starling/kernel.scm256
1 files changed, 256 insertions, 0 deletions
diff --git a/starling/kernel.scm b/starling/kernel.scm
new file mode 100644
index 0000000..caab692
--- /dev/null
+++ b/starling/kernel.scm
@@ -0,0 +1,256 @@
+;;; Starling Game Engine
+;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 Starling. 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 (starling kernel)
+ #:use-module (chickadee)
+ #: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 mixer)
+ #:use-module (sdl2 video)
+ #:use-module (starling node)
+ #:export (on-quit
+ on-key-press
+ on-key-release
+ on-text-input
+ on-mouse-press
+ on-mouse-release
+ on-mouse-move
+ on-controller-add
+ on-controller-remove
+ on-controller-press
+ on-controller-release
+ on-controller-move
+ <window-config>
+ width
+ height
+ title
+ fullscreen?
+ <kernel>
+ window-config
+ update-hz
+ window
+ gl-context
+ boot-kernel)
+ #:re-export (abort-game))
+
+;; Input event handler methods
+(define-method (on-quit (node <node>))
+ (abort-game))
+
+(define-method (on-key-press (node <node>) key scancode modifiers repeat?)
+ #t)
+
+(define-method (on-key-release (node <node>) key scancode modifiers)
+ #t)
+
+(define-method (on-text-input (node <node>) text)
+ #t)
+
+(define-method (on-mouse-press (node <node>) button clicks x y)
+ #t)
+
+(define-method (on-mouse-release (node <node>) button x y)
+ #t)
+
+(define-method (on-mouse-move (node <node>) x y x-rel y-rel buttons)
+ #t)
+
+(define-method (on-controller-add (node <node>) controller)
+ #t)
+
+(define-method (on-controller-remove (node <node>) controller)
+ #t)
+
+(define-method (on-controller-press (node <node>) controller button)
+ #t)
+
+(define-method (on-controller-release (node <node>) controller button)
+ #t)
+
+(define-method (on-controller-move controller axis value)
+ #t)
+
+(define-class <window-config> ()
+ (width #:accessor width #:init-form 640)
+ (height #:accessor height #:init-form 480)
+ (title #:accessor title #:init-form "Made with Starling Game Engine")
+ (fullscreen? #:accessor fullscreen? #:init-form #f))
+
+(define-class <kernel> (<node>)
+ (name #:accessor name #:init-form "starling-kernel")
+ (window-config #:accessor window-config #:init-form (make <window-config>))
+ (update-hz #:accessor update-hz #:init-form 60)
+ (window #:accessor window)
+ (gl-context #:accessor gl-context)
+ (controllers #:accessor controllers #:init-thunk make-hash-table))
+
+(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 (update* (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)
+ (let ((first-child (car (children kernel))))
+ (cond
+ ((quit-event? event)
+ (on-quit first-child))
+ ((keyboard-down-event? event)
+ (on-key-press first-child
+ (keyboard-event-key event)
+ (keyboard-event-scancode event)
+ (keyboard-event-modifiers event)
+ (keyboard-event-repeat? event)))
+ ((keyboard-up-event? event)
+ (on-key-release first-child
+ (keyboard-event-key event)
+ (keyboard-event-scancode event)
+ (keyboard-event-modifiers event)))
+ ((text-input-event? event)
+ (on-text-input first-child
+ (text-input-event-text event)))
+ ((mouse-button-down-event? event)
+ (on-mouse-press first-child
+ (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 first-child
+ (mouse-button-event-button event)
+ (mouse-button-event-x event)
+ (invert-y (mouse-button-event-y event))))
+ ((mouse-motion-event? event)
+ (on-mouse-move first-child
+ (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 first-child 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 first-child 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 first-child
+ controller
+ (controller-button-event-button event))))
+ ((controller-button-up-event? event)
+ (let ((controller
+ (lookup-controller kernel
+ (controller-button-event-which event))))
+ (on-controller-release first-child
+ controller
+ (controller-button-event-button event))))
+ ((controller-axis-event? event)
+ (let ((controller
+ (lookup-controller kernel
+ (controller-axis-event-which event))))
+ (on-controller-move first-child
+ controller
+ (controller-axis-event-axis event)
+ (/ (controller-axis-event-value event) 32768.0)))))))
+ ;; Process all pending events.
+ (let loop ((event (poll-event)))
+ (when event
+ (process-event event)
+ (loop (poll-event))))
+ ;; Proceed with standard update procedure.
+ (next-method))
+
+(define (boot-kernel kernel first-node)
+ (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.
+ (false-if-exception (mixer-init))
+ (open-audio)
+ (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)
+ (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)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((current-kernel kernel))
+ (attach-to kernel first-node)
+ (activate kernel)
+ ;; TODO: Add error handler
+ (run-game #:update (lambda (dt) (update* kernel dt))
+ #:render (lambda (alpha) (render* kernel alpha))
+ #:time sdl-ticks
+ #:update-hz (update-hz kernel))))
+ (lambda ()
+ (deactivate kernel)
+ (close-window! (window kernel))))))