From 35ab6dcd0666bf07e8da7cd7521905e10c9dc932 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 5 Dec 2020 15:40:05 -0500
Subject: graphics: buffer: Add dynamic geometry type.

---
 .dir-locals.el                |   2 +
 chickadee/graphics/buffer.scm | 457 +++++++++++++++++++++++++++++++++++++++---
 2 files changed, 432 insertions(+), 27 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 3a62615..aca7480 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -22,6 +22,8 @@
    (eval . (put 'with-color-mask 'scheme-indent-function 1))
    (eval . (put 'with-style 'scheme-indent-function 1))
    (eval . (put 'with-transform 'scheme-indent-function 1))
+   (eval . (put 'with-geometry 'scheme-indent-function 1))
+   (eval . (put 'with-geometry* 'scheme-indent-function 2))
    (eval . (put 'translate 'scheme-indent-function 1))
    (eval . (put 'rotate 'scheme-indent-function 1))
    (eval . (put 'scale 'scheme-indent-function 1)))))
diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm
index b4a1d10..62c9c18 100644
--- a/chickadee/graphics/buffer.scm
+++ b/chickadee/graphics/buffer.scm
@@ -1,5 +1,5 @@
 ;;; Chickadee Game Toolkit
-;;; Copyright © 2016, 2017, 2019 David Thompson <davet@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 David Thompson <davet@gnu.org>
 ;;;
 ;;; Chickadee is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published
@@ -26,6 +26,7 @@
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #: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)
@@ -33,6 +34,7 @@
   #:use-module (system foreign)
   #:use-module (chickadee math matrix)
   #:use-module (chickadee math vector)
+  #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics gl)
   #:use-module (chickadee graphics gpu)
   #:export (make-buffer
@@ -52,6 +54,19 @@
             unmap-buffer!
             resize-buffer!
             with-mapped-buffer
+
+            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!
+
             make-buffer-view
             make-streaming-buffer-view
             buffer-view?
@@ -71,6 +86,7 @@
             map-buffer-view!
             unmap-buffer-view!
             with-mapped-buffer-view
+
             make-vertex-array
             apply-vertex-array
             vertex-array?
@@ -79,10 +95,30 @@
             vertex-array-mode
             null-vertex-array
             render-vertices
-            render-vertices/instanced))
+            render-vertices/instanced
+
+            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!))
 
 ;;;
-;;; Buffers
+;;; Vertex Buffers
 ;;;
 
 (define-record-type <buffer>
@@ -253,11 +289,109 @@ resized."
     (lambda ()
       (unmap-buffer! buffer))))
 
+
+;;;
+;;; 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)))
+
 
 ;;;
 ;;; Buffer Views
 ;;;
 
+(define (type-size type)
+  (match type
+    ('scalar 1)
+    ('vec2 2)
+    ('vec3 3)
+    ((or 'color 'vec4 'mat2) 4)
+    ('mat3 9)
+    ('mat4 16)))
+
+(define (component-type-size component-type)
+  (match component-type
+    ('byte 1)
+    ('unsigned-byte 1)
+    ('short 2)
+    ('unsigned-short 2)
+    ('int 4)
+    ('unsigned-int 4)
+    ('float 4)
+    ('double 8)))
+
 (define-record-type <buffer-view>
   (%make-buffer-view name buffer offset component-type
                      normalized? length type max min sparse divisor)
@@ -301,7 +435,7 @@ resized."
                            max
                            min
                            sparse
-                           divisor)
+                           (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.
@@ -311,6 +445,7 @@ Valid values for TYPE are:
 - vec2: 2D vector
 - vec3: 3D vector
 - vec4: 4D vector
+- color: RGBA color
 - mat2: 2x2 matrix
 - mat3: 3x3 matrix
 - mat4: 4x4 matrix
@@ -335,31 +470,11 @@ element is used for 2 instances, and so on."
   (%make-buffer-view name buffer offset component-type
                      normalized? length type max min sparse divisor))
 
-(define (type-size type)
-  (match type
-    ('scalar 1)
-    ('vec2 2)
-    ('vec3 3)
-    ((or 'vec4 'mat2) 4)
-    ('mat3 9)
-    ('mat4 16)))
-
-(define (component-type-size component-type)
-  (match component-type
-    ('byte 1)
-    ('unsigned-byte 1)
-    ('short 2)
-    ('unsigned-short 2)
-    ('int 4)
-    ('unsigned-int 4)
-    ('float 4)
-    ('double 8)))
-
 (define* (make-streaming-buffer-view type component-type length #:key
                                      (name "anonymous")
                                      (target 'vertex)
                                      data
-                                     divisor)
+                                     (divisor 0))
   "Return a new typed buffer to hold LENGTH elements of TYPE whose
 components are comprised of COMPONENT-TYPE values.  The underlying
 untyped buffer is configured for GPU streaming.  Optonally, a NAME can
@@ -385,13 +500,14 @@ which attributes advance when rendering multiple instances."
                       #:divisor divisor)))
 
 (define (display-buffer-view buffer-view port)
-  (format port "#<buffer-view name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d>"
+  (format port "#<buffer-view name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d divisor: ~d>"
           (buffer-view-name buffer-view)
           (buffer-view->buffer buffer-view)
           (buffer-view-type buffer-view)
           (buffer-view-component-type buffer-view)
           (buffer-view-length buffer-view)
-          (buffer-view-offset buffer-view)))
+          (buffer-view-offset buffer-view)
+          (buffer-view-divisor buffer-view)))
 
 (set-record-type-printer! <buffer-view> display-buffer-view)
 
@@ -633,3 +749,290 @@ argument may be overridden.  The following values are supported:
                                     instances))
       (gl-draw-arrays-instanced (vertex-array-mode-gl array)
                                 offset count instances))))
+
+
+;;;
+;;; 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-buffer-view* name type attr-type dbuffer offset args)
+    (apply make-buffer-view
+           #: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-buffer-view* 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-buffer-view #: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 (geometry-begin! geometry)
+  (let ((index-buffer (geometry-index-buffer geometry)))
+    (for-each (match-lambda
+                ((_ . buffer)
+                 (dynamic-buffer-map! buffer)))
+              (geometry-vertex-buffers geometry))
+    (when index-buffer
+      (dynamic-buffer-map! index-buffer))))
+
+(define (geometry-end! geometry)
+  (let ((index-buffer (geometry-index-buffer geometry)))
+    (when index-buffer
+      (dynamic-buffer-unmap! index-buffer))
+    (for-each (match-lambda
+                ((_ . buffer)
+                 (dynamic-buffer-unmap! buffer)))
+              (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)
+      (match type
+        ((or '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)
+      (match 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)
+      (match 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)
+      (match type
+        ((or '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)))
+                      :::)))))))))))
-- 
cgit v1.2.3