path: root/chickadee/graphics/backend/opengl.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; OpenGL GPU backend.  Supports even old ass OpenGL 2.1 hardware that
;; lots of people are still using!
;;
;;; Code:

(define-module (chickadee graphics backend opengl)
  #:use-module (chickadee data array-list)
  #:use-module (chickadee data queue)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics gpu)
  #:use-module (chickadee math rect)
  #:use-module (gl)
  #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%))
  #:use-module (gl runtime)
  #:use-module (gl types)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module ((sdl2 video) #:select (gl-context-make-current!
                                       swap-gl-window))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module ((system foreign)
                #:select (bytevector->pointer
                          pointer->bytevector
                          pointer->string
                          pointer-address
                          make-pointer
                          %null-pointer)))


;;;
;;; Additional OpenGL wrappers
;;;

;; TODO: Upstream these to guile-opengl

(define gl-clear-color %glClearColor)
(define gl-scissor %glScissor)
(define gl-blend-func %glBlendFunc)
(define gl-blend-equation %glBlendEquation)
(define gl-texture-image-3d %glTexImage3D)
(define gl-texture-image-2d %glTexImage2D)
(define gl-texture-image-1d %glTexImage1D)
(define gl-copy-texture-image-2d %glCopyTexImage2D)
(define gl-copy-texture-image-1d %glCopyTexImage1D)
(define gl-copy-texture-sub-image-3d %glCopyTexSubImage3D)
(define gl-copy-texture-sub-image-2d %glCopyTexSubImage2D)
(define gl-copy-texture-sub-image-1d %glCopyTexSubImage1D)
(define gl-texture-sub-image-3d %glTexSubImage3D)
(define gl-texture-sub-image-2d %glTexSubImage2D)
(define gl-texture-sub-image-1d %glTexSubImage1D)
(define gl-compressed-texture-image-1d %glCompressedTexImage1D)
(define gl-compressed-texture-image-2d %glCompressedTexImage2D)
(define gl-compressed-texture-image-3d %glCompressedTexImage3D)
(define gl-compressed-texture-sub-image-1d %glCompressedTexSubImage1D)
(define gl-compressed-texture-sub-image-2d %glCompressedTexSubImage2D)
(define gl-compressed-texture-sub-image-3d %glCompressedTexSubImage3D)
(define gl-texture-parameter %glTexParameteri)
(define gl-bind-texture %glBindTexture)
(define gl-get-tex-image %glGetTexImage)
(define gl-buffer-data %glBufferData)
(define gl-buffer-sub-data %glBufferSubData)
(define gl-map-buffer %glMapBuffer)
(define gl-unmap-buffer %glUnmapBuffer)
(define gl-draw-buffers %glDrawBuffers)
(define gl-use-program %glUseProgram)
(define gl-link-program  %glLinkProgram)
(define gl-bind-attrib-location  %glBindAttribLocation)
(define gl-attach-shader  %glAttachShader)
(define gl-detach-shader  %glDetachShader)
(define gl-get-attrib-location  %glGetAttribLocation)
(define gl-get-uniform-location  %glGetUniformLocation)
(define gl-create-program  %glCreateProgram)
(define gl-get-program-info-log  %glGetProgramInfoLog)
(define gl-get-programiv  %glGetProgramiv)
(define gl-delete-program  %glDeleteProgram)
(define gl-delete-shader  %glDeleteShader)
(define gl-get-shaderiv  %glGetShaderiv)
(define gl-get-shader-info-log  %glGetShaderInfoLog)
(define gl-compile-shader  %glCompileShader)
(define gl-shader-source  %glShaderSource)
(define gl-create-shader  %glCreateShader)
(define gl-get-active-uniform %glGetActiveUniform)
(define gl-get-active-attrib %glGetActiveAttrib)
(define gl-uniform1i  %glUniform1i)
(define gl-uniform1iv %glUniform1iv)
(define gl-uniform2i  %glUniform2i)
(define gl-uniform3i  %glUniform3i)
(define gl-uniform4i  %glUniform4i)
(define gl-uniform1f %glUniform1f)
(define gl-uniform1fv  %glUniform1fv)
(define gl-uniform2f  %glUniform2f)
(define gl-uniform2fv  %glUniform2fv)
(define gl-uniform3f %glUniform3f)
(define gl-uniform3fv %glUniform3fv)
(define gl-uniform4f  %glUniform4f)
(define gl-uniform4fv %glUniform4fv)
(define gl-uniform-matrix3fv %glUniformMatrix3fv)
(define gl-uniform-matrix4fv %glUniformMatrix4fv)
(define gl-point-size %glPointSize)
(define gl-get-string %glGetString)
(define gl-get-integer-v %glGetIntegerv)
(define gl-depth-func %glDepthFunc)
(define gl-depth-mask %glDepthMask)
(define gl-depth-range %glDepthRange)
(define gl-stencil-mask %glStencilMask)
(define gl-stencil-mask-separate %glStencilMaskSeparate)
(define gl-stencil-func %glStencilFunc)
(define gl-stencil-func-separate %glStencilFuncSeparate)
(define gl-stencil-op %glStencilOp)
(define gl-stencil-op-separate %glStencilOpSeparate)
(define gl-polygon-mode %glPolygonMode)
(define gl-cull-face %glCullFace)
(define gl-front-face %glFrontFace)
(define gl-color-mask %glColorMask)
(define gl-get-error %glGetError)

