summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--boot.js103
-rw-r--r--game.scm527
-rw-r--r--images/2bit-demichrome.gpl8
-rw-r--r--images/chickadee.pngbin0 -> 755 bytes
-rw-r--r--images/endesga-16.gpl20
-rw-r--r--images/map.asebin0 -> 552 bytes
-rw-r--r--images/map.pngbin0 -> 237 bytes
-rw-r--r--images/player-bullet.asebin0 -> 296 bytes
-rw-r--r--images/player-bullet.pngbin0 -> 93 bytes
-rw-r--r--images/player.asebin0 -> 477 bytes
-rw-r--r--images/player.pngbin0 -> 195 bytes
-rw-r--r--index.html15
-rw-r--r--js-runtime/reflect.js543
-rw-r--r--js-runtime/reflect.wasmbin0 -> 4260 bytes
-rw-r--r--js-runtime/wtf8.wasmbin0 -> 1071 bytes
-rw-r--r--web-server.scm155
17 files changed, 1372 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..907c4d7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+/game.wasm
diff --git a/boot.js b/boot.js
new file mode 100644
index 0000000..161a4d9
--- /dev/null
+++ b/boot.js
@@ -0,0 +1,103 @@
+async function load() {
+ const procMap = new WeakMap();
+
+ function wrapProc(obj) {
+ function makeWrapper() {
+ const proc = scheme.to_js(obj);
+ function wrapper (...args) {
+ return proc.call(...args);
+ }
+ procMap.set(obj, wrapper);
+ return wrapper;
+ }
+
+ return procMap.get(obj) || makeWrapper();
+ }
+
+ const mod = await SchemeModule.fetch_and_instantiate("game.wasm", {}, {
+ window: {
+ requestAnimationFrame(proc) {
+ window.requestAnimationFrame(wrapProc(proc));
+ },
+ setTimeout(proc, delay) {
+ window.setTimeout(wrapProc(proc), delay);
+ }
+ },
+ document: {
+ get() { return document; },
+ body() { return document.body; },
+ getElementById: Document.prototype.getElementById.bind(document),
+ createTextNode: Document.prototype.createTextNode.bind(document),
+ createElement: Document.prototype.createElement.bind(document)
+ },
+ element: {
+ value(elem) {
+ return elem.value;
+ },
+ setValue(elem, value) {
+ elem.value = value;
+ },
+ setWidth(elem, width) {
+ elem.width = width;
+ },
+ setHeight(elem, height) {
+ elem.height = height;
+ },
+ appendChild(parent, child) {
+ return parent.appendChild(child);
+ },
+ setAttribute(elem, name, value) {
+ elem.setAttribute(name, value);
+ },
+ removeAttribute(elem, name) {
+ elem.removeAttribute(name);
+ },
+ remove(elem) {
+ elem.remove();
+ },
+ replaceWith(oldElem, newElem) {
+ oldElem.replaceWith(newElem);
+ },
+ addEventListener(elem, name, proc) {
+ elem.addEventListener(name, wrapProc(proc));
+ },
+ removeEventListener(elem, name, proc) {
+ elem.removeEventListener(name, wrapProc(proc));
+ }
+ },
+ event: {
+ keyboardCode(event) {
+ return event.code;
+ }
+ },
+ canvas: {
+ getContext(elem, type) {
+ return elem.getContext(type);
+ },
+ setFillColor(context, color) {
+ context.fillStyle = color;
+ },
+ clearRect(context, x, y, w, h) {
+ context.clearRect(x, y, w, h);
+ },
+ fillRect(context, x, y, w, h) {
+ context.fillRect(x, y, w, h);
+ },
+ drawImage(context, image, sx, sy, sWidth, sHeight, dx, dy, dWidth, dHeight) {
+ context.drawImage(image, sx, sy, sWidth, sHeight, dx, dy, dWidth, dHeight);
+ },
+ setScale(context, sx, sy) {
+ context.scale(sx, sy);
+ },
+ setTransform(context, a, b, c, d, e, f) {
+ context.setTransform(a, b, c, d, e, f);
+ },
+ setImageSmoothingEnabled(context, enabled) {
+ context.imageSmoothingEnabled = (enabled == 1);
+ }
+ }
+ });
+ const scheme = await mod.reflect();
+ scheme.init_module(mod);
+}
+window.addEventListener("load", load);
diff --git a/game.scm b/game.scm
new file mode 100644
index 0000000..d84cdfa
--- /dev/null
+++ b/game.scm
@@ -0,0 +1,527 @@
+(let ()
+ (define-foreign request-animation-frame
+ "window" "requestAnimationFrame"
+ (ref eq) -> none)
+
+ (define-foreign timeout
+ "window" "setTimeout"
+ (ref eq) f64 -> i32)
+
+ (define-foreign current-document
+ "document" "get"
+ -> (ref extern))
+
+ (define-foreign document-body
+ "document" "body"
+ -> (ref extern))
+
+ (define-foreign get-element-by-id
+ "document" "getElementById"
+ (ref string) -> (ref null extern))
+
+ (define-foreign make-text-node
+ "document" "createTextNode"
+ (ref string) -> (ref extern))
+
+ (define-foreign make-element
+ "document" "createElement"
+ (ref string) -> (ref extern))
+
+ (define-foreign element-value
+ "element" "value"
+ (ref extern) -> (ref string))
+
+ (define-foreign set-element-value!
+ "element" "setValue"
+ (ref extern) (ref string) -> none)
+
+ (define-foreign set-element-width!
+ "element" "setWidth"
+ (ref extern) i32 -> none)
+
+ (define-foreign set-element-height!
+ "element" "setHeight"
+ (ref extern) i32 -> none)
+
+ (define-foreign append-child!
+ "element" "appendChild"
+ (ref extern) (ref extern) -> (ref extern))
+
+ (define-foreign remove!
+ "element" "remove"
+ (ref extern) -> none)
+
+ (define-foreign replace-with!
+ "element" "replaceWith"
+ (ref extern) (ref extern) -> none)
+
+ (define-foreign set-attribute!
+ "element" "setAttribute"
+ (ref extern) (ref string) (ref string) -> none)
+
+ (define-foreign remove-attribute!
+ "element" "removeAttribute"
+ (ref extern) (ref string) -> none)
+
+ (define-foreign add-event-listener!
+ "element" "addEventListener"
+ (ref extern) (ref string) (ref eq) -> none)
+
+ (define-foreign remove-event-listener!
+ "element" "removeEventListener"
+ (ref extern) (ref string) (ref eq) -> none)
+
+ (define-foreign keyboard-event-code
+ "event" "keyboardCode"
+ (ref extern) -> (ref string))
+
+ (define-foreign get-context
+ "canvas" "getContext"
+ (ref extern) (ref string) -> (ref extern))
+
+ (define-foreign set-fill-color!
+ "canvas" "setFillColor"
+ (ref extern) (ref string) -> none)
+
+ (define-foreign clear-rect
+ "canvas" "clearRect"
+ (ref extern) f64 f64 f64 f64 -> none)
+
+ (define-foreign fill-rect
+ "canvas" "fillRect"
+ (ref extern) f64 f64 f64 f64 -> none)
+
+ (define-foreign draw-image
+ "canvas" "drawImage"
+ (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
+
+ (define-foreign set-scale!
+ "canvas" "setScale"
+ (ref extern) f64 f64 -> none)
+
+ (define-foreign set-transform!
+ "canvas" "setTransform"
+ (ref extern) f64 f64 f64 f64 f64 f64 -> none)
+
+ (define-foreign set-image-smoothing-enabled!
+ "canvas" "setImageSmoothingEnabled"
+ (ref extern) i32 -> none)
+
+ ;; Hoot's exact and inexact aren't working right. These next two
+ ;; procedures are alternatives for now.
+ (define (trunc x)
+ ;; rational? is also borked so can't use that here.
+ (unless (inexact? x)
+ (error "expected inexact rational" x))
+ (%inline-wasm
+ '(func (param $x (ref eq)) (result (ref eq))
+ (call $s64->scm
+ (i64.trunc_f64_s
+ (struct.get $flonum $val (ref.cast $flonum (local.get $x))))))
+ x))
+ (define (inexact x)
+ (unless (and (exact? x) (integer? x))
+ (error "expected exact integer" x))
+ (%inline-wasm
+ '(func (param $x (ref eq)) (result (ref eq))
+ (if (ref eq)
+ (call $fixnum? (local.get $x))
+ (then
+ (struct.new $flonum
+ (i32.const 0)
+ (f64.convert_i32_s
+ (call $fixnum->i32 (ref.cast i31 (local.get $x))))))
+ (else
+ (struct.new $flonum
+ (i32.const 0)
+ (f64.convert_i64_s
+ (call $bignum-get-i64
+ (struct.get $bignum $val
+ (ref.cast $bignum (local.get $x)))))))))
+ x))
+
+ (define pi (* 4.0 (atan 1.0)))
+ (define pi/2 (/ pi 2.0))
+ (define tau (* pi 2.0))
+
+ (define (clamp x min max)
+ (cond ((< x min) min)
+ ((> x max) max)
+ (else x)))
+
+ (define (vec2 x y)
+ (let ((v (make-bytevector 16)))
+ (set-vec2-x! v x)
+ (set-vec2-y! v y)
+ v))
+ (define (vec2-x v)
+ (bytevector-ieee-double-native-ref v 0))
+ (define (vec2-y v)
+ (bytevector-ieee-double-native-ref v 8))
+ (define (set-vec2-x! v x)
+ (bytevector-ieee-double-native-set! v 0 x))
+ (define (set-vec2-y! v y)
+ (bytevector-ieee-double-native-set! 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-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))))
+ (bytevector-ieee-double-native-set! r 0 x)
+ (bytevector-ieee-double-native-set! r 8 y)
+ (bytevector-ieee-double-native-set! r 16 w)
+ (bytevector-ieee-double-native-set! r 24 h)
+ r))
+ (define (rect-x r)
+ (bytevector-ieee-double-native-ref r 0))
+ (define (rect-y r)
+ (bytevector-ieee-double-native-ref r 8))
+ (define (rect-w r)
+ (bytevector-ieee-double-native-ref r 16))
+ (define (rect-h r)
+ (bytevector-ieee-double-native-ref r 24))
+
+ (define (within? x y rx ry rw rh)
+ (and (>= x rx)
+ (>= y ry)
+ (<= x (+ rx rw))
+ (<= y (+ ry rh))))
+ (define (vec2-within-rect? v r)
+ (within? (vec2-x v) (vec2-y v)
+ (rect-x r) (rect-y r) (rect-w r) (rect-h r)))
+
+ (define demichrome0 "#211e20")
+ (define demichrome1 "#555568")
+ (define demichrome2 "#a0a08b")
+ (define demichrome3 "#e9efec")
+
+ (define game-width 240.0)
+ (define game-height 320.0)
+ (define canvas-scale 2.0)
+ (define canvas-width (* game-width canvas-scale))
+ (define canvas-height (* game-height canvas-scale))
+ (define canvas (get-element-by-id "canvas"))
+ (define context (get-context canvas "2d"))
+ (define image:player (get-element-by-id "image-player"))
+ (define image:player-bullet (get-element-by-id "image-player-bullet"))
+ (define image:map (get-element-by-id "image-map"))
+
+ ;; header: length, capacity
+ (define %bullet-pool-header-size (+ 4 4))
+ ;; per bullet: type, x, y, dx, dy
+ (define %bullet-pool-bullet-size (+ 4 8 8 8 8))
+ (define (make-bullet-pool capacity)
+ (let ((pool (make-bytevector (+ %bullet-pool-header-size
+ (* capacity %bullet-pool-bullet-size)))))
+ (bytevector-s32-native-set! pool 4 capacity)
+ pool))
+ (define (bullet-pool-length pool)
+ (bytevector-s32-native-ref pool 0))
+ (define (set-bullet-pool-length! pool length)
+ (bytevector-s32-native-set! pool 0 length))
+ (define (bullet-pool-capacity pool)
+ (bytevector-s32-native-ref pool 4))
+ (define (bullet-pool-offset i)
+ (+ %bullet-pool-header-size (* i %bullet-pool-bullet-size)))
+ (define (bullet-pool-add! pool type x y dx dy)
+ (let* ((k (bullet-pool-length pool))
+ (offset (bullet-pool-offset k)))
+ (bytevector-s32-native-set! pool offset type)
+ (bytevector-ieee-double-native-set! pool (+ offset 4) x)
+ (bytevector-ieee-double-native-set! pool (+ offset 12) y)
+ (bytevector-ieee-double-native-set! pool (+ offset 20) dx)
+ (bytevector-ieee-double-native-set! pool (+ offset 28) dy)
+ (set-bullet-pool-length! pool (+ k 1))))
+ (define (bullet-pool-remove! pool i)
+ (let ((k (bullet-pool-length pool)))
+ (when (and (>= i 0) (< i k))
+ (let ((at (bullet-pool-offset i))
+ (start (bullet-pool-offset (- k 1))))
+ (bytevector-copy! pool at pool start
+ (+ start %bullet-pool-bullet-size))
+ (set-bullet-pool-length! pool (- k 1))))))
+ (define (bullet-pool-ref pool i)
+ (let ((offset (bullet-pool-offset i)))
+ (values
+ (bytevector-s32-native-ref pool offset)
+ (bytevector-ieee-double-native-ref pool (+ offset 4))
+ (bytevector-ieee-double-native-ref pool (+ offset 12))
+ (bytevector-ieee-double-native-ref pool (+ offset 20))
+ (bytevector-ieee-double-native-ref pool (+ offset 28)))))
+ (define (bullet-pool-update! pool)
+ (let ((padding 16.0))
+ (let loop ((i 0) (k (bullet-pool-length player-bullets)))
+ (let* ((offset (bullet-pool-offset i))
+ (x (bytevector-ieee-double-native-ref pool (+ offset 4)))
+ (y (bytevector-ieee-double-native-ref pool (+ offset 12)))
+ (dx (bytevector-ieee-double-native-ref pool (+ offset 20)))
+ (dy (bytevector-ieee-double-native-ref pool (+ offset 28)))
+ (x* (+ x dx))
+ (y* (+ y dy)))
+ (cond
+ ((= i k) #t)
+ ((or (not (within? x* y* (- padding) (- padding)
+ (+ game-width padding) (+ game-height padding)))
+ (point-collides-with-level? level x* y*))
+ (bullet-pool-remove! pool i)
+ (loop i (- k 1)))
+ (else
+ (bytevector-ieee-double-native-set! pool (+ offset 4) x*)
+ (bytevector-ieee-double-native-set! pool (+ offset 12) y*)
+ (loop (+ i 1) k)))))))
+ (define (draw-bullets pool image w h)
+ (let ((k (bullet-pool-length player-bullets)))
+ (do ((i 0 (+ i 1)))
+ ((= i k))
+ (let* ((offset (bullet-pool-offset i))
+ (type (bytevector-s32-native-ref pool offset))
+ (x (bytevector-ieee-double-native-ref pool (+ offset 4)))
+ (y (bytevector-ieee-double-native-ref pool (+ offset 12))))
+ (draw-image context image (* type w) (* type h) w h
+ (- x (/ w 2.0)) (- y (/ w 2.0)) w h)))))
+
+ (define player-bullets (make-bullet-pool 100))
+ (define enemy-bullets (make-bullet-pool 200))
+
+ (define *scroll* game-width)
+
+ ;; Map:
+ ;; sprite sheet offset, x, y
+ (define %tile-size (+ 8 8 8))
+ (define tile-width 16.0)
+ (define tile-height 16.0)
+ (define (make-level tiles)
+ (let ((k (length tiles)))
+ (unless (= (modulo k 15) 0)
+ (error "incomplete level data"))
+ (let ((bv (make-bytevector (* k %tile-size))))
+ (let y-loop ((tiles tiles) (y 0))
+ (match tiles
+ (() #t)
+ (tiles
+ (y-loop
+ (let x-loop ((tiles tiles) (x 0))
+ (if (< x 15)
+ (match tiles
+ ((t . rest)
+ (let ((n (match t
+ ('_ -1.0)
+ ('X 0.0)
+ ('\ 1.0)
+ ('/ 2.0)))
+ (offset (* (+ x (* y 15)) %tile-size)))
+ (bytevector-ieee-double-native-set! bv offset n)
+ (bytevector-ieee-double-native-set! bv (+ offset 8)
+ (* (inexact x) tile-width))
+ (bytevector-ieee-double-native-set! bv (+ offset 16)
+ (* (inexact y) tile-height)))
+ (x-loop rest (+ x 1))))
+ tiles))
+ (+ y 1)))))
+ (list 15 (/ k 15) bv))))
+ (define-syntax-rule (define-level name tile ...)
+ (define name (make-level '(tile ...))))
+ (define-level level
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ X X X _ _ _ _ _ X
+ X _ _ _ _ _ X X X _ _ _ _ _ X
+ X _ _ _ _ _ X X X _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+ X \ _ _ _ _ _ _ _ _ _ _ _ / X
+ X X \ _ _ _ _ _ _ _ _ _ / X X
+ X X X X X X X X X X X X X X X)
+ (define (level-offset x y)
+ (* (+ (* 15 y) x) %tile-size))
+ (define (point-collides-with-level? level x y)
+ (match level
+ ((width height tiles)
+ (let ((tx (trunc (/ x tile-width)))
+ (ty (trunc (/ y tile-height))))
+ (and (>= tx 0) (< tx 15)
+ (>= ty 0) (< tx height)
+ (>= (bytevector-ieee-double-native-ref tiles (level-offset tx ty)) 0))))))
+ (define (rect-collides-with-level? level x y w h)
+ (match level
+ ((width height tiles)
+ (let ((tx0 (trunc (/ x tile-width)))
+ (ty0 (trunc (/ y tile-height)))
+ (tx1 (trunc (/ (+ x w) tile-width)))
+ (ty1 (trunc (/ (+ y h) tile-height))))
+ (define (occupied? x y)
+ (and (>= x 0) (< x 15)
+ (>= y 0) (< x height)
+ (>= (bytevector-ieee-double-native-ref tiles (level-offset x y)) 0)))
+ (or (occupied? tx0 ty0)
+ (occupied? tx1 ty0)
+ (occupied? tx1 ty1)
+ (occupied? tx0 ty1))))))
+ (define (draw-tiles level)
+ (match level
+ ((width height tiles)
+ (let* ((tw tile-width)
+ (th tile-height)
+ (y-end height)
+ (y-start (- y-end 20)))
+ (do ((y 0 (+ y 1)))
+ ((= y 20))
+ (do ((x 0 (+ x 1)))
+ ((= x 15))
+ (let* ((offset (* (+ (* 15 y) x) %tile-size))
+ (t (bytevector-ieee-double-native-ref tiles offset))
+ (tx (bytevector-ieee-double-native-ref tiles (+ offset 8)))
+ (ty (bytevector-ieee-double-native-ref tiles (+ offset 16))))
+ (draw-image context image:map
+ (* t tw) 0.0 tw th
+ tx ty tw th))))))))
+
+ ;; Player state:
+ (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0)))
+ (define player-velocity (vec2 0.0 0.0))
+ (define player-speed 4.0)
+ (define player-bullet-speed 12.0)
+ (define player-width 24.0)
+ (define player-height 24.0)
+ (define *player-fire-counter* 0)
+ (define player-fire-interval 3)
+ ;; left, right, down, up, fire
+ (define key-state (vector #f #f #f #f #f))
+ (define (update-player-velocity!)
+ ;; TODO: Normalize
+ (match key-state
+ (#(left? right? down? up? _)
+ (set-vec2-x! player-velocity
+ (+ (if left? -1.0 0.0)
+ (if right? 1.0 0.0)))
+ (set-vec2-y! player-velocity
+ (+ (if down? 1.0 0.0)
+ (if up? -1.0 0.0)))
+ (vec2-normalize! player-velocity)
+ (vec2-mul-scalar! player-velocity player-speed))))
+ (define (set-left! pressed?)
+ (vector-set! key-state 0 pressed?)
+ (update-player-velocity!))
+ (define (set-right! pressed?)
+ (vector-set! key-state 1 pressed?)
+ (update-player-velocity!))
+ (define (set-down! pressed?)
+ (vector-set! key-state 2 pressed?)
+ (update-player-velocity!))
+ (define (set-up! pressed?)
+ (vector-set! key-state 3 pressed?)
+ (update-player-velocity!))
+ (define (set-firing! pressed?)
+ (let ((was-firing? (firing?)))
+ (vector-set! key-state 4 pressed?)
+ (when (and pressed? (not was-firing?))
+ (set! *player-fire-counter* 0))))
+ (define (firing?)
+ (vector-ref key-state 4))
+
+ (define (clear-screen)
+ (clear-rect context 0.0 0.0 canvas-width canvas-height))
+
+ (define (draw-player-bullets)
+ (draw-bullets player-bullets image:player-bullet 8.0 8.0))
+
+ (define (draw-player)
+ (draw-image context image:player
+ 0.0 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))
+
+ (define (draw time)
+ (clear-screen)
+ (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
+ (set-scale! context canvas-scale canvas-scale)
+ (set-fill-color! context demichrome0)
+ (fill-rect context 0.0 0.0 game-width game-height)
+ (draw-tiles level)
+ (draw-player-bullets)
+ (draw-player)
+ (request-animation-frame draw))
+
+ (define (on-key-down event)
+ (let ((code (keyboard-event-code event)))
+ (cond
+ ((string-=? code "ArrowLeft")
+ (set-left! #t))
+ ((string-=? code "ArrowRight")
+ (set-right! #t))
+ ((string-=? code "ArrowDown")
+ (set-down! #t))
+ ((string-=? code "ArrowUp")
+ (set-up! #t))
+ ((string-=? code "KeyZ")
+ (set-firing! #t)))))
+
+ (define (on-key-up event)
+ (let ((code (keyboard-event-code event)))
+ (cond
+ ((string-=? code "ArrowLeft")
+ (set-left! #f))
+ ((string-=? code "ArrowRight")
+ (set-right! #f))
+ ((string-=? code "ArrowDown")
+ (set-down! #f))
+ ((string-=? code "ArrowUp")
+ (set-up! #f))
+ ((string-=? code "KeyZ")
+ (set-firing! #f)))))
+
+ (define dt (/ 1000.0 60.0))
+ (define (update)
+ (vec2-add! player-position player-velocity)
+ (vec2-clamp! player-position 0.0 0.0 game-width game-height)
+ (bullet-pool-update! player-bullets)
+ (when (firing?)
+ (set! *player-fire-counter*
+ (modulo (+ *player-fire-counter* 1) player-fire-interval))
+ (when (= *player-fire-counter* 0)
+ (let ((xoff 4.0))
+ (bullet-pool-add! player-bullets 0
+ (- (vec2-x player-position) xoff)
+ (vec2-y player-position)
+ 0.0 (- player-bullet-speed))
+ (bullet-pool-add! player-bullets 0
+ (+ (vec2-x player-position) xoff)
+ (vec2-y player-position)
+ 0.0 (- player-bullet-speed)))
+ (set! *player-fire-counter* 0)))
+ (timeout update dt))
+
+ (set-element-width! canvas (trunc canvas-width))
+ (set-element-height! canvas (trunc canvas-height))
+ (add-event-listener! (current-document) "keydown" on-key-down)
+ (add-event-listener! (current-document) "keyup" on-key-up)
+ (set-image-smoothing-enabled! context 0)
+ (request-animation-frame draw)
+ (timeout update dt))
diff --git a/images/2bit-demichrome.gpl b/images/2bit-demichrome.gpl
new file mode 100644
index 0000000..ec858ca
--- /dev/null
+++ b/images/2bit-demichrome.gpl
@@ -0,0 +1,8 @@
+GIMP Palette
+#Palette Name: 2bit demichrome
+#Description: A 4 colour palette meant to look very robotic or mechanical, with a cold metallic dark grey and a warm dated plastic light grey balancing perfectly
+#Colors: 4
+33 30 32 211e20
+85 85 104 555568
+160 160 139 a0a08b
+233 239 236 e9efec
diff --git a/images/chickadee.png b/images/chickadee.png
new file mode 100644
index 0000000..17a35e0
--- /dev/null
+++ b/images/chickadee.png
Binary files differ
diff --git a/images/endesga-16.gpl b/images/endesga-16.gpl
new file mode 100644
index 0000000..a4a84bf
--- /dev/null
+++ b/images/endesga-16.gpl
@@ -0,0 +1,20 @@
+GIMP Palette
+#Palette Name: Endesga 16
+#Description:
+#Colors: 16
+228 166 114 e4a672
+184 111 80 b86f50
+116 63 57 743f39
+63 40 50 3f2832
+158 40 53 9e2835
+229 59 68 e53b44
+251 146 43 fb922b
+255 231 98 ffe762
+99 198 77 63c64d
+50 115 69 327345
+25 61 63 193d3f
+79 103 129 4f6781
+175 191 210 afbfd2
+255 255 255 ffffff
+44 232 244 2ce8f4
+4 132 209 0484d1
diff --git a/images/map.ase b/images/map.ase
new file mode 100644
index 0000000..4177dd5
--- /dev/null
+++ b/images/map.ase
Binary files differ
diff --git a/images/map.png b/images/map.png
new file mode 100644
index 0000000..14da796
--- /dev/null
+++ b/images/map.png
Binary files differ
diff --git a/images/player-bullet.ase b/images/player-bullet.ase
new file mode 100644
index 0000000..33cb8ba
--- /dev/null
+++ b/images/player-bullet.ase
Binary files differ
diff --git a/images/player-bullet.png b/images/player-bullet.png
new file mode 100644
index 0000000..4693829
--- /dev/null
+++ b/images/player-bullet.png
Binary files differ
diff --git a/images/player.ase b/images/player.ase
new file mode 100644
index 0000000..2c90a8f
--- /dev/null
+++ b/images/player.ase
Binary files differ
diff --git a/images/player.png b/images/player.png
new file mode 100644
index 0000000..145655b
--- /dev/null
+++ b/images/player.png
Binary files differ
diff --git a/index.html b/index.html
new file mode 100644
index 0000000..6bfeba4
--- /dev/null
+++ b/index.html
@@ -0,0 +1,15 @@
+<!DOCTYPE html>
+<html>
+ <head>
+ <script type="text/javascript" src="/js-runtime/reflect.js"></script>
+ <script type="text/javascript" src="/boot.js"></script>
+ </head>
+ <body>
+ <canvas id="canvas"></canvas>
+ <div style="display:none;">
+ <img id="image-player" src="images/player.png" />
+ <img id="image-player-bullet" src="images/player-bullet.png" />
+ <img id="image-map" src="images/map.png" />
+ </div>
+ </body>
+</html>
diff --git a/js-runtime/reflect.js b/js-runtime/reflect.js
new file mode 100644
index 0000000..0662ea5
--- /dev/null
+++ b/js-runtime/reflect.js
@@ -0,0 +1,543 @@
+class Char {
+ constructor(codepoint) {
+ this.codepoint = codepoint;
+ }
+ toString() {
+ let ch = String.fromCodePoint(this.codepoint);
+ if (ch.match(/[a-zA-Z0-9$[\]().]/)) return `#\\${ch}`;
+ return `#\\x${this.codepoint.toString(16)}`;
+ }
+}
+class Eof { toString() { return "#<eof>"; } }
+class Nil { toString() { return "#nil"; } }
+class Null { toString() { return "()"; } }
+class Unspecified { toString() { return "#<unspecified>"; } }
+
+class Complex {
+ constructor(real, imag) {
+ this.real = real;
+ this.imag = imag;
+ }
+ toString() {
+ return `${flonum_to_string(this.real)}+${flonum_to_string(this.imag)}i`;
+ }
+}
+class Fraction {
+ constructor(num, denom) {
+ this.num = num;
+ this.denom = denom;
+ }
+ toString() {
+ return `${this.num}/${this.denom}`;
+ }
+}
+
+class HeapObject {
+ constructor(reflector, obj) {
+ this.reflector = reflector;
+ this.obj = obj;
+ }
+ repr() { return this.toString(); } // Default implementation.
+}
+
+class Pair extends HeapObject {
+ toString() { return "#<pair>"; }
+ repr() {
+ let car_repr = repr(this.reflector.car(this));
+ let cdr_repr = repr(this.reflector.cdr(this));
+ if (cdr_repr == '()')
+ return `(${car_repr})`;
+ if (cdr_repr.charAt(0) == '(')
+ return `(${car_repr} ${cdr_repr.substring(1)}`;
+ return `(${car_repr} . ${cdr_repr})`;
+ }
+}
+class MutablePair extends Pair { toString() { return "#<mutable-pair>"; } }
+
+class Vector extends HeapObject {
+ toString() { return "#<vector>"; }
+ repr() {
+ let len = this.reflector.vector_length(this);
+ let out = '#(';
+ for (let i = 0; i < len; i++) {
+ if (i) out += ' ';
+ out += repr(this.reflector.vector_ref(this, i));
+ }
+ out += ')';
+ return out;
+ }
+}
+class MutableVector extends Vector {
+ toString() { return "#<mutable-vector>"; }
+}
+
+class Bytevector extends HeapObject {
+ toString() { return "#<bytevector>"; }
+ repr() {
+ let len = this.reflector.bytevector_length(this);
+ let out = '#vu8(';
+ for (let i = 0; i < len; i++) {
+ if (i) out += ' ';
+ out += this.reflector.bytevector_ref(this, i);
+ }
+ out += ')';
+ return out;
+ }
+}
+class MutableBytevector extends Bytevector {
+ toString() { return "#<mutable-bytevector>"; }
+}
+
+class Bitvector extends HeapObject {
+ toString() { return "#<bitvector>"; }
+ repr() {
+ let len = this.reflector.bitvector_length(this);
+ let out = '#*';
+ for (let i = 0; i < len; i++) {
+ out += this.reflector.bitvector_ref(this, i) ? '1' : '0';
+ }
+ return out;
+ }
+}
+class MutableBitvector extends Bitvector {
+ toString() { return "#<mutable-bitvector>"; }
+}
+
+class MutableString extends HeapObject {
+ toString() { return "#<mutable-string>"; }
+ repr() { return this.reflector.string_value(this); }
+}
+
+class Procedure extends HeapObject {
+ toString() { return "#<procedure>"; }
+ call(...arg) {
+ return this.reflector.call(this, ...arg);
+ }
+}
+
+class Sym extends HeapObject {
+ toString() { return "#<symbol>"; }
+ repr() { return this.reflector.symbol_name(this); }
+}
+
+class Keyword extends HeapObject {
+ toString() { return "#<keyword>"; }
+ repr() { return `#:${this.reflector.keyword_name(this)}`; }
+}
+
+class Variable extends HeapObject { toString() { return "#<variable>"; } }
+class AtomicBox extends HeapObject { toString() { return "#<atomic-box>"; } }
+class HashTable extends HeapObject { toString() { return "#<hash-table>"; } }
+class WeakTable extends HeapObject { toString() { return "#<weak-table>"; } }
+class Fluid extends HeapObject { toString() { return "#<fluid>"; } }
+class DynamicState extends HeapObject { toString() { return "#<dynamic-state>"; } }
+class Syntax extends HeapObject { toString() { return "#<syntax>"; } }
+class Port extends HeapObject { toString() { return "#<port>"; } }
+class Struct extends HeapObject { toString() { return "#<struct>"; } }
+
+function instantiate_streaming(path, imports) {
+ if (typeof fetch !== 'undefined')
+ return WebAssembly.instantiateStreaming(fetch(path), imports);
+ let bytes;
+ if (typeof read !== 'undefined') {
+ bytes = read(path, 'binary');
+ } else if (typeof readFile !== 'undefined') {
+ bytes = readFile(path);
+ } else {
+ let fs = require('fs');
+ bytes = fs.readFileSync(path);
+ }
+ return WebAssembly.instantiate(bytes, imports);
+}
+
+class Scheme {
+ #instance;
+ #abi;
+ constructor(instance, abi) {
+ this.#instance = instance;
+ this.#abi = abi;
+ }
+
+ static async reflect(abi) {
+ let { module, instance } =
+ await instantiate_streaming('js-runtime/reflect.wasm', {
+ abi,
+ rt: {
+ wtf8_to_string(wtf8) { return wtf8_to_string(wtf8); },
+ string_to_wtf8(str) { return string_to_wtf8(str); },
+ }
+ });
+ return new Scheme(instance, abi);
+ }
+
+ init_module(mod) {
+ mod.set_debug_handler({
+ debug_str(x) { console.log(`debug: ${x}`); },
+ debug_str_i32(x, y) { console.log(`debug: ${x}: ${y}`); },
+ debug_str_scm: (x, y) => {
+ console.log(`debug: ${x}: ${repr(this.to_js(y))}`);
+ },
+ });
+ let proc = new Procedure(this, mod.get_export('$load').value)
+ return proc.call();
+ }
+ static async load_main(path, abi, user_imports = {}) {
+ let mod = await SchemeModule.fetch_and_instantiate(path, abi, user_imports);
+ let reflect = await mod.reflect();
+ return reflect.init_module(mod);
+ }
+ async load_extension(path) {
+ let mod = await SchemeModule.fetch_and_instantiate(path, this.#abi);
+ return this.init_module(mod);
+ }
+
+ #to_scm(js) {
+ let api = this.#instance.exports;
+ if (typeof(js) == 'number') {
+ return api.scm_from_f64(js);
+ } else if (typeof(js) == 'bigint') {
+ if (BigInt(api.scm_most_negative_fixnum()) <= js
+ && js <= BigInt(api.scm_most_positive_fixnum()))
+ return api.scm_from_fixnum(Number(js));
+ return api.scm_from_bignum(js);
+ } else if (typeof(js) == 'boolean') {
+ return js ? api.scm_true() : api.scm_false();
+ } else if (typeof(js) == 'string') {
+ return api.scm_from_string(js);
+ } else if (typeof(js) == 'object') {
+ if (js instanceof Eof) return api.scm_eof();
+ if (js instanceof Nil) return api.scm_nil();
+ if (js instanceof Null) return api.scm_null();
+ if (js instanceof Unspecified) return api.scm_unspecified();
+ if (js instanceof Char) return api.scm_from_char(js.codepoint);
+ if (js instanceof HeapObject) return js.obj;
+ if (js instanceof Fraction)
+ return api.scm_from_fraction(this.#to_scm(js.num),
+ this.#to_scm(js.denom));
+ if (js instanceof Complex)
+ return api.scm_from_complex(js.real, js.imag);
+ return api.scm_from_extern(js);
+ } else {
+ throw new Error(`unexpected; ${typeof(js)}`);
+ }
+ }
+
+ to_js(scm) {
+ let api = this.#instance.exports;
+ let descr = api.describe(scm);
+ let handlers = {
+ fixnum: () => BigInt(api.fixnum_value(scm)),
+ char: () => new Char(api.char_value(scm)),
+ true: () => true,
+ false: () => false,
+ eof: () => new Eof,
+ nil: () => new Nil,
+ null: () => new Null,
+ unspecified: () => new Unspecified,
+ flonum: () => api.flonum_value(scm),
+ bignum: () => api.bignum_value(scm),
+ complex: () => new Complex(api.complex_real(scm),
+ api.complex_imag(scm)),
+ fraction: () => new Fraction(this.to_js(api.fraction_num(scm)),
+ this.to_js(api.fraction_denom(scm))),
+ pair: () => new Pair(this, scm),
+ 'mutable-pair': () => new MutablePair(this, scm),
+ vector: () => new Vector(this, scm),
+ 'mutable-vector': () => new MutableVector(this, scm),
+ bytevector: () => new Bytevector(this, scm),
+ 'mutable-bytevector': () => new MutableBytevector(this, scm),
+ bitvector: () => new Bitvector(this, scm),
+ 'mutable-bitvector': () => new MutableBitvector(this, scm),
+ string: () => api.string_value(scm),
+ 'mutable-string': () => new MutableString(this, scm),
+ procedure: () => new Procedure(this, scm),
+ symbol: () => new Sym(this, scm),
+ keyword: () => new Keyword(this, scm),
+ variable: () => new Variable(this, scm),
+ 'atomic-box': () => new AtomicBox(this, scm),
+ 'hash-table': () => new HashTable(this, scm),
+ 'weak-table': () => new WeakTable(this, scm),
+ fluid: () => new Fluid(this, scm),
+ 'dynamic-state': () => new DynamicState(this, scm),
+ syntax: () => new Syntax(this, scm),
+ port: () => new Port(this, scm),
+ struct: () => new Struct(this, scm),
+ 'extern-ref': () => api.extern_value(scm)
+ };
+ let handler = handlers[descr];
+ return handler ? handler() : scm;
+ }
+
+ call(func, ...args) {
+ let api = this.#instance.exports;
+ let argv = api.make_vector(args.length + 1, api.scm_false());
+ func = this.#to_scm(func);
+ api.vector_set(argv, 0, func);
+ for (let [idx, arg] of args.entries())
+ api.vector_set(argv, idx + 1, this.#to_scm(arg));
+ argv = api.call(func, argv);
+ let results = [];
+ for (let idx = 0; idx < api.vector_length(argv); idx++)
+ results.push(this.to_js(api.vector_ref(argv, idx)))
+ return results;
+ }
+
+ car(x) { return this.to_js(this.#instance.exports.car(x.obj)); }
+ cdr(x) { return this.to_js(this.#instance.exports.cdr(x.obj)); }
+
+ vector_length(x) { return this.#instance.exports.vector_length(x.obj); }
+ vector_ref(x, i) {
+ return this.to_js(this.#instance.exports.vector_ref(x.obj, i));
+ }
+
+ bytevector_length(x) {
+ return this.#instance.exports.bytevector_length(x.obj);
+ }
+ bytevector_ref(x, i) {
+ return this.#instance.exports.bytevector_ref(x.obj, i);
+ }
+
+ bitvector_length(x) {
+ return this.#instance.exports.bitvector_length(x.obj);
+ }
+ bitvector_ref(x, i) {
+ return this.#instance.exports.bitvector_ref(x.obj, i) == 1;
+ }
+
+ string_value(x) { return this.#instance.exports.string_value(x.obj); }
+ symbol_name(x) { return this.#instance.exports.symbol_name(x.obj); }
+ keyword_name(x) { return this.#instance.exports.keyword_name(x.obj); }
+}
+
+class SchemeTrapError extends Error {
+ constructor(tag, data) { super(); this.tag = tag; this.data = data; }
+ // FIXME: data is raw Scheme object; would need to be reflected to
+ // have a toString.
+ toString() { return `SchemeTrap(${this.tag}, <data>)`; }
+}
+
+function flonum_to_string(f64) {
+ if (Object.is(f64, -0)) {
+ return '-0.0';
+ } else if (Number.isFinite(f64)) {
+ let repr = f64 + '';
+ return /^-?[0-9]+$/.test(repr) ? repr + '.0' : repr;
+ } else if (Number.isNaN(f64)) {
+ return '+nan.0';
+ } else {
+ return f64 < 0 ? '-inf.0' : '+inf.0';
+ }
+}
+
+let wtf8_helper;
+
+function wtf8_to_string(wtf8) {
+ let { as_iter, iter_next } = wtf8_helper.exports;
+ let codepoints = [];
+ let iter = as_iter(wtf8);
+ for (let cp = iter_next(iter); cp != -1; cp = iter_next(iter))
+ codepoints.push(cp);
+ return String.fromCodePoint(...codepoints);
+}
+
+function string_to_wtf8(str) {
+ let { string_builder, builder_push_codepoint, finish_builder } =
+ wtf8_helper.exports;
+ let builder = string_builder()
+ for (let cp of str)
+ builder_push_codepoint(builder, cp.codePointAt(0));
+ return finish_builder(builder);
+}
+
+async function load_wtf8_helper_module() {
+ if (wtf8_helper) return;
+ let { module, instance } = await instantiate_streaming("js-runtime/wtf8.wasm");
+ wtf8_helper = instance;
+}
+
+class SchemeModule {
+ #instance;
+ #io_handler;
+ #debug_handler;
+ static #rt = {
+ bignum_from_i32(n) { return BigInt(n); },
+ bignum_from_i64(n) { return n; },
+ bignum_from_u64(n) { return n < 0n ? 0xffff_ffff_ffff_ffffn + (n + 1n) : n; },
+ bignum_is_i64(n) {
+ return -0x8000_0000_0000_0000n <= n && n <= 0x7FFF_FFFF_FFFF_FFFFn;
+ },
+ bignum_is_u64(n) {
+ return 0n <= n && n <= 0xFFFF_FFFF_FFFF_FFFFn;
+ },
+ // This truncates; see https://tc39.es/ecma262/#sec-tobigint64.
+ bignum_get_i64(n) { return n; },
+
+ bignum_add(a, b) { return BigInt(a) + BigInt(b) },
+ bignum_sub(a, b) { return BigInt(a) - BigInt(b) },
+ bignum_mul(a, b) { return BigInt(a) * BigInt(b) },
+ bignum_lsh(a, b) { return BigInt(a) << BigInt(b) },
+ bignum_rsh(a, b) { return BigInt(a) >> BigInt(b) },
+ bignum_quo(a, b) { return BigInt(a) / BigInt(b) },
+ bignum_rem(a, b) { return BigInt(a) % BigInt(b) },
+ bignum_mod(a, b) {
+ let r = BigInt(a) % BigInt(b);
+ if ((b > 0n && r < 0n) || (b < 0n && r > 0n)) {
+ return b + r;
+ } else {
+ return r;
+ }
+ },
+ bignum_gcd(a, b) {
+ a = BigInt(a);
+ b = BigInt(b);
+ if (a < 0n) { a = -a; }
+ if (b < 0n) { b = -b; }
+ if (a == 0n) { return b; }
+ if (b == 0n) { return a; }
+
+ let r;
+ while (b != 0n) {
+ r = a % b;
+ a = b;
+ b = r;
+ }
+ return a;
+ },
+
+ bignum_logand(a, b) { return BigInt(a) & BigInt(b); },
+ bignum_logior(a, b) { return BigInt(a) | BigInt(b); },
+ bignum_logxor(a, b) { return BigInt(a) ^ BigInt(b); },
+ bignum_logsub(a, b) { return BigInt(a) & (~ BigInt(b)); },
+
+ bignum_lt(a, b) { return a < b; },
+ bignum_le(a, b) { return a <= b; },
+ bignum_eq(a, b) { return a == b; },
+
+ bignum_to_f64(n) { return Number(n); },
+
+ f64_is_nan(n) { return Number.isNaN(n); },
+ f64_is_infinite(n) { return !Number.isFinite(n); },
+
+ flonum_to_string,
+
+ string_upcase: Function.call.bind(String.prototype.toUpperCase),
+ string_downcase: Function.call.bind(String.prototype.toLowerCase),
+
+ make_weak_map() { return new WeakMap; },
+ weak_map_get(map, k) { return map.get(k); },
+ weak_map_set(map, k, v) { return map.set(k, v); },
+ weak_map_delete(map, k) { return map.delete(k); },
+
+ fsqrt: Math.sqrt,
+ fsin: Math.sin,
+ fcos: Math.cos,
+ ftan: Math.tan,
+ fasin: Math.asin,
+ facos: Math.acos,
+ fatan: Math.atan,
+ fatan2: Math.atan2,
+ flog: Math.log,
+ fexp: Math.exp,
+
+ jiffies_per_second() { return 1000; },
+ current_jiffy() { return BigInt(Math.floor(performance.now())); },
+ current_second() { return Date.now() / 1000; },
+
+ // Wrap in functions to allow for lazy loading of the wtf8
+ // module.
+ wtf8_to_string(wtf8) { return wtf8_to_string(wtf8); },
+ string_to_wtf8(str) { return string_to_wtf8(str); },
+
+ die(tag, data) { throw new SchemeTrapError(tag, data); }
+ };
+
+ constructor(instance) {
+ this.#instance = instance;
+ let read_stdin = () => '';
+ if (typeof printErr === 'function') {
+ // On the console, try to use 'write' (v8) or 'putstr' (sm),
+ // as these don't add an extraneous newline. Unfortunately
+ // JSC doesn't have a printer that doesn't add a newline.
+ let write_no_newline =
+ typeof write === 'function' ? write
+ : typeof putstr === 'function' ? putstr : print;
+ this.#io_handler = {
+ write_stdout: write_no_newline,
+ write_stderr: printErr,
+ read_stdin
+ };
+ } else {
+ this.#io_handler = {
+ write_stdout: console.log,
+ write_stderr: console.error,
+ read_stdin
+ }
+ }
+ this.#debug_handler = {
+ debug_str(x) { console.log(`debug: ${x}`); },
+ debug_str_i32(x, y) { console.log(`debug: ${x}: ${y}`); },
+ debug_str_scm(x, y) { console.log(`debug: ${x}: #<scm>`); },
+ }
+ }
+ static async fetch_and_instantiate(path, imported_abi, user_imports = {}) {
+ await load_wtf8_helper_module();
+ let io = {
+ write_stdout(str) { mod.#io_handler.write_stdout(str); },
+ write_stderr(str) { mod.#io_handler.write_stderr(str); },
+ read_stdin() { return mod.#io_handler.read_stdin(); },
+ }
+ let debug = {
+ debug_str(x) { mod.#debug_handler.debug_str(x); },
+ debug_str_i32(x, y) { mod.#debug_handler.debug_str_i32(x, y); },
+ debug_str_scm(x, y) { mod.#debug_handler.debug_str_scm(x, y); },
+ }
+ let imports = {
+ rt: SchemeModule.#rt,
+ abi: imported_abi,
+ debug, io, ...user_imports
+ };
+ let { module, instance } = await instantiate_streaming(path, imports);
+ let mod = new SchemeModule(instance);
+ return mod;
+ }
+ set_io_handler(h) { this.#io_handler = h; }
+ set_debug_handler(h) { this.#debug_handler = h; }
+ all_exports() { return this.#instance.exports; }
+ exported_abi() {
+ let abi = {}
+ for (let [k, v] of Object.entries(this.all_exports())) {
+ if (k.startsWith("$"))
+ abi[k] = v;
+ }
+ return abi;
+ }
+ exports() {
+ let ret = {}
+ for (let [k, v] of Object.entries(this.all_exports())) {
+ if (!k.startsWith("$"))
+ ret[k] = v;
+ }
+ return ret;
+ }
+ get_export(name) {
+ if (name in this.all_exports())
+ return this.all_exports()[name];
+ throw new Error(`unknown export: ${name}`)
+ }
+ async reflect() {
+ return await Scheme.reflect(this.exported_abi());
+ }
+}
+
+function repr(obj) {
+ if (obj instanceof HeapObject)
+ return obj.repr();
+ if (typeof obj === 'boolean')
+ return obj ? '#t' : '#f';
+ if (typeof obj === 'number')
+ return flonum_to_string(obj);
+ if (typeof obj === 'string')
+ // FIXME: Improve to match Scheme.
+ return '"' + obj.replace(/(["\\])/g, '\\$1') + '"';
+ return obj + '';
+}
diff --git a/js-runtime/reflect.wasm b/js-runtime/reflect.wasm
new file mode 100644
index 0000000..d2b10d7
--- /dev/null
+++ b/js-runtime/reflect.wasm
Binary files differ
diff --git a/js-runtime/wtf8.wasm b/js-runtime/wtf8.wasm
new file mode 100644
index 0000000..ca1079d
--- /dev/null
+++ b/js-runtime/wtf8.wasm
Binary files differ
diff --git a/web-server.scm b/web-server.scm
new file mode 100644
index 0000000..86015dc
--- /dev/null
+++ b/web-server.scm
@@ -0,0 +1,155 @@
+(use-modules (ice-9 format)
+ (ice-9 ftw)
+ (ice-9 hash-table)
+ (ice-9 match)
+ (ice-9 popen)
+ (ice-9 rdelim)
+ (ice-9 regex)
+ (ice-9 binary-ports)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (sxml simple)
+ (web server)
+ (web request)
+ (web response)
+ (web uri))
+
+(define %mime-types
+ (alist->hash-table
+ '(("js" . application/javascript)
+ ("html" . text/html)
+ ("wasm" . application/wasm)
+ ("png" . image/png))))
+
+(define (file-extension file)
+ "Return the extension of FILE or #f if there is none."
+ (let ((dot (string-rindex file #\.)))
+ (and dot (substring file (+ 1 dot) (string-length file)))))
+
+(define (mime-type file-name)
+ "Guess the MIME type for FILE-NAME based upon its file extension."
+ (or (hash-ref %mime-types (file-extension file-name))
+ 'text/plain))
+
+(define (stat:directory? stat)
+ "Return #t if STAT is a directory."
+ (eq? (stat:type stat) 'directory))
+
+(define (directory? file-name)
+ "Return #t if FILE-NAME is a directory."
+ (stat:directory? (stat file-name)))
+
+(define (directory-contents dir)
+ "Return a list of the files contained within DIR."
+ (define name+directory?
+ (match-lambda
+ ((name stat)
+ (list name (stat:directory? stat)))))
+
+ (define (same-dir? other stat)
+ (string=? dir other))
+
+ (match (file-system-tree dir same-dir?)
+ ;; We are not interested in the parent directory, only the
+ ;; children.
+ ((_ _ children ...)
+ (map name+directory? children))))
+
+(define (work-dir+path->file-name work-dir path)
+ "Convert the URI PATH to an absolute file name relative to the
+directory WORK-DIR."
+ (string-append work-dir path))
+
+(define (request-path-components request)
+ "Split the URI path of REQUEST into a list of component strings. For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (request-file-name request)
+ "Return the relative file name corresponding to the REQUEST URI."
+ (let ((components (request-path-components request)))
+ (if (null? components)
+ "/"
+ (string-join components "/" 'prefix))))
+
+(define (resolve-file-name file-name)
+ "If FILE-NAME is a directory with an 'index.html' file,
+return that file name. If FILE-NAME does not exist, return #f.
+Otherwise, return FILE-NAME as-is."
+ (let ((index-file-name (string-append file-name "/index.html")))
+ (cond
+ ((file-exists? index-file-name) index-file-name)
+ ((file-exists? file-name) file-name)
+ (else #f))))
+
+(define (render-file file-name)
+ "Return a 200 OK HTTP response that renders the contents of
+FILE-NAME."
+ (values `((content-type . (,(mime-type file-name))))
+ (call-with-input-file file-name get-bytevector-all)))
+
+(define (render-directory path dir)
+ "Render the contents of DIR represented by the URI PATH."
+ (define (concat+uri-encode . file-names)
+ "Concatenate FILE-NAMES, preserving the correct file separators."
+ (string-join (map uri-encode
+ (remove string-null?
+ (append-map (cut string-split <> #\/) file-names)))
+ "/" 'prefix))
+
+ (define render-child
+ (match-lambda
+ ((file-name directory?)
+ `(li
+ (a (@ (href ,(concat+uri-encode path file-name)))
+ ,(if directory?
+ (string-append file-name "/")
+ file-name))))))
+
+ (define file-name<
+ (match-lambda*
+ (((name-a _) (name-b _))
+ (string< name-a name-b))))
+
+ (let* ((children (sort (directory-contents dir) file-name<))
+ (title (string-append "Directory listing for " path))
+ (view `(html
+ (head
+ (title ,title))
+ (body
+ (h1 ,title)
+ (ul ,@(map render-child children))))))
+ (values '((content-type . (text/html)))
+ (lambda (port)
+ (display "<!DOCTYPE html>" port)
+ (sxml->xml view port)))))
+
+(define (not-found path)
+ "Return a 404 not found HTTP response for PATH."
+ (values (build-response #:code 404)
+ (string-append "Resource not found: " path)))
+
+(define (serve-file work-dir path)
+ "Return an HTTP response for the file represented by PATH."
+ (match (resolve-file-name
+ (work-dir+path->file-name work-dir path))
+ (#f (not-found path))
+ ((? directory? dir)
+ (render-directory path dir))
+ (file-name
+ (render-file file-name))))
+
+(define (make-handler work-dir)
+ (lambda (request body)
+ "Serve the file asked for in REQUEST."
+ (format #t "~a ~a~%"
+ (request-method request)
+ (uri-path (request-uri request)))
+ (serve-file work-dir (request-file-name request))))
+
+(define* (serve work-dir #:key (open-params '()))
+ "Run a simple HTTP server that serves files in WORK-DIR."
+ (run-server (make-handler work-dir) 'http open-params))
+
+(when (batch-mode?)
+ (serve (getcwd) #:open-params `(#:port 8088 #:addr ,INADDR_ANY)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-24 13:10:56 +0000