summaryrefslogtreecommitdiff
path: root/starling
diff options
context:
space:
mode:
Diffstat (limited to 'starling')
-rw-r--r--starling/game.scm13
-rw-r--r--starling/kernel.scm256
-rw-r--r--starling/node.scm198
3 files changed, 467 insertions, 0 deletions
diff --git a/starling/game.scm b/starling/game.scm
new file mode 100644
index 0000000..b7bc5e3
--- /dev/null
+++ b/starling/game.scm
@@ -0,0 +1,13 @@
+(define-module (starling game)
+ #:use-module (oop goops)
+ #:use-module (starling node))
+
+(define-class <game> (<node>))
+
+(define-method (render (game <game>))
+ #t)
+
+(define-class <2d-game> (<game>))
+
+(define-method (render (game <2d-game>))
+ (render-2d game))
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))))))
diff --git a/starling/node.scm b/starling/node.scm
new file mode 100644
index 0000000..2d4b1c3
--- /dev/null
+++ b/starling/node.scm
@@ -0,0 +1,198 @@
+;;; 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:
+;;
+;; Base class for all game objects.
+;;
+;;; Code:
+
+(define-module (starling node)
+ #:use-module (chickadee scripting)
+ #:use-module (oop goops)
+ #:export (<node>
+ name
+ rank
+ parent
+ children
+ agenda
+ booted?
+ active?
+ on-boot
+ on-enter
+ on-exit
+ activate
+ deactivate
+ update
+ update*
+ render
+ render*
+ child-ref
+ &
+ attach-to
+ detach))
+
+(define-class <node> ()
+ ;; Symbolic name. Used for easy lookup of children within a parent.
+ (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name)
+ ;; An integer value that determines priority order for
+ ;; updating/rendering.
+ (rank #:getter rank #:init-value 0 #:init-keyword #:rank)
+ ;; The node that this node is attached to. A node may only have one
+ ;; parent.
+ (parent #:accessor parent #:init-form #f)
+ ;; List of children ordered by rank.
+ (children #:accessor children #:init-form '())
+ ;; Children indexed by name for fast lookup.
+ (children-map #:getter children-map #:init-form (make-hash-table))
+ ;; Script scheduler.
+ (agenda #:getter agenda #:init-form (make-agenda))
+ ;; Flips to #t upon first entering a scene.
+ (booted? #:accessor booted? #:init-form #f)
+ ;; Flips to #t when node is part of current scene.
+ (active? #:accessor active? #:init-form #f))
+
+(define (for-each-child proc node)
+ (for-each proc (children node)))
+
+
+;;;
+;;; Life cycle event handlers
+;;;
+
+(define-method (update (node <node>) dt)
+ "Advance simulation of NODE by the time delta DT."
+ #t)
+
+(define-method (update* (node <node>) dt)
+ "Update NODE and all of its children. DT is the amount of time
+passed since the last update, in milliseconds."
+ ;; Update children first, recursively.
+ (for-each-child (lambda (child) (update* child dt)) node)
+ ;; Update script, then "physics" (or whatever the update method is
+ ;; doing).
+ (with-agenda (agenda node)
+ (update-agenda 1)
+ (update node dt)))
+
+(define-method (render (node <node>) alpha)
+ "Render NODE. ALPHA is the distance between the previous update and
+the next update represented as a ratio in the range [0, 1]."
+ #t)
+
+(define-method (render* (node <node>) alpha)
+ "Render NODE and all of its children, recursively.
+ALPHA is the distance between the previous update and the next update
+represented as a ratio in the range [0, 1]."
+ (render node alpha)
+ (for-each-child (lambda (child) (render child alpha)) node))
+
+(define-method (on-boot (node <node>))
+ "Perform initialization tasks for NODE."
+ #t)
+
+(define-method (on-enter (node <node>))
+ "Perform task now that NODE has entered the current scene."
+ #t)
+
+(define-method (on-exit (node <node>))
+ "Perform task now that NODE has left the current scene."
+ #t)
+
+
+;;;
+;;; Life cycle state management
+;;;
+
+(define-method (boot (node <node>))
+ "Prepare NODE to enter the game world for the first time."
+ (on-boot node)
+ (set! (booted? node) #t))
+
+(define-method (activate (node <node>))
+ "Mark NODE and all of its children as active."
+ ;; First time activating? We must boot!
+ (with-agenda (agenda node)
+ (unless (booted? node) (boot node))
+ (set! (active? node) #t)
+ (on-enter node)
+ (for-each-child activate node)))
+
+(define-method (deactivate (node <node>))
+ "Mark NODE and all of its children as inactive."
+ (with-agenda (agenda node)
+ (set! (active? node) #f)
+ (on-exit node)
+ (for-each-child deactivate node)))
+
+
+;;;
+;;; Child management
+;;;
+
+(define-method (child-ref (parent <node>) name)
+ "Return the child node of PARENT whose name is NAME."
+ (hash-ref (children-map parent) name))
+
+(define-syntax &
+ (syntax-rules ()
+ ((_ parent child-name)
+ (child-ref parent child-name))
+ ((_ parent child-name . rest)
+ (& (child-ref parent child-name) . rest))))
+
+(define-method (attach-to (new-parent <node>) . new-children)
+ "Attach NEW-CHILDREN to NEW-PARENT."
+ ;; Validate all children first. The whole operation will fail if
+ ;; any of them cannot be attached.
+ (for-each (lambda (child)
+ (when (parent child)
+ (error "node already has a parent:" child))
+ (when (child-ref new-parent (name child))
+ (error "node name taken:" (name child))))
+ new-children)
+ ;; Adopt the children and sort them by their rank so that
+ ;; updating/rendering happens in the desired order.
+ (set! (children new-parent)
+ (sort (append new-children (children new-parent))
+ (lambda (a b)
+ (< (rank a) (rank b)))))
+ ;; Mark the children as having parents and add them to the name
+ ;; index for quick lookup later.
+ (for-each (lambda (child)
+ (set! (parent child) new-parent)
+ ;; If the parent is active, that means the new children
+ ;; must also be active.
+ (when (active? new-parent)
+ (activate child))
+ (hashq-set! (children-map new-parent) (name child) child))
+ new-children))
+
+(define-method (detach (node <node>))
+ "Detach NODE from its parent."
+ (let ((p (parent node)))
+ (unless p
+ (error "node has no parent" node))
+ (set! (children parent) (delq node (children parent)))
+ (hashq-remove! (children-map parent) (name node))
+ ;; Detaching deactives the node and all of its children.
+ (when (active? node)
+ (deactivate node))
+ (set! (parent node) #f)))
+
+(define-method (detach . nodes)
+ "Detach all NODES from their respective parents."
+ (for-each detach nodes))