graphics: Factor GL calls out of texture module.

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)))