diff options
Diffstat (limited to 'chickadee.scm')
| -rw-r--r-- | chickadee.scm | 185 |
1 files changed, 185 insertions, 0 deletions
diff --git a/chickadee.scm b/chickadee.scm new file mode 100644 index 0000000..e3d128a --- /dev/null +++ b/chickadee.scm @@ -0,0 +1,185 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2016 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 +;;; by the Free Software Foundation, either version 3 of the License, +;;; or (at your option) any later version. +;;; +;;; Chickadee 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 this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (chickadee) + #:use-module (gl) + #:use-module (sdl2) + #:use-module (sdl2 events) + #:use-module (sdl2 input text) + #:use-module (chickadee window) + #:use-module (chickadee render gl) + #: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 + 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 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)) + +(define* (run-game #:key + (window-title "Chickadee!") + (window-width 640) + (window-height 480) + window-fullscreen? + (update-hz 60)) + (sdl-init) + (start-text-input) + (let ((window (open-window #:title window-title + #:width window-width + #:height window-height + #:fullscreen? window-fullscreen?))) + (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) + (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) + (mouse-button-event-y event))) + ((mouse-motion-event? event) + (run-hook mouse-move-hook + (mouse-motion-event-x event) + (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)))) + (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) + (update-loop (- lag update-interval))) + (begin + ;; Render a frame. + (run-hook before-draw-hook) + (gl-clear-color 0.267 0.141 0.204 1.0) + (gl-clear (logior (attrib-mask color-buffer) + (attrib-mask depth-buffer) + (attrib-mask stencil-buffer))) + (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 (time) + (sdl-ticks)) |