Initial commit.

Let's do this!

3 files changed, 455 insertions, 0 deletions

diff --git a/sdl2/bindings.scm b/sdl2/bindings.scm
new file mode 100644
index 0000000..138d4fc
--- /dev/null
+++ b/sdl2/bindings.scm
@@ -0,0 +1,194 @@
+;;; guile-sdl2 --- FFI bindings for SDL2
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of guile-sdl2.
+;;;
+;;; Guile-sdl2 is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-sdl2 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 Lesser General Public
+;;; License along with guile-sdl2.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Low-level FFI bindings.
+;;
+;;; Code:
+
+(define-module (sdl2 bindings)
+  #:use-module (system foreign)
+  #:use-module (sdl2 config)
+  #:export (boolean->sdl-bool
+
+            SDL_INIT_TIMER
+            SDL_INIT_AUDIO
+            SDL_INIT_VIDEO
+            SDL_INIT_HAPTIC
+            SDL_INIT_GAMECONTROLLER
+            SDL_INIT_EVENTS
+            SDL_INIT_NOPARACHUTE
+
+            SDL_WINDOW_FULLSCREEN
+            SDL_WINDOW_OPENGL
+            SDL_WINDOW_SHOWN
+            SDL_WINDOW_HIDDEN
+            SDL_WINDOW_BORDERLESS
+            SDL_WINDOW_RESIZABLE
+            SDL_WINDOW_MINIMIZED
+            SDL_WINDOW_MAXIMIZED
+            SDL_WINDOW_INPUT_GRABBED
+            SDL_WINDOW_INPUT_FOCUS
+            SDL_WINDOW_MOUSE_FOCUS
+            SDL_WINDOW_FULLSCREEN_DESKTOP
+            SDL_WINDOW_FOREIGN
+            SDL_WINDOW_ALLOW_HIGHDPI
+            SDL_WINDOW_MOUSE_CAPTURE))
+
+(define sdl-func
+  (let ((lib (dynamic-link %libsdl2)))
+    (lambda (return-type function-name arg-types)
+      "Return a procedure for the foreign function FUNCTION-NAME in
+the SDL2 shared library.  That function must return a value of
+RETURN-TYPE and accept arguments of ARG-TYPES."
+      (pointer->procedure return-type
+                          (dynamic-func function-name lib)
+                          arg-types))))
+
+(define-syntax-rule (define-foreign name return-type func-name arg-types)
+  (define-public name
+    (sdl-func return-type func-name arg-types)))
+
+
+;;;
+;;; Foreign Types
+;;;
+
+(define sdl-bool int)
+
+(define (boolean->sdl-bool b)
+  "Convert the boolean B to an SDL_bool."
+  (if b 1 0))
+
+
+;;;
+;;; Errors
+;;;
+
+(define-foreign sdl-get-error
+  '* "SDL_GetError" '())
+
+
+;;;
+;;; Initialization
+;;;
+
+(define SDL_INIT_TIMER          #x00000001)
+(define SDL_INIT_AUDIO          #x00000010)
+(define SDL_INIT_VIDEO          #x00000020)
+(define SDL_INIT_HAPTIC         #x00001000)
+(define SDL_INIT_GAMECONTROLLER #x00002000)
+(define SDL_INIT_EVENTS         #x00004000)
+
+(define-foreign sdl-init
+  int "SDL_Init" (list uint32))
+
+(define-foreign sdl-quit
+  void "SDL_Quit" '())
+
+
+;;;
+;;; Version
+;;;
+
+(define-foreign sdl-get-version
+  void "SDL_GetVersion" '(*))
+
+
+;;;
+;;; Video
+;;;
+
+(define SDL_WINDOW_FULLSCREEN         #x00000001)
+(define SDL_WINDOW_OPENGL             #x00000002)
+(define SDL_WINDOW_SHOWN              #x00000004)
+(define SDL_WINDOW_HIDDEN             #x00000008)
+(define SDL_WINDOW_BORDERLESS         #x00000010)
+(define SDL_WINDOW_RESIZABLE          #x00000020)
+(define SDL_WINDOW_MINIMIZED          #x00000040)
+(define SDL_WINDOW_MAXIMIZED          #x00000080)
+(define SDL_WINDOW_INPUT_GRABBED      #x00000100)
+(define SDL_WINDOW_INPUT_FOCUS        #x00000200)
+(define SDL_WINDOW_MOUSE_FOCUS        #x00000400)
+(define SDL_WINDOW_FULLSCREEN_DESKTOP (logior SDL_WINDOW_FULLSCREEN
+                                              #x00001000))
+(define SDL_WINDOW_FOREIGN            #x00000800)
+(define SDL_WINDOW_ALLOW_HIGHDPI      #x00002000)
+(define SDL_WINDOW_MOUSE_CAPTURE      #x00004000)
+
+(define-foreign sdl-create-window
+  '* "SDL_CreateWindow" (list '* int int int int uint32))
+
+(define-foreign sdl-destroy-window
+  void "SDL_DestroyWindow" '(*))
+
+(define-foreign sdl-get-window-title
+  '* "SDL_GetWindowTitle" '(*))
+
+(define-foreign sdl-get-window-size
+  void "SDL_GetWindowSize" '(* * *))
+
+(define-foreign sdl-get-window-position
+  void "SDL_GetWindowPosition" '(* * *))
+
+(define-foreign sdl-get-window-id
+  uint32 "SDL_GetWindowID" '(*))
+
+(define-foreign sdl-get-window-from-id
+  '* "SDL_GetWindowFromID" (list uint32))
+
+(define-foreign sdl-hide-window
+  void "SDL_HideWindow" '(*))
+
+(define-foreign sdl-show-window
+  void "SDL_ShowWindow" '(*))
+
+(define-foreign sdl-maximize-window
+  void "SDL_MaximizeWindow" '(*))
+
+(define-foreign sdl-minimize-window
+  void "SDL_MinimizeWindow" '(*))
+
+(define-foreign sdl-raise-window
+  void "SDL_RaiseWindow" '(*))
+
+(define-foreign sdl-restore-window
+  void "SDL_RestoreWindow" '(*))
+
+(define-foreign sdl-set-window-bordered
+  void "SDL_SetWindowBordered" (list '* sdl-bool))
+
+(define-foreign sdl-set-window-title
+  void "SDL_SetWindowTitle" '(* *))
+
+(define-foreign sdl-set-window-position
+  void "SDL_SetWindowPosition" (list '* int int))
+
+(define-foreign sdl-set-window-size
+  void "SDL_SetWindowSize" (list '* int int))
+
+(define-foreign sdl-gl-create-context
+  '* "SDL_GL_CreateContext" '(*))
+
+(define-foreign sdl-gl-delete-context
+  void "SDL_GL_DeleteContext" '(*))
+
+(define-foreign sdl-gl-swap-window
+  void "SDL_GL_SwapWindow" '(*))
diff --git a/sdl2/config.scm.in b/sdl2/config.scm.in
new file mode 100644
index 0000000..4ab9a06
--- /dev/null
+++ b/sdl2/config.scm.in
@@ -0,0 +1,5 @@
+(define-module (sdl2 config)
+  #:export (%libsdl2))
+
+(define %libsdl2
+  "@LIBSDL2@")
diff --git a/sdl2/video.scm b/sdl2/video.scm
new file mode 100644
index 0000000..f7697fc
--- /dev/null
+++ b/sdl2/video.scm
@@ -0,0 +1,256 @@
+;;; guile-sdl2 --- FFI bindings for SDL2
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of guile-sdl2.
+;;;
+;;; Guile-sdl2 is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-sdl2 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 Lesser General Public
+;;; License along with guile-sdl2.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; SDL display and window management functions.
+;;
+;;; Code:
+
+(define-module (sdl2 video)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-4)
+  #:use-module (system foreign)
+  #:use-module ((sdl2 bindings) #:prefix ffi:)
+  #:use-module (sdl2)
+  #:export (sdl-window?
+            make-sdl-window
+            close-sdl-window!
+            call-with-sdl-window
+            sdl-window-title
+            sdl-window-size
+            sdl-window-position
+            sdl-window-id
+            id->sdl-window
+            hide-sdl-window!
+            show-sdl-window!
+            maximize-sdl-window!
+            minimize-sdl-window!
+            raise-sdl-window!
+            restore-sdl-window!
+            set-sdl-window-border!
+            set-sdl-window-title!
+            set-sdl-window-position!
+            set-sdl-window-size!
+
+            make-gl-context
+            gl-context?
+            delete-gl-context!
+            call-with-gl-context
+            swap-gl-sdl-window))
+
+
+;;;
+;;; Windows
+;;;
+
+(define-wrapped-pointer-type <sdl-window>
+  sdl-window?
+  wrap-sdl-window unwrap-sdl-window
+  (lambda (window port)
+    (format port "#<sdl-window id: ~s title: ~s size: ~s position: ~s>"
+            (sdl-window-id window)
+            (sdl-window-title window)
+            (sdl-window-size window)
+            (sdl-window-position window))))
+
+(define* (make-sdl-window #:key (title "Guile SDL2 Window")
+                          (position '(0 0)) (size '(640 480))
+                          (maximize? #f) (minimize? #f)
+                          (show? #t) (resizable? #f)
+                          (opengl? #f) (border? #t)
+                          (fullscreen? #f) (fullscreen-desktop? #f)
+                          (grab-input? #f) (high-dpi? #f))
+  "Create a new window named TITLE with dimensions SIZE located at
+POSITION on the display.  POSITION and SIZE are two-element lists in
+the form '(x y)', where each coordinate is measured in pixels."
+  (define x (match-lambda ((x _) x)))
+  (define y (match-lambda ((_ y) y)))
+
+  (let* ((flags (logior (if fullscreen?
+                            ffi:SDL_WINDOW_FULLSCREEN
+                            0)
+                        (if fullscreen-desktop?
+                            ffi:SDL_WINDOW_FULLSCREEN_DESKTOP
+                            0)
+                        (if opengl?
+                            ffi:SDL_WINDOW_OPENGL
+                            0)
+                        (if show?
+                            0
+                            ffi:SDL_WINDOW_HIDDEN)
+                        (if border?
+                            0
+                            ffi:SDL_WINDOW_BORDERLESS)
+                        (if resizable?
+                            ffi:SDL_WINDOW_RESIZABLE
+                            0)
+                        (if minimize?
+                            ffi:SDL_WINDOW_MINIMIZED
+                            0)
+                        (if maximize?
+                            ffi:SDL_WINDOW_MAXIMIZED
+                            0)
+                        (if grab-input?
+                            ffi:SDL_WINDOW_INPUT_GRABBED
+                            0)
+                        (if high-dpi?
+                            ffi:SDL_WINDOW_ALLOW_HIGHDPI
+                            0)))
+         (ptr (ffi:sdl-create-window (string->pointer title)
+                                     (x position) (y position)
+                                     (x size) (y size)
+                                     flags)))
+    (if (null-pointer? ptr)
+        (sdl-error "make-sdl-window" "failed to create window")
+        (wrap-sdl-window ptr))))
+
+(define (close-sdl-window! window)
+  "Close WINDOW."
+  (ffi:sdl-destroy-window (unwrap-sdl-window window)))
+
+(define (call-with-sdl-window args proc)
+  "Call PROC with a new window defined by ARGS, a list of keyword
+arguments accepted by 'make-sdl-window', and close it when PROC
+returns or otherwise exits."
+  (let ((window (apply make-sdl-window args)))
+    (dynamic-wind
+      (const #t)
+      (lambda () (proc window))
+      (lambda ()
+        (close-sdl-window! window)))))
+
+(define (sdl-window-title window)
+  "Return the title for WINDOW."
+  (pointer->string (ffi:sdl-get-window-title (unwrap-sdl-window window))))
+
+(define (%get-coords window proc)
+  (let ((bv (make-bytevector (* 2 (sizeof int)) 0)))
+    (proc (unwrap-sdl-window window)
+          (bytevector->pointer bv)
+          (bytevector->pointer bv (sizeof int)))
+    (bytevector->sint-list bv (native-endianness) (sizeof int))))
+
+(define (sdl-window-size window)
+  "Return the dimensions of WINDOW."
+  (%get-coords window ffi:sdl-get-window-size))
+
+(define (sdl-window-position window)
+  "Return the position of WINDOW on the display."
+  (%get-coords window ffi:sdl-get-window-position))
+
+(define (sdl-window-id window)
+  "Return the numeric ID of WINDOW."
+  (ffi:sdl-get-window-id (unwrap-sdl-window window)))
+
+(define (id->sdl-window id)
+  "Return the window corresponding to ID, a positive integer, or #f if
+there is no such window."
+  (let ((ptr (ffi:sdl-get-window-from-id id)))
+    (if (null-pointer? ptr)
+        #f
+        (wrap-sdl-window ptr))))
+
+(define (hide-sdl-window! window)
+  "Hide WINDOW."
+  (ffi:sdl-hide-window (unwrap-sdl-window window)))
+
+(define (show-sdl-window! window)
+  "Show WINDOW and focus on it."
+  (ffi:sdl-show-window (unwrap-sdl-window window)))
+
+(define (maximize-sdl-window! window)
+  "Make WINDOW as large as possible."
+  (ffi:sdl-maximize-window (unwrap-sdl-window window)))
+
+(define (minimize-sdl-window! window)
+  "Shrink WINDOW to an iconic representation."
+  (ffi:sdl-minimize-window (unwrap-sdl-window window)))
+
+(define (raise-sdl-window! window)
+  "Raise WINDOW above all other windows and set input focus."
+  (ffi:sdl-raise-window (unwrap-sdl-window window)))
+
+(define (restore-sdl-window! window)
+  "Restore the size and position of a minimized or maximized WINDOW."
+  (ffi:sdl-restore-window (unwrap-sdl-window window)))
+
+(define (set-sdl-window-border! window border?)
+  "When BORDER?, draw the usual border around WINDOW, otherwise remove
+the border."
+  (ffi:sdl-set-window-bordered (unwrap-sdl-window window)
+                               (ffi:boolean->sdl-bool border?)))
+
+(define (set-sdl-window-title! window title)
+  "Set the title of WINDOW to the string TITLE."
+  (ffi:sdl-set-window-title (unwrap-sdl-window window)
+                            (string->pointer title)))
+
+(define (set-sdl-window-position! window position)
+  "Set the position of WINDOW to POSITION, a two-element list of (x,y)
+coordinates measured in pixels."
+  (match position
+    ((x y)
+     (ffi:sdl-set-window-position (unwrap-sdl-window window) x y))))
+
+(define (set-sdl-window-size! window size)
+  "Set the dimensions of WINDOW to SIZE, a two-element list
+of (width,height) coordinates measured in pixels."
+  (match size
+    ((width height)
+     (ffi:sdl-set-window-size (unwrap-sdl-window window) width height))))
+
+
+;;;
+;;; OpenGL
+;;;
+
+(define-wrapped-pointer-type <gl-context>
+  gl-context?
+  wrap-gl-context unwrap-gl-context
+  (lambda (context port)
+    (format port "#<gl-context ~x>"
+            (pointer-address (unwrap-gl-context context)))))
+
+(define (make-gl-context window)
+  "Create an OpenGL context for WINDOW."
+  (let ((ptr (ffi:sdl-gl-create-context (unwrap-sdl-window window))))
+    (if (null-pointer? ptr)
+        (sdl-error "make-gl-context" "failed to create OpenGL context")
+        (wrap-gl-context ptr))))
+
+(define (delete-gl-context! context)
+  "Delete CONTEXT, an OpenGL context object."
+  (ffi:sdl-gl-delete-context (unwrap-gl-context context)))
+
+(define (call-with-gl-context window proc)
+  "Call PROC with a new OpenGL context created for WINDOW, and close
+the context when PROC returns or otherwise exits.."
+  (let ((context (make-gl-context window)))
+    (dynamic-wind
+      (const #t)
+      (lambda () (proc context))
+      (lambda ()
+        (delete-gl-context! context)))))
+
+(define (swap-gl-sdl-window window)
+  "Update WINDOW with OpenGL rendering."
+  (ffi:sdl-gl-swap-window (unwrap-sdl-window window)))