diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | 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> @@ -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))) + :::))))))))))) |