(let () ;; Host imports (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 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 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 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) ;; Hoot's exact and inexact aren't working right. These next two ;; procedures are alternatives for now. (define (trunc x) ;; rational? is also borked so can't use that here. (unless (inexact? x) (error "expected inexact rational" 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 (inexact x) (unless (and (exact? x) (integer? x)) (error "expected exact integer" x)) (%inline-wasm '(func (param $x (ref eq)) (result (ref eq)) (if (ref eq) (call $fixnum? (local.get $x)) (then (struct.new $flonum (i32.const 0) (f64.convert_i32_s (call $fixnum->i32 (ref.cast i31 (local.get $x)))))) (else (struct.new $flonum (i32.const 0) (f64.convert_i64_s (call $bignum-get-i64 (struct.get $bignum $val (ref.cast $bignum (local.get $x))))))))) x)) (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 (clamp x min max) (cond ((< x min) min) ((> x max) max) (else x))) (define (vec2 x y) (let ((v (make-bytevector 16))) (set-vec2-x! v x) (set-vec2-y! v y) v)) (define (vec2-x v) (f64-ref v 0)) (define (vec2-y v) (f64-ref v 8)) (define (set-vec2-x! v x) (f64-set! v 0 x)) (define (set-vec2-y! v y) (f64-set! 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-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))))))) (define demichrome0 "#211e20") (define demichrome1 "#555568") (define demichrome2 "#a0a08b") (define demichrome3 "#e9efec") ;; Screen size stuff (define game-width 240.0) (define game-height 320.0) (define canvas-scale 3.0) (define canvas-width (* game-width canvas-scale)) (define canvas-height (* game-height canvas-scale)) ;; Elements (define canvas (get-element-by-id "canvas")) (define context (get-context canvas "2d")) (define image:background (get-element-by-id "image-background")) (define image:player (get-element-by-id "image-player")) (define image:player-bullet (get-element-by-id "image-player-bullet")) (define image:enemy-bullets (get-element-by-id "image-enemy-bullets")) (define image:map (get-element-by-id "image-map")) (define image:enemies (get-element-by-id "image-enemies")) (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")) ;; 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 %script-tag (make-prompt-tag "script")) (define (run-script thunk) (define script (vector #f)) (define (cancelled?) (vector-ref script 0)) (define (run thunk) (unless (cancelled?) (call-with-prompt %script-tag thunk handler))) (define (handler k delay) (when delay (scheduler-add! *scheduler* (lambda () (run k)) delay))) (run (lambda () (thunk) ;; 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))) script) (define (cancel! script) (vector-set! script 0 #t)) (define (wait delay) (abort-to-prompt %script-tag delay)) ;; Bullets: ;; per bullet: type, x, y, dx, dy (define %bullet-size (+ 4 8 8 8 8)) (define (make-bullet-pool capacity) (let ((pool (make-bytevector (* capacity %bullet-size)))) (vector 0 capacity pool))) (define (bullet-pool-offset i) (* i %bullet-size)) (define (bullet-pool-add! pool type x y dx dy) (match pool (#(length capacity bullets) (let ((offset (bullet-pool-offset length))) (s32-set! bullets offset type) (f64-set! bullets (+ offset 4) x) (f64-set! bullets (+ offset 12) y) (f64-set! bullets (+ offset 20) dx) (f64-set! bullets (+ offset 28) dy) (vector-set! pool 0 (+ length 1)))))) (define (bullet-pool-remove! pool i) (match pool (#(length capacity 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)) (vector-set! pool 0 (- length 1))))))) (define (bullet-pool-reset! pool) (match pool (#(length capacity bullets) (vector-set! pool 0 0)))) (define (bullet-pool-update! pool collide) (match pool (#(length capacity bullets) (let loop ((i 0) (k length)) (when (< i k) (let* ((offset (bullet-pool-offset i)) (x (f64-ref bullets (+ offset 4))) (y (f64-ref bullets (+ offset 12))) (dx (f64-ref bullets (+ offset 20))) (dy (f64-ref bullets (+ offset 28))) (x* (+ x dx)) (y* (+ y dy))) (cond ;; TODO: different bullet hitbox sizes. ((collide x y 2.0 2.0) (bullet-pool-remove! pool i) (loop i (- k 1))) (else (f64-set! bullets (+ offset 4) x*) (f64-set! bullets (+ offset 12) y*) (loop (+ i 1) k))))))))) (define (draw-bullets pool image w h) (match pool (#(length capacity bullets) (do ((i 0 (+ i 1))) ((= i length)) (let* ((offset (bullet-pool-offset i)) (type (s32-ref bullets offset)) (x (f64-ref bullets (+ offset 4))) (y (f64-ref bullets (+ offset 12)))) (draw-image context image (* type w) (* type h) w h (- x (/ w 2.0)) (- y (/ w 2.0)) w h)))))) (define player-bullets (make-bullet-pool 200)) (define enemy-bullets (make-bullet-pool 400)) ;; Scrolling level: (define *scroll* 0.0) (define *scroll-speed* 0.5) (define (update-scroll!) (set! *scroll* (+ *scroll* *scroll-speed*))) ;; sprite sheet offset, x, y (define %tile-size (+ 8 8 8)) (define tile-width 16.0) (define tile-height 16.0) (define level-width 15) (define (make-level tiles) (let ((k (length tiles))) (unless (= (modulo k level-width) 0) (error "incomplete level data")) (let ((bv (make-bytevector (* k %tile-size)))) (let y-loop ((tiles tiles) (y 0)) (match tiles (() #t) (tiles (y-loop (let x-loop ((tiles tiles) (x 0)) (if (< x level-width) (match tiles ((t . rest) (let ((n (match t ('_ -1.0) ('X 0.0) ('\ 1.0) ('/ 2.0))) (offset (* (+ x (* y level-width)) %tile-size))) (f64-set! bv offset n) (f64-set! bv (+ offset 8) (* (inexact x) tile-width)) (f64-set! bv (+ offset 16) (* (inexact y) tile-height))) (x-loop rest (+ x 1)))) tiles)) (+ y 1))))) (vector (/ k level-width) bv)))) (define-syntax-rule (define-level name tile ...) (define name (make-level '(tile ...)))) (define-level level X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ X X X X X _ _ _ _ _ _ _ _ _ _ _ X X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ X X X _ _ _ _ _ X X _ _ _ _ _ X X X _ _ _ _ _ X X _ _ _ _ _ X X X _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X _ _ _ _ _ _ _ _ _ _ _ _ _ X X \ _ _ _ _ _ _ _ _ _ _ _ / X X X \ _ _ _ _ _ _ _ _ _ / X X X X X \ _ _ _ _ _ _ _ / X X X) (define (level-offset x y) (* (+ (* level-width y) x) %tile-size)) (define (point-collides-with-level? level x y) (match level (#(height tiles) (let ((tx (trunc (/ x tile-width))) (ty (trunc (/ y tile-height)))) (and (>= tx 0) (< tx level-width) (>= ty 0) (< tx height) (>= (f64-ref tiles (level-offset tx ty)) 0)))))) (define (rect-collides-with-level? level x y w h) (match level (#(height tiles) (let* ((y (+ y (- (* height tile-height) game-height *scroll*))) (tx0 (trunc (/ x tile-width))) (ty0 (trunc (/ y tile-height))) (tx1 (trunc (/ (+ x w) tile-width))) (ty1 (trunc (/ (+ y h) tile-height)))) (define (occupied? x y) (and (>= x 0) (< x level-width) (>= y 0) (< x height) (>= (f64-ref tiles (level-offset x y)) 0.0))) (or (occupied? tx0 ty0) (occupied? tx1 ty0) (occupied? tx1 ty1) (occupied? tx0 ty1)))))) (define (draw-tiles level) (match level (#(height tiles) (let* ((tw tile-width) (th tile-height) (pixel-y-offset (- (* height th) *scroll* game-height)) (scroll-y-offset (- height (trunc (/ *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)) (do ((x 0 (+ x 1))) ((= x level-width)) (let* ((offset (* (+ (* level-width y) x) %tile-size)) (t (f64-ref tiles offset)) (tx (f64-ref tiles (+ offset 8))) (ty (f64-ref tiles (+ offset 16)))) (draw-image context image:map (* t tw) 0.0 tw th tx (- ty pixel-y-offset) tw th)))))))) ;; Enemy pool: ;; length, capacity, enemies, scripts ;; enemy: type, health, x, y, w, h, dx, dy (define %enemy-size (+ 4 4 8 8 8 8 8 8)) (define (make-enemy-pool capacity) (let ((enemies (make-bytevector (* capacity %enemy-size)))) (vector 0 capacity enemies (make-vector capacity)))) (define (enemy-pool-offset i) (* i %enemy-size)) (define (enemy-pool-add! pool type hp x y w h dx dy script) (match pool (#(length capacity enemies scripts) (unless (= length capacity) (let ((offset (enemy-pool-offset length))) (s32-set! enemies offset type) (s32-set! enemies (+ offset 4) hp) (f64-set! enemies (+ offset 8) x) (f64-set! enemies (+ offset 16) y) (f64-set! enemies (+ offset 24) w) (f64-set! enemies (+ offset 32) h) (f64-set! enemies (+ offset 40) dx) (f64-set! enemies (+ offset 48) dy) (vector-set! scripts length (and script (run-script (lambda () (script length))))) (vector-set! pool 0 (+ length 1))))))) (define (enemy-pool-remove! pool i) (match pool (#(length capacity enemies scripts) (when (and (>= i 0) (< i length)) (let* ((j (- length 1)) (at (enemy-pool-offset i)) (start (enemy-pool-offset j))) (bytevector-copy! enemies at enemies start (+ start %enemy-size)) (let ((script (vector-ref scripts i))) (and script (cancel! script))) (vector-set! scripts i (vector-ref scripts j)) (vector-set! scripts j #f) (vector-set! pool 0 j)))))) (define (enemy-x pool i) (match pool (#(length capacity enemies scripts) (let ((offset (enemy-pool-offset i))) (f64-ref enemies (+ offset 8)))))) (define (enemy-y pool i) (match pool (#(length capacity enemies scripts) (let ((offset (enemy-pool-offset i))) (f64-ref enemies (+ offset 16)))))) (define (enemy-dx pool i) (match pool (#(length capacity enemies scripts) (let ((offset (enemy-pool-offset i))) (f64-ref enemies (+ offset 40)))))) (define (enemy-dy pool i) (match pool (#(length capacity enemies scripts) (let ((offset (enemy-pool-offset i))) (f64-ref enemies (+ offset 48)))))) (define (set-enemy-velocity! pool i dx dy) (match pool (#(length capacity enemies scripts) (let ((offset (enemy-pool-offset i))) (f64-set! enemies (+ offset 40) dx) (f64-set! enemies (+ offset 48) dy))))) (define (enemy-pool-reset! pool) (match pool (#(length capacity enemies scripts) (do ((i 0 (+ i 1))) ((= i length)) (let ((script (vector-ref scripts i))) (and script (cancel! script)) (vector-set! scripts i #f))) (vector-set! pool 0 0)))) (define (enemy-pool-update! pool collide) (match pool (#(length capacity enemies scripts) (let ((padding 16.0)) (let loop ((i 0) (k length)) (unless (= i k) (let* ((offset (enemy-pool-offset i)) (hp (s32-ref enemies (+ offset 4))) (x (f64-ref enemies (+ offset 8))) (y (f64-ref enemies (+ offset 16))) (w (f64-ref enemies (+ offset 24))) (h (f64-ref enemies (+ offset 32))) (dx (f64-ref enemies (+ offset 40))) (dy (f64-ref enemies (+ offset 48))) (x* (+ x dx)) (y* (+ y dy))) (let ((new-hp (collide x y w h hp))) (cond ((or (<= hp 0) (out-of-bounds? x* y* w h)) (sound-effect-play sound:explosion) (enemy-pool-remove! pool i) (loop i (- k 1))) (else (s32-set! enemies (+ offset 4) new-hp) (f64-set! enemies (+ offset 8) x*) (f64-set! enemies (+ offset 16) y*) (loop (+ i 1) k))))))))))) (define (draw-enemies pool) (match pool (#(length capacity enemies scripts) (do ((i 0 (+ i 1))) ((= i length)) (let* ((offset (enemy-pool-offset i)) (t (s32-ref enemies offset)) (x (f64-ref enemies (+ offset 8))) (y (f64-ref enemies (+ offset 16))) (hbw (f64-ref enemies (+ offset 24))) (hbh (f64-ref enemies (+ offset 32))) (w 64.0) (h 64.0)) (draw-image context image:enemies (* t w) (* t h) w h (- x (/ w 2.0)) (- y (/ h 2.0)) w h) (set-fill-color! context "#ff00ff80") (fill-rect context (- x (/ hbw 2.0)) (- y (/ hbh 2.0)) hbw hbh)))))) (define (find-enemy pool x y w h) (match pool (#(length capacity enemies scripts) (let loop ((i 0)) (and (< i length) (let* ((offset (enemy-pool-offset i)) (w* (f64-ref enemies (+ offset 24))) (h* (f64-ref enemies (+ offset 32))) (x* (- (f64-ref enemies (+ offset 8)) (/ w* 2.0))) (y* (- (f64-ref enemies (+ offset 16)) (/ h* 2.0)))) (if (rect-within? x y w h x* y* w* h*) i (loop (+ i 1))))))))) (define (damage-enemy! pool i damage) (match pool (#(length capacity enemies scripts) (when (and (>= i 0) (< i length)) (let* ((offset (enemy-pool-offset i)) (hp (s32-ref enemies (+ offset 4)))) (s32-set! enemies (+ offset 4) (- hp damage))))))) (define enemies (make-enemy-pool 64)) (enemy-pool-add! enemies 0 20 70.0 100.0 16.0 16.0 0.0 0.0 (lambda (id) (let ((speed 2.0)) (let loop ((theta 0.0)) (let ((dx (* (cos theta) speed)) (dy (* (sin theta) speed))) (bullet-pool-add! enemy-bullets 0 (enemy-x enemies id) (enemy-y enemies id) dx dy)) (wait 2) (loop (+ theta 0.2)))))) ;; 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 4.0) (define player-bullet-speed 12.0) (define player-width 24.0) (define player-height 24.0) (define *player-fire-counter* 0) (define player-fire-interval 3) (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) ;; left, right, down, up, fire (define key-state (vector #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 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 (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 (firing?) (vector-ref key-state 4)) (define (player-die!) (unless *player-invincible?* ;; (sound-effect-play sound:player-death) (set! *player-lives* (max (- *player-lives* 1) 0)) (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!) (vec2-add! player-position player-velocity) (vec2-clamp! player-position 0.0 0.0 game-width game-height) (set-vec2-x! player-hitbox-position (- (vec2-x player-position) (/ player-hitbox-width 2.0))) (set-vec2-y! player-hitbox-position (- (vec2-y player-position) (/ player-hitbox-height 2.0))) (when (and (let ((x (vec2-x player-hitbox-position)) (y (vec2-y player-hitbox-position)) (w player-hitbox-width) (h player-hitbox-height)) (or (rect-collides-with-level? level x y w h) (find-enemy enemies x y w h)))) (player-die!)) (when (firing?) (set! *player-fire-counter* (modulo (+ *player-fire-counter* 1) player-fire-interval)) (when (= *player-fire-counter* 0) (sound-effect-play sound:player-shoot 0.5) (bullet-pool-add! player-bullets 0 (- (vec2-x player-position) 6.0) (vec2-y player-position) 0.0 (- player-bullet-speed)) (bullet-pool-add! player-bullets 0 (+ (vec2-x player-position) 8.0) (vec2-y player-position) 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) (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 (clear-screen) (clear-rect context 0.0 0.0 canvas-width canvas-height)) (define (draw-player-bullets) (draw-bullets player-bullets image:player-bullet 8.0 8.0)) (define (draw-enemy-bullets) (draw-bullets enemy-bullets image:enemy-bullets 16.0 16.0)) (define (draw-background image parallax) (let ((scroll (remainder (* *scroll* parallax) game-height))) ;; Bottom (draw-image context image:background 0.0 0.0 game-width (- game-height scroll) 0.0 scroll game-width (- game-height scroll)) ;; Top (draw-image context image:background 0.0 (- game-height scroll) game-width scroll 0.0 0.0 game-width scroll) )) (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 "#3f2832") (fill-rect context 0.0 0.0 game-width game-height) (draw-background image:background 0.75) (draw-tiles level) ;; (draw-tiles level 0.0) (draw-player-bullets) (draw-enemies enemies) (draw-player) (draw-enemy-bullets) (request-animation-frame draw)) (define (reset!) (scheduler-reset! *scheduler*) (set! *scroll* 0.0) (bullet-pool-reset! player-bullets) (bullet-pool-reset! enemy-bullets) (enemy-pool-reset! enemies) (set-vec2-x! player-position (/ game-width 2.0)) (set-vec2-y! player-position (- game-height 12.0)) (set! *player-lives* %default-lives) (set! *player-invincible?* #f) (set! *player-visible?* #t) (set! *player-fire-counter* 0)) (define (on-key-down event) (let ((code (keyboard-event-code event))) (cond ((string-=? code "ArrowLeft") (set-left! #t)) ((string-=? code "ArrowRight") (set-right! #t)) ((string-=? code "ArrowDown") (set-down! #t)) ((string-=? code "ArrowUp") (set-up! #t)) ((string-=? code "KeyZ") (set-firing! #t)) ((string-=? code "KeyR") (reset!))))) (define (on-key-up event) (let ((code (keyboard-event-code event))) (cond ((string-=? code "ArrowLeft") (set-left! #f)) ((string-=? code "ArrowRight") (set-right! #f)) ((string-=? code "ArrowDown") (set-down! #f)) ((string-=? code "ArrowUp") (set-up! #f)) ((string-=? code "KeyZ") (set-firing! #f))))) (define (out-of-bounds? x y w h) (let ((padding 16.0)) (not (rect-within? x y w h (- padding) (- padding) (+ game-width padding) (+ game-height padding))))) (define (player-bullet-collide 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) (let ((enemy-id (find-enemy enemies x y w h))) (and enemy-id (begin (damage-enemy! enemies enemy-id 1) #t)))))) (define (enemy-bullet-collide x y w h) (let ((x* (- x (/ w 2.0))) (y* (- y(/ h 2.0)))) (or (out-of-bounds? x* y* w h) (if (rect-collides-with-level? level x* y* w h) (begin (sound-effect-play sound:bullet-hit 0.1) #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 (enemy-collide x y w h hp) hp) (define dt (/ 1000.0 60.0)) (define (update) (scheduler-tick! *scheduler*) (update-scroll!) (player-update!) (bullet-pool-update! player-bullets player-bullet-collide) (bullet-pool-update! enemy-bullets enemy-bullet-collide) (enemy-pool-update! enemies enemy-collide) (timeout update dt)) (set-element-width! canvas (trunc canvas-width)) (set-element-height! canvas (trunc canvas-height)) (add-event-listener! (current-document) "keydown" on-key-down) (add-event-listener! (current-document) "keyup" on-key-up) (set-image-smoothing-enabled! context 0) (request-animation-frame draw) (timeout update dt))