diff options
| -rw-r--r-- | assets/images/background.xcf | bin | 8943 -> 6681 bytes | |||
| -rw-r--r-- | assets/images/clouds.png | bin | 42047 -> 608 bytes | |||
| -rw-r--r-- | assets/images/clouds.xcf | bin | 0 -> 1404 bytes | |||
| -rw-r--r-- | assets/images/enemies.png | bin | 0 -> 1649 bytes | |||
| -rw-r--r-- | assets/images/enemies.xcf | bin | 0 -> 6836 bytes | |||
| -rw-r--r-- | assets/images/enemy-bullets.png | bin | 0 -> 313 bytes | |||
| -rw-r--r-- | assets/images/enemy-bullets.xcf | bin | 0 -> 1050 bytes | |||
| -rw-r--r-- | assets/images/player-bullets.png | bin | 417 -> 620 bytes | |||
| -rw-r--r-- | assets/images/player-bullets.xcf | bin | 1415 -> 2645 bytes | |||
| -rw-r--r-- | guix.scm | 4 | ||||
| -rw-r--r-- | lisparuga.scm | 78 | ||||
| -rw-r--r-- | lisparuga/actor.scm | 35 | ||||
| -rw-r--r-- | lisparuga/bullets.scm | 60 | ||||
| -rw-r--r-- | lisparuga/enemy.scm | 75 | ||||
| -rw-r--r-- | lisparuga/game.scm | 96 | ||||
| -rw-r--r-- | lisparuga/kernel.scm | 6 | ||||
| -rw-r--r-- | lisparuga/node-2d.scm | 1 | ||||
| -rw-r--r-- | lisparuga/player.scm | 152 |
18 files changed, 427 insertions, 80 deletions
diff --git a/assets/images/background.xcf b/assets/images/background.xcf Binary files differindex 895d445..5ed24cf 100644 --- a/assets/images/background.xcf +++ b/assets/images/background.xcf diff --git a/assets/images/clouds.png b/assets/images/clouds.png Binary files differindex ef20e9c..c498ab3 100644 --- a/assets/images/clouds.png +++ b/assets/images/clouds.png diff --git a/assets/images/clouds.xcf b/assets/images/clouds.xcf Binary files differnew file mode 100644 index 0000000..141fc68 --- /dev/null +++ b/assets/images/clouds.xcf diff --git a/assets/images/enemies.png b/assets/images/enemies.png Binary files differnew file mode 100644 index 0000000..574e6af --- /dev/null +++ b/assets/images/enemies.png diff --git a/assets/images/enemies.xcf b/assets/images/enemies.xcf Binary files differnew file mode 100644 index 0000000..3cf608a --- /dev/null +++ b/assets/images/enemies.xcf diff --git a/assets/images/enemy-bullets.png b/assets/images/enemy-bullets.png Binary files differnew file mode 100644 index 0000000..ce7c73a --- /dev/null +++ b/assets/images/enemy-bullets.png diff --git a/assets/images/enemy-bullets.xcf b/assets/images/enemy-bullets.xcf Binary files differnew file mode 100644 index 0000000..5bd7ceb --- /dev/null +++ b/assets/images/enemy-bullets.xcf diff --git a/assets/images/player-bullets.png b/assets/images/player-bullets.png Binary files differindex 8a3a990..eb9c4cb 100644 --- a/assets/images/player-bullets.png +++ b/assets/images/player-bullets.png diff --git a/assets/images/player-bullets.xcf b/assets/images/player-bullets.xcf Binary files differindex 402a9bc..1977d7a 100644 --- a/assets/images/player-bullets.xcf +++ b/assets/images/player-bullets.xcf @@ -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))) |
