1 files changed, 113 insertions, 0 deletions
diff --git a/strigoform/particles.scm b/strigoform/particles.scm
new file mode 100644
index 0000000..ad21bc0
--- /dev/null
+++ b/strigoform/particles.scm
@@ -0,0 +1,113 @@
+(library (strigoform particles)
+  (export make-particle-pool
+          particle-pool?
+          particle-pool-add!
+          particle-pool-reset!
+          particle-pool-update!
+          draw-particles
+          explode)
+  (import (scheme base)
+          (scheme inexact)
+          (hoot match)
+          (strigoform canvas)
+          (strigoform math)
+          (strigoform type))
+
+  (define-type particle-pool
+    %make-particle-pool
+    particle-pool?
+    (length particle-pool-length set-particle-pool-length!)
+    (capacity particle-pool-capacity set-particle-pool-capacity!)
+    (image particle-pool-image set-particle-pool-image!)
+    (ticks particle-pool-ticks set-particle-pool-ticks!)
+    (particles particle-pool-particles set-particle-pool-particles!))
+
+  ;; per particle: spawn-time, lifespan, tile-x, x, y, dx, dy
+  (define %particle-size (+ 4 4 8 8 8 8 8))
+  (define particle-tile-width 8.0)
+  (define particle-tile-height 8.0)
+
+  (define (make-particle-pool capacity image)
+    (let ((particles (make-bytevector (* capacity %particle-size))))
+      (%make-particle-pool 0 capacity image 0 particles)))
+
+  (define (particle-pool-offset i)
+    (* i %particle-size))
+
+  (define (particle-pool-add! pool type lifespan x y dx dy)
+    (match pool
+      (#('particle-pool length capacity image ticks particles)
+       (let ((offset (particle-pool-offset length))
+             (tx (* (match type
+                      ('muzzle-flash 0.0)
+                      ('explosion 1.0)
+                      ('hit-wall 2.0))
+                    particle-tile-width)))
+         (s32-set! particles offset ticks)
+         (s32-set! particles (+ offset 4) lifespan)
+         (f64-set! particles (+ offset 8) tx)
+         (f64-set! particles (+ offset 16) x)
+         (f64-set! particles (+ offset 24) y)
+         (f64-set! particles (+ offset 32) dx)
+         (f64-set! particles (+ offset 40) dy)
+         (set-particle-pool-length! pool (+ length 1))))))
+
+  (define (particle-pool-remove! pool i)
+    (match pool
+      (#('particle-pool length capacity image ticks particles)
+       (when (and (>= i 0) (< i length))
+         (let ((at (particle-pool-offset i))
+               (start (particle-pool-offset (- length 1))))
+           (bytevector-copy! particles at particles start (+ start %particle-size))
+           (set-particle-pool-length! pool (- length 1)))))))
+
+  (define (particle-pool-reset! pool)
+    (set-particle-pool-length! pool 0))
+
+  (define (particle-pool-update! pool)
+    (match pool
+      (#('particle-pool length capacity image ticks particles)
+       (let ((t (+ ticks 1)))
+         (let loop ((i 0) (k length))
+           (when (< i k)
+             (let* ((offset (particle-pool-offset i))
+                    (t* (s32-ref particles offset))
+                    (l (s32-ref particles (+ offset 4)))
+                    (x (f64-ref particles (+ offset 16)))
+                    (y (f64-ref particles (+ offset 24)))
+                    (dx (f64-ref particles (+ offset 32)))
+                    (dy (f64-ref particles (+ offset 40)))
+                    (x* (+ x dx))
+                    (y* (+ y dy)))
+               (cond
+                ((>= (- t t*) l)
+                 (particle-pool-remove! pool i)
+                 (loop i (- k 1)))
+                (else
+                 (f64-set! particles (+ offset 16) (+ x dx))
+                 (f64-set! particles (+ offset 24) (+ y dy))
+                 (loop (+ i 1) k))))))
+         (set-particle-pool-ticks! pool t)))))
+
+  (define (draw-particles context pool)
+    (match pool
+      (#('particle-pool length capacity image ticks particles)
+       (do ((i 0 (+ i 1)))
+           ((= i length))
+         (let* ((offset (particle-pool-offset i))
+                (tx (f64-ref particles (+ offset 8)))
+                (x (f64-ref particles (+ offset 16)))
+                (y (f64-ref particles (+ offset 24))))
+           (draw-image context image tx 0.0
+                       particle-tile-width particle-tile-height
+                       (- x (/ particle-tile-width 2.0))
+                       (- y (/ particle-tile-height 2.0))
+                       particle-tile-width particle-tile-height))))))
+
+  (define (explode particles x y)
+    (let ((speed 1.0))
+      (do-circle
+       (lambda (theta)
+         (particle-pool-add! particles 'explosion 20 x y
+                             (* (cos theta) speed) (* (sin theta) speed)))
+       16))))