graphics: texture: Use new pixbuf and image API.

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)