diff options
author | David Thompson <dthompson2@worcester.edu> | 2024-07-05 10:38:45 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2024-07-05 10:39:06 -0400 |
commit | b33079617253f844db5d7352280504b8f1851483 (patch) | |
tree | 1772458c0bba9938ef7db823620fdca550dbceae /chapter-7 | |
parent | 6c4ccbcc4b32fba80280cfbea253152acdbefec2 (diff) |
Add propagator experiment.
Diffstat (limited to 'chapter-7')
-rw-r--r-- | chapter-7/.dir-locals.el | 3 | ||||
-rw-r--r-- | chapter-7/Makefile | 8 | ||||
-rw-r--r-- | chapter-7/hoot/reflect.js | 738 | ||||
-rw-r--r-- | chapter-7/hoot/reflect.wasm | bin | 0 -> 5196 bytes | |||
-rw-r--r-- | chapter-7/hoot/wtf8.wasm | bin | 0 -> 1071 bytes | |||
-rw-r--r-- | chapter-7/index.html | 11 | ||||
-rw-r--r-- | chapter-7/manifest.scm | 24 | ||||
-rw-r--r-- | chapter-7/propagators.css | 38 | ||||
-rw-r--r-- | chapter-7/propagators.js | 91 | ||||
-rw-r--r-- | chapter-7/propagators.scm | 649 |
10 files changed, 1562 insertions, 0 deletions
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 Binary files differnew file mode 100644 index 0000000..770c94c --- /dev/null +++ b/chapter-7/hoot/reflect.wasm diff --git a/chapter-7/hoot/wtf8.wasm b/chapter-7/hoot/wtf8.wasm Binary files differnew file mode 100644 index 0000000..ca1079d --- /dev/null +++ b/chapter-7/hoot/wtf8.wasm 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)))))) |