(use-modules (chickadee math)
             (chickadee math matrix)
             (chickadee math rect)
             (chickadee math vector)
             (chickadee graphics color)
             (chickadee graphics path)
             (chickadee graphics sprite)
             (chickadee graphics texture)
             (chickadee scripting)
             (ice-9 match)
             (oop goops)
             (rnrs base)
             (srfi srfi-1)
             (starling asset)
             (starling kernel)
             (starling node)
             (starling node-2d)
             (starling scene))


;;;
;;; Globals
;;;

(define *render-hitboxes?* #t)
(define *god-mode?* #t)


;;;
;;; Constants
;;;

(define game-width 320)
(define game-height 240)
(define game-scale 4)
(define window-width (inexact->exact (* game-width game-scale)))
(define window-height (inexact->exact (* game-height game-scale)))


;;;
;;; Assets
;;;

(define (load-atlas file-name tile-width tile-height)
  (split-texture (load-image file-name) tile-width tile-height))

(define (load-bullet-atlas file-name)
  (texture-atlas (load-image file-name)
                 '(1 1 10 6) ; red medium bullet
                 '(1 9 6 4) ; pink small bullet
                 '(1 15 10 7) ; blue medium bullet
                 ))

(define-asset foreground (load-image "images/foreground.png"))
(define-asset background-1 (load-image "images/back-buildings.png"))
(define-asset background-2 (load-image "images/far-buildings.png"))
(define-asset player-atlas (load-atlas "images/player.png" 80 80))
(define-asset drone-texture (load-image "images/drone-1.png"))
(define-asset police-car (load-image "images/v-police.png"))
(define-asset small-mech (load-image "images/bipedal-unit1.png"))
(define-asset space-marine (load-image "images/space-marine.png"))
(define-asset bullet-atlas (load-bullet-atlas "images/bullets.png"))


;;;
;;; Parallax backgrounds
;;;

(define-class <parallax-layer> ()
  (name #:getter name #:init-keyword #:name)
  (z #:getter z #:init-keyword #:z #:init-form 0)
  (texture #:getter texture #:init-keyword #:texture)
  (y-offset #:getter y-offset #:init-keyword #:y #:init-form 0.0)
  (scalar #:getter scalar #:init-keyword #:scalar #:init-form 1.0))

(define-class <parallax> (<node-2d>)
  (layers #:accessor layers #:init-keyword #:layers #:init-form '())
  (speed #:accessor speed #:init-keyword #:speed #:init-form 1.0)
  (x #:accessor x #:init-form 0.0))

(define-method (on-boot (parallax <parallax>))
  (for-each (lambda (layer)
              (let* ((texture (texture layer))
                     (tw (exact->inexact
                         (/ window-width (texture-width (asset-ref texture))))))
                (attach-to parallax
                           (make <sprite>
                             #:name (name layer)
                             #:rank (z layer)
                             #:texture texture
                             #:position #v(0.0 (y-offset layer))
                             #:source-rect (make-rect 0.0 0.0
                                                      window-width
                                                      (texture-height
                                                       (asset-ref texture)))
                             #:texcoords (make-rect 0.0 0.0 tw 1.0)))))
            (layers parallax)))

(define-method (update (parallax <parallax>) dt)
  (let ((new-x (+ (x parallax) (speed parallax))))
    (set! (x parallax) new-x)
    (for-each (lambda (layer)
                (let* ((sprite (child-ref parallax (name layer)))
                       (t (texture sprite))
                       (width (texture-width t))
                       (tx (exact->inexact
                            (/ (mod (* new-x (scalar layer)) width) width)))
                       (r (texture-gl-tex-rect t)))
                  (set-rect-x! r tx)))
              (layers parallax))))


;;;
;;; Bullet Field
;;;

(define-class <bullet-type> ()
  (tile #:getter tile #:init-keyword #:tile)
  (hitbox #:getter hitbox #:init-keyword #:hitbox))

(define-class <bullet-field> (<node-2d>)
  (batch #:getter batch #:init-form (make-sprite-batch #f))
  (size #:accessor size #:init-form 0)
  (capacity #:getter capacity #:init-form 1000 #:init-keyword #:capacity)
  (types #:accessor types)
  (positions #:accessor positions)
  (velocities #:accessor velocities)
  (hitboxes #:accessor hitboxes)
  (world-hitboxes #:accessor world-hitboxes))

(define-method (initialize (bullets <bullet-field>) initargs)
  (next-method)
  (let ((capacity (capacity bullets)))
    (define (seed-vector thunk)
      (let ((v (make-vector capacity #f)))
        (let loop ((i 0))
          (when (< i capacity)
            (vector-set! v i (thunk))
            (loop (+ i 1))))
        v))
    (set! (types bullets) (make-vector capacity))
    (set! (positions bullets) (seed-vector (lambda () #v(0.0 0.0))))
    (set! (velocities bullets) (seed-vector (lambda () #v(0.0 0.0))))
    (set! (hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))
    (set! (world-hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))))

(define-method (add-bullet (bullets <bullet-field>) type x y dx dy)
  (let* ((i (size bullets))
         (p (vector-ref (positions bullets) i))
         (v (vector-ref (velocities bullets) i))
         (h (vector-ref (hitboxes bullets) i))
         (wh (vector-ref (world-hitboxes bullets) i)))
    (set! (size bullets) (+ i 1))
    (vector-set! (types bullets) i type)
    (set-vec2! p x y)
    (set-vec2! v dx dy)
    (set-rect-x! h -1.0)
    (set-rect-y! h -1.0)
    (set-rect-width! h 2.0)
    (set-rect-height! h 2.0)
    (set-rect-x! wh (+ x -1.0))
    (set-rect-y! wh (+ y -1.0))
    (set-rect-width! wh 2.0)
    (set-rect-height! wh 2.0)))

(define-method (move-bullet (bullets <bullet-field>) from to)
  (let ((positions (positions bullets))
        (velocities (velocities bullets))
        (hitboxes (hitboxes bullets))
        (world-hitboxes (world-hitboxes bullets)))
    (vec2-copy! (vector-ref positions from) (vector-ref positions to))
    (vec2-copy! (vector-ref velocities from) (vector-ref velocities to))
    (rect-copy! (vector-ref hitboxes from) (vector-ref hitboxes to))
    (rect-copy! (vector-ref world-hitboxes from) (vector-ref world-hitboxes to))))

(define-method (kill-bullet (bullets <bullet-field>) i)
  (let ((new-size (- (size bullets) 1)))
    (set! (size bullets) new-size)
    (move-bullet bullets new-size i)))

(define-method (clear-bullets (bullets <bullet-field>))
  (set! (size bullets) 0))

(define-method (update (bullets <bullet-field>) dt)
  (let ((l (size bullets))
        (positions (positions bullets))
        (velocities (velocities bullets))
        (hitboxes (hitboxes bullets))
        (world-hitboxes (world-hitboxes bullets))
        (min-x -16.0)
        (min-y -16.0)
        (max-x (+ game-width 16.0))
        (max-y (+ game-height 16.0)))
    (define (delete i)
      (let ((new-l (- l 1)))
        (set! l new-l)
        (move-bullet bullets new-l i)))
    (let loop ((i 0))
      (when (< i l)
        (let ((p (vector-ref positions i))
              (v (vector-ref velocities i))
              (h (vector-ref hitboxes i))
              (wh (vector-ref world-hitboxes i)))
          (vec2-add! p v)
          ;; Remove bullets that go out of bounds of the play area.
          (if (or (< (vec2-x p) min-x)
                  (> (vec2-x p) max-x)
                  (< (vec2-y p) min-y)
                  (> (vec2-y p) max-y))
              (begin
                (delete i)
                (loop i))
              (begin
                ;; Update hitbox with world coordinates.
                (set-rect-x! wh (+ (vec2-x p) (rect-x h)))
                (set-rect-y! wh (+ (vec2-y p) (rect-y h)))
                (loop (+ i 1)))))))
    (set! (size bullets) l)))

(define %identity (make-identity-matrix4))
(define *bullet-rect* (make-rect 0.0 0.0 0.0 0.0))

(define-method (render (bullets <bullet-field>) alpha)
  (let ((l (size bullets))
        (batch (batch bullets))
        (types (types bullets))
        (positions (positions bullets))
        (atlas (asset-ref bullet-atlas))
        (r *bullet-rect*))
    (set-sprite-batch-texture! batch (texture-atlas-texture atlas))
    (sprite-batch-clear! batch)
    (let loop ((i 0))
      (when (< i l)
        (let* ((p (vector-ref positions i))
               (type (vector-ref types i))
               (texture (texture-atlas-ref atlas (tile type)))
               (tw (texture-width texture))
               (th (texture-height texture)))
          (set-rect-x! r (- (vec2-x p) (/ tw 2.0)))
          (set-rect-y! r (- (vec2-y p) (/ th 2.0)))
          (set-rect-width! r tw)
          (set-rect-height! r th)
          (sprite-batch-add* batch r %identity
                             #:texture-region texture))
        (loop (+ i 1))))
    (draw-sprite-batch* batch (world-matrix bullets))))


;;;
;;; Actor
;;;

(define-generic rect)

(define-class <hitbox> ()
  (name #:getter name #:init-keyword #:name #:init-form 'main)
  (rect #:getter rect #:init-keyword #:rect))

(define-class <actor> (<node-2d>)
  (world-hitboxes #:accessor world-hitboxes #:init-form '())
  (dirty-hitboxes? #:accessor dirty-hitboxes? #:init-form #t))

(define-method (dirty! (actor <actor>))
  (next-method)
  (set! (dirty-hitboxes? actor) #t))

(define-method (hitboxes (actor <actor>)) '())

(define-method (initialize (actor <actor>) initargs)
  (next-method)
  (let ((p (position actor)))
    (set! (world-hitboxes actor)
      (let ((table (make-hash-table)))
        (for-each (lambda (hitbox)
                    (let ((r (rect hitbox)))
                      (hashq-set! table hitbox
                                  (make-rect 0.0 0.0
                                             (rect-width r)
                                             (rect-height r)))))
                  (hitboxes actor))
        table))))

(define-method (update (actor <actor>) dt)
  (when (dirty-hitboxes? actor)
    (let ((p (position actor)))
      (hash-for-each (lambda (hitbox world-hitbox)
                       (let ((r (rect hitbox)))
                         (set-rect-x! world-hitbox (+ (vec2-x p) (rect-x r)))
                         (set-rect-y! world-hitbox (+ (vec2-y p) (rect-y r)))))
                     (world-hitboxes actor)))
    (set! (dirty-hitboxes? actor) #f)))

(define %hitbox-color (make-color 1.0 1.0 1.0 0.7))

(define-method (render-tree (actor <actor>) alpha)
  (next-method)
  (when (and *render-hitboxes?* (visible? actor))
    (for-each (lambda (hitbox)
                ;; (draw-filled-rect (rect hitbox) %hitbox-color
                ;;                   #:matrix (world-matrix actor))
                #t)
              (hitboxes actor))))

(define-method (collide (bullets <bullet-field>) (actor <actor>) proc)
  (define (find-collision bullet-hitbox)
    (find (lambda (actor-hitbox)
            (let ((world-hitbox (hashq-ref (world-hitboxes actor)
                                           actor-hitbox)))
              (rect-intersects? bullet-hitbox
                                world-hitbox)))
          (hitboxes actor)))
  (let ((l (size bullets))
        (bullet-hitboxes (world-hitboxes bullets)))
    (let loop ((i 0))
      (if (< i l)
          (let ((hitbox (find-collision (vector-ref bullet-hitboxes i))))
            (and hitbox (proc i hitbox))
            (loop (+ i 1)))
          #f))))


;;;
;;; Base Enemy
;;;

(define-class <enemy> (<actor>)
  (health #:accessor health #:init-form 1)
  (last-blink #:accessor last-blink #:init-form 0))

(define-method (points (enemy <enemy>)) 0)

(define-method (damage (enemy <enemy>) damage)
  (set! (health enemy) (max (- (health enemy) damage) 0))
  (run-script enemy
    (let ((time (agenda-time)))
      (when (> (- time (last-blink enemy)) 6)
        (set! (last-blink enemy) time)
        (blink enemy 1 3)))))

(define-method (dead? (enemy <enemy>))
  (zero? (health enemy)))

(define-method (emit-bullet (enemy <enemy>) type ox oy theta speed)
  (let ((p (position enemy)))
    (add-enemy-bullet (parent enemy)
                      type
                      (+ (vec2-x p) ox)
                      (+ (vec2-y p) oy)
                      theta
                      speed)))

(define-method (emit-bullet/circle (enemy <enemy>) type ox oy otheta n speed)
  (let loop ((i 0))
    (when (< i n)
      (emit-bullet enemy type ox oy (+ (* 2.0 pi (/ i n)) otheta) speed)
      (loop (+ i 1)))))


;;;
;;; Enemies
;;;

(define space-marine-bullet-type
  (make <bullet-type>
    #:tile 1
    #:hitbox (make-rect -1.0 -1.0 2.0 2.0)))

(define-class <space-marine> (<enemy>)
  (health #:accessor health #:init-form 20)
  (hitboxes #:getter hitboxes
            #:init-form (list (make <hitbox>
                                #:rect (make-rect -8.0 0.0 16.0 38.0))))
  (points #:getter points #:init-form 100))

(define-method (on-boot (marine <space-marine>))
  (attach-to marine
             (make <sprite>
               #:texture space-marine
               #:origin #v(32.0 0.0)))
  (script
   (let loop ((theta 0.0))
     (emit-bullet/circle marine space-marine-bullet-type 0.0 18.0 theta 4 3.0)
     (sleep 5)
     (loop (+ theta (/ pi 32.0))))))

(define-class <drone> (<enemy>)
  (health #:accessor health #:init-form 40)
  (hitboxes #:getter hitboxes
            #:init-form (list (make <hitbox>
                                #:rect (make-rect -18.0 -26.0 40.0 52.0)))))

(define-method (on-boot (drone <drone>))
  (next-method)
  (attach-to drone
             (make <sprite>
               #:texture drone-texture
               #:origin #v(27.0 26.0)))
  ;; (run-script drone
  ;;   (forever
  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 0.0 10 1.5)
  ;;    (sleep 5)
  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 0.5 10 1.5)
  ;;    (sleep 5)
  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 1.0 10 1.5)
  ;;    (sleep 5)))
  ;; (run-script drone
  ;;   (let loop ((theta (/ pi 2.0)))
  ;;     (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 theta 3 1.5)
  ;;     (sleep 10)
  ;;     (loop (- theta (/ pi 33.0)))))
  (run-script drone
    ;; (teleport drone 3600.0 120.0)
    ;; (move-to drone 290.0 120.0 90)
    (forever
     (let ((theta (angle-to-player (parent drone) drone 0 0)))
       (repeat 6
               (emit-bullet drone space-marine-bullet-type 0.0 0.0 theta 3.0)
               (emit-bullet drone space-marine-bullet-type 0.0 0.0 (+ theta 0.04) 3.0)
               (emit-bullet drone space-marine-bullet-type 0.0 0.0 (- theta 0.04) 3.0)
               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 theta 20 3.0)
               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 (+ theta 0.04) 20 3.0)
               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 (- theta 0.04) 20 3.0)
               (sleep 2))
       (sleep 90))))
  )


;;;
;;; Player
;;;

(define-class <player> (<actor>)
  (velocity #:getter velocity #:init-form #v(0.0 0.0))
  (hitboxes #:getter hitboxes
            #:init-form (list (make <hitbox>
                                #:rect (make-rect -1.0 -1.0 2.0 2.0))))
  (speed #:accessor speed #:init-keyword #:speed #:init-form 2.0)
  (shooting? #:accessor shooting? #:init-form #f)
  (shooting-timer #:accessor shooting-timer #:init-form 0)
  (guarding? #:accessor guarding? #:init-form #f)
  (shield-charge #:accessor shield-charge #:init-form 100.0)
  (invincible? #:accessor invincible? #:init-form #f)
  (lives #:accessor lives #:init-form 3)
  (score #:accessor score #:init-form 0))

(define-method (reset-player (player <player>))
  (set! (score player) 0)
  (set! (lives player) 1)
  (set! (shooting? player) #f)
  (set! (shooting-timer player) 0)
  (set! (guarding? player) #f)
  (set! (shield-charge player) 100.0)
  (set! (invincible? player) #f)
  (teleport player 8.0 100.0)
  (set-vec2! (velocity player) 0.0 0.0)
  (show player))

(define-method (dead? (player <player>))
  (zero? (lives player)))

(define-method (kill-player (player <player>))
  (unless (or *god-mode?* (invincible? player))
    (set! (lives player) (max (- (lives player) 1) 0))
    (run-script player
      (set! (invincible? player) #t)
      (blink player 60 2)
      (set! (invincible? player) #f))))

(define-method (on-boot (player <player>))
  (attach-to player
             (make <animated-sprite>
               #:name 'sprite
               #:atlas player-atlas
               #:origin #v(41.0 44.0)
               #:animations `((idle . ,(make <animation>
                                         #:frames #(0 1 2 3)
                                         #:frame-duration 200))
                              (shoot . ,(make <animation>
                                          #:frames #(23 24 25)
                                          #:frame-duration 50)))
               #:default-animation 'idle)
             ;; (make <filled-rect>
             ;;   #:name 'shield
             ;;   #:region (make-rect -30.0 -35.0 60.0 60.0)
             ;;   #:color (make-color 1.0 0.0 1.0 0.5)
             ;;   #:visible? #f)
             ))

(define-method (emit-bullet (player <player>) ox oy theta speed)
  (let ((p (position player)))
    (add-player-bullet (parent player)
                       (+ (vec2-x p) ox)
                       (+ (vec2-y p) oy)
                       theta
                       speed)))

(define player-bullet-type
  (make <bullet-type>
    #:tile 2
    #:hitbox (make-rect -5.0 -3.5 10.0 7.0)))

(define-method (shoot (player <player>))
  (let ((p (position player))
        (ox 20.0)
        (oy 7.0)
        (speed 10.0)
        (theta 0.0)
        (dtheta 0.05))
    (emit-bullet player ox oy theta speed)
    (emit-bullet player ox oy (+ theta dtheta) speed)
    (emit-bullet player ox oy (- theta dtheta) speed)))

(define-method (update (player <player>) dt)
  (let ((p (position player))
        (v (velocity player))
        (min-x 0.0)
        (min-y 26.0)
        (max-x game-width)
        (max-y game-height))
    (unless (and (zero? (vec2-x v)) (zero? (vec2-y v)))
      (vec2-add! p v)
      (dirty! player)
      (when (or (< (vec2-x p) min-x)
                (> (vec2-x p) max-x)
                (< (vec2-y p) min-y)
                (> (vec2-y p) max-y))
        (set-vec2-x! p (max (min (vec2-x p) max-x) min-x))
        (set-vec2-y! p (max (min (vec2-y p) max-y) min-y)))))
  (when (shooting? player)
    (when (zero? (modulo (shooting-timer player) 2))
      (shoot player))
    (set! (shooting-timer player) (+ (shooting-timer player) 1)))
  (if (guarding? player)
      (set! (shield-charge player) (max (- (shield-charge player) 1.0) 0.0))
      (set! (shield-charge player) (min (+ (shield-charge player) 0.1) 100.0)))
  (next-method))

(define-method (change-direction (player <player>) left? right? down? up?)
  (let ((v (velocity player)))
    (set-vec2! v
               (+ (if left? -1.0 0.0)
                  (if right? 1.0 0.0))
               (+ (if down? -1.0 0.0)
                  (if up? 1.0 0.0)))
    (vec2-normalize! v)
    (vec2-mult! v (speed player))))

(define-method (begin-shooting (player <player>))
  (set! (shooting? player) #t)
  (set! (shooting-timer player) 0)
  (change-animation (& player sprite) 'shoot))

(define-method (end-shooting (player <player>))
  (set! (shooting? player) #f)
  (change-animation (& player sprite) 'idle))

(define-method (begin-guarding (player <player>))
  (set! (guarding? player) #t)
  ;;(show (& player shield))
  )

(define-method (end-guarding (player <player>))
  (set! (guarding? player) #f)
  ;;(hide (& player shield))
  )


;;;
;;; Meter
;;;

(define-class <meter> (<node-2d>)
  (width #:accessor width #:init-keyword #:width)
  (thickness #:accessor thickness #:init-keyword #:thickness)
  (proc #:accessor proc #:init-keyword #:proc)
  (background-color #:accessor background-color #:init-form black
                    #:init-keyword #:background-color)
  (fill-color #:accessor fill-color #:init-form tango-light-scarlet-red
              #:init-keyword #:fill-color)
  (background-rect #:getter background-rect #:init-form (make-rect 0.0 0.0 0.0 0.0))
  (fill-rect #:getter fill-rect #:init-form (make-rect 0.0 0.0 0.0 0.0)))

(define-method (update (meter <meter>) dt)
  (let ((b (background-rect meter))
        (f (fill-rect meter))
        (w (width meter))
        (h (thickness meter))
        (t ((proc meter))))
    (set-rect-width! b w)
    (set-rect-height! b h)
    (set-rect-width! f (* w t))
    (set-rect-height! f h)))

(define-method (render (meter <meter>) alpha)
  ;; (draw-filled-rect (background-rect meter) (background-color meter)
  ;;                   #:matrix (world-matrix meter))
  ;; (draw-filled-rect (fill-rect meter) (fill-color meter)
  ;;                   #:matrix (world-matrix meter))
  #t)


;;;
;;; Shmup scene
;;;

(define-class <shmup> (<scene-2d>)
  (state #:accessor state #:init-form 'play)
  (enemies #:accessor enemies #:init-form '())
  (cont #:accessor cont #:init-form #f)
  (cont-x #:accessor cont-x #:init-form +inf.0)
  (move-state #:getter move-state #:init-thunk make-hash-table))

(define-method (update-hud (shmup <shmup>))
  (let ((player (& shmup player)))
    (set! (text (& shmup hud-lives))
      (format #f "lives ~d" (max (- (lives player) 1) 0)))
    (set! (text (& shmup hud-score))
      (format #f "score ~7d" (score player)))))

(define (wait-for-scroll shmup x)
  (yield
   (lambda (k)
     (set! (cont shmup) k)
     (set! (cont-x shmup) x))))

(define-method (stage-1 (shmup <shmup>))
  (wait-for-scroll shmup 100.0)
  ;; (add-enemy shmup
  ;;            (make <drone>))
  ;; (wait-for-scroll shmup 500.0)
  ;; (add-enemy shmup
  ;;            (make <drone>
  ;;              #:position #v(290.0 120.0)))
  )

(define-method (reset-game (shmup <shmup>))
  (set! (enemies shmup) '())
  (with-agenda (agenda shmup) (reset-agenda))
  (reset-player (& shmup player))
  (set! (state shmup) 'play)
  (update-hud shmup)
  (run-script shmup (stage-1 shmup)
    ;; (forever
    ;;  (when (null? (enemies shmup))
    ;;    (sleep 30)
    ;;    (add-enemy shmup
    ;;               (make <drone>
    ;;                 #:position #v(290.0 120.0)))
    ;;    ;; (add-enemy shmup
    ;;    ;;            (make <drone>
    ;;    ;;              #:position #v(290.0 170.0)))
    ;;    )
    ;;  (sleep 2))
    ))

(define-method (start-over (shmup <shmup>))
  (detach (& shmup game-over))
  (for-each detach (enemies shmup))
  (reset-game shmup))

(define-method (on-boot (shmup <shmup>))
  (set! (cameras shmup)
    (list (make <camera-2d> #:resolution (vec2 game-width game-height))))
  (attach-to shmup
             (make <parallax>
               #:name 'background
               #:rank 0
               #:speed 2.0
               #:layers (list (make <parallax-layer>
                                #:name 'background-2
                                #:texture background-2
                                #:y 48.0
                                #:scalar 0.5)
                              (make <parallax-layer>
                                #:name 'background-1
                                #:z 1
                                #:texture background-1
                                #:y 46.0
                                #:scalar 0.7)
                              (make <parallax-layer>
                                #:name 'foreground-2
                                #:z 2
                                #:texture foreground)))
             (make <bullet-field>
               #:name 'player-bullets
               #:rank 2)
             (make <bullet-field>
               #:name 'enemy-bullets
               #:rank 3)
             (make <player>
               #:name 'player
               #:rank 4)
             (make <label>
               #:name 'hud-lives
               #:rank 5
               #:position #v(2.0 228.0)
               #:text "")
             (make <label>
               #:name 'hud-score
               #:rank 5
               #:position #v(230.0 228.0)
               #:text "")
             (make <label>
               #:name 'hud-shield
               #:rank 5
               #:position #v(60.0 0.0)
               #:text "shield")
             (make <meter>
               #:position #v(100.0 4.0)
               #:width 120
               #:thickness 2
               #:proc (lambda ()
                        (/ (shield-charge (& shmup player)) 100.0))
               #:rank 5))
  (reset-game shmup))

(define-method (game-over-maybe (shmup <shmup>))
  (let ((player (& shmup player)))
    (when (dead? player)
      (set! (state shmup) 'game-over)
      (stop-scripts player)
      (hide player)
      (end-shooting player)
      (for-each detach (enemies shmup))
      (set! (enemies shmup) '())
      (stop-scripts shmup)
      (clear-bullets (& shmup player-bullets))
      (clear-bullets (& shmup enemy-bullets))
      (attach-to shmup
                 (make <label>
                   #:name 'game-over
                   #:rank 5
                   #:text "GAME OVER"
                   #:position #v(130.0 120.0))))))

(define-method (update (shmup <shmup>) dt)
  (match (state shmup)
    ('play
     (let ((player (& shmup player))
           (player-bullets (& shmup player-bullets))
           (enemy-bullets (& shmup enemy-bullets)))
       (when (and (cont shmup) (>= (x (& shmup background)) (cont-x shmup)))
         (let ((k (cont shmup)))
           (set! (cont shmup) #f)
           (k)))
       (collide enemy-bullets player
                (lambda (bullet-id hitbox)
                  (kill-bullet enemy-bullets bullet-id)
                  (kill-player player)
                  (update-hud shmup)))
       (for-each (lambda (enemy)
                   (collide player-bullets enemy
                            (lambda (bullet-id hitbox)
                              (kill-bullet player-bullets bullet-id)
                              (damage enemy 1)))
                   (when (dead? enemy)
                     (set! (score player)
                       (+ (score player) (points enemy)))
                     (update-hud shmup)
                     (kill-enemy shmup enemy)))
                 (enemies shmup))
       (game-over-maybe shmup)))
    (_ #f)))

(define-method (add-enemy (shmup <shmup>) (enemy <enemy>))
  (set! (enemies shmup) (cons enemy (enemies shmup)))
  ;; Give it a proper ranking so that enemies draw before the player
  ;; and stuff.
  (set! (rank enemy) 1)
  (attach-to shmup enemy))

(define-method (kill-enemy (shmup <shmup>) (enemy <enemy>))
  (detach enemy)
  (set! (enemies shmup) (delete enemy (enemies shmup))))

(define-method (add-player-bullet (shmup <shmup>) x y theta speed)
  (let ((dx (* (cos theta) speed))
        (dy (* (sin theta) speed)))
    (add-bullet (& shmup player-bullets) player-bullet-type x y dx dy)))

(define-method (angle-to-player (shmup <shmup>) (enemy <enemy>) ox oy)
  (let* ((player (& shmup player))
         (pp (position player))
         (ep (position enemy))
         (dx (- (vec2-x pp) (+ (vec2-x ep) ox)))
         (dy (- (vec2-y pp) (+ (vec2-y ep) oy))))
    (atan dy dx)))

(define-method (add-enemy-bullet (shmup <shmup>) type x y theta speed)
  (let ((dx (* (cos theta) speed))
        (dy (* (sin theta) speed)))
    (add-bullet (& shmup enemy-bullets) type x y dx dy)))

(define-method (update-player-movement (shmup <shmup>) key down?)
  (let ((state (move-state shmup)))
    (hashq-set! state key down?)
    (change-direction (& shmup player)
                      (hashq-ref state 'left)
                      (hashq-ref state 'right)
                      (hashq-ref state 'down)
                      (hashq-ref state 'up))))

(define-method (pause-game (shmup <shmup>))
  (set! (state shmup) 'pause)
  (pause (& shmup background))
  (pause (& shmup player-bullets))
  (pause (& shmup enemy-bullets))
  (pause (& shmup player))
  (end-shooting (& shmup player))
  (end-guarding (& shmup player))
  (hash-clear! (move-state shmup))
  (change-direction (& shmup player) #f #f #f #f)
  (for-each pause (enemies shmup)))

(define-method (resume-game (shmup <shmup>))
  (set! (state shmup) 'play)
  (resume (& shmup background))
  (resume (& shmup player-bullets))
  (resume (& shmup enemy-bullets))
  (resume (& shmup player))
  (for-each resume (enemies shmup)))

(define-method (on-key-press (shmup <shmup>) key modifiers repeat?)
  (match (state shmup)
    ('play
     (match key
       ((or 'up 'down 'left 'right)
        (update-player-movement shmup key #t))
       ('z (begin-shooting (& shmup player)))
       ('x (begin-guarding (& shmup player)))
       ('return (pause-game shmup))
       ('r (reset-game shmup))
       (_ #f)))
    ('pause
     (match key
       ('return (resume-game shmup))
       (_ #f)))
    ('game-over
     (match key
       ('return (start-over shmup))
       (_ #f)))
    (_ #f)))

(define-method (on-key-release (shmup <shmup>) key modifiers)
  (match (state shmup)
    ('play
     (match key
       ((or 'up 'down 'left 'right)
        (update-player-movement shmup key #f))
       ('z (end-shooting (& shmup player)))
       ('x (end-guarding (& shmup player)))
       (_ #f)))
    (_ #f)))

(define-method (on-mouse-press (shmup <shmup>) button clicks x y)
  (match button
    ('left
     (add-enemy shmup
                (make <drone> #:position (vec2 (/ x game-scale) (/ y game-scale)))))
    (_ #f)))

(boot-kernel (make <kernel>
               #:window-config (make <window-config>
                                 #:title "shmup game thing i guess whatever"
                                 #:width window-width
                                 #:height window-height))
             (lambda ()
               (make <shmup>)))