From b33079617253f844db5d7352280504b8f1851483 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Fri, 5 Jul 2024 10:38:45 -0400
Subject: Add propagator experiment.

---
 chapter-7/.dir-locals.el    |   3 +
 chapter-7/Makefile          |   8 +
 chapter-7/hoot/reflect.js   | 738 ++++++++++++++++++++++++++++++++++++++++++++
 chapter-7/hoot/reflect.wasm | Bin 0 -> 5196 bytes
 chapter-7/hoot/wtf8.wasm    | Bin 0 -> 1071 bytes
 chapter-7/index.html        |  11 +
 chapter-7/manifest.scm      |  24 ++
 chapter-7/propagators.css   |  38 +++
 chapter-7/propagators.js    |  91 ++++++
 chapter-7/propagators.scm   | 649 ++++++++++++++++++++++++++++++++++++++
 10 files changed, 1562 insertions(+)
 create mode 100644 chapter-7/.dir-locals.el
 create mode 100644 chapter-7/Makefile
 create mode 100644 chapter-7/hoot/reflect.js
 create mode 100644 chapter-7/hoot/reflect.wasm
 create mode 100644 chapter-7/hoot/wtf8.wasm
 create mode 100644 chapter-7/index.html
 create mode 100644 chapter-7/manifest.scm
 create mode 100644 chapter-7/propagators.css
 create mode 100644 chapter-7/propagators.js
 create mode 100644 chapter-7/propagators.scm

(limited to 'chapter-7')

