render: particles: Fix keyword argument names for gpu-apply call.
[chickadee.git] / chickadee / render / particles.scm
CommitLineData
5dbd832c
DT
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
63within SPAWN-AREA (a rectangle or 2D vector) for DURATION frames. If
64DURATION is not specified, the emitter will spawn particles
65indefinitely."
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>
50d0f677 80 (%make-particles capacity size bv buffer shader vertex-array
5dbd832c
DT
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!)
50d0f677 88 (bv particles-bv)
5dbd832c
DT
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
121in vec2 position;
122in vec2 tex;
123in vec2 offset;
124in float life;
125out vec2 frag_tex;
126out float t;
127uniform mat4 mvp;
128uniform int lifetime;
129uniform int animationRows;
130uniform int animationColumns;
131
132void 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
147in vec2 frag_tex;
148in float t;
149uniform sampler2D color_texture;
150uniform vec4 startColor;
151uniform vec4 endColor;
152
153void 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)
d50b4239
DT
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"
5dbd832c 196 #:buffer buffer
d50b4239
DT
197 #:type 'scalar
198 #:component-type 'int
199 #:offset 24
5dbd832c 200 #:length capacity
d50b4239 201 #:divisor 1)))
5dbd832c
DT
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
233particles. Achieving the desired particle effect involves tweaking
234the 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
239life. White by default.
240
241- END-COLOR: The tint color of the particle at the end of of its life.
242Completely transparent by default for a fade-out effect. The color in
243the middle of a particle's life will be an interpolation of
244START-COLOR and END-COLOR.
245
246- TEXTURE: The texture applied to the particles. The texture may be
247subdivided into many animation frames.
248
249- ANIMATION-ROWS: How many animation frame rows there are in the
250texture. Default is 1.
251
252- ANIMATION-COLUMNS: How many animation frame columns there are in the
253texture. Default is 1.
254
255- WIDTH: The width of each particle. By default, the width of an
256animation frame (in pixels) is used.
257
258- HEIGHT: The height of each particle. By default, the height of an
259animation frame (in pixels) is used.
260
261- SPEED-RANGE: A 2D vector containing the min and max particle speed.
262Each particle will have a speed chosen at random from this range. By
263default, speed ranges from 0.1 to 1.0.
264
265- ACCELERATION-RANGE: A 2D vector containing the min and max particle
266acceleration. Each particle will have an acceleration chosen at
267random from this range. By default, acceleration ranges from 0.0 to
2680.1.
269
270- DIRECTION-RANGE: A 2D vector containing the min and max particle
271direction as an angle in radians. Each particle will have a direction
272chosen at random from this range. By default, the range covers all
273possible angles.
274
275- LIFETIME: How long each particle lives, measured in updates. 30 by
276default.
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.
50d0f677 289 #:length (* stride capacity)
5dbd832c
DT
290 #:stride stride
291 #:usage 'stream)))
292 (%make-particles capacity
293 0
50d0f677
DT
294 ;; 1 extra element as swap space for sorting.
295 (make-bytevector (* (+ capacity 1) stride))
5dbd832c
DT
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))
50d0f677
DT
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)))
5dbd832c 397 (begin
50d0f677
DT
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))))))
5dbd832c
DT
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))
624ac6f5
DT
455 #:start-color (particles-start-color particles)
456 #:end-color (particles-end-color particles)
5dbd832c 457 #:lifetime (particles-lifetime particles)
624ac6f5 458 #:animation-rows
5dbd832c 459 (particles-animation-rows particles)
624ac6f5 460 #:animation-columns
5dbd832c
DT
461 (particles-animation-columns particles))))))))
462
463(define (draw-particles particles)
464 "Render PARTICLES."
465 (draw-particles* particles #f))