diff options
Diffstat (limited to 'strigoform')
| -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 |
17 files changed, 1218 insertions, 0 deletions
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)) |