summaryrefslogtreecommitdiff
path: root/game.scm
diff options
context:
space:
mode:
Diffstat (limited to 'game.scm')
-rw-r--r--game.scm2037
1 files changed, 1004 insertions, 1033 deletions
diff --git a/game.scm b/game.scm
index 6c7343a..23618c2 100644
--- a/game.scm
+++ b/game.scm
@@ -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)))))