path: root/game.scm

(import (scheme base)
        (only (scheme inexact) cos sin)
        (scheme time)
        (only (hoot bytevectors)
              bytevector-s32-native-ref
              bytevector-s32-native-set!
              bytevector-ieee-double-native-ref
              bytevector-ieee-double-native-set!)
        (only (hoot control)
              make-prompt-tag
              abort-to-prompt
              call-with-prompt)
        (hoot debug)
        (hoot ffi)
        (hoot match)
        (only (hoot syntax) define-syntax-rule define*)
        (strigoform audio)
        (strigoform assets)
        (strigoform bullets)
        (strigoform canvas)
        (strigoform document)
        (strigoform element)
        (strigoform enemies)
        (strigoform event)
        (strigoform game-area)
        (strigoform image)
        (strigoform math)
        (strigoform level)
        (strigoform level-1)
        (strigoform particles)
        (strigoform scripts)
        (strigoform time)
        (strigoform window))

;; Global game state:
;; splash, play, pause, game-over, game-clear
(define *game-state* 'splash)
(define *debug?* #f)

;; Canvas elements:
(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))

;; Assets:
(load-assets!)
(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))

;; Particles:
(define particles (make-particle-pool 500 image:particles))

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

;; Scrolling level:
(define *last-row-scanned* 0)
(define level (load-level-1))
(define max-scroll (- (* (level-height level) tile-height) game-height))
(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 (scroll-update!)
  (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll)))
    (set! *last-scroll* *scroll*)
    (set! *scroll* scroll)))

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

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

;; Enemies:
(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 1
                          (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 8))
           (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)
    (define (shoot dx dy)
      (bullet-pool-add! enemy-bullets 2
                        (enemy-x flyer)
                        (enemy-y flyer)
                        4.0 4.0
                        dx dy))
    (set-enemy-dy! flyer 1.0)
    (wait 40)
    (shoot 0.0 2.0)
    (wait 40)
    (set-enemy-dx! flyer -1.0)
    (set-enemy-dy! flyer 0.0)
    (run-script
     (lambda ()
       (do ((i 0 (+ i 1)))
           ((= i 3))
         (wait 20)
         (shoot -2.0 0.0))))
    (wait 140)
    (set-enemy-dx! flyer 0.0)
    (set-enemy-dy! flyer 1.0)
    (run-script
     (lambda ()
       (do ((i 0 (+ i 1)))
           ((= i 3))
         (wait 20)
         (shoot 0.0 2.0)))))
  (spawn-flyer1* x y script))

