path: root/game.scm

(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 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 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 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-volume
    "audio" "volume"
    (ref extern) -> f64)
  (define-foreign set-audio-volume!
    "audio" "setVolume"
    (ref extern) f64 -> none)

  ;; TODO: Add basic fmod as inline wasm function

  ;; Hoot's exact and inexact aren't working right.  These next two
  ;; procedures are alternatives for now.
  (define (trunc x)
    ;; rational? is also borked so can't use that here.
    (unless (and (number? x) (inexact? x))
      (error "expected inexact rational" 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 (inexact x)
    (unless (exact-integer? x)
      (error "expected exact integer" x))
    (%inline-wasm
     '(func (param $x (ref eq)) (result (ref eq))
            (if (ref eq)
                (call $fixnum? (local.get $x))
                (then
                 (struct.new $flonum
                             (i32.const 0)
                             (f64.convert_i32_s
                              (call $fixnum->i32 (ref.cast i31 (local.get $x))))))
                (else
                 (struct.new $flonum
                             (i32.const 0)
                             (f64.convert_i64_s
                              (call $bignum-get-i64
                                    (struct.get $bignum $val
                                                (ref.cast $bignum (local.get $x)))))))))
     x))

  (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 (clamp x min max)
    (cond ((< x min) min)
          ((> x max) max)
          (else x)))

  (define (vec2 x y)
    (let ((v (make-bytevector 16)))
      (set-vec2-x! v x)
      (set-vec2-y! v y)
      v))
  (define (vec2-x v)
    (f64-ref v 0))
  (define (vec2-y v)
    (f64-ref v 8))
  (define (set-vec2-x! v x)
    (f64-set! v 0 x))
  (define (set-vec2-y! v y)
    (f64-set! 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)))))))

  (define demichrome0 "#211e20")
  (define demichrome1 "#555568")
  (define demichrome2 "#a0a08b")
  (define demichrome3 "#e9efec")

  ;; 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:background (get-element-by-id "image-background"))
  (define image:player (get-element-by-id "image-player"))
  (define image:player-bullet (get-element-by-id "image-player-bullet"))
  (define image:enemy-bullets (get-element-by-id "image-enemy-bullets"))
  (define image:map (get-element-by-id "image-map"))
  (define image:enemies (get-element-by-id "image-enemies"))
  (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-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))))))
      ...))

  ;; 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 %script-tag (make-prompt-tag "script"))
  (define-type script
    %make-script
    script?
    (state script-state set-script-state!)
    (cont script-cont set-script-cont!))
  (define (make-script thunk)
    (%make-script '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))
  (define (script-run! script)
    (define (run thunk)
      (unless (script-cancelled? script)
        (call-with-prompt %script-tag thunk handler)))
    (define (handler k delay)
      (when delay
        (scheduler-add! *scheduler* (lambda () (run k)) delay)))
    (when (script-pending? script)
      (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))

  ;; Bullets:
  (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!)
    (bullets bullet-pool-bullets set-bullet-pool-bullets!))
  ;; per bullet: type, x, y, dx, dy
  (define %bullet-size (+ 4 8 8 8 8))
  (define (make-bullet-pool capacity)
    (let ((bullets (make-bytevector (* capacity %bullet-size))))
      (%make-bullet-pool 0 capacity bullets)))
  (define (bullet-pool-offset i)
    (* i %bullet-size))
  (define (bullet-pool-add! pool type x y dx dy)
    (match pool
      (#('bullet-pool length capacity bullets)
       (let ((offset (bullet-pool-offset length)))
         (s32-set! bullets offset type)
         (f64-set! bullets (+ offset 4) x)
         (f64-set! bullets (+ offset 12) y)
         (f64-set! bullets (+ offset 20) dx)
         (f64-set! bullets (+ offset 28) dy)
         (set-bullet-pool-length! pool (+ length 1))))))
  (define (bullet-pool-remove! pool i)
    (match pool
      (#('bullet-pool length capacity 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 bullets)
       (let loop ((i 0) (k length))
         (when (< i k)
           (let* ((offset (bullet-pool-offset i))
                  (x (f64-ref bullets (+ offset 4)))
                  (y (f64-ref bullets (+ offset 12)))
                  (dx (f64-ref bullets (+ offset 20)))
                  (dy (f64-ref bullets (+ offset 28)))
                  (x* (+ x dx))
                  (y* (+ y dy)))
             (cond
              ;; TODO: different bullet hitbox sizes.
              ((collide x y 2.0 2.0)
               (bullet-pool-remove! pool i)
               (loop i (- k 1)))
              (else
               (f64-set! bullets (+ offset 4) x*)
               (f64-set! bullets (+ offset 12) y*)
               (loop (+ i 1) k)))))))))
  (define (draw-bullets pool image w h)
    (match pool
      (#('bullet-pool length capacity bullets)
       (do ((i 0 (+ i 1)))
           ((= i length))
         (let* ((offset (bullet-pool-offset i))
                (type (s32-ref bullets offset))
                (x (f64-ref bullets (+ offset 4)))
                (y (f64-ref bullets (+ offset 12))))
           (draw-image context image (* type w) (* type h) w h
                       (- x (/ w 2.0)) (- y (/ w 2.0)) w h))))))

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

  ;; Scrolling level:
  (define *scroll* 0.0)
  (define *scroll-speed* 0.5)
  (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
    %make-level
    level?
    (height level-height set-level-height!)
    (tiles level-tiles set-level-tiles!))
  (define (make-level tiles)
    (let ((k (length tiles)))
      (unless (= (modulo k level-width) 0)
        (error "incomplete level data"))
      (let ((bv (make-bytevector (* k %tile-size))))
        (let y-loop ((tiles tiles) (y 0))
          (match tiles
            (() #t)
            (tiles
             (y-loop
              (let x-loop ((tiles tiles) (x 0))
                (if (< x level-width)
                    (match tiles
                      ((t . rest)
                       (let ((n (match t
                                  ('X 0.0)
                                  ('\ 1.0)
                                  ('/ 2.0)
                                  (_ -1.0)))
                             (action (match t
                                       ('A 1)
                                       (_ 0)))
                             (offset (* (+ x (* y level-width)) %tile-size)))
                         (s32-set! bv offset action)
                         (f64-set! bv (+ offset 4) n)
                         (f64-set! bv (+ offset 12)
                                   (* (inexact x) tile-width))
                         (f64-set! bv (+ offset 20)
                                   (* (inexact y) tile-height)))
                       (x-loop rest (+ x 1))))
                    tiles))
              (+ y 1)))))
        (%make-level (/ k level-width) bv))))
  (define-syntax-rule (define-level name tile ...)
    (define name (make-level '(tile ...))))
  (define-level level
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X _ _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X _ _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X _ _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X A _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X _ _ _ _ _ _ _ _ A X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X A _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X _ _ _ _ _ _ _ _ A X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X X X A _ _ _ _ _ _ _ _ X X X
    X X _ _ _ _ _ _ _ _ _ _ _ X X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ X X X _ _ _ _ _ X
    X _ _ _ _ _ X X X _ _ _ _ _ X
    X _ _ _ _ _ X X X _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
    X \ _ _ _ _ _ _ _ _ _ _ _ / X
    X X \ _ _ _ _ _ _ _ _ _ / X X
    X X X \ _ _ _ _ _ _ _ / X X X)
  (define (level-offset x y)
    (* (+ (* level-width y) x) %tile-size))
  (define (point-collides-with-level? level x y)
    (match level
      (#('level height tiles)
       (let ((tx (trunc (/ x tile-width)))
             (ty (trunc (/ y tile-height))))
         (and (>= tx 0) (< tx level-width)
              (>= ty 0) (< tx height)
              (>= (f64-ref tiles (level-offset tx ty)) 0))))))
  (define (rect-collides-with-level? level x y w h)
    (match level
      (#('level height tiles)
       (let* ((y (+ y (- (* height tile-height) game-height *scroll*)))
              (tx0 (trunc (/ x tile-width)))
              (ty0 (trunc (/ y tile-height)))
              (tx1 (trunc (/ (+ x w) tile-width)))
              (ty1 (trunc (/ (+ y h) tile-height))))
         (define (occupied? x y)
           (and (>= x 0) (< x level-width)
                (>= y 0) (< x height)
                (>= (f64-ref tiles (+ (level-offset x y) 4)) 0.0)))
         (or (occupied? tx0 ty0)
             (occupied? tx1 ty0)
             (occupied? tx1 ty1)
             (occupied? tx0 ty1))))))
  (define (draw-tiles level)
    (match level
      (#('level height tiles)
       (let* ((tw tile-width)
              (th tile-height)
              (pixel-y-offset (- (* height th) *scroll* game-height))
              (scroll-y-offset (- height (trunc (/ *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))
           (do ((x 0 (+ x 1)))
               ((= x level-width))
             (let* ((offset (level-offset x y))
                    (t (f64-ref tiles (+ offset 4)))
                    (tx (f64-ref tiles (+ offset 12)))
                    (ty (f64-ref tiles (+ offset 20))))
               (draw-image context image:map
                           (* t tw) 0.0 tw th
                           tx (- ty pixel-y-offset) tw th))))))))
  (define max-scroll (- (* (level-height level) tile-height) game-height))
  (define (level-update! level)
    (match level
      (#('level height tiles)
       (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll)))
         (set! *scroll* scroll)
         (let ((row (max (- (trunc
                             (/ (- (* height tile-height)
                                   game-height scroll)
                                tile-height)) 2)
                         0)))
           (do ((y row (+ y 1)))
               ((= y *last-row-scanned*))
             (do ((x 0 (+ x 1)))
                 ((= x level-width))
               (case (s32-ref tiles (level-offset x y))
                 ((0) #t)
                 ((1)
                  (spawn-enemy-a (+ (* x tile-width)
                                    (/ tile-width 2.0))
                                 (+ (* (- row y 3) tile-height)
                                    (/ tile-height 2.0)))))))
           (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!)
    (stationary? enemy-stationary? set-enemy-stationary!)
    (velocity enemy-velocity set-enemy-velocity!)
    (script enemy-script set-enemy-script!))
  (define (enemy-x enemy)
    (vec2-x (enemy-position enemy)))
  (define (enemy-y enemy)
    (vec2-y (enemy-position enemy)))
  (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 (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 stationary? velocity _)
       (if stationary?
           (set-vec2-y! position (+ (vec2-y position) *scroll-speed*))
           (begin
             (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity)))
             (set-vec2-y! position (+ (vec2-y position) (vec2-y velocity))))))))
  (define (enemy-draw enemy)
    (match enemy
      (#('enemy type _ position size _ _ _)
       (let* ((t 0.0)
              (x (vec2-x position))
              (y (vec2-y position))
              (hbw (vec2-x size))
              (hbh (vec2-y size))
              (w 64.0)
              (h 64.0))
         (draw-image context image:enemies (* t w) (* t h) w h
                     (- x (/ w 2.0)) (- y (/ h 2.0)) w h)
         (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))
                 (sound-effect-play sound:explosion)
                 (enemy-pool-remove! pool i)
                 (loop i (- k 1)))
                (else
                 (loop (+ i 1) k))))))))))
  (define (draw-enemies pool)
    (match pool
      (#('enemy-pool length capacity enemies)
       (do ((i 0 (+ i 1)))
           ((= i length))
         (enemy-draw (vector-ref enemies i))))))
  (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-a x y)
    (define (script enemy)
      (let ((speed 2.0))
        (let loop ((theta 0.0))
          (let ((dx (* (cos theta) speed))
                (dy (* (sin theta) speed))
                (v (direction-to-player (enemy-position enemy))))
            (bullet-pool-add! enemy-bullets 0
                              (enemy-x enemy)
                              (enemy-y enemy)
                              (* (vec2-x v) speed)
                              (* (vec2-y v) speed)))
          (wait 30)
          (loop (+ theta 0.2)))))
    (let ((enemy (make-enemy 'foo 20 (vec2 x y) (vec2 16.0 16.0)
                             #t (vec2 0.0 0.0) script)))
      (enemy-pool-add! enemies enemy)))

  ;; Player state:
  (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0)))
  (define player-velocity (vec2 0.0 0.0))
  (define player-speed 2.9)
  (define player-bullet-speed 12.0)
  (define player-width 24.0)
  (define player-height 24.0)
  (define *player-fire-counter* 0)
  (define player-fire-interval 3)
  (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)
  ;; left, right, down, up, fire
  (define key-state (vector #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 player-speed))))
  (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 (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 (firing?)
    (vector-ref key-state 4))
  (define (player-die!)
    (unless *player-invincible?*
      ;; (sound-effect-play sound:player-death)
      (set! *player-lives* (max (- *player-lives* 1) 0))
      (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 (game-over?)
    (= *player-lives* 0))
  (define (player-update!)
    (vec2-add! player-position player-velocity)
    (vec2-clamp! player-position 0.0 0.0 game-width game-height)
    (set-vec2-x! player-hitbox-position
                 (- (vec2-x player-position)
                    (/ player-hitbox-width 2.0)))
    (set-vec2-y! player-hitbox-position
                 (- (vec2-y player-position)
                    (/ player-hitbox-height 2.0)))
    (when (and (let ((x (vec2-x player-hitbox-position))
                     (y (vec2-y player-hitbox-position))
                     (w player-hitbox-width)
                     (h player-hitbox-height))
                 (or (rect-collides-with-level? level x y w h)
                     (find-enemy enemies x y w h))))
      (player-die!))
    (when (firing?)
      (set! *player-fire-counter*
            (modulo (+ *player-fire-counter* 1) player-fire-interval))
      (when (= *player-fire-counter* 0)
        (sound-effect-play sound:player-shoot 0.5)
        (bullet-pool-add! player-bullets 0
                          (- (vec2-x player-position) 6.0)
                          (vec2-y player-position)
                          0.0 (- player-bullet-speed))
        (bullet-pool-add! player-bullets 0
                          (+ (vec2-x player-position) 8.0)
                          (vec2-y player-position)
                          0.0 (- player-bullet-speed))
        (set! *player-fire-counter* 0))))
  (define (draw-player)
    (draw-image context image:player
                (if *player-visible?* 0.0 player-width) 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)
    (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 *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 (trunc game-width))
           (gh (trunc 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*))))

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

  (define (draw-player-bullets)
    (draw-bullets player-bullets image:player-bullet 8.0 8.0))

  (define (draw-enemy-bullets)
    (draw-bullets enemy-bullets image:enemy-bullets 16.0 16.0))

  (define (draw-background image parallax)
    (let ((scroll (remainder (* *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 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 "#3f2832")
    (fill-rect context 0.0 0.0 game-width game-height)
    (draw-background image:background 0.75)
    (draw-tiles level)
    (draw-player-bullets)
    (draw-enemies enemies)
    (draw-player)
    (draw-enemy-bullets)
    (request-animation-frame draw))

  (define (reset!)
    (scheduler-reset! *scheduler*)
    (set! *scroll* 0.0)
    (set! *last-row-scanned* (level-height level))
    (bullet-pool-reset! player-bullets)
    (bullet-pool-reset! enemy-bullets)
    (enemy-pool-reset! enemies)
    (set-vec2-x! player-position (/ game-width 2.0))
    (set-vec2-y! player-position (- game-height 12.0))
    (set! *player-lives* %default-lives)
    (set! *player-invincible?* #f)
    (set! *player-visible?* #t)
    (set! *player-fire-counter* 0))

  (define (on-key-down event)
    (let ((code (keyboard-event-code event)))
      (cond
       ((string-=? code "ArrowLeft")
        (set-left! #t))
       ((string-=? code "ArrowRight")
        (set-right! #t))
       ((string-=? code "ArrowDown")
        (set-down! #t))
       ((string-=? code "ArrowUp")
        (set-up! #t))
       ((string-=? code "KeyZ")
        (set-firing! #t))
       ((string-=? code "KeyR")
        (reset!)))))

  (define (on-key-up event)
    (let ((code (keyboard-event-code event)))
      (cond
       ((string-=? code "ArrowLeft")
        (set-left! #f))
       ((string-=? code "ArrowRight")
        (set-right! #f))
       ((string-=? code "ArrowDown")
        (set-down! #f))
       ((string-=? code "ArrowUp")
        (set-up! #f))
       ((string-=? code "KeyZ")
        (set-firing! #f)))))

  (define (out-of-bounds? x y w h)
    (let ((padding 32.0))
      (not (rect-within? x y w h (- padding) (- padding)
                         (+ game-width padding) (+ game-height padding)))))

  (define (player-bullet-collide 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)
          (let ((enemy (find-enemy enemies x y w h)))
            (and enemy
                 (begin
                   (enemy-damage! enemy 1)
                   #t))))))

  (define (enemy-bullet-collide 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.1)
          ;;       #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)
    (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)
    (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)
  (reset!)
  (request-animation-frame draw)
  (timeout update dt))