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