From f98b1e35944dde31250fa758be88adbc0619b3b0 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 30 Apr 2016 08:46:33 -0400
Subject: Add project base code and assets.

---
 game.scm | 519 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 519 insertions(+)
 create mode 100644 game.scm

(limited to 'game.scm')

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:
-- 
cgit v1.2.3