diff options
| -rw-r--r-- | starling/kernel.scm | 187 |
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." |