From 2bdb665cffff93721bbd38b3809a7c420dff2f1c Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 12 Apr 2020 21:59:35 -0400
Subject: Day 3 progress.

---
 lisparuga/enemy.scm   |  10 +-
 lisparuga/game.scm    | 281 +++++++++++++++++++++++++++++++++++++++++---------
 lisparuga/node-2d.scm |  26 ++++-
 lisparuga/player.scm  |  51 ++++++---
 4 files changed, 304 insertions(+), 64 deletions(-)

(limited to 'lisparuga')

diff --git a/lisparuga/enemy.scm b/lisparuga/enemy.scm
index 0589d16..aa5335e 100644
--- a/lisparuga/enemy.scm
+++ b/lisparuga/enemy.scm
@@ -21,6 +21,7 @@
 ;;; Code:
 
 (define-module (lisparuga enemy)
+  #:use-module (chickadee audio)
   #:use-module (chickadee math)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
@@ -46,6 +47,9 @@
 ;;;
 ;;; Base Enemy
 ;;;
+
+(define-asset explosion-sound (load-audio (scope-asset "sounds/explosion.wav")))
+
 (define-class <enemy> (<actor>)
   (health #:accessor health #:init-keyword #:health)
   (points #:getter points #:init-keyword #:points)
@@ -56,7 +60,11 @@
   #t)
 
 (define-method (damage (enemy <enemy>) x)
-  (set! (health enemy) (max (- (health enemy) x) 0)))
+  (let ((new-health (max (- (health enemy) x) 0)))
+    (set! (health enemy) new-health)
+    (when (zero? new-health)
+      (audio-play (asset-ref explosion-sound)
+                  #:volume 0.5))))
 
 (define-method (dead? (enemy <enemy>))
   (zero? (health enemy)))
diff --git a/lisparuga/game.scm b/lisparuga/game.scm
index 5b14edd..9e79898 100644
--- a/lisparuga/game.scm
+++ b/lisparuga/game.scm
@@ -22,9 +22,11 @@
 ;;; Code:
 
 (define-module (lisparuga game)
+  #:use-module (chickadee)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
   #:use-module (chickadee render color)
+  #:use-module (chickadee render particles)
   #:use-module (chickadee render texture)
   #:use-module (chickadee scripting)
   #:use-module (ice-9 format)
@@ -42,17 +44,36 @@
             start-player-shooting
             stop-player-shooting
             toggle-player-polarity
-            fire-player-homing-missiles))
+            fire-player-homing-missiles
+            spawn-enemies
+            start-stage
+            game-over?
+            complete?))
 
 (define-asset clouds (load-image (scope-asset "images/clouds.png")))
 (define-asset player-bullet-atlas
   (load-tile-atlas (scope-asset "images/player-bullets.png") 16 16))
 (define-asset enemy-bullet-atlas
   (load-tile-atlas (scope-asset "images/enemy-bullets.png") 24 24))
+(define-asset explosion-texture
+  (load-image (scope-asset "images/explosion.png")))
 
 ;; nodes needed:
 ;; scrolling background
-(define-class <game> (<node-2d>))
+(define-class <game> (<canvas>)
+  (player-control? #:accessor player-control? #:init-value #f)
+  (complete? #:accessor complete? #:init-value #f))
+
+(define-method (initialize (game <game>) initargs)
+  (next-method)
+  (set! (views game)
+    ;; Game happens on a 160x240 pixel screen.
+    (list (make <view-2d>
+            #:camera (make <camera-2d>
+                       #:width 160
+                       #:height 240)
+            #:area (make-rect 80 0 160 240)
+            #:clear-color (make-color 0.0 0.0 0.0 1.0)))))
 
 (define-method (on-boot (game <game>))
   (let* ((player-bullets (make <bullet-field>
@@ -60,58 +81,79 @@
                            #:rank 2
                            #:capacity 500
                            #:texture-atlas player-bullet-atlas))
-         (player (make-player player-bullets))
          (enemy-bullets (make <bullet-field>
                           #:name 'enemy-bullets
-                          #:rank 4
+                          #:rank 5
                           #:capacity 1000
                           #:texture-atlas enemy-bullet-atlas))
+         (explosions (make <particles>
+                       #:name 'explosions
+                       #:rank 3
+                       #:particles
+                       (make-particles 1000
+                                       #:texture (asset-ref explosion-texture)
+                                       #:end-color (make-color 1.0 1.0 1.0 0.0)
+                                       #:speed-range (vec2 0.5 5.0)
+                                       #:lifetime 12)))
          (ui (make <node-2d>
                #:name 'ui
                #:rank 999)))
-    (set! (rank player) 1)
     (attach-to game
                (make <sprite>
                  #:name 'clouds
                  #:rank 0
                  #:texture clouds)
-               player
                player-bullets
                (make <node-2d>
                  #:name 'enemies
-                 #:rank 3)
+                 #:rank 4)
+               explosions
                enemy-bullets
                ui)
     ;; Setup UI elements
+    ;; TODO: Move this out of here.
     (attach-to ui
                (make <label>
                  #:name 'score
-                 #:position (vec2 2.0 226.0))
+                 #:position (vec2 2.0 242.0)
+                 #:vertical-align 'top)
                (make <label>
                  #:name 'chain
-                 #:position (vec2 2.0 210.0))
+                 #:position (vec2 158.0 242.0)
+                 #:align 'right
+                 #:vertical-align 'top)
                (make <label>
                  #:name 'energy
-                 #:position (vec2 2.0 18.0))
+                 #:position (vec2 158.0 2.0)
+                 #:align 'right)
                (make <label>
                  #:name 'lives
                  #:position (vec2 2.0 2.0)))
+    (start-stage game)))
+
+(define-method (start-stage (game <game>))
+  (let ((player (make-player (& game player-bullets))))
+    (set! (rank player) 1)
+    (attach-to game player)
     (update-ui game)
-    ;; Test enemy
-    (spawn-enemy game (make-utatsugumi 'white 10.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'white 30.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'white 50.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'black 70.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'black 90.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'black 110.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'white 130.0 180.0))
-    (spawn-enemy game (make-utatsugumi 'white 150.0 180.0))))
-
-(define (update-ui game)
+    (play-stage-1 game)))
+
+(define-method (spawn-enemies (game <game>))
+  ;; Test enemies
+  (spawn-enemy game (make-utatsugumi 'white 10.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'white 30.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'white 50.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'black 70.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'black 90.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'black 110.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'white 130.0 180.0))
+  (spawn-enemy game (make-utatsugumi 'white 150.0 180.0)))
+
+(define-method (update-ui (game <game>))
   (set! (text (& game ui score))
-    (format #f "~9,'0d" (score (& game player))))
+    (format #f "~7,'0d" (score (& game player))))
   (set! (text (& game ui chain))
-    (format #f "CHAIN ~a: ~a"
+    (format #f "~a CHAIN (~a)"
             (let ((n (chain (& game player))))
               (if (< n 9) (number->string n) "MAX"))
             (list->string
@@ -121,48 +163,189 @@
                         #\B))
                   (chain-progress (& game player))))))
   (set! (text (& game ui energy))
-    (format #f "E~d" (quotient (energy (& game player)) 10)))
+    (format #f "ENERGY ~d" (quotient (energy (& game player)) 10)))
   (set! (text (& game ui lives))
-    (format #f "x~d" (max (- (lives (& game player)) 1) 0))))
+    (format #f "SHIP x~d" (max (- (lives (& game player)) 1) 0))))
+
+(define-method (explode (game <game>) (actor <actor>))
+  (let* ((p (position actor))
+         (emitter (make-particle-emitter (make-rect (- (vec2-x p) 8.0)
+                                                    (- (vec2-y p) 8.0)
+                                                    16.0 16.0)
+                                         8 5)))
+    (add-particle-emitter (particles (& game explosions)) emitter)))
 
 (define-method (update (game <game>) dt)
   (let ((refresh-ui? #f)
         (player (& game player)))
-    ;; enemy -> player bullet collision
-    ;; enemy -> player collision
-    (for-each (lambda (enemy)
-                (cond
-                 ((and (collide (& game player-bullets) enemy)
-                       (dead? enemy))
-                  (on-kill player enemy)
-                  (fire-parting-shots-maybe enemy player)
-                  (detach enemy)
-                  (set! refresh-ui? #t))
-                 ((collide player enemy)
-                  (set! refresh-ui? #t))))
-              (children (& game enemies)))
-    ;; player -> enemy bullet collision
-    (when (collide (& game enemy-bullets) (& game player))
-      (set! refresh-ui? #t))
-    (when refresh-ui?
-      (update-ui game))))
+    (when player
+      ;; enemy -> player bullet collision
+      ;; enemy -> player collision
+      (for-each (lambda (enemy)
+                  (cond
+                   ((and (collide (& game player-bullets) enemy)
+                         (dead? enemy))
+                    (on-kill player enemy)
+                    (fire-parting-shots-maybe enemy player)
+                    (explode game enemy)
+                    (detach enemy)
+                    (set! refresh-ui? #t))
+                   ((collide player enemy)
+                    (set! refresh-ui? #t))))
+                (children (& game enemies)))
+      ;; player -> enemy bullet collision
+      (when (collide (& game enemy-bullets) (& game player))
+        (set! refresh-ui? #t))
+      (when refresh-ui?
+        (update-ui game)))
+    (next-method)))
 
 (define-method (spawn-enemy (game <game>) enemy)
   (set! (bullet-field enemy) (& game enemy-bullets))
   (attach-to (& game enemies) enemy))
 
 (define-method (steer-player (game <game>) up? down? left? right?)
-  (steer (& game player) up? down? left? right?))
+  (when (player-control? game)
+    (steer (& game player) up? down? left? right?)))
 
 (define-method (start-player-shooting (game <game>))
-  (start-shooting (& game player)))
+  (when (player-control? game)
+    (start-shooting (& game player))))
 
 (define-method (stop-player-shooting (game <game>))
-  (stop-shooting (& game player)))
+  (when (player-control? game)
+    (stop-shooting (& game player))))
 
 (define-method (toggle-player-polarity (game <game>))
-  (toggle-polarity (& game player)))
+  (when (player-control? game)
+    (toggle-polarity (& game player))))
 
 (define-method (fire-player-homing-missiles (game <game>))
-  (fire-homing-missiles (& game player) (children (& game enemies)))
-  (update-ui game))
+  (when (player-control? game)
+    (fire-homing-missiles (& game player) (children (& game enemies)))
+    (update-ui game)))
+
+(define-method (game-over? (game <game>))
+  (let ((player (& game player)))
+    (and player (dead? player))))
+
+(define-method (play-stage-1 game)
+  (run-script game
+    (do-intro game)
+    (do-tutorial game)
+    (do-phase-1 game)
+    (do-win game)))
+
+(define-method (do-intro (game <game>))
+  (hide (& game ui))
+  (teleport (& game player) 80.0 -24.0)
+  (move-to (& game player) 80.0 32.0 50)
+  (steer (& game player) #f #f #f #f)
+  (set! (player-control? game) #t)
+  (show (& game ui)))
+
+(define *skip-tutorial?* #t)
+
+(define-method (do-tutorial (game <game>))
+  (define* (instruct text continue? #:optional (post-delay 60))
+    (let ((instructions (make <label>
+                          #:text text
+                          #:align 'center
+                          #:vertical-align 'center
+                          #:position (vec2 80.0 120.0))))
+      (attach-to (& game ui) instructions)
+      (while (not (continue?))
+        (sleep 10))
+      (sleep post-delay)
+      (detach instructions)
+      (sleep 60)))
+  (unless *skip-tutorial?*
+    (sleep 30)
+    (instruct "use arrow keys to move"
+              (let ((v (velocity (& game player))))
+                (lambda ()
+                  (not (and (= (vec2-x v) 0.0)
+                            (= (vec2-y v) 0.0))))))
+    (instruct "press Z to shoot"
+              (lambda ()
+                (shooting? (& game player))))
+    (instruct "press X to change color"
+              (let ((starting-polarity (polarity (& game player))))
+                (lambda ()
+                  (not (eq? (polarity (& game player)) starting-polarity)))))
+    (instruct "avoid opposite energy" (const #t) 120)
+    (instruct "absorb same energy" (const #t) 120)
+    (add-energy (& game player) 120)
+    (update-ui game)
+    (instruct "press C to release energy"
+              (lambda ()
+                (zero? (energy (& game player)))))
+    (instruct "get ready!" (const #t) 120)))
+
+(define-method (do-phase-1 (game <game>))
+  (define (utatsugumi-sweep x polarity)
+    (let loop ((i 0))
+      (when (< i 6)
+        (let ((utatsugumi (make-utatsugumi polarity x 260.0)))
+          (spawn-enemy game utatsugumi)
+          (set-vec2! (velocity utatsugumi) 0.0 -3.0)
+          (script
+           (sleep (* 10 60))
+           (detach utatsugumi))
+          (sleep 10))
+        (loop (+ i 1)))))
+  (utatsugumi-sweep 140.0 'white)
+  (sleep 60)
+  (utatsugumi-sweep 20.0 'black)
+  (sleep 60)
+  (utatsugumi-sweep 140.0 'white)
+  (sleep 60)
+  (utatsugumi-sweep 20.0 'black)
+  (sleep (* 3 60)))
+
+(define-method (do-win (game <game>))
+  (set! (player-control? game) #f)
+  (steer (& game player) #f #f #f #f)
+  (stop-shooting (& game player))
+  (hide (& game ui))
+  (let ((battle-report (make <node-2d>
+                         #:name 'battle-report
+                         #:rank 999)))
+    (define (add-row y name value)
+      (attach-to battle-report
+                 (make <label>
+                   #:rank 999
+                   #:text name
+                   #:align 'left
+                   #:position (vec2 16.0 y))
+                 (make <label>
+                   #:rank 999
+                   #:text value
+                   #:align 'left
+                   #:position (vec2 96.0 y))))
+    (let ((backdrop (make <filled-rect>
+                      #:region (make-rect 0.0 0.0 160.0 240.0))))
+      (attach-to battle-report backdrop)
+      (attach-to game battle-report)
+      (tween 45 (make-color 0.0 0.0 0.0 0.0) (make-color 0.0 0.0 0.0 0.8)
+             (lambda (c)
+               (set! (color backdrop) c))
+             #:interpolate color-lerp))
+    (attach-to battle-report
+               (make <label>
+                 #:rank 999
+                 #:text "BATTLE REPORT"
+                 #:align 'center
+                 #:position (vec2 80.0 180.0)))
+    (sleep 30)
+    (add-row 140.0 "SCORE" (number->string (score (& game player))))
+    (sleep 30)
+    (add-row 110.0 "MAX CHAIN" (number->string (max-chain (& game player))))
+    (sleep 30)
+    (attach-to battle-report
+               (make <label>
+                 #:rank 999
+                 #:text "press ENTER to play again"
+                 #:position (vec2 80.0 60.0)
+                 #:align 'center))
+    (set! (complete? game) #t)))
diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm
index 0baef54..b6753ef 100644
--- a/lisparuga/node-2d.scm
+++ b/lisparuga/node-2d.scm
@@ -605,7 +605,31 @@
 
 (define-class <label> (<node-2d>)
   (font #:accessor font #:init-keyword #:font #:init-thunk default-font)
-  (text #:accessor text #:init-form "" #:init-keyword #:text))
+  (text #:accessor text #:init-form "" #:init-keyword #:text)
+  (align #:accessor align #:init-value 'left #:init-keyword #:align)
+  (vertical-align #:accessor vertical-align #:init-value 'bottom
+                  #:init-keyword #:vertical-align))
+
+(define-method (initialize (label <label>) initargs)
+  (next-method)
+  (realign label))
+
+(define-method ((setter text) (label <label>) s)
+  (slot-set! label 'text s)
+  (realign label))
+
+(define-method (realign (label <label>))
+  (let ((font (asset-ref (font label))))
+    (set-vec2! (origin label)
+               (match (align label)
+                 ('left 0.0)
+                 ('right (font-line-width font (text label)))
+                 ('center (/ (font-line-width font (text label)) 2.0)))
+               (match (vertical-align label)
+                 ('bottom 0.0)
+                 ('top (font-line-height font))
+                 ('center (/ (font-line-height font) 2.0)))))
+  (dirty! label))
 
 (define-method (render (label <label>) alpha)
   (draw-text* (asset-ref (font label)) (text label) (world-matrix label)))
diff --git a/lisparuga/player.scm b/lisparuga/player.scm
index ca57891..1265756 100644
--- a/lisparuga/player.scm
+++ b/lisparuga/player.scm
@@ -21,6 +21,7 @@
 ;;; Code:
 
 (define-module (lisparuga player)
+  #:use-module (chickadee audio)
   #:use-module (chickadee math)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
@@ -42,17 +43,23 @@
             energy
             chain
             chain-progress
+            max-chain
             speed
+            invincible?
+            shooting?
             steer
             start-shooting
             stop-shooting
             toggle-polarity
             fire-homing-missiles
             kill-maybe
-            on-kill))
+            on-kill
+            add-energy))
 
-(define-asset ship (load-image (scope-asset "images/player.png")))
 (define-asset ship-atlas (load-tile-atlas (scope-asset "images/player.png") 24 24))
+(define-asset shoot-sound (load-audio (scope-asset "sounds/player-shoot.wav")))
+(define-asset missile-sound (load-audio (scope-asset "sounds/player-missile.wav")))
+(define-asset death-sound (load-audio (scope-asset "sounds/player-death.wav")))
 
 (define kill-hitbox (make-hitbox 'kill (make-rect -2.0 -2.0 4.0 4.0)))
 (define graze-hitbox (make-hitbox 'graze (make-rect -12.0 -12.0 24.0 24.0)))
@@ -63,16 +70,20 @@
   (energy #:accessor energy #:init-value 0)
   (chain #:accessor chain #:init-value 0)
   (chain-progress #:accessor chain-progress #:init-form '())
+  (max-chain #:accessor max-chain #:init-value 0)
   (speed #:accessor speed #:init-value 2.5)
   (invincible? #:accessor invincible? #:init-value #f)
   (shooting? #:accessor shooting? #:init-value #f)
   (shoot-time #:accessor shoot-time #:init-value 0))
 
+(define-method (dead? (player <player>))
+  (zero? (lives player)))
+
 (define (make-player bullet-field)
   (make <player>
     #:name 'player
     #:hitboxes (list graze-hitbox kill-hitbox)
-    #:position (vec2 80.0 24.0)
+    #:position (vec2 80.0 -24.0)
     #:bullet-field bullet-field
     #:polarity 'white))
 
@@ -121,11 +132,13 @@
         (cond
          ;; single shot
          ((zero? t)
+          (audio-play (asset-ref shoot-sound))
           (shoot player 0.0))
          ;; double shot. give a buffer of 4 frames so players can
          ;; reliably fire just a single shot.
          ((> t 4)
-          (shoot player 5.0)
+          (audio-play (asset-ref shoot-sound))
+          (shoot player 6.0)
           (shoot player -5.0))))
       (set! (shoot-time player) (+ t 1))))
   (next-method))
@@ -188,9 +201,10 @@
         (if enemy
             (let* ((ep (position enemy)))
               (define (aim-at-enemy bp bv)
-                (let ((dir (atan (- (vec2-y ep) (vec2-y bp))
-                                 (- (vec2-x ep) (vec2-x bp)))))
-                  (set-vec2! bv (* (cos dir) speed) (* (sin dir) speed))))
+                (unless (dead? enemy)
+                  (let ((dir (atan (- (vec2-y ep) (vec2-y bp))
+                                   (- (vec2-x ep) (vec2-x bp)))))
+                    (set-vec2! bv (* (cos dir) speed) (* (sin dir) speed)))))
               (run-script player
                 (let loop ((i 0))
                   (when (< i n)
@@ -206,6 +220,9 @@
                                 (vec2-x p) (vec2-y p)
                                 (* (cos theta) speed) (* (sin theta) speed))
                   (loop (+ i 1))))))))
+    (when (> e 10)
+      (audio-play (asset-ref missile-sound)
+                  #:volume 0.5))
     ;; Distribute missiles amongst closest enemies
     (let loop ((enemies enemies)
                (missiles-remaining (quotient e 10))
@@ -229,15 +246,22 @@
                   (loop enemies 0 (+ missiles-used missiles-remaining)))))))
     #t))
 
-(define-method (increment-energy (player <player>))
-  (set! (energy player) (min (+ (energy player) 1) 120)))
+(define-method (add-energy (player <player>) n)
+  (set! (energy player) (min (+ (energy player) n) 120)))
 
 (define-method (kill-maybe (player <player>))
   (unless (invincible? player)
-    (let ((new-lives (- (lives player) 1)))
+    (audio-play (asset-ref death-sound))
+    (let ((new-lives (max (- (lives player) 1) 0)))
       (set! (lives player) new-lives)
+      (set! (energy player) 0)
       (if (zero? new-lives)
-          (hide player)
+          (begin
+            ;; to stop the death events from happening over and over
+            ;; after game over condition is reached.
+            (set! (invincible? player) #t)
+            (set-vec2! (velocity player) 0.0 0.0)
+            (hide player))
           ;; Give player invincibility for a bit while they recover.
           (run-script player
             (set! (invincible? player) #t)
@@ -258,7 +282,7 @@
    ;; Absorb bullets of the same polarity.
    ((and (eq? hitbox graze-hitbox)
          (eq? bullet-polarity (polarity player)))
-    (increment-energy player)
+    (add-energy player 1)
     ;; From what I can tell by watching youtube replays at .25 speed,
     ;; each bullet absorbed is worth 100 points.
     (set! (score player) (+ (score player) 100))
@@ -270,13 +294,14 @@
     #t)
    (else #f)))
 
-(define (add-to-chain player polarity)
+(define-method (add-to-chain (player <player>) polarity)
   (let ((current-chain (cons polarity (chain-progress player))))
     (match current-chain
       ;; complete chain.
       ((or ('white 'white 'white)
            ('black 'black 'black))
        (let ((new-chain (+ (chain player) 1)))
+         (set! (max-chain player) (max (max-chain player) new-chain))
          (set! (chain player) new-chain)
          (set! (chain-progress player) '())
          (set! (score player)
-- 
cgit v1.2.3