First commit!

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))