From 6696a0b5fcb1b17895285d80d9636defb2df3f9d Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 10 Apr 2024 14:49:03 -0400
Subject: Sloppily refactor into modules.

---
 strigoform/assets.scm    |  55 +++++++++++
 strigoform/audio.scm     |  55 +++++++++++
 strigoform/bullets.scm   | 106 +++++++++++++++++++++
 strigoform/canvas.scm    |  48 ++++++++++
 strigoform/document.scm  |  24 +++++
 strigoform/element.scm   |  52 ++++++++++
 strigoform/enemies.scm   | 241 +++++++++++++++++++++++++++++++++++++++++++++++
 strigoform/event.scm     |  12 +++
 strigoform/game-area.scm |  15 +++
 strigoform/image.scm     |   8 ++
 strigoform/level.scm     | 129 +++++++++++++++++++++++++
 strigoform/math.scm      | 144 ++++++++++++++++++++++++++++
 strigoform/particles.scm | 113 ++++++++++++++++++++++
 strigoform/scripts.scm   | 147 +++++++++++++++++++++++++++++
 strigoform/time.scm      |  11 +++
 strigoform/type.scm      |  34 +++++++
 strigoform/window.scm    |  24 +++++
 17 files changed, 1218 insertions(+)
 create mode 100644 strigoform/assets.scm
 create mode 100644 strigoform/audio.scm
 create mode 100644 strigoform/bullets.scm
 create mode 100644 strigoform/canvas.scm
 create mode 100644 strigoform/document.scm
 create mode 100644 strigoform/element.scm
 create mode 100644 strigoform/enemies.scm
 create mode 100644 strigoform/event.scm
 create mode 100644 strigoform/game-area.scm
 create mode 100644 strigoform/image.scm
 create mode 100644 strigoform/level.scm
 create mode 100644 strigoform/math.scm
 create mode 100644 strigoform/particles.scm
 create mode 100644 strigoform/scripts.scm
 create mode 100644 strigoform/time.scm
 create mode 100644 strigoform/type.scm
 create mode 100644 strigoform/window.scm

(limited to 'strigoform')

