diff options
Diffstat (limited to 'chickadee.scm')
| -rw-r--r-- | chickadee.scm | 361 |
1 files changed, 182 insertions, 179 deletions
diff --git a/chickadee.scm b/chickadee.scm index e2a705f..eb98443 100644 --- a/chickadee.scm +++ b/chickadee.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016 David Thompson <davet@gnu.org> +;;; Copyright © 2016, 2018 David Thompson <davet@gnu.org> ;;; ;;; Chickadee is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published @@ -27,52 +27,14 @@ #:use-module (chickadee render gl) #:use-module (chickadee render gpu) #:use-module (chickadee render viewport) - #:export (load-hook - update-hook - before-draw-hook - draw-hook - after-draw-hook - quit-hook - key-press-hook - key-release-hook - text-input-hook - mouse-press-hook - mouse-release-hook - mouse-move-hook - controller-add-hook - controller-remove-hook - controller-press-hook - controller-release-hook - controller-move-hook - error-hook - run-game + #:export (run-game* abort-game - time)) - -(define load-hook (make-hook 0)) -(define update-hook (make-hook 1)) -(define before-draw-hook (make-hook 0)) -(define after-draw-hook (make-hook 0)) -(define draw-hook (make-hook 1)) -(define quit-hook (make-hook 0)) -(define key-press-hook (make-hook 4)) -(define key-release-hook (make-hook 3)) -(define text-input-hook (make-hook 1)) -(define mouse-press-hook (make-hook 4)) -(define mouse-release-hook (make-hook 3)) -(define mouse-move-hook (make-hook 5)) -(define controller-add-hook (make-hook 1)) -(define controller-remove-hook (make-hook 1)) -(define controller-press-hook (make-hook 2)) -(define controller-release-hook (make-hook 2)) -(define controller-move-hook (make-hook 3)) -(define error-hook (make-hook 3)) + run-game/sdl)) -(define open-controller (@@ (chickadee input controller) open-controller)) -(define close-controller (@@ (chickadee input controller) close-controller)) -(define lookup-controller (@@ (chickadee input controller) lookup-controller)) - -(define game-loop-prompt-tag (make-prompt-tag 'game-loop)) + +;;; +;;; Error handling +;;; (define (display-game-loop-error stack key args) (let ((port (current-error-port))) @@ -82,149 +44,190 @@ (apply display-error (stack-ref stack 0) port args) (newline port))) -(define (call-with-error-handling thunk) - (if (hook-empty? error-hook) - (thunk) - (let ((stack #f)) - (catch #t - thunk - (lambda (key . args) - (display-game-loop-error stack key args) - (run-hook error-hook stack key args)) - (lambda (key . args) - (set! stack (make-stack #t 3))))))) - -(define-syntax-rule (run-hook* args ...) - (call-with-error-handling - (lambda () - (run-hook args ...)))) - -(define* (run-game #:key - (window-title "Chickadee!") - (window-width 640) - (window-height 480) - window-fullscreen? - (update-hz 60)) +(define (call-with-error-handling handler thunk) + (let ((stack #f)) + (catch #t + thunk + (lambda (key . args) + (display-game-loop-error stack key args) + (error stack key args)) + (lambda (key . args) + (set! stack (make-stack #t 3)))))) + +(define-syntax-rule (with-error-handling handler body ...) + (call-with-error-handling handler (lambda () body ...))) + + +;;; +;;; Game loop core +;;; + +(define game-loop-prompt-tag (make-prompt-tag 'game-loop)) + +(define (abort-game) + (abort-to-prompt game-loop-prompt-tag #f)) + +(define* (run-game #:key update render time error (update-hz 60)) + (let ((timestep (round (/ 1000 update-hz)))) + (call-with-prompt game-loop-prompt-tag + (lambda () + ;; Catch SIGINT and kill the loop. + (sigaction SIGINT + (lambda (signum) + (abort-game))) + ;; A simple analogy is that we are filling up a bucket + ;; with water. When the bucket fills up to a marked + ;; line, we dump it out. Our water is time, and each + ;; time we dump the bucket we update the game. Updating + ;; the game on a fixed timestep like this yields a + ;; stable simulation. + (let loop ((previous-time (time)) + (buffer 0)) + (let* ((current-time (time)) + (delta (- current-time previous-time))) + (let update-loop ((buffer (+ buffer delta))) + (if (>= buffer timestep) + (begin + (with-error-handling error (update timestep)) + (update-loop (- buffer timestep))) + (begin + ;; We render upon every iteration of the loop, and + ;; thus rendering is decoupled from updating. + ;; It's possible to render multiple times before + ;; an update is performed. + (with-error-handling error (render (/ buffer timestep))) + (loop current-time buffer))))))) + (lambda (cont callback) + #f)))) + + +;;; +;;; Simple SDL + OpenGL engine +;;; + +;; Good enough for simple games. + +(define open-controller (@@ (chickadee input controller) open-controller)) +(define close-controller (@@ (chickadee input controller) close-controller)) +(define lookup-controller (@@ (chickadee input controller) lookup-controller)) + +(define* (run-game/sdl #:key + (window-title "Chickadee!") + (window-width 640) + (window-height 480) + window-fullscreen? + (update-hz 60) + (load (const #t)) + (update (const #t)) + (draw (const #t)) + (quit abort-game) + (key-press (const #t)) + (key-release (const #t)) + (text-input (const #t)) + (mouse-press (const #t)) + (mouse-release (const #t)) + (mouse-move (const #t)) + (controller-add (const #t)) + (controller-remove (const #t)) + (controller-press (const #t)) + (controller-release (const #t)) + (controller-move (const #t)) + (error (const #t))) (sdl-init) ((@@ (chickadee audio) enable-audio)) (start-text-input) (let ((window (open-window #:title window-title #:width window-width #:height window-height - #:fullscreen? window-fullscreen?))) + #:fullscreen? window-fullscreen?)) + (default-viewport (make-viewport 0 0 window-width window-height)) + (default-projection (orthographic-projection 0 window-width + window-height 0 + 0 1))) (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. (- window-height y)) - (define (process-event event) - (cond - ((quit-event? event) - (run-hook* quit-hook)) - ((keyboard-down-event? event) - (run-hook* key-press-hook - (keyboard-event-key event) - (keyboard-event-scancode event) - (keyboard-event-modifiers event) - (keyboard-event-repeat? event))) - ((keyboard-up-event? event) - (run-hook* key-release-hook - (keyboard-event-key event) - (keyboard-event-scancode event) - (keyboard-event-modifiers event))) - ((text-input-event? event) - (run-hook* text-input-hook (text-input-event-text event))) - ((mouse-button-down-event? event) - (run-hook* mouse-press-hook - (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) - (run-hook* mouse-release-hook - (mouse-button-event-button event) - (mouse-button-event-x event) - (invert-y (mouse-button-event-y event)))) - ((mouse-motion-event? event) - (run-hook* mouse-move-hook - (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)) - (run-hook* controller-add-hook - (open-controller (controller-device-event-which event)))) - ((and (controller-device-event? event) - (eq? (controller-device-event-action event) 'removed)) - (let ((controller (lookup-controller - (controller-device-event-which event)))) - (run-hook* controller-remove-hook controller) - (close-controller controller))) - ((controller-button-down-event? event) - (run-hook* controller-press-hook - (lookup-controller - (controller-button-event-which event)) - (controller-button-event-button event))) - ((controller-button-up-event? event) - (run-hook* controller-release-hook - (lookup-controller - (controller-button-event-which event)) - (controller-button-event-button event))) - ((controller-axis-event? event) - (run-hook* controller-move-hook - (lookup-controller - (controller-axis-event-which event)) - (controller-axis-event-axis event) - (/ (controller-axis-event-value event) 32768.0))))) - (with-window window - (let ((update-interval (round (/ 1000 update-hz))) - (default-viewport - (make-viewport 0 0 window-width window-height)) - (default-projection - (orthographic-projection 0 window-width window-height 0 0 1))) - (call-with-prompt game-loop-prompt-tag - (lambda () - ;; Catch SIGINT and kill the loop. - (sigaction SIGINT - (lambda (signum) - (abort-game))) - (run-hook* load-hook) - (let loop ((previous-time (sdl-ticks)) - (lag 0)) - (let* ((current-time (sdl-ticks)) - (delta (- current-time previous-time))) - (let update-loop ((lag (+ lag delta))) - (if (>= lag update-interval) - (begin - ;; Process all pending events. - (let loop ((event (poll-event))) - (when event - (process-event event) - (loop (poll-event)))) - ;; Advance the simulation. - (run-hook* update-hook update-interval) - ;; Free any GPU resources that have been GC'd. - (gpu-reap!) - (update-loop (- lag update-interval))) - (begin - ;; Render a frame. - (run-hook* before-draw-hook) - ;; Switch to the null viewport to ensure that - ;; the default viewport will be re-applied and - ;; clear the screen. - (gpu-state-set! *viewport-state* null-viewport) - (with-viewport default-viewport - (with-projection default-projection - (run-hook* draw-hook (/ lag update-interval)))) - (swap-buffers window) - (run-hook* after-draw-hook) - (loop current-time lag))))))) - (lambda (cont callback) - #f)))))) -(define (abort-game) - (abort-to-prompt game-loop-prompt-tag #f)) + (define (input-sdl) + (define (process-event event) + (cond + ((quit-event? event) + (quit)) + ((keyboard-down-event? event) + (key-press (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event) + (keyboard-event-repeat? event))) + ((keyboard-up-event? event) + (key-release (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event))) + ((text-input-event? event) + (text-input (text-input-event-text event))) + ((mouse-button-down-event? event) + (mouse-press (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) + (mouse-release (mouse-button-event-button event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-motion-event? event) + (mouse-move (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)) + (controller-add + (open-controller (controller-device-event-which event)))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'removed)) + (let ((controller (lookup-controller + (controller-device-event-which event)))) + (controller-remove controller) + (close-controller controller))) + ((controller-button-down-event? event) + (controller-press (lookup-controller + (controller-button-event-which event)) + (controller-button-event-button event))) + ((controller-button-up-event? event) + (controller-release (lookup-controller + (controller-button-event-which event)) + (controller-button-event-button event))) + ((controller-axis-event? event) + (controller-move (lookup-controller + (controller-axis-event-which event)) + (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))))) + + (define (update-sdl dt) + (input-sdl) + (update dt) + ;; Free any GPU resources that have been GC'd. + (gpu-reap!)) -(define (time) - (sdl-ticks)) + (define (render-sdl-opengl alpha) + ;; Switch to the null viewport to ensure that + ;; the default viewport will be re-applied and + ;; clear the screen. + (gpu-state-set! *viewport-state* null-viewport) + (with-viewport default-viewport + (with-projection default-projection + (draw alpha))) + (swap-buffers window)) + (with-window window + (load) + (run-game #:update update-sdl + #:render render-sdl-opengl + #:error error + #:time sdl-ticks + #:update-hz update-hz)))) |