(define (spawn-flyer1-down x y)
  (define (script flyer)
    (define (shoot* theta)
      (let ((speed 2.0))
        (bullet-pool-add! enemy-bullets 2
                          (enemy-x flyer)
                          (enemy-y flyer)
                          4.0 4.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)
    (shoot)
    (wait 15)
    (shoot)
    (wait 15)
    (shoot))
  (spawn-flyer1* x y script))

(define (spawn-flyer1-down-left x y)
  (define (script flyer)
    (define (shoot dx dy)
      (bullet-pool-add! enemy-bullets 2
                        (enemy-x flyer)
                        (enemy-y flyer)
                        4.0 4.0
                        dx dy))
    (set-enemy-dy! flyer 1.0)
    (wait 60)
    (set-enemy-dx! flyer -1.0)
    (set-enemy-dy! flyer 0.0)
    (wait 40)
    (tween (lambda (dx)
             (set-enemy-dx! flyer dx))
           30 -1.0 0.0
           smoothstep lerp)
    (forever
     (wait 30)
     (shoot 0.0 1.5)))
  (spawn-flyer1* x y script))

(define (spawn-flyer1-down-right x y)
  (define (script flyer)
    (define (shoot dx dy)
      (bullet-pool-add! enemy-bullets 2
                        (enemy-x flyer)
                        (enemy-y flyer)
                        4.0 4.0
                        dx dy))
    (set-enemy-dy! flyer 1.0)
    (wait 60)
    (set-enemy-dx! flyer 1.0)
    (set-enemy-dy! flyer 0.0)
    (wait 40)
    (tween (lambda (dx)
             (set-enemy-dx! flyer dx))
           30 1.0 0.0
           smoothstep lerp)
    (forever
     (wait 30)
     (shoot 0.0 1.5)))
  (spawn-flyer1* x y script))

(define (spawn-chaser x y)
  (define (script flyer)
    (define (shoot dx dy)
      (bullet-pool-add! enemy-bullets 2
                        (enemy-x flyer)
                        (enemy-y flyer)
                        4.0 4.0
                        dx dy))
    (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)
    (forever
     (wait 30)
     (shoot 0.0 1.5)))
  (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 type x y dx dy)
      (let ((s (if (= type 4) 4.0 2.0)))
        (bullet-pool-add! enemy-bullets type x y s s dx dy)))
    (define (xoff dx)
      (+ (enemy-x boss) dx))
    (define (yoff dy)
      (+ (enemy-y boss) dy))
    (define (shoot+flash type xo yo dx dy)
      (let ((x (xoff xo))
            (y (yoff yo)))
        (shoot type 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 type dx dy)
      (shoot+flash type main-left-x main-y dx dy))
    (define (shoot-main-right type dx dy)
      (shoot+flash type main-right-x main-y dx dy))
    (define (shoot-alt-left type dx dy)
      (shoot+flash type alt-left-x alt-y dx dy))
    (define (shoot-alt-right type dx dy)
      (shoot+flash type alt-right-x alt-y dx dy))
    (define (shoot-beak type dx dy)
      (shoot+flash type 0.0 24.0 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)
    (define (phase-3)
      (define (pred) #t)
      (wait 180)
      (run-script
       (lambda ()
         (let ((speed 4.0))
           (let loop ((theta 0.0))
             (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0)))
                   (theta** (+ (- (/ pi 3.0) (fmod theta (/ pi 3.0))) (/ pi 3.0)))
                   (speed 4.0))
               (shoot-alt-left 4 (* (cos theta*) speed) (* (sin theta*) speed))
               (shoot-alt-right 4 (* (cos theta**) speed) (* (sin theta**) speed))
               (wait 30)
               (loop (+ theta 0.35)))))))
      (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 0 (vec2-x v) (vec2-y v))
                 (wait 4)
                 (inner (+ i 1))))
             (wait-if 30 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 0 (vec2-x v) (vec2-y v))
                 (wait 4)
                 (inner (+ i 1))))
             (wait-if 30 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-beak 4 (* (cos theta) speed) (* (sin theta) speed))
                (inner (+ i 1)))))
          (wait-if 60 pred outer nop))))
    (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 0 dx dy)
               (shoot-alt-right 0 (- 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-main-left 0 (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-main-right 0 (vec2-x v) (vec2-y v))
               (wait 4)))
           (wait-if 120 pred loop nop))))
      (run-script
       (lambda ()
         (let loop ((theta 0.0))
           (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0)))
                 (speed 4.0))
             (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed))
             (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop)))))
      (let ((speed 1.2))
        (let loop ((offset 0.0))
          (do-circle
           (lambda (theta)
             (let ((theta* (+ theta offset)))
               (shoot-beak 0 (* (cos theta*) speed) (* (sin theta*) speed))))
           3)
          (wait-if 5 pred (lambda () (loop (+ offset 0.1))) phase-3))))
    (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 0 (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 0 (vec2-x v) (vec2-y v))
               (wait 4)))
           (wait-if 120 pred loop nop))))
      (run-script
       (lambda ()
         (let loop ((theta 0.0))
           (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0)))
                 (speed 4.0))
             (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed))
             (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop)))))
      (let ((speed 0.75))
        (let loop ((theta 0.0))
          (let ((dx (* (cos theta) speed))
                (dy (* (sin theta) speed)))
            (shoot-main-left 0 dx dy)
            (shoot-main-right 0 (- dx) dy)
            (wait-if 5 pred (lambda () (loop (+ theta 0.4))) phase-2)))))
    (wait 180)
    (run-script
     (lambda ()
       (forever
        (tween (lambda (dx)
                 (set-enemy-dx! boss dx))
               60 -0.5 0.5
               smoothstep lerp)
        (tween (lambda (dx)
                 (set-enemy-dx! boss dx))
               60 0.5 -0.5
               smoothstep lerp))))
    (phase-1))
  (spawn-enemy
   (make-enemy 'boss 1500 (vec2 x (- y 32.0)) (vec2 144.0 64.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 particles
             (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 *scroll*)
              (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! (current-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 (exact (truncate game-width)))
         (gh (exact (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*))))

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

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

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

(define (draw-background context 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 context image:starfield-bg 0.3)
  (draw-background context image:starfield-fg 0.5)
  (draw-level-foreground context level *scroll*)
  (draw-particles context particles)
  (draw-player-bullets)
  (draw-enemies context enemies time)
  (draw-player)
  (draw-enemy-bullets)
  (draw-hud)
  (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))))

