path: root/chickadee/graphics/buffer.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016-2021 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:
;;
;; GPU data buffers.
;;
;;; Code:

(define-module (chickadee graphics buffer)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (gl)
  #:use-module (system foreign)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics gl)
  #:export (make-buffer
            buffer?
            index-buffer?
            buffer-mapped?
            buffer-name
            buffer-length
            buffer-stride
            buffer-target
            buffer-usage
            buffer-data
            null-buffer
            g:buffer
            current-buffer
            map-buffer!
            unmap-buffer!
            resize-buffer!

            make-vertex-attribute
            vertex-attribute?
            vertex-attribute->buffer
            vertex-attribute-name
            vertex-attribute-offset
            vertex-attribute-component-type
            vertex-attribute-normalized?
            vertex-attribute-length
            vertex-attribute-type
            vertex-attribute-data
            vertex-attribute-divisor

            make-vertex-array
            vertex-array?
            vertex-array-indices
            vertex-array-attributes
            vertex-array-mode
            null-vertex-array
            g:vertex-array
            current-vertex-array
            render-vertices
            render-vertices/instanced

            make-dynamic-buffer
            dynamic-buffer?
            dynamic-buffer->buffer
            dynamic-buffer-data
            dynamic-buffer-capacity
            dynamic-buffer-count
            dynamic-buffer-next!
            dynamic-buffer-clear!
            dynamic-buffer-map!
            dynamic-buffer-unmap!
            dynamic-buffer-import!

            define-geometry-type
            geometry-type?
            geometry-type-attributes
            geometry-type-stride

            make-geometry
            geometry?
            geometry-vertex-array
            geometry-vertex-count
            geometry-index-count
            geometry-begin!
            geometry-begin*
            geometry-end!
            geometry-end*
            with-geometry
            with-geometry*
            geometry-index-set!
            geometry-index-append!
            geometry-import!))

;;;
;;; Vertex Buffers
;;;

(define-record-type <buffer>
  (%make-buffer id name length stride target usage data stream-cache)
  buffer?
  (id buffer-id)
  (name buffer-name)
  (length buffer-length set-buffer-length!)
  (stride buffer-stride)
  (target buffer-target)
  (usage buffer-usage)
  (data buffer-data set-buffer-data!)
  (stream-cache buffer-stream-cache))

(define (print-buffer buffer port)
  (format port
          "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
          (buffer-id buffer)
          (buffer-name buffer)
          (buffer-usage buffer)
          (buffer-target buffer)
          (buffer-length buffer)
          (buffer-stride buffer)))

(set-record-type-printer! <buffer> print-buffer)

