diff options
| -rw-r--r-- | .gitignore | 11 | ||||
| -rw-r--r-- | COPYING | 165 | ||||
| -rw-r--r-- | Makefile.am | 52 | ||||
| -rw-r--r-- | README | 65 | ||||
| -rwxr-xr-x | bootstrap | 3 | ||||
| -rw-r--r-- | configure.ac | 57 | ||||
| -rw-r--r-- | guix.scm | 63 | ||||
| -rw-r--r-- | pre-inst-env.in | 32 | ||||
| -rw-r--r-- | sdl2.scm | 79 | ||||
| -rw-r--r-- | sdl2/bindings.scm | 194 | ||||
| -rw-r--r-- | sdl2/config.scm.in | 5 | ||||
| -rw-r--r-- | sdl2/video.scm | 256 |
12 files changed, 982 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..bde866b --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +/Makefile +/Makefile.in +/aclocal.m4 +/autom4te.cache +/build-aux +/config.log +/config.status +/configure +/pre-inst-env +*.go +/sdl2/config.scm @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..93c6e1f --- /dev/null +++ b/Makefile.am @@ -0,0 +1,52 @@ +# 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/>. + +GOBJECTS = $(SOURCES:%.scm=%.go) + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_go_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html> +# for details. +guile_install_go_files = install-nobase_goDATA +$(guile_install_go_files): install-nobase_modDATA + +CLEANFILES = $(GOBJECTS) +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +SUFFIXES = .scm .go +.scm.go: + $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" + +moddir=$(prefix)/share/guile/site/2.0 +godir=$(libdir)/guile/2.0/ccache + +SOURCES = \ + sdl2.scm \ + sdl2/config.scm \ + sdl2/bindings.scm \ + sdl2/video.scm + +EXTRA_DIST += \ + pre-inst-env.in \ + README \ + guix.scm @@ -0,0 +1,65 @@ +-*- mode: org -*- + +Guile-sdl2 provides Guile Scheme bindings for the SDL2 C shared +library. The bindings are written in pure Scheme by using Guile's +foreign function interface. + +* Requirements + + Guile-sdl2 currently depends on the following packages: + + - GNU Guile >= 2.0.9 + - SDL2 >= 2.0.0 + - GNU Make + - GNU pkg-config + + When building from a Git checkout, the following additional packages + are required: + + - GNU Autoconf + - GNU Automake + +* Installing + + Guile-sdl2 uses the standard GNU build system, so installation + requires the usual incantations: + + # ./configure + # make + # make install + + When building from a Git checkout, the following spell is necessary + before running the above commands: + + # ./bootstrap + + GNU Guix users may install the current development snapshot + described in =guix.scm= with the following command: + + # guix package -f guix.scm + +* Developing + + To build the source code from a Git checkout, run the following: + + # ./bootstrap + # ./configure + # make + + To start a Guile REPL with a pre-configured load path for using + guile-sdl2, use the =pre-inst-env= script: + + # ./pre-inst-env guile + + GNU Guix users may create a development environment with all of the + necessary dependencies by running the following command: + + # guix environment -l guix.scm + +* Contact + + Bug reports and patches may be sent to <davet@gnu.org>. + + The maintainer of this library hangs out in the #guile channel on + irc.freenode.net, so help and general discussion may also be found + there. diff --git a/bootstrap b/bootstrap new file mode 100755 index 0000000..872167c --- /dev/null +++ b/bootstrap @@ -0,0 +1,3 @@ +#!/bin/sh + +autoreconf -vif diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..5d25c46 --- /dev/null +++ b/configure.ac @@ -0,0 +1,57 @@ +# -*- Autoconf -*- +# +# 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/>. + +AC_INIT(guile-sdl2, 0.1) +AC_CONFIG_SRCDIR(sdl2) +AC_CONFIG_AUX_DIR([build-aux]) +AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign]) +AM_SILENT_RULES([yes]) + +AC_CONFIG_FILES([Makefile sdl2/config.scm]) +AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) + +GUILE_PROGS([2.0.9]) +PKG_CHECK_MODULES([SDL2], [sdl2]) + +LIBSDL2="libSDL2" +LIBSDL2_LIBDIR="no" +LIBSDL2_PREFIX="no" + +AC_ARG_WITH([libsdl2-prefix], + [AS_HELP_STRING([--with-libsdl2-prefix=DIR], [search for SDL2 in DIR])], + [case "$withval" in + yes|no) + ;; + *) + LIBSDL2="$withval/lib/libSDL2" + LIBSDL2_PREFIX="$withval" + LIBSDL2_LIBDIR="$withval/lib" + ;; + esac]) + +dnl Library name suitable for `dynamic-link'. +AC_MSG_CHECKING([for libSDL2 shared library name]) +AC_MSG_RESULT([$LIBSDL2]) +AC_SUBST([LIBSDL2]) +AC_SUBST([LIBSDL2_PREFIX]) +AC_SUBST([LIBSDL2_LIBDIR]) + +AC_OUTPUT diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..008796b --- /dev/null +++ b/guix.scm @@ -0,0 +1,63 @@ +;;; 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: +;; +;; GNU Guix development package. To build and install, run: +;; +;; guix package -f guix.scm +;; +;; To use as the basis for a development environment, run: +;; +;; guix environment -l guix.scm +;; +;;; Code: + +(use-modules (guix packages) + (guix licenses) + (guix git-download) + (guix build-system gnu) + (gnu packages) + (gnu packages autotools) + (gnu packages guile) + (gnu packages pkg-config) + (gnu packages sdl)) + +(package + (name "guile-sdl2") + (version "0.1") + (source #f) + (build-system gnu-build-system) + (arguments + '(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'bootstrap + (lambda _ (zero? (system* "sh" "bootstrap"))))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("pkg-config" ,pkg-config))) + (inputs + `(("guile" ,guile-2.0) + ("sdl2" ,sdl2))) + (synopsis "Guile bindings for SDL2") + (description "Guile-sdl2 provides pure Guile Scheme bindings to the +SDL2 C shared library via the foreign function interface.") + (home-page "https://git.dthompson.us/guile-sdl2.git") + (license lgpl3+)) diff --git a/pre-inst-env.in b/pre-inst-env.in new file mode 100644 index 0000000..f1e1319 --- /dev/null +++ b/pre-inst-env.in @@ -0,0 +1,32 @@ +#!/bin/sh + +# 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/>. + +abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" +abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" + +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" +export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH + +PATH="$abs_top_builddir/scripts:$PATH" +export PATH + +exec "$@" diff --git a/sdl2.scm b/sdl2.scm new file mode 100644 index 0000000..afed5c0 --- /dev/null +++ b/sdl2.scm @@ -0,0 +1,79 @@ +;;; 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 initialization and error handling. +;; +;;; Code: + +(define-module (sdl2) + #:use-module (ice-9 match) + #:use-module (srfi srfi-4) + #:use-module (system foreign) + #:use-module ((sdl2 bindings) #:prefix ffi:) + #:export (sdl-error-string + sdl-error + sdl-version + sdl-init + sdl-quit)) + +(define %default-init-flags + '(timer audio video haptic game-controller events)) + +(define (sdl-error-string) + "Return the current SDL error string." + (pointer->string (ffi:sdl-get-error))) + +(define (sdl-error func message . args) + (apply throw 'sdl-error func (string-append message ": ~A") + (append args (list (sdl-error-string))))) + +(define (sdl-version) + "Return a three element list containing the major, minor, and patch +version of the linked SDL library." + (let ((bv (make-u8vector 3))) + (ffi:sdl-get-version (bytevector->pointer bv)) + (u8vector->list bv))) + +(define* (sdl-init #:optional (subsystems %default-init-flags)) + "Initialize the SDL library. This must be called before using any +other SDL procedure. + +SUBSYSTEMS is an optional list of symbols that specifies the +subsystems to initialize. All subsystems are initialized by default. +The possible flags are 'timer', 'audio', 'video', 'haptic', +'game-controller', and 'events'." + (let ((flags (apply logior + (map (match-lambda + ('timer ffi:SDL_INIT_TIMER) + ('audio ffi:SDL_INIT_AUDIO) + ('video ffi:SDL_INIT_VIDEO) + ('haptic ffi:SDL_INIT_HAPTIC) + ('game-controller ffi:SDL_INIT_GAMECONTROLLER) + ('events ffi:SDL_INIT_EVENTS)) + subsystems)))) + (unless (zero? (ffi:sdl-init flags)) + (sdl-error "sdl-init" "failed to initialize subsystems ~S" + subsystems)))) + +(define (sdl-quit) + "Quit all activated SDL subsystems. This procedure should be called +upon all exit conditions." + (ffi:sdl-quit)) 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))) |