graphics: texture: Add support for cube maps.

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)