(define (draw-pause time)
  (draw-background context image:starfield-bg 0.3)
  (draw-background context image:starfield-fg 0.5)
  (draw-level-foreground context level *scroll*)
  (draw-particles context particles)
  (draw-player-bullets)
  (draw-enemies context 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 context image:starfield-bg 0.3)
  (draw-background context image:starfield-fg 0.5)
  (draw-level-foreground context level *scroll*)
  (draw-particles context particles)
  (draw-enemies context 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 context image:starfield-bg 0.3)
  (draw-background context image:starfield-fg 0.5)
  (draw-level-foreground context level *scroll*)
  (draw-particles context 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-callback)))
(define draw-callback (procedure->external draw))

(define (reset!)
  (music-stop)
  (music-play)
  (set! *game-state* 'play)
  (scheduler-reset! (current-scheduler))
  ;; (set! *scroll* 0.0)
  (set! *scroll* (* 460.0 tile-height))
  (set! *last-scroll* 0.0)
  ;; (set! *last-row-scanned* (level-height level))
  (set! *last-row-scanned* (- (level-height level) 460))
  (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!)))
        ('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 (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 *scroll*)
        (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 *scroll*)
        (if (rect-collides-with-level? level x* y* w h *scroll*)
            (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 (on-enemy-kill enemy)
  (sound-effect-play sound:explosion)
  (explode particles (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)))))

(define (on-bullet-collide type x y)
  (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))))

(define dt (/ 1000.0 60.0))
(define (update)
  (let ((dscroll (- *scroll* *last-scroll*)))
    (match *game-state*
      ('play
       (scheduler-tick! (current-scheduler))
       (scroll-update!)
       (set! *last-row-scanned*
             (level-update! level *scroll* *last-row-scanned* do-level-action))
       (player-update!)
       (bullet-pool-update! player-bullets player-bullet-collide dscroll on-bullet-collide)
       (bullet-pool-update! enemy-bullets enemy-bullet-collide dscroll on-bullet-collide)
       (enemy-pool-update! enemies dscroll particles on-enemy-kill)
       (particle-pool-update! particles)
       (when (game-over?)
         (do-game-over)))
      ('game-over
       (set! *scroll* *last-scroll*)
       (scheduler-tick! *countdown-scheduler*))
      ('game-clear
       (scheduler-tick! (current-scheduler))
       (bullet-pool-update! player-bullets player-bullet-collide dscroll on-bullet-collide)
       (bullet-pool-update! enemy-bullets enemy-bullet-collide dscroll on-bullet-collide)
       (particle-pool-update! particles))
      (_ #t)))
  (timeout update-callback dt))
(define update-callback (procedure->external update))

(add-event-listener! (current-window) "resize"
                     (procedure->external (lambda (_) (resize-canvas))))
(add-event-listener! (current-document) "keydown"
                     (procedure->external on-key-down))
(add-event-listener! (current-document) "keyup"
                     (procedure->external on-key-up))
(resize-canvas)
(request-animation-frame draw-callback)

(timeout update-callback dt)