render: particles: Fix misuse of streaming vertex buffer.
[chickadee.git] / chickadee / render / particles.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2018 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 (define-module (chickadee render particles)
19 #:use-module (rnrs bytevectors)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-4)
22 #:use-module (srfi srfi-9)
23 #:use-module (srfi srfi-9 gnu)
24 #:use-module (system foreign)
25 #:use-module (chickadee math)
26 #:use-module (chickadee math matrix)
27 #:use-module (chickadee math rect)
28 #:use-module (chickadee math vector)
29 #:use-module (chickadee render)
30 #:use-module (chickadee render buffer)
31 #:use-module (chickadee render color)
32 #:use-module (chickadee render shader)
33 #:use-module (chickadee render texture)
34 #:export (make-particle-emitter
35 particle-emitter?
36 particle-emitter-spawn-area
37 particle-emitter-rate
38 particle-emitter-life
39 particle-emitter-done?
40 make-particles
41 particles?
42 particles-capacity
43 particles-size
44 particles-texture
45 particles-blend-mode
46 particles-color
47 particles-spawn-area
48 add-particle-emitter
49 remove-particle-emitter
50 update-particles
51 draw-particles*
52 draw-particles))
53
54 (define-record-type <particle-emitter>
55 (%make-particle-emitter spawn-area rate life)
56 particle-emitter?
57 (spawn-area particle-emitter-spawn-area)
58 (rate particle-emitter-rate)
59 (life particle-emitter-life set-particle-emitter-life!))
60
61 (define* (make-particle-emitter spawn-area rate #:optional duration)
62 "Return a new particle emitter that spawns RATE particles per frame
63 within SPAWN-AREA (a rectangle or 2D vector) for DURATION frames. If
64 DURATION is not specified, the emitter will spawn particles
65 indefinitely."
66 (%make-particle-emitter spawn-area rate duration))
67
68 (define (update-particle-emitter emitter)
69 "Advance the lifecycle of EMITTER."
70 (let ((life (particle-emitter-life emitter)))
71 (when life
72 (set-particle-emitter-life! emitter (- life 1)))))
73
74 (define (particle-emitter-done? emitter)
75 "Return #t if EMITTER has finished emitting particles."
76 (let ((life (particle-emitter-life emitter)))
77 (and life (<= life 0))))
78
79 (define-record-type <particles>
80 (%make-particles capacity size bv buffer shader vertex-array
81 texture animation-rows animation-columns
82 speed-range acceleration-range direction-range
83 blend-mode start-color end-color lifetime
84 sort emitters)
85 particles?
86 (capacity particles-capacity)
87 (size particles-size set-particles-size!)
88 (bv particles-bv)
89 (buffer particles-buffer)
90 (shader particles-shader)
91 (vertex-array particles-vertex-array)
92 (texture particles-texture set-particles-texture!)
93 (animation-rows particles-animation-rows)
94 (animation-columns particles-animation-columns)
95 (speed-range particles-speed-range set-particles-speed-range!)
96 (acceleration-range particles-acceleration-range
97 set-particles-acceleration-range!)
98 (direction-range particles-direction-range set-particles-direction-range!)
99 (blend-mode particles-blend-mode set-particles-blend-mode!)
100 (start-color particles-start-color set-particles-start-color!)
101 (end-color particles-end-color set-particles-end-color!)
102 (lifetime particles-lifetime set-particles-lifetime!)
103 (sort particles-sort set-particles-sort!)
104 (emitters particles-emitters set-particles-emitters!))
105
106 (define (add-particle-emitter particles emitter)
107 "Add EMITTER to PARTICLES."
108 (set-particles-emitters! particles
109 (cons emitter (particles-emitters particles))))
110
111 (define (remove-particle-emitter particles emitter)
112 "Remove EMITTER from PARTICLES."
113 (set-particles-emitters! particles
114 (delete emitter (particles-emitters particles))))
115
116 (define (make-particles-shader)
117 (strings->shader
118 "
119 #version 130
120
121 in vec2 position;
122 in vec2 tex;
123 in vec2 offset;
124 in float life;
125 out vec2 frag_tex;
126 out float t;
127 uniform mat4 mvp;
128 uniform int lifetime;
129 uniform int animationRows;
130 uniform int animationColumns;
131
132 void main(void) {
133 t = life / lifetime;
134 int numTiles = animationRows * animationColumns;
135 int tile = int(numTiles * (1.0 - t));
136 float tx = float(tile % animationColumns) / animationColumns;
137 float ty = float(tile / animationColumns) / animationRows;
138 float tw = 1.0 / animationColumns;
139 float th = 1.0 / animationRows;
140 frag_tex = vec2(tx, ty) + tex * vec2(tw, th);
141 gl_Position = mvp * vec4(position.xy + offset, 0.0, 1.0);
142 }
143 "
144 "
145 #version 130
146
147 in vec2 frag_tex;
148 in float t;
149 uniform sampler2D color_texture;
150 uniform vec4 startColor;
151 uniform vec4 endColor;
152
153 void main (void) {
154 gl_FragColor = mix(endColor, startColor, t) * texture2D(color_texture, frag_tex);
155 }
156 "))
157
158 (define (make-particles-vertex-array capacity width height texture buffer)
159 (let* ((indices (make-buffer-view #:type 'scalar
160 #:component-type 'unsigned-int
161 #:divisor 0
162 #:buffer (make-buffer
163 (u32vector 0 3 2 0 2 1)
164 #:target 'index)))
165 (verts (make-buffer-view #:type 'vec2
166 #:component-type 'float
167 #:divisor 0
168 #:buffer (make-buffer
169 ;; TODO: use the texture
170 ;; size in pixels.
171 (let ((hw (/ width 2.0))
172 (hh (/ height 2.0)))
173 (f32vector (- hw) (- hh)
174 hw (- hh)
175 hw hh
176 (- hw) hh))
177 #:target 'vertex)))
178 (tex (make-buffer-view #:type 'vec2
179 #:component-type 'float
180 #:divisor 0
181 #:buffer (make-buffer
182 (let ((tex (texture-gl-tex-rect
183 texture)))
184 (f32vector 0 0
185 1 0
186 1 1
187 0 1))
188 #:target 'vertex)))
189 (pos (make-buffer-view #:name "particle position buffer"
190 #:buffer buffer
191 #:type 'vec2
192 #:component-type 'float
193 #:length capacity
194 #:divisor 1))
195 (life (make-buffer-view #:name "particle life remaining buffer"
196 #:buffer buffer
197 #:type 'scalar
198 #:component-type 'int
199 #:offset 24
200 #:length capacity
201 #:divisor 1)))
202 (make-vertex-array #:indices indices
203 #:attributes `((0 . ,verts)
204 (1 . ,tex)
205 (2 . ,pos)
206 (3 . ,life)))))
207
208 (define* (make-particles capacity #:key
209 (blend-mode 'alpha)
210 (start-color white)
211 (end-color (make-color 0.0 0.0 0.0 0.0))
212 (texture null-texture)
213 (animation-rows 1)
214 (animation-columns 1)
215 (width (if (texture-null? texture)
216 8.0
217 (inexact->exact
218 (floor
219 (/ (texture-width texture)
220 animation-columns)))))
221 (height (if (texture-null? texture)
222 8.0
223 (inexact->exact
224 (floor
225 (/ (texture-height texture)
226 animation-rows)))))
227 (speed-range (vec2 0.1 1.0))
228 (acceleration-range (vec2 0.0 0.1))
229 (direction-range (vec2 0.0 (* 2 pi)))
230 (lifetime 30)
231 sort)
232 "Return a new particle system that may contain up to CAPACITY
233 particles. Achieving the desired particle effect involves tweaking
234 the following keyword arguments as needed:
235
236 - BLEND-MODE: Pixel blending mode. 'alpha' by default.
237
238 - START-COLOR: The tint color of the particle at the beginning of its
239 life. White by default.
240
241 - END-COLOR: The tint color of the particle at the end of of its life.
242 Completely transparent by default for a fade-out effect. The color in
243 the middle of a particle's life will be an interpolation of
244 START-COLOR and END-COLOR.
245
246 - TEXTURE: The texture applied to the particles. The texture may be
247 subdivided into many animation frames.
248
249 - ANIMATION-ROWS: How many animation frame rows there are in the
250 texture. Default is 1.
251
252 - ANIMATION-COLUMNS: How many animation frame columns there are in the
253 texture. Default is 1.
254
255 - WIDTH: The width of each particle. By default, the width of an
256 animation frame (in pixels) is used.
257
258 - HEIGHT: The height of each particle. By default, the height of an
259 animation frame (in pixels) is used.
260
261 - SPEED-RANGE: A 2D vector containing the min and max particle speed.
262 Each particle will have a speed chosen at random from this range. By
263 default, speed ranges from 0.1 to 1.0.
264
265 - ACCELERATION-RANGE: A 2D vector containing the min and max particle
266 acceleration. Each particle will have an acceleration chosen at
267 random from this range. By default, acceleration ranges from 0.0 to
268 0.1.
269
270 - DIRECTION-RANGE: A 2D vector containing the min and max particle
271 direction as an angle in radians. Each particle will have a direction
272 chosen at random from this range. By default, the range covers all
273 possible angles.
274
275 - LIFETIME: How long each particle lives, measured in updates. 30 by
276 default.
277
278 - SORT: 'youngest' if youngest particle should be drawn last or
279 'oldest' for the reverse. By default, no sorting is applied at all."
280 (let* ((stride (+ (* 4 2) ; position - 2x f32
281 (* 4 2) ; velocity - 2x f32
282 (* 4 2) ; acceleration - 2x f32
283 4)) ; life remaining - 1x s32
284 (buffer (make-buffer #f
285 #:name "packed particle data"
286 ;; One extra element to use as
287 ;; swap space for sorting
288 ;; particles.
289 #:length (* stride capacity)
290 #:stride stride
291 #:usage 'stream)))
292 (%make-particles capacity
293 0
294 ;; 1 extra element as swap space for sorting.
295 (make-bytevector (* (+ capacity 1) stride))
296 buffer
297 (make-particles-shader)
298 (make-particles-vertex-array capacity
299 width
300 height
301 texture
302 buffer)
303 texture
304 animation-rows
305 animation-columns
306 speed-range
307 acceleration-range
308 direction-range
309 blend-mode
310 start-color
311 end-color
312 lifetime
313 sort
314 '())))
315
316 (define (update-particles particles)
317 "Advance the simulation of PARTICLES."
318 (let* ((buffer (particles-buffer particles))
319 (va (particles-vertex-array particles))
320 (pos (assq-ref (vertex-array-attributes va) 2))
321 (speed-range (particles-speed-range particles))
322 (acceleration-range (particles-acceleration-range particles))
323 (direction-range (particles-direction-range particles))
324 (sort (particles-sort particles))
325 (lifetime (particles-lifetime particles))
326 (float-ref bytevector-ieee-single-native-ref)
327 (float-set! bytevector-ieee-single-native-set!)
328 (int-ref bytevector-s32-native-ref)
329 (int-set! bytevector-s32-native-set!)
330 (y-offset 4)
331 (dx-offset 8)
332 (dy-offset 12)
333 (ddx-offset 16)
334 (ddy-offset 20)
335 (life-offset 24))
336 (let* ((bv (particles-bv particles))
337 (stride (buffer-stride buffer))
338 (capacity (particles-capacity particles)))
339 ;; Update existing particles, removing dead ones.
340 (let loop ((i 0)
341 (size (particles-size particles)))
342 (if (< i size)
343 (let* ((offset (* i stride))
344 (life (- (int-ref bv (+ offset life-offset)) 1)))
345 (if (<= life 0)
346 (let ((new-size (- size 1)))
347 (bytevector-copy! bv (* new-size stride) bv offset stride)
348 (loop i new-size))
349 (let ((x (float-ref bv offset))
350 (y (float-ref bv (+ offset y-offset)))
351 (dx (float-ref bv (+ offset dx-offset)))
352 (dy (float-ref bv (+ offset dy-offset)))
353 (ddx (float-ref bv (+ offset ddx-offset)))
354 (ddy (float-ref bv (+ offset ddy-offset))))
355 (int-set! bv (+ offset life-offset) life)
356 (float-set! bv offset (+ x dx))
357 (float-set! bv (+ offset y-offset) (+ y dy))
358 (float-set! bv (+ offset dx-offset) (+ dx ddx))
359 (float-set! bv (+ offset dy-offset) (+ dy ddy))
360 (loop (+ i 1) size))))
361 (set-particles-size! particles size)))
362 ;; Add particles from each active emitter and then remove
363 ;; emitters that have completed.
364 (let ((sx (vec2-x speed-range))
365 (sy (vec2-y speed-range))
366 (ax (vec2-x acceleration-range))
367 (ay (vec2-y acceleration-range))
368 (dx (vec2-x direction-range))
369 (dy (vec2-y direction-range))
370 (emitters (particles-emitters particles)))
371 (define (emit emitter any-done?)
372 (let* ((spawn-area (particle-emitter-spawn-area emitter))
373 (rate (particle-emitter-rate emitter))
374 (rx (rect-x spawn-area))
375 (ry (rect-y spawn-area))
376 (rw (rect-width spawn-area))
377 (rh (rect-height spawn-area))
378 (start (particles-size particles))
379 (end (min (+ start rate) capacity)))
380 (let loop ((i start))
381 (if (< i end)
382 (let* ((offset (* i stride))
383 (speed (+ (* (random:uniform) (- sy sx)) sx))
384 (accel (+ (* (random:uniform) (- ay ax)) ax))
385 (dir (+ (* (random:uniform) (- dy dx)) dx))
386 (dir-x (cos dir))
387 (dir-y (sin dir)))
388 (float-set! bv offset (+ rx (* (random:uniform) rw)))
389 (float-set! bv (+ offset y-offset)
390 (+ ry (* (random:uniform) rh)))
391 (float-set! bv (+ offset dx-offset) (* dir-x speed))
392 (float-set! bv (+ offset dy-offset) (* dir-y speed))
393 (float-set! bv (+ offset ddx-offset) (* dir-x accel))
394 (float-set! bv (+ offset ddy-offset) (* dir-y accel))
395 (int-set! bv (+ offset life-offset) lifetime)
396 (loop (+ i 1)))
397 (begin
398 (set-particles-size! particles end)
399 (update-particle-emitter emitter)
400 (or any-done? (particle-emitter-done? emitter)))))))
401 (when (fold emit #f emitters)
402 (set-particles-emitters! particles
403 (remove particle-emitter-done? emitters))))
404 ;; Sort particles.
405 (when sort
406 (let ((compare (cond
407 ((eq? sort 'young)
408 (lambda (i j)
409 (< (int-ref bv (+ i life-offset))
410 (int-ref bv (+ j life-offset)))))
411 ((eq? sort 'old)
412 (lambda (i j)
413 (> (int-ref bv (+ i life-offset))
414 (int-ref bv (+ j life-offset)))))
415 (else
416 (error "unknown particle sorting method" sort))))
417 (tmp (* (particles-capacity particles) stride)))
418 (define (swap i j)
419 (bytevector-copy! bv i bv tmp stride)
420 (bytevector-copy! bv j bv i stride)
421 (bytevector-copy! bv tmp bv j stride))
422 ;; In the benchmarks I've done, insertion sort has
423 ;; performed much better than quicksort here. The number
424 ;; of comparisons and swaps is much fewer.
425 (define (sort start end)
426 (let outer ((i (+ start stride)))
427 (when (< i end)
428 (let inner ((j i))
429 (when (and (> j start)
430 (compare j (- j stride)))
431 (swap (- j stride) j)
432 (inner (- j stride))))
433 (outer (+ i stride)))))
434 (sort 0 (* (particles-size particles) stride))))
435 (with-mapped-buffer buffer
436 (bytevector-copy! bv 0 (buffer-data buffer) 0 (* (particles-size particles) stride))))))
437
438 (define draw-particles*
439 (let ((mvp (make-null-matrix4)))
440 (lambda (particles matrix)
441 "Render PARTICLES with MATRIX applied."
442 (let ((size (particles-size particles))
443 (va (particles-vertex-array particles)))
444 (with-blend-mode (particles-blend-mode particles)
445 (with-texture 0 (particles-texture particles)
446 (gpu-apply/instanced (particles-shader particles)
447 va
448 size
449 #:mvp (if matrix
450 (begin
451 (matrix4-mult! mvp matrix
452 (current-projection))
453 mvp)
454 (current-projection))
455 #:startColor (particles-start-color particles)
456 #:endColor (particles-end-color particles)
457 #:lifetime (particles-lifetime particles)
458 #:animationRows
459 (particles-animation-rows particles)
460 #:animationColumns
461 (particles-animation-columns particles))))))))
462
463 (define (draw-particles particles)
464 "Render PARTICLES."
465 (draw-particles* particles #f))