summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/texture.scm68
-rw-r--r--guix.scm6
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)
diff --git a/guix.scm b/guix.scm
index 295ae85..d079ebd 100644
--- a/guix.scm
+++ b/guix.scm
@@ -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.")