diff options
| -rw-r--r-- | chickadee/graphics/texture.scm | 68 | ||||
| -rw-r--r-- | guix.scm | 6 |
2 files changed, 42 insertions, 32 deletions
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm index e9a13ae..8b61af6 100644 --- a/chickadee/graphics/texture.scm +++ b/chickadee/graphics/texture.scm @@ -16,20 +16,23 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (chickadee graphics texture) + #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (system foreign) #:use-module (gl) #:use-module ((gl enums) #:prefix gl:) - #:use-module ((sdl2 image) #:prefix sdl2:) - #:use-module ((sdl2 surface) #:prefix sdl2:) #:use-module (chickadee math rect) #:use-module (chickadee graphics color) #:use-module (chickadee graphics engine) #:use-module (chickadee graphics gl) + #:use-module (chickadee image jpeg) + #:use-module (chickadee image png) #:use-module (chickadee utils) #:export (make-texture make-texture-region @@ -389,34 +392,41 @@ HEIGHT, 32 bit color bytevector." (bytevector-copy! pixels source-start buffer target-start row-width))) buffer)) +(define (file-extension file-name) + (last (string-split file-name #\.))) + (define (call-with-loaded-image file-name transparent-color flip? proc) - (sdl2:call-with-surface (sdl2:load-image file-name) - (lambda (surface) - (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888) - (lambda (surface) - (let ((width (sdl2:surface-width surface)) - (height (sdl2:surface-height surface)) - (pixels (sdl2:surface-pixels surface))) - ;; Zero the alpha channel of pixels that match the transparent - ;; color key. - (when transparent-color - (let ((r (inexact->exact (* (color-r transparent-color) 255))) - (g (inexact->exact (* (color-g transparent-color) 255))) - (b (inexact->exact (* (color-b transparent-color) 255))) - (pixel-count (* width height 4))) - (for-range ((i pixel-count 0 4)) - (when (and (= r (bytevector-u8-ref pixels i)) - (= g (bytevector-u8-ref pixels (+ i 1))) - (= b (bytevector-u8-ref pixels (+ i 2)))) - (bytevector-u8-set! pixels (+ i 3) 0))))) - (proc (if flip? - (flip-pixels-vertically pixels width height) - ;; Need to copy the pixels for some reason. - ;; Noticed when implementing cube maps when all - ;; 6 texture pieces were all showing up as the - ;; last image loaded. - (bytevector-copy pixels)) - width height))))))) + (let-values (((pixels width height) + (match (file-extension file-name) + ((or "jpg" "jpeg") + (load-jpeg file-name)) + ("png" + (load-png file-name)) + (_ + (raise-exception + (make-exception-with-message + (string-append "image type not supported: " + file-name))))))) + ;; Zero the alpha channel of pixels that match the transparent + ;; color key. + (when transparent-color + (let ((r (inexact->exact (* (color-r transparent-color) 255))) + (g (inexact->exact (* (color-g transparent-color) 255))) + (b (inexact->exact (* (color-b transparent-color) 255))) + (pixel-count (* width height 4))) + (for-range ((i pixel-count 0 4)) + (when (and (= r (bytevector-u8-ref pixels i)) + (= g (bytevector-u8-ref pixels (+ i 1))) + (= b (bytevector-u8-ref pixels (+ i 2)))) + (bytevector-u8-set! pixels (+ i 3) 0))))) + (proc (if flip? + (flip-pixels-vertically pixels width height) + ;; Need to copy the pixels for some reason. + ;; Noticed when implementing cube maps when all + ;; 6 texture pieces were all showing up as the + ;; last image loaded. + (bytevector-copy pixels)) + width height))) (define* (load-image file #:key (min-filter 'nearest) @@ -108,12 +108,12 @@ #:phases (modify-phases %standard-phases (add-after 'unpack 'bootstrap - (lambda _ - (zero? (system* "sh" "bootstrap"))))))) + (lambda _ + (zero? (system* "sh" "bootstrap"))))))) (native-inputs (list autoconf automake pkg-config texinfo)) (inputs - (list target-guile sdl2 sdl2-image)) + (list target-guile 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.") |