diff options
| -rw-r--r-- | chickadee/graphics/framebuffer.scm | 2 | ||||
| -rw-r--r-- | chickadee/graphics/text.scm | 3 | ||||
| -rw-r--r-- | chickadee/graphics/texture.scm | 97 |
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)) |