diff options
| author | David Thompson <dthompson2@worcester.edu> | 2024-04-10 14:49:03 -0400 |
|---|---|---|
| committer | David Thompson <dthompson2@worcester.edu> | 2024-04-10 14:49:03 -0400 |
| commit | 6696a0b5fcb1b17895285d80d9636defb2df3f9d (patch) | |
| tree | 2cce306afcd7776925f725a382ae1a834513636c | |
| parent | 20b4e7c566cd268f8fafd3e2d3846513e31949e7 (diff) | |
Sloppily refactor into modules.
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile | 30 | ||||
| -rw-r--r-- | compile-map.scm | 14 | ||||
| -rw-r--r-- | game.scm | 3243 | ||||
| -rw-r--r-- | strigoform/assets.scm | 55 | ||||
| -rw-r--r-- | strigoform/audio.scm | 55 | ||||
| -rw-r--r-- | strigoform/bullets.scm | 106 | ||||
| -rw-r--r-- | strigoform/canvas.scm | 48 | ||||
| -rw-r--r-- | strigoform/document.scm | 24 | ||||
| -rw-r--r-- | strigoform/element.scm | 52 | ||||
| -rw-r--r-- | strigoform/enemies.scm | 241 | ||||
| -rw-r--r-- | strigoform/event.scm | 12 | ||||
| -rw-r--r-- | strigoform/game-area.scm | 15 | ||||
| -rw-r--r-- | strigoform/image.scm | 8 | ||||
| -rw-r--r-- | strigoform/level.scm | 129 | ||||
| -rw-r--r-- | strigoform/math.scm | 144 | ||||
| -rw-r--r-- | strigoform/particles.scm | 113 | ||||
| -rw-r--r-- | strigoform/scripts.scm | 147 | ||||
| -rw-r--r-- | strigoform/time.scm | 11 | ||||
| -rw-r--r-- | strigoform/type.scm | 34 | ||||
| -rw-r--r-- | strigoform/window.scm | 24 |
21 files changed, 2456 insertions, 2050 deletions
@@ -1,3 +1,4 @@ /game.wasm /level.scm /strigoform.zip +/strigoform/level-1.scm @@ -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")))))) @@ -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)) |