(define-gl-procedure (glGenerateMipmap (target GLenum) -> void)
  "Generate mipmaps for the texture attached to target of the active
texture unit.")

(define-gl-procedure (glTextureView (texture GLuint)
                                    (target GLenum)
                                    (origtexture GLuint)
                                    (internalformat GLenum)
                                    (minlevel GLuint)
                                    (numlevels GLuint)
                                    (minlayer GLuint)
                                    (numlayers GLuint)
                                    -> void)
  "Initialize a texture as a data alias of another texture's data
store.")

(define-gl-procedure (glGenSamplers (n GLsizei)
                                    (ids GLuint-*)
                                    -> void)
  "Generate sampler object names.")

(define-gl-procedure (glDeleteSamplers (n GLsizei)
                                       (ids GLuint-*)
                                       -> void)
  "Delete named sampler objects.")

(define-gl-procedure (glDrawArraysInstanced (mode GLenum)
                                            (first GLint)
                                            (count GLsizei)
                                            (primcount GLsizei)
                                            -> void)
  "Draw multiple instances of a set of arrays.")

(define-gl-procedure (glDrawElementsInstanced (mode GLenum)
                                              (count GLsizei)
                                              (type GLenum)
                                              (indices void-*)
                                              (primcount GLsizei)
                                              -> void)
  "Draw multiple instances of a set of elements.")

(define-gl-procedure (glVertexAttribDivisor (index GLuint)
                                            (divisor GLuint)
                                            -> void)
  "Modify the rate at which generic vertex attributes advance during
instanced rendering.")

(define-gl-procedure (glGenVertexArrays (n GLsizei)
                                        (arrays GLuint-*)
                                        -> void)
  "Generate N vertex arrays.")

(define-gl-procedure (glDeleteVertexArrays (n GLsizei)
                                           (arrays GLuint-*)
                                           -> void)
  "Delete vertex array objects.")

(define-gl-procedure (glBindVertexArray (array GLuint)
                                        -> void)
  "Bind vertex array object ARRAY.")

(define-gl-procedure (glEnableVertexAttribArray (index GLuint)
                                                -> void)
  "Enable or disable a generic vertex attribute array.")

(define-gl-procedure (glVertexAttribPointer (index GLuint)
                                            (size GLint)
                                            (type GLenum)
                                            (normalized GLboolean)
                                            (stride GLsizei)
                                            (pointer GLvoid-*)
                                            -> void)
  "Define an array of generic vertex attribute data.")

(define-gl-procedure (glDrawElements (mode GLenum)
                                     (count GLsizei)
                                     (type GLenum)
                                     (indices GLvoid-*)
                                     -> void)
  "Render primitives from array data.")

(define-gl-procedure (glGenFramebuffers (n GLsizei)
                                        (ids GLuint-*)
                                        -> void)
  "Generate framebuffer object names.")

(define-gl-procedure (glDeleteFramebuffers (n GLsizei)
                                           (framebuffers GLuint-*)
                                           -> void)
  "Delete framebuffer objects.")

(define-gl-procedure (glBindFramebuffer (target GLenum)
                                        (framebuffer GLuint)
                                        -> void)
  "Bind a framebuffer to a framebuffer target.")

(define-gl-procedure (glGetFramebufferAttachmentParameteriv (target GLenum)
                                                            (attachment GLenum)
                                                            (pname GLenum)
                                                            (params GLint-*)
                                                            -> void)
  "Return attachment parameters of a framebuffer object.")

(define-gl-procedure (glFramebufferTexture2D (target GLenum)
                                             (attachment GLenum)
                                             (textarget GLenum)
                                             (texture GLuint)
                                             (level GLint)
                                             -> void)
  "Attach a level of a texture object as a logical buffer to the
currently bound framebuffer object.")

(define-gl-procedure (glCheckFramebufferStatus (target GLenum)
                                               -> GLenum)
  "Return the framebuffer completeness status of a framebuffer
object.")

(define-gl-procedure (glGenRenderbuffers (n GLsizei)
                                         (ids GLuint-*)
                                         -> void)
  "Generate renderbuffer object names.")

(define-gl-procedure (glDeleteRenderbuffers (n GLsizei)
                                            (renderbuffers GLuint-*)
                                            -> void)
  "Delete renderbuffer objects.")

(define-gl-procedure (glBindRenderbuffer (target GLenum)
                                         (renderbuffer GLuint)
                                         -> void)
  "Bind a named renderbuffer object.")

(define-gl-procedure (glRenderbufferStorage (target GLenum)
                                            (internalformat GLenum)
                                            (width GLsizei)
                                            (height GLsizei)
                                            -> void)
  "Create and initialize a renderbuffer object's data store.")

(define-gl-procedure (glFramebufferRenderbuffer (target GLenum)
                                                (attachment GLenum)
                                                (renderbuffertarget GLenum)
                                                (renderbuffer GLuint)
                                                -> void)
  "Attach a renderbuffer object to a framebuffer object.")

(define-gl-procedure (glUniform1ui (location GLint)
                                   (v0 GLuint)
                                   -> void)
  "Specify the value of a uniform variable for the current program object")

(define-gl-procedure (glUniform1uiv (location GLint)
                                    (count GLint)
                                    (ptr GLvoid-*)
                                    -> void)
  "Specify the value of a uniform variable for the current program object")

(define gl-generate-mipmap glGenerateMipmap)
(define gl-texture-view glTextureView)
(define gl-gen-samplers glGenSamplers)
(define gl-draw-arrays-instanced glDrawArraysInstanced)
(define gl-draw-elements-instanced glDrawElementsInstanced)
(define gl-vertex-attrib-divisor glVertexAttribDivisor)
(define gl-gen-vertex-arrays glGenVertexArrays)
(define gl-delete-vertex-arrays glDeleteVertexArrays)
(define gl-bind-vertex-array glBindVertexArray)
(define gl-enable-vertex-attrib-array glEnableVertexAttribArray)
(define gl-vertex-attrib-pointer glVertexAttribPointer)
(define gl-draw-elements glDrawElements)
(define gl-gen-framebuffers glGenFramebuffers)
(define gl-bind-framebuffer glBindFramebuffer)
(define gl-get-framebuffer-attachment-parameteriv
  glGetFramebufferAttachmentParameteriv)
(define gl-framebuffer-texture-2d glFramebufferTexture2D)
(define gl-check-framebuffer-status glCheckFramebufferStatus)
(define gl-gen-renderbuffers glGenRenderbuffers)
(define gl-delete-renderbuffers glDeleteRenderbuffers)
(define gl-bind-renderbuffer glBindRenderbuffer)
(define gl-renderbuffer-storage glRenderbufferStorage)
(define gl-framebuffer-renderbuffer glFramebufferRenderbuffer)
(define gl-uniform1ui glUniform1ui)
(define gl-uniform1uiv glUniform1uiv)

(define (gl-generate-sampler)
  (let ((bv (u32vector 0)))
    (glGenSamplers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-sampler n)
  (let ((bv (u32vector n)))
    (glDeleteSamplers 1 bv)))

(define (gl-generate-vertex-array)
  (let ((bv (u32vector 0)))
    (glGenVertexArrays 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-vertex-array n)
  (let ((bv (u32vector n)))
    (glDeleteVertexArrays 1 bv)))

(define (gl-generate-framebuffer)
  (let ((bv (u32vector 0)))
    (glGenFramebuffers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-framebuffer n)
  (let ((bv (u32vector n)))
    (glDeleteFramebuffers 1 bv)))

(define (gl-generate-renderbuffer)
  (let ((bv (u32vector 0)))
    (glGenRenderbuffers 1 bv)
    (u32vector-ref bv 0)))

(define (gl-delete-renderbuffer n)
  (let ((bv (u32vector n)))
    (glDeleteRenderbuffers 1 bv)))


;;;
;;; Internal API imports
;;;

(define-syntax-rule (define-internal-import name)
  (define name (@@ (chickadee graphics gpu) name)))

(define-internal-import buffer-handle)
(define-internal-import shader-module-handle)
(define-internal-import <vertex-attribute>)
(define-internal-import <vertex-buffer-layout>)
(define-internal-import <vertex-state>)
(define-internal-import <blend-component>)
(define-internal-import <blend-state>)
(define-internal-import <color-target-state>)
(define-internal-import <fragment-state>)
(define-internal-import <primitive-state>)
(define-internal-import <stencil-face-state>)
(define-internal-import <depth-stencil-state>)
(define-internal-import <multisample-state>)
(define-internal-import <render-pipeline>)
(define-internal-import <render-state>)
(define-internal-import <draw-command>)


;;;
;;; GPU backend
;;;

(define-record-type <gl-buffer>
  (%make-gl-buffer id)
  gl-buffer?
  (id gl-buffer-id)
  (map-target gl-buffer-map-target set-gl-buffer-map-target!))

(define-record-type <gl-texture>
  (%make-gl-texture id)
  gl-texture?
  (id gl-texture-id))

(define-record-type <gl-texture-view>
  (%make-gl-texture-view id)
  gl-texture-view?
  (id gl-texture-view-id))

(define-record-type <gl-sampler>
  (%make-gl-sampler id)
  gl-sampler?
  (id gl-sampler-id))

(define-record-type <gl-shader>
  (make-gl-shader id)
  gl-shader?
  (id gl-shader-id))

(define-record-type <gl-shader-module>
  (%make-gl-shader-module vertex fragment)
  gl-shader-module?
  (vertex gl-shader-module-vertex)
  (fragment gl-shader-module-fragment))

(define-record-type <gl-program>
  (make-gl-program id)
  gl-program?
  (id gl-program-id))

(define-record-type <gl-meta>
  (%make-gl-meta version glsl-version vendor renderer driver extensions)
  gl-meta?
  (version gl-meta-version)
  (glsl-version gl-meta-glsl-version)
  (vendor gl-meta-vendor)
  (renderer gl-meta-renderer)
  (driver gl-meta-driver)
  (extensions gl-meta-extensions))

(define (make-gl-meta)
  (define (get-string id)
    (pointer->string (gl-get-string id)))
  (define (parse-version str)
    (match (string-split str #\space)
      ((version . _) version)))
  (let ((version (get-string (string-name version)))
        (extensions (make-hash-table)))
    (for-each (lambda (name)
                (hash-set! extensions name #t))
              (string-split (get-string (string-name extensions))
                            #\space))
    (%make-gl-meta (parse-version version)
                   (parse-version
                    (get-string
                     (version-2-0 shading-language-version)))
                   (get-string (string-name vendor))
                   (get-string (string-name renderer))
                   version
                   extensions)))

(define (gl-meta-has-extension? meta name)
  (hash-ref (gl-meta-extensions meta) name))

(define-record-type <gl-state>
  (%make-gl-state window context meta queue)
  gl-state?
  (window gl-state-window)
  (context gl-state-context)
  (meta gl-state-meta)
  (queue gl-state-queue)
  (buffer-index gl-state-buffer-index %set-gl-state-buffer-index!)
  (buffer-vertex gl-state-buffer-vertex %set-gl-state-buffer-vertex!)
  (buffer-copy-read gl-state-buffer-copy-read %set-gl-state-buffer-copy-read!)
  (buffer-copy-write gl-state-buffer-copy-write %set-gl-state-buffer-copy-write!)
  (program gl-state-program %set-gl-state-program!)
  (cull-mode gl-state-cull-mode %set-gl-state-cull-mode!)
  (front-face gl-state-front-face %set-gl-state-front-face!))

(define (make-gl-state window context)
  (%make-gl-state window context (make-gl-meta) (make-queue)))

(define debug-level (or (getenv "GL_DEBUG") -1))

(define (gl-debug level msg)
  (when (>= debug-level level)
    (format #t "gl: ~a\n" msg)))

(define (gl-state-version>= state version)
  (string>= (gl-meta-version (gl-state-meta state)) version))

(define-syntax-rule (gl-state-make-current! state)
  (gl-context-make-current! (gl-state-window state) (gl-state-context state)))

(define (gl-state-swap state)
  (swap-gl-window (gl-state-window state)))

(define (gl-state-enqueue state command-buffer)
  (let ((q (gl-state-queue state)))
    (for-each (lambda (cmd) (enqueue! q cmd))
              (command-buffer-commands command-buffer))))

(define (set-gl-state-buffer-vertex! state buffer)
  (unless (eq? (gl-state-buffer-vertex state) buffer)
    (gl-bind-buffer (version-1-5 array-buffer) (gl-buffer-id buffer))
    (%set-gl-state-buffer-vertex! state buffer)))

(define (set-gl-state-buffer-index! state buffer)
  (unless (eq? (gl-state-buffer-index state) buffer)
    (gl-bind-buffer (gl-buffer-id buffer) (version-1-5 element-array-buffer))
    (%set-gl-state-buffer-index! state buffer)))

(define (set-gl-state-buffer-copy-read! state buffer)
  (unless (eq? (gl-state-buffer-copy-read state) buffer)
    (gl-bind-buffer (gl-buffer-id buffer) (version-3-1 copy-read-buffer))
    (%set-gl-state-buffer-copy-read! state buffer)))

(define (set-gl-state-buffer-copy-write! state buffer)
  (unless (eq? (gl-state-buffer-copy-write state) buffer)
    (gl-bind-buffer (gl-buffer-id buffer) (version-3-1 copy-write-buffer))
    (%set-gl-state-buffer-copy-write! state buffer)))

(define (set-gl-state-program! state program)
  (unless (eq? (gl-state-program state) program)
    (gl-use-program (gl-program-id program))
    (%set-gl-state-program! state program)))

(define (set-gl-state-cull-mode! state cull-mode)
  (unless (eq? (gl-state-cull-mode state) cull-mode)
    (match cull-mode
      ('none
       (gl-disable (enable-cap cull-face)))
      ('front
       (gl-enable (enable-cap cull-face))
       (gl-cull-face (cull-face-mode front)))
      ('back
       (gl-enable (enable-cap cull-face))
       (gl-cull-face (cull-face-mode back))))
    (%set-gl-state-cull-mode! state cull-mode)))

(define (set-gl-state-front-face! state front-face)
  (unless (eq? (gl-state-front-face state) front-face)
    (match front-face
      ('ccw (gl-front-face (front-face-direction ccw)))
      ('cw (gl-front-face (front-face-direction cw))))
    (%set-gl-state-front-face! state front-face)))

;; (define (set-gl-state-blend-mode! state blend)
;;   (unless (equal? (gl-state-blend state))
;;     (match blend
;;       (#f (gl-disable (enable-cap blend)))
;;       (($ <blend-state> ($ <blend-component> color-op color-src color-dst)
;;                         ($ <blend-component> alpha-op alpha-src alpha-dst))
;;        (gl-enable (enable-cap blend))
;;        (gl-blend-equation equation)
;;        (gl-blend-func src dest)))
;;     (%set-gl-state-blend! state blend)))

(define *offset-cache* (make-hash-table))

(define (offset->pointer offset)
  (or (hashv-ref *offset-cache* offset)
      (let ((ptr (make-pointer offset)))
        (hashv-set! *offset-cache* offset ptr)
        ptr)))

(define (gl-state-tick state)
  (define (format-component-count format)
    (match format
      ((or 'uint32 'float32) 1)
      ((or 'uint8x2 'sint8x2 'unorm8x2 'snorm8x2 'uint16x2 'sint16x2
           'unorm16x2 'snorm16x2 'float16x2 'float32x2 'uint32x2 'sint32
           'sint32x2)
       2)
      ((or 'float32x3 'uint32x3 'sint32x3) 3)
      ((or 'uint8x4 'sint8x4 'unorm8x4 'snorm8x4 'uint16x4 'sint16x4
           'unorm16x4 'snorm16x4 'float16x4 'float32x4 'uint32x4 'sint32x4)
       4)))
  (define (format-type format)
    (match format
      ((or 'uint8x2 'uint8x4)
       (data-type unsigned-byte))
      ((or 'uint16x2 'uint16x4)
       (data-type unsigned-short))
      ((or 'uint32 'uint32x2 'uint32x3 'uint32x4)
       (data-type unsigned-int))
      ((or 'sint8x2 'sint8x4)
       (data-type byte))
      ((or 'sint16x2 'sint16x4)
       (data-type short))
      ((or 'sint32 'sint32x2 'sint32x3 'sint32x4)
       (data-type int))
      ((or 'float16x2 'float16x4)
       (oes-vertex-half-float half-float-oes))
      ((or 'float32 'float32x2 'float32x3 'float32x4 'unorm8x2 'unorm8x4
           'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4 'snorm16x2 'snorm16x4)
       (data-type float))))
  (define (format-normalized? format)
    (match format
      ((or 'uint8x2 'uint8x4 'sint8x2 'sint8x4 'uint16x2 'uint16x4 'sint16x2
           'sint16x4 'float16x2 'float16x4 'float32 'float32x2 'float32x3
           'float32x4 'uint32 'uint32x2 'uint32x3 'uint32x4 'sint32 'sint32x2
           'sint32x3 'sint32x4)
       #f)
      ((or 'unorm8x2 'unorm8x4 'snorm8x2 'snorm8x4 'unorm16x2 'unorm16x4
           'snorm16x2 'snorm16x4)
       #t)))
  (define (primitive-mode primitive)
    (match (primitive-state-topology primitive)
      ('point-list (begin-mode points))
      ('line-list (begin-mode lines))
      ('line-strip (begin-mode line-strip))
      ('triangle-list (begin-mode triangles))
      ('triangle-strip (begin-mode triangle-strip))))
  (define (apply-render-pipeline pipeline)
    (match pipeline
      (($ <render-pipeline> program
                            ($ <vertex-state> _ buffers)
                            fragment
                            ($ <primitive-state> _ front-face cull-mode _)
                            depth-stencil
                            multisample)
       (set-gl-state-program! state program)
       (set-gl-state-front-face! state front-face)
       (set-gl-state-cull-mode! state cull-mode))))
  (define (apply-render-state render-state)
    (match render-state
      (($ <render-state> (and pipeline ($ <render-pipeline> _ vertex fragment))
                         vertex-buffers)
       (apply-render-pipeline pipeline)
       ;; Bind vertex buffers and setup vertex attributes.
       (let loop ((layouts (vertex-state-buffers vertex))
                  (i 0))
         (match layouts
           (() #t)
           ((($ <vertex-buffer-layout> stride step-mode attributes) . rest)
            (set-gl-state-buffer-vertex! state
                                         (buffer-handle
                                          (vector-ref vertex-buffers i)))
            (let attrib-loop ((attributes attributes))
              (match attributes
                (() (loop rest (+ i 1)))
                ((($ <vertex-attribute> location format offset) . rest-attribs)
                 (gl-enable-vertex-attrib-array location)
                 (gl-vertex-attrib-pointer location
                                           (format-component-count format)
                                           (format-type format)
                                           (format-normalized? format)
                                           stride
                                           (offset->pointer offset))
                 (attrib-loop rest-attribs)))
              attributes)))))))
  (define (do-command cmd)
    (match cmd
      (($ <draw-command> render-state vertex-count instance-count
                         first-vertex first-instance)
       (apply-render-state render-state)
       ;; TODO: Support instanced rendering.
       ;; TODO: Support index buffers.
       (gl-draw-arrays (primitive-mode
                        (render-pipeline-primitive
                         (render-state-pipeline render-state)))
                       first-vertex vertex-count))))
  (gl-state-make-current! state)
  (let ((q (gl-state-queue state)))
    (let loop ()
      (unless (queue-empty? q)
        (do-command (dequeue! q))
        (loop)))))


;;;
;;; Buffers
;;;

;; The copy-src and uniform usages are available only if the GL
;; version is 3.1 or greater.  The indirect and storage usages targets
;; are available only if the GL version is 4.3 or greater.  The
;; query-resolve target is available only if the GL version is 4.4 or
;; greater.
;;
;; TODO: Do we somehow slowly emulate the missing buffer support on GL
;; versions? Or do we just leave that up to higher-level APIs to
;; handle?  Punt for now and see what the situation is like when we
;; actually hit a real world compatibility problem.

(define (make-gl-buffer state length usage)
  (gl-state-make-current! state)
  (let ((buffer (%make-gl-buffer (gl-generate-buffer))))
    (set-gl-state-buffer-vertex! state buffer)
    ;; Allocate buffer memory.
    (gl-buffer-data (version-1-5 array-buffer)
                    length %null-pointer
                    ;; TODO: Set hints based on usage flags.
                    (version-1-5 static-draw))
    buffer))

(define (gl-buffer-destroy state buffer)
  (gl-delete-buffer (gl-buffer-id buffer)))

(define (gl-buffer-map state buffer mode offset length)
  (match mode
    ('read
     (let ((target (version-3-1 copy-write-buffer))
           (access (version-1-5 read-only)))
       (set-gl-buffer-map-target! buffer target)
       (set-gl-state-buffer-copy-write! target buffer)
       (pointer->bytevector (gl-map-buffer target access) length offset)))
    ('write
     (let ((target (version-3-1 copy-read-buffer))
           (access (version-1-5 write-only)))
       (set-gl-buffer-map-target! buffer target)
       (set-gl-state-buffer-copy-read! target buffer)
       (pointer->bytevector (gl-map-buffer target access) length offset)))))

(define (gl-buffer-unmap state buffer)
  (gl-unmap-buffer (gl-buffer-map-target buffer)))

(define (gl-buffer-write state buffer buffer-offset data data-offset length)
  (gl-state-make-current! state)
  (set-gl-state-buffer-vertex! state buffer)
  (gl-buffer-sub-data (version-1-5 array-buffer)
                      buffer-offset length
                      (bytevector->pointer data data-offset)))


;;;
;;; Textures and samplers
;;;

;; A texture simply maps to an OpenGL texture, but texture views and
;; samplers are where things get complicated.  Texture views are
;; supported in OpenGL >= 4.3 so older versions have to fall back to
;; copying data into a new texture.  Samplers are supported in OpenGL
;; >= 3.3 so older versions have to fall back to copying data into yet
;; another new texture and using glTexParameter.

(define (make-gl-texture state width height depth mip-level-count
                         sample-count dimension format usage
                         view-formats)
  (%make-gl-texture (gl-generate-texture)))

(define (gl-texture-destroy state texture)
  (gl-delete-texture (gl-texture-id texture)))

(define (make-gl-texture-view state texture format dimension aspect base-mip-level
                              mip-level-count base-layer layer-count)
  (if (gl-state-version>= state "4.3")
      (let ((alias (gl-generate-texture)))
        (gl-texture-view alias
                         (match dimension
                           ('2d (texture-target texture-2d))
                           ('3d (texture-target texture-3d-ext)))
                         (gl-texture-id (texture-handle texture))
                         ;; TODO: Respect format
                         (pixel-internal-format rgba8)
                         base-mip-level mip-level-count
                         base-layer layer-count)
        (%make-gl-texture-view alias))
      (error "texture view emulation for OpenGL <= 4.3 unimplemented")))

(define (gl-texture-view-destroy view)
  (gl-delete-texture (gl-texture-view-id view)))

(define (make-gl-sampler state address-mode-u address-mode-v address-mode-w
                         mag-filter min-filter mipmap-filter)
  (if (gl-state-version>= state "3.3")
      (%make-gl-sampler (gl-generate-sampler))
      (error "sampler emulation for OpenGL <= 3.3 unimplemented")))

(define (gl-sampler-destroy sampler)
  (gl-delete-sampler (gl-sampler-id sampler)))


;;;
;;; Shaders
;;;

(define (make-gl-shader-module state vertex-source fragment-source)
  (define header
    ;; Set up preprocessor directives dynamically based on the current
    ;; OpenGL context's GLSL version so that we can write shaders that
    ;; are compatible with as many systems as possible.
    (let ((version (gl-meta-glsl-version (gl-state-meta state))))
      (cond
       ((string>= version "3.3")
        "#version 330
#define GLSL330
")
       ((string>= version "1.3")
        "#version 130
#define GLSL130
")
       ((string>= version "1.2")
        "#version 120
#define GLSL120
")
       (else
        (error "incompatible GLSL version" version)))))
  (define (set-shader-source shader source)
    (let ((bv (string->utf8 (string-append header source))))
      (gl-shader-source shader 1
                        (bytevector->pointer
                         (u64vector
                          (pointer-address (bytevector->pointer bv))))
                        (bytevector->pointer
                         (u32vector (bytevector-length bv))))))
  (define (shader-info-log shader)
    (let ((log-length-bv (make-u32vector 1 0)))
      (gl-get-shaderiv shader (version-2-0 info-log-length)
                       (bytevector->pointer log-length-bv))
      ;; Add one byte to account for the null string terminator.
      (let* ((log-length (u32vector-ref log-length-bv 0))
             (log (make-u8vector (1+ log-length) 0)))
        (gl-get-shader-info-log shader log-length %null-pointer
                                (bytevector->pointer log))
        (utf8->string log))))
  (define (compiled? shader)
    (let ((status (make-u32vector 1)))
      (gl-get-shaderiv shader
                       (version-2-0 compile-status)
                       (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (define (compile shader source)
    (set-shader-source shader source)
    (gl-compile-shader shader)
    (unless (compiled? shader)
      (let ((msg (shader-info-log shader)))
        (gl-delete-shader shader)
        (error (format #f "failed to compile shader: ~a" msg)))))
  (define (make-shader source type)
    (let ((shader (gl-create-shader type)))
      (compile shader source)
      (make-gl-shader shader)))
  (gl-state-make-current! state)
  (%make-gl-shader-module (make-shader vertex-source (version-2-0 vertex-shader))
                          (make-shader fragment-source (version-2-0 fragment-shader))))

(define (gl-shader-module-destroy state module)
  (gl-state-make-current! state)
  (gl-delete-shader (gl-shader-module-vertex module))
  (gl-delete-shader (gl-shader-module-fragment module)))

(define (make-gl-render-pipeline state vertex fragment primitive
                                 depth-stencil multisample)
  (define (program-info-log program)
    (let ((log-length-bv (make-u32vector 1 0)))
      (gl-get-shaderiv program (version-2-0 info-log-length)
                       (bytevector->pointer log-length-bv))
      ;; Add one byte to account for the null string terminator.
      (let* ((log-length (u32vector-ref log-length-bv 0))
             (log (make-u8vector (1+ log-length) 0)))
        (gl-get-shader-info-log program log-length %null-pointer
                                (bytevector->pointer log))
        (utf8->string log))))
  (define (linked? program)
    (let ((status (make-u32vector 1 0)))
      (gl-get-programiv program (version-2-0 link-status)
                        (bytevector->pointer status))
      (= (u32vector-ref status 0) 1)))
  (gl-state-make-current! state)
  (let ((program (gl-create-program))
        (vertex* (gl-shader-id
                  (gl-shader-module-vertex
                   (shader-module-handle
                    (vertex-state-module vertex)))))
        (fragment* (gl-shader-id
                    (gl-shader-module-fragment
                     (shader-module-handle
                      (fragment-state-module fragment))))))
    (gl-attach-shader program vertex*)
    (gl-attach-shader program fragment*)
    (gl-link-program program)
    (gl-detach-shader program vertex*)
    (gl-detach-shader program fragment*)
    (unless (linked? program)
      (let ((msg (program-info-log program)))
        (gl-delete-program program)
        (error (format #f "failed to link shader: ~a" msg))))
    (make-gl-program program)))

(define (gl-render-pipeline-destroy state program)
  (gl-state-make-current! state)
  (gl-delete-program (gl-program-id program)))

(define-gpu-device-backend opengl
  make-gl-state
  #:tick gl-state-tick
  #:swap gl-state-swap
  #:enqueue gl-state-enqueue
  #:make-buffer make-gl-buffer
  #:buffer-destroy gl-buffer-destroy
  #:buffer-map gl-buffer-map
  #:buffer-unmap gl-buffer-unmap
  #:buffer-write gl-buffer-write
  #:make-texture make-gl-texture
  #:texture-destroy gl-texture-destroy
  #:make-texture-view make-gl-texture-view
  #:texture-view-destroy gl-texture-view-destroy
  #:make-sampler make-gl-sampler
  #:sampler-destroy gl-sampler-destroy
  #:make-shader-module make-gl-shader-module
  #:shader-module-destroy gl-shader-module-destroy
  #:make-render-pipeline make-gl-render-pipeline
  #:render-pipeline-destroy gl-render-pipeline-destroy)