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