path: root/game.scm

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

  ;; 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 (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 (and (exact? x) (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-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))))

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

  (define game-width 240.0)
  (define game-height 320.0)
  (define canvas-scale 2.0)
  (define canvas-width (* game-width canvas-scale))
  (define canvas-height (* game-height canvas-scale))
  (define canvas (get-element-by-id "canvas"))
  (define context (get-context canvas "2d"))
  (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"))

  ;; 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* (make-scheduler 100))
  (define %script-tag (make-prompt-tag "script"))
  (define (run-script thunk)
    (define (run thunk)
      (call-with-prompt %script-tag thunk handler))
    (define (handler k delay)
      (when delay
        (scheduler-add! *scheduler* (lambda () (run k)) delay)))
    (run
     (lambda ()
       (thunk)
       ;; 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 (wait delay)
    (abort-to-prompt %script-tag delay))

  ;; Bullets:
  ;; per bullet: type, x, y, dx, dy
  (define %bullet-size (+ 4 8 8 8 8))
  (define (make-bullet-pool capacity)
    (let ((pool (make-bytevector (* capacity %bullet-size))))
      (vector 0 capacity pool)))
  (define (bullet-pool-offset i)
    (* i %bullet-size))
  (define (bullet-pool-add! pool type x y dx dy)
    (match 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)
         (vector-set! pool 0 (+ length 1))))))
  (define (bullet-pool-remove! pool i)
    (match 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))
           (vector-set! pool 0 (- length 1)))))))
  (define (bullet-pool-update! pool collide)
    (match 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
      (#(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* 1.0)
  (define (update-scroll!)
    (set! *scroll* (+ *scroll* *scroll-speed*)))
  ;; sprite sheet offset, x, y
  (define %tile-size (+ 8 8 8))
  (define tile-width 16.0)
  (define tile-height 16.0)
  (define level-width 15)
  (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
                                  ('_ -1.0)
                                  ('X 0.0)
                                  ('\ 1.0)
                                  ('/ 2.0)))
                             (offset (* (+ x (* y level-width)) %tile-size)))
                         (f64-set! bv offset n)
                         (f64-set! bv (+ offset 8)
                                   (* (inexact x) tile-width))
                         (f64-set! bv (+ offset 16)
                                   (* (inexact y) tile-height)))
                       (x-loop rest (+ x 1))))
                    tiles))
              (+ y 1)))))
        (vector (/ 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
    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
      (#(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
      (#(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)) 0.0)))
         (or (occupied? tx0 ty0)
             (occupied? tx1 ty0)
             (occupied? tx1 ty1)
             (occupied? tx0 ty1))))))
  (define (draw-tiles level)
    (match 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-width y) x) %tile-size))
                    (t (f64-ref tiles offset))
                    (tx (f64-ref tiles (+ offset 8)))
                    (ty (f64-ref tiles (+ offset 16))))
               (draw-image context image:map
                           (* t tw) 0.0 tw th
                           tx (- ty pixel-y-offset) tw th))))))))

  ;; Enemies:
  ;; length, capacity, pool
  ;; enemy: type, health, x, y, w, h, dx, dy
  (define %enemy-size (+ 4 4 8 8 8 8 8 8))
  (define (make-enemy-pool capacity)
    (let ((enemies (make-bytevector (* capacity %enemy-size))))
      (vector 0 capacity enemies)))
  (define (enemy-pool-offset i)
    (* i %enemy-size))
  (define (enemy-pool-add! pool type hp x y w h dx dy)
    (match pool
      (#(length capacity enemies)
       (unless (= length capacity)
         (let ((offset (enemy-pool-offset length)))
           (s32-set! enemies offset type)
           (s32-set! enemies (+ offset 4) hp)
           (f64-set! enemies (+ offset 8) x)
           (f64-set! enemies (+ offset 16) y)
           (f64-set! enemies (+ offset 24) w)
           (f64-set! enemies (+ offset 32) h)
           (f64-set! enemies (+ offset 40) dx)
           (f64-set! enemies (+ offset 48) dy)
           (vector-set! pool 0 (+ length 1)))))))
  (define (enemy-pool-remove! pool i)
    (match pool
      (#(length capacity enemies)
       (when (and (>= i 0) (< i length))
         (let ((at (enemy-pool-offset i))
               (start (enemy-pool-offset (- length 1))))
           (bytevector-copy! enemies at enemies start (+ start %enemy-size))
           (vector-set! pool 0 (- length 1)))))))
  (define (enemy-pool-update! pool collide)
    (match pool
      (#(length capacity enemies)
       (let ((padding 16.0))
         (let loop ((i 0) (k length))
           (unless (= i k)
             (let* ((offset (enemy-pool-offset i))
                    (hp (s32-ref enemies (+ offset 4)))
                    (x (f64-ref enemies (+ offset 8)))
                    (y (f64-ref enemies (+ offset 16)))
                    (w (f64-ref enemies (+ offset 24)))
                    (h (f64-ref enemies (+ offset 32)))
                    (dx (f64-ref enemies (+ offset 40)))
                    (dy (f64-ref enemies (+ offset 48)))
                    (x* (+ x dx))
                    (y* (+ y dy)))
               (let ((new-hp (collide x y w h hp)))
                 (cond
                  ((or (<= hp 0)
                       (out-of-bounds? x* y* w h))
                   (enemy-pool-remove! pool i)
                   (loop i (- k 1)))
                  (else
                   (s32-set! enemies (+ offset 4) new-hp)
                   (f64-set! enemies (+ offset 8) x*)
                   (f64-set! enemies (+ offset 16) y*)
                   (loop (+ i 1) k)))))))))))
  (define (draw-enemies pool)
    (match pool
      (#(length capacity enemies)
       (do ((i 0 (+ i 1)))
           ((= i length))
         (let* ((offset (enemy-pool-offset i))
                (t (s32-ref enemies offset))
                (x (f64-ref enemies (+ offset 8)))
                (y (f64-ref enemies (+ offset 16)))
                (hbw (f64-ref enemies (+ offset 24)))
                (hbh (f64-ref enemies (+ offset 32)))
                (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 "#ff00ff")
           (fill-rect context
                      (- x (/ hbw 2.0))
                      (- y (/ hbh 2.0))
                      hbw hbh))))))
  (define (find-enemy pool x y w h)
    (match pool
      (#(length capacity enemies)
       (let loop ((i 0))
         (and (< i length)
              (let* ((offset (enemy-pool-offset i))
                     (w* (f64-ref enemies (+ offset 24)))
                     (h* (f64-ref enemies (+ offset 32)))
                     (x* (- (f64-ref enemies (+ offset 8))
                            (/ w* 2.0)))
                     (y* (- (f64-ref enemies (+ offset 16))
                            (/ h* 2.0))))
                (if (rect-within? x y w h x* y* w* h*)
                    i
                    (loop (+ i 1)))))))))
  (define (damage-enemy! pool i damage)
    (match pool
      (#(length capacity enemies)
       (when (and (>= i 0) (< i length))
         (let* ((offset (enemy-pool-offset i))
                (hp (s32-ref enemies (+ offset 4))))
           (s32-set! enemies (+ offset 4) (- hp damage)))))))

  (define enemies (make-enemy-pool 64))
  (enemy-pool-add! enemies 0 20 70.0 100.0 16.0 16.0 0.0 0.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-speed 4.0)
  (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!)
    (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 (not *player-invincible?*)
               (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!)))
  (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 "#ff00ff")
    (fill-rect context
               (vec2-x player-hitbox-position)
               (vec2-y player-hitbox-position)
               player-hitbox-width
               player-hitbox-height))

  (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 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 demichrome0)
    (fill-rect context 0.0 0.0 game-width game-height)
    (draw-tiles level)
    ;; (draw-tiles level 0.0)
    (draw-player-bullets)
    (draw-enemies enemies)
    (draw-player)
    (draw-enemy-bullets)
    (request-animation-frame draw))

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

  (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 16.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-id (find-enemy enemies x y w h)))
            (and enemy-id
                 (begin
                   (damage-enemy! enemies enemy-id 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-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 (enemy-collide x y w h hp)
    hp)

  (define dt (/ 1000.0 60.0))
  (define (update)
    (scheduler-tick! *scheduler*)
    (update-scroll!)
    (player-update!)
    (bullet-pool-update! player-bullets player-bullet-collide)
    (bullet-pool-update! enemy-bullets enemy-bullet-collide)
    (enemy-pool-update! enemies enemy-collide)
    (when (firing?)
      (set! *player-fire-counter*
            (modulo (+ *player-fire-counter* 1) player-fire-interval))
      (when (= *player-fire-counter* 0)
        (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)))
    (timeout update dt))

  ;; Temp hacky scripts
  (run-script
   (lambda ()
     (let ((ox 70.0)
           (oy 100.0)
           (speed 2.0))
       (let loop ((theta 0.0))
         (let ((dx (* (cos theta) speed))
               (dy (* (sin theta) speed)))
           (bullet-pool-add! enemy-bullets 0 ox oy dx dy))
         (wait 2)
         (loop (+ theta 0.2))))))

  (set-element-width! canvas (trunc canvas-width))
  (set-element-height! canvas (trunc canvas-height))
  (add-event-listener! (current-document) "keydown" on-key-down)
  (add-event-listener! (current-document) "keyup" on-key-up)
  (set-image-smoothing-enabled! context 0)
  (request-animation-frame draw)
  (timeout update dt))