diff options
| -rw-r--r-- | chickadee/graphics/gpu.scm | 193 | ||||
| -rw-r--r-- | chickadee/graphics/texture.scm | 274 |
2 files changed, 252 insertions, 215 deletions
diff --git a/chickadee/graphics/gpu.scm b/chickadee/graphics/gpu.scm index 5549266..cf922e3 100644 --- a/chickadee/graphics/gpu.scm +++ b/chickadee/graphics/gpu.scm @@ -137,6 +137,21 @@ gpu-texture? gpu-texture-id gpu-texture-target + gpu-texture-upload-2d + gpu-texture-upload-2d/sub + gpu-texture-copy-image + gpu-texture-generate-mipmap + gpu-texture-upload-cube-map-positive-x + gpu-texture-upload-cube-map-negative-x + gpu-texture-upload-cube-map-positive-y + gpu-texture-upload-cube-map-negative-y + gpu-texture-upload-cube-map-positive-z + gpu-texture-upload-cube-map-negative-z + set-gpu-texture-min-filter! + set-gpu-texture-mag-filter! + set-gpu-texture-wrap-r! + set-gpu-texture-wrap-s! + set-gpu-texture-wrap-t! gpu-texture:null fresh-gpu-shader @@ -244,6 +259,41 @@ (->scheme (%eaccessor obj))) ...)) +(define-enum-converters texture-min-filter + symbol->texture-min-filter + texture-min-filter->symbol + (nearest) + (linear) + (nearest-mipmap-nearest) + (linear-mipmap-nearest) + (nearest-mipmap-linear) + (linear-mipmap-linear)) + +(define-enum-converters texture-mag-filter + symbol->texture-mag-filter + texture-mag-filter->symbol + (nearest) + (linear)) + +(define (symbol->texture-target target) + (match target + ('2d (texture-target texture-2d)) + ('cube-map (version-1-3 texture-cube-map)))) + +(define (symbol->texture-wrap-mode mode) + (match mode + ('repeat (texture-wrap-mode repeat)) + ('mirrored-repeat (version-1-4 mirrored-repeat)) + ('clamp (texture-wrap-mode clamp)) + ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis)) + ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis)))) + +(define-enum-converters pixel-format + symbol->pixel-format + pixel-format->symbol + (rgb) + (rgba)) + (define-enum-converters blend-equation-mode-ext symbol->blend-equation blend-equation->symbol @@ -682,9 +732,7 @@ (define-gpu-type <gpu-texture> (make-gpu-texture (target) (gl-generate-texture) - (match target - ('2d (texture-target texture-2d)) - ('cube-map (version-1-3 texture-cube-map)))) + (symbol->texture-target target)) (free-gpu-texture (gl-delete-texture id)) (bind-gpu-texture (gl-bind-texture target id)) (gpu-texture:null 0 (texture-target texture-2d)) @@ -816,9 +864,12 @@ (define (gpu-texture gpu unit) (vector-ref (gpu-textures gpu) unit)) +(define (set-active-texture-unit! n) + (set-gl-active-texture (+ (version-1-3 texture0) n))) + (define (set-gpu-texture! gpu unit texture) (unless (eq? texture (gpu-texture gpu unit)) - (set-gl-active-texture (+ (version-1-3 texture0) unit)) + (set-active-texture-unit! unit) (bind-gpu-texture texture) (vector-set! (gpu-textures gpu) unit texture))) @@ -887,3 +938,137 @@ (when (< i (vector-length textures)) (set-gpu-texture! gpu i gpu-texture:null) (loop (+ i 1)))))) + + +;;; +;;; Accessors +;;; + +(define (set-gpu-texture-min-filter! gpu texture filter) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-parameter (gpu-texture-target texture) + (texture-parameter-name texture-min-filter) + (symbol->texture-min-filter filter))) + +(define (set-gpu-texture-mag-filter! gpu texture filter) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-parameter (gpu-texture-target texture) + (texture-parameter-name texture-mag-filter) + (symbol->texture-mag-filter filter))) + +(define (set-gpu-texture-wrap-r! gpu texture mode) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-parameter (gpu-texture-target texture) + (texture-parameter-name texture-wrap-r-ext) + (symbol->texture-wrap-mode mode))) + +(define (set-gpu-texture-wrap-s! gpu texture mode) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-parameter (gpu-texture-target texture) + (texture-parameter-name texture-wrap-s) + (symbol->texture-wrap-mode mode))) + +(define (set-gpu-texture-wrap-t! gpu texture mode) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-parameter (gpu-texture-target texture) + (texture-parameter-name texture-wrap-t) + (symbol->texture-wrap-mode mode))) + +(define-inlinable (tex-image-2d gpu target level internal-format + width height pixel-format pixels) + (gl-texture-image-2d target + level + (symbol->pixel-format internal-format) + width height 0 + (symbol->pixel-format pixel-format) + (color-pointer-type unsigned-byte) + (or pixels %null-pointer))) + +(define (gpu-texture-upload-2d gpu texture level internal-format + width height pixel-format pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (gpu-texture-target texture) level internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-2d/sub gpu texture level x y width height + pixel-format pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-texture-sub-image-2d (gpu-texture-target texture) 0 + x y width height + (symbol->pixel-format pixel-format) + (color-pointer-type unsigned-byte) + pixels)) + +(define (gpu-texture-copy-image gpu texture level pixel-format dst offset) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-get-tex-image (gpu-texture-target texture) level + (symbol->pixel-format pixel-format) + (color-pointer-type unsigned-byte) + (bytevector->pointer dst offset))) + +(define (gpu-texture-upload-cube-map-positive-x gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-positive-x) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-cube-map-negative-x gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-negative-x) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-cube-map-positive-y gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-positive-y) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-cube-map-negative-y gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-negative-y) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-cube-map-positive-z gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-positive-z) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-upload-cube-map-negative-z gpu texture internal-format + width height pixel-format + pixels) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (tex-image-2d gpu (version-1-3 texture-cube-map-negative-z) + 0 internal-format + width height pixel-format pixels)) + +(define (gpu-texture-generate-mipmap gpu texture) + (set-gpu-texture! gpu 0 texture) + (set-active-texture-unit! 0) + (gl-generate-mipmap (gpu-texture-target texture))) diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm index 86702a3..faf9953 100644 --- a/chickadee/graphics/texture.scm +++ b/chickadee/graphics/texture.scm @@ -23,12 +23,9 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (system foreign) - #:use-module (gl) - #:use-module ((gl enums) #:prefix gl:) #:use-module (chickadee math rect) #:use-module (chickadee graphics color) #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) #:use-module (chickadee graphics gpu) #:use-module (chickadee graphics pixbuf) #:use-module (chickadee image) @@ -64,18 +61,6 @@ white-texture gray-texture flat-texture - g:texture-0 - g:texture-1 - g:texture-2 - g:texture-3 - g:texture-4 - g:texture-5 - current-texture-0 - current-texture-1 - current-texture-2 - current-texture-3 - current-texture-4 - current-texture-5 texture-atlas list->texture-atlas @@ -141,52 +126,6 @@ (define (cube-map? texture) (and (texture? texture) (eq? (texture-type texture) 'cube-map))) -(define (gl-texture-target type) - (case type - ((2d) - (texture-target texture-2d)) - ((cube-map) - (version-1-3 texture-cube-map)))) - -(define (gl-wrap-mode mode) - (case mode - ((repeat) - (texture-wrap-mode repeat)) - ('mirrored-repeat (version-1-4 mirrored-repeat)) - ((clamp) - (texture-wrap-mode clamp)) - ((clamp-to-border) - (texture-wrap-mode clamp-to-border-sgis)) - ((clamp-to-edge) - (texture-wrap-mode clamp-to-edge-sgis)))) - -(define (gl-min-filter min-filter) - (case min-filter - ((nearest) - (gl:texture-min-filter nearest)) - ((linear) - (gl:texture-min-filter linear)) - ((nearest-mipmap-nearest) - (gl:texture-min-filter nearest-mipmap-nearest)) - ((linear-mipmap-nearest) - (gl:texture-min-filter linear-mipmap-nearest)) - ((nearest-mipmap-linear) - (gl:texture-min-filter nearest-mipmap-linear)) - ((linear-mipmap-linear) - (gl:texture-min-filter linear-mipmap-linear)))) - -(define (gl-mag-filter mag-filter) - (case mag-filter - ((nearest) - (gl:texture-mag-filter nearest)) - ((linear) - (gl:texture-mag-filter linear)))) - -(define (gl-pixel-format format) - (case format - ((rgba) - (pixel-format rgba)))) - (define* (make-texture width height #:key pixels flip? (min-filter 'nearest) @@ -206,160 +145,81 @@ 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 (fresh-gpu-texture (current-gpu) '2d) - '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))))) - (with-graphics-state! ((texture 0 (texture-id 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)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (or pixels %null-pointer)) - ;; 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))) + (let* ((gpu (current-gpu)) + (id (fresh-gpu-texture gpu '2d)) + (texture (%make-texture id '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))))) + (set-gpu-texture-min-filter! gpu id min-filter) + (set-gpu-texture-mag-filter! gpu id mag-filter) + (set-gpu-texture-wrap-s! gpu id wrap-s) + (set-gpu-texture-wrap-t! gpu id wrap-t) + (gpu-texture-upload-2d gpu id 0 'rgba width height format pixels) + ;; Generate mipmaps, if needed. + (when (memq min-filter + '(nearest-mipmap-nearest + linear-mipmap-nearest + nearest-mipmap-linear + linear-mipmap-linear)) + (gpu-texture-generate-mipmap gpu id)) + texture)) (define* (pixbuf->texture pixbuf #:key flip? (min-filter 'nearest) (mag-filter 'nearest) (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) + (wrap-t 'repeat)) "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 (fresh-gpu-texture (current-gpu) '2d) - '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))))) - (with-graphics-state! ((texture 0 (texture-id 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)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)) - ;; 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))) + (make-texture (pixbuf-width pixbuf) + (pixbuf-height pixbuf) + #:pixels (pixbuf-pixels pixbuf) + #:format 'rgba + #:flip? flip? + #:min-filter min-filter + #:mag-filter mag-filter + #:wrap-s wrap-s + #:wrap-t wrap-t)) (define* (make-cube-map #:key right left top bottom front back (min-filter 'linear) (mag-filter 'linear) (format 'rgba)) - (define (set-face name pixbuf) - (gl-texture-image-2d (case name - ((right) - (version-1-3 texture-cube-map-positive-x)) - ((left) - (version-1-3 texture-cube-map-negative-x)) - ((top) - (version-1-3 texture-cube-map-positive-y)) - ((bottom) - (version-1-3 texture-cube-map-negative-y)) - ((front) - (version-1-3 texture-cube-map-positive-z)) - ((back) - (version-1-3 texture-cube-map-negative-z))) - 0 - (pixel-format rgba) - (pixbuf-width pixbuf) - (pixbuf-height pixbuf) - 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf))) (assert-current-graphics-engine) - (let ((texture (%make-texture (fresh-gpu-texture (current-gpu) 'cube-map) - 'cube-map #f - min-filter mag-filter - 'clamp-to-edge 'clamp-to-edge - 0 0 0 0 #f #f))) - (with-graphics-state! ((texture 0 (texture-id 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))) + (let* ((gpu (current-gpu)) + (id (fresh-gpu-texture gpu 'cube-map)) + (texture (%make-texture id 'cube-map #f + min-filter mag-filter + 'clamp-to-edge 'clamp-to-edge + 0 0 0 0 #f #f))) + (define (set-face proc pixbuf) + (proc gpu id 'rgba (pixbuf-width pixbuf) (pixbuf-height pixbuf) + 'rgba (pixbuf-pixels pixbuf))) + (set-gpu-texture-min-filter! gpu id min-filter) + (set-gpu-texture-mag-filter! gpu id mag-filter) + (set-gpu-texture-wrap-r! gpu id 'clamp-to-edge) + (set-gpu-texture-wrap-s! gpu id 'clamp-to-edge) + (set-gpu-texture-wrap-t! gpu id 'clamp-to-edge) + (set-face gpu-texture-upload-cube-map-positive-x right) + (set-face gpu-texture-upload-cube-map-negative-x left) + (set-face gpu-texture-upload-cube-map-positive-y top) + (set-face gpu-texture-upload-cube-map-negative-y bottom) + (set-face gpu-texture-upload-cube-map-positive-z front) + (set-face gpu-texture-upload-cube-map-negative-z back) + ;; Generate mipmaps, if needed. + (when (memq min-filter + '(nearest-mipmap-nearest + linear-mipmap-nearest + nearest-mipmap-linear + linear-mipmap-linear)) + (gpu-texture-generate-mipmap gpu id)) + texture)) (define (make-texture-region texture rect) "Create a new texture region covering a section of TEXTURE defined @@ -428,25 +288,17 @@ are 'nearest and 'linear. By default, 'nearest is used." (define (texture-copy-pixbuf! texture pixbuf) "Copy the contents of PIXBUF to TEXTURE." - (with-graphics-state! ((g:texture-0 texture)) - (gl-texture-sub-image-2d (texture-target texture-2d) 0 + (gpu-texture-upload-2d/sub (current-gpu) (texture-id texture) 0 (texture-x texture) (texture-y texture) (pixbuf-width pixbuf) (pixbuf-height pixbuf) - (gl-pixel-format 'rgba) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)))) + 'rgba (pixbuf-pixels pixbuf))) (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))) - (set-gpu-texture! (current-gpu) 0 texture) - (gl-get-tex-image (texture-target texture-2d) - 0 - (gl-pixel-format 'rgba) - (color-pointer-type unsigned-byte) - (bytevector->pointer pixels)) + (gpu-texture-copy-image (current-gpu) texture 0 'rgba pixels 0) (let ((pixbuf (bytevector->pixbuf pixels w h #:format 'rgba #:bit-depth 8))) |