702423b735ab1eed40ae26df441cf998e99801d7
[chickadee.git] / chickadee / render / buffer.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2016, 2017 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Chickadee is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published
6 ;;; by the Free Software Foundation, either version 3 of the License,
7 ;;; or (at your option) any later version.
8 ;;;
9 ;;; Chickadee is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; GPU data buffers.
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee render buffer)
25 #:use-module (ice-9 format)
26 #:use-module (ice-9 match)
27 #:use-module (oop goops)
28 #:use-module (rnrs bytevectors)
29 #:use-module (srfi srfi-4)
30 #:use-module (srfi srfi-9)
31 #:use-module (srfi srfi-9 gnu)
32 #:use-module (gl)
33 #:use-module (system foreign)
34 #:use-module (chickadee math matrix)
35 #:use-module (chickadee math vector)
36 #:use-module (chickadee render gl)
37 #:use-module (chickadee render gpu)
38 #:export (make-buffer
39 make-streaming-buffer
40 buffer?
41 index-buffer?
42 buffer-name
43 buffer-length
44 buffer-stride
45 buffer-target
46 buffer-usage
47 buffer-data
48 null-buffer
49 map-buffer!
50 unmap-buffer!
51 with-mapped-buffer
52 *buffer-state*
53 make-typed-buffer
54 make-streaming-typed-buffer
55 typed-buffer?
56 typed-buffer->buffer
57 typed-buffer->vector
58 typed-buffer-name
59 typed-buffer-offset
60 typed-buffer-component-type
61 typed-buffer-normalized?
62 typed-buffer-count
63 typed-buffer-type
64 typed-buffer-max
65 typed-buffer-min
66 typed-buffer-sparse
67 typed-buffer-data
68 typed-buffer-divisor
69 map-typed-buffer!
70 unmap-typed-buffer!
71 with-mapped-typed-buffer
72 make-vertex-array
73 vertex-array?
74 vertex-array-indices
75 vertex-array-attributes
76 vertex-array-mode
77 null-vertex-array
78 *vertex-array-state*
79 render-vertices
80 render-vertices/instanced))
81
82 ;;;
83 ;;; Buffers
84 ;;;
85
86 (define-record-type <buffer>
87 (%make-buffer id name length stride target usage data)
88 buffer?
89 (id buffer-id)
90 (name buffer-name)
91 (length buffer-length)
92 (stride buffer-stride)
93 (target buffer-target)
94 (usage buffer-usage)
95 (data buffer-data set-buffer-data!))
96
97 (set-record-type-printer! <buffer>
98 (lambda (buffer port)
99 (format port
100 "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
101 (buffer-id buffer)
102 (buffer-name buffer)
103 (buffer-usage buffer)
104 (buffer-target buffer)
105 (buffer-length buffer)
106 (buffer-stride buffer))))
107
108 (define null-buffer
109 (%make-buffer 0 "null" 0 0 'vertex 'static #f))
110
111 (define <<buffer>> (class-of null-buffer))
112
113 (define (free-buffer buffer)
114 (gl-delete-buffers 1 (u32vector (buffer-id buffer))))
115
116 (define-method (gpu-finalize (buffer <<buffer>>))
117 (free-buffer buffer))
118
119 (define (apply-buffer buffer)
120 (gl-bind-buffer (buffer-target-gl buffer)
121 (buffer-id buffer)))
122
123 (define *buffer-state*
124 (make-gpu-state apply-buffer null-buffer))
125
126 (define (generate-buffer-gl)
127 (let ((bv (u32vector 1)))
128 (gl-gen-buffers 1 (bytevector->pointer bv))
129 (u32vector-ref bv 0)))
130
131 (define (index-buffer? buffer)
132 "Return #t if VIEW is an index buffer view."
133 (eq? (buffer-target buffer) 'index))
134
135 (define (buffer-usage-gl buffer)
136 (match (buffer-usage buffer)
137 ('static (arb-vertex-buffer-object static-draw-arb))
138 ('stream (arb-vertex-buffer-object stream-draw-arb))))
139
140 (define (buffer-target-gl buffer)
141 (if (index-buffer? buffer)
142 (arb-vertex-buffer-object element-array-buffer-arb)
143 (arb-vertex-buffer-object array-buffer-arb)))
144
145 (define* (make-buffer data #:key
146 (name "anonymous")
147 (length (bytevector-length data))
148 (offset 0)
149 (stride 0)
150 (target 'vertex)
151 (usage 'static))
152 "Upload DATA, a bytevector, to the GPU. By default, the entire
153 bytevector is uploaded. A subset of the data may be uploaded by
154 specifying the OFFSET, the index of the first byte to be uploaded, and
155 LENGTH, the number of bytes to upload.
156
157 If DATA is #f, allocate LENGTH bytes of fresh GPU memory instead.
158
159 TARGET and USAGE are hints that tell the GPU how the buffer is
160 intended to be used.
161
162 TARGET may be:
163 - vertex: Vertex attribute data.
164 - index: Index buffer data.
165
166 USAGE may be:
167 - static: The buffer data will not be modified after creation.
168 - stream: The buffer data will be modified frequently.
169
170 NAME is simply an arbitrary string for debugging purposes that is
171 never sent to the GPU."
172 ;; Weird bugs will occur when creating a new vertex buffer while a
173 ;; vertex array is bound.
174 (gpu-state-set! *vertex-array-state* null-vertex-array)
175 (let ((buffer (gpu-guard
176 (%make-buffer (generate-buffer-gl)
177 name
178 length
179 stride
180 target
181 usage
182 #f))))
183 (gpu-state-set! *buffer-state* buffer)
184 (gl-buffer-data (buffer-target-gl buffer)
185 length
186 (if data
187 (bytevector->pointer data offset)
188 %null-pointer)
189 (buffer-usage-gl buffer))
190 (gpu-state-set! *buffer-state* null-buffer)
191 buffer))
192
193 (define* (make-streaming-buffer length #:key
194 (name "anonymous")
195 (target 'vertex))
196 "Return a new vertex buffer of LENGTH bytes, named NAME, suitable
197 for streaming data to the GPU every frame."
198 (make-buffer #f #:usage 'stream #:length length #:name name #:target target))
199
200 (define (map-buffer! buffer)
201 "Map the memory space for BUFFER from the GPU to the CPU, allowing
202 the vertex buffer to be updated with new vertex data. The
203 'unmap-buffer!' procedure must be called to submit the new
204 vertex buffer data back to the GPU."
205 (let ((target (buffer-target-gl buffer))
206 (length (buffer-length buffer))
207 (usage (buffer-usage-gl buffer)))
208 (gpu-state-set! *buffer-state* buffer)
209 (when (eq? usage 'stream)
210 ;; Orphan the buffer to avoid implicit synchronization.
211 ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
212 (gl-buffer-data target length %null-pointer usage))
213 (let ((ptr (gl-map-buffer target (version-1-5 read-write))))
214 (set-buffer-data! buffer (pointer->bytevector ptr length)))))
215
216 (define (unmap-buffer! buffer)
217 "Return the mapped vertex buffer data for BUFFER to the GPU."
218 (gpu-state-set! *buffer-state* buffer)
219 (gl-unmap-buffer (buffer-target-gl buffer))
220 (set-buffer-data! buffer #f))
221
222 (define-syntax-rule (with-mapped-buffer buffer body ...)
223 (dynamic-wind
224 (lambda ()
225 (map-buffer! buffer))
226 (lambda () body ...)
227 (lambda ()
228 (unmap-buffer! buffer))))
229
230 \f
231 ;;;
232 ;;; Typed Buffers
233 ;;;
234
235 (define-record-type <typed-buffer>
236 (%make-typed-buffer name buffer offset component-type
237 normalized? length type max min sparse divisor)
238 typed-buffer?
239 (name typed-buffer-name)
240 (buffer typed-buffer->buffer)
241 (offset typed-buffer-offset)
242 (component-type typed-buffer-component-type)
243 (normalized? typed-buffer-normalized?)
244 (length typed-buffer-length)
245 (type typed-buffer-type)
246 (max typed-buffer-max)
247 (min typed-buffer-min)
248 (sparse typed-buffer-sparse)
249 (divisor typed-buffer-divisor)) ; for instanced rendering
250
251 (define (typed-buffer-stride typed-buffer)
252 (or (buffer-stride (typed-buffer->buffer typed-buffer))
253 (* (type-size (typed-buffer-type typed-buffer))
254 (component-type-size (typed-buffer-component-type typed-buffer)))))
255
256 (define (num-elements byte-length byte-offset type component-type)
257 (inexact->exact
258 (floor
259 (/ (- byte-length byte-offset)
260 (* (component-type-size component-type)
261 (type-size type))))))
262
263
264 (define* (make-typed-buffer #:key
265 (name "anonymous")
266 buffer
267 type
268 component-type
269 normalized?
270 (offset 0)
271 (length (num-elements (buffer-length buffer)
272 offset
273 type
274 component-type))
275 max
276 min
277 sparse
278 divisor)
279 "Return a new typed buffer view for BUFFER starting at byte index
280 OFFSET of LENGTH elements, where each element is of TYPE and composed
281 of COMPONENT-TYPE values.
282
283 Valid values for TYPE are:
284 - scalar: single number
285 - vec2: 2D vector
286 - vec3: 3D vector
287 - vec4: 4D vector
288 - mat2: 2x2 matrix
289 - mat3: 3x3 matrix
290 - mat4: 4x4 matrix
291
292 Valid values for COMPONENT-TYPE are:
293
294 - byte
295 - unsigned-byte
296 - short
297 - unsigned-short
298 - int
299 - unsigned-int
300 - float
301 - double
302
303 DIVISOR is only needed for instanced rendering applications and
304 represents how many instances each vertex element applies to. A
305 divisor of 0 means that a single element is used for every instance
306 and is used for the data being instanced. A divisor of 1 means that
307 each element is used for 1 instance. A divisor of 2 means that each
308 element is used for 2 instances, and so on."
309 (%make-typed-buffer name buffer offset component-type
310 normalized? length type max min sparse divisor))
311
312 (define (type-size type)
313 (match type
314 ('scalar 1)
315 ('vec2 2)
316 ('vec3 3)
317 ((or 'vec4 'mat2) 4)
318 ('mat3 9)
319 ('mat4 16)))
320
321 (define (component-type-size component-type)
322 (match component-type
323 ('byte 1)
324 ('unsigned-byte 1)
325 ('short 2)
326 ('unsigned-short 2)
327 ('int 4)
328 ('unsigned-int 4)
329 ('float 4)
330 ('double 8)))
331
332 (define* (make-streaming-typed-buffer type component-type length #:key
333 (name "anonymous")
334 (target 'vertex)
335 data
336 divisor)
337 "Return a new typed buffer to hold LENGTH elements of TYPE whose
338 components are comprised of COMPONENT-TYPE values. The underlying
339 untyped buffer is configured for GPU streaming. Optonally, a NAME can
340 be specified for the buffer. If the buffer will be used for instanced
341 rendering, the DIVISOR argument must be used to specify the rate at
342 which attributes advance when rendering multiple instances."
343 (let* ((buffer-length
344 (* length (type-size type) (component-type-size component-type)))
345 (buffer (if data
346 (make-buffer data
347 #:name name
348 #:length buffer-length
349 #:usage 'stream
350 #:target target)
351 (make-streaming-buffer buffer-length
352 #:name name
353 #:target target))))
354 (make-typed-buffer #:name name
355 #:buffer buffer
356 #:type type
357 #:component-type component-type
358 #:length length
359 #:divisor divisor)))
360
361 (define (display-typed-buffer typed-buffer port)
362 (format port "#<typed-buffer name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d>"
363 (typed-buffer-name typed-buffer)
364 (typed-buffer->buffer typed-buffer)
365 (typed-buffer-type typed-buffer)
366 (typed-buffer-component-type typed-buffer)
367 (typed-buffer-length typed-buffer)
368 (typed-buffer-offset typed-buffer)))
369
370 (set-record-type-printer! <typed-buffer> display-typed-buffer)
371
372 (define (typed-buffer-type-size typed-buffer)
373 (type-size (typed-buffer-type typed-buffer)))
374
375 (define (typed-buffer-data typed-buffer)
376 (buffer-data (typed-buffer->buffer typed-buffer)))
377
378 (define (typed-buffer-type-gl typed-buffer)
379 (match (typed-buffer-component-type typed-buffer)
380 ('byte (data-type byte))
381 ('unsigned-byte (data-type unsigned-byte))
382 ('short (data-type short))
383 ('unsigned-short (data-type unsigned-short))
384 ('int (data-type int))
385 ('unsigned-int (data-type unsigned-int))
386 ('float (data-type float))
387 ('double (data-type double))))
388
389 (define (map-typed-buffer! typed-buffer)
390 (map-buffer! (typed-buffer->buffer typed-buffer)))
391
392 (define (unmap-typed-buffer! typed-buffer)
393 (unmap-buffer! (typed-buffer->buffer typed-buffer)))
394
395 (define-syntax-rule (with-mapped-typed-buffer typed-buffer body ...)
396 (with-mapped-buffer (typed-buffer->buffer typed-buffer) body ...))
397
398 (define* (apply-typed-buffer typed-buffer #:optional attribute-index)
399 (gpu-state-set! *buffer-state* (typed-buffer->buffer typed-buffer))
400 ;; If there is no attribute-index, we assume this is being bound for
401 ;; use as an index buffer.
402 (when attribute-index
403 (gl-enable-vertex-attrib-array attribute-index)
404 (gl-vertex-attrib-pointer attribute-index
405 (typed-buffer-type-size typed-buffer)
406 (typed-buffer-type-gl typed-buffer)
407 (typed-buffer-normalized? typed-buffer)
408 (typed-buffer-stride typed-buffer)
409 (make-pointer (typed-buffer-offset typed-buffer)))
410 (let ((divisor (typed-buffer-divisor typed-buffer)))
411 (when divisor
412 (gl-vertex-attrib-divisor attribute-index divisor)))))
413
414 ;; TODO: Handle 4-byte alignment rule for the types that need it.
415 (define (typed-buffer->vector typed-buffer)
416 (define (component-parser type)
417 (match type
418 ('byte bytevector-s8-ref)
419 ('unsigned-byte bytevector-u8-ref)
420 ('short
421 (lambda (bv i)
422 (bytevector-s16-ref bv i (native-endianness))))
423 ('unsigned-short
424 (lambda (bv i)
425 (bytevector-u16-ref bv i (native-endianness))))
426 ('unsigned-int
427 (lambda (bv i)
428 (bytevector-u32-ref bv i (native-endianness))))
429 ('float bytevector-ieee-single-native-ref)))
430 (define (element-parser type component-type)
431 (let ((parse-component (component-parser component-type))
432 (component-type-size (component-type-size component-type)))
433 (match type
434 ('scalar parse-component)
435 ('vec2
436 (lambda (bv i)
437 (vec2 (parse-component bv i)
438 (parse-component bv (+ i component-type-size)))))
439 ('vec3
440 (lambda (bv i)
441 (vec3 (parse-component bv i)
442 (parse-component bv (+ i component-type-size))
443 (parse-component bv (+ i (* component-type-size 2))))))
444 ;; TODO: Use a proper vec4 type when it exists.
445 ('vec4
446 (lambda (bv i)
447 (vector (parse-component bv i)
448 (parse-component bv (+ i component-type-size))
449 (parse-component bv (+ i (* component-type-size 2)))
450 (parse-component bv (+ i (* component-type-size 3))))))
451 ;; TODO: Use proper matrix2 type when it exists.
452 ('mat2
453 (lambda (bv i)
454 (vector (vector (parse-component bv i)
455 (parse-component bv (+ i component-type-size)))
456 (vector (parse-component bv (+ i (* component-type-size 2)))
457 (parse-component bv (+ i (* component-type-size 3)))))))
458 ;; TODO: Use proper matrix3 type when it exists.
459 ('mat3
460 (lambda (bv i)
461 (vector (vector (parse-component bv i)
462 (parse-component bv (+ i component-type-size))
463 (parse-component bv (+ i (* component-type-size 2))))
464 (vector (parse-component bv (+ i (* component-type-size 3)))
465 (parse-component bv (+ i (* component-type-size 4)))
466 (parse-component bv (+ i (* component-type-size 5)))))))
467 ('mat4
468 (lambda (bv i)
469 (make-matrix4 (parse-component bv i)
470 (parse-component bv (+ i component-type-size))
471 (parse-component bv (+ i (* component-type-size 2)))
472 (parse-component bv (+ i (* component-type-size 3)))
473 (parse-component bv (+ i (* component-type-size 4)))
474 (parse-component bv (+ i (* component-type-size 5)))
475 (parse-component bv (+ i (* component-type-size 6)))
476 (parse-component bv (+ i (* component-type-size 7)))
477 (parse-component bv (+ i (* component-type-size 8)))
478 (parse-component bv (+ i (* component-type-size 9)))
479 (parse-component bv (+ i (* component-type-size 10)))
480 (parse-component bv (+ i (* component-type-size 11)))
481 (parse-component bv (+ i (* component-type-size 12)))
482 (parse-component bv (+ i (* component-type-size 13)))
483 (parse-component bv (+ i (* component-type-size 14)))
484 (parse-component bv (+ i (* component-type-size 15)))))))))
485 (with-mapped-typed-buffer typed-buffer
486 (let* ((data (typed-buffer-data typed-buffer))
487 (length (typed-buffer-length typed-buffer))
488 (offset (typed-buffer-offset typed-buffer))
489 (stride (typed-buffer-stride typed-buffer))
490 (type (typed-buffer-type typed-buffer))
491 (component-type (typed-buffer-component-type typed-buffer))
492 (type-byte-size (* (type-size type)
493 (component-type-size component-type)))
494 (v (make-vector length))
495 (parse-element (element-parser type component-type)))
496 (let loop ((i 0))
497 (when (< i length)
498 (let ((byte-index (+ (* i stride) offset)))
499 (vector-set! v i (parse-element data byte-index)))
500 (loop (+ i 1))))
501 v)))
502
503 \f
504 ;;;
505 ;;; Vertex Arrays
506 ;;;
507
508 (define-record-type <vertex-array>
509 (%make-vertex-array id indices attributes mode)
510 vertex-array?
511 (id vertex-array-id)
512 (indices vertex-array-indices)
513 (attributes vertex-array-attributes)
514 (mode vertex-array-mode))
515
516 (set-record-type-printer! <vertex-array>
517 (lambda (array port)
518 (format port
519 "#<vertex-array indices: ~a attributes: ~a mode: ~s>"
520 (vertex-array-indices array)
521 (vertex-array-attributes array)
522 (vertex-array-mode array))))
523
524 (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
525
526 (define <<vertex-array>> (class-of null-vertex-array))
527
528 (define (generate-vertex-array)
529 (let ((bv (u32vector 1)))
530 (gl-gen-vertex-arrays 1 (bytevector->pointer bv))
531 (u32vector-ref bv 0)))
532
533 (define (free-vertex-array va)
534 (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))
535
536 (define-method (gpu-finalize (va <<vertex-array>>))
537 (free-vertex-array va))
538
539 (define (apply-vertex-array va)
540 (gl-bind-vertex-array (vertex-array-id va)))
541
542 (define *vertex-array-state*
543 (make-gpu-state apply-vertex-array null-vertex-array))
544
545 (define* (make-vertex-array #:key indices attributes (mode 'triangles))
546 "Return a new vertex array using the index data within the typed
547 buffer INDICES and the vertex attribute data within ATTRIBUTES, an
548 alist mapping shader attribute indices to typed buffers containing
549 vertex data.
550
551 By default, the vertex array is interpreted as containing a series of
552 triangles. If another primtive type is desired, the MODE keyword
553 argument may be overridden. The following values are supported:
554
555 - points
556 - lines
557 - line-loop
558 - line-strip
559 - triangles
560 - triangle-strip
561 - triangle-fan"
562 (let ((array (gpu-guard
563 (%make-vertex-array (generate-vertex-array)
564 indices
565 attributes
566 mode))))
567 (gpu-state-set! *vertex-array-state* array)
568 (for-each (match-lambda
569 ((index . typed-buffer)
570 (apply-typed-buffer typed-buffer index)))
571 attributes)
572 (apply-typed-buffer indices)
573 (gpu-state-set! *vertex-array-state* null-vertex-array)
574 array))
575
576 (define (vertex-array-mode-gl array)
577 (match (vertex-array-mode array)
578 ('points (begin-mode points))
579 ('lines (begin-mode lines))
580 ('line-loop (begin-mode line-loop))
581 ('line-strip (begin-mode line-strip))
582 ('triangles (begin-mode triangles))
583 ('triangle-strip (begin-mode triangle-strip))
584 ('triangle-fan (begin-mode triangle-fan))))
585
586 (define* (render-vertices array #:optional count)
587 (gpu-state-set! *vertex-array-state* array)
588 (let ((indices (vertex-array-indices array)))
589 (gl-draw-elements (vertex-array-mode-gl array)
590 (or count
591 (typed-buffer-length indices))
592 (typed-buffer-type-gl indices)
593 %null-pointer)))
594
595 (define* (render-vertices/instanced array instances #:optional count)
596 (gpu-state-set! *vertex-array-state* array)
597 (let ((indices (vertex-array-indices array)))
598 (gl-draw-elements-instanced (vertex-array-mode-gl array)
599 (or count
600 (typed-buffer-length indices))
601 (typed-buffer-type-gl indices)
602 %null-pointer
603 instances)))