summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/gpu.scm193
-rw-r--r--chickadee/graphics/texture.scm274
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)))