diff options
| -rw-r--r-- | .dir-locals.el | 3 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | README | 5 | ||||
| -rw-r--r-- | TODO.org | 24 | ||||
| -rw-r--r-- | configure.ac | 35 | ||||
| -rwxr-xr-x | examples/2048/2048.scm | 3 | ||||
| -rw-r--r-- | examples/common.scm | 2 | ||||
| -rw-r--r-- | examples/mines/mines.scm | 2 | ||||
| -rw-r--r-- | guix.scm | 55 | ||||
| -rw-r--r-- | sly.scm | 4 | ||||
| -rw-r--r-- | sly/audio.scm | 55 | ||||
| -rw-r--r-- | sly/config.scm.in | 4 | ||||
| -rw-r--r-- | sly/event.scm | 42 | ||||
| -rw-r--r-- | sly/game.scm | 13 | ||||
| -rw-r--r-- | sly/input/joystick.scm | 171 | ||||
| -rw-r--r-- | sly/input/keyboard.scm | 22 | ||||
| -rw-r--r-- | sly/input/mouse.scm | 36 | ||||
| -rw-r--r-- | sly/render.scm | 13 | ||||
| -rw-r--r-- | sly/render/font.scm | 34 | ||||
| -rw-r--r-- | sly/render/texture.scm | 73 | ||||
| -rw-r--r-- | sly/window.scm | 67 | ||||
| -rw-r--r-- | sly/wrappers/freeimage.scm | 264 |
22 files changed, 266 insertions, 663 deletions
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 @@ -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 @@ -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)) @@ -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. @@ -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 <music> @@ -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 <jordan.likes.curry@gmail.com> -;;; -;;; 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 -;;; <http://www.gnu.org/licenses/>. - -;;; 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 <axis-event> - (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 + (($ <vector2> 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 <font> (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 <window> (%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 <dthompson2@worcester.edu> -;;; -;;; 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 -;;; <http://www.gnu.org/licenses/>. - -;;; 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> - freeimage-bitmap? - wrap-freeimage-bitmap unwrap-freeimage-bitmap - (lambda (r port) - (let ((bitmap (unwrap-freeimage-bitmap r))) - (format port - "<freeimage-bitmap ~x width: ~d height: ~d bpp: ~d>" - (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-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) |