summaryrefslogtreecommitdiff
path: root/starling
diff options
context:
space:
mode:
authorDavid Thompson <davet@gnu.org>2019-05-07 17:25:05 -0400
committerDavid Thompson <davet@gnu.org>2019-05-07 17:25:05 -0400
commitf26106ad280cbc586b4470ba1f2229a2b4f6d0f9 (patch)
treecd5ecf2207c32877c5014c2aa175b9ad19267cb1 /starling
parent917d7ba45b69fd1997e4cdd25cbce44bbc947552 (diff)
kernel: Use scene multiplexer for scene management.
Diffstat (limited to 'starling')
-rw-r--r--starling/kernel.scm187
1 files changed, 71 insertions, 116 deletions
diff --git a/starling/kernel.scm b/starling/kernel.scm
index 9fa9ac8..7957a51 100644
--- a/starling/kernel.scm
+++ b/starling/kernel.scm
@@ -56,12 +56,7 @@
current-kernel
boot-kernel
elapsed-time
- fps
- current-scene
- previous-scene
- push-scene
- pop-scene
- replace-scene)
+ fps)
#:re-export (abort-game))
(define-class <window-config> ()
@@ -72,7 +67,7 @@
(fullscreen? #:accessor fullscreen? #:init-form #f
#:init-keyword #:fullscreen?))
-(define-class <kernel> (<node>)
+(define-class <kernel> (<scene-mux>)
(name #:accessor name #:init-form "starling-kernel"
#:init-keyword #:name)
(window-config #:accessor window-config #:init-form (make <window-config>)
@@ -86,9 +81,7 @@
(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)
- ;; The scene stack.
- (scenes #:accessor scenes #:init-form '()))
+ (repl #:accessor repl))
(define current-kernel (make-parameter #f))
@@ -129,78 +122,77 @@
((_ height)
(- height y))))
(define (process-event event)
- (let ((current-scene (current-scene)))
- (cond
- ((quit-event? event)
- (on-quit current-scene))
- ((keyboard-down-event? event)
- (on-key-press current-scene
+ (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)
- (keyboard-event-repeat? event)))
- ((keyboard-up-event? event)
- (on-key-release current-scene
- (keyboard-event-key event)
- (keyboard-event-scancode event)
- (keyboard-event-modifiers event)))
- ((text-input-event? event)
- (on-text-input current-scene
- (text-input-event-text event)))
- ((mouse-button-down-event? event)
- (on-mouse-press current-scene
+ (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-clicks event)
(mouse-button-event-x event)
(invert-y (mouse-button-event-y event))))
- ((mouse-button-up-event? event)
- (on-mouse-release current-scene
- (mouse-button-event-button event)
- (mouse-button-event-x event)
- (invert-y (mouse-button-event-y event))))
- ((mouse-motion-event? event)
- (on-mouse-move current-scene
- (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 current-scene 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 current-scene 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 current-scene
+ ((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-button-up-event? event)
- (let ((controller
- (lookup-controller kernel
- (controller-button-event-which event))))
- (on-controller-release current-scene
- controller
- (controller-button-event-button event))))
- ((controller-axis-event? event)
- (let ((controller
- (lookup-controller kernel
- (controller-axis-event-which event))))
- (on-controller-move current-scene
- controller
- (controller-axis-event-axis event)
- (/ (controller-axis-event-value event) 32768.0)))))))
+ ((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
@@ -239,6 +231,9 @@
(set-window-title! (window kernel) title))
(apply throw key args)))
+(define-method (on-scenes-empty (kernel <kernel>))
+ (abort-game))
+
(define (elapsed-time)
(sdl-ticks))
@@ -277,8 +272,8 @@
(const #t)
(lambda ()
(parameterize ((current-kernel kernel))
- (push-scene (thunk))
(activate kernel)
+ (push-scene kernel (thunk))
(run-game* #:update (lambda (dt) (update* kernel dt))
#:render (lambda (alpha) (render* kernel alpha))
#:error (lambda (stack key args)
@@ -289,46 +284,6 @@
(deactivate kernel)
(close-window! (window kernel))))))
-(define (current-scene)
- "Return the currently active scene"
- (match (scenes (current-kernel))
- (() #f)
- ((scene . rest) scene)))
-
-(define (previous-scene)
- (match (scenes (current-kernel))
- ((or () (_)) #f)
- ((_ scene . rest) scene)))
-
-(define-method (push-scene (scene <scene>))
- "Make SCENE the currently active scene and remember the previously
-active scene."
- (let ((old (current-scene)))
- (set! (scenes (current-kernel)) (cons scene (scenes (current-kernel))))
- (when old (detach old))
- (attach-to (current-kernel) scene)))
-
-(define-method (replace-scene (scene <scene>))
- "Make SCENE the currently active scene and forget about whatever was
-previously active."
- (let ((old (current-scene)))
- (unless old
- (error "no scene to replace!"))
- (set! (scenes (current-kernel)) (cons scene (cdr (scenes (current-kernel)))))
- (detach old)
- (attach-to (current-kernel) scene)))
-
-(define-method (pop-scene)
- "Replace the current scene with the previously active scene."
- (let ((old (current-scene)))
- (set! (scenes (current-kernel)) (cdr (scenes (current-kernel))))
- (detach old)
- (let ((new (current-scene)))
- (if new
- (attach-to (current-kernel) new)
- ;; No scenes remain, it's time to shut down!
- (abort-game)))))
-
(define-meta-command ((debug-game starling) repl)
"debug-game
Enter a debugger for the current game loop error."