diff --git a/chapter-7/.dir-locals.el b/chapter-7/.dir-locals.el
new file mode 100644
index 0000000..95249a0
--- /dev/null
+++ b/chapter-7/.dir-locals.el
@@ -0,0 +1,3 @@
+((scheme-mode
+  .
+  ((eval . (put 'with-cells 'scheme-indent-function 1)))))
diff --git a/chapter-7/Makefile b/chapter-7/Makefile
new file mode 100644
index 0000000..15a88da
--- /dev/null
+++ b/chapter-7/Makefile
@@ -0,0 +1,8 @@
+propagators.wasm: propagators.scm
+	guild compile-wasm -o $@ $<
+
+serve: propagators.wasm
+	guile -c '((@ (hoot web-server) serve))'
+
+clean:
+	rm -f propagators.wasm
diff --git a/chapter-7/hoot/reflect.js b/chapter-7/hoot/reflect.js
new file mode 100644
index 0000000..b00874c
--- /dev/null
+++ b/chapter-7/hoot/reflect.js
@@ -0,0 +1,738 @@
+// -*- js2-basic-offset: 4 -*-
+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() {
+        const sign = this.imag >= 0 && Number.isFinite(this.imag) ? "+": "";
+        return `${flonum_to_string(this.real)}${sign}${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 string_repr(this.reflector.string_value(this)); }
+}
+
+class Procedure extends HeapObject {
+    toString() { return "#<procedure>"; }
+    call(...arg) {
+        return this.reflector.call(this, ...arg);
+    }
+    async call_async(...arg) {
+        return await this.reflector.call_async(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, {reflect_wasm_dir = '.'}) {
+        let debug = {
+            debug_str(x) { console.log(`reflect debug: ${x}`); },
+            debug_str_i32(x, y) { console.log(`reflect debug: ${x}: ${y}`); },
+            debug_str_scm: (x, y) => {
+                console.log(`reflect debug: ${x}: #<scm>`);
+            },
+        };
+        let reflect_wasm = reflect_wasm_dir + '/reflect.wasm';
+        let rt = {
+            die(tag, data) { throw new SchemeTrapError(tag, data); },
+            wtf8_to_string(wtf8) { return wtf8_to_string(wtf8); },
+            string_to_wtf8(str) { return string_to_wtf8(str); },
+        };
+        let { module, instance } =
+            await instantiate_streaming(reflect_wasm, { abi, debug, rt });
+        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))}`);
+            },
+        });
+        mod.set_ffi_handler({
+            procedure_to_extern: (obj) => {
+                const proc = this.#to_js(obj);
+                return (...args) => {
+                    return proc.call(...args);
+                };
+            }
+        });
+        let proc = new Procedure(this, mod.get_export('$load').value);
+        return proc.call();
+    }
+    static async load_main(path, opts = {}) {
+        let mod = await SchemeModule.fetch_and_instantiate(path, opts);
+        let reflect = await mod.reflect(opts);
+        return reflect.#init_module(mod);
+    }
+    async load_extension(path, opts = {}) {
+        opts = Object.assign({ abi: this.#abi }, opts);
+        let mod = await SchemeModule.fetch_and_instantiate(path, opts);
+        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 if (typeof(js) == 'function') {
+            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;
+    }
+
+    call_async(func, ...args) {
+        return new Promise((resolve, reject) => {
+            this.call(func,
+                      val => resolve(this.#to_js(val)),
+                      err => reject(this.#to_js(err)),
+                      ...args);
+        })
+    }
+
+    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 string_repr(str) {
+    // FIXME: Improve to match Scheme.
+    return '"' + str.replace(/(["\\])/g, '\\$1').replace(/\n/g, '\\n') + '"';
+}
+
+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 async_invoke = typeof queueMicrotask !== 'undefined'
+    ? queueMicrotask
+    : thunk => setTimeout(thunk, 0);
+function async_invoke_later(thunk, jiffies) {
+    setTimeout(thunk, jiffies / 1000);
+}
+
+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);
+
+    // Passing too many codepoints can overflow the stack.
+    let maxcp = 100000;
+    if (codepoints.length <= maxcp) {
+        return String.fromCodePoint(...codepoints);
+    }
+
+    // For converting large strings, concatenate several smaller
+    // strings.
+    let substrings = [];
+    let end = 0;
+    for (let start = 0; start != codepoints.length; start = end) {
+        end = Math.min(start + maxcp, codepoints.length);
+        substrings.push(String.fromCodePoint(...codepoints.slice(start, end)));
+    }
+    return substrings.join('');
+}
+
+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(reflect_wasm_dir = '') {
+    if (wtf8_helper) return;
+    let wtf8_wasm = reflect_wasm_dir + "/wtf8.wasm";
+    let { module, instance } = await instantiate_streaming(wtf8_wasm);
+    wtf8_helper = instance;
+}
+
+class SchemeModule {
+    #instance;
+    #io_handler;
+    #debug_handler;
+    #ffi_handler;
+    static #rt = {
+        bignum_from_string(str) { return BigInt(str); },
+        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, fail) {
+            const val = map.get(k);
+            return val === undefined ? fail: val;
+        },
+        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 1000000; },
+        current_jiffy() { return performance.now() * 1000; },
+        current_second() { return Date.now() / 1000; },
+
+        async_invoke,
+        async_invoke_later,
+        promise_on_completed(p, kt, kf) { p.then(kt, kf); },
+        promise_complete(callback, val) { callback(val); },
+
+        // 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 open_file_error = (filename) => {
+            throw new Error('No file system access');
+        };
+        if (typeof printErr === 'function') { // v8/sm dev console
+            // 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;
+            // Use readline when available.  v8 strips newlines so
+            // we need to add them back.
+            let read_stdin =
+                typeof readline == 'function' ? () => {
+                    let line = readline();
+                    if (line) {
+                        return `${line}\n`;
+                    } else {
+                        return '\n';
+                    }
+                }: () => '';
+            this.#io_handler = {
+                write_stdout: write_no_newline,
+                write_stderr: printErr,
+                read_stdin,
+                file_exists: (filename) => false,
+                open_input_file: open_file_error,
+                open_output_file: open_file_error,
+                close_file: () => undefined,
+                read_file: (handle, length) => 0,
+                write_file: (handle, length) => 0,
+                seek_file: (handle, offset, whence) => -1,
+                file_random_access: (handle) => false,
+                file_buffer_size: (handle) => 0,
+                file_buffer_ref: (handle, i) => 0,
+                file_buffer_set: (handle, i, x) => undefined,
+                delete_file: (filename) => undefined
+            };
+        } else if (typeof window !== 'undefined') { // web browser
+            this.#io_handler = {
+                write_stdout: console.log,
+                write_stderr: console.error,
+                read_stdin: () => '',
+                file_exists: (filename) => false,
+                open_input_file: open_file_error,
+                open_output_file: open_file_error,
+                close_file: () => undefined,
+                read_file: (handle, length) => 0,
+                write_file: (handle, length) => 0,
+                seek_file: (handle, offset, whence) => -1,
+                file_random_access: (handle) => false,
+                file_buffer_size: (handle) => 0,
+                file_buffer_ref: (handle, i) => 0,
+                file_buffer_set: (handle, i, x) => undefined,
+                delete_file: (filename) => undefined
+            };
+        } else { // nodejs
+            const fs = require('fs');
+            const process = require('process');
+            const bufLength = 1024;
+            const stdinBuf = Buffer.alloc(bufLength);
+            const SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2;
+            this.#io_handler = {
+                write_stdout: console.log,
+                write_stderr: console.error,
+                read_stdin: () => {
+                    let n = fs.readSync(process.stdin.fd, stdinBuf, 0, stdinBuf.length);
+                    return stdinBuf.toString('utf8', 0, n);
+                },
+                file_exists: fs.existsSync.bind(fs),
+                open_input_file: (filename) => {
+                    let fd = fs.openSync(filename, 'r');
+                    return {
+                        fd,
+                        buf: Buffer.alloc(bufLength),
+                        pos: 0
+                    };
+                },
+                open_output_file: (filename) => {
+                    let fd = fs.openSync(filename, 'w');
+                    return {
+                        fd,
+                        buf: Buffer.alloc(bufLength),
+                        pos: 0
+                    };
+                },
+                close_file: (handle) => {
+                    fs.closeSync(handle.fd);
+                },
+                read_file: (handle, count) => {
+                    const n = fs.readSync(handle.fd, handle.buf, 0, count, handle.pos);
+                    handle.pos += n;
+                    return n;
+                },
+                write_file: (handle, count) => {
+                    const n = fs.writeSync(handle.fd, handle.buf, 0, count, handle.pos);
+                    handle.pos += n;
+                    return n;
+                },
+                seek_file: (handle, offset, whence) => {
+                    // There doesn't seem to be a way to ask NodeJS if
+                    // a position is valid or not.
+                    if (whence == SEEK_SET) {
+                        handle.pos = offset;
+                        return handle.pos;
+                    } else if (whence == SEEK_CUR) {
+                        handle.pos += offset;
+                        return handle.pos;
+                    }
+
+                    // SEEK_END not supported.
+                    return -1;
+                },
+                file_random_access: (handle) => {
+                    return true;
+                },
+                file_buffer_size: (handle) => {
+                    return handle.buf.length;
+                },
+                file_buffer_ref: (handle, i) => {
+                    return handle.buf[i];
+                },
+                file_buffer_set: (handle, i, x) => {
+                    handle.buf[i] = x;
+                },
+                delete_file: fs.rmSync.bind(fs)
+            };
+        }
+        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, { abi, reflect_wasm_dir = '.',
+                                               user_imports = {} }) {
+        await load_wtf8_helper_module(reflect_wasm_dir);
+        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(); },
+            file_exists(filename) { return mod.#io_handler.file_exists(filename); },
+            open_input_file(filename) { return mod.#io_handler.open_input_file(filename); },
+            open_output_file(filename) { return mod.#io_handler.open_output_file(filename); },
+            close_file(handle) { mod.#io_handler.close_file(handle); },
+            read_file(handle, length) { return mod.#io_handler.read_file(handle, length); },
+            write_file(handle, length) { return mod.#io_handler.write_file(handle, length); },
+            seek_file(handle, offset, whence) { return mod.#io_handler.seek_file(handle, offset, whence); },
+            file_random_access(handle) { return mod.#io_handler.file_random_access(handle); },
+            file_buffer_size(handle) { return mod.#io_handler.file_buffer_size(handle); },
+            file_buffer_ref(handle, i) { return mod.#io_handler.file_buffer_ref(handle, i); },
+            file_buffer_set(handle, i, x) { return mod.#io_handler.file_buffer_set(handle, i, x); },
+            delete_file(filename) { mod.#io_handler.delete_file(filename); }
+        };
+        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 ffi = {
+            procedure_to_extern(proc) {
+                return mod.#ffi_handler.procedure_to_extern(proc);
+            }
+        };
+        let imports = {
+          rt: SchemeModule.#rt,
+          abi, debug, io, ffi, ...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; }
+    set_ffi_handler(h) { this.#ffi_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(opts = {}) {
+        return await Scheme.reflect(this.exported_abi(), opts);
+    }
+}
+
+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')
+        return string_repr(obj);
+    return obj + '';
+}
diff --git a/chapter-7/hoot/reflect.wasm b/chapter-7/hoot/reflect.wasm
new file mode 100644
index 0000000..770c94c
Binary files /dev/null and b/chapter-7/hoot/reflect.wasm differ
diff --git a/chapter-7/hoot/wtf8.wasm b/chapter-7/hoot/wtf8.wasm
new file mode 100644
index 0000000..ca1079d
Binary files /dev/null and b/chapter-7/hoot/wtf8.wasm differ
diff --git a/chapter-7/index.html b/chapter-7/index.html
new file mode 100644
index 0000000..17e5f54
--- /dev/null
+++ b/chapter-7/index.html
@@ -0,0 +1,11 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <title>FRP color picker</title>
+    <link rel="stylesheet" type="text/css" href="propagators.css"/>
+    <script type="text/javascript" src="hoot/reflect.js"></script>
+    <script type="text/javascript" src="propagators.js"></script>
+  </head>
+  <body>
+  </body>
+</html>
diff --git a/chapter-7/manifest.scm b/chapter-7/manifest.scm
new file mode 100644
index 0000000..237372a
--- /dev/null
+++ b/chapter-7/manifest.scm
@@ -0,0 +1,24 @@
+(use-modules (guix git-download)
+             (guix packages)
+             (gnu packages base)
+             (gnu packages guile)
+             (gnu packages guile-xyz))
+
+(define guile-hoot-next
+  (let ((commit "addbcd33158265a6c00e87aeb89d9c20f57bce1e")
+        (revision "1"))
+    (package
+      (inherit guile-hoot)
+      (version (git-version "0.4.1" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://gitlab.com/spritely/guile-hoot.git")
+                      (commit commit)))
+                (file-name (git-file-name "guile-hoot" version))
+                (sha256
+                 (base32 "1zv8w9pawr3wajlcr862x21198x421fa47qbfkblnidiknfgs7sa"))))
+      (arguments
+       '(#:tests? #f)))))
+
+(packages->manifest (list guile-next guile-hoot-next gnu-make))
diff --git a/chapter-7/propagators.css b/chapter-7/propagators.css
new file mode 100644
index 0000000..1b803e2
--- /dev/null
+++ b/chapter-7/propagators.css
@@ -0,0 +1,38 @@
+body {
+    font-family: sans;
+    background-color: #fbfbfb;
+    margin: auto;
+    max-width: 20em;
+}
+
+h1 {
+    text-align: center;
+}
+
+.preview {
+    width: 50%;
+    margin-left: auto;
+    margin-right: auto;
+}
+
+.hex {
+    text-align: center;
+    margin-top: 0.5em;
+}
+
+fieldset {
+    margin-bottom: 1em;
+    margin-top: 1em;
+}
+
+.color-block {
+    width: 100%;
+    aspect-ratio: 1;
+    border: 1px black solid;
+}
+
+.slider {
+    display: grid;
+    grid-template-columns: 35% max-content;
+    grip-gap: 1em;
+}
diff --git a/chapter-7/propagators.js b/chapter-7/propagators.js
new file mode 100644
index 0000000..1477a86
--- /dev/null
+++ b/chapter-7/propagators.js
@@ -0,0 +1,91 @@
+window.addEventListener("load", async () => {
+  await Scheme.load_main("propagators.wasm", {
+    reflect_wasm_dir: "hoot",
+    user_imports: {
+      window: {
+        scrollTo: window.scrollTo,
+        setTimeout: setTimeout,
+        getWindow: function() {
+          return window;
+        },
+      },
+      document: {
+        makeTextNode: Document.prototype.createTextNode.bind(document),
+        makeElement: Document.prototype.createElement.bind(document),
+        getElementById: Document.prototype.getElementById.bind(document),
+        getBody: function() {
+          return document.body;
+        },
+      },
+      element: {
+        firstChild: (elem) => elem.firstChild,
+        nextSibling: (elem) => elem.nextSibling,
+        appendChild: function(parent, child) {
+          return parent.appendChild(child);
+        },
+        setAttribute: function(elem, attr, value) {
+          return elem.setAttribute(attr, value);
+        },
+        getAttribute: function(elem, attr) {
+          return elem.getAttribute(attr);
+        },
+        getProperty: function(elem, property, dflt) {
+          // The little + '' ensures the value is a string
+          return value = elem[property] + '';
+        },
+        setProperty: function(elem, property, new_value) {
+          elem[property] = new_value;
+        },
+        getValue: (elem) => elem.value,
+        setValue: (elem, val) => elem.value = val,
+        remove: function(elem) {
+          elem.remove();
+        },
+        replaceWith: (oldElem, newElem) => oldElem.replaceWith(newElem),
+        addEventListener: function(elem, name, f) {
+          elem.addEventListener(name, f);
+        },
+      },
+      websocket: {
+        create: function(uri) {
+          ws = new WebSocket(uri);
+          return ws;
+        },
+        registerHandler: function(sock, handler, f) {
+          sock[handler] = function (event) {
+            if (handler == "onmessage") {
+              f(event.data);
+            } else {
+              f(event);
+            }
+          };
+        },
+        send: function(sock, message) {
+          sock.send(message);
+        },
+      },
+      notification: {
+        create: function(text) {
+          return new Notification(text);
+        },
+        permission: function() {
+          return Notification.permission;
+        },
+        requestPermission: Notification.requestPermission,
+      },
+      promise: {
+        on: function(promise, f) {
+          promise.then(f);
+        },
+      },
+      localStorage: {
+        getItem: (key) => localStorage.getItem(key) || "#f",
+        setItem: (key, value) => localStorage.setItem(key, value)
+      },
+      location: {
+        protocol: () => location.protocol,
+        hostname: () => location.hostname
+      }
+    }
+  });
+});
diff --git a/chapter-7/propagators.scm b/chapter-7/propagators.scm
new file mode 100644
index 0000000..db27a2e
--- /dev/null
+++ b/chapter-7/propagators.scm
@@ -0,0 +1,649 @@
+(use-modules (ice-9 match)
+             (srfi srfi-9)
+             (srfi srfi-9 gnu)
+             ((hoot hashtables) #:select (make-weak-key-hashtable
+                                          weak-key-hashtable-ref
+                                          weak-key-hashtable-set!))
+             ((hoot numbers) #:select (truncate))
+             (hoot ffi))
+
+(define-foreign make-element
+  "document" "makeElement"
+  (ref string) -> (ref extern))
+
+(define-foreign make-text-node
+  "document" "makeTextNode"
+  (ref string) -> (ref extern))
+
+(define-foreign get-element-by-id
+  "document" "getElementById"
+  (ref string) -> (ref null extern))
+
+(define-foreign first-child
+  "element" "firstChild"
+  (ref extern) -> (ref null extern))
+
+(define-foreign next-sibling
+  "element" "nextSibling"
+  (ref extern) -> (ref null extern))
+
+(define-foreign append-child!
+  "element" "appendChild"
+  (ref extern) (ref extern) -> (ref extern))
+
+(define-foreign attribute-ref
+  "element" "getAttribute"
+  (ref extern) (ref string) -> (ref string))
+
+(define-foreign set-attribute!
+  "element" "setAttribute"
+  (ref extern) (ref string) (ref string) -> none)
+
+(define-foreign property-ref
+  "element" "getProperty"
+  (ref extern) (ref string) -> (ref string))
+
+(define-foreign set-property!
+  "element" "setProperty"
+  (ref extern) (ref string) (ref string) -> none)
+
+(define-foreign value
+  "element" "getValue"
+  (ref extern) -> (ref string))
+
+(define-foreign set-value!
+  "element" "setValue"
+  (ref extern)  (ref string) -> none)
+
+(define-foreign add-event-listener!
+  "element" "addEventListener"
+  (ref extern) (ref string) (ref extern) -> none)
+
+(define-foreign remove!
+  "element" "remove"
+  (ref extern) -> none)
+
+(define-foreign replace-with!
+  "element" "replaceWith"
+  (ref extern) (ref extern) -> none)
+
+(define-foreign document-body
+  "document" "getBody"
+  -> (ref null extern))
+
+(define-foreign timeout
+  "window" "setTimeout"
+  (ref extern) f64 -> i32)
+
+(define (lset-adjoin = list . rest)
+  (define pred
+    (if (or (eq? = eq?) (eq? = eqv?))
+        =
+        (lambda (x y) (= y x))))
+  (let lp ((ans list) (rest rest))
+    (match rest
+      (() ans)
+      ((x . rest*)
+       (lp (if (member x ans pred)
+               ans
+               (cons x ans))
+           rest*)))))
+
+(define (any pred lst)
+  (let lp ((lst lst))
+    (match lst
+      (() #f)
+      ((x . rest)
+       (or (pred x) (lp rest))))))
+
+(define (every pred lst)
+  (let lp ((lst lst))
+    (match lst
+      (() #t)
+      ((x . rest)
+       (and (pred x) (lp rest))))))
+
+(define procedure->external*
+  (let ((cache (make-weak-key-hashtable)))
+    (lambda (proc)
+      (or (weak-key-hashtable-ref cache proc)
+          (let ((extern (procedure->external proc)))
+            (weak-key-hashtable-set! cache proc extern)
+            extern)))))
+(define (queue-task! thunk)
+  (timeout (procedure->external* thunk) 0.0))
+
+(define-record-type <nothing>
+  (make-nothing)
+  %nothing?)
+(define (print-nothing nothing port)
+  (display "#<nothing>" port))
+(set-record-type-printer! <nothing> print-nothing)
+(define nothing (make-nothing))
+(define (nothing? x) (eq? x nothing))
+
+(define-record-type <contradiction>
+  (make-contradiction details)
+  contradiction?
+  (details contradiction-details))
+
+(define (print-contradiction contradiction port)
+  (format port "#<contradiction ~a>"
+          (contradiction-details contradiction)))
+(set-record-type-printer! <contradiction> print-contradiction)
+
+(define contradiction (make-contradiction nothing))
+
+(define-record-type <relations>
+  (%make-relations name parent children)
+  relations?
+  (name relations-name)
+  (parent relations-parent)
+  (children relations-children set-relations-children!))
+
+(define (print-relations relations port)
+  (match relations
+    (($ <relations> name parent children)
+     (format port "#<relations ~a ↑ ~a ↓ ~a>"
+             name parent children))))
+(set-record-type-printer! <relations> print-relations)
+
+(define current-parent (make-parameter #f))
+
+(define (make-relations name)
+  (%make-relations name (current-parent) '()))
+
+(define (add-child! parent child)
+  (when parent
+    (set-relations-children! parent (cons child (relations-children parent)))))
+
+(define-record-type <cell>
+  (%make-cell relations neighbors content strongest
+              equivalent? merge find-strongest handle-contradiction)
+  cell?
+  (relations cell-relations)
+  (neighbors cell-neighbors set-cell-neighbors!)
+  (content cell-content set-cell-content!)
+  (strongest cell-strongest set-cell-strongest!)
+  ;; Dispatch table:
+  (equivalent? cell-equivalent?)
+  (merge cell-merge)
+  (find-strongest cell-find-strongest)
+  (handle-contradiction cell-handle-contradiction))
+
+(define (print-cell cell port)
+  (match cell
+    (($ <cell> ($ <relations> name) _ _ strongest)
+     (display "#<cell " port)
+     (display name port)
+     (display " " port)
+     (display strongest port)
+     (display ">" port))))
+(set-record-type-printer! <cell> print-cell)
+
+(define-record-type <propagator>
+  (%make-propagator relations inputs outputs activate)
+  propagator?
+  (relations propagator-relations)
+  (inputs propagator-inputs)
+  (outputs propagator-outputs)
+  (activate propagator-activate))
+
+(define (print-propagator propagator port)
+  (match propagator
+    (($ <propagator> ($ <relations> name) inputs outputs)
+     (display "#<propagator " port)
+     (display name port)
+     (display " " port)
+     (display inputs port)
+     (display " -> " port)
+     (display outputs port)
+     (display ">" port))))
+(set-record-type-printer! <propagator> print-propagator)
+
+(define default-equivalent? equal?)
+;; But what about partial information???
+(define (default-merge old new) new)
+(define (default-find-strongest content) content)
+(define (default-handle-contradiction cell) (values))
+
+(define* (make-cell name #:key
+                    (equivalent? default-equivalent?)
+                    (merge default-merge)
+                    (find-strongest default-find-strongest)
+                    (handle-contradiction default-handle-contradiction))
+  (let ((cell (%make-cell (make-relations name) '() nothing nothing
+                          equivalent? merge find-strongest
+                          handle-contradiction)))
+    (add-child! (current-parent) cell)
+    cell))
+
+(define (cell-name cell)
+  (relations-name (cell-relations cell)))
+
+(define (add-cell-neighbor! cell neighbor)
+  (set-cell-neighbors! cell (lset-adjoin eq? (cell-neighbors cell) neighbor)))
+
+(define (test-cell-content! cell)
+  (match cell
+    (($ <cell> _ neighbors content strongest equivalent? _
+               find-strongest handle-contradiction)
+     (let ((strongest* (find-strongest content)))
+       (cond
+        ((equivalent? strongest strongest*)
+         (set-cell-strongest! cell strongest*))
+        ((contradiction? strongest*)
+         (set-cell-strongest! cell strongest*)
+         (handle-contradiction cell))
+        (else
+         (set-cell-strongest! cell strongest*)
+         (for-each alert-propagator! neighbors)))))))
+
+(define (add-cell-content! cell new)
+  (let ((merge (cell-merge cell)))
+    (set-cell-content! cell (merge (cell-content cell) new))
+    (test-cell-content! cell)))
+
+(define (alert-propagator! propagator)
+  (queue-task! (propagator-activate propagator)))
+
+(define (make-propagator name inputs outputs activate)
+  (let ((propagator (%make-propagator (make-relations name)
+                                      inputs outputs activate)))
+    (add-child! (current-parent) propagator)
+    (for-each (lambda (cell)
+                (add-cell-neighbor! cell propagator))
+              inputs)
+    (alert-propagator! propagator)
+    propagator))
+
+(define (unusable-value? x)
+  (or (nothing? x) (contradiction? x)))
+
+(define (primitive-propagator name f)
+  (match-lambda*
+    ((inputs ... output)
+     (define (activate)
+       (let ((args (map cell-strongest inputs)))
+         (unless (any unusable-value? args)
+           (add-cell-content! output (apply f args)))))
+     (make-propagator name inputs (list output) activate))))
+
+(define (compound-propagator name inputs outputs to-build)
+  (let ((built? #f))
+    (define (maybe-build)
+      (unless (or built?
+                  (and (not (null? inputs))
+                       (every unusable-value? (map cell-strongest inputs))))
+        (parameterize ((current-parent (propagator-relations propagator)))
+          (to-build)
+          (set! built? #t))))
+    (define propagator (make-propagator name inputs outputs maybe-build))
+    propagator))
+
+(define (constraint-propagator name cells to-build)
+  (compound-propagator name cells cells to-build))
+
+(define-record-type <reactive-id>
+  (%make-reactive-id name clock)
+  reactive-id?
+  (name reactive-id-name)
+  (clock reactive-id-clock set-reactive-id-clock!))
+
+(define (print-reactive-id id port)
+  (display "#<reactive-id " port)
+  (display (reactive-id-name id) port)
+  (display ">" port))
+(set-record-type-printer! <reactive-id> print-reactive-id)
+
+(define (make-reactive-id name)
+  (%make-reactive-id name 0))
+
+(define (reactive-id-tick! id)
+  (let ((t (1+ (reactive-id-clock id))))
+    (set-reactive-id-clock! id t)
+    `((,id . ,t))))
+
+;; Partial value structure for FRP
+(define-record-type <ephemeral>
+  (make-ephemeral value timestamps)
+  ephemeral?
+  (value ephemeral-value)
+  ;; Association list mapping identity -> time
+  (timestamps ephemeral-timestamps))
+
+(define (ephemeral-fresher? a b)
+  (let ((b-inputs (ephemeral-timestamps b)))
+    (let lp ((a-inputs (ephemeral-timestamps a)))
+      (match a-inputs
+        (() #t)
+        (((key . a-time) . rest)
+         (match (assq-ref b-inputs key)
+           (#f (lp rest))
+           (b-time
+            (and (> a-time b-time)
+                 (lp rest)))))))))
+
+(define (merge-ephemeral-timestamps ephemerals)
+  (let lp ((ephemerals ephemerals) (timestamps '()))
+    (match ephemerals
+      (() timestamps)
+      ((($ <ephemeral> _ timestamps*) . rest)
+       (let lp2 ((timestamps* timestamps*) (timestamps timestamps))
+         (match timestamps*
+           (() (lp rest timestamps))
+           (((and timestamp (key . time)) . rest)
+            (match (assq-ref timestamps key)
+              (#f (lp2 rest (cons timestamp timestamps)))
+              (time*
+               (if (= time time*)
+                   (lp2 rest timestamps)
+                   #f)))))))
+      ((_ . rest) (lp rest timestamps)))))
+
+(define (merge-ephemerals old new)
+  (cond
+   ((nothing? old) new)
+   ((nothing? new) old)
+   (else (if (ephemeral-fresher? new old) new old))))
+
+(define (ephemeral-wrap proc)
+  (match-lambda*
+    ((and ephemerals (($ <ephemeral> args) ...))
+     (match (merge-ephemeral-timestamps ephemerals)
+       (#f nothing)
+       (timestamps (make-ephemeral (apply proc args) timestamps))))))
+
+(define* (primitive-reactive-propagator name proc)
+  (primitive-propagator name (ephemeral-wrap proc)))
+
+(define-syntax-rule (define-primitive-reactive-propagator name proc)
+  (define name (primitive-reactive-propagator 'name proc)))
+
+(define (r:property input elem property)
+  (let ((property (symbol->string property)))
+    (define (activate)
+      (match (cell-strongest input)
+        (($ <ephemeral> val)
+         (set-property! elem property (obj->string val)))
+        ;; Ignore unusable values.
+        (_ (values))))
+    (make-propagator 'property (list input) '() activate)))
+
+(define-record-type <binding>
+  (make-binding id cell default group)
+  binding?
+  (id binding-id)
+  (cell binding-cell)
+  (default binding-default)
+  (group binding-group))
+
+(define* (binding id cell #:key (default nothing) (group '()))
+  (make-binding id cell default group))
+
+(define (obj->string obj)
+  (if (string? obj)
+      obj
+      (call-with-output-string
+        (lambda (port)
+          (write obj port)))))
+
+(define (string->obj str)
+  (call-with-input-string str read))
+
+(define* (r:binding binding elem)
+  (match binding
+    (($ <binding> id cell default group)
+     (define (update new)
+       (unless (nothing? new)
+         (let ((timestamp (reactive-id-tick! id)))
+           (add-cell-content! cell (make-ephemeral new timestamp))
+           ;; Freshen timestamps for all cells in the same group.
+           (for-each (lambda (other)
+                       (unless (eq? other cell)
+                         (match (cell-strongest other)
+                           (($ <ephemeral> val)
+                            (add-cell-content! other (make-ephemeral val timestamp)))
+                           (_ #f))))
+                     group))))
+     ;; Sync the element's value with the cell's value.
+     (define (activate)
+       (match (cell-strongest cell)
+         (($ <ephemeral> val)
+          (set-value! elem (obj->string val)))
+         (_ (values))))
+     ;; Initialize element value with the default value.
+     (update default)
+     ;; Sync the cell's value with the element's value.
+     (add-event-listener! elem "input"
+                          (procedure->external
+                           (lambda (event)
+                             (update (string->obj (value elem))))))
+     (make-propagator 'r:binding (list cell) '() activate))))
+
+(define (cell->elem cell)
+  (let ((exp (cell-strongest cell)))
+    (if (unusable-value? exp)
+        (make-text-node "")
+        (sxml->dom exp))))
+
+(define (sxml->dom exp)
+  (match exp
+    ;; The simple case: a string representing a text node.
+    ((? string? str)
+     (make-text-node str))
+    ((? number? num)
+     (make-text-node (number->string num)))
+    ;; A cell containing SXML (or nothing)
+    ((? cell? cell)
+     (let ((elem (cell->elem cell)))
+       (r:dom cell elem)
+       elem))
+    ;; An element tree.  The first item is the HTML tag.
+    (((? symbol? tag) . body)
+     ;; Create a new element with the given tag.
+     (let ((elem (make-element (symbol->string tag))))
+       (define (add-children children)
+         ;; Recursively call sxml->dom for each child node and
+         ;; append it to elem.
+         (for-each (lambda (child)
+                     (append-child! elem (sxml->dom child)))
+                   children))
+       (match body
+         ((('@ . attrs) . children)
+          (for-each (lambda (attr)
+                      (match attr
+                        (((? symbol? name) (? string? val))
+                         (set-attribute! elem
+                                         (symbol->string name)
+                                         val))
+                        (((? symbol? name) (? number? val))
+                         (set-attribute! elem
+                                         (symbol->string name)
+                                         (number->string val)))
+                        (((? symbol? name) (? cell? cell))
+                         (r:property cell elem name))
+                        ;; The value attribute is special and can be
+                        ;; used to setup a 2-way data binding.
+                        (('value (? binding? binding))
+                         (r:binding binding elem))))
+                    attrs)
+          (add-children children))
+         (children (add-children children)))
+       elem))))
+
+(define (r:dom input elem)
+  (define (activate)
+    (match (cell-strongest input)
+      (($ <ephemeral> exp)
+       (let ((new (sxml->dom exp)))
+         (replace-with! elem new)
+         (set! elem new)))
+      (_ (values))))
+  (make-propagator 'dom (list input) '() activate))
+
+(define-record-type <rgb-color>
+  (rgb-color r g b)
+  rgb-color?
+  (r rgb-color-r)
+  (g rgb-color-g)
+  (b rgb-color-b))
+
+(define-record-type <hsv-color>
+  (hsv-color h s v)
+  hsv-color?
+  (h hsv-color-h)
+  (s hsv-color-s)
+  (v hsv-color-v))
+
+(define (assert-real x)
+  (unless (real? x)
+    (error "expected real number" x)))
+
+(define (fmod x y)
+  (assert-real x)
+  (assert-real y)
+  (- x (* (truncate (/ x y)) y)))
+
+(define (rgb->hsv rgb)
+  (match rgb
+    (($ <rgb-color> r g b)
+     (let* ((cmax (max r g b))
+            (cmin (min r g b))
+            (delta (- cmax cmin)))
+       (hsv-color (cond
+                   ((= delta 0.0) 0.0)
+                   ((= cmax r)
+                    (let ((h (* 60.0 (fmod (/ (- g b) delta) 6.0))))
+                      (if (< h 0.0) (+ h 360.0) h)))
+                   ((= cmax g) (* 60.0 (+ (/ (- b r) delta) 2.0)))
+                   ((= cmax b) (* 60.0 (+ (/ (- r g) delta) 4.0))))
+                  (if (= cmax 0.0)
+                      0.0
+                      (/ delta cmax))
+                  cmax)))))
+
+(define (hsv->rgb hsv)
+  (match hsv
+    (($ <hsv-color> h s v)
+     (let* ((h' (/ h 60.0))
+            (c (* v s))
+            (x (* c (- 1.0 (abs (- (fmod h' 2.0) 1.0)))))
+            (m (- v c)))
+       (define-values (r' g' b')
+         (cond
+          ((<= 0.0 h 60.0) (values c x 0.0))
+          ((<= h 120.0) (values x c 0.0))
+          ((<= h 180.0) (values 0.0 c x))
+          ((<= h 240.0) (values 0.0 x c))
+          ((<= h 300.0) (values x 0.0 c))
+          ((<= h 360.0) (values c 0.0 x))))
+       (rgb-color (+ r' m) (+ g' m) (+ b' m))))))
+
+(define (uniform->byte x)
+  (inexact->exact (round (* x 255.0))))
+
+(define (rgb->int rgb)
+  (match rgb
+    (($ <rgb-color> r g b)
+     (+ (* (uniform->byte r) (ash 1 16))
+        (* (uniform->byte g) (ash 1 8))
+        (uniform->byte b)))))
+
+(define (rgb->hex-string rgb)
+  (list->string
+   (cons #\#
+         (let lp ((i 0) (n (rgb->int rgb)) (out '()))
+           (if (= i 6)
+               out
+               (lp (1+ i) (ash n -4)
+                   (cons (integer->char
+                          (let ((digit (logand n 15)))
+                            (+ (if (< digit 10)
+                                   (char->integer #\0)
+                                   (- (char->integer #\a) 10))
+                               digit)))
+                         out)))))))
+
+(define (rgb-hex->style hex)
+  (string-append "background-color: " hex ";"))
+
+(define-primitive-reactive-propagator r:rgb-color rgb-color)
+(define-primitive-reactive-propagator r:rgb-color-r rgb-color-r)
+(define-primitive-reactive-propagator r:rgb-color-g rgb-color-g)
+(define-primitive-reactive-propagator r:rgb-color-b rgb-color-b)
+(define-primitive-reactive-propagator r:hsv-color hsv-color)
+(define-primitive-reactive-propagator r:hsv-color-h hsv-color-h)
+(define-primitive-reactive-propagator r:hsv-color-s hsv-color-s)
+(define-primitive-reactive-propagator r:hsv-color-v hsv-color-v)
+(define-primitive-reactive-propagator r:rgb->hsv rgb->hsv)
+(define-primitive-reactive-propagator r:hsv->rgb hsv->rgb)
+(define-primitive-reactive-propagator r:rgb->hex-string rgb->hex-string)
+(define-primitive-reactive-propagator r:rgb-hex->style rgb-hex->style)
+
+(define (r:components<->rgb r g b rgb)
+  (define (build)
+    (r:rgb-color r g b rgb)
+    (r:rgb-color-r rgb r)
+    (r:rgb-color-g rgb g)
+    (r:rgb-color-b rgb b))
+  (constraint-propagator 'r:components<->rgb (list r g b rgb) build))
+
+(define (r:components<->hsv h s v hsv)
+  (define (build)
+    (r:hsv-color h s v hsv)
+    (r:hsv-color-h hsv h)
+    (r:hsv-color-s hsv s)
+    (r:hsv-color-v hsv v))
+  (constraint-propagator 'r:components<->hsv (list h s v hsv) build))
+
+(define (r:rgb<->hsv rgb hsv)
+  (define (build)
+    (r:rgb->hsv rgb hsv)
+    (r:hsv->rgb hsv rgb))
+  (constraint-propagator 'r:components<->hsv (list rgb hsv) build))
+
+(define (render exp)
+  (append-child! (document-body) (sxml->dom exp)))
+
+(define* (slider id name min max default #:optional (step "any"))
+  `(div (@ (class "slider"))
+        (label (@ (for ,id)) ,name)
+        (input (@ (id ,id) (type "range")
+                  (min ,min) (max ,max) (step ,step)
+                  (value ,default)))))
+
+(define (uslider id name default) ; [0,1] slider
+  (slider id name 0 1 default))
+
+(define-syntax-rule (with-cells (name ...) body . body*)
+  (let ((name (make-cell 'name #:merge merge-ephemerals)) ...) body . body*))
+
+(with-cells (r g b rgb h s v hsv hex style)
+  (define color (make-reactive-id 'color))
+  (define rgb-group (list r g b))
+  (define hsv-group (list h s v))
+  (r:components<->rgb r g b rgb)
+  (r:components<->hsv h s v hsv)
+  (r:rgb<->hsv rgb hsv)
+  (r:rgb->hex-string rgb hex)
+  (r:rgb-hex->style hex style)
+  (render
+   `(div
+     (h1 "Color Picker")
+     (div (@ (class "preview"))
+          (div (@ (class "color-block") (style ,style)))
+          (div (@ (class "hex")) ,hex))
+     (fieldset
+      (legend "RGB")
+      ,(uslider "red" "Red"
+                (binding color r #:default 1.0 #:group rgb-group))
+      ,(uslider "green" "Green"
+                (binding color g #:default 0.0 #:group rgb-group))
+      ,(uslider "blue" "Blue"
+                (binding color b #:default 1.0 #:group rgb-group)))
+     (fieldset
+      (legend "HSV")
+      ,(slider "hue" "Hue" 0 360 (binding color h #:group hsv-group))
+      ,(uslider "saturation" "Saturation" (binding color s #:group hsv-group))
+      ,(uslider "value" "Value" (binding color v #:group hsv-group))))))
-- 
cgit v1.2.3