From 8b9b5d371d1dc1c780e227ce9a555cf6c88a85c8 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 22 Dec 2015 14:35:44 -0500 Subject: Upgrade to SDL2! This commit is massive and crazy and I'm not going to do the usual GNU ChangeLog thing because it's just too much. Let's just be happy that the port is completed! --- .dir-locals.el | 3 +- Makefile.am | 2 - README | 5 +- TODO.org | 24 ++++- configure.ac | 35 +----- examples/2048/2048.scm | 3 +- examples/common.scm | 2 +- examples/mines/mines.scm | 2 +- guix.scm | 55 +++++++++- sly.scm | 4 +- sly/audio.scm | 55 +++++----- sly/config.scm.in | 4 - sly/event.scm | 42 ++++++-- sly/game.scm | 13 +-- sly/input/joystick.scm | 171 ----------------------------- sly/input/keyboard.scm | 22 ++-- sly/input/mouse.scm | 36 +++---- sly/render.scm | 13 +-- sly/render/font.scm | 34 ++---- sly/render/texture.scm | 73 +++++++------ sly/window.scm | 67 ++++++------ sly/wrappers/freeimage.scm | 264 --------------------------------------------- 22 files changed, 266 insertions(+), 663 deletions(-) delete mode 100644 sly/input/joystick.scm delete mode 100644 sly/wrappers/freeimage.scm diff --git a/.dir-locals.el b/.dir-locals.el index 0c7a721..3af9ad2 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -18,4 +18,5 @@ (eval . (put 'with-model-view-mul 'scheme-indent-function 1)) (eval . (put 'with-camera 'scheme-indent-function 1)) (eval . (put 'with-color 'scheme-indent-function 1)) - (eval . (put 'uniform-let 'scheme-indent-function 1))))) + (eval . (put 'uniform-let 'scheme-indent-function 1)) + (eval . (put 'call-with-surface 'scheme-indent-function 1))))) diff --git a/Makefile.am b/Makefile.am index 9d24e02..d5336ba 100644 --- a/Makefile.am +++ b/Makefile.am @@ -31,7 +31,6 @@ SOURCES = \ sly/game.scm \ sly/input/keyboard.scm \ sly/input/mouse.scm \ - sly/input/joystick.scm \ sly/live-reload.scm \ sly/math.scm \ sly/math/quaternion.scm \ @@ -63,7 +62,6 @@ SOURCES = \ sly.scm WRAPPER_SOURCES = \ - sly/wrappers/freeimage.scm \ sly/wrappers/gl.scm \ sly/wrappers/gsl.scm \ sly/wrappers/util.scm diff --git a/README b/README index ca6e21a..fe201d8 100644 --- a/README +++ b/README @@ -161,7 +161,6 @@ Sly differentiates itself from most other game engines by encouraging #+BEGIN_SRC sh guix environment -l guix.scm ./bootstrap && ./configure \ - --with-libfreeimage-prefix=$(guix build freeimage) \ --with-libgslcblas-prefix=$(guix build gsl) #+END_SRC @@ -196,9 +195,7 @@ Sly differentiates itself from most other game engines by encouraging - GNU Guile >= 2.0.11 - [[http://www.gnu.org/software/guile-opengl/][guile-opengl]] >= 0.1.0 - - [[https://www.gnu.org/software/guile-sdl/index.html][guile-sdl]] >= 0.5.0 - - SDL 1.2 - - FreeImage >= 3.0 + - [[https://dthompson.us/pages/software/guile-sdl2.html][guile-sdl2]] >= 0.1.0 - GNU Scientific Library (GSL) * Releases diff --git a/TODO.org b/TODO.org index 3c11d06..70b0ba3 100644 --- a/TODO.org +++ b/TODO.org @@ -29,6 +29,11 @@ context when necessary. For example, don't change texture when rendering several sprites in a row that use the same one. + - Use streaming vertex buffers + - See: https://www.opengl.org/wiki/Buffer_Object#Mapping + - See: https://www.opengl.org/wiki/Buffer_Object_Streaming + - See: https://bitbucket.org/rude/love/src/d95dfb67079a60f8de64304dac9002544695f1bb/src/modules/graphics/opengl/SpriteBatch.cpp?at=default + ** DONE Tilesets Break an image up into many small pieces. Useful for creating maps. @@ -136,8 +141,9 @@ - [ ] Scheme -> GLSL compiler Port http://wiki.call-cc.org/eggref/4/glls to guile? -** TODO Upgrade to SDL2 - Write necessary bindings and release [[https://git.dthompson.us/guile-sdl2.git][guile-sdl2]]. +** DONE Upgrade to SDL2 + - Write necessary bindings and release [[https://git.dthompson.us/guile-sdl2.git][guile-sdl2]]. + - Replace freeimage with sdl_image 2.0 ** TODO "Nine patches" Images that have a resizable central area but fixed width/height @@ -167,6 +173,8 @@ cube is 6 squares, etc. A triangle has 3 vertices with a particular winding. +* Release TODO + ** DONE 0.1 Release A 0.1 release was made under the project's old name, guile-2d. Now that things have changed so drastically and the name has been @@ -181,3 +189,15 @@ - [X] Finish FRP module - [X] Make basic webpage with HTML docs - [X] Basic rendering (must support sprites and text) + +** TODO January 2016 Lisp Game Jam + +*** Blockers + + - Sprite batches + - Sound effects and music support + +*** Nice to haves + + - SDL2 migration + - Guix-based standalone binary creation script diff --git a/configure.ac b/configure.ac index 7708392..a31480a 100644 --- a/configure.ac +++ b/configure.ac @@ -19,39 +19,12 @@ sly_datadir="`eval eval echo $datadir | sed -e "s|NONE|$sly_prefix|g"`" AC_SUBST([sly_datadir]) GUILE_PROGS([2.0.11]) -GUILE_MODULE_REQUIRED([sdl sdl]) -GUILE_MODULE_REQUIRED([sdl mixer]) -GUILE_MODULE_REQUIRED([sdl ttf]) +GUILE_MODULE_REQUIRED([sdl2]) +GUILE_MODULE_REQUIRED([sdl2 image]) +GUILE_MODULE_REQUIRED([sdl2 mixer]) +GUILE_MODULE_REQUIRED([sdl2 ttf]) GUILE_MODULE_REQUIRED([gl]) -dnl Freeimage doesn't have a pkg-config file, so use this primitive -dnl test instead. -AC_CHECK_LIB([freeimage], [FreeImage_GetVersion],, - [AC_MSG_ERROR([freeimage not found.])]) - -LIBFREEIMAGE="libfreeimage" -LIBFREEIMAGE_LIBDIR="no" -LIBFREEIMAGE_PREFIX="no" - -AC_ARG_WITH([libfreeimage-prefix], - [AS_HELP_STRING([--with-libfreeimage-prefix=DIR], [search for FreeImage in DIR])], - [case "$withval" in - yes|no) - ;; - *) - LIBFREEIMAGE="$withval/lib/libfreeimage" - LIBFREEIMAGE_PREFIX="$withval" - LIBFREEIMAGE_LIBDIR="$withval/lib" - ;; - esac]) - -dnl Library name suitable for `dynamic-link'. -AC_MSG_CHECKING([for libfreeimage shared library name]) -AC_MSG_RESULT([$LIBFREEIMAGE]) -AC_SUBST([LIBFREEIMAGE]) -AC_SUBST([LIBFREEIMAGE_PREFIX]) -AC_SUBST([LIBFREEIMAGE_LIBDIR]) - LIBGSLCBLAS="libgslcblas" LIBGSLCBLAS_LIBDIR="no" LIBGSLCBLAS_PREFIX="no" diff --git a/examples/2048/2048.scm b/examples/2048/2048.scm index 05eb78b..e9eb16d 100755 --- a/examples/2048/2048.scm +++ b/examples/2048/2048.scm @@ -264,9 +264,8 @@ ;;; Rendering ;;; -(open-window) +(init-window) (enable-fonts) -(enable-audio) (define background (rgb #xfaf8ef)) diff --git a/examples/common.scm b/examples/common.scm index 65e02df..915c5fa 100644 --- a/examples/common.scm +++ b/examples/common.scm @@ -20,7 +20,7 @@ (sly-init) -(add-hook! key-press-hook (lambda (key unicode) +(add-hook! key-press-hook (lambda (key) (when (eq? key 'escape) (stop-game-loop)))) diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm index 0b55d8b..fd7256f 100644 --- a/examples/mines/mines.scm +++ b/examples/mines/mines.scm @@ -288,7 +288,7 @@ ;;; View ;;; -(open-window) +(init-window) (enable-fonts) (define font (load-default-font)) diff --git a/guix.scm b/guix.scm index c425dd3..0effc5d 100644 --- a/guix.scm +++ b/guix.scm @@ -36,7 +36,9 @@ ;; ;;; Code: -(use-modules (guix packages) +(use-modules (ice-9 match) + (srfi srfi-1) + (guix packages) (guix licenses) (guix git-download) (guix build-system gnu) @@ -50,6 +52,50 @@ (gnu packages maths) (gnu packages image)) +(define guile-sdl2 + (package + (name "guile-sdl2") + (version "0.1.0") + (source (origin + (method git-fetch) + (uri (git-reference + (url "git://dthompson.us/guile-sdl2.git") + (commit "6f1b62d"))) + (sha256 + (base32 + "0l2fxbdbw0hggqrs6ai862zdi9x6jibaqb79qfinf6d1rvnyavw3")))) + (build-system gnu-build-system) + (arguments + '(#:configure-flags + (list (string-append "--with-libsdl2-prefix=" + (assoc-ref %build-inputs "sdl2")) + (string-append "--with-libsdl2-image-prefix=" + (assoc-ref %build-inputs "sdl2-image")) + (string-append "--with-libsdl2-ttf-prefix=" + (assoc-ref %build-inputs "sdl2-ttf")) + (string-append "--with-libsdl2-mixer-prefix=" + (assoc-ref %build-inputs "sdl2-mixer"))) + #:make-flags '("GUILE_AUTO_COMPILE=0") + #: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) + ("sdl2-image" ,sdl2-image) + ("sdl2-mixer" ,sdl2-mixer) + ("sdl2-ttf" ,sdl2-ttf))) + (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+))) + (package (name "sly") (version "0.1") @@ -78,12 +124,11 @@ ("automake" ,automake) ("texinfo" ,texinfo))) (propagated-inputs - `(("guile" ,guile-2.0) - ("guile-sdl" ,guile-sdl) + `(("guile-sdl2" ,guile-sdl2) ("guile-opengl" ,guile-opengl))) (inputs - `(("gsl" ,gsl) - ("freeimage" ,freeimage) + `(("guile" ,guile-2.0) + ("gsl" ,gsl) ("mesa" ,mesa))) (synopsis "2D/3D game engine for GNU Guile") (description "Sly is a 2D/3D game engine written in Guile Scheme. diff --git a/sly.scm b/sly.scm index 2c54dfa..3ec28ff 100644 --- a/sly.scm +++ b/sly.scm @@ -24,6 +24,7 @@ (define-module (sly) #:use-module (sly window) #:use-module (sly render font) + #:use-module ((sdl2) #:prefix sdl2:) #:export (sly-init)) (eval-when (eval load compile) @@ -54,5 +55,6 @@ (define* (sly-init #:key (fonts? #t)) "Initialize Sly's global state, such as the OpenGL context." - (open-window) + (sdl2:sdl-init) + (init-window) (when fonts? (enable-fonts))) diff --git a/sly/audio.scm b/sly/audio.scm index 715df11..4f24e43 100644 --- a/sly/audio.scm +++ b/sly/audio.scm @@ -24,12 +24,11 @@ (define-module (sly audio) #:use-module (srfi srfi-9) #:use-module (srfi srfi-2) - #:use-module ((sdl mixer) #:prefix SDL:) + #:use-module ((sdl2 mixer) #:prefix sdl2:) #:export (enable-audio load-sample sample? sample-audio - sample-volume set-sample-volume play-sample load-music @@ -46,7 +45,11 @@ music-playing?)) (define (enable-audio) - (SDL:open-audio)) + ;; The SDL mixer will throw an exception if it cannot initialize a + ;; particular audio format. We don't want this to be fatal, so we + ;; ignore it. + (false-if-exception (sdl2:mixer-init)) + (sdl2:open-audio)) ;; Used to wrap SDL audio functions whose return values should be ;; ignored. @@ -64,20 +67,17 @@ (define (load-sample filename) "Load audio sample from FILENAME or return #f if the file cannot be loaded" - (let ((audio (SDL:load-wave filename))) + (let ((audio (sdl2:load-chunk filename))) (if audio (make-sample audio) #f))) -(define (sample-volume) - "Return the volume that all samples are played at." - (SDL:volume)) - (define (set-sample-volume volume) - "Set the volume that all samples are played at to VOLUME." - (ignore-value (SDL:volume volume))) + "Set the volume that all samples are played at to VOLUME, an integer +value between 0 and 128." + (ignore-value (sdl2:set-channel-volume! #f volume))) (define (play-sample sample) "Play the given audio SAMPLE." - (ignore-value (SDL:play-channel (sample-audio sample)))) + (ignore-value (sdl2:play-chunk! (sample-audio sample)))) ;; Wrapper over SDL music objects. (define-record-type @@ -85,44 +85,43 @@ loaded" music? (audio music-audio)) -(define (load-music filename) - "Load music from FILENAME or return #f if the file cannot be -loaded." - (let ((audio (SDL:load-music filename))) - (if audio (make-music audio) #f))) +(define (load-music file) + "Load music from FILE." + (make-music (sdl2:load-music file))) (define (music-volume) "Return the volume that music is played at." - (SDL:music-volume)) + (sdl2:music-volume)) (define (set-music-volume volume) - "Set the volume that music is played at to VOLUME." - (ignore-value (SDL:volume volume))) + "Set the volume that music is played at to VOLUME, an integer value +between 0 and 128." + (ignore-value (sdl2:set-music-volume! volume))) (define (play-music music) "Play the given MUSIC." - (ignore-value (SDL:play-music (music-audio music)))) + (sdl2:play-music! (music-audio music))) (define (pause-music) "Pause the current music track." - (ignore-value (SDL:pause-music))) + (sdl2:pause-music!)) (define (resume-music) "Resume the current music track." - (ignore-value (SDL:resume-music))) + (sdl2:resume-music!)) (define (rewind-music) "Restart the current music track." - (ignore-value (SDL:rewind-music))) + (sdl2:rewind-music!)) (define (stop-music) "Stop playing the current music track." - (ignore-value (SDL:halt-music))) + (sdl2:stop-music!)) (define (music-playing?) - "Return #t if music is currently playing, otherwise return #f." - (SDL:playing-music?)) + "Return #t if music is currently playing." + (sdl2:music-playing?)) (define (music-paused?) - "Return #t if music is currently paused, otherwise return #f." - (SDL:paused-music?)) + "Return #t if music is currently paused." + (sdl2:music-paused?)) diff --git a/sly/config.scm.in b/sly/config.scm.in index c69a3cc..e0f2cc9 100644 --- a/sly/config.scm.in +++ b/sly/config.scm.in @@ -24,7 +24,6 @@ (define-module (sly config) #:export (%datadir scope-datadir - %libfreeimage %libgslcblas)) (define %datadir @@ -34,8 +33,5 @@ "Append the Sly data directory to FILE." (string-append %datadir file)) -(define %libfreeimage - "@LIBFREEIMAGE@") - (define %libgslcblas "@LIBGSLCBLAS@") diff --git a/sly/event.scm b/sly/event.scm index c5e57cb..90fae3b 100644 --- a/sly/event.scm +++ b/sly/event.scm @@ -22,16 +22,16 @@ ;;; Code: (define-module (sly event) - #:use-module ((sdl sdl) #:prefix SDL:) + #:use-module ((sdl2 events) #:prefix sdl2:) #:export (process-events register-event-handler)) -(define process-events - (let ((e (SDL:make-event))) - (lambda () - "Process all events in the input event queue." - (while (SDL:poll-event e) - (handle-event e))))) +(define (process-events) + "Process all events in the input event queue." + (let ((e (sdl2:poll-event))) + (when e + (handle-event e) + (process-events)))) (define event-handlers (make-hash-table)) @@ -40,6 +40,28 @@ (define (handle-event e) "Run the relevant hook for the event E." - (let ((handle (hashq-get-handle event-handlers (SDL:event:type e)))) - (when handle - ((cdr handle) e)))) + (define (event-type e) + (cond + ((sdl2:keyboard-down-event? e) + 'key-down) + ((sdl2:keyboard-up-event? e) + 'key-up) + ((sdl2:mouse-button-down-event? e) + 'mouse-button-down) + ((sdl2:mouse-button-up-event? e) + 'mouse-button-up) + ((sdl2:mouse-motion-event? e) + 'mouse-motion) + ((sdl2:joystick-button-down-event? e) + 'joy-button-down) + ((sdl2:joystick-button-up-event? e) + 'joy-button-up) + ((sdl2:joystick-axis-event? e) + 'joy-axis-motion) + ((sdl2:window-resized-event? e) + 'window-resize) + ((sdl2:quit-event? e) + 'quit))) + + (let ((handler (hashq-ref event-handlers (event-type e)))) + (and handler (handler e)))) diff --git a/sly/game.scm b/sly/game.scm index b114ada..5f1a1ec 100644 --- a/sly/game.scm +++ b/sly/game.scm @@ -26,7 +26,8 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module ((sdl sdl) #:prefix SDL:) + #:use-module (sdl2) + #:use-module ((sdl2 video) #:prefix sdl2:) #:use-module (gl) #:use-module (sly agenda) #:use-module (sly event) @@ -84,7 +85,7 @@ instead of becoming completely unresponsive and possibly crashing." (gl-clear (clear-buffer-mask color-buffer depth-buffer)) (run-hook draw-hook dt alpha) (with-graphics gfx ((signal-ref scene) gfx)) - (SDL:gl-swap-buffers)) + (swap-window)) (define (update lag) "Call the update callback. The update callback will be called as @@ -108,7 +109,7 @@ leftover frame time LAG." (define (frame-sleep time) "Sleep for the remainder of the frame that started at TIME." (let ((t (- (+ time frame-interval) - (SDL:get-ticks)))) + (sdl-ticks)))) (usleep (max 0 (* t 1000))))) (define (process-frame previous-time lag) @@ -117,7 +118,7 @@ PREVIOUS-TIME to the current time, and updating using a game tick accumulator initialized to LAG. Returns a timestamp to be used as the starting point of the next delta time calculation and the leftover time in the game tick accumulator." - (let* ((current-time (SDL:get-ticks)) + (let* ((current-time (sdl-ticks)) (dt (- current-time previous-time))) (catch #t (lambda () @@ -134,7 +135,7 @@ time in the game tick accumulator." (run-hook after-game-loop-error-hook) ;; An unknown amount of time has passed since running the ;; hook, so let's start with a fresh timer. - (values (SDL:get-ticks) 0)))) + (values (sdl-ticks) 0)))) (lambda (key . args) ;; Strip out 3 stack frames to get to the frame where the ;; error happened. The stripped frames include the throw @@ -156,7 +157,7 @@ milliseconds of the last iteration of the game loop." (lambda (signum) (stop-game-loop))) ;; Let's play! - (game-loop (SDL:get-ticks) 0)) + (game-loop (sdl-ticks) 0)) (lambda (cont callback) (when (procedure? callback) (callback cont)))))) diff --git a/sly/input/joystick.scm b/sly/input/joystick.scm deleted file mode 100644 index 0e465f6..0000000 --- a/sly/input/joystick.scm +++ /dev/null @@ -1,171 +0,0 @@ -;;; Sly -;;; Copyright (C) 2014 Jordan Russell -;;; -;;; This program 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. -;;; -;;; This program 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 -;;; . - -;;; Commentary: -;; -;; Joystick signals -;; -;;; Code: - -(define-module (sly input joystick) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module (sly event) - #:use-module (sly signal) - #:use-module (sly math vector) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:re-export ((SDL:joystick-name . joystick-name) - (SDL:num-joysticks . num-joysticks)) - #:export (enable-joystick - joystick-num-axes - joystick-num-buttons - joystick-axis-hook - joystick-button-press-hook - joystick-button-release-hook - axis-value-raw - raw-axis-max - raw-axis-min - axis-value - button-down? - make-directional-signal - make-directional-signal-raw - axis-scale)) - -(define *joysticks* '()) - -(define (enable-joystick) - (set! *joysticks* - (map SDL:joystick-open - (iota (SDL:num-joysticks))))) - -(define (get-joystick idx) - (list-ref *joysticks* idx)) - -(define-syntax-rule (js-proc->idx-proc (js-proc . name) doc) - (define (name idx) - doc - (if (> idx (SDL:num-joysticks)) - 0 - (js-proc (get-joystick idx))))) - -(js-proc->idx-proc (SDL:joystick-num-axes . joystick-num-axes) - "Get number of axes of joystick at IDX.") - -(js-proc->idx-proc (SDL:joystick-num-buttons . joystick-num-buttons) - "Get number of buttons of joystick at IDX.") - -(define joystick-axis-hook (make-hook 3)) - -(register-event-handler - 'joy-axis-motion - (lambda (e) - (run-hook joystick-axis-hook - (SDL:event:jaxis:which e) - (SDL:event:jaxis:axis e) - (SDL:event:jaxis:value e)))) - -(define-record-type - (make-axis-event which axis value) - axis-event? - (which axis-event-joystick) - (axis axis-event-axis) - (value axis-event-value)) - -(define joystick-button-press-hook (make-hook 2)) - -(register-event-handler - 'joy-button-down - (lambda (e) - (run-hook joystick-button-press-hook - (SDL:event:jbutton:which e) - (SDL:event:jbutton:button e)))) - -(define joystick-button-release-hook (make-hook 2)) - -(register-event-handler - 'joy-button-up - (lambda (e) - (run-hook joystick-button-release-hook - (SDL:event:jbutton:which e) - (SDL:event:jbutton:button e)))) - -(define-signal last-axis-event - (hook->signal joystick-axis-hook 'none - make-axis-event)) - -(define raw-axis-min -32768) -(define raw-axis-max 32767) - -(define (axis-value-raw idx axis) - "Create a signal on the axis at AXIS of the joystick at IDX; -joystick axis values are stored in a signed 16 bit integer and so, -values range from [-32768,32767]." - (signal-map axis-event-value - (signal-filter - (lambda (e) - (and (axis-event? e) - (= (axis-event-joystick e) idx) - (= (axis-event-axis e) axis))) - (make-axis-event idx axis 0) - last-axis-event))) - -(define (make-directional-signal-raw idx x-axis y-axis) - "Create a signal for a Dpad or Analog stick with X and Y axes; -values range from [-32768,32767]." - (signal-map vector2 - (axis-value-raw idx x-axis) - (axis-value-raw idx y-axis))) - -(define (axis-scale raw-value) - "Map a RAW-VALUE in [-32768, 32767] to a value in [-1, 1]." - (define (clamp x) - (cond ((< (abs x) 1/100) 0) - ((> x 99/100) 1) - ((< x -99/100) -1) - (else x))) - (clamp (/ raw-value 32768))) - -(define (axis-value idx axis) - "Create a signal for the value of AXIS on joystick IDX; -values are scaled to [-1,1]." - (signal-map axis-scale (axis-value-raw idx axis))) - -(define (make-directional-signal idx x-axis y-axis) - "Create a signal for a Dpad or Analog stick with X and Y axes; -values are scaled to [-1,1]." - (signal-map (lambda (v) - (vector2 (axis-scale (vx v)) - (axis-scale (vy v)))) - (make-directional-signal-raw idx x-axis y-axis))) - -(define-signal button-last-down - (hook->signal joystick-button-press-hook 'none - list)) - -(define-signal button-last-up - (hook->signal joystick-button-release-hook 'none - list)) - -;; shamelessly copied from keyboard.scm -(define (button-down? idx n) - "Create a signal for the state of button N on joystick at IDX" - (define (same-button? l) - (equal? (list idx n) l)) - (define (button-filter value signal) - (signal-constant value (signal-filter same-button? #f signal))) - (signal-merge (button-filter #f button-last-up) - (button-filter #t button-last-down))) diff --git a/sly/input/keyboard.scm b/sly/input/keyboard.scm index 574375e..370775c 100644 --- a/sly/input/keyboard.scm +++ b/sly/input/keyboard.scm @@ -22,7 +22,7 @@ ;;; Code: (define-module (sly input keyboard) - #:use-module ((sdl sdl) #:prefix SDL:) + #:use-module ((sdl2 events) #:prefix sdl2:) #:use-module (sly event) #:use-module (sly signal) #:use-module (sly math vector) @@ -35,33 +35,25 @@ key-arrows key-wasd)) -(define key-press-hook (make-hook 2)) +(define key-press-hook (make-hook 1)) (register-event-handler 'key-down (lambda (e) - (run-hook key-press-hook - (SDL:event:key:keysym:sym e) - (SDL:event:key:keysym:unicode e)))) + (run-hook key-press-hook (sdl2:keyboard-event-key e)))) (define-signal key-last-down - (hook->signal key-press-hook 'none - (lambda (key unicode) - key))) + (hook->signal key-press-hook 'none identity)) -(define key-release-hook (make-hook 2)) +(define key-release-hook (make-hook 1)) (register-event-handler 'key-up (lambda (e) - (run-hook key-release-hook - (SDL:event:key:keysym:sym e) - (SDL:event:key:keysym:unicode e)))) + (run-hook key-release-hook (sdl2:keyboard-event-key e)))) (define-signal key-last-up - (hook->signal key-release-hook 'none - (lambda (key unicode) - key))) + (hook->signal key-release-hook 'none identity)) (define (key-down? key) "Create a signal for the state of KEY. The signal value is #t when diff --git a/sly/input/mouse.scm b/sly/input/mouse.scm index d8ff1c6..c6d2b96 100644 --- a/sly/input/mouse.scm +++ b/sly/input/mouse.scm @@ -22,7 +22,8 @@ ;;; Code: (define-module (sly input mouse) - #:use-module ((sdl sdl) #:prefix SDL:) + #:use-module (ice-9 match) + #:use-module ((sdl2 events) #:prefix sdl2:) #:use-module (sly window) #:use-module (sly event) #:use-module (sly signal) @@ -37,57 +38,56 @@ mouse-last-up mouse-down?)) -(define mouse-move-hook (make-hook 2)) +(define mouse-move-hook (make-hook 1)) (register-event-handler 'mouse-motion (lambda (e) (run-hook mouse-move-hook - (SDL:event:motion:x e) - (SDL:event:motion:y e)))) + (vector2 (sdl2:mouse-motion-event-x e) + (sdl2:mouse-motion-event-y e))))) (define-signal mouse-position (hook->signal mouse-move-hook (vector2 0 0) ;; Sly uses the bottom-left as the origin, so invert ;; the y-axis for convenience. - (lambda (x y) - (vector2 x (- (signal-ref window-height) y))))) + (match-lambda + (($ x y) + (vector2 x (- (signal-ref window-height) y)))))) (define-signal mouse-x (signal-map vx mouse-position)) (define-signal mouse-y (signal-map vy mouse-position)) -(define mouse-press-hook (make-hook 3)) +(define mouse-press-hook (make-hook 2)) (register-event-handler 'mouse-button-down (lambda (e) (run-hook mouse-press-hook - (SDL:event:button:button e) - (SDL:event:button:x e) - (SDL:event:button:y e)))) + (sdl2:mouse-button-event-button e) + (vector2 (sdl2:mouse-button-event-x e) + (sdl2:mouse-button-event-y e))))) (define-signal mouse-last-down (hook->signal mouse-press-hook 'none - (lambda (button x y) - button))) + (lambda (button position) button))) -(define mouse-click-hook (make-hook 3)) +(define mouse-click-hook (make-hook 2)) (register-event-handler 'mouse-button-up (lambda (e) (run-hook mouse-click-hook - (SDL:event:button:button e) - (SDL:event:button:x e) - (SDL:event:button:y e)))) + (sdl2:mouse-button-event-button e) + (vector2 (sdl2:mouse-button-event-x e) + (sdl2:mouse-button-event-y e))))) (define-signal mouse-last-up (hook->signal mouse-click-hook 'none - (lambda (button x y) - button))) + (lambda (button position) button))) (define (mouse-down? button) "Create a signal for the state of BUTTON. Value is #t when mouse diff --git a/sly/render.scm b/sly/render.scm index b6dd3fb..875f7c1 100644 --- a/sly/render.scm +++ b/sly/render.scm @@ -519,11 +519,8 @@ COLOR and applies RENDERER." (graphics-model-view-excursion gfx (lambda (gfx) (graphics-model-view-mul! gfx (graphics-projection-transform gfx)) - (graphics-mesh-excursion gfx - (lambda (gfx) - (set-graphics-mesh! gfx mesh) - (graphics-uniform-excursion gfx - `((mvp ,(graphics-model-view-transform gfx)) - (texture? ,(not (texture-null? - (graphics-texture gfx))))) - draw-graphics-mesh!))))))) + (set-graphics-mesh! gfx mesh) + (graphics-uniform-excursion gfx + `((mvp ,(graphics-model-view-transform gfx)) + (texture? ,(not (texture-null? (graphics-texture gfx))))) + draw-graphics-mesh!))))) diff --git a/sly/render/font.scm b/sly/render/font.scm index 433e4bc..f9d1a91 100644 --- a/sly/render/font.scm +++ b/sly/render/font.scm @@ -27,8 +27,9 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (system foreign) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module ((sdl ttf) #:prefix SDL:) + #:use-module ((sdl2) #:prefix sdl2:) + #:use-module ((sdl2 surface) #:prefix sdl2:) + #:use-module ((sdl2 ttf) #:prefix sdl2:) #:use-module (gl) #:use-module (sly wrappers gl) #:use-module (sly render color) @@ -47,7 +48,7 @@ ;;; (define (enable-fonts) - (SDL:ttf-init)) + (sdl2:ttf-init)) (define-record-type (make-font ttf point-size) @@ -58,7 +59,7 @@ (define (load-font filename point-size) "Load the TTF font in FILENAME with the given POINT-SIZE." (if (file-exists? filename) - (make-font (SDL:load-font filename point-size) point-size) + (make-font (sdl2:load-font filename point-size) point-size) (error "File not found!" filename))) (define* (load-default-font #:optional (point-size 12)) @@ -66,33 +67,14 @@ argument with a default value of 12." (load-font (string-append %datadir "/fonts/DejaVuSans.ttf") point-size)) -(define (flip-pixels-vertically pixels width height) - "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x -HEIGHT, 32 bit color bytevector." - (let ((buffer (make-u8vector (bytevector-length pixels))) - (row-width (* width 4))) ; assuming 32 bit color - (let loop ((y 0)) - (when (< y height) - (let* ((y* (- height y 1)) - (source-start (* y row-width)) - (target-start (* y* row-width))) - (bytevector-copy! pixels source-start buffer target-start row-width) - (loop (1+ y))))) - buffer)) +(define %sdl-white (sdl2:make-color 255 255 255 255)) (define (render-text font text) "Return a new texture with TEXT rendered using FONT." ;; An empty string will result in a surface value of #f, in which ;; case we want to abort the texture creation process. - (and-let* ((surface (SDL:render-utf8 (font-ttf font) text - (SDL:make-color 255 255 255) #t)) - (width (SDL:surface:w surface)) - (height (SDL:surface:h surface)) - ;; Need to flip pixels so that origin is on the bottom-left. - (pixels (flip-pixels-vertically (SDL:surface-pixels surface) - width height))) - ;; Need to flip pixels so that origin is on the bottom-left. - (bytevector->texture pixels width height 'linear 'linear))) + (let ((surface (sdl2:render-font-blended (font-ttf font) text %sdl-white))) + ((@@ (sly render texture) surface->texture) surface 'linear 'linear))) (define* (make-label font text #:key (anchor 'top-left)) "Create a sprite that displays TEXT rendered using FONT. ANCHOR diff --git a/sly/render/texture.scm b/sly/render/texture.scm index ef8c3ea..bb7f88c 100644 --- a/sly/render/texture.scm +++ b/sly/render/texture.scm @@ -24,18 +24,19 @@ (define-module (sly render texture) #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-9) #:use-module (gl) #:use-module (gl low-level) #:use-module (gl contrib packed-struct) + #:use-module (sdl2 image) + #:use-module (sdl2 surface) #:use-module (sly render color) #:use-module (sly utils) #:use-module (sly math vector) #:use-module (sly wrappers gl) - #:use-module (sly wrappers freeimage) #:export (make-texture make-texture-region - bytevector->texture load-texture texture? texture-region? @@ -140,36 +141,46 @@ downscaling and MAG-FILTER for upscaling." pixels)) (make-texture texture-id #f width height 0 0 1 1))) -(define (bitmap->texture bitmap min-filter mag-filter) - "Translates a freeimage bitmap into an OpenGL texture." - (bytevector->texture (freeimage-get-bits bitmap) - (freeimage-get-width bitmap) - (freeimage-get-height bitmap) - min-filter mag-filter - (version-1-2 bgra))) - -(define (load-bitmap filename) - ;; Throw an error if image file does not exist or else we will - ;; segfault later. - (unless (file-exists? filename) - (throw 'image-not-found filename)) - ;; Load image and convert it to 32 bit color. - (let* ((image-type (freeimage-get-file-type filename)) - (bitmap (freeimage-load image-type filename)) - (32bit-bitmap (freeimage-convert-to-32-bits bitmap))) - (freeimage-unload bitmap) - 32bit-bitmap)) - -(define* (load-texture file-name #:optional #:key +(define (flip-pixels-vertically pixels width height) + "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x +HEIGHT, 32 bit color bytevector." + (let ((buffer (make-u8vector (bytevector-length pixels))) + (row-width (* width 4))) ; assuming 32 bit color + (let loop ((y 0)) + (when (< y height) + (let* ((y* (- height y 1)) + (source-start (* y row-width)) + (target-start (* y* row-width))) + (bytevector-copy! pixels source-start buffer target-start row-width) + (loop (1+ y))))) + buffer)) + +(define (surface->texture surface min-filter mag-filter) + "Convert SURFACE, an SDL2 surface object, into a texture that uses +the given MIN-FILTER and MAG-FILTER." + ;; Convert to 32 bit RGBA color. + (call-with-surface (convert-surface-format surface 'abgr8888) + (lambda (surface) + (let* ((width (surface-width surface)) + (height (surface-height surface)) + ;; OpenGL textures use the bottom-left corner as the + ;; origin, whereas SDL uses the top-left, so the rows + ;; of pixels must be reversed before creating a + ;; texture from them. + (pixels (flip-pixels-vertically (surface-pixels surface) + width height))) + (bytevector->texture pixels width height + min-filter mag-filter))))) + +(define* (load-texture file #:optional #:key (min-filter 'nearest) (mag-filter 'nearest)) - "Load a texture from an image file at FILENAME. MIN-FILTER and -MAG-FILTER describe the method that should be used for minification -and magnification. Valid values are 'nearest and 'linear. By -default, 'nearest is used." - (let* ((bitmap (load-bitmap file-name)) - (texture (bitmap->texture bitmap min-filter mag-filter))) - (freeimage-unload bitmap) - texture)) + "Load a texture from an image in FILE. MIN-FILTER and MAG-FILTER +describe the method that should be used for minification and +magnification. Valid values are 'nearest and 'linear. By default, +'nearest is used." + (call-with-surface (load-image file) + (lambda (surface) + (surface->texture surface min-filter mag-filter)))) (define (anchor-texture texture anchor) "Translate ANCHOR into a vector that represents the desired centtral diff --git a/sly/window.scm b/sly/window.scm index 0ee28cb..de52daa 100644 --- a/sly/window.scm +++ b/sly/window.scm @@ -22,9 +22,11 @@ ;;; Code: (define-module (sly window) + #:use-module (ice-9 match) #:use-module (srfi srfi-9) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module ((sdl mixer) #:prefix SDL:) + #:use-module ((sdl2) #:prefix sdl2:) + #:use-module ((sdl2 events) #:prefix sdl2:) + #:use-module ((sdl2 video) #:prefix sdl2:) #:use-module (sly event) #:use-module (sly signal) #:use-module (sly math transform) @@ -38,11 +40,12 @@ window-height window-size window-projection - open-window - close-window with-window window-resize-hook - window-close-hook)) + window-close-hook + + init-window + swap-window)) (define-record-type (%make-window title resolution fullscreen?) @@ -57,21 +60,17 @@ (fullscreen? #f)) (%make-window title resolution fullscreen?)) -(define window-resize-hook (make-hook 2)) +(define window-resize-hook (make-hook 1)) (register-event-handler - 'video-resize + 'window-resize (lambda (e) - (let ((width (SDL:event:resize:w e)) - (height (SDL:event:resize:h e))) - ;; Reset video mode. - (SDL:set-video-mode width height 24 '(opengl)) - (run-hook window-resize-hook width height)))) + (match (sdl2:window-event-vector e) + ((width height) + (run-hook window-resize-hook (vector2 width height)))))) (define-signal window-size - (hook->signal window-resize-hook - (vector2 0 0) - vector2)) + (hook->signal window-resize-hook (vector2 0 0) identity)) (define-signal window-width (signal-map vx window-size)) (define-signal window-height (signal-map vy window-size)) @@ -89,26 +88,30 @@ (lambda (e) (run-hook window-close-hook))) -(define* (open-window #:optional (window (make-window #:title ""))) - "Open the game window using the settings in WINDOW." - (let ((flags (if (window-fullscreen? window) '(opengl fullscreen) 'opengl)) - (width (vx (window-resolution window))) - (height (vy (window-resolution window)))) - (signal-set! window-size (vector2 width height)) - ;; Initialize everything - (SDL:enable-unicode #t) - (SDL:init 'everything) - ;; Open SDL window in OpenGL mode. - (unless (SDL:set-video-mode width height 24 flags) - (error "Failed to open window:" width height flags)) - (SDL:set-caption (window-title window)))) +(define %sdl-window #f) +(define %gl-context #f) + +(define (init-window) + (set! %sdl-window (sdl2:make-window #:opengl? #t #:show? #t)) + (set! %gl-context (sdl2:make-gl-context %sdl-window))) + +(define (open-window window) + (let ((res (window-resolution window))) + (sdl2:set-window-title! %sdl-window (window-title window)) + (sdl2:set-window-size! %sdl-window (list (vx res) (vy res))) + (sdl2:show-window! %sdl-window) + (signal-set! window-size res))) (define (close-window) - "Close the currently open window." - (SDL:quit)) + (sdl2:hide-window! %sdl-window) + (sdl2:sdl-quit)) (define-syntax-rule (with-window window body ...) (dynamic-wind - (lambda () (open-window window)) + (lambda () + (open-window window)) (lambda () body ...) - (lambda () (close-window)))) + close-window)) + +(define (swap-window) + (sdl2:swap-gl-window %sdl-window)) diff --git a/sly/wrappers/freeimage.scm b/sly/wrappers/freeimage.scm deleted file mode 100644 index eb1ceeb..0000000 --- a/sly/wrappers/freeimage.scm +++ /dev/null @@ -1,264 +0,0 @@ -;;; Sly -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program 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. -;;; -;;; This program 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 -;;; . - -;;; Commentary: -;; -;; Quick and dirty wrapper for some freeimage functions. -;; -;;; Code: - -(define-module (sly wrappers freeimage) - #:use-module (system foreign) - #:use-module (ice-9 format) - #:use-module (sly config) - #:use-module (sly wrappers util)) - -(define libfreeimage (dynamic-link %libfreeimage)) - -(define-syntax-rule (define-foreign name ret string-name args) - (define name - (pointer->procedure ret (dynamic-func string-name libfreeimage) args))) - -(define (number->boolean n) - (not (zero? n))) - -;;; -;;; FreeImage file formats -;;; - -(define-enumeration freeimage-format - (unknown -1) - (bmp 0) - (ico 1) - (jpeg 2) - (jng 3) - (koala 4) - (lbm 5) - (iff 5) - (mng 6) - (pbm 7) - (pbmraw 8) - (pcd 9) - (pcx 10) - (pgm 11) - (pgmraw 12) - (png 13) - (ppm 14) - (ppmraw 15) - (ras 16) - (targa 17) - (tiff 18) - (wbmp 19) - (psd 20) - (cut 21) - (xbm 22) - (xpm 23) - (dds 24) - (gif 25) - (hdr 26) - (faxg3 27) - (sgi 28) - (exr 29) - (j2k 30) - (jp2 31) - (pfm 32) - (pict 33) - (raw 34)) - -(export freeimage-format) - -;;; -;;; General functions -;;; - -(define-foreign %freeimage-get-version - '* "FreeImage_GetVersion" '()) -(define-foreign %freeimage-set-output-message - void "FreeImage_SetOutputMessage" '(*)) - -(define (freeimage-get-version) - (pointer->string (%freeimage-get-version))) - -(define (freeimage-set-output-message callback) - (%freeimage-set-output-message - (procedure->pointer void - (lambda (image-format message) - (callback image-format (pointer->string message))) - (list unsigned-int '*)))) - -;; Set a default output message callback to writes to stdout. -(freeimage-set-output-message - (lambda (image-format message) - (display "freeimage error: ") - (display message) - (newline))) - -(export freeimage-get-version - freeimage-set-output-message) - - -;;; -;;; Bitmap management functions -;;; - -(define-wrapped-pointer-type - freeimage-bitmap? - wrap-freeimage-bitmap unwrap-freeimage-bitmap - (lambda (r port) - (let ((bitmap (unwrap-freeimage-bitmap r))) - (format port - "" - (pointer-address bitmap) - (%freeimage-get-width bitmap) - (%freeimage-get-height bitmap) - (%freeimage-get-bpp bitmap))))) - -(define-foreign %freeimage-load - '* "FreeImage_Load" (list unsigned-int '* unsigned-int)) -(define-foreign %freeimage-unload - void "FreeImage_Unload" '(*)) - -(define (freeimage-load image-format filename) - (wrap-freeimage-bitmap - (%freeimage-load image-format (string->pointer filename) 0))) - -(define (freeimage-unload bitmap) - (%freeimage-unload (unwrap-freeimage-bitmap bitmap))) - -(export - freeimage-bitmap? - freeimage-load - freeimage-unload) - -;;; -;;; Bitmap information functions -;;; - -(define-foreign %freeimage-get-image-type - unsigned-int "FreeImage_GetImageType" '(*)) -(define-foreign %freeimage-get-bpp - unsigned-int "FreeImage_GetBPP" '(*)) -(define-foreign %freeimage-get-width - unsigned-int "FreeImage_GetWidth" '(*)) -(define-foreign %freeimage-get-height - unsigned-int "FreeImage_GetHeight" '(*)) -(define-foreign %freeimage-get-pitch - unsigned-int "FreeImage_GetPitch" '(*)) -(define-foreign %freeimage-get-red-mask - unsigned-int "FreeImage_GetRedMask" '(*)) -(define-foreign %freeimage-get-green-mask - unsigned-int "FreeImage_GetGreenMask" '(*)) -(define-foreign %freeimage-get-blue-mask - unsigned-int "FreeImage_GetBlueMask" '(*)) -(define-foreign %freeimage-has-pixels - unsigned-int "FreeImage_HasPixels" '(*)) - -(define (freeimage-get-image-type bitmap) - (%freeimage-get-image-type (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-bpp bitmap) - (%freeimage-get-bpp (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-width bitmap) - (%freeimage-get-width (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-height bitmap) - (%freeimage-get-height (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-pitch bitmap) - (%freeimage-get-pitch (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-red-mask bitmap) - (%freeimage-get-red-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-green-mask bitmap) - (%freeimage-get-green-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-blue-mask bitmap) - (%freeimage-get-blue-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-has-pixels? bitmap) - (number->boolean - (%freeimage-has-pixels (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-get-image-type - freeimage-get-bpp - freeimage-get-width - freeimage-get-height - freeimage-get-red-mask - freeimage-get-green-mask - freeimage-get-blue-mask - freeimage-has-pixels?) - -;;; -;;; Filetype functions -;;; - -(define-foreign %freeimage-get-file-type - unsigned-int "FreeImage_GetFileType" (list '* int)) - -(define (freeimage-get-file-type filename) - (%freeimage-get-file-type (string->pointer filename) 0)) - -(export freeimage-get-file-type) - -;;; -;;; Pixel access functions -;;; - -(define-foreign %freeimage-get-bits '* "FreeImage_GetBits" '(*)) - -(define (freeimage-get-bits bitmap) - (pointer->bytevector - (%freeimage-get-bits (unwrap-freeimage-bitmap bitmap)) - (* (freeimage-get-height bitmap) - (freeimage-get-pitch bitmap)))) - -(export freeimage-get-bits) - -;;; -;;; Conversion functions -;;; - -(define-foreign %freeimage-convert-to-24-bits - '* "FreeImage_ConvertTo24Bits" '(*)) -(define-foreign %freeimage-convert-to-32-bits - '* "FreeImage_ConvertTo32Bits" '(*)) - -(define (freeimage-convert-to-24-bits bitmap) - (wrap-freeimage-bitmap - (%freeimage-convert-to-24-bits (unwrap-freeimage-bitmap bitmap)))) - -(define (freeimage-convert-to-32-bits bitmap) - (wrap-freeimage-bitmap - (%freeimage-convert-to-32-bits (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-convert-to-24-bits - freeimage-convert-to-32-bits) - -;;; -;;; Rotation and flipping -;;; - -(define-foreign %freeimage-flip-vertical - uint8 "FreeImage_FlipVertical" '(*)) - -(define (freeimage-flip-vertical bitmap) - (number->boolean - (%freeimage-flip-vertical (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-flip-vertical) -- cgit v1.2.3