From 729f0b687b975e60f338831bcb0d59fad776f3e1 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Sun, 12 Apr 2020 09:03:41 -0400
Subject: Day 2 progress.

---
 assets/images/background.xcf     | Bin 8943 -> 6681 bytes
 assets/images/clouds.png         | Bin 42047 -> 608 bytes
 assets/images/clouds.xcf         | Bin 0 -> 1404 bytes
 assets/images/enemies.png        | Bin 0 -> 1649 bytes
 assets/images/enemies.xcf        | Bin 0 -> 6836 bytes
 assets/images/enemy-bullets.png  | Bin 0 -> 313 bytes
 assets/images/enemy-bullets.xcf  | Bin 0 -> 1050 bytes
 assets/images/player-bullets.png | Bin 417 -> 620 bytes
 assets/images/player-bullets.xcf | Bin 1415 -> 2645 bytes
 guix.scm                         |   4 +-
 lisparuga.scm                    |  78 +++++++++++++++-----
 lisparuga/actor.scm              |  35 ++++++---
 lisparuga/bullets.scm            |  60 ++++++++++------
 lisparuga/enemy.scm              |  75 ++++++++++++++++++-
 lisparuga/game.scm               |  96 +++++++++++++++++++++++--
 lisparuga/kernel.scm             |   6 +-
 lisparuga/node-2d.scm            |   1 +
 lisparuga/player.scm             | 152 ++++++++++++++++++++++++++++++++++-----
 18 files changed, 427 insertions(+), 80 deletions(-)
 create mode 100644 assets/images/clouds.xcf
 create mode 100644 assets/images/enemies.png
 create mode 100644 assets/images/enemies.xcf
 create mode 100644 assets/images/enemy-bullets.png
 create mode 100644 assets/images/enemy-bullets.xcf

