path: root/game.scm

(use-modules (hoot compile)
             (ice-9 binary-ports)
             (wasm assemble))

(define src
  `(let ()
     ;; Host imports
     (define-foreign current-window
       "window" "get"
       -> (ref extern))
     (define-foreign window-inner-width
       "window" "innerWidth"
       (ref extern) -> i32)
     (define-foreign window-inner-height
       "window" "innerHeight"
       (ref extern) -> i32)
     (define-foreign request-animation-frame
       "window" "requestAnimationFrame"
       (ref eq) -> none)
     (define-foreign timeout
       "window" "setTimeout"
       (ref eq) f64 -> i32)

     (define-foreign current-document
       "document" "get"
       -> (ref extern))
     (define-foreign document-body
       "document" "body"
       -> (ref extern))
     (define-foreign get-element-by-id
       "document" "getElementById"
       (ref string) -> (ref null extern))
     (define-foreign make-text-node
       "document" "createTextNode"
       (ref string) -> (ref extern))
     (define-foreign make-element
       "document" "createElement"
       (ref string) -> (ref extern))

     (define-foreign element-value
       "element" "value"
       (ref extern) -> (ref string))
     (define-foreign set-element-value!
       "element" "setValue"
       (ref extern) (ref string) -> none)
     (define-foreign set-element-width!
       "element" "setWidth"
       (ref extern) i32 -> none)
     (define-foreign set-element-height!
       "element" "setHeight"
       (ref extern) i32 -> none)
     (define-foreign append-child!
       "element" "appendChild"
       (ref extern) (ref extern) -> (ref extern))
     (define-foreign remove!
       "element" "remove"
       (ref extern) -> none)
     (define-foreign replace-with!
       "element" "replaceWith"
       (ref extern) (ref extern) -> none)
     (define-foreign set-attribute!
       "element" "setAttribute"
       (ref extern) (ref string) (ref string) -> none)
     (define-foreign remove-attribute!
       "element" "removeAttribute"
       (ref extern) (ref string) -> none)
     (define-foreign add-event-listener!
       "element" "addEventListener"
       (ref extern) (ref string) (ref eq) -> none)
     (define-foreign remove-event-listener!
       "element" "removeEventListener"
       (ref extern) (ref string) (ref eq) -> none)
     (define-foreign clone-element
       "element" "clone"
       (ref extern) -> (ref extern))

     (define-foreign prevent-default!
       "event" "preventDefault"
       (ref extern) -> none)
     (define-foreign keyboard-event-code
       "event" "keyboardCode"
       (ref extern) -> (ref string))

     (define-foreign get-context
       "canvas" "getContext"
       (ref extern) (ref string) -> (ref extern))
     (define-foreign set-fill-color!
       "canvas" "setFillColor"
       (ref extern) (ref string) -> none)
     (define-foreign set-font!
       "canvas" "setFont"
       (ref extern) (ref string) -> none)
     (define-foreign set-text-align!
       "canvas" "setTextAlign"
       (ref extern) (ref string) -> none)
     (define-foreign clear-rect
       "canvas" "clearRect"
       (ref extern) f64 f64 f64 f64 -> none)
     (define-foreign fill-rect
       "canvas" "fillRect"
       (ref extern) f64 f64 f64 f64 -> none)
     (define-foreign fill-text
       "canvas" "fillText"
       (ref extern) (ref string) f64 f64 -> none)
     (define-foreign draw-image
       "canvas" "drawImage"
       (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
     (define-foreign set-scale!
       "canvas" "setScale"
       (ref extern) f64 f64 -> none)
     (define-foreign set-transform!
       "canvas" "setTransform"
       (ref extern) f64 f64 f64 f64 f64 f64 -> none)
     (define-foreign set-image-smoothing-enabled!
       "canvas" "setImageSmoothingEnabled"
       (ref extern) i32 -> none)

     (define-foreign load-audio
       "audio" "new"
       (ref string) -> (ref extern))
     (define-foreign audio-play
       "audio" "play"
       (ref extern) -> none)
     (define-foreign audio-pause
       "audio" "pause"
       (ref extern) -> none)
     (define-foreign audio-volume
       "audio" "volume"
       (ref extern) -> f64)
     (define-foreign set-audio-volume!
       "audio" "setVolume"
       (ref extern) f64 -> none)
     (define-foreign set-audio-loop!
       "audio" "setLoop"
       (ref extern) i32 -> none)
     (define-foreign audio-seek
       "audio" "seek"
       (ref extern) f64 -> none)

     (define-foreign load-image
       "image" "new"
       (ref string) -> (ref extern))

     ;; 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 (1+ (- (length '(field ...))
                           (length (memq 'field '(field ...)))))))
             (lambda (obj val)
               (match obj
                 (#('name field ...)
                  (vector-set! obj i val))))))
         ...))

     (define (assert-float x)
       (unless (and (number? x) (inexact? x) (rational? x))
         (error "expected inexact rational" x)))
     (define (truncate x)
       (assert-float x)
       (%inline-wasm
        '(func (param $x (ref eq)) (result (ref eq))
               (call $s64->scm
                     (i64.trunc_f64_s
                      (struct.get $flonum $val (ref.cast $flonum (local.get $x))))))
        x))
     (define (fmod x y)
       (assert-float x)
       (assert-float y)
       (%inline-wasm
        '(func (param $x (ref eq)) (param $y (ref eq)) (result (ref eq))
               (struct.new
                $flonum
                (i32.const 0)
                (f64.sub (struct.get
                          $flonum $val
                          (ref.cast $flonum (local.get $x)))
                         (f64.mul
                          (f64.trunc
                           (f64.div
                            (struct.get $flonum $val
                                        (ref.cast $flonum
                                                  (local.get $x)))
                            (struct.get $flonum $val
                                        (ref.cast $flonum
                                                  (local.get $y)))))
                          (struct.get $flonum $val
                                      (ref.cast $flonum
                                                (local.get $y)))))))
        x y))

     (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 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 (assq-ref lst key)
       (match (assq key lst)
         (#f #f)
         ((_ . val) val)))

     (define %jps (inexact (jiffies-per-second)))
     (define (current-time)
       (/ (inexact (current-jiffy)) %jps))

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

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

     ;; splash, play, pause, game-over, game-clear
     (define *game-state* 'splash)

     ;; Screen size stuff
     (define game-width 240.0)
     (define game-height 320.0)

     ;; Elements
     (define canvas (get-element-by-id "canvas"))
     (define context (get-context canvas "2d"))
     (define image:cover (load-image "images/cover.png"))
     (define image:starfield-bg (load-image "images/starfield-bg.png"))
     (define image:starfield-fg (load-image "images/starfield-fg.png"))
     (define image:player (load-image "images/player.png"))
     (define image:player-bullets (load-image "images/player-bullets.png"))
     (define image:enemy-bullets (load-image "images/enemy-bullets.png"))
     (define image:map (load-image "images/map.png"))
     (define image:turret (load-image "images/turret.png"))
     (define image:popcorn (load-image "images/popcorn.png"))
     (define image:flyer0 (load-image "images/flyer0.png"))
     (define image:flyer1 (load-image "images/flyer1.png"))
     (define image:boss (load-image "images/boss.png"))
     (define image:particles (load-image "images/particles.png"))
     (define sound:explosion (load-sound-effect "audio/explosion.wav"))
     (define sound:player-shoot (load-sound-effect "audio/player-shoot.wav"))
     (define sound:player-death (load-sound-effect "audio/player-death.wav"))
     (define sound:enemy-shoot (load-sound-effect "audio/enemy-shoot.wav"))
     (define sound:bullet-hit (load-sound-effect "audio/bullet-hit.wav"))
     (define music (load-audio "audio/music.ogg"))
     (set-audio-loop! music 1)
     (set-audio-volume! music 0.5)
     (define (music-play)
       (audio-play music))
     (define (music-pause)
       (audio-pause music))
     (define (music-stop)
       (audio-pause music)
       (audio-seek music 0.0))

     (define *debug?* #f)

     ;; Scripting
     (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 (make-parameter *scheduler*))
     (define current-script (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)))))))

     ;; Particles:
     (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 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 particles (make-particle-pool 500 image:particles))
     (define (explode 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)))

     ;; Bullets:
     ;; Similar to particles... but different.
     (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)
       (match pool
         (#('bullet-pool length capacity image bullets)
          (let ((dscroll (- *scroll* *last-scroll*)))
            (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)
                    (let ((d 1.0)
                          (l 3))
                      (sound-effect-play sound:bullet-hit 0.02)
                      (particle-pool-add! particles 'hit-wall l x* y* d d)
                      (particle-pool-add! particles 'hit-wall l x* y* (- d) d)
                      (particle-pool-add! particles 'hit-wall l x* y* (- d) (- d))
                      (particle-pool-add! particles 'hit-wall l x* y* d (- d))
                      #t)
                    (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 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))))))

     (define player-bullets (make-bullet-pool 200 image:player-bullets))
     (define enemy-bullets (make-bullet-pool 400 image:enemy-bullets))

     ;; Scrolling level:
     (define *scroll* 0.0)
     (define *last-scroll* 0.0)
     (define *scroll-speed* 0.5)
     (define (change-scroll-speed new-speed duration)
       (run-script
        (lambda ()
          (tween (lambda (speed)
                   (set! *scroll-speed* speed))
                 duration
                 *scroll-speed* new-speed
                 smoothstep lerp))))
     (define *last-row-scanned* 0)
     ;; 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 ,(call-with-input-file "level.scm" read))
     (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 (truncate (/ x tile-width)))
                (ty (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)
       (match level
         (#('level height foreground collision objects)
          (let* ((y (+ y (- (* height tile-height) game-height *scroll*)))
                 (tx0 (truncate (/ x tile-width)))
                 (ty0 (truncate (/ y tile-height)))
                 (tx1 (truncate (/ (+ x w) tile-width)))
                 (ty1 (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 level layer parallax)
       (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 (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 level)
       (match level
         (#('level height foreground collision objects)
          (draw-level-layer level foreground 1.0))))
     (define (do-level-action type x y properties)
       (match type
         ('turret (spawn-turret x y))
         ('popcorn (spawn-popcorn x y))
         ('popcorn-down (spawn-popcorn-down x y))
         ('popcorn-swarm (spawn-popcorn-swarm x y))
         ('popcorn-sweep-left (spawn-popcorn-sweep-left x y))
         ('popcorn-sweep-right (spawn-popcorn-sweep-right x y))
         ('flyer0 (spawn-flyer0 x y))
         ('flyer1 (spawn-flyer1 x y))
         ('flyer1-tunnel (spawn-tunnel-flyer1 x y))
         ('flyer1-down (spawn-flyer1-down x y))
         ('flyer1-down-left (spawn-flyer1-down-left x y))
         ('flyer1-down-right (spawn-flyer1-down-right x y))
         ('boss (spawn-boss x y))
         ('scroll-speed
          (let ((speed (assq-ref properties 'speed))
                (duration (or (assq-ref properties 'duration) 0)))
            (when speed
              (change-scroll-speed speed duration))))
         ('chaser (spawn-chaser x y))
         ('warning (do-warning))
         (_ #t)))
     (define max-scroll (- (* (level-height level) tile-height) game-height))
     (define (level-update! level)
       (match level
         (#('level height foreground collision objects)
          (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll)))
            (set! *last-scroll* *scroll*)
            (set! *scroll* scroll)
            (let ((row (max (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-level-action type x* y* properties)))))
                          (vector-ref objects y)))
              (set! *last-row-scanned* row))))))

     ;; Enemies
     (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)
       (match enemy
         (#('enemy _ _ position size velocity _ _ _ _ _ _)
          (let ((scroll-dy (- *scroll* *last-scroll*)))
            (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity)))
            (set-vec2-y! position (+ (vec2-y position)
                                     (+ (vec2-y velocity) scroll-dy)))))))
     (define (draw-enemy 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 (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)
       (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)
                  (cond
                   ((or (enemy-dead? enemy)
                        (enemy-out-of-bounds? enemy))
                    (when (enemy-dead? enemy)
                      (sound-effect-play sound:explosion)
                      (explode (enemy-x enemy) (enemy-y enemy))
                      (set! *player-score*
                            (+ *player-score* (enemy-points enemy))))
                    (when (eq? (enemy-type enemy) 'boss)
                      (run-script
                       (lambda ()
                         (set! *player-invincible?* #t)
                         (wait 60)
                         (do-game-clear))))
                    (enemy-pool-remove! pool i)
                    (loop i (- k 1)))
                   (else
                    (loop (+ i 1) k))))))))))
     (define (draw-enemies pool time)
       (match pool
         (#('enemy-pool length capacity enemies)
          (do ((i 0 (+ i 1)))
              ((= i length))
            (draw-enemy (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)))))))))

     (define enemies (make-enemy-pool 64))

     (define (spawn-enemy enemy)
       (enemy-pool-add! enemies enemy))

     (define (spawn-popcorn* x y script)
       (spawn-enemy
        (make-enemy 'popcorn 2 (vec2 x y) (vec2 12.0 12.0)
                    (vec2 0.0 0.0) script 100
                    #(0.0 16.0 32.0 48.0) image:popcorn (vec2 16.0 16.0))))

     (define (spawn-turret* x y script)
       (spawn-enemy
        (make-enemy 'turret 10 (vec2 x y) (vec2 12.0 12.0)
                    (vec2 0.0 0.0) script 200
                    #(0.0 16.0 32.0 48.0) image:turret (vec2 16.0 16.0))))

     (define (spawn-flyer0* x y script)
       (spawn-enemy
        (make-enemy 'flyer0 20 (vec2 x y) (vec2 12.0 12.0)
                    (vec2 0.0 0.0) script 500
                    #(0.0 16.0 32.0 48.0) image:flyer0 (vec2 16.0 16.0))))

     (define (spawn-flyer1* x y script)
       (spawn-enemy
        (make-enemy 'flyer1 30 (vec2 x y) (vec2 22.0 16.0)
                    (vec2 0.0 0.0) script 1000
                    #(0.0 24.0 48.0 72.0) image:flyer1 (vec2 24.0 24.0))))

     (define (spawn-turret x y)
       (define (script enemy)
         (let ((speed 3.0))
           (define (current-dir)
             (direction-to-player (enemy-position enemy)))
           (define (shoot dir)
             (bullet-pool-add! enemy-bullets 0
                               (enemy-x enemy)
                               (enemy-y enemy)
                               2.0 2.0
                               (* (vec2-x dir) speed)
                               (* (vec2-y dir) speed)))
           (forever
            (wait 60)
            (let ((dir (current-dir)))
              (shoot dir)
              (wait 5)
              (shoot dir)
              (wait 5)
              (shoot dir)))))
       (spawn-turret* x y script))

     (define (spawn-popcorn x y)
       (define (script popcorn)
         (forever
          (tween (lambda (dy)
                   (set-enemy-dy! popcorn dy))
                 30 -0.2 0.2
                 smoothstep lerp)
          (tween (lambda (dy)
                   (set-enemy-dy! popcorn dy))
                 30 0.2 -0.2
                 smoothstep lerp)))
       (spawn-popcorn* x y script))

     (define (spawn-popcorn-down x y)
       (define (script popcorn)
         (set-enemy-dy! popcorn 1.1))
       (spawn-popcorn* x y script))

     (define (spawn-popcorn-swarm x y)
       (define (script popcorn)
         (forever
          (tween (lambda (dx)
                   (set-enemy-dx! popcorn dx))
                 60 -0.5 0.5
                 smoothstep lerp)
          (tween (lambda (dx)
                   (set-enemy-dx! popcorn dx))
                 60 0.5 -0.5
                 smoothstep lerp)))
       (spawn-popcorn* x y script))

     (define (spawn-popcorn-sweep-left x y)
       (define (script popcorn)
         (set-enemy-dy! popcorn 1.0)
         (tween (lambda (dx)
                  (set-enemy-dx! popcorn dx))
                60 0.0 -3.0
                smoothstep lerp))
       (run-script
        (lambda ()
          (do ((i 0 (+ i 1)))
              ((= i 9))
              (spawn-popcorn* x y script)
              (wait 15)))))

     (define (spawn-popcorn-sweep-right x y)
       (define (script popcorn)
         (set-enemy-dy! popcorn 1.0)
         (tween (lambda (dx)
                  (set-enemy-dx! popcorn dx))
                60 0.0 3.0
                smoothstep lerp))
       (run-script
        (lambda ()
          (do ((i 0 (+ i 1)))
              ((= i 9))
              (spawn-popcorn* x y script)
              (wait 15)))))

     (define (spawn-flyer0 x y)
       (define (script flyer)
         (run-script
          (lambda ()
            (wait 60)
            (let ((speed 1.0))
              (let loop ((i 0.0))
                (let ((theta (+ (* (sin i) (/ pi 3.0)) (/ pi 3.0))))
                  (bullet-pool-add! enemy-bullets 0
                                    (enemy-x flyer)
                                    (enemy-y flyer)
                                    2.0 2.0
                                    (* (cos theta) speed)
                                    (* (sin theta) speed))
                  (wait 5))
                (loop (+ i 0.5))))))
         (let ((speed 0.5))
           (forever
            (tween (lambda (dx)
                     (set-enemy-dx! flyer dx))
                   60 -0.5 0.5
                   smoothstep lerp)
            (tween (lambda (dx)
                     (set-enemy-dx! flyer dx))
                   60 0.5 -0.5
                   smoothstep lerp))))
       (spawn-flyer0* x y script))

     (define (spawn-flyer1 x y)
       (spawn-flyer1* x y #f))

     (define (spawn-tunnel-flyer1 x y)
       (define (script flyer)
         (set-enemy-dy! flyer 1.0)
         (wait 80)
         (set-enemy-dx! flyer -1.0)
         (set-enemy-dy! flyer 0.0)
         (wait 140)
         (set-enemy-dx! flyer 0.0)
         (set-enemy-dy! flyer 1.0))
       (spawn-flyer1* x y script))

     (define (spawn-flyer1-down x y)
       (define (script flyer)
         (define (shoot* theta)
           (let ((speed 3.5))
             (bullet-pool-add! enemy-bullets 0
                               (enemy-x flyer)
                               (enemy-y flyer)
                               2.0 2.0
                               (* (cos theta) speed)
                               (* (sin theta) speed))))
         (define (shoot)
           (shoot* pi/2)
           (shoot* (+ pi/2 0.1))
           (shoot* (- pi/2 0.1)))
         (set-enemy-dy! flyer 1.0)
         (wait 30)
         (forever
          (shoot)
          (wait 5)
          (shoot)
          (wait 5)
          (shoot)
          (wait 45)))
       (spawn-flyer1* x y script))

     (define (spawn-flyer1-down-left x y)
       (define (script flyer)
         (set-enemy-dy! flyer 1.0)
         (wait 60)
         (set-enemy-dx! flyer -1.0)
         (set-enemy-dy! flyer 0.0)
         (wait 60)
         (tween (lambda (dx)
                  (set-enemy-dx! flyer dx))
                30 -1.0 0.0
                smoothstep lerp))
       (spawn-flyer1* x y script))

     (define (spawn-flyer1-down-right x y)
       (define (script flyer)
         (set-enemy-dy! flyer 1.0)
         (wait 60)
         (set-enemy-dx! flyer 1.0)
         (set-enemy-dy! flyer 0.0)
         (wait 60)
         (tween (lambda (dx)
                  (set-enemy-dx! flyer dx))
                30 1.0 0.0
                smoothstep lerp))
       (spawn-flyer1* x y script))

     (define (spawn-chaser x y)
       (define (script flyer)
         (set-enemy-dy! flyer -3.0)
         (wait 30)
         (tween (lambda (dy)
                  (set-enemy-dy! flyer dy))
                30 -3.0 -1.0
                smoothstep lerp)
         (tween (lambda (dy)
                  (set-enemy-dy! flyer dy))
                30 -1.0 -2.9
                smoothstep lerp)
         (wait (* 5 60))
         (tween (lambda (dy)
                  (set-enemy-dy! flyer dy))
                30 -2.9 -1.2
                smoothstep lerp)
         (wait (+ (* 3 60) 30))
         (tween (lambda (dy)
                  (set-enemy-dy! flyer dy))
                30 -1.2 0.0
                smoothstep lerp))
       (spawn-flyer1* x (+ y game-height 8.0) script))

     (define (spawn-boss x y)
       (define (script boss)
         (define (muzzle-flash x y)
           (let ((life 6)
                 (ldx -1.0)
                 (rdx 1.0)
                 (dy 1.0))
             (particle-pool-add! particles 'muzzle-flash life x y ldx dy)
             (particle-pool-add! particles 'muzzle-flash life x y rdx dy)))
         (define (shoot x y dx dy)
           (bullet-pool-add! enemy-bullets 0 x y 2.0 2.0 dx dy))
         (define (xoff dx)
           (+ (enemy-x boss) dx))
         (define (yoff dy)
           (+ (enemy-y boss) dy))
         (define (shoot+flash xo yo dx dy)
           (let ((x (xoff xo))
                 (y (yoff yo)))
             (shoot x y dx dy)
             (muzzle-flash x y)))
         (define main-left-x -43.0)
         (define main-right-x 43.0)
         (define main-y 48.0)
         (define alt-left-x -58.0)
         (define alt-right-x 58.0)
         (define alt-y 28.0)
         (define (shoot-main-left dx dy)
           (shoot+flash main-left-x main-y dx dy))
         (define (shoot-main-right dx dy)
           (shoot+flash main-right-x main-y dx dy))
         (define (shoot-alt-left dx dy)
           (shoot+flash alt-left-x alt-y dx dy))
         (define (shoot-alt-right dx dy)
           (shoot+flash alt-right-x alt-y dx dy))
         (define (player-dir dx dy)
           (let ((p (enemy-position boss)))
             (direction-to-player
              (vec2 (+ (vec2-x p) dx) (+ (vec2-y p) dy)))))
         (define (wait-if duration pred consequent alternate)
           (let loop ((d duration))
             (if (= d 0)
                 (consequent)
                 (begin
                   (wait 1)
                   (if (pred)
                       (loop (- d 1))
                       (alternate))))))
         (define (nop) #f)
         ;; alt guns make Xs across the screen
         ;; main guns shoot at player
         ;; beak shoots spiral
         (define (phase-2)
           (define (pred) (> (enemy-health boss) 500))
           (wait 180)
           (run-script
            (lambda ()
              (let loop ()
               (let ((dx 2.0)
                     (dy 4.0))
                 (do ((i 0 (+ i 1)))
                     ((= i 30))
                   (shoot-alt-left dx dy)
                   (shoot-alt-right (- dx) dy)
                   (wait 4))
                 (wait-if 60 pred loop nop)))))
           (run-script
            (lambda ()
              (wait 120)
              (let loop ()
               (let ((v (player-dir main-left-x main-y)))
                 (vec2-mul-scalar! v 3.5)
                 (do ((i 0 (+ i 1)))
                     ((= i 5))
                   (shoot-alt-left (vec2-x v) (vec2-y v))
                   (wait 4)))
               (wait-if 120 pred loop nop))))
           (run-script
            (lambda ()
              (wait 60)
              (let loop ()
               (let ((v (player-dir main-right-x main-y)))
                 (vec2-mul-scalar! v 3.5)
                 (do ((i 0 (+ i 1)))
                     ((= i 5))
                   (shoot-alt-right (vec2-x v) (vec2-y v))
                   (wait 4)))
               (wait-if 120 pred loop nop))))
           (let ((x (enemy-x boss))
                 (y (+ (enemy-y boss) 48.0))
                 (speed 0.75))
             (let loop ((offset 0.0))
               (do-circle
                (lambda (theta)
                  (let ((theta* (+ theta offset)))
                    (shoot x y (* (cos theta*) speed) (* (sin theta*) speed))))
                3)
               (wait-if 10 pred (lambda () (loop (+ offset 0.3))) phase-3))))
         ;; intense alt fire aimed at player
         ;; half-circle arcs of bullets at player
         (define (phase-3)
           (define (pred) #t)
           (wait 180)
           (run-script
            (lambda ()
              (wait 120)
              (let outer ()
                (let ((v (player-dir alt-left-x alt-y)))
                  (vec2-mul-scalar! v 3.5)
                  (let inner ((i 0))
                    (when (< i 15)
                      (shoot-alt-left (vec2-x v) (vec2-y v))
                      (wait 4)
                      (inner (+ i 1))))
                  (wait-if 10 pred outer nop)))))
           (run-script
            (lambda ()
              (wait 60)
              (let outer ()
                (let ((v (player-dir alt-right-x alt-y)))
                  (vec2-mul-scalar! v 3.5)
                  (let inner ((i 0))
                    (when (< i 15)
                      (shoot-alt-right (vec2-x v) (vec2-y v))
                      (wait 4)
                      (inner (+ i 1))))
                  (wait-if 10 pred outer nop)))))
           (let ((speed 1.0)
                 (k 10))
             (let outer ()
               (let inner ((i 0))
                 (when (<= i k)
                   (let ((theta (* (inexact (/ i k)) pi)))
                     (shoot-main-left (* (cos theta) speed) (* (sin theta) speed))
                     (shoot-main-right (* (cos theta) speed) (* (sin theta) speed))
                     (inner (+ i 1)))))
               (wait-if 60 pred outer nop))))
         ;; alt guns fired aimed shots at player
         ;; main guns shoot spirals
         (define (phase-1)
           (define (pred) (> (enemy-health boss) 1000))
           (run-script
            (lambda ()
              (wait 120)
              (let loop ()
                (let ((v (player-dir alt-left-x alt-y)))
                  (vec2-mul-scalar! v 3.5)
                  (do ((i 0 (+ i 1)))
                      ((= i 5))
                    (shoot-alt-left (vec2-x v) (vec2-y v))
                    (wait 4)))
                (wait-if 120 pred loop nop))))
           (run-script
            (lambda ()
              (wait 60)
              (let loop ()
                (let ((v (player-dir alt-right-x alt-y)))
                  (vec2-mul-scalar! v 3.5)
                  (do ((i 0 (+ i 1)))
                      ((= i 5))
                    (shoot-alt-right (vec2-x v) (vec2-y v))
                    (wait 4)))
                (wait-if 120 pred loop nop))))
           (let ((speed 0.75))
             (let loop ((theta 0.0))
               (let ((dx (* (cos theta) speed))
                     (dy (* (sin theta) speed)))
                 (shoot-main-left dx dy)
                 (shoot-main-right (- dx) dy)
                 (wait-if 5 pred (lambda () (loop (+ theta 0.4))) phase-2)))))
         (wait 180)
         (phase-1))
       (spawn-enemy
        (make-enemy 'boss 1500 (vec2 x (- y 32.0)) (vec2 144.0 50.0)
                    (vec2 0.0 0.0) script 500000
                    #(0.0 144.0 288.0 432.0) image:boss (vec2 144.0 96.0))))

     ;; Player state:
     (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0)))
     (define player-velocity (vec2 0.0 0.0))
     (define *player-tile-x* 0.0)
     (define player-speed 2.9)
     (define player-focus-speed 1.5)
     (define player-bullet-speed 12.3)
     (define player-width 24.0)
     (define player-height 24.0)
     (define *player-fire-counter* 0)
     (define player-fire-interval 3)
     (define player-focus-fire-interval 5)
     (define player-hitbox-position (vec2 0.0 0.0))
     (define player-hitbox-width 2.0)
     (define player-hitbox-height 2.0)
     (define %default-lives 3)
     (define *player-lives* %default-lives)
     (define *player-visible?* #t)
     (define *player-invincible?* #f)
     (define *player-score* 0)
     (define *player-1cc?* #t)
     ;; left, right, down, up, fire, focus
     (define key-state (vector #f #f #f #f #f #f))
     (define (update-player-velocity!)
       (match key-state
         (#(left? right? down? up? _ _)
          (set-vec2-x! player-velocity
                       (+ (if left? -1.0 0.0)
                          (if right? 1.0 0.0)))
          (set-vec2-y! player-velocity
                       (+ (if down? 1.0 0.0)
                          (if up? -1.0 0.0)))
          (vec2-normalize! player-velocity)
          (vec2-mul-scalar! player-velocity
                            (if (focusing?)
                                player-focus-speed
                                player-speed))
          (set! *player-tile-x*
                (* (cond
                    ((and left? (not right?)) 1.0)
                    ((and right? (not left?)) 3.0)
                    (else 0.0))
                   player-width)))))
     (define (set-left! pressed?)
       (vector-set! key-state 0 pressed?)
       (update-player-velocity!))
     (define (set-right! pressed?)
       (vector-set! key-state 1 pressed?)
       (update-player-velocity!))
     (define (set-down! pressed?)
       (vector-set! key-state 2 pressed?)
       (update-player-velocity!))
     (define (set-up! pressed?)
       (vector-set! key-state 3 pressed?)
       (update-player-velocity!))
     (define (firing?)
       (vector-ref key-state 4))
     (define (set-firing! pressed?)
       (let ((was-firing? (firing?)))
         (vector-set! key-state 4 pressed?)
         (when (and pressed? (not was-firing?))
           (set! *player-fire-counter* 0))))
     (define (focusing?)
       (vector-ref key-state 5))
     (define (set-focusing! pressed?)
       (let ((was-focusing? (focusing?)))
         (vector-set! key-state 5 pressed?)
         (update-player-velocity!)
         (when (and pressed? (not was-focusing?))
           (set! *player-fire-counter* 0))))
     (define (player-position-reset!)
       (set-vec2-x! player-position (/ game-width 2.0))
       (set-vec2-y! player-position (- game-height 12.0)))
     (define (do-player-invincible)
       (run-script
        (lambda ()
          (set! *player-invincible?* #t)
          (let ((t 5))
            (let loop ((i 0))
              (when (< i 10)
                (set! *player-visible?* #f)
                (wait t)
                (set! *player-visible?* #t)
                (wait t)
                (loop (+ i 1)))))
          (set! *player-invincible?* #f))))
     (define (player-die!)
       (unless *player-invincible?*
         (sound-effect-play sound:player-death 0.5)
         (explode (vec2-x player-position)
                  (vec2-y player-position))
         (set! *player-lives* (max (- *player-lives* 1) 0))
         (player-position-reset!)
         (do-player-invincible)))
     (define (game-over?)
       (= *player-lives* 0))
     (define (player-update!)
       (define (muzzle-flash x y)
         (let ((life 6)
               (ldx -1.0)
               (rdx 1.0)
               (dy -1.0))
           (particle-pool-add! particles 'muzzle-flash life x y ldx dy)
           (particle-pool-add! particles 'muzzle-flash life x y rdx dy)))
       (let ((old-x (vec2-x player-position))
             (old-y (vec2-y player-position)))
         (vec2-add! player-position player-velocity)
         (vec2-clamp! player-position 0.0 0.0 game-width game-height)
         (let ((x (vec2-x player-position))
               (y (vec2-y player-position))
               (hbx (vec2-x player-hitbox-position))
               (hby (vec2-y player-hitbox-position))
               (hbw player-hitbox-width)
               (hbh player-hitbox-height))
           (if (or (rect-collides-with-level? level x y hbw hbh)
                   (find-enemy enemies x y hbw hbh))
               (begin
                 ;; (set-vec2-x! player-position old-x)
                 ;; (set-vec2-y! player-position
                 ;;              (+ old-y (- *scroll* *last-scroll*)))
                 (player-die!))
               (begin
                 (set-vec2-x! player-hitbox-position (- x (/ hbw 2.0)))
                 (set-vec2-y! player-hitbox-position (- y (/ hbh 2.0)))))))
       (when (firing?)
         (set! *player-fire-counter*
               (modulo (+ *player-fire-counter* 1)
                       (if (focusing?)
                           player-focus-fire-interval
                           player-fire-interval)))
         (when (= *player-fire-counter* 0)
           (sound-effect-play sound:player-shoot 0.2)
           (let ((px (vec2-x player-position))
                 (py (vec2-y player-position)))
             (if (focusing?)
                 (let ((y-off 6.0))
                   (muzzle-flash px (- py y-off))
                   (bullet-pool-add! player-bullets 1
                                     (- px 1.0) py
                                     6.0 6.0
                                     0.0 (- player-bullet-speed)))
                 (let ((hbw 3.0)
                       (hbh 4.0)
                       (lx (- px 6.0))
                       (rx (+ px 8.0))
                       (y (- py 4.0)))
                   (muzzle-flash lx y)
                   (muzzle-flash rx y)
                   (bullet-pool-add! player-bullets 0
                                     lx py
                                     hbw hbh
                                     0.0 (- player-bullet-speed))
                   (bullet-pool-add! player-bullets 0
                                     rx py
                                     hbw hbh
                                     0.0 (- player-bullet-speed)))))
           (set! *player-fire-counter* 0))))
     (define (draw-player)
       (when *player-visible?*
         (draw-image context image:player
                     *player-tile-x* 0.0
                     player-width player-height
                     (- (vec2-x player-position)
                        (/ player-width 2.0))
                     (- (vec2-y player-position)
                        (/ player-height 2.0))
                     player-width player-height))
       (when *debug?*
         (set-fill-color! context "#ff00ff80")
         (fill-rect context
                    (vec2-x player-hitbox-position)
                    (vec2-y player-hitbox-position)
                    player-hitbox-width
                    player-hitbox-height)))
     (define (direction-to-player v)
       (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position))))
         (vec2-sub! v* v)
         (vec2-normalize! v*)
         v*))

     (define (do-splash)
       (music-stop)
       (set! *game-state* 'splash))

     ;; Game over screen state
     (define *countdown* "")
     (define *countdown-scheduler* (make-scheduler 5))
     (define (do-countdown)
       (parameterize ((current-scheduler *countdown-scheduler*))
         (run-script
          (lambda ()
            (let loop ((i 9))
              (set! *countdown* (number->string i))
              (wait 60)
              (unless (= i 0)
                (loop (- i 1))))
            (do-splash)))))
     (define (do-game-over)
       (scheduler-reset! *countdown-scheduler*)
       (music-pause)
       (set! *game-state* 'game-over)
       (do-countdown))
     (define (do-continue)
       (music-play)
       (player-position-reset!)
       (set! *player-lives* 3)
       (set! *player-1cc?* #f)
       (set! *game-state* 'play)
       (do-player-invincible))

     ;; Clear screen state
     (define *clear-show-1cc-bonus?* #f)
     (define *clear-show-life-bonus?* #f)
     (define *clear-show-total-score?* #f)
     (define *clear-1cc-bonus* "")
     (define *clear-life-bonus* "")
     (define *clear-total-score* "")
     (define (do-game-clear)
       (scheduler-reset! *scheduler*)
       (music-stop)
       (set! *game-state* 'game-clear)
       (set! *clear-show-1cc-bonus?* #f)
       (set! *clear-show-life-bonus?* #f)
       (set! *clear-show-total-score?* #f)
       (if *player-1cc?*
           (let ((1cc-bonus 1000000)
                 (life-bonus (* *player-lives* 250000)))
             (set! *player-score* (+ *player-score* 1cc-bonus life-bonus))
             (set! *clear-1cc-bonus* (number->string 1cc-bonus))
             (set! *clear-life-bonus* (number->string life-bonus)))
           (begin
             (set! *clear-1cc-bonus* "0")
             (set! *clear-life-bonus* "0")))
       (set! *clear-total-score* (number->string *player-score*))
       (run-script
        (lambda ()
          (wait 60)
          (set! *clear-show-1cc-bonus?* #t)
          (wait 60)
          (set! *clear-show-life-bonus?* #t)
          (wait 60)
          (set! *clear-show-total-score?* #t))))

     ;; Canvas sizing/scaling.
     (define *canvas-scale* 0.0)
     (define *canvas-width* 0)
     (define *canvas-height* 0)
     (define (resize-canvas)
       (let* ((win (current-window))
              (w (window-inner-width win))
              (h (window-inner-height win))
              (gw (truncate game-width))
              (gh (truncate game-height))
              (scale (max (min (quotient w gw) (quotient h gh)) 1))
              (cw (* gw scale))
              (ch (* gh scale)))
         (set-element-width! canvas cw)
         (set-element-height! canvas ch)
         (set-image-smoothing-enabled! context 0)
         (set! *canvas-scale* (inexact scale))
         (set! *canvas-width* (* game-width *canvas-scale*))
         (set! *canvas-height* (* game-height *canvas-scale*))))

     ;; Boss warning message state
     (define *show-warning?* #f)
     (define (do-warning)
       (run-script
        (lambda ()
          (do ((i 0 (+ i 1)))
              ((= i 10))
            (set! *show-warning?* #t)
            (wait 15)
            (set! *show-warning?* #f)
            (wait 15)))))

     (define (clear-screen)
       (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*))

     (define (draw-player-bullets)
       (draw-bullets player-bullets))

     (define (draw-enemy-bullets)
       (draw-bullets enemy-bullets))

     (define (draw-background image parallax)
       (let ((scroll (fmod (* *scroll* parallax) game-height)))
         ;; Bottom
         (draw-image context image
                     0.0 0.0 game-width (- game-height scroll)
                     0.0 scroll game-width (- game-height scroll))
         ;; Top
         (draw-image context image
                     0.0 (- game-height scroll) game-width scroll
                     0.0 0.0 game-width scroll)))

     (define (draw-hud)
       (let ((y (- game-height 8.0)))
         ;; TODO: Don't allocate strings every frame when the UI
         ;; values rarely change.
         (set-fill-color! context "#ffffff")
         (set-font! context "bold 16px monogram")
         (set-text-align! context "right")
         (fill-text context (string-append "x" (number->string *player-lives*))
                    (- game-width 4.0) y)
         (set-text-align! context "left")
         (fill-text context (number->string *player-score*) 4.0 y)))

     (define (draw-splash time)
       (draw-image context image:cover
                   0.0 0.0 game-width game-height
                   0.0 0.0 game-width game-height)
       (let ((x (/ game-width 2.0))
             (y (+ (- game-height 40.0) (* (sin (* time 2.0)) 4.0))))
         (set-fill-color! context "#ffffff")
         (set-font! context "bold 18px monogram")
         (set-text-align! context "center")
         (fill-text context "Press ENTER to start" x y)))

     (define (draw-play time)
       (draw-background image:starfield-bg 0.3)
       (draw-background image:starfield-fg 0.5)
       (draw-level-foreground level)
       (draw-particles particles)
       (draw-player-bullets)
       (draw-enemies enemies time)
       (draw-player)
       (draw-enemy-bullets)
       (when *show-warning?*
         (set-fill-color! context "#d27d2c")
         (set-text-align! context "center")
         (set-font! context "bold 72px monogram")
         (fill-text context "WARNING"
                    (/ game-width 2.0)
                    (/ game-height 2.0)))
       (draw-hud))

     (define (draw-pause time)
       (draw-background image:starfield-bg 0.3)
       (draw-background image:starfield-fg 0.5)
       (draw-level-foreground level)
       (draw-particles particles)
       (draw-player-bullets)
       (draw-enemies enemies time)
       (draw-player)
       (draw-enemy-bullets)
       (draw-hud)
       (set-fill-color! context "#ffffff")
       (set-font! context "bold 36px monogram")
       (set-text-align! context "center")
       (fill-text context "PAUSED" (/ game-width 2.0) (/ game-height 2.0)))

     (define (draw-game-over time)
       (draw-background image:starfield-bg 0.3)
       (draw-background image:starfield-fg 0.5)
       (draw-level-foreground level)
       (draw-particles particles)
       (draw-enemies enemies time)
       (draw-enemy-bullets)
       (draw-hud)
       (set-fill-color! context "#ffffff")
       (set-font! context "bold 36px monogram")
       (set-text-align! context "center")
       (fill-text context "CONTINUE?"
                  (/ game-width 2.0) (/ game-height 3.0))
       (set-font! context "bold 72px monogram")
       (fill-text context *countdown*
                  (/ game-width 2.0) (+ (/ game-height 3.0) 60.0)))

     (define (draw-game-clear time)
       (draw-background image:starfield-bg 0.3)
       (draw-background image:starfield-fg 0.5)
       (draw-level-foreground level)
       (draw-particles particles)
       (draw-player)
       (set-fill-color! context "#ffffff")
       (set-font! context "bold 36px monogram")
       (set-text-align! context "center")
       (fill-text context "CLEAR" (/ game-width 2.0) (/ game-height 3.0))
       (set-font! context "bold 24px monogram")
       (set-text-align! context "left")
       (when *clear-show-1cc-bonus?*
         (fill-text context "1CC BONUS"
                    16.0
                    (+ (/ game-height 3.0) 40)))
       (when *clear-show-life-bonus?*
         (fill-text context "LIFE BONUS"
                    16.0
                    (+ (/ game-height 3.0) 80)))
       (when *clear-show-total-score?*
         (fill-text context "TOTAL SCORE"
                    16.0
                    (+ (/ game-height 3.0) 120)))
       (set-text-align! context "right")
       (when *clear-show-1cc-bonus?*
         (fill-text context *clear-1cc-bonus*
                    (- game-width 16.0)
                    (+ (/ game-height 3.0) 40)))
       (when *clear-show-life-bonus?*
         (fill-text context *clear-life-bonus*
                    (- game-width 16.0)
                    (+ (/ game-height 3.0) 80)))
       (when *clear-show-total-score?*
         (fill-text context *clear-total-score*
                    (- game-width 16.0)
                    (+ (/ game-height 3.0) 120))))

     (define (draw _prev-time)
       (let ((time (current-time)))
         (clear-screen)
         (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
         (set-scale! context *canvas-scale* *canvas-scale*)
         (set-fill-color! context "#140c1c")
         (fill-rect context 0.0 0.0 game-width game-height)
         (let ((draw* (match *game-state*
                        ('splash draw-splash)
                        ('play draw-play)
                        ('pause draw-pause)
                        ('game-over draw-game-over)
                        ('game-clear draw-game-clear))))
           (draw* time))
         (request-animation-frame draw)))

     (define (reset!)
       (music-stop)
       (music-play)
       (set! *game-state* 'play)
       (scheduler-reset! *scheduler*)
       (set! *scroll* 0.0)
       ;; (set! *scroll* (* 440.0 tile-height))
       (set! *last-scroll* 0.0)
       (set! *last-row-scanned* (level-height level))
       ;; (set! *last-row-scanned* (- (level-height level)
       ;;                             440))
       (bullet-pool-reset! player-bullets)
       (bullet-pool-reset! enemy-bullets)
       (enemy-pool-reset! enemies)
       (particle-pool-reset! particles)
       (player-position-reset!)
       (set! *player-tile-x* 0.0)
       (set! *player-lives* %default-lives)
       (set! *player-invincible?* #f)
       (set! *player-visible?* #t)
       (set! *player-fire-counter* 0)
       (set! *player-score* 0)
       (set! *player-1cc?* #t))

     (define (on-key-down event)
       (let ((code (keyboard-event-code event)))
         (cond
          ((string-=? code "ArrowLeft")
           (set-left! #t)
           (prevent-default! event))
          ((string-=? code "ArrowRight")
           (set-right! #t)
           (prevent-default! event))
          ((string-=? code "ArrowDown")
           (set-down! #t)
           (prevent-default! event))
          ((string-=? code "ArrowUp")
           (set-up! #t)
           (prevent-default! event))
          ((string-=? code "KeyZ")
           (set-firing! #t)
           (prevent-default! event))
          ((string-=? code "KeyX";; "ShiftLeft"
                      )
           (set-focusing! #t)
           (prevent-default! event)))))

     (define (on-key-up event)
       (let ((code (keyboard-event-code event)))
         (cond
          ((string-=? code "ArrowLeft")
           (set-left! #f)
           (prevent-default! event))
          ((string-=? code "ArrowRight")
           (set-right! #f)
           (prevent-default! event))
          ((string-=? code "ArrowDown")
           (set-down! #f)
           (prevent-default! event))
          ((string-=? code "ArrowUp")
           (set-up! #f)
           (prevent-default! event))
          ((string-=? code "KeyZ")
           (set-firing! #f)
           (prevent-default! event))
          ((string-=? code "KeyX";; "ShiftLeft"
                      )
           (set-focusing! #f)
           (prevent-default! event))
          (else
           (match *game-state*
             ('splash
              (when (string-=? code "Enter")
                (reset!)
                (set! *game-state* 'play)))
             ('play
              (cond
               ((string-=? code "Enter")
                (set! *game-state* 'pause)
                (music-pause)
                (prevent-default! event))
               ((string-=? code "KeyD")
                (set! *debug?* (not *debug?*))
                (prevent-default! event))
               ((string-=? code "KeyR")
                (reset!)
                (prevent-default! event))
               ((string-=? code "KeyW")
                (do-game-clear)
                (prevent-default! event))
               ((string-=? code "KeyO")
                (do-game-over)
                (prevent-default! event))))
             ('pause
              (cond
               ((string-=? code "Enter")
                (set! *game-state* 'play)
                (music-play)
                (prevent-default! event))))
             ('game-clear
              (cond
               ((string-=? code "Enter")
                (do-splash)
                (prevent-default! event))))
             ('game-over
              (cond
               ((string-=? code "Enter")
                (do-continue)
                (prevent-default! event))))
             (_ #t))))))

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

     (define (player-bullet-collide type x y w h)
       (let ((x* (- x (/ w 2.0)))
             (y* (- y(/ h 2.0))))
         (or (rect-collides-with-level? level x* y* w h)
             (let ((enemy (find-enemy enemies x y w h)))
               (and enemy
                    (begin
                      (enemy-damage! enemy
                                     (case type
                                       ((0) 1)
                                       ((1) 3)))
                      #t))))))

     (define (enemy-bullet-collide type x y w h)
       (let ((x* (- x (/ w 2.0)))
             (y* (- y(/ h 2.0))))
         (or (out-of-bounds? x* y* w h)
             ;; (rect-collides-with-level? level x* y* w h)
             (if (rect-collides-with-level? level x* y* w h)
                 (begin
                   (sound-effect-play sound:bullet-hit 0.01)
                   #t)
                 #f)
             (if (rect-within? x y w h
                               (vec2-x player-hitbox-position)
                               (vec2-y player-hitbox-position)
                               player-hitbox-width
                               player-hitbox-height)
                 (begin
                   (player-die!)
                   #t)
                 #f))))

     (define dt (/ 1000.0 60.0))
     (define (update)
       (match *game-state*
         ('play
          (scheduler-tick! *scheduler*)
          (level-update! level)
          (player-update!)
          (bullet-pool-update! player-bullets player-bullet-collide)
          (bullet-pool-update! enemy-bullets enemy-bullet-collide)
          (enemy-pool-update! enemies)
          (particle-pool-update! particles)
          (when (game-over?)
            (do-game-over)))
         ('game-over
          (set! *scroll* *last-scroll*)
          (scheduler-tick! *countdown-scheduler*))
         ('game-clear
          (scheduler-tick! *scheduler*)
          (bullet-pool-update! player-bullets player-bullet-collide)
          (bullet-pool-update! enemy-bullets enemy-bullet-collide)
          (particle-pool-update! particles))
         (_ #t))
       (timeout update dt))

     (add-event-listener! (current-window) "resize" (lambda (_) (resize-canvas)))
     (add-event-listener! (current-document) "keydown" on-key-down)
     (add-event-listener! (current-document) "keyup" on-key-up)
     (resize-canvas)
     (request-animation-frame draw)
     (timeout update dt)))

(call-with-output-file "game.wasm"
  (lambda (port)
    (put-bytevector port (assemble-wasm (compile src)))))