cf0a79b49f99fbede8192013d9263cf63e74c1b4
[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-view
60 typed-buffer-offset
61 typed-buffer-component-type
62 typed-buffer-normalized?
63 typed-buffer-count
64 typed-buffer-type
65 typed-buffer-max
66 typed-buffer-min
67 typed-buffer-sparse
68 typed-buffer-data
69 typed-buffer-divisor
70 map-typed-buffer!
71 unmap-typed-buffer!
72 with-mapped-typed-buffer
73 make-vertex-array
74 vertex-array?
75 vertex-array-indices
76 vertex-array-attributes
77 vertex-array-mode
78 null-vertex-array
79 *vertex-array-state*
80 render-vertices
81 render-vertices/instanced))
82
83 ;;;
84 ;;; Buffers
85 ;;;
86
87 (define-record-type <buffer>
88 (%make-buffer id name length stride target usage data)
89 buffer?
90 (id buffer-id)
91 (name buffer-name)
92 (length buffer-length)
93 (stride buffer-stride)
94 (target buffer-target)
95 (usage buffer-usage)
96 (data buffer-data set-buffer-data!))
97
98 (set-record-type-printer! <buffer>
99 (lambda (buffer port)
100 (format port
101 "#<buffer id: ~d name: ~s usage: ~s target: ~s length: ~d stride: ~s>"
102 (buffer-id buffer)
103 (buffer-name buffer)
104 (buffer-usage buffer)
105 (buffer-target buffer)
106 (buffer-length buffer)
107 (buffer-stride buffer))))
108
109 (define null-buffer
110 (%make-buffer 0 "null" 0 0 'vertex 'static #f))
111
112 (define <<buffer>> (class-of null-buffer))
113
114 (define (free-buffer buffer)
115 (gl-delete-buffers 1 (u32vector (buffer-id buffer))))
116
117 (define-method (gpu-finalize (buffer <<buffer>>))
118 (free-buffer buffer))
119
120 (define (apply-buffer buffer)
121 (gl-bind-buffer (buffer-target-gl buffer)
122 (buffer-id buffer)))
123
124 (define *buffer-state*
125 (make-gpu-state apply-buffer null-buffer))
126
127 (define (generate-buffer-gl)
128 (let ((bv (u32vector 1)))
129 (gl-gen-buffers 1 (bytevector->pointer bv))
130 (u32vector-ref bv 0)))
131
132 (define (index-buffer? buffer)
133 "Return #t if VIEW is an index buffer view."
134 (eq? (buffer-target buffer) 'index))
135
136 (define (buffer-usage-gl buffer)
137 (match (buffer-usage buffer)
138 ('static (arb-vertex-buffer-object static-draw-arb))
139 ('stream (arb-vertex-buffer-object stream-draw-arb))))
140
141 (define (buffer-target-gl buffer)
142 (if (index-buffer? buffer)
143 (arb-vertex-buffer-object element-array-buffer-arb)
144 (arb-vertex-buffer-object array-buffer-arb)))
145
146 (define* (make-buffer data #:key
147 (name "anonymous")
148 (length (bytevector-length data))
149 (offset 0)
150 (stride 0)
151 (target 'vertex)
152 (usage 'static))
153 "Upload BV, a bytevector of TYPE elements, to the GPU as a vertex
154 buffer.
155
156 USAGE provides a hint to the GPU as to how the vertex buffer will be
157 used:
158
159 - static: The vertex buffer will not be modified after creation.
160 - stream: The vertex buffer will be modified frequently."
161 ;; Weird bugs will occur when creating a new vertex buffer while a
162 ;; vertex array is bound.
163 (gpu-state-set! *vertex-array-state* null-vertex-array)
164 (let ((buffer (gpu-guard
165 (%make-buffer (generate-buffer-gl)
166 name
167 length
168 stride
169 target
170 usage
171 #f))))
172 (gpu-state-set! *buffer-state* buffer)
173 (gl-buffer-data (buffer-target-gl buffer)
174 length
175 (if data
176 (bytevector->pointer data offset)
177 %null-pointer)
178 (buffer-usage-gl buffer))
179 (gpu-state-set! *buffer-state* null-buffer)
180 buffer))
181
182 (define* (make-streaming-buffer length #:key
183 (name "anonymous")
184 (target 'vertex))
185 "Return a new vertex buffer of LENGTH bytes, named NAME, suitable
186 for streaming data to the GPU every frame."
187 (make-buffer #f #:usage 'stream #:length length #:name name #:target target))
188
189 (define (map-buffer! buffer)
190 "Map the memory space for BUFFER from the GPU to the CPU, allowing
191 the vertex buffer to be updated with new vertex data. The
192 'unmap-buffer!' procedure must be called to submit the new
193 vertex buffer data back to the GPU."
194 (let ((target (buffer-target-gl buffer))
195 (length (buffer-length buffer))
196 (usage (buffer-usage-gl buffer)))
197 (gpu-state-set! *buffer-state* buffer)
198 (when (eq? usage 'stream)
199 ;; Orphan the buffer to avoid implicit synchronization.
200 ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification
201 (gl-buffer-data target length %null-pointer usage))
202 (let ((ptr (gl-map-buffer target (version-1-5 read-write))))
203 (set-buffer-data! buffer (pointer->bytevector ptr length)))))
204
205 (define (unmap-buffer! buffer)
206 "Return the mapped vertex buffer data for BUFFER to the GPU."
207 (gpu-state-set! *buffer-state* buffer)
208 (gl-unmap-buffer (buffer-target-gl buffer))
209 (set-buffer-data! buffer #f))
210
211 (define-syntax-rule (with-mapped-buffer buffer body ...)
212 (dynamic-wind
213 (lambda ()
214 (map-buffer! buffer))
215 (lambda () body ...)
216 (lambda ()
217 (unmap-buffer! buffer))))
218
219 \f
220 ;;;
221 ;;; Typed Buffers
222 ;;;
223
224 (define-record-type <typed-buffer>
225 (%make-typed-buffer name buffer offset component-type
226 normalized? length type max min sparse divisor)
227 typed-buffer?
228 (name typed-buffer-name)
229 (buffer typed-buffer->buffer)
230 (offset typed-buffer-offset)
231 (component-type typed-buffer-component-type)
232 (normalized? typed-buffer-normalized?)
233 (length typed-buffer-length)
234 (type typed-buffer-type)
235 (max typed-buffer-max)
236 (min typed-buffer-min)
237 (sparse typed-buffer-sparse)
238 (divisor typed-buffer-divisor)) ; for instanced rendering
239
240 (define (typed-buffer-stride typed-buffer)
241 (or (buffer-stride (typed-buffer->buffer typed-buffer))
242 (* (type-size (typed-buffer-type typed-buffer))
243 (component-type-size (typed-buffer-component-type typed-buffer)))))
244
245 (define (num-elements byte-length byte-offset type component-type)
246 (inexact->exact
247 (floor
248 (/ (- byte-length byte-offset)
249 (* (component-type-size component-type)
250 (type-size type))))))
251
252
253 (define* (make-typed-buffer #:key
254 (name "anonymous")
255 buffer
256 type
257 component-type
258 normalized?
259 (offset 0)
260 (length (num-elements (buffer-length buffer)
261 offset
262 type
263 component-type))
264 max
265 min
266 sparse
267 divisor)
268 (%make-typed-buffer name buffer offset component-type
269 normalized? length type max min sparse divisor))
270
271 (define (type-size type)
272 (match type
273 ('scalar 1)
274 ('vec2 2)
275 ('vec3 3)
276 ((or 'vec4 'mat2) 4)
277 ('mat3 9)
278 ('mat4 16)))
279
280 (define (component-type-size component-type)
281 (match component-type
282 ('byte 1)
283 ('unsigned-byte 1)
284 ('short 2)
285 ('unsigned-short 2)
286 ('int 4)
287 ('unsigned-int 4)
288 ('float 4)
289 ('double 8)))
290
291 (define* (make-streaming-typed-buffer type component-type length #:key
292 (name "anonymous")
293 (target 'vertex)
294 data
295 divisor)
296 "Return a new typed buffer to hold LENGTH elements of TYPE whose
297 components are comprised of COMPONENT-TYPE values. The underlying
298 untyped buffer is configured for GPU streaming. Optonally, a NAME can
299 be specified for the buffer. If the buffer will be used for instanced
300 rendering, the DIVISOR argument must be used to specify the rate at
301 which attributes advance when rendering multiple instances."
302 (let* ((buffer-length
303 (* length (type-size type) (component-type-size component-type)))
304 (buffer (if data
305 (make-buffer data
306 #:name name
307 #:length buffer-length
308 #:usage 'stream
309 #:target target)
310 (make-streaming-buffer buffer-length
311 #:name name
312 #:target target))))
313 (make-typed-buffer #:name name
314 #:buffer buffer
315 #:type type
316 #:component-type component-type
317 #:length length
318 #:divisor divisor)))
319
320 (define (display-typed-buffer typed-buffer port)
321 (format port "#<typed-buffer name: ~s buffer: ~a type: ~s component-type: ~s length: ~d offset: ~d>"
322 (typed-buffer-name typed-buffer)
323 (typed-buffer->buffer typed-buffer)
324 (typed-buffer-type typed-buffer)
325 (typed-buffer-component-type typed-buffer)
326 (typed-buffer-length typed-buffer)
327 (typed-buffer-offset typed-buffer)))
328
329 (set-record-type-printer! <typed-buffer> display-typed-buffer)
330
331 (define (typed-buffer-type-size typed-buffer)
332 (type-size (typed-buffer-type typed-buffer)))
333
334 (define (typed-buffer-data typed-buffer)
335 (buffer-data (typed-buffer->buffer typed-buffer)))
336
337 (define (typed-buffer-type-gl typed-buffer)
338 (match (typed-buffer-component-type typed-buffer)
339 ('byte (data-type byte))
340 ('unsigned-byte (data-type unsigned-byte))
341 ('short (data-type short))
342 ('unsigned-short (data-type unsigned-short))
343 ('int (data-type int))
344 ('unsigned-int (data-type unsigned-int))
345 ('float (data-type float))
346 ('double (data-type double))))
347
348 (define (map-typed-buffer! typed-buffer)
349 (map-buffer! (typed-buffer->buffer typed-buffer)))
350
351 (define (unmap-typed-buffer! typed-buffer)
352 (unmap-buffer! (typed-buffer->buffer typed-buffer)))
353
354 (define-syntax-rule (with-mapped-typed-buffer typed-buffer body ...)
355 (with-mapped-buffer (typed-buffer->buffer typed-buffer) body ...))
356
357 (define* (apply-typed-buffer typed-buffer #:optional attribute-index)
358 (gpu-state-set! *buffer-state* (typed-buffer->buffer typed-buffer))
359 ;; If there is no attribute-index, we assume this is being bound for
360 ;; use as an index buffer.
361 (when attribute-index
362 (gl-enable-vertex-attrib-array attribute-index)
363 (gl-vertex-attrib-pointer attribute-index
364 (typed-buffer-type-size typed-buffer)
365 (typed-buffer-type-gl typed-buffer)
366 (typed-buffer-normalized? typed-buffer)
367 (typed-buffer-stride typed-buffer)
368 (make-pointer (typed-buffer-offset typed-buffer)))
369 (let ((divisor (typed-buffer-divisor typed-buffer)))
370 (when divisor
371 (gl-vertex-attrib-divisor attribute-index divisor)))))
372
373 ;; TODO: Handle 4-byte alignment rule for the types that need it.
374 (define (typed-buffer->vector typed-buffer)
375 (define (component-parser type)
376 (match type
377 ('byte bytevector-s8-ref)
378 ('unsigned-byte bytevector-u8-ref)
379 ('short
380 (lambda (bv i)
381 (bytevector-s16-ref bv i (native-endianness))))
382 ('unsigned-short
383 (lambda (bv i)
384 (bytevector-u16-ref bv i (native-endianness))))
385 ('unsigned-int
386 (lambda (bv i)
387 (bytevector-u32-ref bv i (native-endianness))))
388 ('float bytevector-ieee-single-native-ref)))
389 (define (element-parser type component-type)
390 (let ((parse-component (component-parser component-type))
391 (component-type-size (component-type-size component-type)))
392 (match type
393 ('scalar parse-component)
394 ('vec2
395 (lambda (bv i)
396 (vec2 (parse-component bv i)
397 (parse-component bv (+ i component-type-size)))))
398 ('vec3
399 (lambda (bv i)
400 (vec3 (parse-component bv i)
401 (parse-component bv (+ i component-type-size))
402 (parse-component bv (+ i (* component-type-size 2))))))
403 ;; TODO: Use a proper vec4 type when it exists.
404 ('vec4
405 (lambda (bv i)
406 (vector (parse-component bv i)
407 (parse-component bv (+ i component-type-size))
408 (parse-component bv (+ i (* component-type-size 2)))
409 (parse-component bv (+ i (* component-type-size 3))))))
410 ;; TODO: Use proper matrix2 type when it exists.
411 ('mat2
412 (lambda (bv i)
413 (vector (vector (parse-component bv i)
414 (parse-component bv (+ i component-type-size)))
415 (vector (parse-component bv (+ i (* component-type-size 2)))
416 (parse-component bv (+ i (* component-type-size 3)))))))
417 ;; TODO: Use proper matrix3 type when it exists.
418 ('mat3
419 (lambda (bv i)
420 (vector (vector (parse-component bv i)
421 (parse-component bv (+ i component-type-size))
422 (parse-component bv (+ i (* component-type-size 2))))
423 (vector (parse-component bv (+ i (* component-type-size 3)))
424 (parse-component bv (+ i (* component-type-size 4)))
425 (parse-component bv (+ i (* component-type-size 5)))))))
426 ('mat4
427 (lambda (bv i)
428 (make-matrix4 (parse-component bv i)
429 (parse-component bv (+ i component-type-size))
430 (parse-component bv (+ i (* component-type-size 2)))
431 (parse-component bv (+ i (* component-type-size 3)))
432 (parse-component bv (+ i (* component-type-size 4)))
433 (parse-component bv (+ i (* component-type-size 5)))
434 (parse-component bv (+ i (* component-type-size 6)))
435 (parse-component bv (+ i (* component-type-size 7)))
436 (parse-component bv (+ i (* component-type-size 8)))
437 (parse-component bv (+ i (* component-type-size 9)))
438 (parse-component bv (+ i (* component-type-size 10)))
439 (parse-component bv (+ i (* component-type-size 11)))
440 (parse-component bv (+ i (* component-type-size 12)))
441 (parse-component bv (+ i (* component-type-size 13)))
442 (parse-component bv (+ i (* component-type-size 14)))
443 (parse-component bv (+ i (* component-type-size 15)))))))))
444 (with-mapped-typed-buffer typed-buffer
445 (let* ((data (typed-buffer-data typed-buffer))
446 (length (typed-buffer-length typed-buffer))
447 (offset (typed-buffer-offset typed-buffer))
448 (stride (typed-buffer-stride typed-buffer))
449 (type (typed-buffer-type typed-buffer))
450 (component-type (typed-buffer-component-type typed-buffer))
451 (type-byte-size (* (type-size type)
452 (component-type-size component-type)))
453 (v (make-vector length))
454 (parse-element (element-parser type component-type)))
455 (let loop ((i 0))
456 (when (< i length)
457 (let ((byte-index (+ (* i stride) offset)))
458 (vector-set! v i (parse-element data byte-index)))
459 (loop (+ i 1))))
460 v)))
461
462 \f
463 ;;;
464 ;;; Vertex Arrays
465 ;;;
466
467 (define-record-type <vertex-array>
468 (%make-vertex-array id indices attributes mode)
469 vertex-array?
470 (id vertex-array-id)
471 (indices vertex-array-indices)
472 (attributes vertex-array-attributes)
473 (mode vertex-array-mode))
474
475 (set-record-type-printer! <vertex-array>
476 (lambda (array port)
477 (format port
478 "#<vertex-array indices: ~a attributes: ~a mode: ~s>"
479 (vertex-array-indices array)
480 (vertex-array-attributes array)
481 (vertex-array-mode array))))
482
483 (define null-vertex-array (%make-vertex-array 0 #f '() 'triangles))
484
485 (define <<vertex-array>> (class-of null-vertex-array))
486
487 (define (generate-vertex-array)
488 (let ((bv (u32vector 1)))
489 (gl-gen-vertex-arrays 1 (bytevector->pointer bv))
490 (u32vector-ref bv 0)))
491
492 (define (free-vertex-array va)
493 (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va))))
494
495 (define-method (gpu-finalize (va <<vertex-array>>))
496 (free-vertex-array va))
497
498 (define (apply-vertex-array va)
499 (gl-bind-vertex-array (vertex-array-id va)))
500
501 (define *vertex-array-state*
502 (make-gpu-state apply-vertex-array null-vertex-array))
503
504 (define* (make-vertex-array #:key indices attributes (mode 'triangles))
505 (let ((array (gpu-guard
506 (%make-vertex-array (generate-vertex-array)
507 indices
508 attributes
509 mode))))
510 (gpu-state-set! *vertex-array-state* array)
511 (for-each (match-lambda
512 ((index . typed-buffer)
513 (apply-typed-buffer typed-buffer index)))
514 attributes)
515 (apply-typed-buffer indices)
516 (gpu-state-set! *vertex-array-state* null-vertex-array)
517 array))
518
519 (define (vertex-array-mode-gl array)
520 (match (vertex-array-mode array)
521 ('points (begin-mode points))
522 ('lines (begin-mode lines))
523 ('line-loop (begin-mode line-loop))
524 ('line-strip (begin-mode line-strip))
525 ('triangles (begin-mode triangles))
526 ('triangle-strip (begin-mode triangle-strip))
527 ('triangle-fan (begin-mode triangle-fan))))
528
529 (define* (render-vertices array #:optional count)
530 (gpu-state-set! *vertex-array-state* array)
531 (let ((indices (vertex-array-indices array)))
532 (gl-draw-elements (vertex-array-mode-gl array)
533 (or count
534 (typed-buffer-length indices))
535 (typed-buffer-type-gl indices)
536 %null-pointer)))
537
538 (define* (render-vertices/instanced array instances #:optional count)
539 (gpu-state-set! *vertex-array-state* array)
540 (let ((indices (vertex-array-indices array)))
541 (gl-draw-elements-instanced (vertex-array-mode-gl array)
542 (or count
543 (typed-buffer-length indices))
544 (typed-buffer-type-gl indices)
545 %null-pointer
546 instances)))