diff options
Diffstat (limited to 'game.scm')
| -rw-r--r-- | game.scm | 2037 |
1 files changed, 1004 insertions, 1033 deletions
@@ -1,1077 +1,1048 @@ -(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) +(use-modules (hoot compile) + (ice-9 binary-ports) + (wasm assemble)) - (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 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 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 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 prevent-default! - "event" "preventDefault" - (ref extern) -> none) - (define-foreign keyboard-event-code - "event" "keyboardCode" - (ref extern) -> (ref string)) + (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 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 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 prevent-default! + "event" "preventDefault" + (ref extern) -> none) + (define-foreign keyboard-event-code + "event" "keyboardCode" + (ref extern) -> (ref string)) - (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 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-image - "image" "new" - (ref string) -> (ref extern)) + (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-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-foreign load-image + "image" "new" + (ref string) -> (ref extern)) - ;; TODO: Add basic fmod as inline wasm function + (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)))))) + ...)) - ;; 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 (and (number? x) (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 (exact-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)) + ;; TODO: Add basic fmod as inline wasm function - (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!) + ;; 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 (and (number? x) (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 (exact-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 pi (* 4.0 (atan 1.0))) - (define pi/2 (/ pi 2.0)) - (define tau (* pi 2.0)) + (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 (clamp x min max) - (cond ((< x min) min) - ((> x max) max) - (else x))) + (define pi (* 4.0 (atan 1.0))) + (define pi/2 (/ pi 2.0)) + (define tau (* pi 2.0)) - (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 (clamp x min max) + (cond ((< x min) min) + ((> x max) max) + (else x))) - (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-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 (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)))) + (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)) - ;; 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 (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)))) - ;; Screen size stuff - (define game-width 240.0) - (define game-height 320.0) + ;; 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))))))) - ;; Elements - (define canvas (get-element-by-id "canvas")) - (define context (get-context canvas "2d")) - (define image:background (load-image "images/background.png")) - (define image:player (load-image "images/player.png")) - (define image:player-bullet (load-image "images/player-bullet.png")) - (define image:enemy-bullets (load-image "images/enemy-bullets.png")) - (define image:map (load-image "images/map.png")) - (define image:enemies (load-image "images/enemies.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")) + ;; intro, play, game-over, game-won + (define *game-state* 'play) - ;; 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-type script - %make-script - script? - (state script-state set-script-state!) - (cont script-cont set-script-cont!)) - (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)) - (define (script-run! script) - (define (run thunk) - (unless (script-cancelled? script) - (call-with-prompt %script-tag thunk handler))) - (define (handler k delay) - (when delay - (scheduler-add! *scheduler* (lambda () (run k)) delay))) - (when (script-pending? script) - (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)) + ;; Screen size stuff + (define game-width 240.0) + (define game-height 320.0) - ;; Bullets: - (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!) - (bullets bullet-pool-bullets set-bullet-pool-bullets!)) - ;; per bullet: type, x, y, dx, dy - (define %bullet-size (+ 4 8 8 8 8)) - (define (make-bullet-pool capacity) - (let ((bullets (make-bytevector (* capacity %bullet-size)))) - (%make-bullet-pool 0 capacity bullets))) - (define (bullet-pool-offset i) - (* i %bullet-size)) - (define (bullet-pool-add! pool type x y dx dy) - (match pool - (#('bullet-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) - (set-bullet-pool-length! pool (+ length 1)))))) - (define (bullet-pool-remove! pool i) - (match pool - (#('bullet-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)) - (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 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 - (#('bullet-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)))))) + ;; Elements + (define canvas (get-element-by-id "canvas")) + (define context (get-context canvas "2d")) + (define image:background (load-image "images/background.png")) + (define image:player (load-image "images/player.png")) + (define image:player-bullet (load-image "images/player-bullet.png")) + (define image:enemy-bullets (load-image "images/enemy-bullets.png")) + (define image:map (load-image "images/map.png")) + (define image:enemies (load-image "images/enemies.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 player-bullets (make-bullet-pool 200)) - (define enemy-bullets (make-bullet-pool 400)) + ;; 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-type script + %make-script + script? + (state script-state set-script-state!) + (cont script-cont set-script-cont!)) + (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)) + (define (script-run! script) + (define (run thunk) + (unless (script-cancelled? script) + (call-with-prompt %script-tag thunk handler))) + (define (handler k delay) + (when delay + (scheduler-add! *scheduler* (lambda () (run k)) delay))) + (when (script-pending? script) + (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)) - ;; Scrolling level: - (define *scroll* 0.0) - (define *scroll-speed* 0.5) - (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 - %make-level - level? - (height level-height set-level-height!) - (tiles level-tiles set-level-tiles!)) - (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 - ('X 0.0) - ('\ 1.0) - ('/ 2.0) - (_ -1.0))) - (action (match t - ('A 1) - (_ 0))) - (offset (* (+ x (* y level-width)) %tile-size))) - (s32-set! bv offset action) - (f64-set! bv (+ offset 4) n) - (f64-set! bv (+ offset 12) - (* (inexact x) tile-width)) - (f64-set! bv (+ offset 20) - (* (inexact y) tile-height))) - (x-loop rest (+ x 1)))) - tiles)) - (+ y 1))))) - (%make-level (/ 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 A _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ A X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X A _ _ _ _ _ _ _ _ X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X _ _ _ _ _ _ _ _ A X X X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X _ _ _ _ _ _ _ _ _ _ _ _ _ X - X X _ _ _ _ _ _ _ _ _ _ _ X X - X X X A _ _ _ _ _ _ _ _ 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 - (#('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 - (#('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) 4)) 0.0))) - (or (occupied? tx0 ty0) - (occupied? tx1 ty0) - (occupied? tx1 ty1) - (occupied? tx0 ty1)))))) - (define (draw-tiles level) - (match level - (#('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-offset x y)) - (t (f64-ref tiles (+ offset 4))) - (tx (f64-ref tiles (+ offset 12))) - (ty (f64-ref tiles (+ offset 20)))) - (draw-image context image:map - (* t tw) 0.0 tw th - tx (- ty pixel-y-offset) tw th)))))))) - (define max-scroll (- (* (level-height level) tile-height) game-height)) - (define (level-update! level) - (match level - (#('level height tiles) - (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) - (set! *scroll* scroll) - (let ((row (max (- (trunc - (/ (- (* height tile-height) - game-height scroll) - tile-height)) 2) - 0))) - (do ((y row (+ y 1))) - ((= y *last-row-scanned*)) - (do ((x 0 (+ x 1))) - ((= x level-width)) - (case (s32-ref tiles (level-offset x y)) - ((0) #t) - ((1) - (spawn-enemy-a (+ (* x tile-width) - (/ tile-width 2.0)) - (+ (* (- row y 3) tile-height) - (/ tile-height 2.0))))))) - (set! *last-row-scanned* row)))))) + ;; Bullets: + (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!) + (bullets bullet-pool-bullets set-bullet-pool-bullets!)) + ;; per bullet: type, x, y, dx, dy + (define %bullet-size (+ 4 8 8 8 8)) + (define (make-bullet-pool capacity) + (let ((bullets (make-bytevector (* capacity %bullet-size)))) + (%make-bullet-pool 0 capacity bullets))) + (define (bullet-pool-offset i) + (* i %bullet-size)) + (define (bullet-pool-add! pool type x y dx dy) + (match pool + (#('bullet-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) + (set-bullet-pool-length! pool (+ length 1)))))) + (define (bullet-pool-remove! pool i) + (match pool + (#('bullet-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)) + (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 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 + (#('bullet-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)))))) - ;; 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!) - (stationary? enemy-stationary? set-enemy-stationary!) - (velocity enemy-velocity set-enemy-velocity!) - (script enemy-script set-enemy-script!)) - (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 (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 stationary? velocity _) - (if stationary? - (set-vec2-y! position (+ (vec2-y position) *scroll-speed*)) - (begin - (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity))) - (set-vec2-y! position (+ (vec2-y position) (vec2-y velocity)))))))) - (define (enemy-draw enemy) - (match enemy - (#('enemy type _ position size _ _ _) - (let* ((t 0.0) - (x (vec2-x position)) - (y (vec2-y position)) - (hbw (vec2-x size)) - (hbh (vec2-y size)) - (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 player-bullets (make-bullet-pool 200)) + (define enemy-bullets (make-bullet-pool 400)) - (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)) - (sound-effect-play sound:explosion) - (enemy-pool-remove! pool i) - (loop i (- k 1))) - (else - (loop (+ i 1) k)))))))))) - (define (draw-enemies pool) - (match pool - (#('enemy-pool length capacity enemies) - (do ((i 0 (+ i 1))) - ((= i length)) - (enemy-draw (vector-ref enemies i)))))) - (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))))))))) + ;; Scrolling level: + (define *scroll* 0.0) + (define *scroll-speed* 0.5) + (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!)) + (define-type level + make-level + level? + (height level-height set-level-height!) + (foreground level-foreground set-level-foreground!) + (background level-background set-level-background!) + (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 background collision objects) + (let ((tx (trunc (/ x tile-width))) + (ty (trunc (/ 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 background collision objects) + (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) + (= (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 (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)) + (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 background collision objects) + (draw-level-layer level foreground 1.0)))) + (define (draw-level-background level) + (match level + (#('level height foreground background collision objects) + (draw-level-layer level background 0.75)))) + (define max-scroll (- (* (level-height level) tile-height) game-height)) + (define (level-update! level) + (match level + (#('level height foreground background collision objects) + (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll))) + (set! *scroll* scroll) + (let ((row (max (- (trunc + (/ (- (* height tile-height) + game-height scroll) + tile-height)) 2) + 0))) + (do ((y row (+ y 1))) + ((= y *last-row-scanned*)) + (for-each (lambda (obj) + (match obj + (#('level-object x type) + (match type + ('enemy-a + (spawn-enemy-a (+ (* x tile-width) + (/ tile-width 2.0)) + (+ (* (- y row 3) tile-height) + (/ tile-height 2.0)))) + (_ #t))))) + (vector-ref objects y))) + (set! *last-row-scanned* row)))))) - (define enemies (make-enemy-pool 64)) + ;; 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!) + (stationary? enemy-stationary? set-enemy-stationary!) + (velocity enemy-velocity set-enemy-velocity!) + (script enemy-script set-enemy-script!)) + (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 (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 stationary? velocity _) + (if stationary? + (set-vec2-y! position (+ (vec2-y position) *scroll-speed*)) + (begin + (set-vec2-x! position (+ (vec2-x position) (vec2-x velocity))) + (set-vec2-y! position (+ (vec2-y position) (vec2-y velocity)))))))) + (define (enemy-draw enemy) + (match enemy + (#('enemy type _ position size _ _ _) + (let* ((t 0.0) + (x (vec2-x position)) + (y (vec2-y position)) + (hbw (vec2-x size)) + (hbh (vec2-y size)) + (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-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)) + (sound-effect-play sound:explosion) + (enemy-pool-remove! pool i) + (loop i (- k 1))) + (else + (loop (+ i 1) k)))))))))) + (define (draw-enemies pool) + (match pool + (#('enemy-pool length capacity enemies) + (do ((i 0 (+ i 1))) + ((= i length)) + (enemy-draw (vector-ref enemies i)))))) + (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 (spawn-enemy-a x y) - (define (script enemy) - (let ((speed 2.0)) - (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) - (* (vec2-x v) speed) - (* (vec2-y v) speed))) - (wait 30) - (loop (+ theta 0.2))))) - (let ((enemy (make-enemy 'foo 20 (vec2 x y) (vec2 16.0 16.0) - #t (vec2 0.0 0.0) script))) - (enemy-pool-add! enemies enemy))) + (define enemies (make-enemy-pool 64)) - ;; 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-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 (direction-to-player v) - (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) - (vec2-sub! v* v) - (vec2-normalize! v*) - v*)) + (define (spawn-enemy-a x y) + (define (script enemy) + (let ((speed 2.0)) + (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) + (* (vec2-x v) speed) + (* (vec2-y v) speed))) + (wait 30) + (loop (+ theta 0.2))))) + (let ((enemy (make-enemy 'foo 20 (vec2 x y) (vec2 16.0 16.0) + #t (vec2 0.0 0.0) script))) + (enemy-pool-add! enemies enemy))) - (define *canvas-scale* 0.0) - (define *canvas-width* 0) - (define *canvas-height* 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-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.2) + (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 (direction-to-player v) + (let ((v* (vec2 (vec2-x player-position) (vec2-y player-position)))) + (vec2-sub! v* v) + (vec2-normalize! v*) + v*)) - (define (resize-canvas) - (let* ((win (current-window)) - (w (window-inner-width win)) - (h (window-inner-height win)) - (gw (trunc game-width)) - (gh (trunc 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*)))) + ;; 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 (trunc game-width)) + (gh (trunc 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 (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-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-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 - 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-background image parallax) + (let ((scroll (remainder (* *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 strings every frame when the UI values rarely - ;; change. - (set-fill-color! context "#ffffff") - (set-font! context "bold 8px monospace") - (fill-text context (string-append "x" (number->string *player-lives*)) - (- game-width 16.0) y) - ;; TODO: Add scoring. - (fill-text context (string-append "score " (number->string 0)) - 4.0 y))) + (define (draw-hud) + (let ((y (- game-height 8.0))) + ;; TODO: Don't strings every frame when the UI values rarely + ;; change. + (set-fill-color! context "#ffffff") + (set-font! context "bold 8px monospace") + (set-text-align! context "right") + (fill-text context (string-append "x" (number->string *player-lives*)) + (- game-width 4.0) y) + ;; TODO: Add scoring. + (set-text-align! context "left") + (fill-text context (string-append "score " (number->string 0)) + 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 "#3f2832") - (fill-rect context 0.0 0.0 game-width game-height) - (draw-background image:background 0.75) - (draw-tiles level) - (draw-player-bullets) - (draw-enemies enemies) - (draw-player) - (draw-enemy-bullets) - (draw-hud) - (request-animation-frame draw)) + (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-level-background level) + (draw-background image:background 0.75) + (draw-level-foreground level) + (draw-player-bullets) + (draw-enemies enemies) + (draw-player) + (draw-enemy-bullets) + (draw-hud) + (match *game-state* + ('game-over + (set-fill-color! context "#ffffff") + (set-font! context "bold 24px monospace") + (set-text-align! context "center") + (fill-text context "GAME OVER" (/ game-width 2.0) (/ game-height 2.0))) + (_ #t)) + (request-animation-frame draw)) - (define (reset!) - (scheduler-reset! *scheduler*) - (set! *scroll* 0.0) - (set! *last-row-scanned* (level-height level)) - (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 (reset!) + (set! *game-state* 'play) + (scheduler-reset! *scheduler*) + (set! *scroll* 0.0) + (set! *last-row-scanned* (level-height level)) + (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) - (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 "KeyR") - (reset!) - (prevent-default! event))))) + (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 "KeyR") + (reset!) + (prevent-default! event))) + (match *game-state* + ('game-over + (cond + ((string-=? code "Enter") + (reset!) + (prevent-default! event)))) + (_ #t)))) - (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))))) + (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))))) - (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 (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 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 (find-enemy enemies x y w h))) - (and enemy + (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 (find-enemy enemies x y w h))) + (and enemy + (begin + (enemy-damage! enemy 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) + (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.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 - (enemy-damage! enemy 1) - #t)))))) + (player-die!) + #t) + #f)))) - (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) - (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.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 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) + (when (game-over?) + (set! *game-state* 'game-over))) + (_ #t)) + (timeout update dt)) - (define dt (/ 1000.0 60.0)) - (define (update) - (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) - (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))) - (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))))) |