summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/texture.scm227
1 files changed, 105 insertions, 122 deletions
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm
index 8b61af6..af36703 100644
--- a/chickadee/graphics/texture.scm
+++ b/chickadee/graphics/texture.scm
@@ -31,14 +31,16 @@
#: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 image)
+ #:use-module (chickadee pixbuf)
#:use-module (chickadee utils)
#:export (make-texture
make-texture-region
make-cube-map
load-image
load-cube-map
+ texture->pixbuf
+ write-texture
texture?
texture-region?
cube-map?
@@ -284,15 +286,16 @@ Currently only 32-bit RGBA format is supported."
(gl-generate-mipmap (texture-target texture-2d))))
texture))
-(define* (make-cube-map faces #:key
+(define* (make-cube-map #:key
+ right left top bottom front back
(min-filter 'linear)
(mag-filter 'linear)
(format 'rgba))
- (define (set-face name pixels width height)
+ (define (set-face name pixbuf)
(gl-texture-image-2d (case name
((right)
(version-1-3 texture-cube-map-positive-x))
- ((left)
+ ((left)
(version-1-3 texture-cube-map-negative-x))
((top)
(version-1-3 texture-cube-map-positive-y))
@@ -302,57 +305,53 @@ Currently only 32-bit RGBA format is supported."
(version-1-3 texture-cube-map-positive-z))
((back)
(version-1-3 texture-cube-map-negative-z)))
- 0 (pixel-format rgba) width height 0
+ 0
+ (pixel-format rgba)
+ (pixbuf-width pixbuf)
+ (pixbuf-height pixbuf)
+ 0
(gl-pixel-format format)
(color-pointer-type unsigned-byte)
- pixels))
- (match faces
- (((right right-width right-height)
- (left left-width left-height)
- (top top-width top-height)
- (bottom bottom-width bottom-height)
- (front front-width front-height)
- (back back-width back-height))
- (assert-current-graphics-engine)
- (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
- min-filter mag-filter
- 'clamp-to-edge 'clamp-to-edge
- 0 0 0 0 #f #f)))
- (graphics-engine-guard! texture)
- (with-graphics-state! ((g:texture-0 texture))
- ;; Ensure that we are using texture unit 0 because
- ;; with-graphics-state! doesn't guarantee it.
- (set-gl-active-texture (version-1-3 texture0))
- (gl-texture-parameter (gl-texture-target 'cube-map)
- (texture-parameter-name texture-min-filter)
- (gl-min-filter min-filter))
- (gl-texture-parameter (gl-texture-target 'cube-map)
- (texture-parameter-name texture-mag-filter)
- (gl-mag-filter mag-filter))
- (gl-texture-parameter (gl-texture-target 'cube-map)
- (texture-parameter-name texture-wrap-s)
- (gl-wrap-mode 'clamp-to-edge))
- (gl-texture-parameter (gl-texture-target 'cube-map)
- (texture-parameter-name texture-wrap-t)
- (gl-wrap-mode 'clamp-to-edge))
- (gl-texture-parameter (gl-texture-target 'cube-map)
- (texture-parameter-name texture-wrap-r-ext)
- (gl-wrap-mode 'clamp-to-edge))
- (set-face 'right right right-width right-height)
- (set-face 'left left left-width left-height)
- (set-face 'top top top-width top-height)
- (set-face 'bottom bottom bottom-width bottom-height)
- (set-face 'front front front-width front-height)
- (set-face 'back back back-width back-height)
- ;; Generate mipmaps, if needed.
- (when (memq min-filter
- '(nearest-mipmap-nearest
- linear-mipmap-nearest
- nearest-mipmap-linear
- linear-mipmap-linear))
- (gl-generate-mipmap (gl-texture-target 'cube-map))))
- texture))
- (_ (error "cube map requires six faces"))))
+ (pixbuf-pixels pixbuf)))
+ (assert-current-graphics-engine)
+ (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
+ min-filter mag-filter
+ 'clamp-to-edge 'clamp-to-edge
+ 0 0 0 0 #f #f)))
+ (graphics-engine-guard! texture)
+ (with-graphics-state! ((g:texture-0 texture))
+ ;; Ensure that we are using texture unit 0 because
+ ;; with-graphics-state! doesn't guarantee it.
+ (set-gl-active-texture (version-1-3 texture0))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-min-filter)
+ (gl-min-filter min-filter))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-mag-filter)
+ (gl-mag-filter mag-filter))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-s)
+ (gl-wrap-mode 'clamp-to-edge))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-t)
+ (gl-wrap-mode 'clamp-to-edge))
+ (gl-texture-parameter (gl-texture-target 'cube-map)
+ (texture-parameter-name texture-wrap-r-ext)
+ (gl-wrap-mode 'clamp-to-edge))
+ (set-face 'right right)
+ (set-face 'left left)
+ (set-face 'top top)
+ (set-face 'bottom bottom)
+ (set-face 'front front)
+ (set-face 'back back)
+ ;; Generate mipmaps, if needed.
+ (when (memq min-filter
+ '(nearest-mipmap-nearest
+ linear-mipmap-nearest
+ nearest-mipmap-linear
+ linear-mipmap-linear))
+ (gl-generate-mipmap (gl-texture-target 'cube-map))))
+ texture))
(define (make-texture-region texture rect)
"Create a new texture region covering a section of TEXTURE defined
@@ -380,85 +379,69 @@ by the bounding box RECT."
(else
(error "regions can only be made from 2d textures")))))
-(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
- (for-range ((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)))
- buffer))
-
-(define (file-extension file-name)
- (last (string-split file-name #\.)))
-
-(define (call-with-loaded-image file-name transparent-color flip? proc)
- (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.
+(define (%load-image image transparent-color flip?)
+ (let ((pixbuf (read-image image)))
+ (when flip?
+ (pixbuf-flip-vertically! pixbuf))
(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
+ (pixbuf-color-key! pixbuf transparent-color))
+ pixbuf))
+
+(define* (load-image image #:key
(min-filter 'nearest)
(mag-filter 'nearest)
(wrap-s 'repeat)
(wrap-t 'repeat)
transparent-color
(flip? #t))
- "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-loaded-image file transparent-color flip?
- (lambda (pixels width height)
- (make-texture pixels width height
- #:min-filter min-filter
- #:mag-filter mag-filter
- #:wrap-s wrap-s
- #:wrap-t wrap-t))))
+ "Load a texture from an image in IMAGE, which can be an image object
+or a file name string. 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* ((image* (if (image? image) image (make-image image)))
+ (pixbuf (%load-image image* transparent-color flip?)))
+ (make-texture (pixbuf-pixels pixbuf)
+ (pixbuf-width pixbuf)
+ (pixbuf-height pixbuf)
+ #:min-filter min-filter
+ #:mag-filter mag-filter
+ #:wrap-s wrap-s
+ #:wrap-t wrap-t)))
(define* (load-cube-map #:key right left top bottom front back
(min-filter 'linear-mipmap-linear)
(mag-filter 'linear))
- (let ((right (call-with-loaded-image right #f #f list))
- (left (call-with-loaded-image left #f #f list))
- (top (call-with-loaded-image top #f #f list))
- (bottom (call-with-loaded-image bottom #f #f list))
- (front (call-with-loaded-image front #f #f list))
- (back (call-with-loaded-image back #f #f list)))
- (make-cube-map (list right left top bottom front back)
- #:min-filter min-filter
- #:mag-filter mag-filter)))
+ (make-cube-map #:right (%load-image right #f #f)
+ #:left (%load-image left #f #f)
+ #:top (%load-image top #f #f)
+ #:bottom (%load-image bottom #f #f)
+ #:front (%load-image front #f #f)
+ #:back (%load-image back #f #f)
+ #:min-filter min-filter
+ #:mag-filter mag-filter))
+
+(define (texture->pixbuf texture)
+ "Return a new pixbuf with the contents of TEXTURE."
+ (let* ((w (texture-width texture))
+ (h (texture-height texture))
+ (pixels (make-bytevector (* w h 4) 0)))
+ (with-graphics-state! ((g:texture-0 texture))
+ (gl-get-tex-image (texture-target texture-2d)
+ 0
+ (gl-pixel-format 'rgba)
+ (color-pointer-type unsigned-byte)
+ (bytevector->pointer pixels)))
+ (let ((pixbuf (bytevector->pixbuf pixels w h
+ #:format 'rgba
+ #:bit-depth 8)))
+ (pixbuf-flip-vertically! pixbuf)
+ pixbuf)))
+
+(define* (write-texture texture
+ #:optional (file-name (temp-image-file-name 'png))
+ #:key (format 'png))
+ "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)"
+ (write-image (texture->pixbuf texture) file-name #:format format))
(define (black-texture)
null-texture)