summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--assets/images/background.xcfbin8943 -> 6681 bytes
-rw-r--r--assets/images/clouds.pngbin42047 -> 608 bytes
-rw-r--r--assets/images/clouds.xcfbin0 -> 1404 bytes
-rw-r--r--assets/images/enemies.pngbin0 -> 1649 bytes
-rw-r--r--assets/images/enemies.xcfbin0 -> 6836 bytes
-rw-r--r--assets/images/enemy-bullets.pngbin0 -> 313 bytes
-rw-r--r--assets/images/enemy-bullets.xcfbin0 -> 1050 bytes
-rw-r--r--assets/images/player-bullets.pngbin417 -> 620 bytes
-rw-r--r--assets/images/player-bullets.xcfbin1415 -> 2645 bytes
-rw-r--r--guix.scm4
-rw-r--r--lisparuga.scm78
-rw-r--r--lisparuga/actor.scm35
-rw-r--r--lisparuga/bullets.scm60
-rw-r--r--lisparuga/enemy.scm75
-rw-r--r--lisparuga/game.scm96
-rw-r--r--lisparuga/kernel.scm6
-rw-r--r--lisparuga/node-2d.scm1
-rw-r--r--lisparuga/player.scm152
18 files changed, 427 insertions, 80 deletions
diff --git a/assets/images/background.xcf b/assets/images/background.xcf
index 895d445..5ed24cf 100644
--- a/assets/images/background.xcf
+++ b/assets/images/background.xcf
Binary files differ
diff --git a/assets/images/clouds.png b/assets/images/clouds.png
index ef20e9c..c498ab3 100644
--- a/assets/images/clouds.png
+++ b/assets/images/clouds.png
Binary files differ
diff --git a/assets/images/clouds.xcf b/assets/images/clouds.xcf
new file mode 100644
index 0000000..141fc68
--- /dev/null
+++ b/assets/images/clouds.xcf
Binary files differ
diff --git a/assets/images/enemies.png b/assets/images/enemies.png
new file mode 100644
index 0000000..574e6af
--- /dev/null
+++ b/assets/images/enemies.png
Binary files differ
diff --git a/assets/images/enemies.xcf b/assets/images/enemies.xcf
new file mode 100644
index 0000000..3cf608a
--- /dev/null
+++ b/assets/images/enemies.xcf
Binary files differ
diff --git a/assets/images/enemy-bullets.png b/assets/images/enemy-bullets.png
new file mode 100644
index 0000000..ce7c73a
--- /dev/null
+++ b/assets/images/enemy-bullets.png
Binary files differ
diff --git a/assets/images/enemy-bullets.xcf b/assets/images/enemy-bullets.xcf
new file mode 100644
index 0000000..5bd7ceb
--- /dev/null
+++ b/assets/images/enemy-bullets.xcf
Binary files differ
diff --git a/assets/images/player-bullets.png b/assets/images/player-bullets.png
index 8a3a990..eb9c4cb 100644
--- a/assets/images/player-bullets.png
+++ b/assets/images/player-bullets.png
Binary files differ
diff --git a/assets/images/player-bullets.xcf b/assets/images/player-bullets.xcf
index 402a9bc..1977d7a 100644
--- a/assets/images/player-bullets.xcf
+++ b/assets/images/player-bullets.xcf
Binary files 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)))