(use-modules (hoot compile) (ice-9 binary-ports) (wasm assemble)) (define src `(let () ;; Host imports (define-foreign current-window "window" "get" -> (ref extern)) (define-foreign window-inner-width "window" "innerWidth" (ref extern) -> i32) (define-foreign window-inner-height "window" "innerHeight" (ref extern) -> i32) (define-foreign request-animation-frame "window" "requestAnimationFrame" (ref eq) -> none) (define-foreign timeout "window" "setTimeout" (ref eq) f64 -> i32) (define-foreign current-document "document" "get" -> (ref extern)) (define-foreign document-body "document" "body" -> (ref extern)) (define-foreign get-element-by-id "document" "getElementById" (ref string) -> (ref null extern)) (define-foreign make-text-node "document" "createTextNode" (ref string) -> (ref extern)) (define-foreign make-element "document" "createElement" (ref string) -> (ref extern)) (define-foreign element-value "element" "value" (ref extern) -> (ref string)) (define-foreign set-element-value! "element" "setValue" (ref extern) (ref string) -> none) (define-foreign set-element-width! "element" "setWidth" (ref extern) i32 -> none) (define-foreign set-element-height! "element" "setHeight" (ref extern) i32 -> none) (define-foreign append-child! "element" "appendChild" (ref extern) (ref extern) -> (ref extern)) (define-foreign remove! "element" "remove" (ref extern) -> none) (define-foreign replace-with! "element" "replaceWith" (ref extern) (ref extern) -> none) (define-foreign set-attribute! "element" "setAttribute" (ref extern) (ref string) (ref string) -> none) (define-foreign remove-attribute! "element" "removeAttribute" (ref extern) (ref string) -> none) (define-foreign add-event-listener! "element" "addEventListener" (ref extern) (ref string) (ref eq) -> none) (define-foreign remove-event-listener! "element" "removeEventListener" (ref extern) (ref string) (ref eq) -> none) (define-foreign clone-element "element" "clone" (ref extern) -> (ref extern)) (define-foreign prevent-default! "event" "preventDefault" (ref extern) -> none) (define-foreign keyboard-event-code "event" "keyboardCode" (ref extern) -> (ref string)) (define-foreign get-context "canvas" "getContext" (ref extern) (ref string) -> (ref extern)) (define-foreign set-fill-color! "canvas" "setFillColor" (ref extern) (ref string) -> none) (define-foreign set-font! "canvas" "setFont" (ref extern) (ref string) -> none) (define-foreign set-text-align! "canvas" "setTextAlign" (ref extern) (ref string) -> none) (define-foreign clear-rect "canvas" "clearRect" (ref extern) f64 f64 f64 f64 -> none) (define-foreign fill-rect "canvas" "fillRect" (ref extern) f64 f64 f64 f64 -> none) (define-foreign fill-text "canvas" "fillText" (ref extern) (ref string) f64 f64 -> none) (define-foreign draw-image "canvas" "drawImage" (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none) (define-foreign set-scale! "canvas" "setScale" (ref extern) f64 f64 -> none) (define-foreign set-transform! "canvas" "setTransform" (ref extern) f64 f64 f64 f64 f64 f64 -> none) (define-foreign set-image-smoothing-enabled! "canvas" "setImageSmoothingEnabled" (ref extern) i32 -> none) (define-foreign load-audio "audio" "new" (ref string) -> (ref extern)) (define-foreign audio-play "audio" "play" (ref extern) -> none) (define-foreign audio-volume "audio" "volume" (ref extern) -> f64) (define-foreign set-audio-volume! "audio" "setVolume" (ref extern) f64 -> none) (define-foreign load-image "image" "new" (ref string) -> (ref 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 (1+ (- (length '(field ...)) (length (memq 'field '(field ...))))))) (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 (truncate x) (assert-float x) (%inline-wasm '(func (param $x (ref eq)) (result (ref eq)) (call $s64->scm (i64.trunc_f64_s (struct.get $flonum $val (ref.cast $flonum (local.get $x)))))) x)) (define (fmod x y) (assert-float x) (assert-float y) (%inline-wasm '(func (param $x (ref eq)) (param $y (ref eq)) (result (ref eq)) (struct.new $flonum (i32.const 0) (f64.sub (struct.get $flonum $val (ref.cast $flonum (local.get $x))) (f64.mul (f64.trunc (f64.div (struct.get $flonum $val (ref.cast $flonum (local.get $x))) (struct.get $flonum $val (ref.cast $flonum (local.get $y))))) (struct.get $flonum $val (ref.cast $flonum (local.get $y))))))) x 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-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))))))) ;; intro, play, paused, game-over, game-win (define *game-state* 'play) ;; 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: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 *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-script (make-parameter #f)) (define %script-tag (make-prompt-tag "script")) (define-type script %make-script script? (state script-state set-script-state!) (cont script-cont set-script-cont!) (children script-children set-script-children!)) (define (make-script thunk) (%make-script '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 (run thunk) (unless (script-cancelled? script) (call-with-prompt %script-tag (lambda () (parameterize ((current-script script)) (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) (let ((speed 1.0)) (sound-effect-play sound:explosion) (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 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))) (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 (truncate (/ x tile-width))) (ty (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 (truncate (/ x tile-width))) (ty0 (truncate (/ y tile-height))) (tx1 (truncate (/ (+ x w) tile-width))) (ty1 (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 (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)) ('flyer0 (spawn-flyer0 x y)) ('flyer1 (spawn-flyer1 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)))) (_ #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 (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 (inexact (current-jiffy)) animation image image-size)) (define (enemy-x enemy) (vec2-x (enemy-position enemy))) (define (enemy-y enemy) (vec2-y (enemy-position enemy))) (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 250.0)) (match enemy (#('enemy type _ position size _ _ _ spawn-time animation image image-size) (let* ((tx (vector-ref animation (modulo (truncate (fmod (- 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) (explode (enemy-x enemy) (enemy-y enemy)) (set! *player-score* (+ *player-score* (enemy-points enemy)))) (when (eq? (enemy-type enemy) 'boss) (run-script (lambda () (wait 60) (set! *game-state* 'game-win)))) (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-turret* x y script) (spawn-enemy (make-enemy 'turret 10 (vec2 x y) (vec2 12.0 12.0) (vec2 0.0 0.0) script 100 #(0.0 0.0 0.0 0.0) image:turret (vec2 32.0 32.0)))) (define (spawn-popcorn* x y script) (spawn-enemy (make-enemy 'popcorn 1 (vec2 x y) (vec2 12.0 12.0) (vec2 0.0 0.0) script 100 #(0.0 0.0 0.0 0.0) image:popcorn (vec2 32.0 32.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 100 #(0.0 0.0 0.0 0.0) image:flyer0 (vec2 32.0 32.0)))) (define (spawn-flyer1* x y script) (spawn-enemy (make-enemy 'flyer1 10 (vec2 x y) (vec2 16.0 16.0) (vec2 0.0 0.0) script 100 #(0.0 0.0 0.0 0.0) image:flyer1 (vec2 32.0 32.0)))) (define (spawn-turret x y) (define (script enemy) (let ((speed 2.0)) (wait 60) (let loop ((theta 0.0)) (let ((dx (* (cos theta) speed)) (dy (* (sin theta) speed)) (v (direction-to-player (enemy-position enemy)))) (bullet-pool-add! enemy-bullets 0 (enemy-x enemy) (enemy-y enemy) 2.0 2.0 (* (vec2-x v) speed) (* (vec2-y v) speed))) (wait 30) (loop (+ theta 0.2))))) (spawn-turret* x y script)) (define (spawn-popcorn x y) (spawn-popcorn* x y #f)) (define (spawn-flyer0 x y) (define (script flyer) (run-script (lambda () (let ((speed 1.0)) (forever (do-circle (lambda (theta) (bullet-pool-add! enemy-bullets 0 (enemy-x flyer) (enemy-y flyer) 2.0 2.0 (* (cos theta) speed) (* (sin theta) speed)) (wait 5)) 16))))) (forever (set-enemy-dx! flyer 0.5) (wait 60) (set-enemy-dx! flyer -0.5) (wait 60))) (spawn-flyer0* x y script)) (define (spawn-flyer1 x y) (spawn-flyer1* x y #f)) (define (spawn-boss x y) (spawn-enemy (make-enemy 'boss 300 (vec2 x y) (vec2 100.0 40.0) (vec2 0.0 0.0) #f 1000000 #(0.0 0.0 0.0 0.0) image:boss (vec2 120.0 80.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-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) ;; 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))))) (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 (player-die!) (unless *player-invincible?* (sound-effect-play sound:player-death 0.5) (set! *player-lives* (max (- *player-lives* 1) 0)) (player-position-reset!) (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 (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) (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) (draw-image context image:player (if *player-visible?* 0.0 player-width) 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*)) ;; 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 (truncate game-width)) (gh (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 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 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) (draw-background image:starfield-bg 0.2) (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) (match *game-state* ('game-over (set-fill-color! context "#ffffff") (set-font! context "bold 36px monogram") (set-text-align! context "center") (fill-text context "GAME OVER" (/ game-width 2.0) (/ game-height 2.0))) ('game-win (set-fill-color! context "#ffffff") (set-font! context "bold 36px monogram") (set-text-align! context "center") (fill-text context "WELL DONE" (/ game-width 2.0) (/ game-height 2.0))) ('paused (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))) (_ #t)) (request-animation-frame draw)) (define (reset!) (set! *game-state* 'play) (scheduler-reset! *scheduler*) ;; (set! *scroll* 0.0) (set! *scroll* (* 250.0 tile-height)) (set! *last-scroll* 0.0) ;; (set! *last-row-scanned* (level-height level)) (set! *last-row-scanned* (- (level-height level) 250)) (bullet-pool-reset! player-bullets) (bullet-pool-reset! enemy-bullets) (enemy-pool-reset! enemies) (particle-pool-reset! particles) (player-position-reset!) (set! *player-lives* %default-lives) (set! *player-invincible?* #f) (set! *player-visible?* #t) (set! *player-fire-counter* 0) (set! *player-score* 0)) (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 "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 "ShiftLeft") (set-focusing! #f) (prevent-default! event)) (else (match *game-state* ('play (cond ((string-=? code "Enter") (set! *game-state* 'paused) (prevent-default! event)) ((string-=? code "KeyD") (set! *debug?* (not *debug?*)) (prevent-default! event)) ((string-=? code "KeyR") (reset!) (prevent-default! event)) ((string-=? code "KeyW") (set! *game-state* 'game-win) (prevent-default! event)))) ('paused (cond ((string-=? code "Enter") (set! *game-state* 'play) (prevent-default! event)))) ((or 'game-over 'game-win) (cond ((string-=? code "Enter") (reset!) (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) (+ game-height padding))))) (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?) (set! *game-state* 'game-over))) (_ #t)) (timeout update dt)) (add-event-listener! (current-window) "resize" (lambda (_) (resize-canvas))) (add-event-listener! (current-document) "keydown" on-key-down) (add-event-listener! (current-document) "keyup" on-key-up) (resize-canvas) (reset!) (request-animation-frame draw) (timeout update dt))) (call-with-output-file "game.wasm" (lambda (port) (put-bytevector port (assemble-wasm (compile src)))))