path: root/game.scm

;;; Sly
;;; Copyright (C) 2016 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (ice-9 format)
             (ice-9 match)
             (sly)
             (sly actor)
             (sly audio)
             (sly fps)
             (sly live-reload)
             ((sly math vector) #:select (magnitude) #:prefix v:)
             (sly records)
             (sly render framebuffer)
             (sly render sprite-batch)
             (sly render tileset)
             (srfi srfi-1)
             (srfi srfi-9)
             (srfi srfi-11))


;;;
;;; Model
;;;

(define resolution (vector2 120 160))
(define bounds (make-rect (vector2 0 0) resolution))
(define player-bounds (rect-inflate bounds -6 -8))
(define bullet-bounds (rect-inflate bounds 32 32))
(define player-speed 1.1)
(define player-attack 1)

(define origin2 (vector2 0 0))


;;;
;;; Data types
;;;

(define-record-type* <bullet>
  %make-bullet make-bullet
  bullet?
  (type bullet-type 'generic)
  (polarity bullet-polarity 'light)
  (live? bullet-live? #t)
  (position bullet-position origin2)
  (direction bullet-direction 0)
  (hitbox bullet-hitbox (make-rect -1 -1 1 1)))

(define-record-type* <player>
  %make-player make-player
  player?
  (polarity player-polarity 'light)
  (position player-position (vector2 (/ (vx resolution) 2) 8))
  (direction player-direction (vector2 0 0))
  (shooting? player-shooting? #f)
  (hitbox player-hitbox (make-rect -1 1 2 4))
  (absorb-hitbox player-absorb-hitbox (make-rect -9 -2 16 6))
  (last-death-time player-last-death-time #f))

(define-record-type* <enemy>
  %make-enemy make-enemy
  enemy?
  (position enemy-position origin2)
  (aim enemy-aim 0) ; angle for firing bullets
  ;; TODO: We could leave out the '-light' part and use the polarity
  ;; field to figure things out, but it's more work so forget it.
  (type enemy-type 'pincer-dark)
  (polarity enemy-polarity 'light)
  (hitbox enemy-hitbox (make-rect -5 -5 10 10))
  (last-hit-time enemy-last-hit-time #f)
  (health enemy-health 0))

(define-record-type* <stats>
  %make-stats make-stats
  stats?
  (score stats-score 0)
  (lives stats-lives 3)
  (chain stats-chain 0)
  (chain-type stats-chain-type #f)
  (chain-progress stats-chain-progress 0))

(define-record-type* <explosion>
  %make-explosion make-explosion
  explosion?
  (type explosion-type 'regular)
  (position explosion-position origin2)
  (time explosion-time 0))

(define-record-type* <world>
  %make-world make-world
  world?
  (waves world-waves #f)
  (stats world-stats (make-stats))
  (player world-player (make-actor (make-player) idle))
  (player-bullets world-player-bullets '())
  (enemies world-enemies '())
  (enemy-bullets world-enemy-bullets '())
  (explosions world-explosions '()))


;;;
;;; Enemies
;;;

(define (enemy-dead? enemy)
  (zero? (enemy-health enemy)))

(define (enemy-alive? enemy)
  (> (enemy-health enemy) 0))

(define (damage-enemy enemy bullet time)
  (make-enemy #:inherit enemy
              #:last-hit-time time
              #:health (max 0
                            (- (enemy-health enemy)
                               (if (eq? (enemy-polarity enemy)
                                        (bullet-polarity bullet))
                                   player-attack
                                   ;; Bullets of opposite polarity
                                   ;; deal double damage.
                                   (* player-attack 2))))))


;;;
;;; Player
;;;

(define (kill-player player time)
  (make-player #:inherit player #:last-death-time time))

(define player-invincible-time (* 4 60))

(define (player-invincible? player time)
  (let ((last-death (player-last-death-time player)))
    (and last-death
         (negative?
          (- time (+ last-death player-invincible-time))))))

(define (toggle-polarity player)
  (make-player #:inherit player
               #:polarity (if (eq? (player-polarity player) 'light)
                              'dark
                              'light)))


;;;
;;; Bullets
;;;

(define (kill-bullet bullet)
  (make-bullet #:inherit bullet #:live? #f))

(define (move-bullet bullet offset)
  (make-bullet #:inherit bullet
               #:position (v+ (bullet-position bullet) offset)))

(define (move-bullet-to bullet position)
  (make-bullet #:inherit bullet #:position position))

(define (bullet-in-bounds? bullet)
  (rect-contains? bullet-bounds (bullet-position bullet)))

(define (forward speed)
  (lambda (world effects bullet)
    (values #f
            effects
            (move-bullet bullet (polar2 speed (bullet-direction bullet))))))

(define (direct-player player direction)
  (make-player #:inherit player #:direction direction))

(define (move-player player offset)
  (make-player #:inherit player
               #:position (rect-clamp player-bounds
                                      (v+ (player-position player) offset))))

(define (set-player-shooting player shooting?)
  (make-player #:inherit player #:shooting? shooting?))

(define (player-forward speed)
  (lambda (world effects player)
    (values #f
            effects
            (move-player player (v* speed (player-direction player))))))

(define player-bullet-script
  (forever (forward 5)))

(define player-bullet-direction (/ pi 2))

(define (make-player-bullet player offset)
  (make-actor (make-bullet #:position (v+ (player-position player) offset)
                           #:type (match (player-polarity player)
                                    ('light 'player-light)
                                    ('dark 'player-dark))
                           #:direction player-bullet-direction)
              player-bullet-script))

(define (add-player-bullets world bullets)
  (make-world #:inherit world
              #:player-bullets
              (append bullets (world-player-bullets world))))

(define (player-shoot world player)
  (add-player-bullets world
                      (list
                       (make-player-bullet player (vector2 -2 1))
                       (make-player-bullet player (vector2 4 1)))))

(define (place-enemy enemy position)
  (make-enemy #:inherit enemy
              #:position position))

(define (move-enemy enemy offset)
  (make-enemy #:inherit enemy
              #:position (v+ (enemy-position enemy) offset)))

(define (aim-enemy enemy offset)
  (make-enemy #:inherit enemy
              #:aim (+ (enemy-aim enemy) offset)))

(define (add-enemy-bullets world bullets)
  (make-world #:inherit world
              #:enemy-bullets
              (append bullets (world-enemy-bullets world))))

(define (add-enemy-bullet world bullet)
  (make-world #:inherit world
              #:enemy-bullets
              (cons bullet (world-enemy-bullets world))))

(define (simple-enemy-bullet position direction speed)
  (make-actor (make-bullet #:type 'small-light
                           #:position position
                           #:direction direction)
              (forever (forward speed))))

(define (enemy-shoot world enemy type speed aim-offset)
  (let* ((position (enemy-position enemy))
         (bullet (make-actor (make-bullet #:type type
                                          #:polarity (match type
                                                       ((or 'small-light
                                                            'large-light)
                                                        'light)
                                                       ((or 'small-dark
                                                            'large-dark)
                                                        'dark))
                                          #:position position
                                          #:direction (+ (enemy-aim enemy)
                                                         aim-offset))
                             (forever (forward speed)))))
    (add-enemy-bullet world bullet)))

(define (enemy-shoot-at-player world enemy speed)
  (let* ((v (normalize
             (v- (enemy-position enemy)
                 (player-position
                  (actor-ref
                   (world-player world))))))
         (direction (+ pi (atan (vy v) (vx v))))
         (position (enemy-position enemy))
         (bullets
          (list (simple-enemy-bullet position (+ direction (/ pi 16)) speed)
                (simple-enemy-bullet position (+ direction (/ pi 8)) speed)
                (simple-enemy-bullet position direction speed)
                (simple-enemy-bullet position (- direction (/ pi 8)) speed)
                (simple-enemy-bullet position (- direction (/ pi 16)) speed))))
    (add-enemy-bullets world bullets)))

(define (explosion-active? explosion current-time)
  (< (- current-time (explosion-time explosion)) 15))


;;;
;;; Stats
;;;

(define (decrement-life stats)
  (make-stats #:inherit stats
              #:lives (max 0 (1- (stats-lives stats)))))

(define max-chain-multiplier 10)

(define (add-to-score enemy stats)
  ;; TODO: Award different points for different types of enemies.
  (make-stats #:inherit stats
              #:score (+ (stats-score stats)
                         1000          ; base kill points
                         ;; Chain multiplier.
                         (* 255
                            (min (stats-chain stats)
                                 max-chain-multiplier)))))

(define (add-to-chain enemy stats)
  (let* ((enemy-polarity (enemy-polarity enemy))
         (chain-polarity (stats-chain-type stats))
         (progress (stats-chain-progress stats)))
    (cond
     ((or (zero? progress) (= progress 3))
      (make-stats #:inherit stats
                  #:chain-type enemy-polarity
                  #:chain-progress 1))
     ((not (eq? enemy-polarity chain-polarity))
      (make-stats #:inherit stats
                  #:chain-type #f
                  #:chain-progress 0
                  #:chain 0))
     ((= progress 1)
      (make-stats #:inherit stats
                  #:chain-progress 2))
     ((= progress 2)
      (make-stats #:inherit stats
                  #:chain-progress 3
                  #:chain (1+ (stats-chain stats)))))))


;;;
;;; Collision detection
;;;

(define (player-world-hitbox player)
  (rect-move (player-hitbox player) (player-position player)))

(define (player-world-absorb-hitbox player)
  (rect-move (player-absorb-hitbox player) (player-position player)))

(define (enemy-world-hitbox enemy)
  (rect-move (enemy-hitbox enemy) (enemy-position enemy)))

(define (bullet-world-hitbox bullet)
  (rect-move (bullet-hitbox bullet) (bullet-position bullet)))

(define (enemy/player-collision? enemy player)
  (rect-intersects? (enemy-world-hitbox enemy)
                    (player-world-hitbox player)))

(define (enemy/bullet-collision? enemy bullet)
  (rect-intersects? (enemy-world-hitbox enemy)
                    (bullet-world-hitbox bullet)))

(define (player/bullet-polarity-eq? player bullet)
  (eq? (player-polarity player) (bullet-polarity bullet)))

(define (player/bullet-collision? player bullet)
  (rect-intersects? (if (player/bullet-polarity-eq? player bullet)
                        (player-world-absorb-hitbox player)
                        (player-world-hitbox player))
                    (bullet-world-hitbox bullet)))

(define (collide-enemies-and-bullets enemies player-bullets stats time)
  (define (collide enemy bullets stats explosions)
    (let loop ((bullets bullets)
               (prev-bullets '())
               (stats stats))
      (match bullets
        (()
         (values enemy (reverse prev-bullets) stats explosions))
        ((bullet . rest)
         (if (enemy/bullet-collision? (actor-ref enemy) (actor-ref bullet))
             (let* ((new-enemy (call-with-actor enemy
                                (lambda (enemy)
                                  (damage-enemy enemy
                                                (actor-ref bullet)
                                                time))))
                    (new-enemy* (actor-ref new-enemy)))
               (values new-enemy
                       ;; Remove bullet.
                       (append (reverse prev-bullets) rest)
                       (if (enemy-alive? new-enemy*)
                           stats
                           ;; Enemy killed, add to player score and
                           (add-to-chain new-enemy*
                                         (add-to-score new-enemy* stats)))
                       (if (enemy-alive? new-enemy*)
                           explosions
                           ;; Add new explosion.
                           (cons (make-explosion #:type 'regular
                                                 #:position (enemy-position
                                                             new-enemy*)
                                                 #:time time)
                                 explosions))))
             (loop rest (cons bullet prev-bullets) stats))))))

  (let loop ((enemies enemies)
             (new-enemies '())
             (bullets player-bullets)
             (explosions '())
             (stats stats))
    (match enemies
      (()
       (values (reverse new-enemies) bullets stats explosions))
      ((enemy . rest)
       (let-values (((new-enemy bullets stats explosions)
                     (collide enemy bullets stats explosions)))
         (loop rest
               (if (enemy-alive? (actor-ref new-enemy))
                   (cons new-enemy new-enemies)
                   new-enemies)
               bullets
               explosions
               stats))))))

(define (collide-player-and-enemies player enemies stats time)
  (let loop ((enemies enemies))
    (match enemies
      (()
       (values player stats '()))
      ((enemy . rest)
       (if (enemy/player-collision? (actor-ref enemy) (actor-ref player))
           (let* ((invincible? (player-invincible? (actor-ref player) time))
                  (new-player (if invincible?
                                  player
                                  (call-with-actor player
                                    (lambda (player)
                                      (kill-player player time)))))
                  (position (player-position (actor-ref player)))
                  (explosion (make-explosion #:type 'player
                                             #:position position
                                             #:time time)))
             (values new-player
                     (if invincible?
                         stats
                         (decrement-life stats))
                     (list explosion)))
           (loop rest))))))

(define (collide-player-and-bullets player enemy-bullets stats time)
  (let loop ((bullets enemy-bullets)
             (new-bullets '()))
    (match bullets
      (()
       (values player (reverse new-bullets) stats '()))
      ((bullet . rest)
       (let* ((b (actor-ref bullet))
              (p (actor-ref player)))
         (if (player/bullet-collision? p b)
             (let* ((hit? (not (or (player-invincible? p time)
                                   (player/bullet-polarity-eq? p b))))
                    (new-player (if hit?
                                    (call-with-actor player
                                      (lambda (player)
                                        (kill-player player time)))
                                    player))
                    (position (player-position p))
                    (explosion (make-explosion #:type 'player
                                               #:position position
                                               #:time time)))
               (values new-player
                       (append (reverse new-bullets) rest)
                       (if hit? (decrement-life stats) stats)
                       (if hit? (list explosion) '())))
             (loop rest (cons bullet new-bullets))))))))


;;;
;;; Game world simulation
;;;

(define (final-wave? world)
  (= (length (world-waves world)) 1))

(define (game-over? world)
  (zero? (stats-lives (world-stats world))))

(define (game-won? world)
  (and (null? (world-waves world))
       (null? (world-enemies world))
       (not (game-over? world))))

(define (game-intro? world)
  (not (world-waves world)))

(define (keep-bullet? bullet)
  (and (bullet-live? bullet)
       (bullet-in-bounds? bullet)))

(define (update-bullets effects world bullets)
  ;; TODO: Gather effects
  (values effects
          (filter-map (lambda (actor)
                        (let-values (((effects new-actor)
                                      (update-actor world '() actor)))
                          (let ((bullet (actor-ref new-actor)))
                            (and (bullet-live? bullet)
                                 (bullet-in-bounds? bullet)
                                 new-actor))))
                      bullets)))

(define (update-enemies effects world)
  ;; TODO: gather effects
  (let-values (((new-effects new-enemies)
                (actor-filter-update enemy-alive? world (world-enemies world))))
    (values (append new-effects effects) new-enemies)))

(define (update-player effects world)
  (update-actor world effects (world-player world)))

(define (update-world world time)
  (let*-values
      (((game-over?) (game-over? world))
       ((game-won?) (game-won? world))
       ((effects new-player)
        (if game-over?
            (values '() (world-player world))
            (update-player '() world)))
       ((effects new-enemies) (update-enemies effects world))
       ((effects new-player-bullets)
        (if game-over?
            (values effects '())
            (update-bullets effects world (world-player-bullets world))))
       ((effects new-enemy-bullets)
        (update-bullets effects world (world-enemy-bullets world)))
       ((stats) (world-stats world))
       ((new-enemies new-player-bullets new-stats explosions1)
        ;; Don't allow enemies to be killed after the game has been
        ;; lost because that would lead to strange things.
        (if game-over?
            (values new-enemies new-player-bullets stats '())
            (collide-enemies-and-bullets new-enemies new-player-bullets
                                         stats time)))
       ;; Move to the next wave, if needed.
       ((new-enemies new-waves)
        (let ((waves (world-waves world)))
          (cond
           ((not waves)
            (values new-enemies #f))
           ((null? waves)
            (values new-enemies '()))
           ((null? new-enemies)
            (values (car waves) (cdr waves)))
           (else
            (values new-enemies waves)))))
       ((new-player new-enemy-bullets new-stats explosions2)
        ;; Don't collide when the game has been won or lost.
        (if (or game-over? game-won?)
            (values new-player new-enemy-bullets new-stats '())
            (collide-player-and-bullets new-player new-enemy-bullets
                                        new-stats time)))
       ((new-player new-stats explosions3)
        ;; Don't collide when the game has been lost.  By definition
        ;; their are no enemies when the game is won, so we don't have
        ;; to worry about that case.
        (if game-over?
            (values new-player new-stats '())
            (collide-player-and-enemies new-player new-enemies
                                        new-stats time)))
       ((new-explosions)
        (filter (lambda (explosion)
                  (explosion-active? explosion time))
                (append explosions1
                        explosions2
                        explosions3
                        (world-explosions world)))))
    (apply-effects effects
                   (make-world #:player new-player
                               #:player-bullets new-player-bullets
                               #:enemies new-enemies
                               #:enemy-bullets new-enemy-bullets
                               #:waves new-waves
                               #:stats new-stats
                               #:explosions new-explosions))))

(define (world-eval exp world)
  (match exp
    (('null) world)
    (('tick time)
     (update-world world time))
    (('player-direction direction)
     (make-world #:inherit world
                 #:player (call-with-actor (world-player world)
                            (lambda (player)
                              (direct-player player direction)))))
    (('player-shoot shooting?)
     (make-world #:inherit world
                 #:player (call-with-actor (world-player world)
                            (lambda (player)
                              (set-player-shooting player shooting?)))))
    (('player-toggle-polarity)
     (make-world #:inherit world
                 #:player (call-with-actor (world-player world)
                            toggle-polarity)))
    (('restart restart?)
     (if (and restart?
              (or (game-over? world)
                  (game-won? world)
                  (game-intro? world)))
         (make-world #:inherit %default-world
                     #:waves %waves)
         world))))

(define player-shoot* (action-effect-lift player-shoot))
(define place-enemy* (action-lift place-enemy))
(define move-enemy* (action-lift move-enemy))
(define aim-enemy* (action-lift aim-enemy))
(define enemy-shoot* (action-effect-lift enemy-shoot))
(define enemy-shoot-at-player* (action-effect-lift enemy-shoot-at-player))

(define %default-player
  (make-actor (make-player)
              (forever
               (both (repeat 3 (player-forward player-speed))
                     (whena player-shooting? (player-shoot*))))))

(define (make-pincer polarity position action)
  (make-actor (make-enemy #:position position
                          #:health 40
                          #:polarity polarity
                          #:type (match polarity
                                   ('light 'pincer-light)
                                   ('dark 'pincer-dark)))
              action))

(define (make-popcorn polarity position action)
  (make-actor (make-enemy #:position position
                          #:health 1
                          #:polarity polarity
                          #:type (match polarity
                                   ('light 'popcorn-light)
                                   ('dark 'popcorn-dark)))
              action))

(define %hard-spiral
  (let* ((v (vector2 .8 0))
         (bullet-speed 0.6)
         (interval 15)
         (shoot (together
                 (wait 2)
                 (aim-enemy* (/ pi 32))
                 (enemy-shoot* 'large-light bullet-speed 0)
                 (enemy-shoot* 'large-dark (/ bullet-speed 2) pi))))
    (forever
     (sequence
       (repeat interval (together (move-enemy* v) shoot))
       (repeat interval (together (move-enemy* (v- v)) shoot))
       (repeat interval (together (move-enemy* (v- v)) shoot))
       (repeat interval (together (move-enemy* v) shoot))))))

(define (move-linear offset duration)
  (repeat duration
          (move-enemy*
           (v* offset (/ 1.0 duration)))))

(define hard-pincer
  (let ((start (vector2 -60 120)))
    (make-pincer 'light start
                 (sequence (move-linear (v- (vector2 30 120) start) 90)
                           %hard-spiral))))

(define (make-medium-wave polarity)
  (list (let ((start (vector2 -60 120)))
          (make-pincer polarity start
                       (sequence (move-linear (v- (vector2 30 120) start) 90)
                                 %hard-spiral)))
        (let ((start (vector2 180 120)))
          (make-pincer polarity start
                       (sequence (move-linear (v- (vector2 90 120) start) 90)
                                 %hard-spiral)))
        (let ((start (vector2 -30 140)))
          (make-pincer polarity start
                       (sequence (move-linear (v- (vector2 60 140) start) 90)
                                 %hard-spiral)))))

(define (polarity-not polarity)
  (if (eq? polarity 'light)
      'dark
      'light))

(define (make-easy-wave polarity bullet-speed)
  (define (bullet-type* polarity)
    (match polarity
      ('light 'small-light)
      ('dark 'small-dark)))

  (define sweep-size 16)
  (define theta (/ pi/2 sweep-size))

  (define (action polarity)
    (define bullet-speed*
      (if (eq? polarity 'dark)
          bullet-speed
          (* bullet-speed 1.5)))

    (sequence
      (wait (if (eq? polarity 'dark) 60 0))
      (aim-enemy* (if (eq? polarity 'dark)
                      (* 5/4 pi)
                      (* 7/4 pi)))
      (forever
       (sequence
         (repeat sweep-size
                 (sequence
                   (wait 10)
                   (enemy-shoot* (bullet-type* polarity) bullet-speed* 0)
                   (aim-enemy* (if (eq? polarity 'dark) theta (- theta)))))
         (move-linear (vector2 10 10) 10)
         (wait 60)
         (repeat sweep-size
                 (sequence
                   (wait 10)
                   (enemy-shoot* (bullet-type* polarity) bullet-speed* 0)
                   (aim-enemy* (if (eq? polarity 'dark) (- theta) theta))))
         (move-linear (vector2 -10 -10) 10)
         (wait 60)))))

  (define (enemy polarity start)
    (make-popcorn polarity start
                  (sequence
                    (wait (if (eq? polarity 'dark) 30 0))
                    (move-linear (vector2 0 -120) 90)
                    (action polarity))))

  (list (enemy polarity (vector2 20 200))
        (enemy polarity (vector2 20 220))
        (enemy polarity (vector2 20 240))
        (enemy (polarity-not polarity) (vector2 40 200))
        (enemy (polarity-not polarity) (vector2 40 220))
        (enemy (polarity-not polarity) (vector2 40 240))
        (enemy polarity (vector2 60 200))
        (enemy polarity (vector2 60 220))
        (enemy polarity (vector2 60 240))
        (enemy (polarity-not polarity) (vector2 80 200))
        (enemy (polarity-not polarity) (vector2 80 220))
        (enemy (polarity-not polarity) (vector2 80 240))
        (enemy polarity (vector2 100 200))
        (enemy polarity (vector2 100 220))
        (enemy polarity (vector2 100 240))))

(define (make-intro-wave make-enemy* polarity1 polarity2 polarity3 bullet-speed)
  (define (bullet-type* polarity)
    (match polarity
      ('light 'small-light)
      ('dark 'small-dark)))

  (define (action polarity)
    (let ((shoot (repeat 8
                         (sequence
                           (enemy-shoot* (bullet-type* polarity)
                                         bullet-speed
                                         (* 0.125 pi))
                           (enemy-shoot* (bullet-type* polarity)
                                         bullet-speed
                                         0)
                           (enemy-shoot* (bullet-type* polarity)
                                         bullet-speed
                                         (* -0.125 pi)))))
          (theta (/ pi 16)))
      (sequence
        (aim-enemy* (* 1.5 pi))
        (forever
         (sequence
           shoot
           (aim-enemy* theta)
           shoot
           (aim-enemy* theta)
           shoot
           (aim-enemy* (- theta))
           shoot
           (aim-enemy* (- theta))
           shoot
           (aim-enemy* (- theta))
           shoot
           (aim-enemy* (- theta))
           shoot
           (aim-enemy* theta)
           shoot
           (aim-enemy* theta))))))

  (define (enemy polarity start)
    (make-enemy* polarity start
                 (sequence
                   (move-linear (vector2 0 -120) 90)
                   (action polarity))))

  (list (enemy polarity1 (vector2 20 250))
        (enemy polarity2 (vector2 60 250))
        (enemy polarity3 (vector2 100 250))))

(define (make-final-wave)
  (define popcorn-bullet-speed 1)

  (define shoot-down-light
    (sequence
      (aim-enemy* (* 1.5 pi))
      (forever
       (sequence
         (move-linear (vector2 5 0) 5)
         (repeat 20
                 (sequence
                   (enemy-shoot* 'small-light popcorn-bullet-speed 0)
                   (wait 3)))
         (move-linear (vector2 -5 0) 5)
         (wait 150)))))

  (define shoot-down-dark
    (sequence
      (aim-enemy* (* 1.5 pi))
      (forever
       (sequence
         (move-linear (vector2 -5 0) 5)
         (repeat 20
                 (sequence
                   (enemy-shoot* 'small-dark popcorn-bullet-speed 0)
                   (wait 3)))
         (move-linear (vector2 5 0) 5)
         (wait 150)))))

  (define popcorn-start-height 225)

  (define (make-popcorn* polarity n x)
    (make-popcorn polarity
                  (vector2 x (+ popcorn-start-height (* 16 n)))
                  (sequence
                    (move-linear (vector2 0 -120) 90)
                    (wait (* 60 n))
                    (if (eq? polarity 'light)
                        shoot-down-light
                        shoot-down-dark))))

  (define (make-pincer* polarity x)
    (define bullet-type*
      (if (eq? polarity 'light)
          'large-light
          'large-dark))

    (define speed (if (eq? polarity 'light) .6 .4))

    (make-pincer polarity
                 (vector2 x 200)
                 (sequence
                   (move-linear (vector2 0 -110) 80)
                   (forever
                    (sequence
                      (enemy-shoot* 'large-light speed 0)
                      (enemy-shoot* 'large-dark speed (* .25 pi))
                      (enemy-shoot* 'large-light speed (* .5 pi))
                      (enemy-shoot* 'large-dark speed (* .75 pi))
                      (enemy-shoot* 'large-light speed pi)
                      (enemy-shoot* 'large-dark speed  (* 1.25 pi))
                      (enemy-shoot* 'large-light speed (* 1.5 pi))
                      (enemy-shoot* 'large-dark speed (* 1.75 pi))
                      (aim-enemy* (/ pi 32))
                      (wait 6))))))

  (append
   (list (make-pincer* 'light 20)
         (make-pincer* 'dark 60)
         (make-pincer* 'light 100))
   (concatenate
    (list-tabulate 8
                   (lambda (n)
                     (let ((x (+ 8 (* 15 n)))
                           (polarity (if (even? n) 'light 'dark)))
                       (list (make-popcorn* polarity 0 x)
                             (make-popcorn* (polarity-not polarity) 1 x)
                             (make-popcorn* polarity 2 x))))))))

(define %waves
  (list (make-intro-wave make-popcorn 'light 'light 'light 1)
        (make-intro-wave make-popcorn 'dark 'dark 'dark 1)
        (make-intro-wave make-popcorn 'light 'light 'light 3)
        (make-intro-wave make-popcorn 'dark 'dark 'dark 3)
        (make-easy-wave 'light 1)
        (make-easy-wave 'dark 1)
        (make-easy-wave 'light 2)
        (make-easy-wave 'dark 2)
        (make-intro-wave make-pincer 'light 'dark 'light 1.2)
        (make-intro-wave make-pincer 'dark 'light 'dark 1.2)
        (make-medium-wave 'light)
        (make-medium-wave 'dark)
        (make-final-wave)))

(define %default-world
  (make-world #:player %default-player))


;;;
;;; Controller
;;;

(define-signal timer (signal-timer))

(define-signal world
  (signal-fold world-eval
               %default-world
               (signal-merge
                (make-signal '(null))
                (signal-let ((time timer))
                  `(tick ,time))
                (signal-let ((direction key-arrows))
                  `(player-direction ,direction))
                (signal-let ((shoot? (signal-drop-repeats (key-down? 'z))))
                  `(player-shoot ,shoot?))
                (signal-let ((toggle?
                              (signal-filter identity #f
                                             (signal-drop-repeats
                                              (key-down? 'x)))))
                  `(player-toggle-polarity))
                (signal-let ((restart? (key-down? 'return)))
                  `(restart ,restart?)))))

(define (key-toggle key)
  "Create a signal that is initially #f and toggles between #t and #f
each time KEY is pressed."
  (signal-fold (lambda (down? previous)
                 (and down? (not previous)))
               #f
               (signal-filter identity #f
                              ;; Ignore repeated key down signals.
                              (signal-drop-repeats (key-down? key)))))

(define-signal display-fps? (key-toggle 'f))


;;;
;;; Music and Sound
;;;

(define load-music*
  (memoize
   (lambda (file)
     (load-music (string-append "assets/music/" file)))))

(define-signal music
  (signal-drop-repeats
   (signal-let ((world world))
     (load-music* (cond
                   ((game-intro? world) "title-screen.ogg")
                   ((game-over? world) "ending.ogg")
                   ((game-won? world) "title-screen.ogg")
                   (else "level-2.ogg"))))))

(define (loop-music music)
  (play-music music #:loop? #t))

(define (load-sample* file)
  (load-sample (string-append "assets/sounds/" file)))

(define (enemy-hit-sound world time)
  (and (any (lambda (enemy)
              (let ((hit-time (enemy-last-hit-time (actor-ref enemy))))
                (and hit-time (= time hit-time))))
            (world-enemies world))
       'enemy-hit))

(define (player-shoot-sound world time)
  (and (zero? (modulo time 5))
       (player-shooting? (actor-ref (world-player world)))
       'player-shoot))

(define (player-death-sound world time)
  (and (let ((death-time (player-last-death-time
                          (actor-ref (world-player world)))))
         (and death-time (= time death-time)))
       'player-death))

(define (explosion-sound world time)
  (and (any (lambda (explosion)
              (let ((explode-time (explosion-time explosion)))
                (= time explode-time)))
            (world-explosions world))
       'explosion))

(define (play-sound-effects sounds)
  (for-each play-sample sounds))

(define-signal sounds
  (on-start
   `((enemy-hit . ,(load-sample* "hit.wav"))
     (explosion . ,(load-sample* "explosion.wav"))
     (player-death . ,(load-sample* "player-death.wav"))
     (player-shoot . ,(load-sample* "player-shoot.wav")))))

(define-signal sound-effects
  (signal-let ((world world)
               (time timer)
               (sounds sounds))
    (filter-map (lambda (sound-proc)
                  (let ((sound (sound-proc world time)))
                    (and sound (assq-ref sounds sound))))
                (list enemy-hit-sound
                      player-shoot-sound
                      player-death-sound
                      explosion-sound))))


;;;
;;; View
;;;

(define resolution-scale 4)
(define scaled-resolution (v* resolution resolution-scale))

(define camera
  (2d-camera #:area (make-rect 0 0 (vx resolution) (vy resolution))))

(define scaled-camera
  (2d-camera #:area (make-rect 0 0
                               (vx scaled-resolution)
                               (vy scaled-resolution))))

(define-signal framebuffer
  (on-start
   (make-framebuffer (vx scaled-resolution) (vy scaled-resolution))))

(define-signal framebuffer-sprite
  (signal-map-maybe (lambda (framebuffer)
                      (make-sprite (framebuffer-texture framebuffer)
                                   #:anchor 'bottom-left))
                    framebuffer))

(define-signal font
  (on-start
   (load-font "assets/fonts/kenpixel_mini.ttf" 7)))

(define-signal big-font
  (on-start
   (load-font "assets/fonts/kenpixel_mini.ttf" 16)))

(define font-color (rgb #xdeeed6))

(define-signal fps-text
  (signal-let ((fps fps)
               (font font))
    (if font
        (move (vector2 (vx resolution) 0)
              (render-sprite
               (make-label font
                           (format #f "~d fps" fps)
                           #:blended? #f
                           #:anchor 'bottom-right)))
        render-nothing)))

(define-signal score-text
  (signal-let ((font font)
               (world world))
    (if font
        (move resolution
              (render-sprite
               (make-label font
                           (number->string (stats-score (world-stats world)))
                           #:blended? #f
                           #:anchor 'top-right)))
        render-nothing)))

(define-signal lives-text
  (signal-let ((font font)
               (world world))
    (if font
        (move (vector2 (/ (vx resolution) 2) (vy resolution))
              (render-sprite
               (make-label font
                           (format #f "~d ship"
                                   (stats-lives (world-stats world)))
                           #:blended? #f
                           #:anchor 'top-center)))
        render-nothing)))

(define-signal chain-text
  (signal-let ((font font)
               (world world))
    (if font
        (move (vector2 1 (vy resolution))
              (render-sprite
               (make-label font
                           (format #f "~d chain"
                                   (stats-chain (world-stats world)))
                           #:blended? #f
                           #:anchor 'top-left)))
        render-nothing)))

(define render-status-text
  (memoize
   (lambda (font text)
     (render-sprite
      (make-label font text #:blended? #f #:anchor 'center)))))

(define-signal status-text
  (signal-let ((big-font big-font)
               (font font)
               (world world))
    (cond
     ((or (not font) (not big-font))
      render-nothing)
     ((game-over? world)
      (move (v* resolution 0.5)
            (render-begin
             (render-status-text big-font "GAME OVER")
             (move (vector2 0 -16)
                   (render-status-text font "Press ENTER to play again"))
             (move (vector2 0 -28)
                   (render-status-text font "Press ESC to quit")))))
     ((game-won? world)
      (move (v* resolution 0.5)
            (render-begin
             (render-status-text big-font "COMPLETE!")
             (move (vector2 0 -16)
                   (render-status-text font "Press ENTER to play again"))
             (move (vector2 0 -28)
                   (render-status-text font "Press ESC to quit")))))
     ((game-intro? world)
      (move (v* resolution (vector2 0.5 0.8))
            (render-begin
             (render-status-text font "Use arrow keys to move")
             (move (vector2 0 -12)
                   (render-status-text font "Press Z to shoot"))
             (move (vector2 0 -24)
                   (render-status-text font "Press X to change polarity"))
             (move (vector2 0 -36)
                   (render-status-text font "Press ESC to quit"))
             (move (vector2 0 -60)
                   (render-status-text big-font "Press ENTER")))))
     (else
      render-nothing))))

(define load-sprite/live (with-live-reload load-sprite))
(define load-tileset/live (with-live-reload load-tileset))

(define-signal background
  (load-sprite/live "assets/images/background.png"
                    #:anchor 'bottom-left))

(define-signal background-overlay
  (load-sprite/live "assets/images/background-overlay.png"
                    #:anchor 'bottom-left))

(define-signal player-tileset
  (load-tileset/live "assets/images/player.png" 16 16))

(define-signal bullet-tileset
  (load-tileset/live "assets/images/bullets.png" 16 16))

(define-signal enemy-tileset
  (load-tileset/live "assets/images/enemies.png" 16 16))

(define-signal explosion-tileset
  (load-tileset/live "assets/images/explosion.png" 16 16))

(define-signal chain-tileset
  (load-tileset/live "assets/images/chain.png" 24 16))

(define make-chain-sprite
  (memoize
   (lambda (tileset stats)
     (make-sprite (tileset-ref tileset
                               (- (match (stats-chain-type stats)
                                    ('light 2)
                                    ('dark  5))
                                  (1- (stats-chain-progress stats))))
                  #:anchor 'top-left))))

(define-signal chain-sprite
  (signal-map-maybe (lambda (world tileset)
                      (let ((stats (world-stats world)))
                        (if (zero? (stats-chain-progress stats))
                            render-nothing
                            (move (vector2 0 (- (vy resolution) 5))
                                  (render-sprite
                                   (make-chain-sprite tileset stats))))))
                    world
                    chain-tileset))

(define-signal player-sprite
  (signal-map-maybe (lambda (world tileset)
                      (make-sprite
                       (let* ((player (actor-ref (world-player world)))
                              (dx (vx (player-direction player)))
                              (offset (cond
                                       ((zero? dx) 0)
                                       ((positive? dx) 1)
                                       ((negative? dx) 2))))
                         (tileset-ref tileset
                                      (+ (match (player-polarity player)
                                           ('light 12)
                                           ('dark 8))
                                         offset)))))
                    world
                    player-tileset))

(define (make-scrolling-background background time speed)
  (signal-let ((background background)
               (time timer))
    (if background
        (let* ((height (vy resolution))
               (y (- (* (modulo time (round (/ height speed))) speed)))
               (render (render-sprite background)))
          (render-begin
           (move (vector2 0 y) render)
           (move (vector2 0 (+ y height)) render)))
        render-nothing)))

(define (render-sprite-maybe sprite)
  (signal-map (lambda (sprite)
                (if sprite
                    (render-sprite sprite)
                    render-nothing))
              sprite))

(define-signal scrolling-background
  (signal-map render-begin
              ;;(make-scrolling-background background timer 0.2)
              (render-sprite-maybe background)
              (make-scrolling-background background-overlay timer 4)))

(define-signal batch
  (on-start (make-sprite-batch 1000)))

(define bullet-rect (make-rect -8 -8 16 16))
(define enemy-rect (make-rect -8 -8 16 16))
(define explosion-rect (make-rect -8 -8 16 16))

(define (render-bullets bullets tileset batch)
  (lambda (context)
    (with-sprite-batch batch context
      (for-each (lambda (actor)
                  (let* ((bullet (actor-ref actor))
                         (rect (rect-move bullet-rect
                                          (bullet-position bullet)))
                         (tex (tileset-ref tileset
                                           (match (bullet-type bullet)
                                             ('player-light 12)
                                             ('player-dark 13)
                                             ('large-light 9)
                                             ('large-dark 8)
                                             ('small-light 11)
                                             ('small-dark 10)))))
                    (sprite-batch-add! batch context tex rect)))
                bullets))))

(define (render-enemies enemies tileset batch time)
  (lambda (context)
    (with-sprite-batch batch context
      (for-each (lambda (actor)
                  (let* ((enemy (actor-ref actor))
                         (hit-time (enemy-last-hit-time enemy))
                         (hit? (and hit-time (zero? (- time hit-time))))
                         (rect (rect-move enemy-rect (enemy-position enemy)))
                         (tex (tileset-ref tileset
                                           (+ (match (enemy-type enemy)
                                                ('popcorn-dark 0)
                                                ('popcorn-light 4)
                                                ('pincer-dark 8)
                                                ('pincer-light 12))
                                              (if hit?
                                                  ;; Use the hit
                                                  ;; indicator frame.
                                                  2
                                                  ;; Swap between the
                                                  ;; 2 normal
                                                  ;; animation frames.
                                                  (modulo (round (/ time 5))
                                                          2))))))
                    (sprite-batch-add! batch context tex rect)))
                enemies))))

(define (render-player player sprite time)
  (if (and (player-invincible? player time)
           (odd? (round (/ time 3))))
      render-nothing
      (move (player-position player)
            (render-sprite sprite))))

(define (render-explosions explosions tileset batch time)
  (lambda (context)
    (with-sprite-batch batch context
      (for-each (lambda (explosion)
                  (let* ((start-time (explosion-time explosion))
                         (rect (rect-move explosion-rect
                                          (explosion-position explosion)))
                         ;; 3 frames of animation.
                         (frame (min 2 (floor (/ (- time start-time) 5))))
                         (tex (tileset-ref tileset frame)))
                    (sprite-batch-add! batch context tex rect)))
                explosions))))

(define-signal scene
  (signal-let ((fps-text fps-text)
               (score-text score-text)
               (lives-text lives-text)
               (chain-text chain-text)
               (status-text status-text)
               (display-fps? display-fps?)
               (background scrolling-background)
               (framebuffer framebuffer)
               (framebuffer-sprite framebuffer-sprite)
               (player-sprite player-sprite)
               (chain-sprite chain-sprite)
               (bullet-tileset bullet-tileset)
               (enemy-tileset enemy-tileset)
               (explosion-tileset explosion-tileset)
               (batch batch)
               (world world)
               (time timer))
    (if (and framebuffer framebuffer-sprite batch bullet-tileset
             enemy-tileset player-sprite explosion-tileset chain-sprite)
        (let ((player (actor-ref (world-player world))))
          (render-begin
           (with-framebuffer framebuffer
             (with-camera camera
               (render-begin
                background
                (render-explosions (world-explosions world)
                                   explosion-tileset
                                   batch
                                   time)
                (render-bullets (world-player-bullets world)
                                bullet-tileset
                                batch)
                (if (game-over? world)
                    render-nothing
                    (render-player player player-sprite time))
                (render-enemies (world-enemies world)
                                enemy-tileset
                                batch
                                time)
                (render-bullets (world-enemy-bullets world)
                                bullet-tileset
                                batch)
                (with-color font-color
                  (render-begin
                   (if display-fps?
                       fps-text
                       render-nothing)
                   score-text
                   lives-text
                   chain-text
                   status-text))
                chain-sprite)))
           (with-camera scaled-camera
             (scale resolution-scale (render-sprite framebuffer-sprite)))))
        render-nothing)))


;;;
;;; Main
;;;

(with-window (make-window #:title "lisparuga"
                          #:resolution scaled-resolution)
  (enable-fonts)
  (enable-audio)
  (add-signal-hook! music loop-music)
  (add-signal-hook! sound-effects play-sound-effects)
  (add-hook! key-press-hook (lambda (key)
                              (when (eq? key 'escape)
                                (stop-game-loop))))

  (add-hook! window-close-hook stop-game-loop)
  (start-sly-repl)
  (run-game-loop scene))

;;; Local Variables:
;;; compile-command: "../pre-inst-env guile simple.scm"
;;; End: