summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/framebuffer.scm2
-rw-r--r--chickadee/graphics/text.scm3
-rw-r--r--chickadee/graphics/texture.scm97
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))