Allow textures to be built with raw bytevectors or nothing.

This fixes a large, unnecessary allocation of a pixbuf in
make-framebuffer and skips pixbuf allocation in a few other places.
Since framebuffer textures are not defined by some input bitmap, it
does not make sense to allocate a useless empty pixbuf.

3 files changed, 75 insertions, 27 deletions

diff --git a/chickadee/graphics/framebuffer.scm b/chickadee/graphics/framebuffer.scm
index 9c4b99b..a05d6ef 100644
--- a/chickadee/graphics/framebuffer.scm
+++ b/chickadee/graphics/framebuffer.scm
@@ -103,7 +103,7 @@ dimensions WIDTH x HEIGHT."
   (assert-current-graphics-engine)
   (let* ((framebuffer-id (generate-framebuffer))
          (renderbuffer-id (generate-renderbuffer))
-         (texture (make-texture (make-pixbuf width height)
+         (texture (make-texture width height
                                 #:min-filter min-filter
                                 #:mag-filter mag-filter
                                 #:wrap-s wrap-s
diff --git a/chickadee/graphics/text.scm b/chickadee/graphics/text.scm
index 41765d9..12269ac 100644
--- a/chickadee/graphics/text.scm
+++ b/chickadee/graphics/text.scm
@@ -197,7 +197,8 @@ non-smooth scaling will be used."
                char-set))
              (texture-filter (if smooth? 'linear 'nearest))
              ;; TODO: Use multiple textures if needed.
-             (texture (make-texture (bytevector->pixbuf pixels texture-size texture-size)
+             (texture (make-texture texture-size texture-size
+                                    #:pixels pixels
                                     #:min-filter texture-filter
                                     #:mag-filter texture-filter)))
         ;; Process kernings.
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm
index afb1977..a008174 100644
--- a/chickadee/graphics/texture.scm
+++ b/chickadee/graphics/texture.scm
@@ -35,6 +35,7 @@
   #:export (make-texture
             make-texture-region
             make-cube-map
+            pixbuf->texture
             load-image
             load-cube-map
             texture->pixbuf
@@ -227,25 +228,74 @@
     ((rgba)
      (pixel-format rgba))))
 
-(define* (make-texture pixbuf #:key
-                       flip?
+(define* (make-texture width height #:key
+                       pixels flip?
                        (min-filter 'nearest)
                        (mag-filter 'nearest)
                        (wrap-s 'repeat)
                        (wrap-t 'repeat)
                        (format 'rgba))
-  "Translate the bytevector PIXELS into an OpenGL texture with
-dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
-The first pixel in PIXELS corresponds to the upper-left corner of the
-image.  If this is not the case and the first pixel corresponds to the
-lower-left corner of the image, set FLIP? to #t.  The generated
-texture uses MIN-FILTER for downscaling and MAG-FILTER for upscaling.
-WRAP-S and WRAP-T are symbols that control how texture access is
-handled for texture coordinates outside the [0, 1] range.  Allowed
-symbols are: repeat (the default), mirrored-repeat, clamp,
+  "Return a new GPU texture of WIDTH x HEIGHT pixels in size.  PIXELS
+may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in
+which case the texture will contain a copy of that data.  If PIXELS is
+not provided, the texture data will not be initialized.  If FLIP? is
+#t then the texture coordinates will be flipped vertically.  The
+generated texture uses MIN-FILTER for downscaling and MAG-FILTER for
+upscaling.  WRAP-S and WRAP-T are symbols that control how texture
+access is handled for texture coordinates outside the [0, 1] range.
+Allowed symbols are: repeat (the default), mirrored-repeat, clamp,
 clamp-to-border, clamp-to-edge.  FORMAT specifies the pixel format.
 Currently only 32-bit RGBA format is supported."
   (assert-current-graphics-engine)
+  (let ((texture (%make-texture (gl-generate-texture) '2d #f
+                                min-filter mag-filter wrap-s wrap-t
+                                0 0 width height
+                                (make-rect 0.0 0.0 width height)
+                                (if flip?
+                                    (make-rect 0.0 1.0 1.0 -1.0)
+                                    (make-rect 0.0 0.0 1.0 1.0)))))
+    (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 (texture-target texture-2d)
+                            (texture-parameter-name texture-min-filter)
+                            (gl-min-filter min-filter))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-mag-filter)
+                            (gl-mag-filter mag-filter))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-wrap-s)
+                            (gl-wrap-mode wrap-s))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-wrap-t)
+                            (gl-wrap-mode wrap-t))
+      (when pixels
+        (gl-texture-image-2d (texture-target texture-2d)
+                             0 (pixel-format rgba) width height 0
+                             (gl-pixel-format format)
+                             (color-pointer-type unsigned-byte)
+                             pixels))
+      ;; Generate mipmaps, if needed.
+      (when (memq min-filter
+                  '(nearest-mipmap-nearest
+                    linear-mipmap-nearest
+                    nearest-mipmap-linear
+                    linear-mipmap-linear))
+        (gl-generate-mipmap (texture-target texture-2d))))
+    texture))
+
+(define* (pixbuf->texture pixbuf #:key
+                          flip?
+                          (min-filter 'nearest)
+                          (mag-filter 'nearest)
+                          (wrap-s 'repeat)
+                          (wrap-t 'repeat)
+                          (format 'rgba))
+  "Translate PIXBUF into a texture stored on the GPU.  See
+'make-texture' for documentation of all keyword arguments."
+  (assert-current-graphics-engine)
   (let* ((width (pixbuf-width pixbuf))
          (height (pixbuf-height pixbuf))
          (texture (%make-texture (gl-generate-texture) '2d #f
@@ -400,11 +450,11 @@ 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
-                  #:min-filter min-filter
-                  #:mag-filter mag-filter
-                  #:wrap-s wrap-s
-                  #:wrap-t wrap-t)))
+    (pixbuf->texture 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)
@@ -446,18 +496,16 @@ are 'nearest and 'linear.  By default, 'nearest is used."
 
 (define %white-texture
   (delay
-    (make-texture
-     (bytevector->pixbuf (u32vector #xffffffff #xffffffff #xffffffff #xffffffff)
-                         2 2))))
+    (make-texture 2 2 #:pixels (u32vector #xffffffff #xffffffff
+                                          #xffffffff #xffffffff))))
 
 (define (white-texture)
   (force %white-texture))
 
 (define %gray-texture
   (delay
-    (make-texture
-     (bytevector->pixbuf (u32vector #xff808080 #xff808080 #xff808080 #xff808080)
-                         2 2))))
+    (make-texture 2 2 #:pixels (u32vector #xff808080 #xff808080
+                                          #xff808080 #xff808080))))
 
 (define (gray-texture)
   (force %gray-texture))
@@ -473,9 +521,8 @@ are 'nearest and 'linear.  By default, 'nearest is used."
 ;; unchanged by this normal map.
 (define %flat-texture
   (delay
-    (make-texture
-     (bytevector->pixbuf (u32vector #xffff8080 #xffff8080 #xffff8080 #xffff8080)
-                         2 2))))
+    (make-texture 2 2 #:pixels (u32vector #xffff8080 #xffff8080
+                                          #xffff8080 #xffff8080))))
 
 (define (flat-texture)
   (force %flat-texture))