1 files changed, 89 insertions, 0 deletions
diff --git a/chickadee/window.scm b/chickadee/window.scm
new file mode 100644
index 0000000..0ca94e4
--- /dev/null
+++ b/chickadee/window.scm
@@ -0,0 +1,89 @@
+;;; 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 window)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module ((sdl2) #:prefix sdl2:)
+  #:use-module ((sdl2 events) #:prefix sdl2:)
+  #:use-module ((sdl2 video) #:prefix sdl2:)
+  #:export (open-window
+            close-window
+            window?
+            window-title
+            window-width
+            window-height
+            window-fullscreen?
+            with-window
+            swap-buffers))
+
+(define-record-type <window>
+  (make-window sdl-window gl-context)
+  window?
+  (sdl-window unwrap-window)
+  (gl-context window-gl-context))
+
+(define* (open-window #:key
+                      (title "Chickadee")
+                      (width 640)
+                      (height 480)
+                      fullscreen?)
+  (sdl2:set-gl-attribute! 'context-major-version 3)
+  (sdl2:set-gl-attribute! 'context-minor-version 3)
+  (sdl2:set-gl-attribute! 'double-buffer 1)
+  (sdl2:set-gl-attribute! 'depth-size 24)
+  (sdl2:set-gl-attribute! 'red-size 8)
+  (sdl2:set-gl-attribute! 'green-size 8)
+  (sdl2:set-gl-attribute! 'blue-size 8)
+  (sdl2:set-gl-attribute! 'alpha-size 8)
+  (sdl2:set-gl-attribute! 'stencil-size 8)
+  (sdl2:set-gl-attribute! 'retained-backing 0)
+  (sdl2:set-gl-attribute! 'framebuffer-srgb-capable 1)
+  (let* ((sdl-window (sdl2:make-window #:opengl? #t
+                                       #:title title
+                                       #:size (list width height)
+                                       #:fullscreen? fullscreen?))
+         (gl-context (sdl2:make-gl-context sdl-window))
+         (window (make-window sdl-window gl-context)))
+    (sdl2:set-gl-swap-interval! 'vsync)
+    window))
+
+(define (close-window! window)
+  "Close WINDOW."
+  (sdl2:delete-gl-context! (window-gl-context window))
+  (sdl2:close-window! (unwrap-window window)))
+
+(define (window-title window)
+  "Return the title of WINDOW."
+  (sdl2:window-title (unwrap-window window)))
+
+(define (set-window-title! window title)
+  "Set TITLE for WINDOW."
+  (sdl2:set-window-title! (unwrap-window window) title))
+
+(define (set-window-size! window width height)
+  (sdl2:set-window-size! (unwrap-window window) (list width height)))
+
+(define-syntax-rule (with-window window body ...)
+  (dynamic-wind
+    (const #t)
+    (lambda () body ...)
+    (lambda ()
+      (close-window! window))))
+
+(define (swap-buffers window)
+  (sdl2:swap-gl-window (unwrap-window window)))