diff options
| -rw-r--r-- | chickadee/render/particles.scm | 221 |
1 files changed, 105 insertions, 116 deletions
diff --git a/chickadee/render/particles.scm b/chickadee/render/particles.scm index 5afae81..7e79dda 100644 --- a/chickadee/render/particles.scm +++ b/chickadee/render/particles.scm @@ -77,7 +77,7 @@ indefinitely." (and life (<= life 0)))) (define-record-type <particles> - (%make-particles capacity size buffer shader vertex-array + (%make-particles capacity size bv buffer shader vertex-array texture animation-rows animation-columns speed-range acceleration-range direction-range blend-mode start-color end-color lifetime @@ -85,6 +85,7 @@ indefinitely." particles? (capacity particles-capacity) (size particles-size set-particles-size!) + (bv particles-bv) (buffer particles-buffer) (shader particles-shader) (vertex-array particles-vertex-array) @@ -285,11 +286,13 @@ default. ;; One extra element to use as ;; swap space for sorting ;; particles. - #:length (* stride (+ capacity 1)) + #:length (* stride capacity) #:stride stride #:usage 'stream))) (%make-particles capacity 0 + ;; 1 extra element as swap space for sorting. + (make-bytevector (* (+ capacity 1) stride)) buffer (make-particles-shader) (make-particles-vertex-array capacity @@ -330,121 +333,107 @@ default. (ddx-offset 16) (ddy-offset 20) (life-offset 24)) - (with-mapped-buffer buffer - (let* ((bv (buffer-data buffer)) - (stride (buffer-stride buffer)) - (current-size (particles-size particles))) - ;; Remove particles in batches since often a bunch of - ;; contiguous particles die at the same time. - (define (kill-range start end len) - (when start - (bytevector-copy! bv len - bv start - (- end start)))) - ;; Update existing particles, removing dead ones. - (let loop ((i 0) - (len (* current-size stride)) - (kill-start #f)) - (if (< i len) - (let ((life (- (int-ref bv (+ i life-offset)) 1))) - (cond - ((<= life 0) - (loop (+ i stride) (- len stride) (or kill-start i))) - (kill-start - (kill-range kill-start i len) - (loop kill-start len #f)) - (else - (let ((x (float-ref bv i)) - (y (float-ref bv (+ i y-offset))) - (dx (float-ref bv (+ i dx-offset))) - (dy (float-ref bv (+ i dy-offset))) - (ddx (float-ref bv (+ i ddx-offset))) - (ddy (float-ref bv (+ i ddy-offset)))) - (int-set! bv (+ i life-offset) life) - (float-set! bv i (+ x dx)) - (float-set! bv (+ i y-offset) (+ y dy)) - (float-set! bv (+ i dx-offset) (+ dx ddx)) - (float-set! bv (+ i dy-offset) (+ dy ddy)) - (loop (+ i stride) len #f))))) - (if kill-start + (let* ((bv (particles-bv particles)) + (stride (buffer-stride buffer)) + (capacity (particles-capacity particles))) + ;; Update existing particles, removing dead ones. + (let loop ((i 0) + (size (particles-size particles))) + (if (< i size) + (let* ((offset (* i stride)) + (life (- (int-ref bv (+ offset life-offset)) 1))) + (if (<= life 0) + (let ((new-size (- size 1))) + (bytevector-copy! bv (* new-size stride) bv offset stride) + (loop i new-size)) + (let ((x (float-ref bv offset)) + (y (float-ref bv (+ offset y-offset))) + (dx (float-ref bv (+ offset dx-offset))) + (dy (float-ref bv (+ offset dy-offset))) + (ddx (float-ref bv (+ offset ddx-offset))) + (ddy (float-ref bv (+ offset ddy-offset)))) + (int-set! bv (+ offset life-offset) life) + (float-set! bv offset (+ x dx)) + (float-set! bv (+ offset y-offset) (+ y dy)) + (float-set! bv (+ offset dx-offset) (+ dx ddx)) + (float-set! bv (+ offset dy-offset) (+ dy ddy)) + (loop (+ i 1) size)))) + (set-particles-size! particles size))) + ;; Add particles from each active emitter and then remove + ;; emitters that have completed. + (let ((sx (vec2-x speed-range)) + (sy (vec2-y speed-range)) + (ax (vec2-x acceleration-range)) + (ay (vec2-y acceleration-range)) + (dx (vec2-x direction-range)) + (dy (vec2-y direction-range)) + (emitters (particles-emitters particles))) + (define (emit emitter any-done?) + (let* ((spawn-area (particle-emitter-spawn-area emitter)) + (rate (particle-emitter-rate emitter)) + (rx (rect-x spawn-area)) + (ry (rect-y spawn-area)) + (rw (rect-width spawn-area)) + (rh (rect-height spawn-area)) + (start (particles-size particles)) + (end (min (+ start rate) capacity))) + (let loop ((i start)) + (if (< i end) + (let* ((offset (* i stride)) + (speed (+ (* (random:uniform) (- sy sx)) sx)) + (accel (+ (* (random:uniform) (- ay ax)) ax)) + (dir (+ (* (random:uniform) (- dy dx)) dx)) + (dir-x (cos dir)) + (dir-y (sin dir))) + (float-set! bv offset (+ rx (* (random:uniform) rw))) + (float-set! bv (+ offset y-offset) + (+ ry (* (random:uniform) rh))) + (float-set! bv (+ offset dx-offset) (* dir-x speed)) + (float-set! bv (+ offset dy-offset) (* dir-y speed)) + (float-set! bv (+ offset ddx-offset) (* dir-x accel)) + (float-set! bv (+ offset ddy-offset) (* dir-y accel)) + (int-set! bv (+ offset life-offset) lifetime) + (loop (+ i 1))) (begin - (kill-range kill-start len len) - (loop kill-start len #f)) - (set-particles-size! particles (/ len stride))))) - ;; Add particles from each active emitter and then remove - ;; emitters that have completed. - (let ((sx (vec2-x speed-range)) - (sy (vec2-y speed-range)) - (ax (vec2-x acceleration-range)) - (ay (vec2-y acceleration-range)) - (dx (vec2-x direction-range)) - (dy (vec2-y direction-range)) - (emitters (particles-emitters particles)) - (len (- (bytevector-length bv) stride))) - (define (emit emitter any-done?) - (let* ((size (particles-size particles)) - (spawn-area (particle-emitter-spawn-area emitter)) - (rate (particle-emitter-rate emitter)) - (rx (rect-x spawn-area)) - (ry (rect-y spawn-area)) - (rw (rect-width spawn-area)) - (rh (rect-height spawn-area)) - (start (* size stride)) - (end (min (+ start (* rate stride)) len))) - (let loop ((i start)) - (if (< i end) - (let* ((speed (+ (* (random:uniform) (- sy sx)) sx)) - (accel (+ (* (random:uniform) (- ay ax)) ax)) - (dir (+ (* (random:uniform) (- dy dx)) dx)) - (dir-x (cos dir)) - (dir-y (sin dir))) - (float-set! bv i (+ rx (* (random:uniform) rw))) - (float-set! bv (+ i y-offset) - (+ ry (* (random:uniform) rh))) - (float-set! bv (+ i dx-offset) (* dir-x speed)) - (float-set! bv (+ i dy-offset) (* dir-y speed)) - (float-set! bv (+ i ddx-offset) (* dir-x accel)) - (float-set! bv (+ i ddy-offset) (* dir-y accel)) - (int-set! bv (+ i life-offset) lifetime) - (loop (+ i stride))) - (begin - (set-particles-size! particles (/ end stride)) - (update-particle-emitter emitter) - (or any-done? (particle-emitter-done? emitter))))))) - (when (fold emit #f emitters) - (set-particles-emitters! particles - (remove particle-emitter-done? emitters)))) - ;; Sort particles. - (when sort - (let ((compare (cond - ((eq? sort 'young) - (lambda (i j) - (< (int-ref bv (+ i life-offset)) - (int-ref bv (+ j life-offset))))) - ((eq? sort 'old) - (lambda (i j) - (> (int-ref bv (+ i life-offset)) - (int-ref bv (+ j life-offset))))) - (else - (error "unknown particle sorting method" sort)))) - (tmp (* (particles-capacity particles) stride))) - (define (swap i j) - (bytevector-copy! bv i bv tmp stride) - (bytevector-copy! bv j bv i stride) - (bytevector-copy! bv tmp bv j stride)) - ;; In the benchmarks I've done, insertion sort has - ;; performed much better than quicksort here. The number - ;; of comparisons and swaps is much fewer. - (define (sort start end) - (let outer ((i (+ start stride))) - (when (< i end) - (let inner ((j i)) - (when (and (> j start) - (compare j (- j stride))) - (swap (- j stride) j) - (inner (- j stride)))) - (outer (+ i stride))))) - (sort 0 (* (particles-size particles) stride)))))))) + (set-particles-size! particles end) + (update-particle-emitter emitter) + (or any-done? (particle-emitter-done? emitter))))))) + (when (fold emit #f emitters) + (set-particles-emitters! particles + (remove particle-emitter-done? emitters)))) + ;; Sort particles. + (when sort + (let ((compare (cond + ((eq? sort 'young) + (lambda (i j) + (< (int-ref bv (+ i life-offset)) + (int-ref bv (+ j life-offset))))) + ((eq? sort 'old) + (lambda (i j) + (> (int-ref bv (+ i life-offset)) + (int-ref bv (+ j life-offset))))) + (else + (error "unknown particle sorting method" sort)))) + (tmp (* (particles-capacity particles) stride))) + (define (swap i j) + (bytevector-copy! bv i bv tmp stride) + (bytevector-copy! bv j bv i stride) + (bytevector-copy! bv tmp bv j stride)) + ;; In the benchmarks I've done, insertion sort has + ;; performed much better than quicksort here. The number + ;; of comparisons and swaps is much fewer. + (define (sort start end) + (let outer ((i (+ start stride))) + (when (< i end) + (let inner ((j i)) + (when (and (> j start) + (compare j (- j stride))) + (swap (- j stride) j) + (inner (- j stride)))) + (outer (+ i stride))))) + (sort 0 (* (particles-size particles) stride)))) + (with-mapped-buffer buffer + (bytevector-copy! bv 0 (buffer-data buffer) 0 (* (particles-size particles) stride)))))) (define draw-particles* (let ((mvp (make-null-matrix4))) |