From 238800cded9aa2df6748de1ba3b6f86fffb83821 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 4 Nov 2013 06:38:45 -0500 Subject: Merge game-loop module with game module. --- 2d/game.scm | 243 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 240 insertions(+), 3 deletions(-) (limited to '2d/game.scm') diff --git a/2d/game.scm b/2d/game.scm index 4c91b1b..aa19e44 100644 --- a/2d/game.scm +++ b/2d/game.scm @@ -22,17 +22,34 @@ ;;; Code: (define-module (2d game) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) - #:use-module (2d helpers) - #:use-module (2d observer) + #:use-module ((sdl sdl) #:prefix SDL:) + #:use-module (figl gl) + #:use-module (2d agenda) + #:use-module (2d coroutine) + #:use-module (2d game) + #:use-module (2d mvars) + #:use-module (2d repl server) + #:use-module (2d repl repl) + #:use-module (2d scene) + #:use-module (2d stage) #:use-module (2d vector2) + #:use-module (2d window) #:export ( make-game game? game-title game-resolution game-fullscreen? - game-first-scene)) + game-first-scene + current-fps + run-game + quit-game + pause-game + resume-game + game-running? + game-paused?)) ;;; ;;; Games @@ -54,3 +71,223 @@ "Return a new game. All game properties have some reasonable default value." (%make-game title resolution fullscreen? first-scene)) + +(define (run-game game) + "Open a window and start the game loop for GAME." + (open-window (game-title game) + (game-resolution game) + (game-fullscreen? game)) + (set! running? #t) + (resume-game) + (push-scene (game-first-scene game)) + (spawn-server) + (game-loop (SDL:get-ticks) 0) + (close-window)) + +;;; +;;; Game Loop +;;; + +(define running? #f) +(define paused? #f) + +(define (update-and-render stage dt accumulator) + (let ((remainder (update stage accumulator))) + (run-repl) + (render stage dt) + remainder)) + +(define (tick dt accumulator) + "Advance the game by one frame." + (if paused? + (begin + (run-repl) + (SDL:delay tick-interval) + accumulator) + (catch #t + (lambda () + (let ((stage (current-stage))) + (if stage + (update-and-render stage dt accumulator) + (quit-game)))) + (lambda (key . args) + (pause-game) + accumulator) + (lambda (key . args) + (display-backtrace (make-stack #t) + (current-output-port)))))) + +(define (game-loop last-time accumulator) + "Update game state, and render. LAST-TIME is the time in +milliseconds of the last iteration of the loop. ACCUMULATOR is the +time in milliseconds that has passed since the last game update." + (when running? + (let* ((current-time (SDL:get-ticks)) + (dt (- current-time last-time)) + (accumulator (+ accumulator dt))) + (game-loop current-time (tick dt accumulator))))) + +(define (game-running?) + (running?)) + +(define (game-paused?) + (paused?)) + +(define (pause-game) + "Pauses the game loop. Useful when developing." + (set! paused? #t)) + +(define (resume-game) + "Resumes the game loop." + (set! paused? #f)) + +(define (quit-game) + "Finish the current frame and terminate the game loop." + (set! running? #f)) + +;;; +;;; Constants +;;; + +(define target-fps 60) +(define tick-interval (floor (/ 1000 target-fps))) + +;;; +;;; Event Handling +;;; + +;; By default, pressing the escape key will pop the current scene, and +;; closing the window will quit the game. +(default-events `((key-down . ,(lambda (state key mod unicode) + (when (eq? key 'escape) + (pop-scene)))) + (quit . ,(lambda (state) + (quit-game))))) + +(define handle-events + (let ((e (SDL:make-event))) + (lambda (stage) + "Handle all events in the SDL event queue." + (while (SDL:poll-event e) + (handle-event stage e))))) + +(define (handle-event stage e) + "Call the relevant callbacks for the event, E." + (case (SDL:event:type e) + ((active) + (stage-trigger stage 'active)) + ((video-resize) + (stage-trigger stage + 'resize + (SDL:event:resize:w e) + (SDL:event:resize:h e))) + ((quit) + (stage-trigger stage 'quit)) + ((key-down) + (stage-trigger stage + 'key-down + (SDL:event:key:keysym:sym e) + (SDL:event:key:keysym:mod e) + (SDL:event:key:keysym:unicode e))) + ((key-up) + (stage-trigger stage + 'key-up + (SDL:event:key:keysym:sym e) + (SDL:event:key:keysym:mod e) + (SDL:event:key:keysym:unicode e))) + ((mouse-motion) + (stage-trigger stage + 'mouse-motion + (SDL:event:motion:state e) + (SDL:event:motion:x e) + (SDL:event:motion:y e) + (SDL:event:motion:xrel e) + (SDL:event:motion:yrel e))) + ((mouse-button-down) + (stage-trigger stage + 'mouse-press + (SDL:event:button:button e) + (SDL:event:button:x e) + (SDL:event:button:y e))) + ((mouse-button-up) + (stage-trigger stage + 'mouse-click + (SDL:event:button:button e) + (SDL:event:button:x e) + (SDL:event:button:y e))))) + +;;; +;;; Frames Per Second +;;; + +(define game-fps 0) + +(define accumulate-fps! + (let* ((elapsed-time 0) + (fps 0)) + (lambda (dt) + "Increment the frames-per-second counter. Resets to 0 every +second." + (let ((new-time (+ elapsed-time dt)) + (new-fps (1+ fps))) + (if (>= new-time 1000) + (begin + (set! game-fps new-fps) + (set! fps 0) + (set! elapsed-time 0)) + (begin + (set! fps new-fps) + (set! elapsed-time new-time))))))) + +(define (current-fps) + "Return the current FPS value." + game-fps) + +;;; +;;; Update and Render +;;; + +(define (render stage dt) + "Render a frame." + (set-gl-matrix-mode (matrix-mode modelview)) + (gl-load-identity) + (gl-clear (clear-buffer-mask color-buffer depth-buffer)) + (draw-stage stage) + (SDL:gl-swap-buffers) + (accumulate-fps! dt)) + +(define (update stage accumulator) + "Call the update callback. The update callback will be called as +many times as `tick-interval` can divide ACCUMULATOR. The return value +is the unused accumulator time." + (if (>= accumulator tick-interval) + (begin + (handle-events stage) + (update-agenda) + (update-stage stage) + (update stage (- accumulator tick-interval))) + accumulator)) + +;;; +;;; REPL +;;; + +(define (run-repl-thunk thunk input output error stack) + "Run THUNK with the given REPL STACK. I/O is redirected to the given +INPUT, OUTPUT, and ERROR ports." + (put-mvar + repl-output-mvar + (with-input-from-port input + (lambda () + (with-output-to-port output + (lambda () + (with-error-to-port error + (lambda () + (with-fluids ((*repl-stack* stack)) + (thunk)))))))))) + +(define (run-repl) + "Execute a thunk from the REPL is there is one." + (unless (mvar-empty? repl-input-mvar) + (and-let* ((vals (try-take-mvar repl-input-mvar))) + (apply run-repl-thunk vals)))) -- cgit v1.2.3