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 match)
             (sly)
             (sly actor)
             (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 origin2 (vector2 0 0))

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

(define-record-type* <player>
  %make-player make-player
  player?
  (position player-position (vector2 (/ (vx resolution) 2) 4))
  (direction player-direction (vector2 0 0))
  (shooting? player-shooting? #f)
  (hitbox player-hitbox (make-rect -1 1 2 2))
  (lives player-lives 3)
  (score player-score 0))

(define-record-type* <enemy>
  %make-enemy make-enemy
  enemy?
  (position enemy-position origin2)
  (type enemy-type 'generic)
  (hitbox enemy-hitbox (make-rect -3 -3 6 6))
  (health enemy-health 0))

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

(define (player-dead? player)
  (zero? (player-lives player)))

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

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

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

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

(define (make-player-bullet player offset)
  (make-actor (make-bullet #:position (v+ (player-position player) offset)
                           #: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 (move-enemy enemy offset)
  (make-enemy #:inherit enemy
              #:position (v+ (enemy-position enemy) offset)))

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

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

(define (enemy-shoot world enemy direction speed)
  (let ((position (enemy-position enemy)))
    (add-enemy-bullets world
                       (list
                        (simple-enemy-bullet position direction speed)))))

(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 (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)
  ;; TODO: collision detection
  (let*-values
      (((effects new-player) (update-player '() world))
       ((effects new-enemies) (update-enemies effects world))
       ((effects new-player-bullets)
        (update-bullets effects world (world-player-bullets world)))
       ((effects new-enemy-bullets)
        (update-bullets effects world (world-enemy-bullets world))))
    (apply-effects effects
                   (make-world #:player new-player
                               #:player-bullets new-player-bullets
                               #:enemies new-enemies
                               #:enemy-bullets new-enemy-bullets))))

(define (world-eval exp world)
  (match exp
    (('null) world)
    (('tick time)
     (update-world world))
    (('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?)))))))

(define player-shoot* (action-effect-lift player-shoot))
(define move-enemy* (action-lift move-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 %default-enemy
  (make-actor (make-enemy #:position (vector2 60 120)
                          #:health 100)
              (let ((v (vector2 .8 0))
                    (bullet-speed 0.6)
                    (interval 15))
                (forever
                 (sequence
                   (repeat interval (move-enemy* v))
                   (enemy-shoot-at-player* bullet-speed)
                   (repeat interval (move-enemy* (v- v)))
                   (enemy-shoot-at-player* bullet-speed)
                   (repeat interval (move-enemy* (v- v)))
                   (enemy-shoot-at-player* bullet-speed)
                   (repeat interval (move-enemy* v))
                   (enemy-shoot-at-player* bullet-speed))))))


;;;
;;; Controller
;;;

(define-signal timer (signal-timer))

(define-signal world
  (signal-fold world-eval
               (make-world #:player %default-player
                           #:enemies (list %default-enemy))
               (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?)))))

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


;;;
;;; 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 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))
    (if font
        (move resolution
              (render-sprite
               (make-label font "123456789"
                           #:blended? #f
                           #:anchor 'top-right)))
        render-nothing)))

(define-signal lives-text
  (signal-let ((font font))
    (if font
        (move origin2
              (render-sprite
               (make-label font "3 ship"
                           #:blended? #f
                           #:anchor 'bottom-left)))
        render-nothing)))

(define-signal chain-text
  (signal-let ((font font))
    (if font
        (move (vector2 0 (vy resolution))
              (render-sprite
               (make-label font "0 chain"
                           #:blended? #f
                           #:anchor 'top-left)))
        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 player-sprite
  (signal-map-maybe (lambda (tileset)
                      (make-sprite (tileset-ref tileset 12)))
                    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 (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)
                                             ('generic 12)
                                             ('enemy-basic 13)))))
                    (sprite-batch-add! batch context tex rect)))
                bullets))))

(define (render-enemies enemies tileset batch)
  (lambda (context)
    (with-sprite-batch batch context
      (for-each (lambda (actor)
                  (let* ((enemy (actor-ref actor))
                         (rect (rect-move enemy-rect (enemy-position enemy)))
                         (tex (tileset-ref tileset
                                           (match (enemy-type enemy)
                                             ('generic 12)))))
                    (sprite-batch-add! batch context tex rect)))
                enemies))))

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


;;;
;;; Main
;;;

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

(enable-fonts)

(with-window (make-window #:title "binarium"
                          #:resolution scaled-resolution)
  (run-game-loop scene))

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