From 6696a0b5fcb1b17895285d80d9636defb2df3f9d Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 10 Apr 2024 14:49:03 -0400 Subject: Sloppily refactor into modules. --- game.scm | 3243 +++++++++++++++++++++++--------------------------------------- 1 file changed, 1203 insertions(+), 2040 deletions(-) (limited to 'game.scm') diff --git a/game.scm b/game.scm index 9dd788b..a2d24a3 100644 --- a/game.scm +++ b/game.scm @@ -1,2052 +1,1215 @@ -(use-modules (hoot compile) - (ice-9 binary-ports) - (wasm assemble)) - -(define src - `(let () - ;; Host imports - (define-foreign current-window - "window" "get" - -> (ref null extern)) - (define-foreign window-inner-width - "window" "innerWidth" - (ref null extern) -> i32) - (define-foreign window-inner-height - "window" "innerHeight" - (ref null extern) -> i32) - (define-foreign request-animation-frame - "window" "requestAnimationFrame" - (ref null extern) -> none) - (define-foreign timeout - "window" "setTimeout" - (ref null extern) f64 -> i32) - - (define-foreign current-document - "document" "get" - -> (ref null extern)) - (define-foreign document-body - "document" "body" - -> (ref null extern)) - (define-foreign get-element-by-id - "document" "getElementById" - (ref string) -> (ref null extern)) - (define-foreign make-text-node - "document" "createTextNode" - (ref string) -> (ref null extern)) - (define-foreign make-element - "document" "createElement" - (ref string) -> (ref null extern)) - - (define-foreign element-value - "element" "value" - (ref null extern) -> (ref string)) - (define-foreign set-element-value! - "element" "setValue" - (ref null extern) (ref string) -> none) - (define-foreign set-element-width! - "element" "setWidth" - (ref null extern) i32 -> none) - (define-foreign set-element-height! - "element" "setHeight" - (ref null extern) i32 -> none) - (define-foreign append-child! - "element" "appendChild" - (ref null extern) (ref null extern) -> (ref null extern)) - (define-foreign remove! - "element" "remove" - (ref null extern) -> none) - (define-foreign replace-with! - "element" "replaceWith" - (ref null extern) (ref null extern) -> none) - (define-foreign set-attribute! - "element" "setAttribute" - (ref null extern) (ref string) (ref string) -> none) - (define-foreign remove-attribute! - "element" "removeAttribute" - (ref null extern) (ref string) -> none) - (define-foreign add-event-listener! - "element" "addEventListener" - (ref null extern) (ref string) (ref null extern) -> none) - (define-foreign remove-event-listener! - "element" "removeEventListener" - (ref null extern) (ref string) (ref null extern) -> none) - (define-foreign clone-element - "element" "clone" - (ref null extern) -> (ref null extern)) - - (define-foreign prevent-default! - "event" "preventDefault" - (ref null extern) -> none) - (define-foreign keyboard-event-code - "event" "keyboardCode" - (ref null extern) -> (ref string)) - - (define-foreign get-context - "canvas" "getContext" - (ref null extern) (ref string) -> (ref null extern)) - (define-foreign set-fill-color! - "canvas" "setFillColor" - (ref null extern) (ref string) -> none) - (define-foreign set-font! - "canvas" "setFont" - (ref null extern) (ref string) -> none) - (define-foreign set-text-align! - "canvas" "setTextAlign" - (ref null extern) (ref string) -> none) - (define-foreign clear-rect - "canvas" "clearRect" - (ref null extern) f64 f64 f64 f64 -> none) - (define-foreign fill-rect - "canvas" "fillRect" - (ref null extern) f64 f64 f64 f64 -> none) - (define-foreign fill-text - "canvas" "fillText" - (ref null extern) (ref string) f64 f64 -> none) - (define-foreign draw-image - "canvas" "drawImage" - (ref null extern) (ref null extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) - (define-foreign set-scale! - "canvas" "setScale" - (ref null extern) f64 f64 -> none) - (define-foreign set-transform! - "canvas" "setTransform" - (ref null extern) f64 f64 f64 f64 f64 f64 -> none) - (define-foreign set-image-smoothing-enabled! - "canvas" "setImageSmoothingEnabled" - (ref null extern) i32 -> none) - - (define-foreign load-audio - "audio" "new" - (ref string) -> (ref null extern)) - (define-foreign audio-play - "audio" "play" - (ref null extern) -> none) - (define-foreign audio-pause - "audio" "pause" - (ref null extern) -> none) - (define-foreign audio-volume - "audio" "volume" - (ref null extern) -> f64) - (define-foreign set-audio-volume! - "audio" "setVolume" - (ref null extern) f64 -> none) - (define-foreign set-audio-loop! - "audio" "setLoop" - (ref null extern) i32 -> none) - (define-foreign audio-seek - "audio" "seek" - (ref null extern) f64 -> none) - - (define-foreign load-image - "image" "new" - (ref string) -> (ref null extern)) - - ;; Record types are only just beginning to be added to Hoot and - ;; there isn't support for mutable structs, yet. So, tagged - ;; vectors will have to do. - (define-syntax-rule (define-type name - constructor - predicate - (field getter setter) ...) - (begin - (define (constructor field ...) - (vector 'name field ...)) - (define (predicate obj) - (match obj - (#('name field ...) #t) - (_ #f))) - (define (getter obj) - (match obj - (#('name field ...) - field))) - ... - (define setter - (let ((i (+ (- (length '(field ...)) - (length (memq 'field '(field ...)))) - 1))) - (lambda (obj val) - (match obj - (#('name field ...) - (vector-set! obj i val)))))) - ...)) - - (define (assert-float x) - (unless (and (number? x) (inexact? x) (rational? x)) - (error "expected inexact rational" x))) - (define (fmod x y) - (assert-float x) - (assert-float y) - (- x (* (truncate (/ x y)) y))) - - (define s32-ref bytevector-s32-native-ref) - (define s32-set! bytevector-s32-native-set!) - (define f64-ref bytevector-ieee-double-native-ref) - (define f64-set! bytevector-ieee-double-native-set!) - - (define pi (* 4.0 (atan 1.0))) - (define pi/2 (/ pi 2.0)) - (define tau (* pi 2.0)) - - (define (do-circle proc k) - (do ((i 0 (+ i 1))) - ((= i k)) - (proc (* tau (inexact (/ i k)))))) - - (define (clamp x min max) - (cond ((< x min) min) - ((> x max) max) - (else x))) - - (define (smoothstep t) - (* t t (- 3.0 (* 2.0 t)))) - - (define (lerp start end alpha) - (+ (* start (- 1.0 alpha)) - (* end alpha))) - - (define (assq-ref lst key) - (match (assq key lst) - (#f #f) - ((_ . val) val))) - - (define %jps (inexact (jiffies-per-second))) - (define (current-time) - (/ (inexact (current-jiffy)) %jps)) - - (define-type vec2 - make-vec2 - vec2? - (bv vec2-bv set-vec2-bv!)) - (define (vec2 x y) - (let ((v (make-vec2 (make-bytevector 16)))) - (set-vec2-x! v x) - (set-vec2-y! v y) - v)) - (define (vec2-x v) - (f64-ref (vec2-bv v) 0)) - (define (vec2-y v) - (f64-ref (vec2-bv v) 8)) - (define (set-vec2-x! v x) - (f64-set! (vec2-bv v) 0 x)) - (define (set-vec2-y! v y) - (f64-set! (vec2-bv v) 8 y)) - (define (vec2-add! v w) - (set-vec2-x! v (+ (vec2-x v) (vec2-x w))) - (set-vec2-y! v (+ (vec2-y v) (vec2-y w)))) - (define (vec2-sub! v w) - (set-vec2-x! v (- (vec2-x v) (vec2-x w))) - (set-vec2-y! v (- (vec2-y v) (vec2-y w)))) - (define (vec2-mul-scalar! v x) - (set-vec2-x! v (* (vec2-x v) x)) - (set-vec2-y! v (* (vec2-y v) x))) - (define (vec2-magnitude v) - (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v))))) - (define (vec2-normalize! v) - (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0)) - (let ((m (vec2-magnitude v))) - (set-vec2-x! v (/ (vec2-x v) m)) - (set-vec2-y! v (/ (vec2-y v) m))))) - (define (vec2-clamp! v xmin ymin xmax ymax) - (set-vec2-x! v (clamp (vec2-x v) xmin xmax)) - (set-vec2-y! v (clamp (vec2-y v) ymin ymax))) - - (define (make-rect x y w h) - (let ((r (make-bytevector (* 8 4)))) - (f64-set! r 0 x) - (f64-set! r 8 y) - (f64-set! r 16 w) - (f64-set! r 24 h) - r)) - (define (rect-x r) - (f64-ref r 0)) - (define (rect-y r) - (f64-ref r 8)) - (define (rect-w r) - (f64-ref r 16)) - (define (rect-h r) - (f64-ref r 24)) - - (define (within? x y rx ry rw rh) - (and (>= x rx) - (>= y ry) - (< x (+ rx rw)) - (< y (+ ry rh)))) - (define (rect-within? ax ay aw ah bx by bw bh) - (let ((ax* (+ ax aw)) - (ay* (+ ay ah))) - (or (within? ax ay bx by bw bh) - (within? ax* ay bx by bw bh) - (within? ax* ay* bx by bw bh) - (within? ax ay* bx by bw bh)))) - - ;; So we can play many overlapping audio samples at once. - (define (load-sound-effect src) - (let* ((k 32) - (audio (load-audio src)) - (vec (make-vector k))) - (do ((i 0 (+ i 1))) - ((= i k)) - (vector-set! vec i (clone-element audio))) - (vector 0 vec))) - (define* (sound-effect-play sound #:optional (volume 1.0)) - (match sound - (#(i vec) - (let ((audio (vector-ref vec i))) - (set-audio-volume! audio volume) - (audio-play audio) - (vector-set! sound 0 (modulo (+ i 1) (vector-length vec))))))) - - ;; splash, play, pause, game-over, game-clear - (define *game-state* 'splash) - - ;; Screen size stuff - (define game-width 240.0) - (define game-height 320.0) - - ;; Elements - (define canvas (get-element-by-id "canvas")) - (define context (get-context canvas "2d")) - (define image:cover (load-image "images/cover.png")) - (define image:starfield-bg (load-image "images/starfield-bg.png")) - (define image:starfield-fg (load-image "images/starfield-fg.png")) - (define image:player (load-image "images/player.png")) - (define image:player-bullets (load-image "images/player-bullets.png")) - (define image:enemy-bullets (load-image "images/enemy-bullets.png")) - (define image:map (load-image "images/map.png")) - (define image:turret (load-image "images/turret.png")) - (define image:popcorn (load-image "images/popcorn.png")) - (define image:flyer0 (load-image "images/flyer0.png")) - (define image:flyer1 (load-image "images/flyer1.png")) - (define image:boss (load-image "images/boss.png")) - (define image:particles (load-image "images/particles.png")) - (define sound:explosion (load-sound-effect "audio/explosion.wav")) - (define sound:player-shoot (load-sound-effect "audio/player-shoot.wav")) - (define sound:player-death (load-sound-effect "audio/player-death.wav")) - (define sound:enemy-shoot (load-sound-effect "audio/enemy-shoot.wav")) - (define sound:bullet-hit (load-sound-effect "audio/bullet-hit.wav")) - (define music (load-audio "audio/music.ogg")) - (set-audio-loop! music 1) - (set-audio-volume! music 0.5) - (define (music-play) - (audio-play music)) - (define (music-pause) - (audio-pause music)) - (define (music-stop) - (audio-pause music) - (audio-seek music 0.0)) - - (define *debug?* #f) - - ;; Scripting - (define (make-scheduler max-tasks) - (vector 0 0 max-tasks (make-vector max-tasks))) - (define (scheduler-add! scheduler thunk delay) - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (unless (= num-tasks max-tasks) - (vector-set! tasks num-tasks (cons (+ ticks delay) thunk)) - (vector-set! scheduler 1 (+ num-tasks 1)))))) - (define (scheduler-tick! scheduler) - (define (run-thunks thunks) - (for-each (lambda (thunk) (thunk)) thunks)) - (run-thunks - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (let ((t (+ ticks 1))) - (let loop ((i 0) (k num-tasks) (to-run '())) - (if (< i k) - (match (vector-ref tasks i) - ((t* . thunk) - (if (<= t* t) - (let ((k* (- k 1))) - (vector-set! tasks i (vector-ref tasks k*)) - (vector-set! tasks k* #f) - (loop i k* (cons thunk to-run))) - (loop (+ i 1) k to-run)))) - (begin - (vector-set! scheduler 0 t) - (vector-set! scheduler 1 k) - to-run)))))))) - (define (scheduler-reset! scheduler) - (match scheduler - (#(ticks num-tasks max-tasks tasks) - (vector-set! scheduler 0 0) - (vector-set! scheduler 1 0) - (do ((i 0 (+ i 1))) - ((= i num-tasks)) - (vector-set! tasks i #f))))) - (define *scheduler* (make-scheduler 100)) - (define current-scheduler (make-parameter *scheduler*)) - (define current-script (make-parameter #f)) - (define %script-tag (make-prompt-tag "script")) - (define-type script - %make-script - script? - (scheduler script-scheduler set-script-scheduler!) - (state script-state set-script-state!) - (cont script-cont set-script-cont!) - (children script-children set-script-children!)) - (define (make-script thunk) - (%make-script (current-scheduler) 'pending thunk '())) - (define (script-pending? script) - (eq? (script-state script) 'pending)) - (define (script-running? script) - (eq? (script-state script) 'running)) - (define (script-cancelled? script) - (eq? (script-state script) 'cancelled)) - (define (script-cancel! script) - (set-script-state! script 'cancelled) - (for-each script-cancel! (script-children script))) - (define (script-run! script) - (define scheduler (script-scheduler script)) - (define (run thunk) - (unless (script-cancelled? script) - (call-with-prompt %script-tag - (lambda () - (parameterize ((current-script script) - (current-scheduler scheduler)) - (thunk))) - handler))) - (define (handler k delay) - (when delay - (scheduler-add! scheduler (lambda () (run k)) delay))) - (when (script-pending? script) - (let ((parent (current-script))) - (when parent - (set-script-children! parent (cons script (script-children parent))))) - (run - (lambda () - (set-script-state! script 'running) - ((script-cont script)) - ;; Nasty hack: For some reason, falling through the prompt - ;; thunk messes up the Scheme stack, resulting in an invalid - ;; ref.cast somewhere. So, we *never* fall through. Instead, - ;; we create a continuation that gets thrown away. - (abort-to-prompt %script-tag #f))))) - (define (run-script thunk) - (let ((script (make-script thunk))) - (script-run! script) - script)) - (define (wait delay) - (abort-to-prompt %script-tag delay)) - (define-syntax-rule (forever body ...) - (let loop () - body ... - (loop))) - (define* (tween proc duration start end ease interpolate) - (let ((d (inexact duration))) - (let loop ((t 0)) - (if (= t duration) - (proc end) - (let ((alpha (ease (/ (inexact t) d)))) - (proc (interpolate start end alpha)) - (wait 1) - (loop (+ t 1))))))) - - ;; Particles: - (define-type particle-pool - %make-particle-pool - particle-pool? - (length particle-pool-length set-particle-pool-length!) - (capacity particle-pool-capacity set-particle-pool-capacity!) - (image particle-pool-image set-particle-pool-image!) - (ticks particle-pool-ticks set-particle-pool-ticks!) - (particles particle-pool-particles set-particle-pool-particles!)) - ;; per particle: spawn-time, lifespan, tile-x, x, y, dx, dy - (define %particle-size (+ 4 4 8 8 8 8 8)) - (define particle-tile-width 8.0) - (define particle-tile-height 8.0) - (define (make-particle-pool capacity image) - (let ((particles (make-bytevector (* capacity %particle-size)))) - (%make-particle-pool 0 capacity image 0 particles))) - (define (particle-pool-offset i) - (* i %particle-size)) - (define (particle-pool-add! pool type lifespan x y dx dy) - (match pool - (#('particle-pool length capacity image ticks particles) - (let ((offset (particle-pool-offset length)) - (tx (* (match type - ('muzzle-flash 0.0) - ('explosion 1.0) - ('hit-wall 2.0)) - particle-tile-width))) - (s32-set! particles offset ticks) - (s32-set! particles (+ offset 4) lifespan) - (f64-set! particles (+ offset 8) tx) - (f64-set! particles (+ offset 16) x) - (f64-set! particles (+ offset 24) y) - (f64-set! particles (+ offset 32) dx) - (f64-set! particles (+ offset 40) dy) - (set-particle-pool-length! pool (+ length 1)))))) - (define (particle-pool-remove! pool i) - (match pool - (#('particle-pool length capacity image ticks particles) - (when (and (>= i 0) (< i length)) - (let ((at (particle-pool-offset i)) - (start (particle-pool-offset (- length 1)))) - (bytevector-copy! particles at particles start (+ start %particle-size)) - (set-particle-pool-length! pool (- length 1))))))) - (define (particle-pool-reset! pool) - (set-particle-pool-length! pool 0)) - (define (particle-pool-update! pool) - (match pool - (#('particle-pool length capacity image ticks particles) - (let ((t (+ ticks 1))) - (let loop ((i 0) (k length)) - (when (< i k) - (let* ((offset (particle-pool-offset i)) - (t* (s32-ref particles offset)) - (l (s32-ref particles (+ offset 4))) - (x (f64-ref particles (+ offset 16))) - (y (f64-ref particles (+ offset 24))) - (dx (f64-ref particles (+ offset 32))) - (dy (f64-ref particles (+ offset 40))) - (x* (+ x dx)) - (y* (+ y dy))) - (cond - ((>= (- t t*) l) - (particle-pool-remove! pool i) - (loop i (- k 1))) - (else - (f64-set! particles (+ offset 16) (+ x dx)) - (f64-set! particles (+ offset 24) (+ y dy)) - (loop (+ i 1) k)))))) - (set-particle-pool-ticks! pool t))))) - (define (draw-particles pool) - (match pool - (#('particle-pool length capacity image ticks particles) - (do ((i 0 (+ i 1))) - ((= i length)) - (let* ((offset (particle-pool-offset i)) - (tx (f64-ref particles (+ offset 8))) - (x (f64-ref particles (+ offset 16))) - (y (f64-ref particles (+ offset 24)))) - (draw-image context image tx 0.0 - particle-tile-width particle-tile-height - (- x (/ particle-tile-width 2.0)) - (- y (/ particle-tile-height 2.0)) - particle-tile-width particle-tile-height)))))) - - (define particles (make-particle-pool 500 image:particles)) - (define (explode x y) +(import (scheme base) + (only (scheme inexact) cos sin) + (scheme time) + (only (hoot bytevectors) + bytevector-s32-native-ref + bytevector-s32-native-set! + bytevector-ieee-double-native-ref + bytevector-ieee-double-native-set!) + (only (hoot control) + make-prompt-tag + abort-to-prompt + call-with-prompt) + (hoot debug) + (hoot ffi) + (hoot match) + (only (hoot syntax) define-syntax-rule define*) + (strigoform audio) + (strigoform assets) + (strigoform bullets) + (strigoform canvas) + (strigoform document) + (strigoform element) + (strigoform enemies) + (strigoform event) + (strigoform game-area) + (strigoform image) + (strigoform math) + (strigoform level) + (strigoform level-1) + (strigoform particles) + (strigoform scripts) + (strigoform time) + (strigoform window)) + +;; Global game state: +;; splash, play, pause, game-over, game-clear +(define *game-state* 'splash) +(define *debug?* #f) + +;; Canvas elements: +(define canvas (get-element-by-id "canvas")) +(define context (get-context canvas "2d")) + +;; Assets: +(load-assets!) +(set-audio-loop! music 1) +(set-audio-volume! music 0.5) +(define (music-play) + (audio-play music)) +(define (music-pause) + (audio-pause music)) +(define (music-stop) + (audio-pause music) + (audio-seek music 0.0)) + +;; Particles: +(define particles (make-particle-pool 500 image:particles)) + +;; Bullets: +(define player-bullets (make-bullet-pool 200 image:player-bullets)) +(define enemy-bullets (make-bullet-pool 400 image:enemy-bullets)) + +;; Scrolling level: +(define *last-row-scanned* 0) +(define level (load-level-1)) +(define max-scroll (- (* (level-height level) tile-height) game-height)) +(define *scroll* 0.0) +(define *last-scroll* 0.0) +(define *scroll-speed* 0.5) +(define (change-scroll-speed new-speed duration) + (run-script + (lambda () + (tween (lambda (speed) + (set! *scroll-speed* speed)) + duration + *scroll-speed* new-speed + smoothstep lerp)))) +(define (scroll-update!) + (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) + (set! *last-scroll* *scroll*) + (set! *scroll* scroll))) + +;; Boss warning message state +(define *show-warning?* #f) +(define (do-warning) + (run-script + (lambda () + (do ((i 0 (+ i 1))) + ((= i 10)) + (set! *show-warning?* #t) + (wait 15) + (set! *show-warning?* #f) + (wait 15))))) + +(define (assq-ref lst key) + (match (assq key lst) + (#f #f) + ((_ . val) val))) + +(define (do-level-action type x y properties) + (match type + ('turret (spawn-turret x y)) + ('popcorn (spawn-popcorn x y)) + ('popcorn-down (spawn-popcorn-down x y)) + ('popcorn-swarm (spawn-popcorn-swarm x y)) + ('popcorn-sweep-left (spawn-popcorn-sweep-left x y)) + ('popcorn-sweep-right (spawn-popcorn-sweep-right x y)) + ('flyer0 (spawn-flyer0 x y)) + ('flyer1 (spawn-flyer1 x y)) + ('flyer1-tunnel (spawn-tunnel-flyer1 x y)) + ('flyer1-down (spawn-flyer1-down x y)) + ('flyer1-down-left (spawn-flyer1-down-left x y)) + ('flyer1-down-right (spawn-flyer1-down-right x y)) + ('boss (spawn-boss x y)) + ('scroll-speed + (let ((speed (assq-ref properties 'speed)) + (duration (or (assq-ref properties 'duration) 0))) + (when speed + (change-scroll-speed speed duration)))) + ('chaser (spawn-chaser x y)) + ('warning (do-warning)) + (_ #t))) + +;; Enemies: +(define enemies (make-enemy-pool 64)) + +(define (spawn-enemy enemy) + (enemy-pool-add! enemies enemy)) + +(define (spawn-popcorn* x y script) + (spawn-enemy + (make-enemy 'popcorn 2 (vec2 x y) (vec2 12.0 12.0) + (vec2 0.0 0.0) script 100 + #(0.0 16.0 32.0 48.0) image:popcorn (vec2 16.0 16.0)))) + +(define (spawn-turret* x y script) + (spawn-enemy + (make-enemy 'turret 10 (vec2 x y) (vec2 12.0 12.0) + (vec2 0.0 0.0) script 200 + #(0.0 16.0 32.0 48.0) image:turret (vec2 16.0 16.0)))) + +(define (spawn-flyer0* x y script) + (spawn-enemy + (make-enemy 'flyer0 20 (vec2 x y) (vec2 12.0 12.0) + (vec2 0.0 0.0) script 500 + #(0.0 16.0 32.0 48.0) image:flyer0 (vec2 16.0 16.0)))) + +(define (spawn-flyer1* x y script) + (spawn-enemy + (make-enemy 'flyer1 30 (vec2 x y) (vec2 22.0 16.0) + (vec2 0.0 0.0) script 1000 + #(0.0 24.0 48.0 72.0) image:flyer1 (vec2 24.0 24.0)))) + +(define (spawn-turret x y) + (define (script enemy) + (let ((speed 3.0)) + (define (current-dir) + (direction-to-player (enemy-position enemy))) + (define (shoot dir) + (bullet-pool-add! enemy-bullets 1 + (enemy-x enemy) + (enemy-y enemy) + 2.0 2.0 + (* (vec2-x dir) speed) + (* (vec2-y dir) speed))) + (forever + (wait 60) + (let ((dir (current-dir))) + (shoot dir) + (wait 5) + (shoot dir) + (wait 5) + (shoot dir))))) + (spawn-turret* x y script)) + +(define (spawn-popcorn x y) + (define (script popcorn) + (forever + (tween (lambda (dy) + (set-enemy-dy! popcorn dy)) + 30 -0.2 0.2 + smoothstep lerp) + (tween (lambda (dy) + (set-enemy-dy! popcorn dy)) + 30 0.2 -0.2 + smoothstep lerp))) + (spawn-popcorn* x y script)) + +(define (spawn-popcorn-down x y) + (define (script popcorn) + (set-enemy-dy! popcorn 1.1)) + (spawn-popcorn* x y script)) + +(define (spawn-popcorn-swarm x y) + (define (script popcorn) + (forever + (tween (lambda (dx) + (set-enemy-dx! popcorn dx)) + 60 -0.5 0.5 + smoothstep lerp) + (tween (lambda (dx) + (set-enemy-dx! popcorn dx)) + 60 0.5 -0.5 + smoothstep lerp))) + (spawn-popcorn* x y script)) + +(define (spawn-popcorn-sweep-left x y) + (define (script popcorn) + (set-enemy-dy! popcorn 1.0) + (tween (lambda (dx) + (set-enemy-dx! popcorn dx)) + 60 0.0 -3.0 + smoothstep lerp)) + (run-script + (lambda () + (do ((i 0 (+ i 1))) + ((= i 9)) + (spawn-popcorn* x y script) + (wait 15))))) + +(define (spawn-popcorn-sweep-right x y) + (define (script popcorn) + (set-enemy-dy! popcorn 1.0) + (tween (lambda (dx) + (set-enemy-dx! popcorn dx)) + 60 0.0 3.0 + smoothstep lerp)) + (run-script + (lambda () + (do ((i 0 (+ i 1))) + ((= i 9)) + (spawn-popcorn* x y script) + (wait 15))))) + +(define (spawn-flyer0 x y) + (define (script flyer) + (run-script + (lambda () + (wait 60) (let ((speed 1.0)) - (do-circle - (lambda (theta) - (particle-pool-add! particles 'explosion 20 x y - (* (cos theta) speed) (* (sin theta) speed))) - 16))) - - ;; Bullets: - ;; Similar to particles... but different. - (define-type bullet-pool - %make-bullet-pool - bullet-pool? - (length bullet-pool-length set-bullet-pool-length!) - (capacity bullet-pool-capacity set-bullet-pool-capacity!) - (image bullet-pool-image set-bullet-pool-image!) - (bullets bullet-pool-bullets set-bullet-pool-bullets!)) - (define bullet-tile-width 16.0) - (define bullet-tile-height 16.0) - ;; per bullet: type, tile-x, x, y, w, h, dx, dy - (define %bullet-size (+ 4 8 8 8 8 8 8 8)) - (define (make-bullet-pool capacity image) - (let ((bullets (make-bytevector (* capacity %bullet-size)))) - (%make-bullet-pool 0 capacity image bullets))) - (define (bullet-pool-offset i) - (* i %bullet-size)) - (define (bullet-pool-add! pool type x y w h dx dy) - (match pool - (#('bullet-pool length capacity image bullets) - (let ((offset (bullet-pool-offset length))) - (s32-set! bullets offset type) - (f64-set! bullets (+ offset 4) (* type bullet-tile-width)) - (f64-set! bullets (+ offset 12) x) - (f64-set! bullets (+ offset 20) y) - (f64-set! bullets (+ offset 28) w) - (f64-set! bullets (+ offset 36) h) - (f64-set! bullets (+ offset 44) dx) - (f64-set! bullets (+ offset 52) dy) - (set-bullet-pool-length! pool (+ length 1)))))) - (define (bullet-pool-remove! pool i) - (match pool - (#('bullet-pool length capacity image bullets) - (when (and (>= i 0) (< i length)) - (let ((at (bullet-pool-offset i)) - (start (bullet-pool-offset (- length 1)))) - (bytevector-copy! bullets at bullets start (+ start %bullet-size)) - (set-bullet-pool-length! pool (- length 1))))))) - (define (bullet-pool-reset! pool) - (set-bullet-pool-length! pool 0)) - (define (bullet-pool-update! pool collide) - (match pool - (#('bullet-pool length capacity image bullets) - (let ((dscroll (- *scroll* *last-scroll*))) - (let loop ((i 0) (k length)) - (when (< i k) - (let* ((offset (bullet-pool-offset i)) - (type (s32-ref bullets offset)) - (x (f64-ref bullets (+ offset 12))) - (y (f64-ref bullets (+ offset 20))) - (w (f64-ref bullets (+ offset 28))) - (h (f64-ref bullets (+ offset 36))) - (dx (f64-ref bullets (+ offset 44))) - (dy (f64-ref bullets (+ offset 52))) - (x* (+ x dx)) - (y* (+ y dy dscroll))) - (cond - ((out-of-bounds? x* y* w h) - (bullet-pool-remove! pool i) - (loop i (- k 1))) - ((collide type x* y* w h) - (let ((d 1.0) - (l 3)) - (sound-effect-play sound:bullet-hit 0.02) - (particle-pool-add! particles 'hit-wall l x* y* d d) - (particle-pool-add! particles 'hit-wall l x* y* (- d) d) - (particle-pool-add! particles 'hit-wall l x* y* (- d) (- d)) - (particle-pool-add! particles 'hit-wall l x* y* d (- d)) - #t) - (bullet-pool-remove! pool i) - (loop i (- k 1))) - (else - (f64-set! bullets (+ offset 12) x*) - (f64-set! bullets (+ offset 20) y*) - (loop (+ i 1) k)))))))))) - (define (draw-bullets pool) - (match pool - (#('bullet-pool length capacity image bullets) - (do ((i 0 (+ i 1))) - ((= i length)) - (let* ((offset (bullet-pool-offset i)) - (tx (f64-ref bullets (+ offset 4))) - (x (f64-ref bullets (+ offset 12))) - (y (f64-ref bullets (+ offset 20))) - (w (f64-ref bullets (+ offset 28))) - (h (f64-ref bullets (+ offset 36)))) - (draw-image context image tx 0.0 - bullet-tile-width bullet-tile-height - (- x (/ bullet-tile-width 2.0)) - (- y (/ bullet-tile-height 2.0)) - bullet-tile-width bullet-tile-height)))))) - - (define player-bullets (make-bullet-pool 200 image:player-bullets)) - (define enemy-bullets (make-bullet-pool 400 image:enemy-bullets)) - - ;; Scrolling level: - (define *scroll* 0.0) - (define *last-scroll* 0.0) - (define *scroll-speed* 0.5) - (define (change-scroll-speed new-speed duration) - (run-script - (lambda () - (tween (lambda (speed) - (set! *scroll-speed* speed)) - duration - *scroll-speed* new-speed - smoothstep lerp)))) - (define *last-row-scanned* 0) - ;; action id, sprite sheet offset, x, y - (define %tile-size (+ 4 8 8 8)) - (define tile-width 16.0) - (define tile-height 16.0) - (define level-width 15) - (define-type level-object - make-level-object - level-object? - (x level-object-x set-level-object-x!) - (type level-object-type set-level-object-type!) - (properties level-object-properties set-level-object-properties!)) - (define-type level - make-level - level? - (height level-height set-level-height!) - (foreground level-foreground set-level-foreground!) - (collision level-collision set-level-collision!) - (objects level-objects set-level-objects!)) - (define level ,(call-with-input-file "level.scm" read)) - (define (level-offset x y) - (+ (* level-width y) x)) - (define (point-collides-with-level? level x y) - (match level - (#('level height foreground collision objects) - (let ((tx (exact (truncate (/ x tile-width)))) - (ty (exact (truncate (/ y tile-height))))) - (and (>= tx 0) (< tx level-width) - (>= ty 0) (< tx height) - (= (bytevector-u8-ref collision (level-offset tx ty)) 1)))))) - (define (rect-collides-with-level? level x y w h) - (match level - (#('level height foreground collision objects) - (let* ((y (+ y (- (* height tile-height) game-height *scroll*))) - (tx0 (exact (truncate (/ x tile-width)))) - (ty0 (exact (truncate (/ y tile-height)))) - (tx1 (exact (truncate (/ (+ x w) tile-width)))) - (ty1 (exact (truncate (/ (+ y h) tile-height))))) - (define (occupied? x y) - (and (>= x 0) (< x level-width) - (>= y 0) (< x height) - (= (bytevector-u8-ref collision (level-offset x y)) 1))) - (or (occupied? tx0 ty0) - (occupied? tx1 ty0) - (occupied? tx1 ty1) - (occupied? tx0 ty1)))))) - (define (draw-level-layer level layer parallax) - (match level - (#('level height _ _ _) - (let* ((tw tile-width) - (th tile-height) - (scroll (* *scroll* parallax)) - (pixel-y-offset (- (* height th) scroll game-height)) - (scroll-y-offset (- height (exact (truncate (/ scroll tile-height))))) - (y-start (clamp (- scroll-y-offset 21) 0 height)) - (y-end (clamp scroll-y-offset 0 height))) - (do ((y y-start (+ y 1))) - ((= y y-end)) - (let* ((row (vector-ref layer y)) - (k (/ (bytevector-length row) 16)) - (ty (* y tile-height))) - (do ((x 0 (+ x 1))) - ((= x k)) - (let* ((offset (* x 16)) - (tx (f64-ref row offset)) - (ix (f64-ref row (+ offset 8)))) - (draw-image context image:map - ix 0.0 tw th - tx (- ty pixel-y-offset) tw th))))))))) - (define (draw-level-foreground level) - (match level - (#('level height foreground collision objects) - (draw-level-layer level foreground 1.0)))) - (define (do-level-action type x y properties) - (match type - ('turret (spawn-turret x y)) - ('popcorn (spawn-popcorn x y)) - ('popcorn-down (spawn-popcorn-down x y)) - ('popcorn-swarm (spawn-popcorn-swarm x y)) - ('popcorn-sweep-left (spawn-popcorn-sweep-left x y)) - ('popcorn-sweep-right (spawn-popcorn-sweep-right x y)) - ('flyer0 (spawn-flyer0 x y)) - ('flyer1 (spawn-flyer1 x y)) - ('flyer1-tunnel (spawn-tunnel-flyer1 x y)) - ('flyer1-down (spawn-flyer1-down x y)) - ('flyer1-down-left (spawn-flyer1-down-left x y)) - ('flyer1-down-right (spawn-flyer1-down-right x y)) - ('boss (spawn-boss x y)) - ('scroll-speed - (let ((speed (assq-ref properties 'speed)) - (duration (or (assq-ref properties 'duration) 0))) - (when speed - (change-scroll-speed speed duration)))) - ('chaser (spawn-chaser x y)) - ('warning (do-warning)) - (_ #t))) - (define max-scroll (- (* (level-height level) tile-height) game-height)) - (define (level-update! level) - (match level - (#('level height foreground collision objects) - (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) - (set! *last-scroll* *scroll*) - (set! *scroll* scroll) - (let ((row (max - (exact - (truncate - (/ (- (* height tile-height) - game-height scroll) - tile-height))) - 0))) - (do ((y row (+ y 1))) - ((= y *last-row-scanned*)) - (for-each (lambda (obj) - (match obj - (#('level-object x type properties) - (let ((x* (+ (* x tile-width) - (/ tile-width 2.0))) - (y* (+ (* (- y row 1) tile-height) - (/ tile-height 2.0)))) - (do-level-action type x* y* properties))))) - (vector-ref objects y))) - (set! *last-row-scanned* row)))))) - - ;; Enemies - (define-type enemy - %make-enemy - enemy? - (type enemy-type set-enemy-type!) - (health enemy-health set-enemy-health!) - (position enemy-position set-enemy-position!) - (size enemy-size set-enemy-size!) - (velocity enemy-velocity set-enemy-velocity!) - (script enemy-script set-enemy-script!) - (points enemy-points set-enemy-points!) - (spawn-time enemy-spawn-time set-enemy-spawn-time!) - (animation enemy-animation set-enemy-animation!) - (image enemy-image set-enemy-image!) - (image-size enemy-image-size set-enemy-image-size!)) - (define (make-enemy type health position size velocity - script points animation image image-size) - (%make-enemy type health position size velocity script - points (current-time) animation image - image-size)) - (define (enemy-x enemy) - (vec2-x (enemy-position enemy))) - (define (enemy-y enemy) - (vec2-y (enemy-position enemy))) - (define (set-enemy-x! enemy x) - (set-vec2-x! (enemy-position enemy) x)) - (define (set-enemy-y! enemy y) - (set-vec2-y! (enemy-position enemy) y)) - (define (enemy-width enemy) - (vec2-x (enemy-size enemy))) - (define (enemy-height enemy) - (vec2-y (enemy-size enemy))) - (define (enemy-dx enemy) - (vec2-x (enemy-velocity enemy))) - (define (enemy-dy enemy) - (vec2-y (enemy-velocity enemy))) - (define (set-enemy-dx! enemy dx) - (set-vec2-x! (enemy-velocity enemy) dx)) - (define (set-enemy-dy! enemy dy) - (set-vec2-y! (enemy-velocity enemy) dy)) - (define (enemy-damage! enemy damage) - (match enemy - (#('enemy type health _ _ _ _ _ _ _ _ _) - (set-enemy-health! enemy (- health damage))))) - (define (enemy-dead? enemy) - (<= (enemy-health enemy) 0)) - (define (enemy-out-of-bounds? enemy) - (match enemy - (#('enemy _ _ position size _ _ _ _ _ _ _) - (out-of-bounds? (vec2-x position) (vec2-y position) - (vec2-x size) (vec2-y size))))) - (define (enemy-within-rect? enemy x y w h) - (match enemy - (#('enemy _ _ position size _ _ _ _ _ _ _) - (let* ((w* (vec2-x size)) - (h* (vec2-y size)) - (x* (- (vec2-x position) (/ w* 2.0))) - (y* (- (vec2-y position) (/ h* 2.0)))) - (rect-within? x y w h x* y* w* h*))))) - (define (enemy-start! enemy) - (let ((proc (enemy-script enemy))) - (when (procedure? proc) - (set-enemy-script! enemy (run-script (lambda () (proc enemy))))))) - (define (enemy-stop! enemy) - (let ((script (enemy-script enemy))) - (when (script? script) - (script-cancel! script)))) - (define (enemy-update! enemy) - (match enemy - (#('enemy _ _ position size velocity _ _ _ _ _ _) - (let ((scroll-dy (- *scroll* *last-scroll*))) - (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity))) - (set-vec2-y! position (+ (vec2-y position) - (+ (vec2-y velocity) scroll-dy))))))) - (define (draw-enemy enemy time) - (let ((frame-duration 0.25)) - (match enemy - (#('enemy type _ position size _ _ _ spawn-time animation - image image-size) - (let* ((tx (vector-ref animation - (modulo (exact - (truncate - (/ (- time spawn-time) - frame-duration))) - (vector-length animation)))) - (x (vec2-x position)) - (y (vec2-y position)) - (hbw (vec2-x size)) - (hbh (vec2-y size)) - (w (vec2-x image-size)) - (h (vec2-y image-size))) - (draw-image context image tx 0.0 w h - (- x (/ w 2.0)) (- y (/ h 2.0)) w h) - (when *debug?* - (set-fill-color! context "#ff00ff80") - (fill-rect context - (- x (/ hbw 2.0)) - (- y (/ hbh 2.0)) - hbw hbh))))))) - - (define-type enemy-pool - %make-enemy-pool - enemy-pool? - (length enemy-pool-length set-enemy-pool-length!) - (capacity enemy-pool-capacity set-enemy-pool-capacity!) - (enemies enemy-pool-enemies set-enemy-pool-enemies!)) - (define (make-enemy-pool capacity) - (%make-enemy-pool 0 capacity (make-vector capacity #f))) - (define (enemy-pool-add! pool enemy) - (match pool - (#('enemy-pool length capacity enemies) - (unless (= length capacity) - (vector-set! enemies length enemy) - (set-enemy-pool-length! pool (+ length 1)) - (enemy-start! enemy))))) - (define (enemy-pool-remove! pool i) - (match pool - (#('enemy-pool length capacity enemies) - (when (and (>= i 0) (< i length)) - (let ((j (- length 1)) - (enemy (vector-ref enemies i))) - (vector-set! enemies i (vector-ref enemies j)) - (vector-set! enemies j #f) - (enemy-stop! enemy) - (set-enemy-pool-length! pool j)))))) - (define (enemy-pool-reset! pool) - (match pool - (#('enemy-pool length capacity enemies) - (do ((i 0 (+ i 1))) - ((= i length)) - (enemy-stop! (vector-ref enemies i)) - (vector-set! enemies i #f)) - (set-enemy-pool-length! pool 0)))) - (define (enemy-pool-update! pool) - (match pool - (#('enemy-pool length capacity enemies) - (let ((padding 16.0)) - (let loop ((i 0) (k length)) - (unless (= i k) - (let ((enemy (vector-ref enemies i))) - (enemy-update! enemy) - (cond - ((or (enemy-dead? enemy) - (enemy-out-of-bounds? enemy)) - (when (enemy-dead? enemy) - (sound-effect-play sound:explosion) - (explode (enemy-x enemy) (enemy-y enemy)) - (set! *player-score* - (+ *player-score* (enemy-points enemy)))) - (when (eq? (enemy-type enemy) 'boss) - (run-script - (lambda () - (set! *player-invincible?* #t) - (wait 60) - (do-game-clear)))) - (enemy-pool-remove! pool i) - (loop i (- k 1))) - (else - (loop (+ i 1) k)))))))))) - (define (draw-enemies pool time) - (match pool - (#('enemy-pool length capacity enemies) - (do ((i 0 (+ i 1))) - ((= i length)) - (draw-enemy (vector-ref enemies i) time))))) - (define (find-enemy pool x y w h) - (match pool - (#('enemy-pool length capacity enemies) - (let loop ((i 0)) - (and (< i length) - (let ((enemy (vector-ref enemies i))) - (if (enemy-within-rect? enemy x y w h) - enemy - (loop (+ i 1))))))))) - - (define enemies (make-enemy-pool 64)) - - (define (spawn-enemy enemy) - (enemy-pool-add! enemies enemy)) - - (define (spawn-popcorn* x y script) - (spawn-enemy - (make-enemy 'popcorn 2 (vec2 x y) (vec2 12.0 12.0) - (vec2 0.0 0.0) script 100 - #(0.0 16.0 32.0 48.0) image:popcorn (vec2 16.0 16.0)))) - - (define (spawn-turret* x y script) - (spawn-enemy - (make-enemy 'turret 10 (vec2 x y) (vec2 12.0 12.0) - (vec2 0.0 0.0) script 200 - #(0.0 16.0 32.0 48.0) image:turret (vec2 16.0 16.0)))) - - (define (spawn-flyer0* x y script) - (spawn-enemy - (make-enemy 'flyer0 20 (vec2 x y) (vec2 12.0 12.0) - (vec2 0.0 0.0) script 500 - #(0.0 16.0 32.0 48.0) image:flyer0 (vec2 16.0 16.0)))) - - (define (spawn-flyer1* x y script) - (spawn-enemy - (make-enemy 'flyer1 30 (vec2 x y) (vec2 22.0 16.0) - (vec2 0.0 0.0) script 1000 - #(0.0 24.0 48.0 72.0) image:flyer1 (vec2 24.0 24.0)))) - - (define (spawn-turret x y) - (define (script enemy) - (let ((speed 3.0)) - (define (current-dir) - (direction-to-player (enemy-position enemy))) - (define (shoot dir) - (bullet-pool-add! enemy-bullets 1 - (enemy-x enemy) - (enemy-y enemy) - 2.0 2.0 - (* (vec2-x dir) speed) - (* (vec2-y dir) speed))) - (forever - (wait 60) - (let ((dir (current-dir))) - (shoot dir) - (wait 5) - (shoot dir) - (wait 5) - (shoot dir))))) - (spawn-turret* x y script)) - - (define (spawn-popcorn x y) - (define (script popcorn) - (forever - (tween (lambda (dy) - (set-enemy-dy! popcorn dy)) - 30 -0.2 0.2 - smoothstep lerp) - (tween (lambda (dy) - (set-enemy-dy! popcorn dy)) - 30 0.2 -0.2 - smoothstep lerp))) - (spawn-popcorn* x y script)) - - (define (spawn-popcorn-down x y) - (define (script popcorn) - (set-enemy-dy! popcorn 1.1)) - (spawn-popcorn* x y script)) - - (define (spawn-popcorn-swarm x y) - (define (script popcorn) - (forever - (tween (lambda (dx) - (set-enemy-dx! popcorn dx)) - 60 -0.5 0.5 - smoothstep lerp) - (tween (lambda (dx) - (set-enemy-dx! popcorn dx)) - 60 0.5 -0.5 - smoothstep lerp))) - (spawn-popcorn* x y script)) - - (define (spawn-popcorn-sweep-left x y) - (define (script popcorn) - (set-enemy-dy! popcorn 1.0) - (tween (lambda (dx) - (set-enemy-dx! popcorn dx)) - 60 0.0 -3.0 - smoothstep lerp)) - (run-script - (lambda () - (do ((i 0 (+ i 1))) - ((= i 9)) - (spawn-popcorn* x y script) - (wait 15))))) - - (define (spawn-popcorn-sweep-right x y) - (define (script popcorn) - (set-enemy-dy! popcorn 1.0) - (tween (lambda (dx) - (set-enemy-dx! popcorn dx)) - 60 0.0 3.0 - smoothstep lerp)) - (run-script - (lambda () - (do ((i 0 (+ i 1))) - ((= i 9)) - (spawn-popcorn* x y script) - (wait 15))))) - - (define (spawn-flyer0 x y) - (define (script flyer) - (run-script - (lambda () - (wait 60) - (let ((speed 1.0)) - (let loop ((i 0.0)) - (let ((theta (+ (* (sin i) (/ pi 3.0)) (/ pi 3.0)))) - (bullet-pool-add! enemy-bullets 0 - (enemy-x flyer) - (enemy-y flyer) - 2.0 2.0 - (* (cos theta) speed) - (* (sin theta) speed)) - (wait 8)) - (loop (+ i 0.5)))))) - (let ((speed 0.5)) - (forever - (tween (lambda (dx) - (set-enemy-dx! flyer dx)) - 60 -0.5 0.5 - smoothstep lerp) - (tween (lambda (dx) - (set-enemy-dx! flyer dx)) - 60 0.5 -0.5 - smoothstep lerp)))) - (spawn-flyer0* x y script)) - - (define (spawn-flyer1 x y) - (spawn-flyer1* x y #f)) - - (define (spawn-tunnel-flyer1 x y) - (define (script flyer) - (define (shoot dx dy) - (bullet-pool-add! enemy-bullets 2 - (enemy-x flyer) - (enemy-y flyer) - 4.0 4.0 - dx dy)) - (set-enemy-dy! flyer 1.0) - (wait 40) - (shoot 0.0 2.0) - (wait 40) - (set-enemy-dx! flyer -1.0) - (set-enemy-dy! flyer 0.0) - (run-script - (lambda () - (do ((i 0 (+ i 1))) - ((= i 3)) - (wait 20) - (shoot -2.0 0.0)))) - (wait 140) - (set-enemy-dx! flyer 0.0) - (set-enemy-dy! flyer 1.0) - (run-script - (lambda () - (do ((i 0 (+ i 1))) - ((= i 3)) - (wait 20) - (shoot 0.0 2.0))))) - (spawn-flyer1* x y script)) - - (define (spawn-flyer1-down x y) - (define (script flyer) - (define (shoot* theta) - (let ((speed 2.0)) - (bullet-pool-add! enemy-bullets 2 + (let loop ((i 0.0)) + (let ((theta (+ (* (sin i) (/ pi 3.0)) (/ pi 3.0)))) + (bullet-pool-add! enemy-bullets 0 (enemy-x flyer) (enemy-y flyer) - 4.0 4.0 + 2.0 2.0 (* (cos theta) speed) - (* (sin theta) speed)))) - (define (shoot) - (shoot* pi/2) - ;; (shoot* (+ pi/2 0.1)) - ;; (shoot* (- pi/2 0.1)) - ) - (set-enemy-dy! flyer 1.0) - (wait 30) - (shoot) - (wait 15) - (shoot) - (wait 15) - (shoot)) - (spawn-flyer1* x y script)) - - (define (spawn-flyer1-down-left x y) - (define (script flyer) - (define (shoot dx dy) - (bullet-pool-add! enemy-bullets 2 - (enemy-x flyer) - (enemy-y flyer) - 4.0 4.0 - dx dy)) - (set-enemy-dy! flyer 1.0) + (* (sin theta) speed)) + (wait 8)) + (loop (+ i 0.5)))))) + (let ((speed 0.5)) + (forever + (tween (lambda (dx) + (set-enemy-dx! flyer dx)) + 60 -0.5 0.5 + smoothstep lerp) + (tween (lambda (dx) + (set-enemy-dx! flyer dx)) + 60 0.5 -0.5 + smoothstep lerp)))) + (spawn-flyer0* x y script)) + +(define (spawn-flyer1 x y) + (spawn-flyer1* x y #f)) + +(define (spawn-tunnel-flyer1 x y) + (define (script flyer) + (define (shoot dx dy) + (bullet-pool-add! enemy-bullets 2 + (enemy-x flyer) + (enemy-y flyer) + 4.0 4.0 + dx dy)) + (set-enemy-dy! flyer 1.0) + (wait 40) + (shoot 0.0 2.0) + (wait 40) + (set-enemy-dx! flyer -1.0) + (set-enemy-dy! flyer 0.0) + (run-script + (lambda () + (do ((i 0 (+ i 1))) + ((= i 3)) + (wait 20) + (shoot -2.0 0.0)))) + (wait 140) + (set-enemy-dx! flyer 0.0) + (set-enemy-dy! flyer 1.0) + (run-script + (lambda () + (do ((i 0 (+ i 1))) + ((= i 3)) + (wait 20) + (shoot 0.0 2.0))))) + (spawn-flyer1* x y script)) + +(define (spawn-flyer1-down x y) + (define (script flyer) + (define (shoot* theta) + (let ((speed 2.0)) + (bullet-pool-add! enemy-bullets 2 + (enemy-x flyer) + (enemy-y flyer) + 4.0 4.0 + (* (cos theta) speed) + (* (sin theta) speed)))) + (define (shoot) + (shoot* pi/2) + ;; (shoot* (+ pi/2 0.1)) + ;; (shoot* (- pi/2 0.1)) + ) + (set-enemy-dy! flyer 1.0) + (wait 30) + (shoot) + (wait 15) + (shoot) + (wait 15) + (shoot)) + (spawn-flyer1* x y script)) + +(define (spawn-flyer1-down-left x y) + (define (script flyer) + (define (shoot dx dy) + (bullet-pool-add! enemy-bullets 2 + (enemy-x flyer) + (enemy-y flyer) + 4.0 4.0 + dx dy)) + (set-enemy-dy! flyer 1.0) + (wait 60) + (set-enemy-dx! flyer -1.0) + (set-enemy-dy! flyer 0.0) + (wait 40) + (tween (lambda (dx) + (set-enemy-dx! flyer dx)) + 30 -1.0 0.0 + smoothstep lerp) + (forever + (wait 30) + (shoot 0.0 1.5))) + (spawn-flyer1* x y script)) + +(define (spawn-flyer1-down-right x y) + (define (script flyer) + (define (shoot dx dy) + (bullet-pool-add! enemy-bullets 2 + (enemy-x flyer) + (enemy-y flyer) + 4.0 4.0 + dx dy)) + (set-enemy-dy! flyer 1.0) + (wait 60) + (set-enemy-dx! flyer 1.0) + (set-enemy-dy! flyer 0.0) + (wait 40) + (tween (lambda (dx) + (set-enemy-dx! flyer dx)) + 30 1.0 0.0 + smoothstep lerp) + (forever + (wait 30) + (shoot 0.0 1.5))) + (spawn-flyer1* x y script)) + +(define (spawn-chaser x y) + (define (script flyer) + (define (shoot dx dy) + (bullet-pool-add! enemy-bullets 2 + (enemy-x flyer) + (enemy-y flyer) + 4.0 4.0 + dx dy)) + (set-enemy-dy! flyer -3.0) + (wait 30) + (tween (lambda (dy) + (set-enemy-dy! flyer dy)) + 30 -3.0 -1.0 + smoothstep lerp) + (tween (lambda (dy) + (set-enemy-dy! flyer dy)) + 30 -1.0 -2.9 + smoothstep lerp) + (wait (* 5 60)) + (tween (lambda (dy) + (set-enemy-dy! flyer dy)) + 30 -2.9 -1.2 + smoothstep lerp) + (wait (+ (* 3 60) 30)) + (tween (lambda (dy) + (set-enemy-dy! flyer dy)) + 30 -1.2 0.0 + smoothstep lerp) + (forever + (wait 30) + (shoot 0.0 1.5))) + (spawn-flyer1* x (+ y game-height 8.0) script)) + +(define (spawn-boss x y) + (define (script boss) + (define (muzzle-flash x y) + (let ((life 6) + (ldx -1.0) + (rdx 1.0) + (dy 1.0)) + (particle-pool-add! particles 'muzzle-flash life x y ldx dy) + (particle-pool-add! particles 'muzzle-flash life x y rdx dy))) + (define (shoot type x y dx dy) + (let ((s (if (= type 4) 4.0 2.0))) + (bullet-pool-add! enemy-bullets type x y s s dx dy))) + (define (xoff dx) + (+ (enemy-x boss) dx)) + (define (yoff dy) + (+ (enemy-y boss) dy)) + (define (shoot+flash type xo yo dx dy) + (let ((x (xoff xo)) + (y (yoff yo))) + (shoot type x y dx dy) + (muzzle-flash x y))) + (define main-left-x -43.0) + (define main-right-x 43.0) + (define main-y 48.0) + (define alt-left-x -58.0) + (define alt-right-x 58.0) + (define alt-y 28.0) + (define (shoot-main-left type dx dy) + (shoot+flash type main-left-x main-y dx dy)) + (define (shoot-main-right type dx dy) + (shoot+flash type main-right-x main-y dx dy)) + (define (shoot-alt-left type dx dy) + (shoot+flash type alt-left-x alt-y dx dy)) + (define (shoot-alt-right type dx dy) + (shoot+flash type alt-right-x alt-y dx dy)) + (define (shoot-beak type dx dy) + (shoot+flash type 0.0 24.0 dx dy)) + (define (player-dir dx dy) + (let ((p (enemy-position boss))) + (direction-to-player + (vec2 (+ (vec2-x p) dx) (+ (vec2-y p) dy))))) + (define (wait-if duration pred consequent alternate) + (let loop ((d duration)) + (if (= d 0) + (consequent) + (begin + (wait 1) + (if (pred) + (loop (- d 1)) + (alternate)))))) + (define (nop) #f) + (define (phase-3) + (define (pred) #t) + (wait 180) + (run-script + (lambda () + (let ((speed 4.0)) + (let loop ((theta 0.0)) + (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) + (theta** (+ (- (/ pi 3.0) (fmod theta (/ pi 3.0))) (/ pi 3.0))) + (speed 4.0)) + (shoot-alt-left 4 (* (cos theta*) speed) (* (sin theta*) speed)) + (shoot-alt-right 4 (* (cos theta**) speed) (* (sin theta**) speed)) + (wait 30) + (loop (+ theta 0.35))))))) + (run-script + (lambda () + (wait 120) + (let outer () + (let ((v (player-dir alt-left-x alt-y))) + (vec2-mul-scalar! v 3.5) + (let inner ((i 0)) + (when (< i 15) + (shoot-alt-left 0 (vec2-x v) (vec2-y v)) + (wait 4) + (inner (+ i 1)))) + (wait-if 30 pred outer nop))))) + (run-script + (lambda () (wait 60) - (set-enemy-dx! flyer -1.0) - (set-enemy-dy! flyer 0.0) - (wait 40) - (tween (lambda (dx) - (set-enemy-dx! flyer dx)) - 30 -1.0 0.0 - smoothstep lerp) - (forever - (wait 30) - (shoot 0.0 1.5))) - (spawn-flyer1* x y script)) - - (define (spawn-flyer1-down-right x y) - (define (script flyer) - (define (shoot dx dy) - (bullet-pool-add! enemy-bullets 2 - (enemy-x flyer) - (enemy-y flyer) - 4.0 4.0 - dx dy)) - (set-enemy-dy! flyer 1.0) + (let outer () + (let ((v (player-dir alt-right-x alt-y))) + (vec2-mul-scalar! v 3.5) + (let inner ((i 0)) + (when (< i 15) + (shoot-alt-right 0 (vec2-x v) (vec2-y v)) + (wait 4) + (inner (+ i 1)))) + (wait-if 30 pred outer nop))))) + (let ((speed 1.0) + (k 10)) + (let outer () + (let inner ((i 0)) + (when (<= i k) + (let ((theta (* (inexact (/ i k)) pi))) + (shoot-beak 4 (* (cos theta) speed) (* (sin theta) speed)) + (inner (+ i 1))))) + (wait-if 60 pred outer nop)))) + (define (phase-2) + (define (pred) (> (enemy-health boss) 500)) + (wait 180) + (run-script + (lambda () + (let loop () + (let ((dx 2.0) + (dy 4.0)) + (do ((i 0 (+ i 1))) + ((= i 30)) + (shoot-alt-left 0 dx dy) + (shoot-alt-right 0 (- dx) dy) + (wait 4)) + (wait-if 60 pred loop nop))))) + (run-script + (lambda () + (wait 120) + (let loop () + (let ((v (player-dir main-left-x main-y))) + (vec2-mul-scalar! v 3.5) + (do ((i 0 (+ i 1))) + ((= i 5)) + (shoot-main-left 0 (vec2-x v) (vec2-y v)) + (wait 4))) + (wait-if 120 pred loop nop)))) + (run-script + (lambda () (wait 60) - (set-enemy-dx! flyer 1.0) - (set-enemy-dy! flyer 0.0) - (wait 40) - (tween (lambda (dx) - (set-enemy-dx! flyer dx)) - 30 1.0 0.0 - smoothstep lerp) - (forever - (wait 30) - (shoot 0.0 1.5))) - (spawn-flyer1* x y script)) - - (define (spawn-chaser x y) - (define (script flyer) - (define (shoot dx dy) - (bullet-pool-add! enemy-bullets 2 - (enemy-x flyer) - (enemy-y flyer) - 4.0 4.0 - dx dy)) - (set-enemy-dy! flyer -3.0) - (wait 30) - (tween (lambda (dy) - (set-enemy-dy! flyer dy)) - 30 -3.0 -1.0 - smoothstep lerp) - (tween (lambda (dy) - (set-enemy-dy! flyer dy)) - 30 -1.0 -2.9 - smoothstep lerp) - (wait (* 5 60)) - (tween (lambda (dy) - (set-enemy-dy! flyer dy)) - 30 -2.9 -1.2 - smoothstep lerp) - (wait (+ (* 3 60) 30)) - (tween (lambda (dy) - (set-enemy-dy! flyer dy)) - 30 -1.2 0.0 - smoothstep lerp) - (forever - (wait 30) - (shoot 0.0 1.5))) - (spawn-flyer1* x (+ y game-height 8.0) script)) - - (define (spawn-boss x y) - (define (script boss) - (define (muzzle-flash x y) - (let ((life 6) - (ldx -1.0) - (rdx 1.0) - (dy 1.0)) - (particle-pool-add! particles 'muzzle-flash life x y ldx dy) - (particle-pool-add! particles 'muzzle-flash life x y rdx dy))) - (define (shoot type x y dx dy) - (let ((s (if (= type 4) 4.0 2.0))) - (bullet-pool-add! enemy-bullets type x y s s dx dy))) - (define (xoff dx) - (+ (enemy-x boss) dx)) - (define (yoff dy) - (+ (enemy-y boss) dy)) - (define (shoot+flash type xo yo dx dy) - (let ((x (xoff xo)) - (y (yoff yo))) - (shoot type x y dx dy) - (muzzle-flash x y))) - (define main-left-x -43.0) - (define main-right-x 43.0) - (define main-y 48.0) - (define alt-left-x -58.0) - (define alt-right-x 58.0) - (define alt-y 28.0) - (define (shoot-main-left type dx dy) - (shoot+flash type main-left-x main-y dx dy)) - (define (shoot-main-right type dx dy) - (shoot+flash type main-right-x main-y dx dy)) - (define (shoot-alt-left type dx dy) - (shoot+flash type alt-left-x alt-y dx dy)) - (define (shoot-alt-right type dx dy) - (shoot+flash type alt-right-x alt-y dx dy)) - (define (shoot-beak type dx dy) - (shoot+flash type 0.0 24.0 dx dy)) - (define (player-dir dx dy) - (let ((p (enemy-position boss))) - (direction-to-player - (vec2 (+ (vec2-x p) dx) (+ (vec2-y p) dy))))) - (define (wait-if duration pred consequent alternate) - (let loop ((d duration)) - (if (= d 0) - (consequent) - (begin - (wait 1) - (if (pred) - (loop (- d 1)) - (alternate)))))) - (define (nop) #f) - (define (phase-3) - (define (pred) #t) - (wait 180) - (run-script - (lambda () - (let ((speed 4.0)) - (let loop ((theta 0.0)) - (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) - (theta** (+ (- (/ pi 3.0) (fmod theta (/ pi 3.0))) (/ pi 3.0))) - (speed 4.0)) - (shoot-alt-left 4 (* (cos theta*) speed) (* (sin theta*) speed)) - (shoot-alt-right 4 (* (cos theta**) speed) (* (sin theta**) speed)) - (wait 30) - (loop (+ theta 0.35))))))) - (run-script - (lambda () - (wait 120) - (let outer () - (let ((v (player-dir alt-left-x alt-y))) - (vec2-mul-scalar! v 3.5) - (let inner ((i 0)) - (when (< i 15) - (shoot-alt-left 0 (vec2-x v) (vec2-y v)) - (wait 4) - (inner (+ i 1)))) - (wait-if 30 pred outer nop))))) - (run-script - (lambda () - (wait 60) - (let outer () - (let ((v (player-dir alt-right-x alt-y))) - (vec2-mul-scalar! v 3.5) - (let inner ((i 0)) - (when (< i 15) - (shoot-alt-right 0 (vec2-x v) (vec2-y v)) - (wait 4) - (inner (+ i 1)))) - (wait-if 30 pred outer nop))))) - (let ((speed 1.0) - (k 10)) - (let outer () - (let inner ((i 0)) - (when (<= i k) - (let ((theta (* (inexact (/ i k)) pi))) - (shoot-beak 4 (* (cos theta) speed) (* (sin theta) speed)) - (inner (+ i 1))))) - (wait-if 60 pred outer nop)))) - (define (phase-2) - (define (pred) (> (enemy-health boss) 500)) - (wait 180) - (run-script - (lambda () - (let loop () - (let ((dx 2.0) - (dy 4.0)) - (do ((i 0 (+ i 1))) - ((= i 30)) - (shoot-alt-left 0 dx dy) - (shoot-alt-right 0 (- dx) dy) - (wait 4)) - (wait-if 60 pred loop nop))))) - (run-script - (lambda () - (wait 120) - (let loop () - (let ((v (player-dir main-left-x main-y))) - (vec2-mul-scalar! v 3.5) - (do ((i 0 (+ i 1))) - ((= i 5)) - (shoot-main-left 0 (vec2-x v) (vec2-y v)) - (wait 4))) - (wait-if 120 pred loop nop)))) - (run-script - (lambda () - (wait 60) - (let loop () - (let ((v (player-dir main-right-x main-y))) - (vec2-mul-scalar! v 3.5) - (do ((i 0 (+ i 1))) - ((= i 5)) - (shoot-main-right 0 (vec2-x v) (vec2-y v)) - (wait 4))) - (wait-if 120 pred loop nop)))) - (run-script - (lambda () - (let loop ((theta 0.0)) - (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) - (speed 4.0)) - (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed)) - (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop))))) - (let ((speed 1.2)) - (let loop ((offset 0.0)) - (do-circle - (lambda (theta) - (let ((theta* (+ theta offset))) - (shoot-beak 0 (* (cos theta*) speed) (* (sin theta*) speed)))) - 3) - (wait-if 5 pred (lambda () (loop (+ offset 0.1))) phase-3)))) - (define (phase-1) - (define (pred) (> (enemy-health boss) 1000)) - (run-script - (lambda () - (wait 120) - (let loop () - (let ((v (player-dir alt-left-x alt-y))) - (vec2-mul-scalar! v 3.5) - (do ((i 0 (+ i 1))) - ((= i 5)) - (shoot-alt-left 0 (vec2-x v) (vec2-y v)) - (wait 4))) - (wait-if 120 pred loop nop)))) - (run-script - (lambda () - (wait 60) - (let loop () - (let ((v (player-dir alt-right-x alt-y))) - (vec2-mul-scalar! v 3.5) - (do ((i 0 (+ i 1))) - ((= i 5)) - (shoot-alt-right 0 (vec2-x v) (vec2-y v)) - (wait 4))) - (wait-if 120 pred loop nop)))) - (run-script - (lambda () - (let loop ((theta 0.0)) - (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) - (speed 4.0)) - (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed)) - (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop))))) - (let ((speed 0.75)) - (let loop ((theta 0.0)) - (let ((dx (* (cos theta) speed)) - (dy (* (sin theta) speed))) - (shoot-main-left 0 dx dy) - (shoot-main-right 0 (- dx) dy) - (wait-if 5 pred (lambda () (loop (+ theta 0.4))) phase-2))))) - (wait 180) - (run-script - (lambda () - (forever - (tween (lambda (dx) - (set-enemy-dx! boss dx)) - 60 -0.5 0.5 - smoothstep lerp) - (tween (lambda (dx) - (set-enemy-dx! boss dx)) - 60 0.5 -0.5 - smoothstep lerp)))) - (phase-1)) - (spawn-enemy - (make-enemy 'boss 1500 (vec2 x (- y 32.0)) (vec2 144.0 64.0) - (vec2 0.0 0.0) script 500000 - #(0.0 144.0 288.0 432.0) image:boss (vec2 144.0 96.0)))) - - ;; Player state: - (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0))) - (define player-velocity (vec2 0.0 0.0)) - (define *player-tile-x* 0.0) - (define player-speed 2.9) - (define player-focus-speed 1.5) - (define player-bullet-speed 12.3) - (define player-width 24.0) - (define player-height 24.0) - (define *player-fire-counter* 0) - (define player-fire-interval 3) - (define player-focus-fire-interval 5) - (define player-hitbox-position (vec2 0.0 0.0)) - (define player-hitbox-width 2.0) - (define player-hitbox-height 2.0) - (define %default-lives 3) - (define *player-lives* %default-lives) - (define *player-visible?* #t) - (define *player-invincible?* #f) - (define *player-score* 0) - (define *player-1cc?* #t) - ;; left, right, down, up, fire, focus - (define key-state (vector #f #f #f #f #f #f)) - (define (update-player-velocity!) - (match key-state - (#(left? right? down? up? _ _) - (set-vec2-x! player-velocity - (+ (if left? -1.0 0.0) - (if right? 1.0 0.0))) - (set-vec2-y! player-velocity - (+ (if down? 1.0 0.0) - (if up? -1.0 0.0))) - (vec2-normalize! player-velocity) - (vec2-mul-scalar! player-velocity - (if (focusing?) - player-focus-speed - player-speed)) - (set! *player-tile-x* - (* (cond - ((and left? (not right?)) 1.0) - ((and right? (not left?)) 3.0) - (else 0.0)) - player-width))))) - (define (set-left! pressed?) - (vector-set! key-state 0 pressed?) - (update-player-velocity!)) - (define (set-right! pressed?) - (vector-set! key-state 1 pressed?) - (update-player-velocity!)) - (define (set-down! pressed?) - (vector-set! key-state 2 pressed?) - (update-player-velocity!)) - (define (set-up! pressed?) - (vector-set! key-state 3 pressed?) - (update-player-velocity!)) - (define (firing?) - (vector-ref key-state 4)) - (define (set-firing! pressed?) - (let ((was-firing? (firing?))) - (vector-set! key-state 4 pressed?) - (when (and pressed? (not was-firing?)) - (set! *player-fire-counter* 0)))) - (define (focusing?) - (vector-ref key-state 5)) - (define (set-focusing! pressed?) - (let ((was-focusing? (focusing?))) - (vector-set! key-state 5 pressed?) - (update-player-velocity!) - (when (and pressed? (not was-focusing?)) - (set! *player-fire-counter* 0)))) - (define (player-position-reset!) - (set-vec2-x! player-position (/ game-width 2.0)) - (set-vec2-y! player-position (- game-height 12.0))) - (define (do-player-invincible) - (run-script - (lambda () - (set! *player-invincible?* #t) - (let ((t 5)) - (let loop ((i 0)) - (when (< i 10) - (set! *player-visible?* #f) - (wait t) - (set! *player-visible?* #t) - (wait t) - (loop (+ i 1))))) - (set! *player-invincible?* #f)))) - (define (player-die!) - (unless *player-invincible?* - (sound-effect-play sound:player-death 0.5) - (explode (vec2-x player-position) - (vec2-y player-position)) - (set! *player-lives* (max (- *player-lives* 1) 0)) - (player-position-reset!) - (do-player-invincible))) - (define (game-over?) - (= *player-lives* 0)) - (define (player-update!) - (define (muzzle-flash x y) - (let ((life 6) - (ldx -1.0) - (rdx 1.0) - (dy -1.0)) - (particle-pool-add! particles 'muzzle-flash life x y ldx dy) - (particle-pool-add! particles 'muzzle-flash life x y rdx dy))) - (let ((old-x (vec2-x player-position)) - (old-y (vec2-y player-position))) - (vec2-add! player-position player-velocity) - (vec2-clamp! player-position 0.0 0.0 game-width game-height) - (let ((x (vec2-x player-position)) - (y (vec2-y player-position)) - (hbx (vec2-x player-hitbox-position)) - (hby (vec2-y player-hitbox-position)) - (hbw player-hitbox-width) - (hbh player-hitbox-height)) - (if (or (rect-collides-with-level? level x y hbw hbh) - (find-enemy enemies x y hbw hbh)) - (begin - ;; (set-vec2-x! player-position old-x) - ;; (set-vec2-y! player-position - ;; (+ old-y (- *scroll* *last-scroll*))) - (player-die!)) - (begin - (set-vec2-x! player-hitbox-position (- x (/ hbw 2.0))) - (set-vec2-y! player-hitbox-position (- y (/ hbh 2.0))))))) - (when (firing?) - (set! *player-fire-counter* - (modulo (+ *player-fire-counter* 1) + (let loop () + (let ((v (player-dir main-right-x main-y))) + (vec2-mul-scalar! v 3.5) + (do ((i 0 (+ i 1))) + ((= i 5)) + (shoot-main-right 0 (vec2-x v) (vec2-y v)) + (wait 4))) + (wait-if 120 pred loop nop)))) + (run-script + (lambda () + (let loop ((theta 0.0)) + (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) + (speed 4.0)) + (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed)) + (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop))))) + (let ((speed 1.2)) + (let loop ((offset 0.0)) + (do-circle + (lambda (theta) + (let ((theta* (+ theta offset))) + (shoot-beak 0 (* (cos theta*) speed) (* (sin theta*) speed)))) + 3) + (wait-if 5 pred (lambda () (loop (+ offset 0.1))) phase-3)))) + (define (phase-1) + (define (pred) (> (enemy-health boss) 1000)) + (run-script + (lambda () + (wait 120) + (let loop () + (let ((v (player-dir alt-left-x alt-y))) + (vec2-mul-scalar! v 3.5) + (do ((i 0 (+ i 1))) + ((= i 5)) + (shoot-alt-left 0 (vec2-x v) (vec2-y v)) + (wait 4))) + (wait-if 120 pred loop nop)))) + (run-script + (lambda () + (wait 60) + (let loop () + (let ((v (player-dir alt-right-x alt-y))) + (vec2-mul-scalar! v 3.5) + (do ((i 0 (+ i 1))) + ((= i 5)) + (shoot-alt-right 0 (vec2-x v) (vec2-y v)) + (wait 4))) + (wait-if 120 pred loop nop)))) + (run-script + (lambda () + (let loop ((theta 0.0)) + (let ((theta* (+ (fmod theta (/ pi 3.0)) (/ pi 3.0))) + (speed 4.0)) + (shoot-beak 4 (* (cos theta*) speed) (* (sin theta*) speed)) + (wait-if 30 pred (lambda () (loop (+ theta 0.35))) nop))))) + (let ((speed 0.75)) + (let loop ((theta 0.0)) + (let ((dx (* (cos theta) speed)) + (dy (* (sin theta) speed))) + (shoot-main-left 0 dx dy) + (shoot-main-right 0 (- dx) dy) + (wait-if 5 pred (lambda () (loop (+ theta 0.4))) phase-2))))) + (wait 180) + (run-script + (lambda () + (forever + (tween (lambda (dx) + (set-enemy-dx! boss dx)) + 60 -0.5 0.5 + smoothstep lerp) + (tween (lambda (dx) + (set-enemy-dx! boss dx)) + 60 0.5 -0.5 + smoothstep lerp)))) + (phase-1)) + (spawn-enemy + (make-enemy 'boss 1500 (vec2 x (- y 32.0)) (vec2 144.0 64.0) + (vec2 0.0 0.0) script 500000 + #(0.0 144.0 288.0 432.0) image:boss (vec2 144.0 96.0)))) + +;; Player state: +(define player-position (vec2 (/ game-width 2.0) (- game-height 12.0))) +(define player-velocity (vec2 0.0 0.0)) +(define *player-tile-x* 0.0) +(define player-speed 2.9) +(define player-focus-speed 1.5) +(define player-bullet-speed 12.3) +(define player-width 24.0) +(define player-height 24.0) +(define *player-fire-counter* 0) +(define player-fire-interval 3) +(define player-focus-fire-interval 5) +(define player-hitbox-position (vec2 0.0 0.0)) +(define player-hitbox-width 2.0) +(define player-hitbox-height 2.0) +(define %default-lives 3) +(define *player-lives* %default-lives) +(define *player-visible?* #t) +(define *player-invincible?* #f) +(define *player-score* 0) +(define *player-1cc?* #t) +;; left, right, down, up, fire, focus +(define key-state (vector #f #f #f #f #f #f)) +(define (update-player-velocity!) + (match key-state + (#(left? right? down? up? _ _) + (set-vec2-x! player-velocity + (+ (if left? -1.0 0.0) + (if right? 1.0 0.0))) + (set-vec2-y! player-velocity + (+ (if down? 1.0 0.0) + (if up? -1.0 0.0))) + (vec2-normalize! player-velocity) + (vec2-mul-scalar! player-velocity (if (focusing?) - player-focus-fire-interval - player-fire-interval))) - (when (= *player-fire-counter* 0) - (sound-effect-play sound:player-shoot 0.2) - (let ((px (vec2-x player-position)) - (py (vec2-y player-position))) - (if (focusing?) - (let ((y-off 6.0)) - (muzzle-flash px (- py y-off)) - (bullet-pool-add! player-bullets 1 - (- px 1.0) py - 6.0 6.0 - 0.0 (- player-bullet-speed))) - (let ((hbw 3.0) - (hbh 4.0) - (lx (- px 6.0)) - (rx (+ px 8.0)) - (y (- py 4.0))) - (muzzle-flash lx y) - (muzzle-flash rx y) - (bullet-pool-add! player-bullets 0 - lx py - hbw hbh - 0.0 (- player-bullet-speed)) - (bullet-pool-add! player-bullets 0 - rx py - hbw hbh - 0.0 (- player-bullet-speed))))) - (set! *player-fire-counter* 0)))) - (define (draw-player) - (when *player-visible?* - (draw-image context image:player - *player-tile-x* 0.0 - player-width player-height - (- (vec2-x player-position) - (/ player-width 2.0)) - (- (vec2-y player-position) - (/ player-height 2.0)) - player-width player-height)) - (when *debug?* - (set-fill-color! context "#ff00ff80") - (fill-rect context - (vec2-x player-hitbox-position) - (vec2-y player-hitbox-position) - player-hitbox-width - player-hitbox-height))) - (define (direction-to-player v) - (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) - (vec2-sub! v* v) - (vec2-normalize! v*) - v*)) - - (define (do-splash) - (music-stop) - (set! *game-state* 'splash)) - - ;; Game over screen state - (define *countdown* "") - (define *countdown-scheduler* (make-scheduler 5)) - (define (do-countdown) - (parameterize ((current-scheduler *countdown-scheduler*)) - (run-script - (lambda () - (let loop ((i 9)) - (set! *countdown* (number->string i)) - (wait 60) - (unless (= i 0) - (loop (- i 1)))) - (do-splash))))) - (define (do-game-over) - (scheduler-reset! *countdown-scheduler*) - (music-pause) - (set! *game-state* 'game-over) - (do-countdown)) - (define (do-continue) - (music-play) - (player-position-reset!) - (set! *player-lives* 3) - (set! *player-1cc?* #f) - (set! *game-state* 'play) - (do-player-invincible)) - - ;; Clear screen state - (define *clear-show-1cc-bonus?* #f) - (define *clear-show-life-bonus?* #f) - (define *clear-show-total-score?* #f) - (define *clear-1cc-bonus* "") - (define *clear-life-bonus* "") - (define *clear-total-score* "") - (define (do-game-clear) - (scheduler-reset! *scheduler*) - (music-stop) - (set! *game-state* 'game-clear) - (set! *clear-show-1cc-bonus?* #t) - (set! *clear-show-life-bonus?* #t) - (set! *clear-show-total-score?* #t) - (if *player-1cc?* - (let ((1cc-bonus 1000000) - (life-bonus (* *player-lives* 250000))) - (set! *player-score* (+ *player-score* 1cc-bonus life-bonus)) - (set! *clear-1cc-bonus* (number->string 1cc-bonus)) - (set! *clear-life-bonus* (number->string life-bonus))) - (begin - (set! *clear-1cc-bonus* "0") - (set! *clear-life-bonus* "0"))) - (set! *clear-total-score* (number->string *player-score*)) - ;; Disabled due to a Hoot compiler bug :((( - ;; (run-script - ;; (lambda () - ;; (wait 60) - ;; (set! *clear-show-1cc-bonus?* #t) - ;; (wait 60) - ;; (set! *clear-show-life-bonus?* #t) - ;; (wait 60) - ;; (set! *clear-show-total-score?* #t))) - ) - - ;; Canvas sizing/scaling. - (define *canvas-scale* 0.0) - (define *canvas-width* 0) - (define *canvas-height* 0) - (define (resize-canvas) - (let* ((win (current-window)) - (w (window-inner-width win)) - (h (window-inner-height win)) - (gw (exact (truncate game-width))) - (gh (exact (truncate game-height))) - (scale (max (min (quotient w gw) (quotient h gh)) 1)) - (cw (* gw scale)) - (ch (* gh scale))) - (set-element-width! canvas (pk 'canvas-width cw)) - (set-element-height! canvas (pk 'canvas-height ch)) - (set-image-smoothing-enabled! context 0) - (set! *canvas-scale* (inexact scale)) - (set! *canvas-width* (* game-width *canvas-scale*)) - (set! *canvas-height* (* game-height *canvas-scale*)))) - - ;; Boss warning message state - (define *show-warning?* #f) - (define (do-warning) - (run-script - (lambda () - (do ((i 0 (+ i 1))) - ((= i 10)) - (set! *show-warning?* #t) - (wait 15) - (set! *show-warning?* #f) - (wait 15))))) - - (define (clear-screen) - (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)) - - (define (draw-player-bullets) - (draw-bullets player-bullets)) - - (define (draw-enemy-bullets) - (draw-bullets enemy-bullets)) - - (define (draw-background image parallax) - (let ((scroll (fmod (* *scroll* parallax) game-height))) - ;; Bottom - (draw-image context image - 0.0 0.0 game-width (- game-height scroll) - 0.0 scroll game-width (- game-height scroll)) - ;; Top - (draw-image context image - 0.0 (- game-height scroll) game-width scroll - 0.0 0.0 game-width scroll))) - - (define (draw-hud) - (let ((y (- game-height 8.0))) - ;; TODO: Don't allocate strings every frame when the UI - ;; values rarely change. - (set-fill-color! context "#ffffff") - (set-font! context "bold 16px monogram") - (set-text-align! context "right") - (fill-text context (string-append "x" (number->string *player-lives*)) - (- game-width 4.0) y) - (set-text-align! context "left") - (fill-text context (number->string *player-score*) 4.0 y))) - - (define (draw-splash time) - (draw-image context image:cover - 0.0 0.0 game-width game-height - 0.0 0.0 game-width game-height) - (let ((x (/ game-width 2.0)) - (y (+ (- game-height 40.0) (* (sin (* time 2.0)) 4.0)))) - (set-fill-color! context "#ffffff") - (set-font! context "bold 18px monogram") - (set-text-align! context "center") - (fill-text context "Press ENTER to start" x y))) - - (define (draw-play time) - (draw-background image:starfield-bg 0.3) - (draw-background image:starfield-fg 0.5) - (draw-level-foreground level) - (draw-particles particles) - (draw-player-bullets) - (draw-enemies enemies time) - (draw-player) - (draw-enemy-bullets) - (draw-hud) - (when *show-warning?* - (set-fill-color! context "#d27d2c") - (set-text-align! context "center") - (set-font! context "bold 72px monogram") - (fill-text context "WARNING" - (/ game-width 2.0) - (/ game-height 2.0)))) - - (define (draw-pause time) - (draw-background image:starfield-bg 0.3) - (draw-background image:starfield-fg 0.5) - (draw-level-foreground level) - (draw-particles particles) - (draw-player-bullets) - (draw-enemies enemies time) - (draw-player) - (draw-enemy-bullets) - (draw-hud) - (set-fill-color! context "#ffffff") - (set-font! context "bold 36px monogram") - (set-text-align! context "center") - (fill-text context "PAUSED" (/ game-width 2.0) (/ game-height 2.0))) - - (define (draw-game-over time) - (draw-background image:starfield-bg 0.3) - (draw-background image:starfield-fg 0.5) - (draw-level-foreground level) - (draw-particles particles) - (draw-enemies enemies time) - (draw-enemy-bullets) - (draw-hud) - (set-fill-color! context "#ffffff") - (set-font! context "bold 36px monogram") - (set-text-align! context "center") - (fill-text context "CONTINUE?" - (/ game-width 2.0) (/ game-height 3.0)) - (set-font! context "bold 72px monogram") - (fill-text context *countdown* - (/ game-width 2.0) (+ (/ game-height 3.0) 60.0))) - - (define (draw-game-clear time) - (draw-background image:starfield-bg 0.3) - (draw-background image:starfield-fg 0.5) - (draw-level-foreground level) - (draw-particles particles) - (draw-player) - (set-fill-color! context "#ffffff") - (set-font! context "bold 36px monogram") - (set-text-align! context "center") - (fill-text context "CLEAR" (/ game-width 2.0) (/ game-height 3.0)) - (set-font! context "bold 24px monogram") - (set-text-align! context "left") - (when *clear-show-1cc-bonus?* - (fill-text context "1CC BONUS" - 16.0 - (+ (/ game-height 3.0) 40))) - (when *clear-show-life-bonus?* - (fill-text context "LIFE BONUS" - 16.0 - (+ (/ game-height 3.0) 80))) - (when *clear-show-total-score?* - (fill-text context "TOTAL SCORE" - 16.0 - (+ (/ game-height 3.0) 120))) - (set-text-align! context "right") - (when *clear-show-1cc-bonus?* - (fill-text context *clear-1cc-bonus* - (- game-width 16.0) - (+ (/ game-height 3.0) 40))) - (when *clear-show-life-bonus?* - (fill-text context *clear-life-bonus* - (- game-width 16.0) - (+ (/ game-height 3.0) 80))) - (when *clear-show-total-score?* - (fill-text context *clear-total-score* - (- game-width 16.0) - (+ (/ game-height 3.0) 120)))) - - (define (draw _prev-time) - (let ((time (current-time))) - (clear-screen) - (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) - (set-scale! context *canvas-scale* *canvas-scale*) - (set-fill-color! context "#140c1c") - (fill-rect context 0.0 0.0 game-width game-height) - (let ((draw* (match *game-state* - ('splash draw-splash) - ('play draw-play) - ('pause draw-pause) - ('game-over draw-game-over) - ('game-clear draw-game-clear)))) - (draw* time)) - (request-animation-frame draw-callback))) - (define draw-callback (procedure->external draw)) - - (define (reset!) - (music-stop) - (music-play) - (set! *game-state* 'play) - (scheduler-reset! *scheduler*) - (set! *scroll* 0.0) - ;; (set! *scroll* (* 460.0 tile-height)) - (set! *last-scroll* 0.0) - (set! *last-row-scanned* (level-height level)) - ;; (set! *last-row-scanned* (- (level-height level) 460)) - (bullet-pool-reset! player-bullets) - (bullet-pool-reset! enemy-bullets) - (enemy-pool-reset! enemies) - (particle-pool-reset! particles) - (player-position-reset!) - (set! *player-tile-x* 0.0) - (set! *player-lives* %default-lives) - (set! *player-invincible?* #f) - (set! *player-visible?* #t) - (set! *player-fire-counter* 0) - (set! *player-score* 0) - (set! *player-1cc?* #t)) - - (define (on-key-down event) - (let ((code (keyboard-event-code event))) + player-focus-speed + player-speed)) + (set! *player-tile-x* + (* (cond + ((and left? (not right?)) 1.0) + ((and right? (not left?)) 3.0) + (else 0.0)) + player-width))))) +(define (set-left! pressed?) + (vector-set! key-state 0 pressed?) + (update-player-velocity!)) +(define (set-right! pressed?) + (vector-set! key-state 1 pressed?) + (update-player-velocity!)) +(define (set-down! pressed?) + (vector-set! key-state 2 pressed?) + (update-player-velocity!)) +(define (set-up! pressed?) + (vector-set! key-state 3 pressed?) + (update-player-velocity!)) +(define (firing?) + (vector-ref key-state 4)) +(define (set-firing! pressed?) + (let ((was-firing? (firing?))) + (vector-set! key-state 4 pressed?) + (when (and pressed? (not was-firing?)) + (set! *player-fire-counter* 0)))) +(define (focusing?) + (vector-ref key-state 5)) +(define (set-focusing! pressed?) + (let ((was-focusing? (focusing?))) + (vector-set! key-state 5 pressed?) + (update-player-velocity!) + (when (and pressed? (not was-focusing?)) + (set! *player-fire-counter* 0)))) +(define (player-position-reset!) + (set-vec2-x! player-position (/ game-width 2.0)) + (set-vec2-y! player-position (- game-height 12.0))) +(define (do-player-invincible) + (run-script + (lambda () + (set! *player-invincible?* #t) + (let ((t 5)) + (let loop ((i 0)) + (when (< i 10) + (set! *player-visible?* #f) + (wait t) + (set! *player-visible?* #t) + (wait t) + (loop (+ i 1))))) + (set! *player-invincible?* #f)))) +(define (player-die!) + (unless *player-invincible?* + (sound-effect-play sound:player-death 0.5) + (explode particles + (vec2-x player-position) + (vec2-y player-position)) + (set! *player-lives* (max (- *player-lives* 1) 0)) + (player-position-reset!) + (do-player-invincible))) +(define (game-over?) + (= *player-lives* 0)) +(define (player-update!) + (define (muzzle-flash x y) + (let ((life 6) + (ldx -1.0) + (rdx 1.0) + (dy -1.0)) + (particle-pool-add! particles 'muzzle-flash life x y ldx dy) + (particle-pool-add! particles 'muzzle-flash life x y rdx dy))) + (let ((old-x (vec2-x player-position)) + (old-y (vec2-y player-position))) + (vec2-add! player-position player-velocity) + (vec2-clamp! player-position 0.0 0.0 game-width game-height) + (let ((x (vec2-x player-position)) + (y (vec2-y player-position)) + (hbx (vec2-x player-hitbox-position)) + (hby (vec2-y player-hitbox-position)) + (hbw player-hitbox-width) + (hbh player-hitbox-height)) + (if (or (rect-collides-with-level? level x y hbw hbh *scroll*) + (find-enemy enemies x y hbw hbh)) + (begin + ;; (set-vec2-x! player-position old-x) + ;; (set-vec2-y! player-position + ;; (+ old-y (- *scroll* *last-scroll*))) + (player-die!)) + (begin + (set-vec2-x! player-hitbox-position (- x (/ hbw 2.0))) + (set-vec2-y! player-hitbox-position (- y (/ hbh 2.0))))))) + (when (firing?) + (set! *player-fire-counter* + (modulo (+ *player-fire-counter* 1) + (if (focusing?) + player-focus-fire-interval + player-fire-interval))) + (when (= *player-fire-counter* 0) + (sound-effect-play sound:player-shoot 0.2) + (let ((px (vec2-x player-position)) + (py (vec2-y player-position))) + (if (focusing?) + (let ((y-off 6.0)) + (muzzle-flash px (- py y-off)) + (bullet-pool-add! player-bullets 1 + (- px 1.0) py + 6.0 6.0 + 0.0 (- player-bullet-speed))) + (let ((hbw 3.0) + (hbh 4.0) + (lx (- px 6.0)) + (rx (+ px 8.0)) + (y (- py 4.0))) + (muzzle-flash lx y) + (muzzle-flash rx y) + (bullet-pool-add! player-bullets 0 + lx py + hbw hbh + 0.0 (- player-bullet-speed)) + (bullet-pool-add! player-bullets 0 + rx py + hbw hbh + 0.0 (- player-bullet-speed))))) + (set! *player-fire-counter* 0)))) +(define (draw-player) + (when *player-visible?* + (draw-image context image:player + *player-tile-x* 0.0 + player-width player-height + (- (vec2-x player-position) + (/ player-width 2.0)) + (- (vec2-y player-position) + (/ player-height 2.0)) + player-width player-height)) + (when *debug?* + (set-fill-color! context "#ff00ff80") + (fill-rect context + (vec2-x player-hitbox-position) + (vec2-y player-hitbox-position) + player-hitbox-width + player-hitbox-height))) +(define (direction-to-player v) + (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) + (vec2-sub! v* v) + (vec2-normalize! v*) + v*)) + +(define (do-splash) + (music-stop) + (set! *game-state* 'splash)) + +;; Game over screen state +(define *countdown* "") +(define *countdown-scheduler* (make-scheduler 5)) +(define (do-countdown) + (parameterize ((current-scheduler *countdown-scheduler*)) + (run-script + (lambda () + (let loop ((i 9)) + (set! *countdown* (number->string i)) + (wait 60) + (unless (= i 0) + (loop (- i 1)))) + (do-splash))))) +(define (do-game-over) + (scheduler-reset! *countdown-scheduler*) + (music-pause) + (set! *game-state* 'game-over) + (do-countdown)) +(define (do-continue) + (music-play) + (player-position-reset!) + (set! *player-lives* 3) + (set! *player-1cc?* #f) + (set! *game-state* 'play) + (do-player-invincible)) + +;; Clear screen state +(define *clear-show-1cc-bonus?* #f) +(define *clear-show-life-bonus?* #f) +(define *clear-show-total-score?* #f) +(define *clear-1cc-bonus* "") +(define *clear-life-bonus* "") +(define *clear-total-score* "") +(define (do-game-clear) + (scheduler-reset! (current-scheduler)) + (music-stop) + (set! *game-state* 'game-clear) + (set! *clear-show-1cc-bonus?* #f) + (set! *clear-show-life-bonus?* #f) + (set! *clear-show-total-score?* #f) + (if *player-1cc?* + (let ((1cc-bonus 1000000) + (life-bonus (* *player-lives* 250000))) + (set! *player-score* (+ *player-score* 1cc-bonus life-bonus)) + (set! *clear-1cc-bonus* (number->string 1cc-bonus)) + (set! *clear-life-bonus* (number->string life-bonus))) + (begin + (set! *clear-1cc-bonus* "0") + (set! *clear-life-bonus* "0"))) + (set! *clear-total-score* (number->string *player-score*)) + (run-script + (lambda () + (wait 60) + (set! *clear-show-1cc-bonus?* #t) + (wait 60) + (set! *clear-show-life-bonus?* #t) + (wait 60) + (set! *clear-show-total-score?* #t)))) + +;; Canvas sizing/scaling. +(define *canvas-scale* 0.0) +(define *canvas-width* 0) +(define *canvas-height* 0) +(define (resize-canvas) + (let* ((win (current-window)) + (w (window-inner-width win)) + (h (window-inner-height win)) + (gw (exact (truncate game-width))) + (gh (exact (truncate game-height))) + (scale (max (min (quotient w gw) (quotient h gh)) 1)) + (cw (* gw scale)) + (ch (* gh scale))) + (set-element-width! canvas cw) + (set-element-height! canvas ch) + (set-image-smoothing-enabled! context 0) + (set! *canvas-scale* (inexact scale)) + (set! *canvas-width* (* game-width *canvas-scale*)) + (set! *canvas-height* (* game-height *canvas-scale*)))) + +(define (clear-screen) + (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)) + +(define (draw-player-bullets) + (draw-bullets context player-bullets)) + +(define (draw-enemy-bullets) + (draw-bullets context enemy-bullets)) + +(define (draw-background context image parallax) + (let ((scroll (fmod (* *scroll* parallax) game-height))) + ;; Bottom + (draw-image context image + 0.0 0.0 game-width (- game-height scroll) + 0.0 scroll game-width (- game-height scroll)) + ;; Top + (draw-image context image + 0.0 (- game-height scroll) game-width scroll + 0.0 0.0 game-width scroll))) + +(define (draw-hud) + (let ((y (- game-height 8.0))) + ;; TODO: Don't allocate strings every frame when the UI + ;; values rarely change. + (set-fill-color! context "#ffffff") + (set-font! context "bold 16px monogram") + (set-text-align! context "right") + (fill-text context (string-append "x" (number->string *player-lives*)) + (- game-width 4.0) y) + (set-text-align! context "left") + (fill-text context (number->string *player-score*) 4.0 y))) + +(define (draw-splash time) + (draw-image context image:cover + 0.0 0.0 game-width game-height + 0.0 0.0 game-width game-height) + (let ((x (/ game-width 2.0)) + (y (+ (- game-height 40.0) (* (sin (* time 2.0)) 4.0)))) + (set-fill-color! context "#ffffff") + (set-font! context "bold 18px monogram") + (set-text-align! context "center") + (fill-text context "Press ENTER to start" x y))) + +(define (draw-play time) + (draw-background context image:starfield-bg 0.3) + (draw-background context image:starfield-fg 0.5) + (draw-level-foreground context level *scroll*) + (draw-particles context particles) + (draw-player-bullets) + (draw-enemies context enemies time) + (draw-player) + (draw-enemy-bullets) + (draw-hud) + (when *show-warning?* + (set-fill-color! context "#d27d2c") + (set-text-align! context "center") + (set-font! context "bold 72px monogram") + (fill-text context "WARNING" + (/ game-width 2.0) + (/ game-height 2.0)))) + +(define (draw-pause time) + (draw-background context image:starfield-bg 0.3) + (draw-background context image:starfield-fg 0.5) + (draw-level-foreground context level *scroll*) + (draw-particles context particles) + (draw-player-bullets) + (draw-enemies context enemies time) + (draw-player) + (draw-enemy-bullets) + (draw-hud) + (set-fill-color! context "#ffffff") + (set-font! context "bold 36px monogram") + (set-text-align! context "center") + (fill-text context "PAUSED" (/ game-width 2.0) (/ game-height 2.0))) + +(define (draw-game-over time) + (draw-background context image:starfield-bg 0.3) + (draw-background context image:starfield-fg 0.5) + (draw-level-foreground context level *scroll*) + (draw-particles context particles) + (draw-enemies context enemies time) + (draw-enemy-bullets) + (draw-hud) + (set-fill-color! context "#ffffff") + (set-font! context "bold 36px monogram") + (set-text-align! context "center") + (fill-text context "CONTINUE?" + (/ game-width 2.0) (/ game-height 3.0)) + (set-font! context "bold 72px monogram") + (fill-text context *countdown* + (/ game-width 2.0) (+ (/ game-height 3.0) 60.0))) + +(define (draw-game-clear time) + (draw-background context image:starfield-bg 0.3) + (draw-background context image:starfield-fg 0.5) + (draw-level-foreground context level *scroll*) + (draw-particles context particles) + (draw-player) + (set-fill-color! context "#ffffff") + (set-font! context "bold 36px monogram") + (set-text-align! context "center") + (fill-text context "CLEAR" (/ game-width 2.0) (/ game-height 3.0)) + (set-font! context "bold 24px monogram") + (set-text-align! context "left") + (when *clear-show-1cc-bonus?* + (fill-text context "1CC BONUS" + 16.0 + (+ (/ game-height 3.0) 40))) + (when *clear-show-life-bonus?* + (fill-text context "LIFE BONUS" + 16.0 + (+ (/ game-height 3.0) 80))) + (when *clear-show-total-score?* + (fill-text context "TOTAL SCORE" + 16.0 + (+ (/ game-height 3.0) 120))) + (set-text-align! context "right") + (when *clear-show-1cc-bonus?* + (fill-text context *clear-1cc-bonus* + (- game-width 16.0) + (+ (/ game-height 3.0) 40))) + (when *clear-show-life-bonus?* + (fill-text context *clear-life-bonus* + (- game-width 16.0) + (+ (/ game-height 3.0) 80))) + (when *clear-show-total-score?* + (fill-text context *clear-total-score* + (- game-width 16.0) + (+ (/ game-height 3.0) 120)))) + +(define (draw _prev-time) + (let ((time (current-time))) + (clear-screen) + (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0) + (set-scale! context *canvas-scale* *canvas-scale*) + (set-fill-color! context "#140c1c") + (fill-rect context 0.0 0.0 game-width game-height) + (let ((draw* (match *game-state* + ('splash draw-splash) + ('play draw-play) + ('pause draw-pause) + ('game-over draw-game-over) + ('game-clear draw-game-clear)))) + (draw* time)) + (request-animation-frame draw-callback))) +(define draw-callback (procedure->external draw)) + +(define (reset!) + (music-stop) + (music-play) + (set! *game-state* 'play) + (scheduler-reset! (current-scheduler)) + ;; (set! *scroll* 0.0) + (set! *scroll* (* 460.0 tile-height)) + (set! *last-scroll* 0.0) + ;; (set! *last-row-scanned* (level-height level)) + (set! *last-row-scanned* (- (level-height level) 460)) + (bullet-pool-reset! player-bullets) + (bullet-pool-reset! enemy-bullets) + (enemy-pool-reset! enemies) + (particle-pool-reset! particles) + (player-position-reset!) + (set! *player-tile-x* 0.0) + (set! *player-lives* %default-lives) + (set! *player-invincible?* #f) + (set! *player-visible?* #t) + (set! *player-fire-counter* 0) + (set! *player-score* 0) + (set! *player-1cc?* #t)) + +(define (on-key-down event) + (let ((code (keyboard-event-code event))) + (cond + ((string=? code "ArrowLeft") + (set-left! #t) + (prevent-default! event)) + ((string=? code "ArrowRight") + (set-right! #t) + (prevent-default! event)) + ((string=? code "ArrowDown") + (set-down! #t) + (prevent-default! event)) + ((string=? code "ArrowUp") + (set-up! #t) + (prevent-default! event)) + ((string=? code "KeyZ") + (set-firing! #t) + (prevent-default! event)) + ((string=? code "KeyX" ;; "ShiftLeft" + ) + (set-focusing! #t) + (prevent-default! event))))) + +(define (on-key-up event) + (let ((code (keyboard-event-code event))) + (cond + ((string=? code "ArrowLeft") + (set-left! #f) + (prevent-default! event)) + ((string=? code "ArrowRight") + (set-right! #f) + (prevent-default! event)) + ((string=? code "ArrowDown") + (set-down! #f) + (prevent-default! event)) + ((string=? code "ArrowUp") + (set-up! #f) + (prevent-default! event)) + ((string=? code "KeyZ") + (set-firing! #f) + (prevent-default! event)) + ((string=? code "KeyX" ;; "ShiftLeft" + ) + (set-focusing! #f) + (prevent-default! event)) + (else + (match *game-state* + ('splash + (when (string=? code "Enter") + (reset!))) + ('play (cond - ((string=? code "ArrowLeft") - (set-left! #t) - (prevent-default! event)) - ((string=? code "ArrowRight") - (set-right! #t) + ((string=? code "Enter") + (set! *game-state* 'pause) + (music-pause) (prevent-default! event)) - ((string=? code "ArrowDown") - (set-down! #t) + ;; ((string=? code "KeyD") + ;; (set! *debug?* (not *debug?*)) + ;; (prevent-default! event)) + ((string=? code "KeyR") + (reset!) (prevent-default! event)) - ((string=? code "ArrowUp") - (set-up! #t) + ((string=? code "KeyW") + (do-game-clear) (prevent-default! event)) - ((string=? code "KeyZ") - (set-firing! #t) - (prevent-default! event)) - ((string=? code "KeyX" ;; "ShiftLeft" - ) - (set-focusing! #t) - (prevent-default! event))))) - - (define (on-key-up event) - (let ((code (keyboard-event-code event))) + ;; ((string=? code "KeyO") + ;; (do-game-over) + ;; (prevent-default! event)) + )) + ('pause (cond - ((string=? code "ArrowLeft") - (set-left! #f) - (prevent-default! event)) - ((string=? code "ArrowRight") - (set-right! #f) - (prevent-default! event)) - ((string=? code "ArrowDown") - (set-down! #f) - (prevent-default! event)) - ((string=? code "ArrowUp") - (set-up! #f) - (prevent-default! event)) - ((string=? code "KeyZ") - (set-firing! #f) - (prevent-default! event)) - ((string=? code "KeyX" ;; "ShiftLeft" - ) - (set-focusing! #f) - (prevent-default! event)) - (else - (match *game-state* - ('splash - (when (string=? code "Enter") - (reset!))) - ('play - (cond - ((string=? code "Enter") - (set! *game-state* 'pause) - (music-pause) - (prevent-default! event)) - ;; ((string=? code "KeyD") - ;; (set! *debug?* (not *debug?*)) - ;; (prevent-default! event)) - ((string=? code "KeyR") - (reset!) - (prevent-default! event)) - ((string=? code "KeyW") - (do-game-clear) - (prevent-default! event)) - ;; ((string=? code "KeyO") - ;; (do-game-over) - ;; (prevent-default! event)) - )) - ('pause - (cond - ((string=? code "Enter") - (set! *game-state* 'play) - (music-play) - (prevent-default! event)))) - ('game-clear - (cond - ((string=? code "Enter") - (do-splash) - (prevent-default! event)))) - ('game-over - (cond - ((string=? code "Enter") - (do-continue) - (prevent-default! event)))) - (_ #t)))))) - - (define (out-of-bounds? x y w h) - (let ((padding 32.0)) - (not (rect-within? x y w h (- padding) (- padding) - (+ game-width (* padding 2.0)) - (+ game-height (* padding 2.0)))))) - - (define (player-bullet-collide type x y w h) - (let ((x* (- x (/ w 2.0))) - (y* (- y(/ h 2.0)))) - (or (rect-collides-with-level? level x* y* w h) - (let ((enemy (find-enemy enemies x y w h))) - (and enemy - (begin - (enemy-damage! enemy - (case type - ((0) 1) - ((1) 3))) - #t)))))) - - (define (enemy-bullet-collide type x y w h) - (let ((x* (- x (/ w 2.0))) - (y* (- y(/ h 2.0)))) - (or (out-of-bounds? x* y* w h) - ;; (rect-collides-with-level? level x* y* w h) - (if (rect-collides-with-level? level x* y* w h) - (begin - (sound-effect-play sound:bullet-hit 0.01) - #t) - #f) - (if (rect-within? x y w h - (vec2-x player-hitbox-position) - (vec2-y player-hitbox-position) - player-hitbox-width - player-hitbox-height) - (begin - (player-die!) - #t) - #f)))) - - (define dt (/ 1000.0 60.0)) - (define (update) - (match *game-state* - ('play - (scheduler-tick! *scheduler*) - (level-update! level) - (player-update!) - (bullet-pool-update! player-bullets player-bullet-collide) - (bullet-pool-update! enemy-bullets enemy-bullet-collide) - (enemy-pool-update! enemies) - (particle-pool-update! particles) - (when (game-over?) - (do-game-over))) - ('game-over - (set! *scroll* *last-scroll*) - (scheduler-tick! *countdown-scheduler*)) - ('game-clear - (scheduler-tick! *scheduler*) - (bullet-pool-update! player-bullets player-bullet-collide) - (bullet-pool-update! enemy-bullets enemy-bullet-collide) - (particle-pool-update! particles)) - (_ #t)) - (timeout update-callback dt)) - (define update-callback (procedure->external update)) - - (add-event-listener! (current-window) "resize" - (procedure->external (lambda (_) (resize-canvas)))) - (add-event-listener! (current-document) "keydown" - (procedure->external on-key-down)) - (add-event-listener! (current-document) "keyup" - (procedure->external on-key-up)) - (resize-canvas) - (request-animation-frame draw-callback) - (timeout update-callback dt))) - -(define %imports - '((scheme base) - (only (scheme inexact) atan cos sin sqrt) - (scheme time) - (only (hoot bytevectors) - bytevector-s32-native-ref - bytevector-s32-native-set! - bytevector-ieee-double-native-ref - bytevector-ieee-double-native-set!) - (only (hoot control) - make-prompt-tag - abort-to-prompt - call-with-prompt) - (hoot ffi) - (hoot match) - (only (hoot syntax) define-syntax-rule define*) - (hoot debug))) - -(call-with-output-file "game.wasm" - (lambda (port) - (put-bytevector port (assemble-wasm (compile src #:imports %imports))))) + ((string=? code "Enter") + (set! *game-state* 'play) + (music-play) + (prevent-default! event)))) + ('game-clear + (cond + ((string=? code "Enter") + (do-splash) + (prevent-default! event)))) + ('game-over + (cond + ((string=? code "Enter") + (do-continue) + (prevent-default! event)))) + (_ #t)))))) + +(define (player-bullet-collide type x y w h) + (let ((x* (- x (/ w 2.0))) + (y* (- y(/ h 2.0)))) + (or (rect-collides-with-level? level x* y* w h *scroll*) + (let ((enemy (find-enemy enemies x y w h))) + (and enemy + (begin + (enemy-damage! enemy + (case type + ((0) 1) + ((1) 3))) + #t)))))) + +(define (enemy-bullet-collide type x y w h) + (let ((x* (- x (/ w 2.0))) + (y* (- y(/ h 2.0)))) + (or (out-of-bounds? x* y* w h) + ;; (rect-collides-with-level? level x* y* w h *scroll*) + (if (rect-collides-with-level? level x* y* w h *scroll*) + (begin + (sound-effect-play sound:bullet-hit 0.01) + #t) + #f) + (if (rect-within? x y w h + (vec2-x player-hitbox-position) + (vec2-y player-hitbox-position) + player-hitbox-width + player-hitbox-height) + (begin + (player-die!) + #t) + #f)))) + +(define (on-enemy-kill enemy) + (sound-effect-play sound:explosion) + (explode particles (enemy-x enemy) (enemy-y enemy)) + (set! *player-score* + (+ *player-score* (enemy-points enemy))) + (when (eq? (enemy-type enemy) 'boss) + (run-script + (lambda () + (set! *player-invincible?* #t) + (wait 60) + (do-game-clear))))) + +(define (on-bullet-collide type x y) + (let ((d 1.0) (l 3)) + (sound-effect-play sound:bullet-hit 0.02) + (particle-pool-add! particles 'hit-wall l x y d d) + (particle-pool-add! particles 'hit-wall l x y (- d) d) + (particle-pool-add! particles 'hit-wall l x y (- d) (- d)) + (particle-pool-add! particles 'hit-wall l x y d (- d)))) + +(define dt (/ 1000.0 60.0)) +(define (update) + (let ((dscroll (- *scroll* *last-scroll*))) + (match *game-state* + ('play + (scheduler-tick! (current-scheduler)) + (scroll-update!) + (set! *last-row-scanned* + (level-update! level *scroll* *last-row-scanned* do-level-action)) + (player-update!) + (bullet-pool-update! player-bullets player-bullet-collide dscroll on-bullet-collide) + (bullet-pool-update! enemy-bullets enemy-bullet-collide dscroll on-bullet-collide) + (enemy-pool-update! enemies dscroll particles on-enemy-kill) + (particle-pool-update! particles) + (when (game-over?) + (do-game-over))) + ('game-over + (set! *scroll* *last-scroll*) + (scheduler-tick! *countdown-scheduler*)) + ('game-clear + (scheduler-tick! (current-scheduler)) + (bullet-pool-update! player-bullets player-bullet-collide dscroll on-bullet-collide) + (bullet-pool-update! enemy-bullets enemy-bullet-collide dscroll on-bullet-collide) + (particle-pool-update! particles)) + (_ #t))) + (timeout update-callback dt)) +(define update-callback (procedure->external update)) + +(add-event-listener! (current-window) "resize" + (procedure->external (lambda (_) (resize-canvas)))) +(add-event-listener! (current-document) "keydown" + (procedure->external on-key-down)) +(add-event-listener! (current-document) "keyup" + (procedure->external on-key-up)) +(resize-canvas) +(request-animation-frame draw-callback) + +(timeout update-callback dt) -- cgit v1.2.3