Add particle effect when bomb explodes.

modules/game/particles.scm

@@ -0,0 +1,116 @@
+;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (game particles)
+  #:use-module (dom canvas)
+  #:use-module (game tileset)
+  #:use-module (hoot bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (math)
+  #:use-module (srfi srfi-9)
+  #:export (make-particle-pool
+            particle-pool?
+            particle-pool-add!
+            particle-pool-reset!
+            particle-pool-update!
+            draw-particles))
+
+(define s32-ref bytevector-s32-native-ref)
+(define s32-set! bytevector-s32-native-set!)
+(define f64-ref bytevector-ieee-double-native-ref)
+(define f64-set! bytevector-ieee-double-native-set!)
+
+(define-record-type <particle-pool>
+  (%make-particle-pool length capacity tileset ticks particles)
+  particle-pool?
+  (length particle-pool-length set-particle-pool-length!)
+  (capacity particle-pool-capacity set-particle-pool-capacity!)
+  (tileset particle-pool-tileset set-particle-pool-tileset!)
+  (ticks particle-pool-ticks set-particle-pool-ticks!)
+  (particles particle-pool-particles set-particle-pool-particles!))
+
+;; per particle: spawn-time, lifespan, tile-idx, x, y, dx, dy
+(define %particle-size (+ 4 4 4 8 8 8 8))
+(define particle-tile-width 16.0)
+(define particle-tile-height 16.0)
+
+(define (make-particle-pool capacity tileset)
+  (let ((particles (make-bytevector (* capacity %particle-size))))
+    (%make-particle-pool 0 capacity tileset 0 particles)))
+
+(define (particle-pool-offset i)
+  (* i %particle-size))
+
+(define (particle-pool-add! pool tile-idx lifespan x y dx dy)
+  (match pool
+    (($ <particle-pool> length capacity tileset ticks particles)
+     (let ((offset (particle-pool-offset length)))
+       (s32-set! particles offset ticks)
+       (s32-set! particles (+ offset 4) lifespan)
+       (s32-set! particles (+ offset 8) tile-idx)
+       (f64-set! particles (+ offset 12) x)
+       (f64-set! particles (+ offset 20) y)
+       (f64-set! particles (+ offset 28) dx)
+       (f64-set! particles (+ offset 36) dy)
+       (set-particle-pool-length! pool (1+ length))))))
+
+(define (particle-pool-remove! pool i)
+  (match pool
+    (($ <particle-pool> length capacity tileset 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 tileset 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 12)))
+                  (y (f64-ref particles (+ offset 20)))
+                  (dx (f64-ref particles (+ offset 28)))
+                  (dy (f64-ref particles (+ offset 36)))
+                  (x* (+ x dx))
+                  (y* (+ y dy)))
+             (cond
+              ((>= (- t t*) l)
+               (particle-pool-remove! pool i)
+               (loop i (- k 1)))
+              (else
+               (f64-set! particles (+ offset 12) (+ x dx))
+               (f64-set! particles (+ offset 20) (+ y dy))
+               (loop (+ i 1) k))))))
+       (set-particle-pool-ticks! pool t)))))
+
+(define (draw-particles context pool)
+  (match pool
+    (($ <particle-pool> length capacity tileset ticks particles)
+     (do ((i 0 (+ i 1)))
+         ((= i length))
+       (let* ((offset (particle-pool-offset i))
+              (idx (s32-ref particles (+ offset 8)))
+              (x (f64-ref particles (+ offset 12)))
+              (y (f64-ref particles (+ offset 20))))
+         (draw-tile context tileset idx
+                    (- x (/ particle-tile-width 2.0))
+                    (- y (/ particle-tile-height 2.0))))))))