diff options
| -rw-r--r-- | chickadee/graphics/texture.scm | 227 |
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) |