render: particles: Fix misuse of streaming vertex buffer.

* chickadee/render/particles.scm (update-particles): Use a dedicated
  bytevector for storing the state of the particles and copy it over
  to the GPU at the end.

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)))