(define null-buffer
  (%make-buffer 0 "null" 0 0 'vertex 'static #f #f))

(define (free-buffer buffer)
  (gl-delete-buffers 1 (u32vector (buffer-id buffer))))

(define (bind-buffer buffer)
  (gl-bind-buffer (buffer-target-gl buffer)
                  (buffer-id buffer)))

(define-graphics-finalizer buffer-finalizer
  #:predicate buffer?
  #:free free-buffer)

(define-graphics-state g:buffer
  current-buffer
  #:default null-buffer
  #:bind bind-buffer)

(define (generate-buffer-gl)
  (let ((bv (u32vector 1)))
    (gl-gen-buffers 1 (bytevector->pointer bv))
    (u32vector-ref bv 0)))

(define (index-buffer? buffer)
  "Return #t if VIEW is an index buffer view."
  (eq? (buffer-target buffer) 'index))

(define (buffer-usage-gl buffer)
  (case (buffer-usage buffer)
    ((static)
     (version-1-5 static-draw))
    ((stream)
     (version-1-5 stream-draw))))

(define (buffer-target-gl buffer)
  (if (index-buffer? buffer)
      (version-1-5 element-array-buffer)
      (version-1-5 array-buffer)))

(define* (make-buffer data #:key
                      (name "anonymous")
                      (length (if data (bytevector-length data) 0))
                      (offset 0)
                      (stride 0)
                      (target 'vertex)
                      (usage 'static))
  "Upload DATA, a bytevector, to the GPU.  By default, the entire
bytevector is uploaded.  A subset of the data may be uploaded by
specifying the OFFSET, the index of the first byte to be uploaded, and
LENGTH, the number of bytes to upload.

If DATA is #f, allocate LENGTH bytes of fresh GPU memory instead.

TARGET and USAGE are hints that tell the GPU how the buffer is
intended to be used.

TARGET may be:
- vertex: Vertex attribute data.
- index: Index buffer data.

USAGE may be:
- static: The buffer data will not be modified after creation.
- stream: The buffer data will be modified frequently.

NAME is simply an arbitrary string for debugging purposes that is
never sent to the GPU."
  (assert-current-graphics-engine)
  ;; Weird bugs will occur when creating a new vertex buffer while a
  ;; vertex array is bound.
  (with-graphics-state! ((g:vertex-array null-vertex-array))
    (let ((buffer (%make-buffer (generate-buffer-gl)
                                name
                                length
                                stride
                                target
                                usage
                                #f
                                (and (eq? usage 'stream)
                                     (make-hash-table)))))
      (graphics-engine-guard! buffer)
      (with-graphics-state! ((g:buffer buffer))
        (gl-buffer-data (buffer-target-gl buffer)
                        length
                        (if data
                            (bytevector->pointer data offset)
                            %null-pointer)
                        (buffer-usage-gl buffer)))
      buffer)))

(define (buffer-mapped? buffer)
  "Return #t if buffer data has been mapped from GPU."
  (if (buffer-data buffer) #t #f))

;; For streaming buffers, we use buffer re-specification to achieve
;; good throughput.  However, it requires getting a new data pointer
;; every frame and allocating a Scheme bytevector for that memory
;; region.  Allocating this bytevector every frame causes significant
;; GC pressure.  It turns out that, GPU drivers tend to return the
;; same set of pointers over and over.  So, by caching bytevectors for
;; those memory regions we avoid bytevector allocation after a frame
;; or two of warmup.
(define (pointer->bytevector/cached buffer pointer length)
  (let* ((cache (buffer-stream-cache buffer))
         (address (pointer-address pointer))
         (cached (hashv-ref cache address)))
    (if (and cached (= (bytevector-length cached) length))
        cached
        (let ((bv (pointer->bytevector pointer length)))
          (hashv-set! cache address bv)
          bv))))

(define* (map-buffer! buffer #:optional (mode 'read-write))
  "Map the memory space for BUFFER from the GPU to the CPU, allowing
the vertex buffer to be updated with new vertex data.  The
'unmap-buffer!' procedure must be called to submit the new
vertex buffer data back to the GPU."
  (unless (buffer-mapped? buffer) ;; Don't map a buffer that is already mapped!
    (let ((target (buffer-target-gl buffer))
          (length (buffer-length buffer)))
      (with-graphics-state! ((g:buffer buffer))
        (when (eq? (buffer-usage buffer) 'stream)
          ;; Orphan the buffer to avoid implicit synchronization.
          ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
          (gl-buffer-data target length %null-pointer (buffer-usage-gl buffer)))
        (let* ((ptr (gl-map-buffer target
                                   (case mode
                                     ((read-write)
                                      (version-1-5 read-write))
                                     ((read-only)
                                      (version-1-5 read-only))
                                     ((write-only)
                                      (version-1-5 write-only)))))
               (bv (pointer->bytevector/cached buffer ptr length)))
          (set-buffer-data! buffer bv))))))

(define (unmap-buffer! buffer)
  "Return the mapped vertex buffer data for BUFFER to the GPU."
  (with-graphics-state! ((g:buffer buffer))
    (gl-unmap-buffer (buffer-target-gl buffer))
    (set-buffer-data! buffer #f)))

(define (resize-buffer! buffer length)
  "Resize BUFFER to LENGTH bytes, preserving all existing mapped data
that that fits into the resized buffer.  Only streaming buffers can be
resized."
  (if (eq? (buffer-usage buffer) 'stream)
      ;; Remap the buffer and copy old contents
      (let ((old-bv (buffer-data buffer)))
        (set-buffer-length! buffer length)
        (when old-bv
          ;; Need to make a copy of the data.
          (let ((old-bv (bytevector-copy old-bv)))
            (unmap-buffer! buffer)
            ;; TODO: Set map mode in record
            (map-buffer! buffer 'write-only)
            (let ((new-bv (buffer-data buffer)))
              (bytevector-copy! old-bv 0 new-bv 0
                                (min (bytevector-length old-bv)
                                     (bytevector-length new-bv)))))))
      (error "cannot resize static buffer")))


;;;
;;; Vertex Attributes
;;;

(define (type-size type)
  (case type
    ((scalar) 1)
    ((vec2) 2)
    ((vec3) 3)
    ((color vec4 mat2) 4)
    ((mat3) 9)
    ((mat4) 16)))

(define (component-type-size component-type)
  (case component-type
    ((byte) 1)
    ((unsigned-byte) 1)
    ((short) 2)
    ((unsigned-short) 2)
    ((int) 4)
    ((unsigned-int) 4)
    ((float) 4)
    ((double) 8)))

(define-record-type <vertex-attribute>
  (%make-vertex-attribute name buffer offset offset-pointer component-type
                          normalized? length type divisor)
  vertex-attribute?
  (name vertex-attribute-name)
  (buffer vertex-attribute->buffer)
  (offset vertex-attribute-offset)
  (offset-pointer vertex-attribute-offset-pointer)
  (component-type vertex-attribute-component-type)
  (normalized? vertex-attribute-normalized?)
  (length vertex-attribute-length)
  (type vertex-attribute-type)
  (divisor vertex-attribute-divisor)) ; for instanced rendering

(define (vertex-attribute-stride vertex-attribute)
  (or (buffer-stride (vertex-attribute->buffer vertex-attribute))
      (* (type-size (vertex-attribute-type vertex-attribute))
         (component-type-size (vertex-attribute-component-type vertex-attribute)))))

(define (num-elements byte-length byte-offset type component-type)
  (inexact->exact
   (floor
    (/ (- byte-length byte-offset)
       (* (component-type-size component-type)
          (type-size type))))))

(define* (make-vertex-attribute #:key
                                (name "anonymous")
                                buffer
                                type
                                component-type
                                normalized?
                                (offset 0)
                                (length (num-elements (buffer-length buffer)
                                                      offset
                                                      type
                                                      component-type))
                                (divisor 0))
  "Return a new typed buffer view for BUFFER starting at byte index
OFFSET of LENGTH elements, where each element is of TYPE and composed
of COMPONENT-TYPE values.

Valid values for TYPE are:
- scalar: single number
- vec2: 2D vector
- vec3: 3D vector
- vec4: 4D vector
- color: RGBA color
- mat2: 2x2 matrix
- mat3: 3x3 matrix
- mat4: 4x4 matrix

Valid values for COMPONENT-TYPE are:

- byte
- unsigned-byte
- short
- unsigned-short
- int
- unsigned-int
- float
- double

DIVISOR is only needed for instanced rendering applications and
represents how many instances each vertex element applies to.  A
divisor of 0 means that a single element is used for every instance
and is used for the data being instanced.  A divisor of 1 means that
each element is used for 1 instance.  A divisor of 2 means that each
element is used for 2 instances, and so on."
  (let ((offset-ptr (make-pointer offset)))
    (%make-vertex-attribute name buffer offset offset-ptr component-type
                            normalized? length type divisor)))

(define (display-vertex-attribute vertex-attribute port)
  (format port "#<vertex-attribute name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>"
          (vertex-attribute-name vertex-attribute)
          (vertex-attribute->buffer vertex-attribute)
          (vertex-attribute-type vertex-attribute)
          (vertex-attribute-component-type vertex-attribute)
          (vertex-attribute-length vertex-attribute)
          (vertex-attribute-offset vertex-attribute)
          (vertex-attribute-divisor vertex-attribute)))

(set-record-type-printer! <vertex-attribute> display-vertex-attribute)

(define (vertex-attribute-type-size vertex-attribute)
  (type-size (vertex-attribute-type vertex-attribute)))

(define (vertex-attribute-data vertex-attribute)
  (buffer-data (vertex-attribute->buffer vertex-attribute)))

(define (vertex-attribute-type-gl vertex-attribute)
  (case (vertex-attribute-component-type vertex-attribute)
    ((byte) (data-type byte))
    ((unsigned-byte) (data-type unsigned-byte))
    ((short) (data-type short))
    ((unsigned-short) (data-type unsigned-short))
    ((int) (data-type int))
    ((unsigned-int) (data-type unsigned-int))
    ((float) (data-type float))
    ((double) (data-type double))))

(define (apply-vertex-attribute vertex-attribute attribute-index)
  (with-graphics-state! ((g:buffer (vertex-attribute->buffer vertex-attribute)))
    ;; If there is no attribute-index, we assume this is being bound for
    ;; use as an index buffer.
    (when attribute-index
      (gl-enable-vertex-attrib-array attribute-index)
      (gl-vertex-attrib-pointer attribute-index
                                (vertex-attribute-type-size vertex-attribute)
                                (vertex-attribute-type-gl vertex-attribute)
                                (vertex-attribute-normalized? vertex-attribute)
                                (vertex-attribute-stride vertex-attribute)
                                (vertex-attribute-offset-pointer vertex-attribute))
      (let ((divisor (vertex-attribute-divisor vertex-attribute)))
        (when divisor
          (gl-vertex-attrib-divisor attribute-index divisor))))))


;;;
;;; Vertex Arrays
;;;

(define-record-type <vertex-array>
  (%make-vertex-array id indices attributes mode)
  vertex-array?
  (id vertex-array-id)
  (indices vertex-array-indices)
  (attributes vertex-array-attributes)
  (mode vertex-array-mode))

(set-record-type-printer! <vertex-array>
                          (lambda (array port)
                            (format port
                                    "#<vertex-array indices: ~a attributes: ~a mode: ~s>"
                                    (vertex-array-indices array)
                                    (vertex-array-attributes array)
                                    (vertex-array-mode array))))

(define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))

(define (generate-vertex-array)
  (let ((bv (u32vector 1)))
    (gl-gen-vertex-arrays 1 (bytevector->pointer bv))
    (u32vector-ref bv 0)))

(define (free-vertex-array va)
  (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))

(define (apply-vertex-array va)
  (gl-bind-vertex-array (vertex-array-id va)))

(define (bind-vertex-array va)
  (gl-bind-vertex-array (vertex-array-id va)))

(define-graphics-finalizer vertex-array-finalizer
  #:predicate vertex-array?
  #:free free-vertex-array)

(define-graphics-state g:vertex-array
  current-vertex-array
  #:default null-vertex-array
  #:bind bind-vertex-array)

(define* (make-vertex-array #:key indices attributes (mode 'triangles))
  "Return a new vertex array using the index data within the typed
buffer INDICES and the vertex attribute data within ATTRIBUTES, an
alist mapping shader attribute indices to typed buffers containing
vertex data.

By default, the vertex array is interpreted as containing a series of
triangles.  If another primtive type is desired, the MODE keyword
argument may be overridden.  The following values are supported:

- points
- lines
- line-loop
- line-strip
- triangles
- triangle-strip
- triangle-fan"
  (assert-current-graphics-engine)
  (let ((array (%make-vertex-array (generate-vertex-array)
                                   indices
                                   attributes
                                   mode)))
    (graphics-engine-guard! array)
    (with-graphics-state! ((g:vertex-array array))
      (for-each (match-lambda
                  ((index . vertex-attribute)
                   (apply-vertex-attribute vertex-attribute index)))
                attributes)
      (when indices (apply-vertex-attribute indices #f)))
    ;; Restore the old array.  Is this needed?
    ;; (graphics-engine-commit!)
    array))

(define (vertex-array-mode-gl array)
  (case (vertex-array-mode array)
    ((points) (begin-mode points))
    ((lines) (begin-mode lines))
    ((line-loop) (begin-mode line-loop))
    ((line-strip) (begin-mode line-strip))
    ((triangles) (begin-mode triangles))
    ((triangle-strip) (begin-mode triangle-strip))
    ((triangle-fan) (begin-mode triangle-fan))))

(define (render-vertices array count offset)
  (with-graphics-state! ((g:vertex-array array))
    (let ((indices (vertex-array-indices array)))
      (if indices
          (begin
            (apply-vertex-attribute indices #f)
            (gl-draw-elements (vertex-array-mode-gl array)
                              (or count
                                  (vertex-attribute-length indices))
                              (vertex-attribute-type-gl indices)
                              (vertex-attribute-offset-pointer indices)))
          (gl-draw-arrays (vertex-array-mode-gl array)
                          offset
                          (or count
                              (vertex-attribute-length
                               (assv-ref (vertex-array-attributes array)
                                         0))))))))

(define (render-vertices/instanced array instances count offset)
  (with-graphics-state! ((g:vertex-array array))
    (let ((indices (vertex-array-indices array)))
      (if indices
          (begin
            (apply-vertex-attribute indices #f)
            (gl-draw-elements-instanced (vertex-array-mode-gl array)
                                        (or count
                                            (vertex-attribute-length indices))
                                        (vertex-attribute-type-gl indices)
                                        (vertex-attribute-offset-pointer indices)
                                        instances))
          (gl-draw-arrays-instanced (vertex-array-mode-gl array)
                                    offset count instances)))))


;;;
;;; Dynamic Buffers
;;;

;; A layer on top of vertex buffers to handle buffer streaming with
;; dynamic buffer expansion.
(define-record-type <dynamic-buffer>
  (%make-dynamic-buffer buffer capacity count)
  dynamic-buffer?
  (buffer dynamic-buffer->buffer)
  (data dynamic-buffer-data set-dynamic-buffer-data!)
  (capacity dynamic-buffer-capacity set-dynamic-buffer-capacity!)
  (count dynamic-buffer-count set-dynamic-buffer-count!))

(define* (make-dynamic-buffer #:key name capacity stride usage (target 'vertex))
  (let* ((buffer (make-buffer #f
                              #:name name
                              #:length (* capacity stride)
                              #:stride stride
                              #:usage usage
                              #:target target)))
    (%make-dynamic-buffer buffer capacity 0)))

(define-inlinable (dynamic-buffer-bounds-check dbuffer i)
  (unless (< i (dynamic-buffer-count dbuffer))
    (error "index out of bounds" i)))

(define (expand-dynamic-buffer dbuffer)
  (let ((new-capacity (inexact->exact
                       (round (* (dynamic-buffer-capacity dbuffer) 1.5))))
        (buffer (dynamic-buffer->buffer dbuffer)))
    (resize-buffer! buffer (* new-capacity (buffer-stride buffer)))
    (set-dynamic-buffer-capacity! dbuffer new-capacity)
    (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))

(define-inlinable (dynamic-buffer-next! dbuffer n)
  (let ((count (dynamic-buffer-count dbuffer)))
    (let resize ()
      (let ((capacity (dynamic-buffer-capacity dbuffer)))
        (when (> (+ count n) capacity)
          (expand-dynamic-buffer dbuffer)
          (resize))))
    (set-dynamic-buffer-count! dbuffer (+ count n))
    count))

(define (dynamic-buffer-clear! dbuffer)
  (set-dynamic-buffer-count! dbuffer 0))

(define (dynamic-buffer-map! dbuffer)
  (let ((buffer (dynamic-buffer->buffer dbuffer)))
    (dynamic-buffer-clear! dbuffer)
    (map-buffer! buffer 'write-only)
    ;; Stashing the bytevector here turns out to be a *huge* performance
    ;; booster.  Probably because it's avoiding another layer of record
    ;; type checks and stuff?  I dunno.
    (set-dynamic-buffer-data! dbuffer (buffer-data buffer))))

(define (dynamic-buffer-unmap! dbuffer)
  (unmap-buffer! (dynamic-buffer->buffer dbuffer))
  (set-dynamic-buffer-data! dbuffer #f))

(define (dynamic-buffer-import! dbuffer bv start end)
  (let ((stride (buffer-stride (dynamic-buffer->buffer dbuffer)))
        (copy-count (- end start)))
    (let resize ()
      (let ((capacity (dynamic-buffer-capacity dbuffer)))
        (when (< capacity copy-count)
          (begin
            (expand-dynamic-buffer dbuffer)
            (resize)))))
    (bytevector-copy! bv
                      (* start stride)
                      (dynamic-buffer-data dbuffer)
                      0
                      (* copy-count stride))
    (set-dynamic-buffer-count! dbuffer copy-count)))


;;;
;;; Geometry Builder
;;;

(define-record-type <geometry>
  (%make-geometry vertex-buffers index-buffer vertex-array)
  geometry?
  (vertex-buffers geometry-vertex-buffers)
  (index-buffer geometry-index-buffer)
  (vertex-array geometry-vertex-array))

(define-record-type <geometry-type>
  (make-geometry-type attributes stride)
  geometry-type?
  (attributes geometry-type-attributes)
  (stride geometry-type-stride))

(define* (make-geometry types capacity #:key (index? #t) (usage 'stream)
                        (index-usage usage) (index-capacity capacity)
                        (mode 'triangles))
  (define (scalar-type? type)
    (memq type '(float double int unsigned-int)))
  (define (make-dynamic-buffer* type . args)
    (apply make-dynamic-buffer
           #:name "vertex"
           #:capacity capacity
           #:usage usage
           #:stride (geometry-type-stride type)
           args))
  (define (filter-kwargs l keep)
    (let loop ((l l))
      (match l
        (() '())
        ((kw arg . rest)
         (if (memq kw keep)
             (cons* kw arg (loop rest))
             (loop rest))))))
  (define (make-vertex-attribute* name type attr-type dbuffer offset args)
    (apply make-vertex-attribute
           #:name (format #f "~s view" name)
           #:buffer (dynamic-buffer->buffer dbuffer)
           #:type (if (scalar-type? attr-type)
                      'scalar
                      attr-type)
           #:component-type (if (scalar-type? attr-type)
                                attr-type
                                'float)
           #:offset offset
           args))
  (define (canonicalize-types)
    (if (geometry-type? types)
        (list (list types))
        (map (lambda (x)
               (match x
                 ((_ ...)
                  x)
                 (type
                  (list type))))
             types)))
  (define (build-vertex-buffers types)
    (map (match-lambda
           ((type . args)
            (cons type
                  (apply make-dynamic-buffer*
                         type
                         (filter-kwargs args '(#:capacity #:usage))))))
         types))
  (define (build-views types buffers)
    (let loop ((types types)
               (location 0))
      (match types
        (() '())
        (((type . args) . rest)
         (let inner ((attrs (geometry-type-attributes type))
                     (location location))
           (match attrs
             (()
              (loop rest location))
             (((name attr-type offset) . rest)
              (cons (cons location
                          (make-vertex-attribute* name
                                                  type
                                                  attr-type
                                                  (assq-ref buffers type)
                                                  offset
                                                  (filter-kwargs args '(#:divisor))))
                    (inner rest (+ location 1))))))))))
  (let* ((index-buffer (and index?
                            (make-dynamic-buffer #:name "index"
                                                 #:capacity index-capacity
                                                 #:usage index-usage
                                                 #:stride 4
                                                 #:target 'index)))
         (index-view (and index?
                          (make-vertex-attribute #:name "index view"
                                                 #:buffer (dynamic-buffer->buffer
                                                           index-buffer)
                                                 #:type 'scalar
                                                 #:component-type 'unsigned-int)))
         (types (canonicalize-types))
         (vertex-buffers (build-vertex-buffers types))
         (vertex-views (build-views types vertex-buffers))
         (vertex-array (make-vertex-array #:indices index-view
                                          #:attributes vertex-views
                                          #:mode mode)))
    (%make-geometry vertex-buffers index-buffer vertex-array)))

(define (geometry-vertex-buffer geometry type)
  (assq-ref (geometry-vertex-buffers geometry) type))

(define-inlinable (geometry-set-index! geometry i j)
  (let ((buffer (geometry-index-buffer geometry)))
    (dynamic-buffer-bounds-check buffer i)
    (u32vector-set! (dynamic-buffer-data buffer) i j)))

(define-syntax-rule (geometry-index-append! geometry i ...)
  (let* ((buffer (geometry-index-buffer geometry))
         (n (length '(i ...)))
         (j (dynamic-buffer-next! buffer n))
         (bv (dynamic-buffer-data buffer)))
    (begin
      (u32vector-set! bv j i)
      (set! j (+ j 1)))
    ...))

(define (geometry-import! geometry type bv start end)
  (dynamic-buffer-import! (geometry-vertex-buffer geometry type) bv start end))

(define-inlinable (geometry-vertex-count geometry type)
  (dynamic-buffer-count (geometry-vertex-buffer geometry type)))

(define-inlinable (geometry-index-count geometry)
  (dynamic-buffer-count (geometry-index-buffer geometry)))

(define (geometry-begin* geometry type)
  (dynamic-buffer-map!
   (if (eq? type 'index)
       (geometry-index-buffer geometry)
       (geometry-vertex-buffer geometry type))))

(define (geometry-end* geometry type)
  (dynamic-buffer-unmap!
   (if (eq? type 'index)
       (geometry-index-buffer geometry)
       (geometry-vertex-buffer geometry type))))

(define-syntax-rule (with-geometry* geometry (type ...) body ...)
  (begin
    (geometry-begin* geometry type) ...
    body ...
    (geometry-end* geometry type) ...))

(define (begin:map buffer-pair)
  (dynamic-buffer-map! (cdr buffer-pair)))

(define (geometry-begin! geometry)
  (let ((index-buffer (geometry-index-buffer geometry)))
    (for-each begin:map (geometry-vertex-buffers geometry))
    (when index-buffer
      (dynamic-buffer-map! index-buffer))))

(define (end:unmap buffer-pair)
  (dynamic-buffer-unmap! (cdr buffer-pair)))

(define (geometry-end! geometry)
  (let ((index-buffer (geometry-index-buffer geometry)))
    (when index-buffer
      (dynamic-buffer-unmap! index-buffer))
    (for-each end:unmap (geometry-vertex-buffers geometry))))

(define-syntax-rule (with-geometry geometry body ...)
  (begin
    (geometry-begin! geometry)
    body ...
    (geometry-end! geometry)))

;; Thanks to wingo for his define-packed-struct macro in guile-opengl
;; that I used as a reference while making this.
(define-syntax-parameter g-append (syntax-rules ()))
(define-syntax define-geometry-type
  (lambda (stx)
    (define (type-size type)
      (case type
        ((float int unsigned-int) 4)
        ((double) 8)
        ((vec2) (* (type-size 'float) 2))
        ((vec3) (* (type-size 'float) 3))
        ((vec4) (* (type-size 'float) 4))))
    (define (type-getter type)
      (case type
        ((float) #'bytevector-ieee-single-native-ref)
        ((double) #'bytevector-ieee-double-native-ref)
        ((int) #'bytevector-s32-native-ref)
        ((unsigned-int) #'bytevector-u32-native-ref)))
    (define (type-setter type)
      (case type
        ((float) #'bytevector-ieee-single-native-set!)
        ((double) #'bytevector-ieee-double-native-set!)
        ((int) #'bytevector-s32-native-set!)
        ((unsigned-int) #'bytevector-u32-native-set!)))
    (define (expand-attribute name type)
      (case type
        ((float int unsigned-int)
         (list (list name type)))
        ((vec2)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)))
        ((vec3)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)
           (,(symbol-append name ':z) float)))
        ((vec4)
         `((,(symbol-append name ':x) float)
           (,(symbol-append name ':y) float)
           (,(symbol-append name ':z) float)
           (,(symbol-append name ':w) float)))))
    (define (expand-attributes attrs)
      (append-map (match-lambda
                    ((name type _)
                     (expand-attribute name type)))
                  attrs))
    (define* (build-fields primitives #:optional (offset 0))
      (match primitives
        (() '())
        (((name type) . rest)
         (cons (list name type offset
                     (type-getter type)
                     (type-setter type))
               (build-fields rest (+ offset (type-size type)))))))
    (define (build-attributes attrs)
      (let loop ((attrs attrs)
                 (offset 0))
        (match attrs
          (() '())
          (((name type) . rest)
           (cons (list name type offset)
                 (loop rest (+ offset (type-size type))))))))
    (define (compute-stride types)
      (fold (lambda (type sum) (+ (type-size type) sum)) 0 types))
    (syntax-case stx ()
      ((_ type-name getter setter appender (name type) ...)
       (let* ((attributes (build-attributes
                           (syntax->datum #'((name type) ...))))
              (stride* (compute-stride (syntax->datum #'(type ...))))
              (fields (build-fields (expand-attributes attributes))))
         (with-syntax ((((attr-name attr-type attr-offset) ...)
                        (datum->syntax stx attributes))
                       (((field-name field-type field-offset field-getter field-setter) ...)
                        (datum->syntax stx fields))
                       (type-stride stride*))
           #'(begin
               (define type-name
                 (make-geometry-type '((attr-name attr-type attr-offset) ...)
                                     type-stride))
               (define-syntax-rule (getter field geometry i)
                 (let ((dbuffer (geometry-vertex-buffer geometry type-name)))
                   (dynamic-buffer-bounds-check dbuffer i)
                   (case 'field
                     ((field-name)
                      (field-getter (dynamic-buffer-data dbuffer
                                                         (+ (* i type-stride) field-offset))))
                     ...
                     (else (error "unknown field" 'field)))))
               (define-syntax-rule (setter geometry field i x)
                 (let ((dbuffer (geometry-vertex-buffer geometry type-name)))
                   (dynamic-buffer-bounds-check dbuffer i)
                   (case 'field
                     ((field-name)
                      (field-setter (dynamic-buffer-data dbuffer)
                                    (+ (* i type-stride) field-offset)
                                    x))
                     ...
                     (else (error "unknown field" 'field)))))
               (define-syntax appender
                 (syntax-rules ::: ()
                               ((_ geometry (field-name ...) :::)
                                (let* ((dbuffer (geometry-vertex-buffer geometry type-name))
                                       (n (length '((field-name ...) :::)))
                                       (i (dynamic-buffer-next! dbuffer n))
                                       (bv (dynamic-buffer-data dbuffer)))
                                  (let ((offset (* i type-stride)))
                                    (field-setter bv (+ offset field-offset) field-name)
                                    ...
                                    (set! i (+ i 1)))
                                  :::)))))))))))