diff --git a/assets/images/background.xcf b/assets/images/background.xcf
index 895d445..5ed24cf 100644
Binary files a/assets/images/background.xcf and b/assets/images/background.xcf differ
diff --git a/assets/images/clouds.png b/assets/images/clouds.png
index ef20e9c..c498ab3 100644
Binary files a/assets/images/clouds.png and b/assets/images/clouds.png differ
diff --git a/assets/images/clouds.xcf b/assets/images/clouds.xcf
new file mode 100644
index 0000000..141fc68
Binary files /dev/null and b/assets/images/clouds.xcf differ
diff --git a/assets/images/enemies.png b/assets/images/enemies.png
new file mode 100644
index 0000000..574e6af
Binary files /dev/null and b/assets/images/enemies.png differ
diff --git a/assets/images/enemies.xcf b/assets/images/enemies.xcf
new file mode 100644
index 0000000..3cf608a
Binary files /dev/null and b/assets/images/enemies.xcf differ
diff --git a/assets/images/enemy-bullets.png b/assets/images/enemy-bullets.png
new file mode 100644
index 0000000..ce7c73a
Binary files /dev/null and b/assets/images/enemy-bullets.png differ
diff --git a/assets/images/enemy-bullets.xcf b/assets/images/enemy-bullets.xcf
new file mode 100644
index 0000000..5bd7ceb
Binary files /dev/null and b/assets/images/enemy-bullets.xcf differ
diff --git a/assets/images/player-bullets.png b/assets/images/player-bullets.png
index 8a3a990..eb9c4cb 100644
Binary files a/assets/images/player-bullets.png and b/assets/images/player-bullets.png differ
diff --git a/assets/images/player-bullets.xcf b/assets/images/player-bullets.xcf
index 402a9bc..1977d7a 100644
Binary files a/assets/images/player-bullets.xcf and b/assets/images/player-bullets.xcf differ
diff --git a/guix.scm b/guix.scm
index 159842b..215e71e 100644
--- a/guix.scm
+++ b/guix.scm
@@ -125,7 +125,7 @@ SDL2 C shared library via the foreign function interface.")
      (license lgpl3+))))
 
 (define chickadee
-  (let ((commit "94823dc194ac805939f91a68ca01d9c778f56b2b"))
+  (let ((commit "f2721b20704a0e5a4960d490d0ba465feccdf192"))
     (package
      (name "chickadee")
      (version (string-append "0.5.0-1." (string-take commit 7)))
@@ -136,7 +136,7 @@ SDL2 C shared library via the foreign function interface.")
                     (commit commit)))
               (sha256
                (base32
-                "1qp1x5zmhg1z36hg7h3pkbv3rd2rz3kssgm2hr4cib2qh834vywz"))))
+                "0cs838mr7r92kyihvvya2nbywd0g6rfb7qgcxaqivyh3qyss4zi8"))))
      (build-system gnu-build-system)
      (arguments
       '(#:make-flags '("GUILE_AUTO_COMPILE=0")
diff --git a/lisparuga.scm b/lisparuga.scm
index 828ba58..b552a7a 100644
--- a/lisparuga.scm
+++ b/lisparuga.scm
@@ -33,6 +33,7 @@
   #:use-module (lisparuga kernel)
   #:use-module (lisparuga node)
   #:use-module (lisparuga node-2d)
+  #:use-module (lisparuga player)
   #:use-module (lisparuga scene)
   #:use-module (oop goops)
   #:export (launch-lisparuga))
@@ -42,7 +43,11 @@
 
 (define-asset background (load-image (scope-asset "images/background.png")))
 
-(define-class <lisparuga> (<scene-2d>))
+(define-class <lisparuga> (<scene-2d>)
+  (state #:accessor state #:init-value 'play))
+
+(define (game-over? lisparuga)
+  (zero? (lives (& lisparuga actor-canvas game player))))
 
 (define-method (on-boot (lisparuga <lisparuga>))
   ;; Scale a small framebuffer up to the window size.
@@ -57,38 +62,77 @@
   ;; rendered.
   (let ((actor-canvas (make <canvas>
                         #:name 'actor-canvas
+                        #:rank 1
                         #:views (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))))))
-    (attach-to actor-canvas (make <game> #:name 'game))
     (attach-to lisparuga
                (make <sprite>
                  #:name 'background
+                 #:rank 0
                  #:texture background)
-               actor-canvas)))
+               actor-canvas)
+    (new-game-transition lisparuga)))
+
+(define (new-game-transition lisparuga)
+  (set! (state lisparuga) 'play)
+  (let ((game-over (& lisparuga game-over)))
+    (and game-over (detach game-over)))
+  (let ((old-game (& lisparuga actor-canvas game)))
+    (and old-game (detach old-game)))
+  (attach-to (& lisparuga actor-canvas) (make <game> #:name 'game)))
+
+(define (game-over-transition lisparuga)
+  (set! (state lisparuga) 'game-over)
+  (let ((game-over (make <node-2d>
+                     #:name 'game-over
+                     #:rank 999)))
+    (attach-to game-over
+               (make <label>
+                 #:name 'game-over
+                 #:text "GAME OVER"
+                 #:position (vec2 (- 160.0 (/ (* 9.0 8.0) 2.0))
+                                  116.0)
+                 #:rank 999))
+    (attach-to lisparuga game-over)))
 
 (define-method (update (lisparuga <lisparuga>) dt)
-  (steer-player (& lisparuga actor-canvas game)
-                (key-pressed? 'up)
-                (key-pressed? 'down)
-                (key-pressed? 'left)
-                (key-pressed? 'right)))
+  (match (state lisparuga)
+    ('play
+     (if (game-over? lisparuga)
+         (game-over-transition lisparuga)
+         (steer-player (& lisparuga actor-canvas game)
+                       (key-pressed? 'up)
+                       (key-pressed? 'down)
+                       (key-pressed? 'left)
+                       (key-pressed? 'right))))
+    (_ #f)))
 
 (define-method (on-key-press (lisparuga <lisparuga>) key scancode modifiers repeat?)
-  (unless repeat?
-    (match key
-      ('z (start-player-shooting (& lisparuga actor-canvas game)))
-      ('x (toggle-player-polarity (& lisparuga actor-canvas game)))
-      ('c (fire-player-homing-missiles (& lisparuga actor-canvas game)))
-      (_ #t))))
+  (match (state lisparuga)
+    ('play
+     (unless repeat?
+       (match key
+         ('z (start-player-shooting (& lisparuga actor-canvas game)))
+         ('x (toggle-player-polarity (& lisparuga actor-canvas game)))
+         ('c (fire-player-homing-missiles (& lisparuga actor-canvas game)))
+         (_ #t))))
+    ('game-over
+     (match key
+       ('return (new-game-transition lisparuga))
+       (_ #f)))
+    (_ #f)))
 
 (define-method (on-key-release (lisparuga <lisparuga>) key scancode modifiers)
-  (match key
-    ('z (stop-player-shooting (& lisparuga actor-canvas game)))
-    (_ #t)))
+  (match (state lisparuga)
+    ('play
+     (match key
+       ('z (stop-player-shooting (& lisparuga actor-canvas game)))
+       (_ #t)))
+    (_ #f)))
 
 (define* (launch-lisparuga #:key (window-width 640) (window-height 480))
   (boot-kernel (make <kernel>
diff --git a/lisparuga/actor.scm b/lisparuga/actor.scm
index c7caab2..5439e6b 100644
--- a/lisparuga/actor.scm
+++ b/lisparuga/actor.scm
@@ -28,6 +28,7 @@
   #:use-module (lisparuga node)
   #:use-module (lisparuga node-2d)
   #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:export (make-hitbox
             hitbox?
@@ -43,6 +44,7 @@
             velocity
             hitboxes
             world-hitboxes
+            collide
             on-collision
             bullet-field))
 
@@ -69,7 +71,10 @@
                         (make-rect 0.0 0.0 (rect-width r) (rect-height r)))))
 
 (define (sync-world-hitbox world-hitbox position)
-  (rect-move-vec2! (world-hitbox-rect world-hitbox) position))
+  (let ((r (hitbox-rect (world-hitbox-parent world-hitbox)))
+        (wr (world-hitbox-rect world-hitbox)))
+    (set-rect-x! wr (+ (vec2-x position) (rect-x r)))
+    (set-rect-y! wr (+ (vec2-y position) (rect-y r)))))
 
 (define (world-hitbox-collision? a b)
   (if (world-hitbox? b)
@@ -88,10 +93,18 @@
   (world-hitboxes #:accessor world-hitboxes #:init-form '())
   (bullet-field #:accessor bullet-field #:init-keyword #:bullet-field))
 
+(define (sync-hitboxes actor)
+  ;; Sync hitboxes to world coordinates.
+  (let ((pos (position actor)))
+    (for-each (lambda (world-hitbox)
+                (sync-world-hitbox world-hitbox pos))
+              (world-hitboxes actor))))
+
 (define-method (initialize (actor <actor>) initargs)
   (next-method)
   (set! (world-hitboxes actor)
-    (map make-world-hitbox (hitboxes actor))))
+    (map make-world-hitbox (hitboxes actor)))
+  (sync-hitboxes actor))
 
 (define-method (update (actor <actor>) dt)
   (let ((v (velocity actor)))
@@ -99,15 +112,21 @@
                  (= (vec2-y v) 0.0))
       ;; Move by current velocity.
       (vec2-add! (position actor) v)
-      ;; Sync hitboxes to world coordinates.
-      (let ((pos (position actor)))
-        (for-each (lambda (world-hitbox)
-                    (sync-world-hitbox world-hitbox pos))
-                  (world-hitboxes actor)))
+      (sync-hitboxes actor)
       ;; Mark for matrix updates.
       (dirty! actor))))
 
+(define-method (collide (actor <actor>) (other-actor <actor>))
+  (any (lambda (wh)
+         (any (lambda (other-wh)
+                (and (world-hitbox-collision? wh other-wh)
+                     (on-collision actor other-actor
+                                   (world-hitbox-parent wh)
+                                   (world-hitbox-parent other-wh))))
+              (world-hitboxes other-actor)))
+       (world-hitboxes actor)))
+
 ;; Actor-actor collision event.
 (define-method (on-collision (actor <actor>) (other-actor <actor>)
                              hitbox other-hitbox)
-  #t)
+  #f)
diff --git a/lisparuga/bullets.scm b/lisparuga/bullets.scm
index e241694..6645f0d 100644
--- a/lisparuga/bullets.scm
+++ b/lisparuga/bullets.scm
@@ -39,7 +39,7 @@
             bullet-hitbox-rect
             bullet-tile
             ikaruga-bullet
-            ikaruga-missle
+            ikaruga-missile
             small-dot
             medium-dot
             large-dot
@@ -48,7 +48,6 @@
 
             <bullet-field>
             spawn-bullet
-            collision?
             size
             capacity
             texture-atlas))
@@ -68,11 +67,11 @@
   (tile-black bullet-tile-black))
 
 (define ikaruga-bullet
-  (make-bullet 'ikaruga (make-rect 0.0 0.0 0.0 0.0) 0 1))
+  (make-bullet 'ikaruga (make-rect -3.0 -1.0 6.0 10.0) 0 1))
 (define ikaruga-missile
-  (make-bullet 'ikaruga-missile (make-rect 0.0 0.0 0.0 0.0) 0 1))
+  (make-bullet 'ikaruga-missile (make-rect -3.0 -1.0 6.0 10.0) 4 5))
 (define small-dot
-  (make-bullet 'small-dot (make-rect 0.0 0.0 0.0 0.0) 0 1))
+  (make-bullet 'small-dot (make-rect -1.0 -1.0 2.0 2.0) 0 1))
 (define medium-dot
   (make-bullet 'medium-dot (make-rect 0.0 0.0 0.0 0.0) 0 1))
 (define large-dot
@@ -98,6 +97,7 @@
   (positions #:accessor positions)
   (velocities #:accessor velocities)
   (hitboxes #:accessor hitboxes)
+  (procs #:accessor procs)
   (texture-atlas #:accessor texture-atlas #:init-keyword #:texture-atlas)
   (scratch-rect #:getter scratch-rect #:init-form (make-rect 0.0 0.0 0.0 0.0)))
 
@@ -115,7 +115,8 @@
     (set! (polarities bullets) (make-vector capacity))
     (set! (positions bullets) (seed-vector (lambda () #v(0.0 0.0))))
     (set! (velocities bullets) (seed-vector (lambda () #v(0.0 0.0))))
-    (set! (hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))))
+    (set! (hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))
+    (set! (procs bullets) (make-vector capacity))))
 
 (define-method (spawn-bullet (bullets <bullet-field>) id polarity x y dx dy)
   (let* ((i (size bullets))
@@ -128,22 +129,29 @@
     (vector-set! (polarities bullets) i polarity)
     (set-vec2! p x y)
     (set-vec2! v dx dy)
-    (set-rect-x! h (rect-x r))
-    (set-rect-y! h (rect-y r))
+    (set-rect-x! h (+ x (rect-x r)))
+    (set-rect-y! h (+ y (rect-y r)))
     (set-rect-width! h (rect-width r))
-    (set-rect-height! h (rect-height r))))
+    (set-rect-height! h (rect-height r))
+    (vector-set! (procs bullets) i #f)))
+
+(define-method (spawn-bullet (bullets <bullet-field>) id polarity x y dx dy proc)
+  (spawn-bullet bullets id polarity x y dx dy)
+  (vector-set! (procs bullets) (- (size bullets) 1) proc))
 
 (define-method (move-bullet (bullets <bullet-field>) from to)
   (let ((ids (ids bullets))
         (polarities (polarities bullets))
         (positions (positions bullets))
         (velocities (velocities bullets))
-        (hitboxes (hitboxes bullets)))
+        (hitboxes (hitboxes bullets))
+        (procs (procs bullets)))
     (vector-set! ids to (vector-ref ids from))
     (vector-set! polarities to (vector-ref polarities from))
     (vec2-copy! (vector-ref positions from) (vector-ref positions to))
     (vec2-copy! (vector-ref velocities from) (vector-ref velocities to))
-    (rect-copy! (vector-ref hitboxes from) (vector-ref hitboxes to))))
+    (rect-copy! (vector-ref hitboxes from) (vector-ref hitboxes to))
+    (vector-set! procs to (vector-ref procs from))))
 
 (define-method (kill-bullet (bullets <bullet-field>) i)
   (let ((new-size (- (size bullets) 1)))
@@ -158,6 +166,7 @@
         (positions (positions bullets))
         (velocities (velocities bullets))
         (hitboxes (hitboxes bullets))
+        (procs (procs bullets))
         ;; Delete bullets that go too far off the screen.
         (min-x -32.0)
         (min-y -32.0)
@@ -171,7 +180,9 @@
       (when (< i l)
         (let ((p (vector-ref positions i))
               (v (vector-ref velocities i))
-              (h (vector-ref hitboxes i)))
+              (h (vector-ref hitboxes i))
+              (proc (vector-ref procs i)))
+          (and (procedure? proc) (proc p v))
           (vec2-add! p v)
           ;; Remove bullets that go out of bounds of the play area.
           (if (or (< (vec2-x p) min-x)
@@ -198,17 +209,20 @@
         (polarities (polarities bullets))
         (hitboxes (hitboxes bullets)))
     (let loop ((i 0))
-      (when (< i l)
-        (let* ((id (vector-ref ids i))
-               (h (vector-ref hitboxes i))
-               (wh (find (lambda (wh)
-                           (world-hitbox-collision? wh h))
-                         (world-hitboxes actor))))
-          (if (and wh
-                   (on-collision actor id (vector-ref polarities i)
-                                 (world-hitbox-parent wh)))
-              (kill-bullet bullets i)
-              (loop (+ i 1))))))))
+      (if (< i l)
+          (let* ((id (vector-ref ids i))
+                 (h (vector-ref hitboxes i))
+                 (collided? (find (lambda (wh)
+                                    (and (world-hitbox-collision? wh h)
+                                         (on-collision actor id (vector-ref polarities i)
+                                                       (world-hitbox-parent wh))))
+                                  (world-hitboxes actor))))
+            (if collided?
+                (begin
+                  (kill-bullet bullets i)
+                  #t)
+                (loop (+ i 1))))
+          #f))))
 
 (define %identity-matrix (make-identity-matrix4))
 
diff --git a/lisparuga/enemy.scm b/lisparuga/enemy.scm
index 5ecba62..0589d16 100644
--- a/lisparuga/enemy.scm
+++ b/lisparuga/enemy.scm
@@ -21,6 +21,7 @@
 ;;; Code:
 
 (define-module (lisparuga enemy)
+  #:use-module (chickadee math)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
   #:use-module (chickadee scripting)
@@ -36,6 +37,8 @@
             health
             points
             parting-shots
+            dead?
+            fire-parting-shots-maybe
 
             make-utatsugumi))
 
@@ -46,7 +49,68 @@
 (define-class <enemy> (<actor>)
   (health #:accessor health #:init-keyword #:health)
   (points #:getter points #:init-keyword #:points)
-  (parting-shots #:getter parting-shots #:init-keyword #:parting-shots))
+  (parting-shots #:getter parting-shots #:init-keyword #:parting-shots)
+  (fire-parting-shots? #:accessor fire-parting-shots? #:init-form #f))
+
+(define-method (on-kill (enemy <enemy>))
+  #t)
+
+(define-method (damage (enemy <enemy>) x)
+  (set! (health enemy) (max (- (health enemy) x) 0)))
+
+(define-method (dead? (enemy <enemy>))
+  (zero? (health enemy)))
+
+(define (fire-parting-shots-maybe enemy player)
+  (when (fire-parting-shots? enemy)
+    (let* ((n (parting-shots enemy))
+           (ep (position enemy))
+           (pp (position player))
+           (angle-to-player
+            (atan (- (vec2-y pp) (vec2-y ep))
+                  (- (vec2-x pp) (vec2-x ep)))))
+      (let loop ((i 0))
+        (when (< i n)
+          (let ((theta (+ angle-to-player
+                          (- (* (random:uniform) (/ pi 4.0))
+                             (/ pi 8.0)))))
+            (spawn-bullet (bullet-field enemy)
+                          small-dot
+                          (polarity enemy)
+                          (+ (vec2-x ep)
+                             (- (* (random:uniform) 16.0)
+                                8.0))
+                          (+ (vec2-y ep)
+                             (- (* (random:uniform) 16.0)
+                                8.0))
+                          (* (cos theta) 4.0)
+                          (* (sin theta) 4.0)))
+          (loop (+ i 1)))))))
+
+(define-method (on-collision (enemy <enemy>) bullet bullet-polarity hitbox)
+  ;; TODO: Distinguish between normal play bullets and homing shots
+  ;; that do more damage.
+  ;;
+  ;; Same polarity = 1 point of damage
+  ;; Opposite polarity = 2 points of damage
+  (let ((same-polarity? (eq? bullet-polarity (polarity enemy))))
+    (damage enemy (if same-polarity? 1 2))
+    (when (and same-polarity? (dead? enemy))
+      (set! (fire-parting-shots? enemy) #t)))
+  #t)
+
+(define %enemy-tiles
+  ;; 0: Utatsugumi - white
+  `((0.0 0.0 24.0 24.0)
+    ;; 1: Utatsugumi - black
+    (24.0 0.0 24.0 24.0)))
+
+(define (load-enemy-atlas file-name)
+  (let ((texture (load-image file-name)))
+    (list->texture-atlas texture %enemy-tiles)))
+
+(define-asset enemy-atlas
+  (load-enemy-atlas (scope-asset "images/enemies.png")))
 
 
 ;;;
@@ -55,6 +119,13 @@
 
 (define-class <utatsugumi> (<enemy>))
 
+(define-method (on-boot (utatsugumi <utatsugumi>))
+  (attach-to utatsugumi
+             (make <atlas-sprite>
+               #:atlas enemy-atlas
+               #:index (if (eq? 'white (polarity utatsugumi)) 0 1)
+               #:origin (vec2 12.0 12.0))))
+
 (define (make-utatsugumi polarity x y)
   (make <utatsugumi>
     #:name (gensym "utatsugumi-")
@@ -62,4 +133,6 @@
     #:points 20
     #:parting-shots 5
     #:polarity polarity
+    #:hitboxes
+    (list (make-hitbox 'utatsugumi (make-rect -10.0 -10.0 20.0 20.0)))
     #:position (vec2 x y)))
diff --git a/lisparuga/game.scm b/lisparuga/game.scm
index edd97fc..5b14edd 100644
--- a/lisparuga/game.scm
+++ b/lisparuga/game.scm
@@ -26,9 +26,13 @@
   #:use-module (chickadee math vector)
   #:use-module (chickadee render color)
   #:use-module (chickadee render texture)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 format)
+  #:use-module (lisparuga actor)
   #:use-module (lisparuga asset)
   #:use-module (lisparuga bullets)
   #:use-module (lisparuga config)
+  #:use-module (lisparuga enemy)
   #:use-module (lisparuga node)
   #:use-module (lisparuga node-2d)
   #:use-module (lisparuga player)
@@ -43,28 +47,109 @@
 (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))
 
 ;; nodes needed:
-;; enemies
-;; enemy bullets
 ;; scrolling background
 (define-class <game> (<node-2d>))
 
 (define-method (on-boot (game <game>))
   (let* ((player-bullets (make <bullet-field>
+                           #:name 'player-bullets
+                           #:rank 2
                            #:capacity 500
                            #:texture-atlas player-bullet-atlas))
          (player (make-player player-bullets))
          (enemy-bullets (make <bullet-field>
+                          #:name 'enemy-bullets
+                          #:rank 4
                           #:capacity 1000
-                          #:texture-atlas player-bullet-atlas)))
+                          #:texture-atlas enemy-bullet-atlas))
+         (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
-               enemy-bullets)))
+               (make <node-2d>
+                 #:name 'enemies
+                 #:rank 3)
+               enemy-bullets
+               ui)
+    ;; Setup UI elements
+    (attach-to ui
+               (make <label>
+                 #:name 'score
+                 #:position (vec2 2.0 226.0))
+               (make <label>
+                 #:name 'chain
+                 #:position (vec2 2.0 210.0))
+               (make <label>
+                 #:name 'energy
+                 #:position (vec2 2.0 18.0))
+               (make <label>
+                 #:name 'lives
+                 #:position (vec2 2.0 2.0)))
+    (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)
+  (set! (text (& game ui score))
+    (format #f "~9,'0d" (score (& game player))))
+  (set! (text (& game ui chain))
+    (format #f "CHAIN ~a: ~a"
+            (let ((n (chain (& game player))))
+              (if (< n 9) (number->string n) "MAX"))
+            (list->string
+             (map (lambda (polarity)
+                    (if (eq? polarity 'white)
+                        #\W
+                        #\B))
+                  (chain-progress (& game player))))))
+  (set! (text (& game ui energy))
+    (format #f "E~d" (quotient (energy (& game player)) 10)))
+  (set! (text (& game ui lives))
+    (format #f "x~d" (max (- (lives (& game player)) 1) 0))))
+
+(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))))
+
+(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?))
@@ -79,4 +164,5 @@
   (toggle-polarity (& game player)))
 
 (define-method (fire-player-homing-missiles (game <game>))
-  (fire-homing-missiles (& game player)))
+  (fire-homing-missiles (& game player) (children (& game enemies)))
+  (update-ui game))
diff --git a/lisparuga/kernel.scm b/lisparuga/kernel.scm
index 36dea70..e8359d4 100644
--- a/lisparuga/kernel.scm
+++ b/lisparuga/kernel.scm
@@ -228,12 +228,8 @@
 
 (define-method (render-tree (kernel <kernel>) alpha)
   (let ((start-time (elapsed-time)))
-    ;; Switch to the null viewport to ensure that
-    ;; the default viewport will be re-applied and
-    ;; clear the screen.
-    (set-gpu-viewport! (current-gpu) null-viewport)
     (with-viewport (default-viewport kernel)
-      (gl-clear %clear-mask)
+      (clear-screen)
       (next-method))
     (sdl2:swap-gl-window (window kernel))
     ;; Compute FPS.
diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm
index 8dca8e1..0baef54 100644
--- a/lisparuga/node-2d.scm
+++ b/lisparuga/node-2d.scm
@@ -174,6 +174,7 @@
 
 (define-syntax-rule (with-camera camera body ...)
   (with-framebuffer (framebuffer camera)
+    (clear-screen)
     (with-projection (if (target camera)
                          (view-matrix camera)
                          (projection-matrix camera))
diff --git a/lisparuga/player.scm b/lisparuga/player.scm
index a810e48..ca57891 100644
--- a/lisparuga/player.scm
+++ b/lisparuga/player.scm
@@ -21,14 +21,17 @@
 ;;; Code:
 
 (define-module (lisparuga player)
+  #:use-module (chickadee math)
   #:use-module (chickadee math rect)
   #:use-module (chickadee math vector)
   #:use-module (chickadee scripting)
   #:use-module (chickadee render texture)
+  #:use-module (ice-9 match)
   #:use-module (lisparuga actor)
   #:use-module (lisparuga asset)
   #:use-module (lisparuga bullets)
   #:use-module (lisparuga config)
+  #:use-module (lisparuga enemy)
   #:use-module (lisparuga node)
   #:use-module (lisparuga node-2d)
   #:use-module (oop goops)
@@ -44,21 +47,23 @@
             start-shooting
             stop-shooting
             toggle-polarity
-            fire-homing-missiles))
+            fire-homing-missiles
+            kill-maybe
+            on-kill))
 
 (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 kill-hitbox (make-hitbox 'kill (make-rect 0.0 0.0 0.0 0.0)))
-(define graze-hitbox (make-hitbox 'graze (make-rect 0.0 0.0 0.0 0.0)))
+(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)))
 
 (define-class <player> (<actor>)
   (score #:accessor score #:init-value 0)
-  (lives #:accessor lives #:init-value 2)
+  (lives #:accessor lives #:init-value 3)
   (energy #:accessor energy #:init-value 0)
   (chain #:accessor chain #:init-value 0)
   (chain-progress #:accessor chain-progress #:init-form '())
-  (speed #:accessor speed #:init-value 1.75)
+  (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))
@@ -153,11 +158,75 @@
         ;; Change sprite
         (set! (index (& player ship)) (if (eq? old 'white) 4 0))))))
 
-(define-method (fire-homing-missiles (player <player>))
+(define-method (fire-homing-missiles (player <player>) enemies)
   (let* ((e (energy player))
-         (n (quotient e 10)))
-    (set! (energy player) (- e (* n 10)))
-    ;; TODO: search for nearest enemy and fire missiles
+         (n (quotient e 10))
+         (p (position player))
+         (bullets (bullet-field player)))
+    (define (distance-to-player enemy)
+      ;; We don't need the true distance here so no need to use an
+      ;; expensive sqrt call.
+      (let ((ep (position enemy)))
+        (+ (expt (- (vec2-x ep) (vec2-x p)) 2)
+           (expt (- (vec2-y ep) (vec2-y p)) 2))))
+    (define (find-closest-enemy enemies)
+      (let loop ((enemies enemies)
+                 (closest-enemy #f)
+                 (distance 999999999.0))
+        (match enemies
+          ((enemy . rest)
+           (if (dead? enemy)
+               (loop rest closest-enemy distance)
+               (let ((d (distance-to-player enemy)))
+                 (if (< d distance)
+                     (loop rest enemy d)
+                     (loop rest closest-enemy distance)))))
+          (()
+           closest-enemy))))
+    (define (fire-missiles n enemy)
+      (let ((speed 10.0))
+        (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))))
+              (run-script player
+                (let loop ((i 0))
+                  (when (< i n)
+                    (spawn-bullet bullets ikaruga-missile (polarity player)
+                                  (vec2-x p) (vec2-y p) 0.0 0.0 aim-at-enemy)
+                    (sleep 3)
+                    (loop (+ i 1))))))
+            (let loop ((i 0))
+              (when (< i n)
+                (let ((theta (+ (* (random:uniform) .5 pi)
+                                (* .25 pi))))
+                  (spawn-bullet bullets ikaruga-missile (polarity player)
+                                (vec2-x p) (vec2-y p)
+                                (* (cos theta) speed) (* (sin theta) speed))
+                  (loop (+ i 1))))))))
+    ;; Distribute missiles amongst closest enemies
+    (let loop ((enemies enemies)
+               (missiles-remaining (quotient e 10))
+               (missiles-used 0))
+      (if (zero? missiles-remaining)
+          (set! (energy player) (- e (* missiles-used 10)))
+          (let ((closest-enemy (find-closest-enemy enemies)))
+            (if closest-enemy
+                ;; Either kill the enemy or use all missiles.
+                (let ((missiles-to-fire (min (inexact->exact
+                                              (ceiling
+                                               (/ (health closest-enemy) 10.0)))
+                                             missiles-remaining)))
+                  (fire-missiles missiles-to-fire closest-enemy)
+                  (loop (delq closest-enemy enemies)
+                        (- missiles-remaining missiles-to-fire)
+                        (+ missiles-used missiles-to-fire)))
+                ;; No enemy available, fire missiles into the void
+                (begin
+                  (fire-missiles missiles-remaining #f)
+                  (loop enemies 0 (+ missiles-used missiles-remaining)))))))
     #t))
 
 (define-method (increment-energy (player <player>))
@@ -165,18 +234,24 @@
 
 (define-method (kill-maybe (player <player>))
   (unless (invincible? player)
-    (set! (lives player) (- (lives player) 1))
-    ;; Give player invincibility for a bit while they recover.
-    (run-script player
-      (set! (invincible? player) #t)
-      ;; 3 seconds of blinking
-      (blink 18 5)
-      (set! (invincible? player) #f))))
+    (let ((new-lives (- (lives player) 1)))
+      (set! (lives player) new-lives)
+      (if (zero? new-lives)
+          (hide player)
+          ;; Give player invincibility for a bit while they recover.
+          (run-script player
+            (set! (invincible? player) #t)
+            ;; 3 seconds of blinking
+            (blink player 18 5)
+            (set! (invincible? player) #f))))))
 
 (define-method (on-collision (player <player>) (other <actor>)
                              hitbox other-hitbox)
-  (when (eq? hitbox kill-hitbox)
-    (kill-maybe player)))
+  (if (eq? hitbox kill-hitbox)
+      (begin
+        (kill-maybe player)
+        #t)
+      #f))
 
 (define-method (on-collision (player <player>) bullet bullet-polarity hitbox)
   (cond
@@ -184,9 +259,48 @@
    ((and (eq? hitbox graze-hitbox)
          (eq? bullet-polarity (polarity player)))
     (increment-energy player)
+    ;; 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))
     #t)
    ;; If a bullet makes it to the kill hitbox, lose a life.
-   ((eq? hitbox kill-hitbox)
+   ((and (eq? hitbox kill-hitbox)
+         (not (invincible? player)))
     (kill-maybe player)
     #t)
    (else #f)))
+
+(define (add-to-chain 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! (chain player) new-chain)
+         (set! (chain-progress player) '())
+         (set! (score player)
+           (+ (score player)
+              ;; Chain formula yields these results:
+              ;;
+              ;; - 1 Chain --- 100 points
+              ;; - 2 Chain --- 200 points
+              ;; - 3 Chain --- 400 points
+              ;; - 4 Chain --- 800 points
+              ;; - 5 Chain --- 1,600 points
+              ;; - 6 Chain --- 3,200 points
+              ;; - 7 Chain --- 6,400 points
+              ;; - 8 Chain --- 12,800 points
+              ;; - 9+ Chain -- 25,600 points
+              (* (expt 2 (- (min new-chain 9) 1)) 100)))))
+      ;; 1st or 2nd kill of the chain.
+      ((or ('white) ('black) ('white 'white) ('black 'black))
+       (set! (chain-progress player) current-chain))
+      ;; failed chain, start over.
+      (_
+       (set! (chain-progress player) '())
+       (set! (chain player) 0)))))
+
+(define-method (on-kill (player <player>) (enemy <enemy>))
+  (set! (score player) (+ (score player) (points enemy)))
+  (add-to-chain player (polarity enemy)))
-- 
cgit v1.2.3