diff options
Diffstat (limited to 'game.scm')
| -rw-r--r-- | game.scm | 519 |
1 files changed, 519 insertions, 0 deletions
diff --git a/game.scm b/game.scm new file mode 100644 index 0000000..1616398 --- /dev/null +++ b/game.scm @@ -0,0 +1,519 @@ +;;; 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: |