diff options
Diffstat (limited to 'chickadee/graphics/buffer.scm')
| -rw-r--r-- | chickadee/graphics/buffer.scm | 837 |
1 files changed, 254 insertions, 583 deletions
diff --git a/chickadee/graphics/buffer.scm b/chickadee/graphics/buffer.scm index 625a9e0..050433f 100644 --- a/chickadee/graphics/buffer.scm +++ b/chickadee/graphics/buffer.scm @@ -1,5 +1,5 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2016-2021 David Thompson <dthompson2@worcester.edu> +;;; Copyright © 2016-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. @@ -20,6 +20,10 @@ ;;; Code: (define-module (chickadee graphics buffer) + #:use-module (chickadee data bytestruct) + #:use-module ((chickadee graphics backend) #:prefix gpu:) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) @@ -27,56 +31,38 @@ #: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 + destroy-buffer buffer? - index-buffer? + buffer-available? + buffer-destroyed? 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 + buffer-write! + map-buffer + unmap-buffer + bytevector->buffer + + make-dbuffer + dbuffer? + dbuffer-mapped? + dbuffer-buffer + dbuffer-capacity + dbuffer-length + dbuffer-clear! + dbuffer-map! + dbuffer-unmap! + dbuffer-reserve! + dbuffer-pack! + dbuffer-append! + dbuffer-pack-indices-quad! + dbuffer-append-indices-quad! make-dynamic-buffer dynamic-buffer? - dynamic-buffer->buffer + dynamic-buffer-buffer dynamic-buffer-data dynamic-buffer-capacity dynamic-buffer-count @@ -93,7 +79,8 @@ make-geometry geometry? - geometry-vertex-array + geometry-vertex-buffers + geometry-index-buffer geometry-vertex-count geometry-index-count geometry-begin! @@ -106,460 +93,102 @@ geometry-index-append! geometry-import!)) -;;; -;;; Vertex Buffers -;;; - (define-record-type <buffer> - (%make-buffer id name length stride target usage data stream-cache) + (%make-buffer gpu handle name length usage state map-state) buffer? - (id buffer-id) + (gpu buffer-gpu) + (handle buffer-handle) (name buffer-name) - (length buffer-length set-buffer-length!) - (stride buffer-stride) - (target buffer-target) + (length buffer-length) (usage buffer-usage) - (data buffer-data set-buffer-data!) - (stream-cache buffer-stream-cache)) + (state buffer-state set-buffer-state!) + (map-state buffer-map-state set-buffer-map-state!) + (mapping buffer-mapping set-buffer-mapping!)) (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))) + (match buffer + (($ <buffer> _ _ name length usage _) + (format #t "#<buffer name: ~s length: ~s usage: ~s>" + name length usage)))) (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-available? buffer) + (eq? (buffer-state buffer) 'available)) -(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"))) +(define (buffer-destroyed? buffer) + (eq? (buffer-state buffer) 'destroyed)) - -;;; -;;; 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))))) +(define (buffer-mapped? buffer) + (eq? (buffer-map-state buffer) 'mapped)) + +;; TODO: Validate length is > 0 and < max length. +;; TODO: Validate usage flags. +(define* (make-buffer length #:key name (usage '(vertex))) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-buffer gpu length usage))) + (%make-buffer gpu handle name length usage 'available 'unmapped))) + +;; TODO: Ensure buffer is unmapped first. +(define (destroy-buffer buffer) + (unless (buffer-destroyed? buffer) + (gpu:destroy-buffer (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-state! buffer 'destroyed))) + +(define (write-buffer buffer at data start length) + (gpu:write-buffer (buffer-gpu buffer) (buffer-handle buffer) + 0 data 0 length)) + +(define (map-buffer buffer mode offset length) + (let ((bv (gpu:map-buffer (buffer-gpu buffer) (buffer-handle buffer) + mode offset length))) + (set-buffer-mapping! buffer bv) + (set-buffer-map-state! buffer 'mapped) + bv)) + +(define (unmap-buffer buffer) + (when (buffer-mapped? buffer) + (gpu:unmap-buffer (buffer-gpu buffer) (buffer-handle buffer)) + (set-buffer-mapping! buffer #f))) + +(define* (bytevector->buffer data #:key name (usage '(vertex))) + (let* ((length (bytevector-length data)) + (buffer (make-buffer length #:name name #:usage usage))) + (write-buffer buffer 0 data 0 length) + buffer)) + +;; (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))))) ;;; @@ -569,33 +198,39 @@ argument may be overridden. The following values are supported: ;; 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) + (%make-dynamic-buffer buffer stride capacity count) dynamic-buffer? - (buffer dynamic-buffer->buffer) + (buffer dynamic-buffer-buffer set-dynamic-buffer-buffer!) + (stride dynamic-buffer-stride) (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 +(define* (make-dynamic-buffer #:key name capacity stride (usage '(vertex))) + (let* ((buffer (make-buffer (* capacity stride) #:name name - #:length (* capacity stride) - #:stride stride - #:usage usage - #:target target))) - (%make-dynamic-buffer buffer capacity 0))) + #:usage usage))) + (%make-dynamic-buffer buffer stride 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)))) + (match dbuffer + (($ <dynamic-buffer> old-buffer stride old-data old-capacity count) + (let* ((new-capacity (* old-capacity 2)) + (new-length (* new-capacity stride)) + (new-buffer (make-buffer new-length + #:name (buffer-name old-buffer) + #:usage (buffer-usage old-buffer)))) + (set-dynamic-buffer-buffer! dbuffer new-buffer) + (set-dynamic-buffer-capacity! dbuffer new-capacity) + (when old-data + (unmap-buffer old-buffer) + (let ((new-data (map-buffer new-buffer 'write 0 new-length))) + (bytevector-copy! old-data 0 new-data 0 (bytevector-length old-data)) + (set-dynamic-buffer-data! dbuffer new-data))))))) (define-inlinable (dynamic-buffer-next! dbuffer n) (let ((count (dynamic-buffer-count dbuffer))) @@ -611,20 +246,17 @@ argument may be overridden. The following values are supported: (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)))) + (dynamic-buffer-clear! dbuffer) + (let* ((buffer (dynamic-buffer-buffer dbuffer)) + (bv (map-buffer buffer 'write 0 (buffer-length buffer)))) + (set-dynamic-buffer-data! dbuffer bv))) (define (dynamic-buffer-unmap! dbuffer) - (unmap-buffer! (dynamic-buffer->buffer 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))) + (let ((stride (dynamic-buffer-stride dbuffer)) (copy-count (- end start))) (let resize () (let ((capacity (dynamic-buffer-capacity dbuffer))) @@ -641,15 +273,97 @@ argument may be overridden. The following values are supported: ;;; +;;; Builder??? +;;; + +(define-record-type <dbuffer> + (%make-dbuffer buffer capacity length) + dbuffer? + (buffer dbuffer-buffer set-dbuffer-buffer!) + (data dbuffer-data set-dbuffer-data!) + (capacity dbuffer-capacity set-dbuffer-capacity!) + (length dbuffer-length set-dbuffer-length!)) + +(define (dbuffer-mapped? dbuffer) + (bytevector? (dbuffer-data dbuffer))) + +(define* (make-dbuffer #:key name (capacity 128) (usage '(vertex))) + (let* ((buffer (make-buffer capacity #:name name #:usage usage))) + (%make-dbuffer buffer capacity 0))) + +(define (expand-dbuffer dbuffer) + (match dbuffer + (($ <dbuffer> old-buffer old-data old-capacity old-length) + (let* ((new-capacity (* old-capacity 2)) + (new-buffer (make-buffer new-capacity + #:name (buffer-name old-buffer) + #:usage (buffer-usage old-buffer)))) + (set-dbuffer-buffer! dbuffer new-buffer) + (set-dbuffer-capacity! dbuffer new-capacity) + (when old-data + (unmap-buffer old-buffer) + (let ((new-data (map-buffer new-buffer 'write 0 new-capacity))) + (bytevector-copy! old-data 0 new-data 0 old-length) + (set-dbuffer-data! dbuffer new-data))))))) + +(define (dbuffer-reserve! dbuffer n) + (match dbuffer + (($ <dbuffer> _ _ capacity length) + (if (> (+ length n) capacity) + (begin + (expand-dbuffer dbuffer) + (dbuffer-reserve! dbuffer n)) + (begin + (set-dbuffer-length! dbuffer (+ length n)) + length))))) + +(define (dbuffer-clear! dbuffer) + (set-dbuffer-length! dbuffer 0)) + +(define (dbuffer-map! dbuffer) + (dbuffer-clear! dbuffer) + (let* ((buffer (dbuffer-buffer dbuffer)) + (bv (map-buffer buffer 'write 0 (buffer-length buffer)))) + (set-dbuffer-data! dbuffer bv))) + +(define (dbuffer-unmap! dbuffer) + (unmap-buffer (dbuffer-buffer dbuffer)) + (set-dbuffer-data! dbuffer #f)) + +;; TODO: Add setters and define appenders as reserve + set +(define-syntax-rule (dbuffer-pack! <type> (elem ...) dbuffer offset) + (if (exact-integer? offset) + (bytestruct-pack! <type> (elem ...) (dbuffer-data dbuffer) offset) + (error "expected exact integer" offset))) + +(define-syntax-rule (dbuffer-append! <type> (elem ...) dbuffer) + (let ((offset (dbuffer-reserve! dbuffer (bytestruct-sizeof <type>)))) + (dbuffer-pack! <type> (elem ...) dbuffer offset))) + +(define-inlinable (dbuffer-pack-indices-quad! dbuffer offset i) + (unless (exact-integer? offset) + (error "expected exact integer" offset)) + (let ((bv (dbuffer-data dbuffer))) + (bytevector-u32-native-set! bv offset i) + (bytevector-u32-native-set! bv (+ offset 4) (+ i 2)) + (bytevector-u32-native-set! bv (+ offset 8) (+ i 3)) + (bytevector-u32-native-set! bv (+ offset 12) i) + (bytevector-u32-native-set! bv (+ offset 16) (+ i 1)) + (bytevector-u32-native-set! bv (+ offset 20) (+ i 2)))) + +(define-inlinable (dbuffer-append-indices-quad! dbuffer i) + (dbuffer-pack-indices-quad! dbuffer (dbuffer-reserve! dbuffer 24) i)) + + +;;; ;;; Geometry Builder ;;; (define-record-type <geometry> - (%make-geometry vertex-buffers index-buffer vertex-array) + (%make-geometry vertex-buffers index-buffer) geometry? (vertex-buffers geometry-vertex-buffers) - (index-buffer geometry-index-buffer) - (vertex-array geometry-vertex-array)) + (index-buffer geometry-index-buffer)) (define-record-type <geometry-type> (make-geometry-type attributes stride) @@ -666,7 +380,7 @@ argument may be overridden. The following values are supported: (apply make-dynamic-buffer #:name "vertex" #:capacity capacity - #:usage usage + #:usage '(index vertex) #:stride (geometry-type-stride type) args)) (define (filter-kwargs l keep) @@ -677,18 +391,6 @@ argument may be overridden. The following values are supported: (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)) @@ -703,49 +405,19 @@ argument may be overridden. The following values are supported: (map (match-lambda ((type . args) (cons type - (apply make-dynamic-buffer* - type - (filter-kwargs args '(#:capacity #:usage)))))) + (make-dynamic-buffer #:name "vertex" + #:capacity capacity + #:usage '(vertex) + #:stride (geometry-type-stride type))))) 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))) + #:usage '(index) + #:stride 4))) (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))) + (vertex-buffers (build-vertex-buffers types))) + (%make-geometry vertex-buffers index-buffer))) (define (geometry-vertex-buffer geometry type) (assq-ref (geometry-vertex-buffers geometry) type)) @@ -753,7 +425,7 @@ argument may be overridden. The following values are supported: (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))) + (bytevector-u32-native-set! (dynamic-buffer-data buffer) i j))) (define-syntax-rule (geometry-index-append! geometry i ...) (let* ((buffer (geometry-index-buffer geometry)) @@ -792,19 +464,17 @@ argument may be overridden. The following values are supported: body ... (geometry-end* geometry type) ...)) -(define (begin:map buffer-pair) - (dynamic-buffer-map! (cdr buffer-pair))) - (define (geometry-begin! geometry) + (define (begin:map buffer-pair) + (dynamic-buffer-map! (cdr buffer-pair))) (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) + (define (end:unmap buffer-pair) + (dynamic-buffer-unmap! (cdr buffer-pair))) (let ((index-buffer (geometry-index-buffer geometry))) (when index-buffer (dynamic-buffer-unmap! index-buffer)) @@ -899,8 +569,9 @@ argument may be overridden. The following values are supported: (dynamic-buffer-bounds-check dbuffer i) (case 'field ((field-name) - (field-getter (dynamic-buffer-data dbuffer - (+ (* i type-stride) field-offset)))) + (field-getter + (dynamic-buffer-data dbuffer (+ (* i type-stride) + field-offset)))) ... (else (error "unknown field" 'field))))) (define-syntax-rule (setter geometry field i x) @@ -915,13 +586,13 @@ argument may be overridden. The following values are supported: (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))) - :::))))))))))) + ((_ 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))) + :::))))))))))) |