diff --git a/strigoform/assets.scm b/strigoform/assets.scm
new file mode 100644
index 0000000..67524e1
--- /dev/null
+++ b/strigoform/assets.scm
@@ -0,0 +1,55 @@
+(library (strigoform assets)
+  (export load-assets!
+          image:cover
+          image:starfield-bg
+          image:starfield-fg
+          image:player
+          image:player-bullets
+          image:enemy-bullets
+          image:map
+          image:turret
+          image:popcorn
+          image:flyer0
+          image:flyer1
+          image:boss
+          image:particles
+          sound:explosion
+          sound:player-shoot
+          sound:player-death
+          sound:enemy-shoot
+          sound:bullet-hit
+          music)
+  (import (scheme base)
+          (only (hoot syntax) define-syntax-rule)
+          (strigoform image)
+          (strigoform audio))
+
+  (define *assets* '())
+
+  (define (load-assets!)
+    (for-each (lambda (thunk) (thunk)) *assets*))
+
+  (define-syntax-rule (define-asset name exp)
+    (begin
+      (define name #f)
+      (set! *assets* (cons (lambda () (set! name exp)) *assets*))))
+
+  (define-asset image:cover (load-image "images/cover.png"))
+  (define-asset image:starfield-bg (load-image "images/starfield-bg.png"))
+  (define-asset image:starfield-fg (load-image "images/starfield-fg.png"))
+  (define-asset image:player (load-image "images/player.png"))
+  (define-asset image:player-bullets (load-image "images/player-bullets.png"))
+  (define-asset image:enemy-bullets (load-image "images/enemy-bullets.png"))
+  (define-asset image:map (load-image "images/map.png"))
+  (define-asset image:turret (load-image "images/turret.png"))
+  (define-asset image:popcorn (load-image "images/popcorn.png"))
+  (define-asset image:flyer0 (load-image "images/flyer0.png"))
+  (define-asset image:flyer1 (load-image "images/flyer1.png"))
+  (define-asset image:boss (load-image "images/boss.png"))
+  (define-asset image:particles (load-image "images/particles.png"))
+  (define-asset sound:explosion (load-sound-effect "audio/explosion.wav"))
+  (define-asset sound:player-shoot (load-sound-effect "audio/player-shoot.wav"))
+  (define-asset sound:player-death (load-sound-effect "audio/player-death.wav"))
+  (define-asset sound:enemy-shoot (load-sound-effect "audio/enemy-shoot.wav"))
+  (define-asset sound:bullet-hit (load-sound-effect "audio/bullet-hit.wav"))
+  (define-asset music (load-audio "audio/music.ogg")))
diff --git a/strigoform/audio.scm b/strigoform/audio.scm
new file mode 100644
index 0000000..1c89025
--- /dev/null
+++ b/strigoform/audio.scm
@@ -0,0 +1,55 @@
+(library (strigoform audio)
+  (export load-audio
+          audio-play
+          audio-pause
+          audio-volume
+          set-audio-volume!
+          set-audio-loop!
+          audio-seek
+          load-sound-effect
+          sound-effect-play)
+  (import (scheme base)
+          (hoot ffi)
+          (hoot match)
+          (only (hoot syntax) define*)
+          (strigoform element))
+
+  (define-foreign load-audio
+    "audio" "new"
+    (ref string) -> (ref null extern))
+  (define-foreign audio-play
+    "audio" "play"
+    (ref null extern) -> none)
+  (define-foreign audio-pause
+    "audio" "pause"
+    (ref null extern) -> none)
+  (define-foreign audio-volume
+    "audio" "volume"
+    (ref null extern) -> f64)
+  (define-foreign set-audio-volume!
+    "audio" "setVolume"
+    (ref null extern) f64 -> none)
+  (define-foreign set-audio-loop!
+    "audio" "setLoop"
+    (ref null extern) i32 -> none)
+  (define-foreign audio-seek
+    "audio" "seek"
+    (ref null extern) f64 -> none)
+
+  ;; So we can play many overlapping audio samples at once.
+  (define (load-sound-effect src)
+    (let* ((k 32)
+           (audio (load-audio src))
+           (vec (make-vector k)))
+      (do ((i 0 (+ i 1)))
+          ((= i k))
+        (vector-set! vec i (clone-element audio)))
+      (vector 0 vec)))
+
+  (define* (sound-effect-play sound  #:optional (volume 1.0))
+    (match sound
+      (#(i vec)
+       (let ((audio (vector-ref vec i)))
+         (set-audio-volume! audio volume)
+         (audio-play audio)
+         (vector-set! sound 0 (modulo (+ i 1) (vector-length vec))))))))
diff --git a/strigoform/bullets.scm b/strigoform/bullets.scm
new file mode 100644
index 0000000..f271d43
--- /dev/null
+++ b/strigoform/bullets.scm
@@ -0,0 +1,106 @@
+(library (strigoform bullets)
+  (export make-bullet-pool
+          bullet-pool?
+          bullet-pool-add!
+          bullet-pool-remove!
+          bullet-pool-reset!
+          bullet-pool-update!
+          draw-bullets)
+  (import (scheme base)
+          (hoot match)
+          (strigoform canvas)
+          (strigoform game-area)
+          (strigoform math)
+          (strigoform particles)
+          (strigoform type))
+
+  (define-type bullet-pool
+    %make-bullet-pool
+    bullet-pool?
+    (length bullet-pool-length set-bullet-pool-length!)
+    (capacity bullet-pool-capacity set-bullet-pool-capacity!)
+    (image bullet-pool-image set-bullet-pool-image!)
+    (bullets bullet-pool-bullets set-bullet-pool-bullets!))
+
+  (define bullet-tile-width 16.0)
+  (define bullet-tile-height 16.0)
+  ;; per bullet: type, tile-x, x, y, w, h, dx, dy
+  (define %bullet-size (+ 4 8 8 8 8 8 8 8))
+
+  (define (make-bullet-pool capacity image)
+    (let ((bullets (make-bytevector (* capacity %bullet-size))))
+      (%make-bullet-pool 0 capacity image bullets)))
+
+  (define (bullet-pool-offset i)
+    (* i %bullet-size))
+
+  (define (bullet-pool-add! pool type x y w h dx dy)
+    (match pool
+      (#('bullet-pool length capacity image bullets)
+       (let ((offset (bullet-pool-offset length)))
+         (s32-set! bullets offset type)
+         (f64-set! bullets (+ offset 4) (* type bullet-tile-width))
+         (f64-set! bullets (+ offset 12) x)
+         (f64-set! bullets (+ offset 20) y)
+         (f64-set! bullets (+ offset 28) w)
+         (f64-set! bullets (+ offset 36) h)
+         (f64-set! bullets (+ offset 44) dx)
+         (f64-set! bullets (+ offset 52) dy)
+         (set-bullet-pool-length! pool (+ length 1))))))
+
+  (define (bullet-pool-remove! pool i)
+    (match pool
+      (#('bullet-pool length capacity image bullets)
+       (when (and (>= i 0) (< i length))
+         (let ((at (bullet-pool-offset i))
+               (start (bullet-pool-offset (- length 1))))
+           (bytevector-copy! bullets at bullets start (+ start %bullet-size))
+           (set-bullet-pool-length! pool (- length 1)))))))
+
+  (define (bullet-pool-reset! pool)
+    (set-bullet-pool-length! pool 0))
+
+  (define (bullet-pool-update! pool collide dscroll on-collide)
+    (match pool
+      (#('bullet-pool length capacity image bullets)
+       (let loop ((i 0) (k length))
+         (when (< i k)
+           (let* ((offset (bullet-pool-offset i))
+                  (type (s32-ref bullets offset))
+                  (x (f64-ref bullets (+ offset 12)))
+                  (y (f64-ref bullets (+ offset 20)))
+                  (w (f64-ref bullets (+ offset 28)))
+                  (h (f64-ref bullets (+ offset 36)))
+                  (dx (f64-ref bullets (+ offset 44)))
+                  (dy (f64-ref bullets (+ offset 52)))
+                  (x* (+ x dx))
+                  (y* (+ y dy dscroll)))
+             (cond
+              ((out-of-bounds? x* y* w h)
+               (bullet-pool-remove! pool i)
+               (loop i (- k 1)))
+              ((collide type x* y* w h)
+               (on-collide type x* y*)
+               (bullet-pool-remove! pool i)
+               (loop i (- k 1)))
+              (else
+               (f64-set! bullets (+ offset 12) x*)
+               (f64-set! bullets (+ offset 20) y*)
+               (loop (+ i 1) k)))))))))
+
+  (define (draw-bullets context pool)
+    (match pool
+      (#('bullet-pool length capacity image bullets)
+       (do ((i 0 (+ i 1)))
+           ((= i length))
+         (let* ((offset (bullet-pool-offset i))
+                (tx (f64-ref bullets (+ offset 4)))
+                (x (f64-ref bullets (+ offset 12)))
+                (y (f64-ref bullets (+ offset 20)))
+                (w (f64-ref bullets (+ offset 28)))
+                (h (f64-ref bullets (+ offset 36))))
+           (draw-image context image tx 0.0
+                       bullet-tile-width bullet-tile-height
+                       (- x (/ bullet-tile-width 2.0))
+                       (- y (/ bullet-tile-height 2.0))
+                       bullet-tile-width bullet-tile-height)))))))
diff --git a/strigoform/canvas.scm b/strigoform/canvas.scm
new file mode 100644
index 0000000..f5565ef
--- /dev/null
+++ b/strigoform/canvas.scm
@@ -0,0 +1,48 @@
+(library (strigoform canvas)
+  (export get-context
+          set-fill-color!
+          set-font!
+          set-text-align!
+          clear-rect
+          fill-rect
+          fill-text
+          draw-image
+          set-scale!
+          set-transform!
+          set-image-smoothing-enabled!)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign get-context
+    "canvas" "getContext"
+    (ref null extern) (ref string) -> (ref null extern))
+  (define-foreign set-fill-color!
+    "canvas" "setFillColor"
+    (ref null extern) (ref string) -> none)
+  (define-foreign set-font!
+    "canvas" "setFont"
+    (ref null extern) (ref string) -> none)
+  (define-foreign set-text-align!
+    "canvas" "setTextAlign"
+    (ref null extern) (ref string) -> none)
+  (define-foreign clear-rect
+    "canvas" "clearRect"
+    (ref null extern) f64 f64 f64 f64 -> none)
+  (define-foreign fill-rect
+    "canvas" "fillRect"
+    (ref null extern) f64 f64 f64 f64 -> none)
+  (define-foreign fill-text
+    "canvas" "fillText"
+    (ref null extern) (ref string) f64 f64 -> none)
+  (define-foreign draw-image
+    "canvas" "drawImage"
+    (ref null extern) (ref null extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
+  (define-foreign set-scale!
+    "canvas" "setScale"
+    (ref null extern) f64 f64 -> none)
+  (define-foreign set-transform!
+    "canvas" "setTransform"
+    (ref null extern) f64 f64 f64 f64 f64 f64 -> none)
+  (define-foreign set-image-smoothing-enabled!
+    "canvas" "setImageSmoothingEnabled"
+    (ref null extern) i32 -> none))
diff --git a/strigoform/document.scm b/strigoform/document.scm
new file mode 100644
index 0000000..9bdedc0
--- /dev/null
+++ b/strigoform/document.scm
@@ -0,0 +1,24 @@
+(library (strigoform document)
+  (export current-document
+          document-body
+          get-element-by-id
+          make-text-node
+          make-element)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign current-document
+    "document" "get"
+    -> (ref null extern))
+  (define-foreign document-body
+    "document" "body"
+    -> (ref null extern))
+  (define-foreign get-element-by-id
+    "document" "getElementById"
+    (ref string) -> (ref null extern))
+  (define-foreign make-text-node
+    "document" "createTextNode"
+    (ref string) -> (ref null extern))
+  (define-foreign make-element
+    "document" "createElement"
+    (ref string) -> (ref null extern)))
diff --git a/strigoform/element.scm b/strigoform/element.scm
new file mode 100644
index 0000000..a901960
--- /dev/null
+++ b/strigoform/element.scm
@@ -0,0 +1,52 @@
+(library (strigoform element)
+  (export element-value
+          set-element-value!
+          set-element-width!
+          set-element-height!
+          append-child!
+          remove!
+          replace-with!
+          set-attribute!
+          remove-attribute!
+          add-event-listener!
+          remove-event-listener!
+          clone-element)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign element-value
+    "element" "value"
+    (ref null extern) -> (ref string))
+  (define-foreign set-element-value!
+    "element" "setValue"
+    (ref null extern) (ref string) -> none)
+  (define-foreign set-element-width!
+    "element" "setWidth"
+    (ref null extern) i32 -> none)
+  (define-foreign set-element-height!
+    "element" "setHeight"
+    (ref null extern) i32 -> none)
+  (define-foreign append-child!
+    "element" "appendChild"
+    (ref null extern) (ref null extern) -> (ref null extern))
+  (define-foreign remove!
+    "element" "remove"
+    (ref null extern) -> none)
+  (define-foreign replace-with!
+    "element" "replaceWith"
+    (ref null extern) (ref null extern) -> none)
+  (define-foreign set-attribute!
+    "element" "setAttribute"
+    (ref null extern) (ref string) (ref string) -> none)
+  (define-foreign remove-attribute!
+    "element" "removeAttribute"
+    (ref null extern) (ref string) -> none)
+  (define-foreign add-event-listener!
+    "element" "addEventListener"
+    (ref null extern) (ref string) (ref null extern) -> none)
+  (define-foreign remove-event-listener!
+    "element" "removeEventListener"
+    (ref null extern) (ref string) (ref null extern) -> none)
+  (define-foreign clone-element
+    "element" "clone"
+    (ref null extern) -> (ref null extern)))
diff --git a/strigoform/enemies.scm b/strigoform/enemies.scm
new file mode 100644
index 0000000..a457c8d
--- /dev/null
+++ b/strigoform/enemies.scm
@@ -0,0 +1,241 @@
+(library (strigoform enemies)
+  (export make-enemy
+          enemy?
+          enemy-type
+          enemy-health set-enemy-health!
+          enemy-position
+          enemy-x set-enemy-x!
+          enemy-y set-enemy-y!
+          enemy-size
+          enemy-width
+          enemy-height
+          enemy-velocity
+          enemy-dx set-enemy-dx!
+          enemy-dy set-enemy-dy!
+          enemy-script
+          enemy-points
+          enemy-spawn-time
+          enemy-animation
+          enemy-image
+          enemy-image-size
+          enemy-damage!
+          enemy-dead?
+          enemy-out-of-bounds?
+          enemy-within-rect?
+          enemy-start!
+          enemy-stop!
+          draw-enemy
+
+          make-enemy-pool
+          enemy-pool?
+          enemy-pool-length
+          enemy-pool-capacity
+          enemy-pool-enemies
+          enemy-pool-add!
+          enemy-pool-remove!
+          enemy-pool-reset!
+          enemy-pool-update!
+          draw-enemies
+          find-enemy)
+  (import (scheme base)
+          (hoot match)
+          (strigoform assets)
+          (strigoform audio)
+          (strigoform canvas)
+          (strigoform game-area)
+          (strigoform math)
+          (strigoform particles)
+          (strigoform scripts)
+          (strigoform time)
+          (strigoform type))
+
+  (define-type enemy
+    %make-enemy
+    enemy?
+    (type enemy-type set-enemy-type!)
+    (health enemy-health set-enemy-health!)
+    (position enemy-position set-enemy-position!)
+    (size enemy-size set-enemy-size!)
+    (velocity enemy-velocity set-enemy-velocity!)
+    (script enemy-script set-enemy-script!)
+    (points enemy-points set-enemy-points!)
+    (spawn-time enemy-spawn-time set-enemy-spawn-time!)
+    (animation enemy-animation set-enemy-animation!)
+    (image enemy-image set-enemy-image!)
+    (image-size enemy-image-size set-enemy-image-size!))
+
+  (define (make-enemy type health position size velocity
+                      script points animation image image-size)
+    (%make-enemy type health position size velocity script
+                 points (current-time) animation image
+                 image-size))
+
+  (define (enemy-x enemy)
+    (vec2-x (enemy-position enemy)))
+
+  (define (enemy-y enemy)
+    (vec2-y (enemy-position enemy)))
+
+  (define (set-enemy-x! enemy x)
+    (set-vec2-x! (enemy-position enemy) x))
+
+  (define (set-enemy-y! enemy y)
+    (set-vec2-y! (enemy-position enemy) y))
+
+  (define (enemy-width enemy)
+    (vec2-x (enemy-size enemy)))
+
+  (define (enemy-height enemy)
+    (vec2-y (enemy-size enemy)))
+
+  (define (enemy-dx enemy)
+    (vec2-x (enemy-velocity enemy)))
+
+  (define (enemy-dy enemy)
+    (vec2-y (enemy-velocity enemy)))
+
+  (define (set-enemy-dx! enemy dx)
+    (set-vec2-x! (enemy-velocity enemy) dx))
+
+  (define (set-enemy-dy! enemy dy)
+    (set-vec2-y! (enemy-velocity enemy) dy))
+
+  (define (enemy-damage! enemy damage)
+    (match enemy
+      (#('enemy type health _ _ _ _ _ _ _ _ _)
+       (set-enemy-health! enemy (- health damage)))))
+
+  (define (enemy-dead? enemy)
+    (<= (enemy-health enemy) 0))
+
+  (define (enemy-out-of-bounds? enemy)
+    (match enemy
+      (#('enemy _ _ position size _ _ _ _ _ _ _)
+       (out-of-bounds? (vec2-x position) (vec2-y position)
+                       (vec2-x size) (vec2-y size)))))
+
+  (define (enemy-within-rect? enemy x y w h)
+    (match enemy
+      (#('enemy _ _ position size _ _ _ _ _ _ _)
+       (let* ((w* (vec2-x size))
+              (h* (vec2-y size))
+              (x* (- (vec2-x position) (/ w* 2.0)))
+              (y* (- (vec2-y position) (/ h* 2.0))))
+         (rect-within? x y w h x* y* w* h*)))))
+
+  (define (enemy-start! enemy)
+    (let ((proc (enemy-script enemy)))
+      (when (procedure? proc)
+        (set-enemy-script! enemy (run-script (lambda () (proc enemy)))))))
+
+  (define (enemy-stop! enemy)
+    (let ((script (enemy-script enemy)))
+      (when (script? script)
+        (script-cancel! script))))
+
+  (define (enemy-update! enemy dscroll)
+    (match enemy
+      (#('enemy _ _ position size velocity _ _ _ _ _ _)
+       (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity)))
+       (set-vec2-y! position (+ (vec2-y position)
+                                (+ (vec2-y velocity) dscroll))))))
+
+  (define (draw-enemy context enemy time)
+    (let ((frame-duration 0.25))
+      (match enemy
+        (#('enemy type _ position size _ _ _ spawn-time animation
+                  image image-size)
+         (let* ((tx (vector-ref animation
+                                (modulo (exact
+                                         (truncate
+                                          (/ (- time spawn-time)
+                                             frame-duration)))
+                                        (vector-length animation))))
+                (x (vec2-x position))
+                (y (vec2-y position))
+                (hbw (vec2-x size))
+                (hbh (vec2-y size))
+                (w (vec2-x image-size))
+                (h (vec2-y image-size)))
+           (draw-image context image tx 0.0 w h
+                       (- x (/ w 2.0)) (- y (/ h 2.0)) w h)
+           ;; (when *debug?*
+           ;;   (set-fill-color! context "#ff00ff80")
+           ;;   (fill-rect context
+           ;;              (- x (/ hbw 2.0))
+           ;;              (- y (/ hbh 2.0))
+           ;;              hbw hbh))
+           )))))
+
+  (define-type enemy-pool
+    %make-enemy-pool
+    enemy-pool?
+    (length enemy-pool-length set-enemy-pool-length!)
+    (capacity enemy-pool-capacity set-enemy-pool-capacity!)
+    (enemies enemy-pool-enemies set-enemy-pool-enemies!))
+
+  (define (make-enemy-pool capacity)
+    (%make-enemy-pool 0 capacity (make-vector capacity #f)))
+
+  (define (enemy-pool-add! pool enemy)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (unless (= length capacity)
+         (vector-set! enemies length enemy)
+         (set-enemy-pool-length! pool (+ length 1))
+         (enemy-start! enemy)))))
+
+  (define (enemy-pool-remove! pool i)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (when (and (>= i 0) (< i length))
+         (let ((j (- length 1))
+               (enemy (vector-ref enemies i)))
+           (vector-set! enemies i (vector-ref enemies j))
+           (vector-set! enemies j #f)
+           (enemy-stop! enemy)
+           (set-enemy-pool-length! pool j))))))
+
+  (define (enemy-pool-reset! pool)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (do ((i 0 (+ i 1)))
+           ((= i length))
+         (enemy-stop! (vector-ref enemies i))
+         (vector-set! enemies i #f))
+       (set-enemy-pool-length! pool 0))))
+
+  (define (enemy-pool-update! pool dscroll particles on-kill)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (let ((padding 16.0))
+         (let loop ((i 0) (k length))
+           (unless (= i k)
+             (let ((enemy (vector-ref enemies i)))
+               (enemy-update! enemy dscroll)
+               (cond
+                ((or (enemy-dead? enemy)
+                     (enemy-out-of-bounds? enemy))
+                 (when (enemy-dead? enemy)
+                   (on-kill enemy))
+                 (enemy-pool-remove! pool i)
+                 (loop i (- k 1)))
+                (else
+                 (loop (+ i 1) k))))))))))
+
+  (define (draw-enemies context pool time)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (do ((i 0 (+ i 1)))
+           ((= i length))
+         (draw-enemy context (vector-ref enemies i) time)))))
+
+  (define (find-enemy pool x y w h)
+    (match pool
+      (#('enemy-pool length capacity enemies)
+       (let loop ((i 0))
+         (and (< i length)
+              (let ((enemy (vector-ref enemies i)))
+                (if (enemy-within-rect? enemy x y w h)
+                    enemy
+                    (loop (+ i 1))))))))))
diff --git a/strigoform/event.scm b/strigoform/event.scm
new file mode 100644
index 0000000..5f47099
--- /dev/null
+++ b/strigoform/event.scm
@@ -0,0 +1,12 @@
+(library (strigoform event)
+  (export prevent-default!
+          keyboard-event-code)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign prevent-default!
+    "event" "preventDefault"
+    (ref null extern) -> none)
+  (define-foreign keyboard-event-code
+    "event" "keyboardCode"
+    (ref null extern) -> (ref string)))
diff --git a/strigoform/game-area.scm b/strigoform/game-area.scm
new file mode 100644
index 0000000..7155813
--- /dev/null
+++ b/strigoform/game-area.scm
@@ -0,0 +1,15 @@
+(library (strigoform game-area)
+  (export game-width
+          game-height
+          out-of-bounds?)
+  (import (scheme base)
+          (strigoform math))
+
+  (define game-width 240.0)
+  (define game-height 320.0)
+
+  (define (out-of-bounds? x y w h)
+    (let ((padding 32.0))
+      (not (rect-within? x y w h (- padding) (- padding)
+                         (+ game-width (* padding 2.0))
+                         (+ game-height (* padding 2.0)))))))
diff --git a/strigoform/image.scm b/strigoform/image.scm
new file mode 100644
index 0000000..f769bd7
--- /dev/null
+++ b/strigoform/image.scm
@@ -0,0 +1,8 @@
+(library (strigoform image)
+  (export load-image)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign load-image
+    "image" "new"
+    (ref string) -> (ref null extern)))
diff --git a/strigoform/level.scm b/strigoform/level.scm
new file mode 100644
index 0000000..f735049
--- /dev/null
+++ b/strigoform/level.scm
@@ -0,0 +1,129 @@
+(library (strigoform level)
+  (export tile-width
+          tile-height
+
+          make-level-object
+          level-object?
+          level-object-x
+          level-object-type
+          level-object-properties
+
+          make-level
+          level?
+          level-height
+          level-foreground
+          level-collision
+          level-objects
+          level-update!
+          draw-level-foreground
+
+          rect-collides-with-level?)
+  (import (scheme base)
+          (hoot match)
+          (strigoform assets)
+          (strigoform canvas)
+          (strigoform game-area)
+          (strigoform math)
+          (strigoform type))
+
+  ;; action id, sprite sheet offset, x, y
+  (define %tile-size (+ 4 8 8 8))
+  (define tile-width 16.0)
+  (define tile-height 16.0)
+  (define level-width 15)
+
+  (define-type level-object
+    make-level-object
+    level-object?
+    (x level-object-x set-level-object-x!)
+    (type level-object-type set-level-object-type!)
+    (properties level-object-properties set-level-object-properties!))
+
+  (define-type level
+    make-level
+    level?
+    (height level-height set-level-height!)
+    (foreground level-foreground set-level-foreground!)
+    (collision level-collision set-level-collision!)
+    (objects level-objects set-level-objects!))
+
+  (define (level-offset x y)
+    (+ (* level-width y) x))
+
+  (define (point-collides-with-level? level x y)
+    (match level
+      (#('level height foreground collision objects)
+       (let ((tx (exact (truncate (/ x tile-width))))
+             (ty (exact (truncate (/ y tile-height)))))
+         (and (>= tx 0) (< tx level-width)
+              (>= ty 0) (< tx height)
+              (= (bytevector-u8-ref collision (level-offset tx ty)) 1))))))
+
+  (define (rect-collides-with-level? level x y w h scroll)
+    (match level
+      (#('level height foreground collision objects)
+       (let* ((y (+ y (- (* height tile-height) game-height scroll)))
+              (tx0 (exact (truncate (/ x tile-width))))
+              (ty0 (exact (truncate (/ y tile-height))))
+              (tx1 (exact (truncate (/ (+ x w) tile-width))))
+              (ty1 (exact (truncate (/ (+ y h) tile-height)))))
+         (define (occupied? x y)
+           (and (>= x 0) (< x level-width)
+                (>= y 0) (< x height)
+                (= (bytevector-u8-ref collision (level-offset x y)) 1)))
+         (or (occupied? tx0 ty0)
+             (occupied? tx1 ty0)
+             (occupied? tx1 ty1)
+             (occupied? tx0 ty1))))))
+
+  (define (draw-level-layer context level layer parallax scroll)
+    (match level
+      (#('level height _ _ _)
+       (let* ((tw tile-width)
+              (th tile-height)
+              (scroll (* scroll parallax))
+              (pixel-y-offset (- (* height th) scroll game-height))
+              (scroll-y-offset (- height (exact (truncate (/ scroll tile-height)))))
+              (y-start (clamp (- scroll-y-offset 21) 0 height))
+              (y-end (clamp scroll-y-offset 0 height)))
+         (do ((y y-start (+ y 1)))
+             ((= y y-end))
+           (let* ((row (vector-ref layer y))
+                  (k (/ (bytevector-length row) 16))
+                  (ty (* y tile-height)))
+             (do ((x 0 (+ x 1)))
+                 ((= x k))
+               (let* ((offset (* x 16))
+                      (tx (f64-ref row offset))
+                      (ix (f64-ref row (+ offset 8))))
+                 (draw-image context image:map
+                             ix 0.0 tw th
+                             tx (- ty pixel-y-offset) tw th)))))))))
+
+  (define (draw-level-foreground context level scroll)
+    (match level
+      (#('level height foreground collision objects)
+       (draw-level-layer context level foreground 1.0 scroll))))
+
+  (define (level-update! level scroll last-row-scanned do-action)
+    (match level
+      (#('level height foreground collision objects)
+       (let ((row (max
+                   (exact
+                    (truncate
+                     (/ (- (* height tile-height)
+                           game-height scroll)
+                        tile-height)))
+                   0)))
+         (do ((y row (+ y 1)))
+             ((= y last-row-scanned))
+           (for-each (lambda (obj)
+                       (match obj
+                         (#('level-object x type properties)
+                          (let ((x* (+ (* x tile-width)
+                                       (/ tile-width 2.0)))
+                                (y* (+ (* (- y row 1) tile-height)
+                                       (/ tile-height 2.0))))
+                            (do-action type x* y* properties)))))
+                     (vector-ref objects y)))
+         row)))))
diff --git a/strigoform/math.scm b/strigoform/math.scm
new file mode 100644
index 0000000..b769572
--- /dev/null
+++ b/strigoform/math.scm
@@ -0,0 +1,144 @@
+(library (strigoform math)
+  (export fmod
+          pi
+          pi/2
+          tau
+          do-circle
+          clamp
+          smoothstep
+          lerp
+
+          s32-ref
+          s32-set!
+          f64-ref
+          f64-set!
+
+          vec2
+          vec2?
+          vec2-x
+          vec2-y
+          set-vec2-x!
+          set-vec2-y!
+          vec2-add!
+          vec2-sub!
+          vec2-mul-scalar!
+          vec2-magnitude
+          vec2-normalize!
+          vec2-clamp!
+
+          make-rect
+          rect-x
+          rect-y
+          rect-w
+          rect-h
+          within?
+          rect-within?)
+  (import (scheme base)
+          (scheme inexact)
+          (only (hoot bytevectors)
+                bytevector-s32-native-ref
+                bytevector-s32-native-set!
+                bytevector-ieee-double-native-ref
+                bytevector-ieee-double-native-set!)
+          (strigoform type))
+
+  (define (assert-float x)
+    (unless (and (number? x) (inexact? x) (rational? x))
+      (error "expected inexact rational" x)))
+
+  (define (fmod x y)
+    (assert-float x)
+    (assert-float y)
+    (- x (* (truncate (/ x y)) y)))
+
+  (define pi (* 4.0 (atan 1.0)))
+  (define pi/2 (/ pi 2.0))
+  (define tau (* pi 2.0))
+
+  (define (do-circle proc k)
+    (do ((i 0 (+ i 1)))
+        ((= i k))
+      (proc (* tau (inexact (/ i k))))))
+
+  (define (clamp x min max)
+    (cond ((< x min) min)
+          ((> x max) max)
+          (else x)))
+
+  (define (smoothstep t)
+    (* t t (- 3.0 (* 2.0 t))))
+
+  (define (lerp start end alpha)
+    (+ (* start (- 1.0 alpha))
+       (* end alpha)))
+
+  (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-type vec2
+    make-vec2
+    vec2?
+    (bv vec2-bv set-vec2-bv!))
+  (define (vec2 x y)
+    (let ((v (make-vec2 (make-bytevector 16))))
+      (set-vec2-x! v x)
+      (set-vec2-y! v y)
+      v))
+  (define (vec2-x v)
+    (f64-ref (vec2-bv v) 0))
+  (define (vec2-y v)
+    (f64-ref (vec2-bv v) 8))
+  (define (set-vec2-x! v x)
+    (f64-set! (vec2-bv v) 0 x))
+  (define (set-vec2-y! v y)
+    (f64-set! (vec2-bv v) 8 y))
+  (define (vec2-add! v w)
+    (set-vec2-x! v (+ (vec2-x v) (vec2-x w)))
+    (set-vec2-y! v (+ (vec2-y v) (vec2-y w))))
+  (define (vec2-sub! v w)
+    (set-vec2-x! v (- (vec2-x v) (vec2-x w)))
+    (set-vec2-y! v (- (vec2-y v) (vec2-y w))))
+  (define (vec2-mul-scalar! v x)
+    (set-vec2-x! v (* (vec2-x v) x))
+    (set-vec2-y! v (* (vec2-y v) x)))
+  (define (vec2-magnitude v)
+    (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v)))))
+  (define (vec2-normalize! v)
+    (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0))
+      (let ((m (vec2-magnitude v)))
+        (set-vec2-x! v (/ (vec2-x v) m))
+        (set-vec2-y! v (/ (vec2-y v) m)))))
+  (define (vec2-clamp! v xmin ymin xmax ymax)
+    (set-vec2-x! v (clamp (vec2-x v) xmin xmax))
+    (set-vec2-y! v (clamp (vec2-y v) ymin ymax)))
+
+  (define (make-rect x y w h)
+    (let ((r (make-bytevector (* 8 4))))
+      (f64-set! r 0 x)
+      (f64-set! r 8 y)
+      (f64-set! r 16 w)
+      (f64-set! r 24 h)
+      r))
+  (define (rect-x r)
+    (f64-ref r 0))
+  (define (rect-y r)
+    (f64-ref r 8))
+  (define (rect-w r)
+    (f64-ref r 16))
+  (define (rect-h r)
+    (f64-ref r 24))
+
+  (define (within? x y rx ry rw rh)
+    (and (>= x rx)
+         (>= y ry)
+         (< x (+ rx rw))
+         (< y (+ ry rh))))
+  (define (rect-within? ax ay aw ah bx by bw bh)
+    (let ((ax* (+ ax aw))
+          (ay* (+ ay ah)))
+      (or (within? ax ay bx by bw bh)
+          (within? ax* ay bx by bw bh)
+          (within? ax* ay* bx by bw bh)
+          (within? ax ay* bx by bw bh)))))
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))))
diff --git a/strigoform/scripts.scm b/strigoform/scripts.scm
new file mode 100644
index 0000000..842e71b
--- /dev/null
+++ b/strigoform/scripts.scm
@@ -0,0 +1,147 @@
+(library (strigoform scripts)
+  (export make-scheduler
+          current-scheduler
+          scheduler-tick!
+          scheduler-reset!
+
+          script?
+          run-script
+          script-cancel!
+          wait
+          forever
+          tween)
+  (import (scheme base)
+          (only (hoot control)
+                make-prompt-tag
+                call-with-prompt
+                abort-to-prompt)
+          (hoot match)
+          (only (hoot syntax) define-syntax-rule define*)
+          (strigoform type))
+
+  (define (make-scheduler max-tasks)
+    (vector 0 0 max-tasks (make-vector max-tasks)))
+
+  (define (scheduler-add! scheduler thunk delay)
+    (match scheduler
+      (#(ticks num-tasks max-tasks tasks)
+       (unless (= num-tasks max-tasks)
+         (vector-set! tasks num-tasks (cons (+ ticks delay) thunk))
+         (vector-set! scheduler 1 (+ num-tasks 1))))))
+
+  (define (scheduler-tick! scheduler)
+    (define (run-thunks thunks)
+      (for-each (lambda (thunk) (thunk)) thunks))
+    (run-thunks
+     (match scheduler
+       (#(ticks num-tasks max-tasks tasks)
+        (let ((t (+ ticks 1)))
+          (let loop ((i 0) (k num-tasks) (to-run '()))
+            (if (< i k)
+                (match (vector-ref tasks i)
+                  ((t* . thunk)
+                   (if (<= t* t)
+                       (let ((k* (- k 1)))
+                         (vector-set! tasks i (vector-ref tasks k*))
+                         (vector-set! tasks k* #f)
+                         (loop i k* (cons thunk to-run)))
+                       (loop (+ i 1) k to-run))))
+                (begin
+                  (vector-set! scheduler 0 t)
+                  (vector-set! scheduler 1 k)
+                  to-run))))))))
+
+  (define (scheduler-reset! scheduler)
+    (match scheduler
+      (#(ticks num-tasks max-tasks tasks)
+       (vector-set! scheduler 0 0)
+       (vector-set! scheduler 1 0)
+       (do ((i 0 (+ i 1)))
+           ((= i num-tasks))
+         (vector-set! tasks i #f)))))
+
+  (define *scheduler* (make-scheduler 100))
+  (define current-scheduler
+    (cond-expand
+     (guile-vm #f)
+     (hoot (make-parameter *scheduler*))))
+  (define current-script
+    (cond-expand
+     (guile-vm #f)
+     (hoot (make-parameter #f))))
+
+  (define %script-tag (make-prompt-tag "script"))
+
+  (define-type script
+    %make-script
+    script?
+    (scheduler script-scheduler set-script-scheduler!)
+    (state script-state set-script-state!)
+    (cont script-cont set-script-cont!)
+    (children script-children set-script-children!))
+
+  (define (make-script thunk)
+    (%make-script (current-scheduler) 'pending thunk '()))
+
+  (define (script-pending? script)
+    (eq? (script-state script) 'pending))
+
+  (define (script-running? script)
+    (eq? (script-state script) 'running))
+
+  (define (script-cancelled? script)
+    (eq? (script-state script) 'cancelled))
+
+  (define (script-cancel! script)
+    (set-script-state! script 'cancelled)
+    (for-each script-cancel! (script-children script)))
+
+  (define (script-run! script)
+    (define scheduler (script-scheduler script))
+    (define (run thunk)
+      (unless (script-cancelled? script)
+        (call-with-prompt %script-tag
+          (lambda ()
+            (parameterize ((current-script script)
+                           (current-scheduler scheduler))
+              (thunk)))
+          handler)))
+    (define (handler k delay)
+      (when delay
+        (scheduler-add! scheduler (lambda () (run k)) delay)))
+    (when (script-pending? script)
+      (let ((parent (current-script)))
+        (when parent
+          (set-script-children! parent (cons script (script-children parent)))))
+      (run
+       (lambda ()
+         (set-script-state! script 'running)
+         ((script-cont script))
+         ;; Nasty hack: For some reason, falling through the prompt
+         ;; thunk messes up the Scheme stack, resulting in an invalid
+         ;; ref.cast somewhere.  So, we *never* fall through.  Instead,
+         ;; we create a continuation that gets thrown away.
+         (abort-to-prompt %script-tag #f)))))
+
+  (define (run-script thunk)
+    (let ((script (make-script thunk)))
+      (script-run! script)
+      script))
+
+  (define (wait delay)
+    (abort-to-prompt %script-tag delay))
+
+  (define-syntax-rule (forever body ...)
+    (let loop ()
+      body ...
+      (loop)))
+
+  (define* (tween proc duration start end ease interpolate)
+    (let ((d (inexact duration)))
+      (let loop ((t 0))
+        (if (= t duration)
+            (proc end)
+            (let ((alpha (ease (/ (inexact t) d))))
+              (proc (interpolate start end alpha))
+              (wait 1)
+              (loop (+ t 1))))))))
diff --git a/strigoform/time.scm b/strigoform/time.scm
new file mode 100644
index 0000000..00971a0
--- /dev/null
+++ b/strigoform/time.scm
@@ -0,0 +1,11 @@
+(library (strigoform time)
+  (export current-time)
+  (import (scheme base)
+          (scheme time))
+
+  (define %jps
+    (cond-expand
+     (guile-vm 0.0)
+     (hoot (inexact (jiffies-per-second)))))
+  (define (current-time)
+    (/ (inexact (current-jiffy)) %jps)))
diff --git a/strigoform/type.scm b/strigoform/type.scm
new file mode 100644
index 0000000..efd4287
--- /dev/null
+++ b/strigoform/type.scm
@@ -0,0 +1,34 @@
+(library (strigoform type)
+  (export define-type)
+  (import (scheme base)
+          (hoot match)
+          (only (hoot syntax) define-syntax-rule))
+
+  ;; Record types are only just beginning to be added to Hoot and
+  ;; there isn't support for mutable structs, yet. So, tagged
+  ;; vectors will have to do.
+  (define-syntax-rule (define-type name
+                        constructor
+                        predicate
+                        (field getter setter) ...)
+    (begin
+      (define (constructor field ...)
+        (vector 'name field ...))
+      (define (predicate obj)
+        (match obj
+          (#('name field ...) #t)
+          (_ #f)))
+      (define (getter obj)
+        (match obj
+          (#('name field ...)
+           field)))
+      ...
+      (define setter
+        (let ((i (+ (- (length '(field ...))
+                       (length (memq 'field '(field ...))))
+                    1)))
+          (lambda (obj val)
+            (match obj
+              (#('name field ...)
+               (vector-set! obj i val))))))
+      ...)))
diff --git a/strigoform/window.scm b/strigoform/window.scm
new file mode 100644
index 0000000..87225ef
--- /dev/null
+++ b/strigoform/window.scm
@@ -0,0 +1,24 @@
+(library (strigoform window)
+  (export current-window
+          window-inner-width
+          window-inner-height
+          request-animation-frame
+          timeout)
+  (import (scheme base)
+          (hoot ffi))
+
+  (define-foreign current-window
+    "window" "get"
+    -> (ref null extern))
+  (define-foreign window-inner-width
+    "window" "innerWidth"
+    (ref null extern) -> i32)
+  (define-foreign window-inner-height
+    "window" "innerHeight"
+    (ref null extern) -> i32)
+  (define-foreign request-animation-frame
+    "window" "requestAnimationFrame"
+    (ref null extern) -> none)
+  (define-foreign timeout
+    "window" "setTimeout"
+    (ref null extern) f64 -> i32))
-- 
cgit v1.2.3