;;; Sly ;;; Copyright (C) 2016 David Thompson ;;; ;;; 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 ;;; . (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 player-attack 1) (define origin2 (vector2 0 0)) ;;; ;;; Data types ;;; (define-record-type* %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* %make-player make-player player? (polarity player-polarity 'light) (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 4)) (absorb-hitbox player-absorb-hitbox (make-rect -9 -2 16 6)) (last-death-time player-last-death-time #f)) (define-record-type* %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 'popcorn-light) (polarity enemy-polarity 'light) (hitbox enemy-hitbox (make-rect -3 -3 6 6)) (last-hit-time enemy-last-hit-time #f) (health enemy-health 0)) (define-record-type* %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* %make-explosion make-explosion explosion? (type explosion-type 'regular) (position explosion-position origin2) (time explosion-time 0)) (define-record-type* %make-world make-world world? (level world-level #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 4))) (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 (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 (explosion-active? explosion current-time) (> (- current-time (explosion-time explosion)) 120)) ;;; ;;; 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 stats enemy) ;; 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))))) ;;; ;;; 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))))) (values new-enemy ;; Remove bullet. (append (reverse prev-bullets) rest) (if (enemy-alive? (actor-ref new-enemy)) stats ;; Enemy killed, add to player score. (add-to-score stats (actor-ref new-enemy))) (if (enemy-alive? (actor-ref new-enemy)) explosions ;; Add new explosion. (cons (make-explosion #:type 'regular #:position (enemy-position (actor-ref 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 (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) ;; 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))) ((stats) (world-stats world)) ((new-enemies new-player-bullets new-stats explosions1) (collide-enemies-and-bullets new-enemies new-player-bullets stats time)) ((new-player new-enemy-bullets new-stats explosions3) (collide-player-and-bullets new-player new-enemy-bullets new-stats time)) ((new-player new-stats explosions2) (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 #: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))))) (define (game-over? world) (zero? (stats-lives (world-stats world)))) (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?)) (signal-let ((toggle? (signal-filter identity #f (signal-drop-repeats (key-down? 'x))))) `(player-toggle-polarity))))) (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) (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 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 (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 (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 9) ('player-light 12) ('player-dark 13) ('large-light 9) ('dark-light 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-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) (time timer)) (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) (render-player player player-sprite time) (render-bullets (world-enemy-bullets world) bullet-tileset batch) (render-enemies (world-enemies world) enemy-tileset batch time) (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: