summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2021-08-16 17:09:16 -0400
committerDavid Thompson <dthompson2@worcester.edu>2021-08-16 17:10:50 -0400
commit9a844442e9326c0420e814941bd471739ef7c6a6 (patch)
tree7fe3824194a86fb3ff5333711cc204dd63d426ba
parentef9c8fe1966fa861758c72f1990751d330dc9b35 (diff)
graphics: texture: Add support for cube maps.
-rw-r--r--.dir-locals.el1
-rw-r--r--chickadee.scm2
-rw-r--r--chickadee/graphics/texture.scm266
3 files changed, 197 insertions, 72 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 9eb5b8e..15dce46 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -2,6 +2,7 @@
(scheme-mode
.
((eval . (put 'sdl2:call-with-surface 'scheme-indent-function 1))
+ (eval . (put 'call-with-loaded-image 'scheme-indent-function 3))
(eval . (put 'with-blend-mode 'scheme-indent-function 1))
(eval . (put 'with-polygon-mode 'scheme-indent-function 1))
(eval . (put 'with-cull-face-mode 'scheme-indent-function 1))
diff --git a/chickadee.scm b/chickadee.scm
index 8adc313..bffb83c 100644
--- a/chickadee.scm
+++ b/chickadee.scm
@@ -401,6 +401,8 @@ border is disabled, otherwise it is enabled.")
(current-error-port))))
;; Turn off multisampling by default.
(gl-disable (version-1-3 multisample))
+ ;; Enable seamless cube maps.
+ (gl-enable (version-3-2 texture-cube-map-seamless))
(load)
(sdl2:load-game-controller-mappings!
(scope-datadir "gamecontrollerdb.txt"))
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm
index b3a9985..e1f2aef 100644
--- a/chickadee/graphics/texture.scm
+++ b/chickadee/graphics/texture.scm
@@ -33,10 +33,14 @@
#:use-module (chickadee utils)
#:export (make-texture
make-texture-region
+ make-cube-map
load-image
+ load-cube-map
texture?
texture-region?
+ cube-map?
texture-null?
+ texture-type
texture-parent
texture-min-filter
texture-mag-filter
@@ -82,10 +86,11 @@
;; The <texture> object is a simple wrapper around an OpenGL texture
;; id.
(define-record-type <texture>
- (%make-texture id parent min-filter mag-filter wrap-s wrap-t
+ (%make-texture id type parent min-filter mag-filter wrap-s wrap-t
x y width height gl-rect gl-tex-rect)
texture?
(id texture-id)
+ (type texture-type)
(parent texture-parent)
(min-filter texture-min-filter)
(mag-filter texture-mag-filter)
@@ -114,7 +119,7 @@
(texture-wrap-t texture))))
(define null-texture
- (%make-texture 0 #f 'linear 'linear 'repeat 'repeat 0 0 0 0
+ (%make-texture 0 '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0
(make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))
(define (texture-null? texture)
@@ -124,14 +129,24 @@
(define (texture-region? texture)
(texture? (texture-parent texture)))
+(define (cube-map? texture)
+ (and (texture? texture) (eq? (texture-type texture) 'cube-map)))
+
(define (free-texture texture)
(gl-delete-texture (texture-id texture)))
+(define (gl-texture-target type)
+ (case type
+ ((2d)
+ (texture-target texture-2d))
+ ((cube-map)
+ (version-1-3 texture-cube-map))))
+
(define (make-bind-texture n)
(lambda (texture)
(let ((texture-unit (+ (version-1-3 texture0) n)))
(set-gl-active-texture texture-unit)
- (gl-bind-texture (texture-target texture-2d)
+ (gl-bind-texture (gl-texture-target (texture-type texture))
(texture-id texture)))))
(define-graphics-finalizer texture-finalizer
@@ -163,6 +178,45 @@
#:default null-texture
#:bind (make-bind-texture 4))
+(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 pixels width height #:key
flip?
(min-filter 'nearest)
@@ -181,16 +235,8 @@ 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."
- (define (gl-wrap 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))))
-
(assert-current-graphics-engine)
- (let ((texture (%make-texture (gl-generate-texture) #f
+ (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)
@@ -204,32 +250,19 @@ Currently only 32-bit RGBA format is supported."
(set-gl-active-texture (version-1-3 texture0))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-min-filter)
- (match 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))))
+ (gl-min-filter min-filter))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-mag-filter)
- (match mag-filter
- ('nearest (gl:texture-mag-filter nearest))
- ('linear (gl:texture-mag-filter linear))))
+ (gl-mag-filter mag-filter))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-wrap-s)
- (gl-wrap wrap-s))
+ (gl-wrap-mode wrap-s))
(gl-texture-parameter (texture-target texture-2d)
(texture-parameter-name texture-wrap-t)
- (gl-wrap wrap-t))
+ (gl-wrap-mode wrap-t))
(gl-texture-image-2d (texture-target texture-2d)
0 (pixel-format rgba) width height 0
- (match format
- ('rgba (pixel-format rgba)))
+ (gl-pixel-format format)
(color-pointer-type unsigned-byte)
(or pixels %null-pointer))
;; Generate mipmaps, if needed.
@@ -241,6 +274,76 @@ Currently only 32-bit RGBA format is supported."
(gl-generate-mipmap (texture-target texture-2d))))
texture))
+(define* (make-cube-map faces #:key
+ (min-filter 'linear)
+ (mag-filter 'linear)
+ (format 'rgba))
+ (define (set-face name pixels width height)
+ (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) width height 0
+ (gl-pixel-format format)
+ (color-pointer-type unsigned-byte)
+ pixels))
+ (match faces
+ (((right right-width right-height)
+ (left left-width left-height)
+ (top top-width top-height)
+ (bottom bottom-width bottom-height)
+ (front front-width front-height)
+ (back back-width back-height))
+ (assert-current-graphics-engine)
+ (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
+ min-filter mag-filter
+ 'clamp-to-edge 'clamp-to-edge
+ 0 0 0 0 #f #f)))
+ (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 (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 right-width right-height)
+ (set-face 'left left left-width left-height)
+ (set-face 'top top top-width top-height)
+ (set-face 'bottom bottom bottom-width bottom-height)
+ (set-face 'front front front-width front-height)
+ (set-face 'back back back-width back-height)
+ ;; 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))
+ (_ (error "cube map requires six faces"))))
+
(define (make-texture-region texture rect)
"Create a new texture region covering a section of TEXTURE defined
by the bounding box RECT."
@@ -252,15 +355,20 @@ by the bounding box RECT."
(h (rect-height rect))
(vert-rect (make-rect 0.0 0.0 w h))
(tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
- (%make-texture (texture-id texture)
- texture
- (texture-min-filter texture)
- (texture-mag-filter texture)
- (texture-wrap-s texture)
- (texture-wrap-t texture)
- x y w h
- vert-rect
- tex-rect)))
+ (case (texture-type texture)
+ ((2d)
+ (%make-texture (texture-id texture)
+ '2d
+ texture
+ (texture-min-filter texture)
+ (texture-mag-filter texture)
+ (texture-wrap-s texture)
+ (texture-wrap-t texture)
+ x y w h
+ vert-rect
+ tex-rect))
+ (else
+ (error "regions can only be made from 2d textures")))))
(define (flip-pixels-vertically pixels width height)
"Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
@@ -274,36 +382,34 @@ HEIGHT, 32 bit color bytevector."
(bytevector-copy! pixels source-start buffer target-start row-width)))
buffer))
-(define (surface->texture surface min-filter mag-filter wrap-s wrap-t
- transparent-color flip?)
- "Convert SURFACE, an SDL2 surface object, into a texture that uses
-the given MIN-FILTER and MAG-FILTER."
- ;; Convert to 32 bit RGBA color.
- (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
+(define (call-with-loaded-image file-name transparent-color flip? proc)
+ (sdl2:call-with-surface (sdl2:load-image file-name)
(lambda (surface)
- (let ((width (sdl2:surface-width surface))
- (height (sdl2:surface-height surface))
- (pixels (sdl2:surface-pixels surface)))
- ;; Zero the alpha channel of pixels that match the transparent
- ;; color key.
- (when transparent-color
- (let ((r (inexact->exact (* (color-r transparent-color) 255)))
- (g (inexact->exact (* (color-g transparent-color) 255)))
- (b (inexact->exact (* (color-b transparent-color) 255)))
- (pixel-count (* width height 4)))
- (for-range ((i pixel-count 0 4))
- (when (and (= r (bytevector-u8-ref pixels i))
- (= g (bytevector-u8-ref pixels (+ i 1)))
- (= b (bytevector-u8-ref pixels (+ i 2))))
- (bytevector-u8-set! pixels (+ i 3) 0)))))
- (make-texture (if flip?
- (flip-pixels-vertically pixels width height)
- pixels)
- width height
- #:min-filter min-filter
- #:mag-filter mag-filter
- #:wrap-s wrap-s
- #:wrap-t wrap-t)))))
+ (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
+ (lambda (surface)
+ (let ((width (sdl2:surface-width surface))
+ (height (sdl2:surface-height surface))
+ (pixels (sdl2:surface-pixels surface)))
+ ;; Zero the alpha channel of pixels that match the transparent
+ ;; color key.
+ (when transparent-color
+ (let ((r (inexact->exact (* (color-r transparent-color) 255)))
+ (g (inexact->exact (* (color-g transparent-color) 255)))
+ (b (inexact->exact (* (color-b transparent-color) 255)))
+ (pixel-count (* width height 4)))
+ (for-range ((i pixel-count 0 4))
+ (when (and (= r (bytevector-u8-ref pixels i))
+ (= g (bytevector-u8-ref pixels (+ i 1)))
+ (= b (bytevector-u8-ref pixels (+ i 2))))
+ (bytevector-u8-set! pixels (+ i 3) 0)))))
+ (proc (if flip?
+ (flip-pixels-vertically pixels width height)
+ ;; Need to copy the pixels for some reason.
+ ;; Noticed when implementing cube maps when all
+ ;; 6 texture pieces were all showing up as the
+ ;; last image loaded.
+ (bytevector-copy pixels))
+ width height)))))))
(define* (load-image file #:key
(min-filter 'nearest)
@@ -316,10 +422,26 @@ the given MIN-FILTER and MAG-FILTER."
describe the method that should be used for minification and
magnification. Valid values are 'nearest and 'linear. By default,
'nearest is used."
- (sdl2:call-with-surface (sdl2:load-image file)
- (lambda (surface)
- (surface->texture surface min-filter mag-filter wrap-s wrap-t
- transparent-color flip?))))
+ (call-with-loaded-image file transparent-color flip?
+ (lambda (pixels width height)
+ (make-texture pixels width height
+ #: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)
+ (mag-filter 'linear))
+ (let ((right (call-with-loaded-image right #f #f list))
+ (left (call-with-loaded-image left #f #f list))
+ (top (call-with-loaded-image top #f #f list))
+ (bottom (call-with-loaded-image bottom #f #f list))
+ (front (call-with-loaded-image front #f #f list))
+ (back (call-with-loaded-image back #f #f list)))
+ (make-cube-map (list right left top bottom front back)
+ #:min-filter min-filter
+ #:mag-filter mag-filter)))
(define (black-texture)
null-texture)