summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el2
-rw-r--r--chickadee/graphics/buffer.scm457
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>
@@ -255,9 +291,107 @@ resized."
;;;
+;;; 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)))
+ :::)))))))))))