diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | chickadee.scm | 2 | ||||
| -rw-r--r-- | chickadee/graphics/texture.scm | 266 |
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) |