path: root/game.scm

;;; Lisparuga
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;;
;;; Lisparuga 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.
;;;
;;; Lisparuga 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 Lisparuga.  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)
             (lisparuga bullets)
             (lisparuga enemies)
             (lisparuga explosions)
             (lisparuga player)
             (lisparuga stats)
             (lisparuga utils)
             (lisparuga world))


;;;
;;; 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: