26 Commits

Author SHA1 Message Date
3003c8a069 HS E37 step 5: hs-tokenize-template + template routing in hs-tokens-of
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 12s
Add hs-tokenize-template: scans " as single STRING token, ${ ... }
as dollar+brace+inner-tokens (inner tokenized with hs-tokenize), and
} as brace-close. Update hs-tokens-of to call hs-tokenize-template
when :template keyword arg is passed. Unlocks tests 1 and 15.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 19:08:38 +00:00
8c62137d32 HS E37 step 2: extend read-string escapes + unterminated/hex errors
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Add \r \b \f \v and \xNN escape handling to read-string. Use
char-from-code for non-SX-literal chars. Throw "Unterminated string"
on EOF inside a string literal. Throw "Invalid hexadecimal escape: \x"
on bad \xNN. Add hs-hex-digit? and hs-hex-val helpers. Unlocks
tests 2, 6, 13, 14 once generator lands.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 19:03:03 +00:00
8ac669c739 HS E37 step 1: hs-api-tokens + stream/token helpers in runtime.sx
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Add hs-eof-sentinel, hs-op-type, hs-raw->api-token, hs-tokens-of,
hs-stream-token, hs-stream-consume, hs-stream-has-more, and the
three token accessors (hs-token-type, hs-token-value, hs-token-op?).
No test delta yet — API-only, generator comes in step 6.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 18:56:26 +00:00
912649c426 HS-plan: log in-expression filter semantics done +1
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 11s
2026-04-25 18:35:48 +00:00
67a5f13713 HS: in-expression filter semantics (+1 test)
`1 in [1, 2, 3]` must return (list 1) not true. Root cause: in? compiled
to hs-contains? which returns boolean for scalar items. Fix: new hs-in?
returns filtered list; new in-bool? operator for is/am-in comparison
contexts so those still return boolean. Parser generates in-bool? for
`X is in Y` / `X am in Y`; plain `in` keeps in? → list return.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 18:35:26 +00:00
db8d7aca91 HS-plan: log cluster 22 done +1; sync scoreboard
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
- Mark cluster 22 done (+1): can refer to function in init blocks
- Scoreboard: merged 1280→1302 (+22 from stale rows 22/29/32/33/34/35)
- Fix stale rows: clusters 29 partial, 32 done, 33 partial+4, 34 partial+7, 35 done

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 17:58:31 +00:00
d31565d556 HS cluster 22: simplify win-call emit + def→window + init-blocks test (+1)
- Remove guard wrapper from hs-win-call emit (direct call is sufficient now)
- def command also registers fn on window[name] so hs-win-call finds it
- Generator: fix \"-escaped quotes in hs-compile string literal (was splitting "here" into three SX nodes)
- Hand-rolled deftest for 'can refer to function in init blocks' now passes

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 17:55:32 +00:00
337c8265cd HS cluster 22: host-call-fn FFI + hs-win-call + def hoisting
- Add host-call-fn FFI primitive to test runner (calls SX lambdas or JS fns)
- Add hs-win-call runtime helper: looks up fn by name in window globals
- Compiler call case: emit guard-wrapped hs-win-call for bare (ref ...) calls
- Compiler method-call else: same guard pattern for non-dot method calls
- Compiler do case: hoist define forms before init/other forms (def hoisting)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 12:53:12 +00:00
a4538c71a8 HS-plan: log cluster 11/33 followups +2
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:52:37 +00:00
5ff2b7068e HS: cluster 11/33 followups (+2 tests)
Three orthogonal fixes that pick up tests now unblocked by earlier
cluster-34 (count filters) and cluster-35 (hs-method-call fallback) work:

(1) parser.sx parse-hide-cmd / parse-show-cmd — added `on` to the keyword
list that signals an implicit-`me` target. Without this, `on click 1
hide on click 2 show` silently parsed as `(hide nil)` because parse-expr
greedily started consuming `on` and returned nil. With the bail-out,
hide/show default to me when the next token is `on` (a sibling feature).

(2) runtime.sx hs-method-call fallback — when method isn't a built-in
collection op, look up obj[method] via host-get; if it's an SX-callable
(lambda) use apply, but if it's a JS-native function (e.g. cookies.clear
on the cookies Proxy) dispatch via `(apply host-call (cons obj (cons
method args)))` so the JS native receives the args correctly. SX
callable? returns false for JS-native function values, hence the split.

(3) generator hs-cleanup! — wrapped body in begin (fn body evaluates
only the last expression) and reset two pieces of mutable global runtime
state between tests: hs-set-default-hide-strategy! nil and
hs-set-log-all! false. The prior `can set default to custom strategy`
test (cluster 11) was leaking _hs-default-hide-strategy to subsequent
tests, breaking `hide element then show element retains original
display` because hs-hide-one! resolved its "display" strategy through
the leaked override.

Also added cluster-33 hand-roll for `basic clear cookie values work`
(uses the new method-call fallback to dispatch cookies.clear via
host-call).

hs-upstream-hide: 15/16 → 16/16. hs-upstream-expressions/cookies: 3/5
→ 4/5. Smoke 0-195 unchanged at 172/195.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:52:02 +00:00
f011d01b49 HS-plan: log cluster 35 done +3
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:38:02 +00:00
122053eda3 HS: namespaced def + script-tag global functions (+3 tests)
Runtime: hs-method-call gains a fallback case — when method isn't one of
the built-in collection ops (map/push/filter/join/indexOf), look up the
method name as a property on obj via host-get; if the value is callable,
invoke via apply with the call args. This makes namespaced calls like
`utils.foo()` work when utils is an SX dict whose foo entry is an SX fn.

Generator: hand-rolled deftests for the 3 cluster-35 tests:
- `is called synchronously` and `can call asynchronously`: pre-evaluate
  the script-tag def via `(eval-expr-cek (hs-to-sx (first (hs-parse
  (hs-tokenize "def foo() ... end")))))` so foo lands in the global eval
  env, then build a click div via dom-set-attr + hs-boot-subtree! and
  exercise it via dom-dispatch click.
- `functions can be namespaced`: hand-build `(define utils (dict))` then
  `(host-set! utils "foo" __utils_foo)` (the def is registered under a
  fresh sym since the parser doesn't yet support `def utils.foo()` dotted
  names), and rely on the new hs-method-call fallback to dispatch
  `utils.foo()` through host-get/apply.

Removed the 3 def entries from SKIP_TEST_NAMES.

hs-upstream-def: 24/27 → 27/27. Smoke 0-195 unchanged at 172/195.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:37:39 +00:00
7bbffa0401 HS-plan: log cluster 34 elsewhere done +2
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:27:04 +00:00
3044a16817 HS: elsewhere / from elsewhere modifier (+2 tests)
Parser: parse-on-feat now consumes `elsewhere` (or `from elsewhere`) as
a modifier between event-name and source. When matched, sets a flag and
emits :elsewhere true on parts. The `from elsewhere` form peeks one
token ahead before consuming both keywords so plain `from #x` continues
to parse as a source expression.

Compiler: scan-on threads elsewhere?; when present, target becomes
(dom-body) (so the listener attaches to body and bubbles see all clicks)
and the handler body is wrapped with `(when (not (host-call me "contains"
(host-get event "target"))) BODY)` so the handler fires only when the
click originated outside the activated element.

Generator: dropped supports "elsewhere" modifier and supports "from
elsewhere" modifier from skip-list.

hs-upstream-on: 48/70 → 50/70. Smoke 0-195 unchanged at 172/195.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:26:30 +00:00
a8a798c592 HS-plan: log cluster 34 done +5 (partial)
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:09:11 +00:00
19c97989d7 HS: count-filtered events + first modifier (+5 tests)
Parser: parse-on-feat now consumes `first` keyword before event-name (sets
count-min/max to 1) and a count expression after event-name — `N` (single),
`N to M` (range), `N and on` (unbounded above). Number tokens are coerced
via parse-number. Emits :count-filter {"min" N "max" M | -1} part.

Compiler: scan-on threads count-filter-info; the handler binding wraps the
fn body in a let-bound __hs-count counter. Each event fire increments the
counter and (when count is in range) executes the original body. Each
on-clause registers an independent handler with its own counter, so
`on click 1 ... on click 2 ... on click 3` produces three handlers that
fire on their respective Nth click (mix-ranges test).

Generator: dropped 5 cluster-34 tests from skip-list — `can filter events
based on count`, `... count range`, `... unbounded count range`, `can mix
ranges`, `on first click fires only once`.

hs-upstream-on: 43/70 → 48/70. Smoke 0-195 unchanged at 172/195.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 12:08:40 +00:00
ff38499bd5 HS-plan: log cluster 29 done +2 (partial)
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 11:58:45 +00:00
e01a3baa5b HS: hyperscript:before:init / :after:init events (+2 tests)
integration.sx hs-activate! now wraps the activation block in a cancelable
hyperscript:before:init event (dispatched on the el via dom-dispatch which
returns the dispatchEvent boolean — true unless preventDefault was called).
On success it dispatches hyperscript:after:init at the end. Both events
bubble so listeners on a containing wa work-area receive them. Generator
gets two hand-rolled deftests that exercise the new dispatch via
hs-boot-subtree!: one captures both events into a list, the other
preventDefaults before:init and asserts data-hyperscript-powered is absent.

hs-upstream-core/bootstrap: 20/26 → 22/26. Smoke 0-195: 170 → 172.

Remaining 4 cluster-29 tests need stricter parser error-rejection
(hs-upstream-core/parser, parse-error event); larger than a single
cluster budget — leave as untranslated for now.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 11:58:19 +00:00
484b55281b HS-plan: claim cluster 29 hyperscript init events
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 11:55:32 +00:00
070a983848 HS-plan: log cluster 32 done +7
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 11:53:18 +00:00
13e0254261 HS: MutationObserver mock + on mutation dispatch (+7 tests)
Parser: parse-on-feat now consumes `of FILTER` after `mutation` event-name,
where FILTER is `attributes`/`childList`/`characterData` ident or `@a [or @b]*`
attr-token chain. Emits :of-filter dict on parts. Compiler: scan-on threads
of-filter-info; mutation event-name emits `(do (hs-on …) (hs-on-mutation-attach!
TARGET MODE ATTRS))`. Runtime: hs-on-mutation-attach! constructs a real
MutationObserver with config matched to filter and dispatches "mutation" event
with records detail. Runner: HsMutationObserver mock with global registry;
prototype hooks on El.setAttribute/appendChild/removeChild/_setInnerHTML fire
matching observers synchronously, with __hsMutationActive guard preventing
recursion. Generator: dropped 7 mutation tests from skip-list, added
evaluate(setAttribute) and evaluate(appendChild) body patterns.

hs-upstream-on: 36/70 → 43/70. Smoke 0-195 unchanged at 170/195.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 11:52:54 +00:00
1340284bc8 HS-plan: claim cluster 32 MutationObserver
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 09:07:40 +00:00
4f98f5f89d hs: drain plan for blockers + Bucket E + F
Tracks the path from 1277/1496 (85.4%) to 100%. Records each blocker's
fix sketch, files in scope, and order of attack. Cluster #31 spec'd in
detail for the next focused sit-down.
2026-04-25 08:54:05 +00:00
84e7bc8a24 HS: cookie API (+3 tests, partial)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Three-part change: (a) tests/hs-run-filtered.js gets a per-test
__hsCookieStore Map, a globalThis.cookies Proxy, and a
document.cookie getter/setter that reads/writes the store. Per-test
reset clears the store. (b) generate-sx-tests.py declares cookies in
the test header and emits hand-rolled deftests for basic set / update
/ length-when-empty (the three tractable tests). (c) regenerated
spec/tests/test-hyperscript-behavioral.sx via mcp_hs_test.regen.

No .sx edits — `set cookies.foo to 'bar'` already compiles to
(dom-set-prop cookies "foo" "bar") which routes through host-set!.

Suite hs-upstream-expressions/cookies: 0/5 → 3/5.
Smoke 0-195 unchanged at 170/195.

Remaining `basic clear` (needs hs-method-call host-call dispatch) and
`iterate` (needs hs-for-each host-array recognition) need runtime.sx
edits — deferred to a future sx-tree worktree.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 08:44:25 +00:00
7735eb7512 HS-plan: cluster 32 MutationObserver blocked (env + scope)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
loops/hs worktree ships without the sx-tree MCP binary built; even
after running `dune build bin/mcp_tree.exe` this iteration, tools
don't surface mid-session and the block-sx-edit hook prevents raw
`.sx` edits. The cluster scope itself spans parser/compiler/runtime
plus JS mock plus generator skip-list, so even with sx-tree loaded
it's a multi-commit job for a dedicated worktree.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 00:33:18 +00:00
4e2e2c781c HS-plan: cluster 31 runtime null-safety blocked (Bucket-D scope)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
All 18 tests are SKIP (untranslated). Implementing the upstream
`error("HS")` helper requires coordinated work across the generator,
compiler (~17 emit paths), runtime (named-target helpers), and
function-call/possessive-base null guards. Doesn't fit a single
loop iteration — needs a dedicated design doc + worktree like the
Bucket E subsystems.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-25 00:01:24 +00:00
53 changed files with 1695 additions and 8945 deletions

View File

@@ -164,13 +164,16 @@
every?
catch-info
finally-info
having-info)
having-info
of-filter-info
count-filter-info
elsewhere?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (if source (hs-to-sx source) (quote me))))
((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (quote me)))))
(let
((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list))))
(let
@@ -178,30 +181,51 @@
(let
((raw-compiled (hs-to-sx stripped-body)))
(let
((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled)))
((compiled-body (let ((base (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) (if elsewhere? (list (quote when) (list (quote not) (list (quote host-call) (quote me) "contains" (list (quote host-get) (quote event) "target"))) base) base))))
(let
((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(let
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))))
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
(let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(if
(= event-name "intersection")
(list
(quote do)
on-call
(cond
((= event-name "mutation")
(list
(quote hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil)))
on-call)))))))))))
(quote do)
on-call
(list
(quote hs-on-mutation-attach!)
target
(if
of-filter-info
(get of-filter-info "type")
"any")
(if
of-filter-info
(let
((a (get of-filter-info "attrs")))
(if
a
(cons (quote list) a)
nil))
nil))))
((= event-name "intersection")
(list
(quote do)
on-call
(list
(quote
hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil))))
(true on-call))))))))))))
((= (first items) :from)
(scan-on
(rest (rest items))
@@ -210,7 +234,10 @@
every?
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :filter)
(scan-on
(rest (rest items))
@@ -219,7 +246,10 @@
every?
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :every)
(scan-on
(rest (rest items))
@@ -228,7 +258,10 @@
true
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :catch)
(scan-on
(rest (rest items))
@@ -237,7 +270,10 @@
every?
(nth items 1)
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :finally)
(scan-on
(rest (rest items))
@@ -246,7 +282,10 @@
every?
catch-info
(nth items 1)
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :having)
(scan-on
(rest (rest items))
@@ -255,6 +294,45 @@
every?
catch-info
finally-info
(nth items 1)
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :of-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
(nth items 1)
count-filter-info
elsewhere?))
((= (first items) :count-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
(nth items 1)
elsewhere?))
((= (first items) :elsewhere)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
(nth items 1)))
(true
(scan-on
@@ -264,8 +342,11 @@
every?
catch-info
finally-info
having-info)))))
(scan-on (rest parts) nil nil false nil nil nil)))))
having-info
of-filter-info
count-filter-info
elsewhere?)))))
(scan-on (rest parts) nil nil false nil nil nil nil nil false)))))
(define
emit-send
(fn
@@ -977,9 +1058,17 @@
(cons
(quote hs-method-call)
(cons obj (cons method args))))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args)))))
(if
(and
(list? dot-node)
(= (first dot-node) (quote ref)))
(list
(quote hs-win-call)
(nth dot-node 1)
(cons (quote list) args))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args))))))
((= head (quote string-postfix))
(list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote block-literal))
@@ -1149,7 +1238,12 @@
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?))
(list
(quote hs-contains?)
(quote hs-in?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote in-bool?))
(list
(quote hs-in-bool?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote of))
@@ -1633,7 +1727,19 @@
body)))
(nth compiled (- (len compiled) 1))
(rest (reverse compiled)))
(cons (quote do) compiled)))))
(let
((defs (filter (fn (c) (and (list? c) (> (len c) 0) (= (first c) (quote define)))) compiled))
(non-defs
(filter
(fn
(c)
(not
(and
(list? c)
(> (len c) 0)
(= (first c) (quote define)))))
compiled)))
(cons (quote do) (append defs non-defs)))))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log))
@@ -1741,7 +1847,13 @@
(make-symbol raw-fn)
(hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast)))))
(cons fn-expr args)))
(if
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(list
(quote hs-win-call)
(nth raw-fn 1)
(cons (quote list) args))
(cons fn-expr args))))
((= head (quote return))
(let
((val (nth ast 1)))
@@ -1929,26 +2041,39 @@
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
params
(quote let)
(list
(quote guard)
(list
(quote _e)
(quote _hs-def-val)
(list
(quote true)
(quote fn)
params
(list
(quote if)
(quote guard)
(list
(quote and)
(list (quote list?) (quote _e))
(quote _e)
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body)))))
(quote true)
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote _e))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body))))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
(nth ast 1)
(quote _hs-def-val))
(quote _hs-def-val))))))
((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval))
(let
@@ -1998,7 +2123,7 @@
(hs-to-sx (nth ast 1)))))
((= head (quote in?))
(list
(quote hs-contains?)
(quote hs-in?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote type-check))

View File

@@ -80,11 +80,14 @@
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
(when
(and src (not (= src prev)))
(hs-log-event! "hyperscript:init")
(dom-set-data el "hs-script" src)
(dom-set-data el "hs-active" true)
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))))))
(when
(dom-dispatch el "hyperscript:before:init" nil)
(hs-log-event! "hyperscript:init")
(dom-set-data el "hs-script" src)
(dom-set-data el "hs-active" true)
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))
(dom-dispatch el "hyperscript:after:init" nil))))))
;; ── Boot: scan entire document ──────────────────────────────────
;; Called once at page load. Finds all elements with _ attribute,

View File

@@ -495,7 +495,8 @@
(quote and)
(list (quote >=) left lo)
(list (quote <=) left hi)))))
((match-kw "in") (list (quote in?) left (parse-expr)))
((match-kw "in")
(list (quote in-bool?) left (parse-expr)))
((match-kw "really")
(do
(match-kw "equal")
@@ -571,7 +572,8 @@
(let
((right (parse-expr)))
(list (quote not) (list (quote =) left right))))))
((match-kw "in") (list (quote in?) left (parse-expr)))
((match-kw "in")
(list (quote in-bool?) left (parse-expr)))
((match-kw "empty") (list (quote empty?) left))
((match-kw "between")
(let
@@ -1555,7 +1557,7 @@
(fn
()
(let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote me))) (true (parse-expr)))))
(let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let
@@ -1566,7 +1568,7 @@
(fn
()
(let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote me))) (true (parse-expr)))))
(let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let
@@ -2601,63 +2603,77 @@
(fn
()
(let
((every? (match-kw "every")))
((every? (match-kw "every")) (first? (match-kw "first")))
(let
((event-name (parse-compound-event-name)))
(let
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
((count-filter (let ((mn nil) (mx nil)) (when first? (do (set! mn 1) (set! mx 1))) (when (= (tp-type) "number") (let ((n (parse-number (tp-val)))) (do (adv!) (set! mn n) (cond ((match-kw "to") (cond ((= (tp-type) "number") (let ((mv (parse-number (tp-val)))) (do (adv!) (set! mx mv)))) (true (set! mx n)))) ((match-kw "and") (cond ((match-kw "on") (set! mx -1)) (true (set! mx n)))) (true (set! mx n)))))) (if mn (dict "min" mn "max" mx) nil))))
(let
((source (if (match-kw "from") (parse-expr) nil)))
((of-filter (when (and (= event-name "mutation") (match-kw "of")) (cond ((and (= (tp-type) "ident") (or (= (tp-val) "attributes") (= (tp-val) "childList") (= (tp-val) "characterData"))) (let ((nm (tp-val))) (do (adv!) (dict "type" nm)))) ((= (tp-type) "attr") (let ((attrs (list (tp-val)))) (do (adv!) (define collect-or! (fn () (when (match-kw "or") (cond ((= (tp-type) "attr") (do (set! attrs (append attrs (list (tp-val)))) (adv!) (collect-or!))) (true (set! p (- p 1))))))) (collect-or!) (dict "type" "attrs" "attrs" attrs)))) (true nil)))))
(let
((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
(let
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
((elsewhere? (cond ((match-kw "elsewhere") true) ((and (= (tp-type) "keyword") (= (tp-val) "from") (let ((nxt (if (< (+ p 1) tok-len) (nth tokens (+ p 1)) nil))) (and nxt (= (get nxt "type") "keyword") (= (get nxt "value") "elsewhere")))) (do (adv!) (adv!) true)) (true false)))
(source (if (match-kw "from") (parse-expr) nil)))
(let
((body (parse-cmd-list)))
((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
(let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(let
((parts (list (quote on) event-name)))
((body (parse-cmd-list)))
(let
((parts (if every? (append parts (list :every true)) parts)))
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if
(match-kw "finally")
(parse-cmd-list)
nil)))
(match-kw "end")
(let
((parts (if flt (append parts (list :filter flt)) parts)))
((parts (list (quote on) event-name)))
(let
((parts (if source (append parts (list :from source)) parts)))
((parts (if every? (append parts (list :every true)) parts)))
(let
((parts (if having (append parts (list :having having)) parts)))
((parts (if flt (append parts (list :filter flt)) parts)))
(let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
((parts (if elsewhere? (append parts (list :elsewhere true)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
((parts (if source (append parts (list :from source)) parts)))
(let
((parts (append parts (list body))))
parts))))))))))))))))))
((parts (if count-filter (append parts (list :count-filter count-filter)) parts)))
(let
((parts (if of-filter (append parts (list :of-filter of-filter)) parts)))
(let
((parts (if having (append parts (list :having having)) parts)))
(let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let
((parts (append parts (list body))))
parts)))))))))))))))))))))))
(define
parse-init-feat
(fn

View File

@@ -82,14 +82,36 @@
observer)))))
;; Wait for CSS transitions/animations to settle on an element.
(define hs-init (fn (thunk) (thunk)))
(define
hs-on-mutation-attach!
(fn
(target mode attr-list)
(let
((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs")))
(cfg-childList (or (= mode "any") (= mode "childList")))
(cfg-characterData (or (= mode "any") (= mode "characterData"))))
(let
((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true)))
(when
(and (= mode "attrs") attr-list)
(dict-set! opts "attributeFilter" attr-list))
(let
((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records)))))
(let
((observer (host-new "MutationObserver" cb)))
(host-call observer "observe" target opts)
observer))))))
;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
(define hs-init (fn (thunk) (thunk)))
;; Toggle between two classes — exactly one is active at a time.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(begin
(define
hs-wait-for
@@ -102,21 +124,20 @@
(target event-name timeout-ms)
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after"
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; Find next sibling matching a selector (or any sibling).
(define
hs-toggle-between!
(fn
@@ -126,7 +147,7 @@
(do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
;; Find next sibling matching a selector (or any sibling).
;; Find previous sibling matching a selector.
(define
hs-toggle-style!
(fn
@@ -150,7 +171,7 @@
(dom-set-style target prop "hidden")
(dom-set-style target prop "")))))))
;; Find previous sibling matching a selector.
;; First element matching selector within a scope.
(define
hs-toggle-style-between!
(fn
@@ -162,7 +183,7 @@
(dom-set-style target prop val2)
(dom-set-style target prop val1)))))
;; First element matching selector within a scope.
;; Last element matching selector.
(define
hs-toggle-style-cycle!
(fn
@@ -183,7 +204,7 @@
(true (find-next (rest remaining))))))
(dom-set-style target prop (find-next vals)))))
;; Last element matching selector.
;; First/last within a specific scope.
(define
hs-take!
(fn
@@ -223,7 +244,6 @@
(dom-set-attr target name attr-val)
(dom-set-attr target name ""))))))))
;; First/last within a specific scope.
(begin
(define
hs-element?
@@ -335,6 +355,9 @@
(dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target)))))))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-add-to!
(fn
@@ -347,9 +370,7 @@
(append target (list value))))
(true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
;; Repeat forever (until break — relies on exception/continuation).
(define
hs-remove-from!
(fn
@@ -359,7 +380,10 @@
(filter (fn (x) (not (= x value))) target)
(host-call target "splice" (host-call target "indexOf" value) 1))))
;; Repeat forever (until break — relies on exception/continuation).
;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define
hs-splice-at!
(fn
@@ -383,10 +407,10 @@
(host-call target "splice" i 1))))
target))))
;; ── Fetch ───────────────────────────────────────────────────────
;; ── Type coercion ───────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define
hs-index
(fn
@@ -398,10 +422,10 @@
((string? obj) (nth obj key))
(true (host-get obj key)))))
;; ── Type coercion ───────────────────────────────────────────────
;; ── Object creation ─────────────────────────────────────────────
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define
hs-put-at!
(fn
@@ -423,10 +447,11 @@
((= pos "start") (host-call target "unshift" value)))
target)))))))
;; ── Object creation ─────────────────────────────────────────────
;; ── Behavior installation ───────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define
hs-dict-without
(fn
@@ -447,27 +472,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key)
out)))))
;; ── Behavior installation ───────────────────────────────────────
;; ── Measurement ─────────────────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define
hs-set-on!
(fn
(props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-ask
(fn
@@ -476,11 +501,6 @@
((w (host-global "window")))
(if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-answer
(fn
@@ -634,6 +654,10 @@
hs-query-all
(fn (sel) (host-call (dom-body) "querySelectorAll" sel)))
(define
hs-query-all-in
(fn
@@ -643,25 +667,21 @@
(hs-query-all sel)
(host-call target "querySelectorAll" sel))))
(define
hs-list-set
(fn
(lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; DOM query stub — sandbox returns empty list
(define
hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; DOM query stub — sandbox returns empty list
;; Method dispatch — obj.method(args)
(define
hs-query-last
(fn
@@ -669,11 +689,11 @@
(let
((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Method dispatch — obj.method(args)
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; Property-based is — check obj.key truthiness
(define
hs-last
(fn
@@ -681,7 +701,7 @@
(let
((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Property-based is — check obj.key truthiness
;; Array slicing (inclusive both ends)
(define
hs-repeat-times
(fn
@@ -699,7 +719,7 @@
((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1))))))))
(do-repeat 0)))
;; Array slicing (inclusive both ends)
;; Collection: sorted by
(define
hs-repeat-forever
(fn
@@ -715,7 +735,7 @@
((= signal "hs-continue") (do-forever))
(true (do-forever))))))
(do-forever)))
;; Collection: sorted by
;; Collection: sorted by descending
(define
hs-repeat-while
(fn
@@ -728,7 +748,7 @@
((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk)))))))
;; Collection: sorted by descending
;; Collection: split by
(define
hs-repeat-until
(fn
@@ -740,7 +760,7 @@
((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Collection: split by
;; Collection: joined by
(define
hs-for-each
(fn
@@ -760,7 +780,7 @@
((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining))))))))
(do-loop items))))
;; Collection: joined by
(begin
(define
hs-append
@@ -1515,6 +1535,25 @@
(hs-contains? (rest collection) item))))))
(true false))))
(define
hs-in?
(fn
(collection item)
(cond
((nil? collection) (list))
((list? collection)
(cond
((nil? item) (list))
((list? item)
(filter (fn (x) (hs-contains? collection x)) item))
((hs-contains? collection item) (list item))
(true (list))))
(true (list)))))
(define
hs-in-bool?
(fn (collection item) (not (hs-falsy? (hs-in? collection item)))))
(define
hs-is
(fn
@@ -2095,7 +2134,13 @@
-1
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0)))
(true nil))))
(true
(let
((fn-val (host-get obj method)))
(cond
((and fn-val (callable? fn-val)) (apply fn-val args))
(fn-val (apply host-call (cons obj (cons method args))))
(true nil)))))))
(define hs-beep (fn (v) v))
@@ -2474,3 +2519,129 @@
((nil? b) false)
((= a b) true)
(true (hs-dom-is-ancestor? a (dom-parent b))))))
(define
hs-win-call
(fn
(fn-name args)
(let ((fn (host-global fn-name))) (if fn (host-call-fn fn args) nil))))
;; ── E37 Tokenizer-as-API ─────────────────────────────────────────────
(define hs-eof-sentinel (fn () {:type "EOF" :value "<<<EOF>>>" :op false}))
(define
hs-op-type
(fn
(val)
(cond
((= val "+") "PLUS")
((= val "-") "MINUS")
((= val "*") "MULTIPLY")
((= val "/") "SLASH")
((= val "%") "PERCENT")
((= val "|") "PIPE")
((= val "!") "EXCLAMATION")
((= val "?") "QUESTION")
((= val "#") "POUND")
((= val "&") "AMPERSAND")
((= val ";") "SEMI")
((= val "=") "EQUALS")
((= val "<") "L_ANG")
((= val ">") "R_ANG")
((= val "<=") "LTE_ANG")
((= val ">=") "GTE_ANG")
((= val "==") "EQ")
((= val "===") "EQQ")
((= val "\\") "BACKSLASH")
(true (str "OP_" val)))))
(define
hs-raw->api-token
(fn
(tok)
(let
((raw-type (get tok "type"))
(raw-val (get tok "value")))
(let
((up-type
(cond
((or (= raw-type "ident") (= raw-type "keyword")) "IDENTIFIER")
((= raw-type "number") "NUMBER")
((= raw-type "string") "STRING")
((= raw-type "class") "CLASS_REF")
((= raw-type "id") "ID_REF")
((= raw-type "attr") "ATTRIBUTE_REF")
((= raw-type "style") "STYLE_REF")
((= raw-type "selector") "QUERY_REF")
((= raw-type "eof") "EOF")
((= raw-type "paren-open") "L_PAREN")
((= raw-type "paren-close") "R_PAREN")
((= raw-type "bracket-open") "L_BRACKET")
((= raw-type "bracket-close") "R_BRACKET")
((= raw-type "brace-open") "L_BRACE")
((= raw-type "brace-close") "R_BRACE")
((= raw-type "comma") "COMMA")
((= raw-type "dot") "PERIOD")
((= raw-type "colon") "COLON")
((= raw-type "op") (hs-op-type raw-val))
(true (str "UNKNOWN_" raw-type))))
(up-val
(cond
((= raw-type "class") (str "." raw-val))
((= raw-type "id") (str "#" raw-val))
((= raw-type "eof") "<<<EOF>>>")
(true raw-val)))
(is-op
(or
(= raw-type "paren-open")
(= raw-type "paren-close")
(= raw-type "bracket-open")
(= raw-type "bracket-close")
(= raw-type "brace-open")
(= raw-type "brace-close")
(= raw-type "comma")
(= raw-type "dot")
(= raw-type "colon")
(= raw-type "op"))))
{:type up-type :value up-val :op is-op}))))
(define
hs-tokens-of
(fn
(src &rest rest)
(let
((template? (and (> (len rest) 0) (= (first rest) :template)))
(raw (if template? (hs-tokenize-template src) (hs-tokenize src))))
{:source src
:list (map hs-raw->api-token raw)
:pos 0})))
(define
hs-stream-token
(fn
(s i)
(let
((lst (get s "list"))
(pos (get s "pos")))
(or (nth lst (+ pos i))
(hs-eof-sentinel)))))
(define
hs-stream-consume
(fn
(s)
(let
((tok (hs-stream-token s 0)))
(when
(not (= (get tok "type") "EOF"))
(dict-set! s "pos" (+ (get s "pos") 1)))
tok)))
(define
hs-stream-has-more
(fn (s) (not (= (get (hs-stream-token s 0) "type") "EOF"))))
(define hs-token-type (fn (tok) (get tok "type")))
(define hs-token-value (fn (tok) (get tok "value")))
(define hs-token-op? (fn (tok) (get tok "op")))

View File

@@ -28,6 +28,27 @@
(define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
(define
hs-hex-digit?
(fn
(c)
(or
(and (>= c "0") (<= c "9"))
(and (>= c "a") (<= c "f"))
(and (>= c "A") (<= c "F")))))
(define
hs-hex-val
(fn
(c)
(let
((code (char-code c)))
(cond
((and (>= code 48) (<= code 57)) (- code 48))
((and (>= code 65) (<= code 70)) (- code 55))
((and (>= code 97) (<= code 102)) (- code 87))
(true 0)))))
;; ── Keyword set ───────────────────────────────────────────────────
(define
@@ -308,7 +329,7 @@
()
(cond
(>= pos src-len)
nil
(error "Unterminated string")
(= (hs-cur) "\\")
(do
(hs-advance! 1)
@@ -318,15 +339,37 @@
((ch (hs-cur)))
(cond
(= ch "n")
(append! chars "\n")
(do (append! chars "\n") (hs-advance! 1))
(= ch "t")
(append! chars "\t")
(do (append! chars "\t") (hs-advance! 1))
(= ch "r")
(do (append! chars "\r") (hs-advance! 1))
(= ch "b")
(do (append! chars (char-from-code 8)) (hs-advance! 1))
(= ch "f")
(do (append! chars (char-from-code 12)) (hs-advance! 1))
(= ch "v")
(do (append! chars (char-from-code 11)) (hs-advance! 1))
(= ch "\\")
(append! chars "\\")
(do (append! chars "\\") (hs-advance! 1))
(= ch quote-char)
(append! chars quote-char)
:else (do (append! chars "\\") (append! chars ch)))
(hs-advance! 1)))
(do (append! chars quote-char) (hs-advance! 1))
(= ch "x")
(do
(hs-advance! 1)
(if
(and
(< (+ pos 1) src-len)
(hs-hex-digit? (hs-cur))
(hs-hex-digit? (hs-peek 1)))
(let
((d1 (hs-hex-val (hs-cur)))
(d2 (hs-hex-val (hs-peek 1))))
(append! chars (char-from-code (+ (* d1 16) d2)))
(hs-advance! 2))
(error "Invalid hexadecimal escape: \\x")))
:else
(do (append! chars "\\") (append! chars ch) (hs-advance! 1)))))
(loop))
(= (hs-cur) quote-char)
(hs-advance! 1)
@@ -623,4 +666,69 @@
:else (do (hs-advance! 1) (scan!)))))))
(scan!)
(hs-emit! "eof" nil pos)
tokens)))
;; ── Template-mode tokenizer (E37 API) ────────────────────────────────
;; Used by hs-tokens-of when :template flag is set.
;; Emits outer " chars as single STRING tokens; ${ ... } as $ { <inner-tokens> };
;; inner content is tokenized with the regular hs-tokenize.
(define
hs-tokenize-template
(fn
(src)
(let
((tokens (list)) (pos 0) (src-len (len src)))
(define t-cur (fn () (if (< pos src-len) (nth src pos) nil)))
(define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil)))
(define t-advance! (fn (n) (set! pos (+ pos n))))
(define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos))))
(define
scan-to-close!
(fn
(depth)
(when
(and (< pos src-len) (> depth 0))
(cond
(= (t-cur) "{")
(do (t-advance! 1) (scan-to-close! (+ depth 1)))
(= (t-cur) "}")
(when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1)))
:else (do (t-advance! 1) (scan-to-close! depth))))))
(define
scan-template!
(fn
()
(when
(< pos src-len)
(let
((ch (t-cur)))
(cond
(= ch "\"")
(do (t-emit! "string" "\"") (t-advance! 1) (scan-template!))
(and (= ch "$") (= (t-peek 1) "{"))
(do
(t-emit! "op" "$")
(t-advance! 1)
(t-emit! "brace-open" "{")
(t-advance! 1)
(let
((inner-start pos))
(scan-to-close! 1)
(let
((inner-src (slice src inner-start pos))
(inner-toks (hs-tokenize inner-src)))
(for-each
(fn (tok)
(when (not (= (get tok "type") "eof"))
(append! tokens tok)))
inner-toks))
(t-emit! "brace-close" "}")
(when (< pos src-len) (t-advance! 1)))
(scan-template!))
(hs-ws? ch)
(do (t-advance! 1) (scan-template!))
:else (do (t-advance! 1) (scan-template!)))))))
(scan-template!)
(t-emit! "eof" nil pos)
tokens)))

View File

@@ -1,176 +0,0 @@
;; lib/prolog/compiler.sx — clause compiler: parse-AST clauses → SX closures
;;
;; Each compiled clause is a lambda (fn (goal trail db cut-box k) bool)
;; that creates fresh vars, builds the instantiated head/body, and calls
;; pl-unify! + pl-solve! directly — no AST walk at solve time.
;;
;; Usage:
;; (pl-db-load! db (pl-parse src))
;; (pl-compile-db! db)
;; ; pl-solve-user! in runtime.sx automatically prefers compiled clauses
;; (pl-solve-once! db goal trail)
;; Collect unique variable names from a parse-AST clause into a dict.
(define
pl-cmp-vars-into!
(fn
(ast seen)
(cond
((not (list? ast)) nil)
((empty? ast) nil)
((= (first ast) "var")
(let
((name (nth ast 1)))
(when
(and (not (= name "_")) (not (dict-has? seen name)))
(dict-set! seen name true))))
((= (first ast) "compound")
(for-each (fn (a) (pl-cmp-vars-into! a seen)) (nth ast 2)))
((= (first ast) "clause")
(begin
(pl-cmp-vars-into! (nth ast 1) seen)
(pl-cmp-vars-into! (nth ast 2) seen))))))
;; Return list of unique var names in a clause (head + body, excluding _).
(define
pl-cmp-collect-vars
(fn
(clause)
(let ((seen {})) (pl-cmp-vars-into! clause seen) (keys seen))))
;; Create a fresh runtime var for each name in the list; return name->var dict.
(define
pl-cmp-make-var-map
(fn
(var-names)
(let
((m {}))
(for-each
(fn (name) (dict-set! m name (pl-mk-rt-var name)))
var-names)
m)))
;; Instantiate a parse-AST term using a pre-built var-map.
;; ("var" "_") always gets a fresh anonymous var.
(define
pl-cmp-build-term
(fn
(ast var-map)
(cond
((pl-var? ast) ast)
((not (list? ast)) ast)
((empty? ast) ast)
((= (first ast) "var")
(let
((name (nth ast 1)))
(if (= name "_") (pl-mk-rt-var "_") (dict-get var-map name))))
((or (= (first ast) "atom") (= (first ast) "num") (= (first ast) "str"))
ast)
((= (first ast) "compound")
(list
"compound"
(nth ast 1)
(map (fn (a) (pl-cmp-build-term a var-map)) (nth ast 2))))
((= (first ast) "clause")
(list
"clause"
(pl-cmp-build-term (nth ast 1) var-map)
(pl-cmp-build-term (nth ast 2) var-map)))
(true ast))))
;; Compile one parse-AST clause to a lambda.
;; Pre-computes var names at compile time; creates fresh vars per call.
(define
pl-compile-clause
(fn
(clause)
(let
((var-names (pl-cmp-collect-vars clause))
(head-ast (nth clause 1))
(body-ast (nth clause 2)))
(fn
(goal trail db cut-box k)
(let
((var-map (pl-cmp-make-var-map var-names)))
(let
((fresh-head (pl-cmp-build-term head-ast var-map))
(fresh-body (pl-cmp-build-term body-ast var-map)))
(let
((mark (pl-trail-mark trail)))
(if
(pl-unify! goal fresh-head trail)
(let
((r (pl-solve! db fresh-body trail cut-box k)))
(if r true (begin (pl-trail-undo-to! trail mark) false)))
(begin (pl-trail-undo-to! trail mark) false)))))))))
;; Try a list of compiled clause lambdas — same cut semantics as pl-try-clauses!.
(define
pl-try-compiled-clauses!
(fn
(db
goal
trail
compiled-clauses
outer-cut-box
outer-was-cut
inner-cut-box
k)
(cond
((empty? compiled-clauses) false)
(true
(let
((r ((first compiled-clauses) goal trail db inner-cut-box k)))
(cond
(r true)
((dict-get inner-cut-box :cut) false)
((and (not outer-was-cut) (dict-get outer-cut-box :cut)) false)
(true
(pl-try-compiled-clauses!
db
goal
trail
(rest compiled-clauses)
outer-cut-box
outer-was-cut
inner-cut-box
k))))))))
;; Compile all clauses in DB and store in :compiled table.
;; After this call, pl-solve-user! will dispatch via compiled lambdas.
;; Note: clauses assert!-ed after this call are not compiled.
(define
pl-compile-db!
(fn
(db)
(let
((src-table (dict-get db :clauses)) (compiled-table {}))
(for-each
(fn
(key)
(dict-set!
compiled-table
key
(map pl-compile-clause (dict-get src-table key))))
(keys src-table))
(dict-set! db :compiled compiled-table)
db)))
;; Cross-validate: load src into both a plain and a compiled DB,
;; run goal-str through each, return true iff solution counts match.
;; Use this to keep the interpreter as the reference implementation.
(define
pl-compiled-matches-interp?
(fn
(src goal-str)
(let
((db-interp (pl-mk-db)) (db-comp (pl-mk-db)))
(pl-db-load! db-interp (pl-parse src))
(pl-db-load! db-comp (pl-parse src))
(pl-compile-db! db-comp)
(let
((gi (pl-instantiate (pl-parse-goal goal-str) {}))
(gc (pl-instantiate (pl-parse-goal goal-str) {})))
(=
(pl-solve-count! db-interp gi (pl-mk-trail))
(pl-solve-count! db-comp gc (pl-mk-trail)))))))

View File

@@ -1,126 +0,0 @@
#!/usr/bin/env bash
# Run every Prolog test suite via sx_server and refresh scoreboard.{json,md}.
# Exit 0 if all green, 1 if any failures.
set -euo pipefail
HERE="$(cd "$(dirname "$0")" && pwd)"
ROOT="$(cd "$HERE/../.." && pwd)"
SX="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [[ ! -x "$SX" ]]; then
echo "sx_server not found at $SX (set SX_SERVER env to override)" >&2
exit 2
fi
cd "$ROOT"
# name : test-file : runner-fn
SUITES=(
"parse:lib/prolog/tests/parse.sx:pl-parse-tests-run!"
"unify:lib/prolog/tests/unify.sx:pl-unify-tests-run!"
"clausedb:lib/prolog/tests/clausedb.sx:pl-clausedb-tests-run!"
"solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!"
"operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!"
"dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!"
"findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!"
"term_inspect:lib/prolog/tests/term_inspect.sx:pl-term-inspect-tests-run!"
"append:lib/prolog/tests/programs/append.sx:pl-append-tests-run!"
"reverse:lib/prolog/tests/programs/reverse.sx:pl-reverse-tests-run!"
"member:lib/prolog/tests/programs/member.sx:pl-member-tests-run!"
"nqueens:lib/prolog/tests/programs/nqueens.sx:pl-nqueens-tests-run!"
"family:lib/prolog/tests/programs/family.sx:pl-family-tests-run!"
"atoms:lib/prolog/tests/atoms.sx:pl-atom-tests-run!"
"query_api:lib/prolog/tests/query_api.sx:pl-query-api-tests-run!"
"iso_predicates:lib/prolog/tests/iso_predicates.sx:pl-iso-predicates-tests-run!"
"meta_predicates:lib/prolog/tests/meta_predicates.sx:pl-meta-predicates-tests-run!"
"list_predicates:lib/prolog/tests/list_predicates.sx:pl-list-predicates-tests-run!"
"meta_call:lib/prolog/tests/meta_call.sx:pl-meta-call-tests-run!"
"set_predicates:lib/prolog/tests/set_predicates.sx:pl-set-predicates-tests-run!"
"char_predicates:lib/prolog/tests/char_predicates.sx:pl-char-predicates-tests-run!"
"io_predicates:lib/prolog/tests/io_predicates.sx:pl-io-predicates-tests-run!"
"assert_rules:lib/prolog/tests/assert_rules.sx:pl-assert-rules-tests-run!"
"string_agg:lib/prolog/tests/string_agg.sx:pl-string-agg-tests-run!"
"advanced:lib/prolog/tests/advanced.sx:pl-advanced-tests-run!"
"compiler:lib/prolog/tests/compiler.sx:pl-compiler-tests-run!"
"cross_validate:lib/prolog/tests/cross_validate.sx:pl-cross-validate-tests-run!"
)
SCRIPT='(epoch 1)
(load "lib/prolog/tokenizer.sx")
(load "lib/prolog/parser.sx")
(load "lib/prolog/runtime.sx")
(load "lib/prolog/query.sx")
(load "lib/prolog/compiler.sx")'
for entry in "${SUITES[@]}"; do
IFS=: read -r _ file _ <<< "$entry"
SCRIPT+=$'\n(load "'"$file"$'")'
done
for entry in "${SUITES[@]}"; do
IFS=: read -r _ _ fn <<< "$entry"
SCRIPT+=$'\n(eval "('"$fn"$')")'
done
OUTPUT="$(printf '%s\n' "$SCRIPT" | "$SX" 2>&1)"
mapfile -t LINES < <(printf '%s\n' "$OUTPUT" | grep -E '^\{:failed')
if [[ ${#LINES[@]} -ne ${#SUITES[@]} ]]; then
echo "Expected ${#SUITES[@]} suite results, got ${#LINES[@]}" >&2
echo "---- raw output ----" >&2
printf '%s\n' "$OUTPUT" >&2
exit 3
fi
TOTAL_PASS=0
TOTAL_FAIL=0
TOTAL=0
JSON_SUITES=""
MD_ROWS=""
for i in "${!SUITES[@]}"; do
IFS=: read -r name _ _ <<< "${SUITES[$i]}"
line="${LINES[$i]}"
passed=$(grep -oE ':passed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
total=$(grep -oE ':total [0-9]+' <<< "$line" | grep -oE '[0-9]+')
failed=$(grep -oE ':failed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
TOTAL_PASS=$((TOTAL_PASS + passed))
TOTAL_FAIL=$((TOTAL_FAIL + failed))
TOTAL=$((TOTAL + total))
status="ok"
[[ "$failed" -gt 0 ]] && status="FAIL"
[[ -n "$JSON_SUITES" ]] && JSON_SUITES+=","
JSON_SUITES+="\"$name\":{\"passed\":$passed,\"total\":$total,\"failed\":$failed}"
MD_ROWS+="| $name | $passed | $total | $status |"$'\n'
done
WHEN="$(date -Iseconds 2>/dev/null || date)"
cat > "$HERE/scoreboard.json" <<JSON
{
"total_passed": $TOTAL_PASS,
"total_failed": $TOTAL_FAIL,
"total": $TOTAL,
"suites": {$JSON_SUITES},
"generated": "$WHEN"
}
JSON
cat > "$HERE/scoreboard.md" <<MD
# Prolog scoreboard
**$TOTAL_PASS / $TOTAL passing** ($TOTAL_FAIL failure(s)).
Generated $WHEN.
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
$MD_ROWS
Run \`bash lib/prolog/conformance.sh\` to refresh. Override the binary
with \`SX_SERVER=path/to/sx_server.exe bash …\`.
MD
if [[ "$TOTAL_FAIL" -gt 0 ]]; then
echo "$TOTAL_FAIL failure(s) across $TOTAL tests" >&2
exit 1
fi
echo "All $TOTAL tests pass."

View File

@@ -1,20 +1,28 @@
;; lib/prolog/parser.sx — tokens → Prolog AST
;;
;; Phase 4 grammar (with operator table):
;; Phase 1 grammar (NO operator table yet):
;; Program := Clause* EOF
;; Clause := Term[999] "." | Term[999] ":-" Term[1200] "."
;; Term[Pmax] uses precedence climbing on the operator table:
;; primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
;; while next token is infix op `op` with prec(op) ≤ Pmax:
;; consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
;; Clause := Term "." | Term ":-" Term "."
;; Term := Atom | Var | Number | String | Compound | List
;; Compound := atom "(" ArgList ")"
;; ArgList := Term ("," Term)*
;; List := "[" "]" | "[" Term ("," Term)* ("|" Term)? "]"
;;
;; Op type → right-prec for op at precedence P:
;; xfx → P-1 strict-both
;; xfy → P right-associative
;; yfx → P-1 left-associative
;; Term AST shapes (all tagged lists for uniform dispatch):
;; ("atom" name) — atom
;; ("var" name) — variable template (parser-time only)
;; ("num" value) — integer or float
;; ("str" value) — string literal
;; ("compound" functor args) — compound term, args is list of term-ASTs
;; ("cut") — the cut atom !
;;
;; AST shapes are unchanged — operators just become compound terms.
;; A clause is (list "clause" head body). A fact is head with body = ("atom" "true").
;;
;; The empty list is (atom "[]"). Cons is compound "." with two args:
;; [1, 2, 3] → .(1, .(2, .(3, [])))
;; [H|T] → .(H, T)
;; ── Parser state helpers ────────────────────────────────────────────
(define
pp-peek
(fn
@@ -58,6 +66,7 @@
(if (= (get t :value) nil) "" (get t :value))
"'"))))))
;; ── AST constructors ────────────────────────────────────────────────
(define pl-mk-atom (fn (name) (list "atom" name)))
(define pl-mk-var (fn (name) (list "var" name)))
(define pl-mk-num (fn (n) (list "num" n)))
@@ -65,14 +74,18 @@
(define pl-mk-compound (fn (f args) (list "compound" f args)))
(define pl-mk-cut (fn () (list "cut")))
;; Term tag extractors
(define pl-term-tag (fn (t) (if (list? t) (first t) nil)))
(define pl-term-val (fn (t) (nth t 1)))
(define pl-compound-functor (fn (t) (nth t 1)))
(define pl-compound-args (fn (t) (nth t 2)))
;; Empty-list atom and cons helpers
(define pl-nil-term (fn () (pl-mk-atom "[]")))
(define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))
;; Build cons list from a list of terms + optional tail
(define
pl-mk-list-term
(fn
@@ -82,61 +95,9 @@
tail
(pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))
;; ── Operator table (Phase 4) ──────────────────────────────────────
;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
(define
pl-op-table
(list
(list "," 1000 "xfy")
(list ";" 1100 "xfy")
(list "->" 1050 "xfy")
(list "=" 700 "xfx")
(list "\\=" 700 "xfx")
(list "is" 700 "xfx")
(list "<" 700 "xfx")
(list ">" 700 "xfx")
(list "=<" 700 "xfx")
(list ">=" 700 "xfx")
(list "+" 500 "yfx")
(list "-" 500 "yfx")
(list "*" 400 "yfx")
(list "/" 400 "yfx")
(list ":-" 1200 "xfx")
(list "mod" 400 "yfx")))
(define
pl-op-find
(fn
(name table)
(cond
((empty? table) nil)
((= (first (first table)) name) (rest (first table)))
(true (pl-op-find name (rest table))))))
(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))
;; Token → (name prec type) for known infix ops, else nil.
(define
pl-token-op
(fn
(t)
(let
((ty (get t :type)) (vv (get t :value)))
(cond
((and (= ty "punct") (= vv ","))
(let
((info (pl-op-lookup ",")))
(if (nil? info) nil (cons "," info))))
((or (= ty "atom") (= ty "op"))
(let
((info (pl-op-lookup vv)))
(if (nil? info) nil (cons vv info))))
(true nil)))))
;; ── Term parser ─────────────────────────────────────────────────────
;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens.
(define
pp-parse-primary
pp-parse-term
(fn
(st)
(let
@@ -150,12 +111,6 @@
((and (= ty "op") (= vv "!"))
(do (pp-advance! st) (pl-mk-cut)))
((and (= ty "punct") (= vv "[")) (pp-parse-list st))
((and (= ty "punct") (= vv "("))
(do
(pp-advance! st)
(let
((inner (pp-parse-term-prec st 1200)))
(do (pp-expect! st "punct" ")") inner))))
((= ty "atom")
(do
(pp-advance! st)
@@ -178,51 +133,13 @@
(if (= vv nil) "" vv)
"'"))))))))
;; Operator-aware term parser: precedence climbing.
(define
pp-parse-term-prec
(fn
(st max-prec)
(let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec))))
(define
pp-parse-op-rhs
(fn
(st left max-prec)
(let
((op-info (pl-token-op (pp-peek st))))
(cond
((nil? op-info) left)
(true
(let
((name (first op-info))
(prec (nth op-info 1))
(ty (nth op-info 2)))
(cond
((> prec max-prec) left)
(true
(let
((right-prec (if (= ty "xfy") prec (- prec 1))))
(do
(pp-advance! st)
(let
((right (pp-parse-term-prec st right-prec)))
(pp-parse-op-rhs
st
(pl-mk-compound name (list left right))
max-prec))))))))))))
;; Backwards-compat alias.
(define pp-parse-term (fn (st) (pp-parse-term-prec st 999)))
;; Args inside parens: parse at prec 999 so comma-as-operator (1000)
;; is not consumed; the explicit comma loop handles separation.
;; Parse one or more comma-separated terms (arguments).
(define
pp-parse-arg-list
(fn
(st)
(let
((first-arg (pp-parse-term-prec st 999)) (args (list)))
((first-arg (pp-parse-term st)) (args (list)))
(do
(append! args first-arg)
(define
@@ -233,12 +150,12 @@
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! args (pp-parse-term-prec st 999))
(append! args (pp-parse-term st))
(loop)))))
(loop)
args))))
;; List literal.
;; Parse a [ ... ] list literal. Consumes the "[".
(define
pp-parse-list
(fn
@@ -251,7 +168,7 @@
(let
((items (list)))
(do
(append! items (pp-parse-term-prec st 999))
(append! items (pp-parse-term st))
(define
comma-loop
(fn
@@ -260,17 +177,52 @@
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! items (pp-parse-term-prec st 999))
(append! items (pp-parse-term st))
(comma-loop)))))
(comma-loop)
(let
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term st)) (pl-nil-term))))
(do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))
;; ── Body parsing ────────────────────────────────────────────────────
;; A body is a single term parsed at prec 1200 — operator parser folds
;; `,`, `;`, `->` automatically into right-associative compounds.
(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))
;; A clause body is a comma-separated list of goals. We flatten into a
;; right-associative `,` compound: (A, B, C) → ','(A, ','(B, C))
;; If only one goal, it's that goal directly.
(define
pp-parse-body
(fn
(st)
(let
((first-goal (pp-parse-term st)) (rest-goals (list)))
(do
(define
gloop
(fn
()
(when
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! rest-goals (pp-parse-term st))
(gloop)))))
(gloop)
(if
(= (len rest-goals) 0)
first-goal
(pp-build-conj first-goal rest-goals))))))
(define
pp-build-conj
(fn
(first-goal rest-goals)
(if
(= (len rest-goals) 0)
first-goal
(pl-mk-compound
","
(list
first-goal
(pp-build-conj (first rest-goals) (rest rest-goals)))))))
;; ── Clause parsing ──────────────────────────────────────────────────
(define
@@ -278,11 +230,12 @@
(fn
(st)
(let
((head (pp-parse-term-prec st 999)))
((head (pp-parse-term st)))
(let
((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true"))))
(do (pp-expect! st "punct" ".") (list "clause" head body))))))
;; Parse an entire program — returns list of clauses.
(define
pl-parse-program
(fn
@@ -300,9 +253,13 @@
(ploop)
clauses))))
;; Parse a single query term (no trailing "."). Returns the term.
(define
pl-parse-query
(fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st))))
;; Convenience: source → clauses
(define pl-parse (fn (src) (pl-parse-program (pl-tokenize src))))
;; Convenience: source → query term
(define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))

View File

@@ -1,114 +0,0 @@
;; lib/prolog/query.sx — high-level Prolog query API for SX/Hyperscript callers.
;;
;; Requires tokenizer.sx, parser.sx, runtime.sx to be loaded first.
;;
;; Public API:
;; (pl-load source-str) → db
;; (pl-query-all db query-str) → list of solution dicts {var-name → term-string}
;; (pl-query-one db query-str) → first solution dict or nil
;; (pl-query source-str query-str) → list of solution dicts (convenience)
;; Collect variable name strings from a parse-time AST (pre-instantiation).
;; Returns list of unique strings, excluding anonymous "_".
(define
pl-query-extract-vars
(fn
(ast)
(let
((seen {}))
(let
((collect!
(fn
(t)
(cond
((not (list? t)) nil)
((empty? t) nil)
((= (first t) "var")
(if
(not (= (nth t 1) "_"))
(dict-set! seen (nth t 1) true)
nil))
((= (first t) "compound")
(for-each collect! (nth t 2)))
(true nil)))))
(collect! ast)
(keys seen)))))
;; Build a solution dict from a var-env after a successful solve.
;; Maps each variable name string to its formatted term value.
(define
pl-query-solution-dict
(fn
(var-names var-env)
(let
((d {}))
(for-each
(fn (name) (dict-set! d name (pl-format-term (dict-get var-env name))))
var-names)
d)))
;; Parse source-str and load clauses into a fresh DB.
;; Returns the DB for reuse across multiple queries.
(define
pl-load
(fn
(source-str)
(let
((db (pl-mk-db)))
(if
(and (string? source-str) (not (= source-str "")))
(pl-db-load! db (pl-parse source-str))
nil)
db)))
;; Run query-str against db, returning a list of solution dicts.
;; Each dict maps variable name strings to their formatted term values.
;; Returns an empty list if no solutions.
(define
pl-query-all
(fn
(db query-str)
(let
((parsed (pl-parse (str "q_ :- " query-str "."))))
(let
((body-ast (nth (first parsed) 2)))
(let
((var-names (pl-query-extract-vars body-ast))
(var-env {}))
(let
((goal (pl-instantiate body-ast var-env))
(trail (pl-mk-trail))
(solutions (list)))
(let
((mark (pl-trail-mark trail)))
(pl-solve!
db
goal
trail
{:cut false}
(fn
()
(begin
(append!
solutions
(pl-query-solution-dict var-names var-env))
false)))
(pl-trail-undo-to! trail mark)
solutions)))))))
;; Return the first solution dict, or nil if no solutions.
(define
pl-query-one
(fn
(db query-str)
(let
((all (pl-query-all db query-str)))
(if (empty? all) nil (first all)))))
;; Convenience: parse source-str, then run query-str against it.
;; Returns a list of solution dicts. Creates a fresh DB each call.
(define
pl-query
(fn
(source-str query-str)
(pl-query-all (pl-load source-str) query-str)))

File diff suppressed because it is too large Load Diff

View File

@@ -1,7 +0,0 @@
{
"total_passed": 517,
"total_failed": 0,
"total": 517,
"suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0}},
"generated": "2026-04-25T14:12:52+00:00"
}

View File

@@ -1,35 +0,0 @@
# Prolog scoreboard
**517 / 517 passing** (0 failure(s)).
Generated 2026-04-25T14:12:52+00:00.
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| parse | 25 | 25 | ok |
| unify | 47 | 47 | ok |
| clausedb | 14 | 14 | ok |
| solve | 62 | 62 | ok |
| operators | 19 | 19 | ok |
| dynamic | 11 | 11 | ok |
| findall | 11 | 11 | ok |
| term_inspect | 14 | 14 | ok |
| append | 6 | 6 | ok |
| reverse | 6 | 6 | ok |
| member | 7 | 7 | ok |
| nqueens | 6 | 6 | ok |
| family | 10 | 10 | ok |
| atoms | 34 | 34 | ok |
| query_api | 16 | 16 | ok |
| iso_predicates | 29 | 29 | ok |
| meta_predicates | 25 | 25 | ok |
| list_predicates | 33 | 33 | ok |
| meta_call | 15 | 15 | ok |
| set_predicates | 15 | 15 | ok |
| char_predicates | 27 | 27 | ok |
| io_predicates | 24 | 24 | ok |
| assert_rules | 15 | 15 | ok |
| string_agg | 25 | 25 | ok |
| advanced | 21 | 21 | ok |
Run `bash lib/prolog/conformance.sh` to refresh. Override the binary
with `SX_SERVER=path/to/sx_server.exe bash …`.

View File

@@ -1,254 +0,0 @@
;; lib/prolog/tests/advanced.sx — predsort/3, term_variables/2, arith extensions
(define pl-adv-test-count 0)
(define pl-adv-test-pass 0)
(define pl-adv-test-fail 0)
(define pl-adv-test-failures (list))
(define
pl-adv-test!
(fn
(name got expected)
(begin
(set! pl-adv-test-count (+ pl-adv-test-count 1))
(if
(= got expected)
(set! pl-adv-test-pass (+ pl-adv-test-pass 1))
(begin
(set! pl-adv-test-fail (+ pl-adv-test-fail 1))
(append!
pl-adv-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-adv-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-adv-db (pl-mk-db))
;; Load a numeric comparator for predsort tests
(pl-db-load!
pl-adv-db
(pl-parse
"cmp_num(Order, X, Y) :- (X < Y -> Order = '<' ; (X > Y -> Order = '>' ; Order = '='))."))
;; ── Arithmetic extensions ──────────────────────────────────────────
(define pl-adv-arith-env-1 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is floor(3.7)" pl-adv-arith-env-1)
(pl-mk-trail))
(pl-adv-test!
"floor(3.7) = 3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-1 "X")))
3)
(define pl-adv-arith-env-2 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is ceiling(3.2)" pl-adv-arith-env-2)
(pl-mk-trail))
(pl-adv-test!
"ceiling(3.2) = 4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-2 "X")))
4)
(define pl-adv-arith-env-3 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is truncate(3.9)" pl-adv-arith-env-3)
(pl-mk-trail))
(pl-adv-test!
"truncate(3.9) = 3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-3 "X")))
3)
(define pl-adv-arith-env-4 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is truncate(0 - 3.9)" pl-adv-arith-env-4)
(pl-mk-trail))
(pl-adv-test!
"truncate(0-3.9) = -3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-4 "X")))
-3)
(define pl-adv-arith-env-5 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is round(3.5)" pl-adv-arith-env-5)
(pl-mk-trail))
(pl-adv-test!
"round(3.5) = 4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-5 "X")))
4)
(define pl-adv-arith-env-6 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sqrt(4.0)" pl-adv-arith-env-6)
(pl-mk-trail))
(pl-adv-test!
"sqrt(4.0) = 2"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-6 "X")))
2)
(define pl-adv-arith-env-7 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(0 - 5)" pl-adv-arith-env-7)
(pl-mk-trail))
(pl-adv-test!
"sign(0-5) = -1"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-7 "X")))
-1)
(define pl-adv-arith-env-8 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(0)" pl-adv-arith-env-8)
(pl-mk-trail))
(pl-adv-test!
"sign(0) = 0"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-8 "X")))
0)
(define pl-adv-arith-env-9 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(3)" pl-adv-arith-env-9)
(pl-mk-trail))
(pl-adv-test!
"sign(3) = 1"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-9 "X")))
1)
(define pl-adv-arith-env-10 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is pow(2, 3)" pl-adv-arith-env-10)
(pl-mk-trail))
(pl-adv-test!
"pow(2,3) = 8"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-10 "X")))
8)
(define pl-adv-arith-env-11 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is floor(0 - 3.7)" pl-adv-arith-env-11)
(pl-mk-trail))
(pl-adv-test!
"floor(0-3.7) = -4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-11 "X")))
-4)
(define pl-adv-arith-env-12 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is ceiling(0 - 3.2)" pl-adv-arith-env-12)
(pl-mk-trail))
(pl-adv-test!
"ceiling(0-3.2) = -3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-12 "X")))
-3)
;; ── term_variables/2 ──────────────────────────────────────────────
(define pl-adv-tv-env-1 {:Vs (pl-mk-rt-var "Vs")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(hello, Vs)" pl-adv-tv-env-1)
(pl-mk-trail))
(pl-adv-test!
"term_variables(hello,Vs) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-1 "Vs")))
"[]")
(define pl-adv-tv-env-2 {:Vs (pl-mk-rt-var "Vs")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(f(a, g(b)), Vs)" pl-adv-tv-env-2)
(pl-mk-trail))
(pl-adv-test!
"term_variables(f(a,g(b)),Vs) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-2 "Vs")))
"[]")
(define pl-adv-tv-env-3 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(f(X, Y), Vs)" pl-adv-tv-env-3)
(pl-mk-trail))
(pl-adv-test!
"term_variables(f(X,Y),Vs) has 2 vars"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-3 "Vs")))
2)
(define pl-adv-tv-env-4 {:Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(X, Vs)" pl-adv-tv-env-4)
(pl-mk-trail))
(pl-adv-test!
"term_variables(X,Vs) has 1 var"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-4 "Vs")))
1)
(define pl-adv-tv-env-5 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(foo(X, Y, X), Vs)" pl-adv-tv-env-5)
(pl-mk-trail))
(pl-adv-test!
"term_variables(foo(X,Y,X),Vs) deduplicates X -> 2 vars"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-5 "Vs")))
2)
;; ── predsort/3 ────────────────────────────────────────────────────
(define pl-adv-ps-env-1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [], R)" pl-adv-ps-env-1)
(pl-mk-trail))
(pl-adv-test!
"predsort([]) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-1 "R")))
"[]")
(define pl-adv-ps-env-2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [1], R)" pl-adv-ps-env-2)
(pl-mk-trail))
(pl-adv-test!
"predsort([1]) -> [1]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-2 "R")))
".(1, [])")
(define pl-adv-ps-env-3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [3,1,2], R)" pl-adv-ps-env-3)
(pl-mk-trail))
(pl-adv-test!
"predsort([3,1,2]) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-3 "R")))
".(1, .(2, .(3, [])))")
(define pl-adv-ps-env-4 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [3,1,2,1,3], R)" pl-adv-ps-env-4)
(pl-mk-trail))
(pl-adv-test!
"predsort([3,1,2,1,3]) dedup -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-4 "R")))
".(1, .(2, .(3, [])))")
;; ── Runner ─────────────────────────────────────────────────────────
(define pl-advanced-tests-run! (fn () {:failed pl-adv-test-fail :passed pl-adv-test-pass :total pl-adv-test-count :failures pl-adv-test-failures}))

View File

@@ -1,215 +0,0 @@
;; lib/prolog/tests/assert_rules.sx — assert/assertz/asserta with rule terms (head :- body)
;; Tests that :- is in the op table (prec 1200 xfx) and pl-build-clause handles rule form.
(define pl-ar-test-count 0)
(define pl-ar-test-pass 0)
(define pl-ar-test-fail 0)
(define pl-ar-test-failures (list))
(define
pl-ar-test!
(fn
(name got expected)
(begin
(set! pl-ar-test-count (+ pl-ar-test-count 1))
(if
(= got expected)
(set! pl-ar-test-pass (+ pl-ar-test-pass 1))
(begin
(set! pl-ar-test-fail (+ pl-ar-test-fail 1))
(append!
pl-ar-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ar-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; ── DB1: assertz a simple rule then query ──────────────────────────
(define pl-ar-db1 (pl-mk-db))
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "assertz((double(X, Y) :- Y is X * 2))" {})
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(3, Y) succeeds"
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(3, Y)" {})
(pl-mk-trail))
true)
(define pl-ar-env1 {})
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(3, Y)" pl-ar-env1)
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(3, Y) binds Y to 6"
(pl-num-val (pl-walk-deep (dict-get pl-ar-env1 "Y")))
6)
(define pl-ar-env1b {})
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(10, Y)" pl-ar-env1b)
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(10, Y) yields 20"
(pl-num-val (pl-walk-deep (dict-get pl-ar-env1b "Y")))
20)
;; ── DB2: assert a rule with multiple facts, count solutions ─────────
(define pl-ar-db2 (pl-mk-db))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assert(fact(a))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assert(fact(b))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assertz((copy(X) :- fact(X)))" {})
(pl-mk-trail))
(pl-ar-test!
"rule copy/1 using fact/1: 2 solutions"
(pl-solve-count! pl-ar-db2 (pl-ar-goal "copy(X)" {}) (pl-mk-trail))
2)
(define pl-ar-env2a {})
(pl-solve-once! pl-ar-db2 (pl-ar-goal "copy(X)" pl-ar-env2a) (pl-mk-trail))
(pl-ar-test!
"rule copy/1: first solution is a"
(pl-atom-name (pl-walk-deep (dict-get pl-ar-env2a "X")))
"a")
;; ── DB3: asserta rule is tried before existing clauses ─────────────
(define pl-ar-db3 (pl-mk-db))
(pl-solve-once!
pl-ar-db3
(pl-ar-goal "assert(ord(a))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db3
(pl-ar-goal "asserta((ord(b) :- true))" {})
(pl-mk-trail))
(define pl-ar-env3 {})
(pl-solve-once! pl-ar-db3 (pl-ar-goal "ord(X)" pl-ar-env3) (pl-mk-trail))
(pl-ar-test!
"asserta rule ord(b) is tried before ord(a)"
(pl-atom-name (pl-walk-deep (dict-get pl-ar-env3 "X")))
"b")
(pl-ar-test!
"asserta: total solutions for ord/1 is 2"
(pl-solve-count! pl-ar-db3 (pl-ar-goal "ord(X)" {}) (pl-mk-trail))
2)
;; ── DB4: rule with conjunction in body ─────────────────────────────
(define pl-ar-db4 (pl-mk-db))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assert(num(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assert(num(2))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assertz((big(X) :- num(X), X > 1))" {})
(pl-mk-trail))
(pl-ar-test!
"conjunction in rule body: big(1) fails"
(pl-solve-once! pl-ar-db4 (pl-ar-goal "big(1)" {}) (pl-mk-trail))
false)
(pl-ar-test!
"conjunction in rule body: big(2) succeeds"
(pl-solve-once! pl-ar-db4 (pl-ar-goal "big(2)" {}) (pl-mk-trail))
true)
;; ── DB5: recursive rule ─────────────────────────────────────────────
(define pl-ar-db5 (pl-mk-db))
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "assert((nat(0) :- true))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "assertz((nat(s(X)) :- nat(X)))" {})
(pl-mk-trail))
(pl-ar-test!
"recursive rule: nat(0) succeeds"
(pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(0)" {}) (pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(s(0)) succeeds"
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "nat(s(0))" {})
(pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(s(s(0))) succeeds"
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "nat(s(s(0)))" {})
(pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(bad) fails"
(pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(bad)" {}) (pl-mk-trail))
false)
;; ── DB6: rule with true body (explicit) ────────────────────────────
(define pl-ar-db6 (pl-mk-db))
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "assertz((always(X) :- true))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "assert(always(extra))" {})
(pl-mk-trail))
(pl-ar-test!
"rule body=true: always(foo) succeeds"
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "always(foo)" {})
(pl-mk-trail))
true)
(pl-ar-test!
"rule body=true: always/1 has 2 clauses (1 rule + 1 fact)"
(pl-solve-count!
pl-ar-db6
(pl-ar-goal "always(X)" {})
(pl-mk-trail))
2)
;; ── Runner ──────────────────────────────────────────────────────────
(define pl-assert-rules-tests-run! (fn () {:failed pl-ar-test-fail :passed pl-ar-test-pass :total pl-ar-test-count :failures pl-ar-test-failures}))

View File

@@ -1,305 +0,0 @@
;; lib/prolog/tests/atoms.sx — type predicates + string/atom built-ins
(define pl-at-test-count 0)
(define pl-at-test-pass 0)
(define pl-at-test-fail 0)
(define pl-at-test-failures (list))
(define
pl-at-test!
(fn
(name got expected)
(begin
(set! pl-at-test-count (+ pl-at-test-count 1))
(if
(= got expected)
(set! pl-at-test-pass (+ pl-at-test-pass 1))
(begin
(set! pl-at-test-fail (+ pl-at-test-fail 1))
(append!
pl-at-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-at-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-at-db (pl-mk-db))
;; ── var/1 + nonvar/1 ──
(pl-at-test!
"var(X) for unbound var"
(pl-solve-once! pl-at-db (pl-at-goal "var(X)" {}) (pl-mk-trail))
true)
(pl-at-test!
"var(foo) fails"
(pl-solve-once! pl-at-db (pl-at-goal "var(foo)" {}) (pl-mk-trail))
false)
(pl-at-test!
"nonvar(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "nonvar(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"nonvar(X) for unbound var fails"
(pl-solve-once! pl-at-db (pl-at-goal "nonvar(X)" {}) (pl-mk-trail))
false)
;; ── atom/1 ──
(pl-at-test!
"atom(foo) succeeds"
(pl-solve-once! pl-at-db (pl-at-goal "atom(foo)" {}) (pl-mk-trail))
true)
(pl-at-test!
"atom([]) succeeds"
(pl-solve-once! pl-at-db (pl-at-goal "atom([])" {}) (pl-mk-trail))
true)
(pl-at-test!
"atom(42) fails"
(pl-solve-once! pl-at-db (pl-at-goal "atom(42)" {}) (pl-mk-trail))
false)
(pl-at-test!
"atom(f(x)) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom(f(x))" {})
(pl-mk-trail))
false)
;; ── number/1 + integer/1 ──
(pl-at-test!
"number(42) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "number(42)" {})
(pl-mk-trail))
true)
(pl-at-test!
"number(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "number(foo)" {})
(pl-mk-trail))
false)
(pl-at-test!
"integer(7) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "integer(7)" {})
(pl-mk-trail))
true)
;; ── compound/1 + callable/1 + atomic/1 ──
(pl-at-test!
"compound(f(x)) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "compound(f(x))" {})
(pl-mk-trail))
true)
(pl-at-test!
"compound(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "compound(foo)" {})
(pl-mk-trail))
false)
(pl-at-test!
"callable(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"callable(f(x)) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(f(x))" {})
(pl-mk-trail))
true)
(pl-at-test!
"callable(42) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(42)" {})
(pl-mk-trail))
false)
(pl-at-test!
"atomic(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atomic(42) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(42)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atomic(f(x)) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(f(x))" {})
(pl-mk-trail))
false)
;; ── is_list/1 ──
(pl-at-test!
"is_list([]) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list([])" {})
(pl-mk-trail))
true)
(pl-at-test!
"is_list([1,2,3]) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list([1,2,3])" {})
(pl-mk-trail))
true)
(pl-at-test!
"is_list(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list(foo)" {})
(pl-mk-trail))
false)
;; ── atom_length/2 ──
(define pl-at-env-al {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_length(hello, N)" pl-at-env-al)
(pl-mk-trail))
(pl-at-test!
"atom_length(hello, N) -> N=5"
(pl-num-val (pl-walk-deep (dict-get pl-at-env-al "N")))
5)
(pl-at-test!
"atom_length empty atom"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_length('', 0)" {})
(pl-mk-trail))
true)
;; ── atom_concat/3 ──
(define pl-at-env-ac {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, X)" pl-at-env-ac)
(pl-mk-trail))
(pl-at-test!
"atom_concat(foo, bar, X) -> X=foobar"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac "X")))
"foobar")
(pl-at-test!
"atom_concat(foo, bar, foobar) check"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, foobar)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atom_concat(foo, bar, foobaz) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, foobaz)" {})
(pl-mk-trail))
false)
(define pl-at-env-ac2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, Y, foobar)" pl-at-env-ac2)
(pl-mk-trail))
(pl-at-test!
"atom_concat(foo, Y, foobar) -> Y=bar"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac2 "Y")))
"bar")
;; ── atom_chars/2 ──
(define pl-at-env-ach {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(cat, Cs)" pl-at-env-ach)
(pl-mk-trail))
(pl-at-test!
"atom_chars(cat, Cs) -> Cs=[c,a,t]"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(cat, [c,a,t])" {})
(pl-mk-trail))
true)
(define pl-at-env-ach2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(A, [h,i])" pl-at-env-ach2)
(pl-mk-trail))
(pl-at-test!
"atom_chars(A, [h,i]) -> A=hi"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ach2 "A")))
"hi")
;; ── char_code/2 ──
(define pl-at-env-cc {})
(pl-solve-once!
pl-at-db
(pl-at-goal "char_code(a, N)" pl-at-env-cc)
(pl-mk-trail))
(pl-at-test!
"char_code(a, N) -> N=97"
(pl-num-val (pl-walk-deep (dict-get pl-at-env-cc "N")))
97)
(define pl-at-env-cc2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "char_code(C, 65)" pl-at-env-cc2)
(pl-mk-trail))
(pl-at-test!
"char_code(C, 65) -> C='A'"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-cc2 "C")))
"A")
;; ── number_codes/2 ──
(pl-at-test!
"number_codes(42, [52,50])"
(pl-solve-once!
pl-at-db
(pl-at-goal "number_codes(42, [52,50])" {})
(pl-mk-trail))
true)
;; ── number_chars/2 ──
(pl-at-test!
"number_chars(42, ['4','2'])"
(pl-solve-once!
pl-at-db
(pl-at-goal "number_chars(42, ['4','2'])" {})
(pl-mk-trail))
true)
(define pl-atom-tests-run! (fn () {:failed pl-at-test-fail :passed pl-at-test-pass :total pl-at-test-count :failures pl-at-test-failures}))

View File

@@ -1,290 +0,0 @@
;; lib/prolog/tests/char_predicates.sx — char_type/2, upcase_atom/2, downcase_atom/2,
;; string_upper/2, string_lower/2
(define pl-cp-test-count 0)
(define pl-cp-test-pass 0)
(define pl-cp-test-fail 0)
(define pl-cp-test-failures (list))
(define
pl-cp-test!
(fn
(name got expected)
(begin
(set! pl-cp-test-count (+ pl-cp-test-count 1))
(if
(= got expected)
(set! pl-cp-test-pass (+ pl-cp-test-pass 1))
(begin
(set! pl-cp-test-fail (+ pl-cp-test-fail 1))
(append!
pl-cp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-cp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-cp-db (pl-mk-db))
;; ─── char_type/2 — alpha ──────────────────────────────────────────
(pl-cp-test!
"char_type(a, alpha) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, alpha)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type('1', alpha) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('1', alpha)" {})
(pl-mk-trail))
false)
(pl-cp-test!
"char_type('A', alpha) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('A', alpha)" {})
(pl-mk-trail))
true)
;; ─── char_type/2 — alnum ─────────────────────────────────────────
(pl-cp-test!
"char_type('5', alnum) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', alnum)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, alnum) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, alnum)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(' ', alnum) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(' ', alnum)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — digit ─────────────────────────────────────────
(pl-cp-test!
"char_type('5', digit) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', digit)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, digit) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, digit)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — digit(Weight) ─────────────────────────────────
(define pl-cp-env-dw {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', digit(N))" pl-cp-env-dw)
(pl-mk-trail))
(pl-cp-test!
"char_type('5', digit(N)) -> N=5"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw "N")))
5)
(define pl-cp-env-dw0 {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('0', digit(N))" pl-cp-env-dw0)
(pl-mk-trail))
(pl-cp-test!
"char_type('0', digit(N)) -> N=0"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw0 "N")))
0)
;; ─── char_type/2 — space/white ───────────────────────────────────
(pl-cp-test!
"char_type(' ', space) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(' ', space)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, space) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, space)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — upper(Lower) ──────────────────────────────────
(define pl-cp-env-ul {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('A', upper(L))" pl-cp-env-ul)
(pl-mk-trail))
(pl-cp-test!
"char_type('A', upper(L)) -> L=a"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ul "L")))
"a")
(pl-cp-test!
"char_type(a, upper(L)) fails — not uppercase"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, upper(_))" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — lower(Upper) ──────────────────────────────────
(define pl-cp-env-lu {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, lower(U))" pl-cp-env-lu)
(pl-mk-trail))
(pl-cp-test!
"char_type(a, lower(U)) -> U='A'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-lu "U")))
"A")
;; ─── char_type/2 — ascii(Code) ───────────────────────────────────
(define pl-cp-env-as {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, ascii(C))" pl-cp-env-as)
(pl-mk-trail))
(pl-cp-test!
"char_type(a, ascii(C)) -> C=97"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-as "C")))
97)
;; ─── char_type/2 — punct ─────────────────────────────────────────
(pl-cp-test!
"char_type('.', punct) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('.', punct)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, punct) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, punct)" {})
(pl-mk-trail))
false)
;; ─── upcase_atom/2 ───────────────────────────────────────────────
(define pl-cp-env-ua {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom(hello, X)" pl-cp-env-ua)
(pl-mk-trail))
(pl-cp-test!
"upcase_atom(hello, X) -> X='HELLO'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ua "X")))
"HELLO")
(pl-cp-test!
"upcase_atom(hello, 'HELLO') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom(hello, 'HELLO')" {})
(pl-mk-trail))
true)
(pl-cp-test!
"upcase_atom('Hello World', 'HELLO WORLD') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom('Hello World', 'HELLO WORLD')" {})
(pl-mk-trail))
true)
(pl-cp-test!
"upcase_atom('', '') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom('', '')" {})
(pl-mk-trail))
true)
;; ─── downcase_atom/2 ─────────────────────────────────────────────
(define pl-cp-env-da {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom('HELLO', X)" pl-cp-env-da)
(pl-mk-trail))
(pl-cp-test!
"downcase_atom('HELLO', X) -> X=hello"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-da "X")))
"hello")
(pl-cp-test!
"downcase_atom('HELLO', hello) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom('HELLO', hello)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"downcase_atom(hello, hello) succeeds — already lowercase"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom(hello, hello)" {})
(pl-mk-trail))
true)
;; ─── string_upper/2 + string_lower/2 (aliases) ───────────────────
(define pl-cp-env-su {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "string_upper(hello, X)" pl-cp-env-su)
(pl-mk-trail))
(pl-cp-test!
"string_upper(hello, X) -> X='HELLO'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-su "X")))
"HELLO")
(define pl-cp-env-sl {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "string_lower('WORLD', X)" pl-cp-env-sl)
(pl-mk-trail))
(pl-cp-test!
"string_lower('WORLD', X) -> X=world"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-sl "X")))
"world")
(define pl-char-predicates-tests-run! (fn () {:failed pl-cp-test-fail :passed pl-cp-test-pass :total pl-cp-test-count :failures pl-cp-test-failures}))

View File

@@ -1,99 +0,0 @@
;; lib/prolog/tests/clausedb.sx — Clause DB unit tests
(define pl-db-test-count 0)
(define pl-db-test-pass 0)
(define pl-db-test-fail 0)
(define pl-db-test-failures (list))
(define
pl-db-test!
(fn
(name got expected)
(begin
(set! pl-db-test-count (+ pl-db-test-count 1))
(if
(= got expected)
(set! pl-db-test-pass (+ pl-db-test-pass 1))
(begin
(set! pl-db-test-fail (+ pl-db-test-fail 1))
(append!
pl-db-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(pl-db-test!
"head-key atom arity 0"
(pl-head-key (nth (first (pl-parse "foo.")) 1))
"foo/0")
(pl-db-test!
"head-key compound arity 2"
(pl-head-key (nth (first (pl-parse "bar(a, b).")) 1))
"bar/2")
(pl-db-test!
"clause-key of :- clause"
(pl-clause-key (first (pl-parse "likes(mary, X) :- friendly(X).")))
"likes/2")
(pl-db-test!
"empty db lookup returns empty list"
(len (pl-db-lookup (pl-mk-db) "parent/2"))
0)
(define pl-db-t1 (pl-mk-db))
(pl-db-load! pl-db-t1 (pl-parse "foo(a). foo(b). foo(c)."))
(pl-db-test!
"three facts same functor"
(len (pl-db-lookup pl-db-t1 "foo/1"))
3)
(pl-db-test!
"mismatching key returns empty"
(len (pl-db-lookup pl-db-t1 "foo/2"))
0)
(pl-db-test!
"first clause has arg a"
(pl-atom-name
(first (pl-args (nth (first (pl-db-lookup pl-db-t1 "foo/1")) 1))))
"a")
(pl-db-test!
"third clause has arg c"
(pl-atom-name
(first (pl-args (nth (nth (pl-db-lookup pl-db-t1 "foo/1") 2) 1))))
"c")
(define pl-db-t2 (pl-mk-db))
(pl-db-load! pl-db-t2 (pl-parse "foo. bar. foo. parent(a, b). parent(c, d)."))
(pl-db-test!
"atom heads keyed as foo/0"
(len (pl-db-lookup pl-db-t2 "foo/0"))
2)
(pl-db-test!
"atom heads keyed as bar/0"
(len (pl-db-lookup pl-db-t2 "bar/0"))
1)
(pl-db-test!
"compound heads keyed as parent/2"
(len (pl-db-lookup pl-db-t2 "parent/2"))
2)
(pl-db-test!
"lookup-goal extracts functor/arity"
(len
(pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "parent(X, Y).")) 1)))
2)
(pl-db-test!
"lookup-goal on atom goal"
(len (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "foo.")) 1)))
2)
(pl-db-test!
"stored clause is clause form"
(first (first (pl-db-lookup pl-db-t2 "parent/2")))
"clause")
(define pl-clausedb-tests-run! (fn () {:failed pl-db-test-fail :passed pl-db-test-pass :total pl-db-test-count :failures pl-db-test-failures}))

View File

@@ -1,185 +0,0 @@
;; lib/prolog/tests/compiler.sx — compiled clause dispatch tests
(define pl-cmp-test-count 0)
(define pl-cmp-test-pass 0)
(define pl-cmp-test-fail 0)
(define pl-cmp-test-failures (list))
(define
pl-cmp-test!
(fn
(name got expected)
(set! pl-cmp-test-count (+ pl-cmp-test-count 1))
(if
(= got expected)
(set! pl-cmp-test-pass (+ pl-cmp-test-pass 1))
(begin
(set! pl-cmp-test-fail (+ pl-cmp-test-fail 1))
(append! pl-cmp-test-failures name)))))
;; Load src, compile, return DB.
(define
pl-cmp-mk
(fn
(src)
(let
((db (pl-mk-db)))
(pl-db-load! db (pl-parse src))
(pl-compile-db! db)
db)))
;; Run goal string against compiled DB; return bool (instantiates vars).
(define
pl-cmp-once
(fn
(db src)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal src) {})
(pl-mk-trail))))
;; Count solutions for goal string against compiled DB.
(define
pl-cmp-count
(fn
(db src)
(pl-solve-count!
db
(pl-instantiate (pl-parse-goal src) {})
(pl-mk-trail))))
;; ── 1. Simple facts ──────────────────────────────────────────────
(define pl-cmp-db1 (pl-cmp-mk "color(red). color(green). color(blue)."))
(pl-cmp-test! "compiled fact hit" (pl-cmp-once pl-cmp-db1 "color(red)") true)
(pl-cmp-test!
"compiled fact miss"
(pl-cmp-once pl-cmp-db1 "color(yellow)")
false)
(pl-cmp-test! "compiled fact count" (pl-cmp-count pl-cmp-db1 "color(X)") 3)
;; ── 2. Recursive rule: append ────────────────────────────────────
(define
pl-cmp-db2
(pl-cmp-mk "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R)."))
(pl-cmp-test!
"compiled append build"
(pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2,3])")
true)
(pl-cmp-test!
"compiled append fail"
(pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2])")
false)
(pl-cmp-test!
"compiled append split count"
(pl-cmp-count pl-cmp-db2 "append(X, Y, [a,b])")
3)
;; ── 3. Cut ───────────────────────────────────────────────────────
(define
pl-cmp-db3
(pl-cmp-mk "first(X, [X|_]) :- !. first(X, [_|T]) :- first(X, T)."))
(pl-cmp-test!
"compiled cut: only one solution"
(pl-cmp-count pl-cmp-db3 "first(X, [a,b,c])")
1)
(let
((db pl-cmp-db3) (trail (pl-mk-trail)) (env {}))
(let
((x (pl-mk-rt-var "X")))
(dict-set! env "X" x)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal "first(X, [a,b,c])") env)
trail)
(pl-cmp-test!
"compiled cut: correct binding"
(pl-atom-name (pl-walk x))
"a")))
;; ── 4. member ────────────────────────────────────────────────────
(define
pl-cmp-db4
(pl-cmp-mk "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
(pl-cmp-test!
"compiled member hit"
(pl-cmp-once pl-cmp-db4 "member(b, [a,b,c])")
true)
(pl-cmp-test!
"compiled member miss"
(pl-cmp-once pl-cmp-db4 "member(d, [a,b,c])")
false)
(pl-cmp-test!
"compiled member count"
(pl-cmp-count pl-cmp-db4 "member(X, [a,b,c])")
3)
;; ── 5. Arithmetic in body ────────────────────────────────────────
(define pl-cmp-db5 (pl-cmp-mk "double(X, Y) :- Y is X * 2."))
(let
((db pl-cmp-db5) (trail (pl-mk-trail)) (env {}))
(let
((y (pl-mk-rt-var "Y")))
(dict-set! env "Y" y)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal "double(5, Y)") env)
trail)
(pl-cmp-test! "compiled arithmetic in body" (pl-num-val (pl-walk y)) 10)))
;; ── 6. Transitive ancestor ───────────────────────────────────────
(define
pl-cmp-db6
(pl-cmp-mk
(str
"parent(a,b). parent(b,c). parent(c,d)."
"ancestor(X,Y) :- parent(X,Y)."
"ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y).")))
(pl-cmp-test!
"compiled ancestor direct"
(pl-cmp-once pl-cmp-db6 "ancestor(a,b)")
true)
(pl-cmp-test!
"compiled ancestor 3-step"
(pl-cmp-once pl-cmp-db6 "ancestor(a,d)")
true)
(pl-cmp-test!
"compiled ancestor fail"
(pl-cmp-once pl-cmp-db6 "ancestor(d,a)")
false)
;; ── 7. Fallback: uncompiled predicate calls compiled sub-predicate
(define
pl-cmp-db7
(let
((db (pl-mk-db)))
(pl-db-load! db (pl-parse "q(1). q(2)."))
(pl-compile-db! db)
(pl-db-load! db (pl-parse "r(X) :- q(X)."))
db))
(pl-cmp-test!
"uncompiled predicate resolves"
(pl-cmp-once pl-cmp-db7 "r(1)")
true)
(pl-cmp-test!
"uncompiled calls compiled sub-pred count"
(pl-cmp-count pl-cmp-db7 "r(X)")
2)
;; ── Runner ───────────────────────────────────────────────────────
(define pl-compiler-tests-run! (fn () {:failed pl-cmp-test-fail :passed pl-cmp-test-pass :total pl-cmp-test-count :failures pl-cmp-test-failures}))

View File

@@ -1,86 +0,0 @@
;; lib/prolog/tests/cross_validate.sx
;; Verifies that the compiled solver produces the same solution counts as the
;; interpreter for each classic program + built-in exercise.
;; Interpreter is the reference: if they disagree, the compiler is wrong.
(define pl-xv-test-count 0)
(define pl-xv-test-pass 0)
(define pl-xv-test-fail 0)
(define pl-xv-test-failures (list))
(define
pl-xv-test!
(fn
(name got expected)
(set! pl-xv-test-count (+ pl-xv-test-count 1))
(if
(= got expected)
(set! pl-xv-test-pass (+ pl-xv-test-pass 1))
(begin
(set! pl-xv-test-fail (+ pl-xv-test-fail 1))
(append! pl-xv-test-failures name)))))
;; Shorthand: assert compiled result matches interpreter.
(define
pl-xv-match!
(fn
(name src goal)
(pl-xv-test! name (pl-compiled-matches-interp? src goal) true)))
;; ── 1. append/3 ─────────────────────────────────────────────────
(define
pl-xv-append
"append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(pl-xv-match! "append build 2+2" pl-xv-append "append([1,2],[3,4],X)")
(pl-xv-match! "append split [a,b,c]" pl-xv-append "append(X, Y, [a,b,c])")
(pl-xv-match! "append member-mode" pl-xv-append "append(_, [3], [1,2,3])")
;; ── 2. member/2 ─────────────────────────────────────────────────
(define pl-xv-member "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(pl-xv-match! "member check hit" pl-xv-member "member(b, [a,b,c])")
(pl-xv-match! "member count" pl-xv-member "member(X, [a,b,c])")
(pl-xv-match! "member empty" pl-xv-member "member(X, [])")
;; ── 3. facts + transitive rules ─────────────────────────────────
(define
pl-xv-ancestor
(str
"parent(a,b). parent(b,c). parent(c,d). parent(a,c)."
"ancestor(X,Y) :- parent(X,Y)."
"ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."))
(pl-xv-match! "ancestor direct" pl-xv-ancestor "ancestor(a,b)")
(pl-xv-match! "ancestor transitive" pl-xv-ancestor "ancestor(a,d)")
(pl-xv-match! "ancestor all from a" pl-xv-ancestor "ancestor(a,Y)")
;; ── 4. cut semantics ────────────────────────────────────────────
(define pl-xv-cut "first(X,[X|_]) :- !. first(X,[_|T]) :- first(X,T).")
(pl-xv-match! "cut one solution" pl-xv-cut "first(X,[a,b,c])")
(pl-xv-match! "cut empty list" pl-xv-cut "first(X,[])")
;; ── 5. arithmetic ───────────────────────────────────────────────
(define pl-xv-arith "sq(X,Y) :- Y is X * X. even(X) :- 0 is X mod 2.")
(pl-xv-match! "sq(3,Y) count" pl-xv-arith "sq(3,Y)")
(pl-xv-match! "sq(3,9) check" pl-xv-arith "sq(3,9)")
(pl-xv-match! "even(4) check" pl-xv-arith "even(4)")
(pl-xv-match! "even(3) check" pl-xv-arith "even(3)")
;; ── 6. if-then-else ─────────────────────────────────────────────
(define pl-xv-ite "classify(X, pos) :- X > 0, !. classify(_, nonpos).")
(pl-xv-match! "classify positive" pl-xv-ite "classify(5, C)")
(pl-xv-match! "classify zero" pl-xv-ite "classify(0, C)")
;; ── Runner ───────────────────────────────────────────────────────
(define pl-cross-validate-tests-run! (fn () {:failed pl-xv-test-fail :passed pl-xv-test-pass :total pl-xv-test-count :failures pl-xv-test-failures}))

View File

@@ -1,158 +0,0 @@
;; lib/prolog/tests/dynamic.sx — assert/asserta/assertz/retract.
(define pl-dy-test-count 0)
(define pl-dy-test-pass 0)
(define pl-dy-test-fail 0)
(define pl-dy-test-failures (list))
(define
pl-dy-test!
(fn
(name got expected)
(begin
(set! pl-dy-test-count (+ pl-dy-test-count 1))
(if
(= got expected)
(set! pl-dy-test-pass (+ pl-dy-test-pass 1))
(begin
(set! pl-dy-test-fail (+ pl-dy-test-fail 1))
(append!
pl-dy-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-dy-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; assertz then query
(define pl-dy-db1 (pl-mk-db))
(pl-solve-once!
pl-dy-db1
(pl-dy-goal "assertz(foo(1))" {})
(pl-mk-trail))
(pl-dy-test!
"assertz(foo(1)) + foo(1)"
(pl-solve-once! pl-dy-db1 (pl-dy-goal "foo(1)" {}) (pl-mk-trail))
true)
(pl-dy-test!
"after one assertz, foo/1 has 1 clause"
(pl-solve-count! pl-dy-db1 (pl-dy-goal "foo(X)" {}) (pl-mk-trail))
1)
;; assertz appends — order preserved
(define pl-dy-db2 (pl-mk-db))
(pl-solve-once!
pl-dy-db2
(pl-dy-goal "assertz(p(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db2
(pl-dy-goal "assertz(p(2))" {})
(pl-mk-trail))
(pl-dy-test!
"assertz twice — count 2"
(pl-solve-count! pl-dy-db2 (pl-dy-goal "p(X)" {}) (pl-mk-trail))
2)
(define pl-dy-env-a {})
(pl-solve-once! pl-dy-db2 (pl-dy-goal "p(X)" pl-dy-env-a) (pl-mk-trail))
(pl-dy-test!
"assertz: first solution is the first asserted (1)"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-a "X")))
1)
;; asserta prepends
(define pl-dy-db3 (pl-mk-db))
(pl-solve-once!
pl-dy-db3
(pl-dy-goal "assertz(p(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db3
(pl-dy-goal "asserta(p(99))" {})
(pl-mk-trail))
(define pl-dy-env-b {})
(pl-solve-once! pl-dy-db3 (pl-dy-goal "p(X)" pl-dy-env-b) (pl-mk-trail))
(pl-dy-test!
"asserta: prepended clause is first solution"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-b "X")))
99)
;; assert/1 = assertz/1
(define pl-dy-db4 (pl-mk-db))
(pl-solve-once!
pl-dy-db4
(pl-dy-goal "assert(g(7))" {})
(pl-mk-trail))
(pl-dy-test!
"assert/1 alias"
(pl-solve-once! pl-dy-db4 (pl-dy-goal "g(7)" {}) (pl-mk-trail))
true)
;; retract removes a fact
(define pl-dy-db5 (pl-mk-db))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(2))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(3))" {})
(pl-mk-trail))
(pl-dy-test!
"before retract: 3 clauses"
(pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
3)
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "retract(q(2))" {})
(pl-mk-trail))
(pl-dy-test!
"after retract(q(2)): 2 clauses left"
(pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
2)
(define pl-dy-env-c {})
(pl-solve-once! pl-dy-db5 (pl-dy-goal "q(X)" pl-dy-env-c) (pl-mk-trail))
(pl-dy-test!
"after retract(q(2)): first remaining is 1"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-c "X")))
1)
;; retract of non-existent
(pl-dy-test!
"retract(missing(0)) on empty db fails"
(pl-solve-once!
(pl-mk-db)
(pl-dy-goal "retract(missing(0))" {})
(pl-mk-trail))
false)
;; retract with unbound var matches first
(define pl-dy-db6 (pl-mk-db))
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "assertz(r(11))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "assertz(r(22))" {})
(pl-mk-trail))
(define pl-dy-env-d {})
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "retract(r(X))" pl-dy-env-d)
(pl-mk-trail))
(pl-dy-test!
"retract(r(X)) binds X to first match"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-d "X")))
11)
(define pl-dynamic-tests-run! (fn () {:failed pl-dy-test-fail :passed pl-dy-test-pass :total pl-dy-test-count :failures pl-dy-test-failures}))

View File

@@ -1,167 +0,0 @@
;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3.
(define pl-fb-test-count 0)
(define pl-fb-test-pass 0)
(define pl-fb-test-fail 0)
(define pl-fb-test-failures (list))
(define
pl-fb-test!
(fn
(name got expected)
(begin
(set! pl-fb-test-count (+ pl-fb-test-count 1))
(if
(= got expected)
(set! pl-fb-test-pass (+ pl-fb-test-pass 1))
(begin
(set! pl-fb-test-fail (+ pl-fb-test-fail 1))
(append!
pl-fb-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-fb-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-fb-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-fb-term-to-sx (first (pl-args w)))
(pl-fb-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t))))
(define
pl-fb-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(define pl-fb-db (pl-mk-db))
(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src))
;; ── findall ──
(define pl-fb-env-1 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1)
(pl-mk-trail))
(pl-fb-test!
"findall member [a, b, c]"
(pl-fb-list-to-sx (dict-get pl-fb-env-1 "L"))
(list "a" "b" "c"))
(define pl-fb-env-2 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2)
(pl-mk-trail))
(pl-fb-test!
"findall with comparison filter"
(pl-fb-list-to-sx (dict-get pl-fb-env-2 "L"))
(list 2 3))
(define pl-fb-env-3 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, fail, L)" pl-fb-env-3)
(pl-mk-trail))
(pl-fb-test!
"findall on fail succeeds with empty list"
(pl-fb-list-to-sx (dict-get pl-fb-env-3 "L"))
(list))
(pl-fb-test!
"findall(X, fail, L) the goal succeeds"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, fail, L)" {})
(pl-mk-trail))
true)
(define pl-fb-env-4 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal
"findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)"
pl-fb-env-4)
(pl-mk-trail))
(pl-fb-test!
"findall over compound template — count = 4"
(len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L")))
4)
;; ── bagof ──
(pl-fb-test!
"bagof succeeds when results exist"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {})
(pl-mk-trail))
true)
(pl-fb-test!
"bagof fails on empty"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, fail, L)" {})
(pl-mk-trail))
false)
(define pl-fb-env-5 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5)
(pl-mk-trail))
(pl-fb-test!
"bagof preserves order"
(pl-fb-list-to-sx (dict-get pl-fb-env-5 "L"))
(list "c" "a" "b"))
;; ── setof ──
(define pl-fb-env-6 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6)
(pl-mk-trail))
(pl-fb-test!
"setof sorts + dedupes atoms"
(pl-fb-list-to-sx (dict-get pl-fb-env-6 "L"))
(list "a" "b" "c"))
(pl-fb-test!
"setof fails on empty"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, fail, L)" {})
(pl-mk-trail))
false)
(define pl-fb-env-7 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7)
(pl-mk-trail))
(pl-fb-test!
"setof sorts + dedupes nums"
(pl-fb-list-to-sx (dict-get pl-fb-env-7 "L"))
(list 1 2 3))
(define pl-findall-tests-run! (fn () {:failed pl-fb-test-fail :passed pl-fb-test-pass :total pl-fb-test-count :failures pl-fb-test-failures}))

View File

@@ -1,326 +0,0 @@
;; lib/prolog/tests/io_predicates.sx — term_to_atom/2, term_string/2,
;; with_output_to/2, writeln/1, format/1, format/2
(define pl-io-test-count 0)
(define pl-io-test-pass 0)
(define pl-io-test-fail 0)
(define pl-io-test-failures (list))
(define
pl-io-test!
(fn
(name got expected)
(begin
(set! pl-io-test-count (+ pl-io-test-count 1))
(if
(= got expected)
(set! pl-io-test-pass (+ pl-io-test-pass 1))
(begin
(set! pl-io-test-fail (+ pl-io-test-fail 1))
(append!
pl-io-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-io-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-io-db (pl-mk-db))
;; helper: get output buffer after running a goal
(define
pl-io-capture!
(fn
(goal)
(do
(pl-output-clear!)
(pl-solve-once! pl-io-db goal (pl-mk-trail))
pl-output-buffer)))
;; ─── term_to_atom/2 — bound Term direction ─────────────────────────────────
(pl-io-test!
"term_to_atom(foo(a,b), A) — compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(foo(a,b), A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"foo(a, b)")
(pl-io-test!
"term_to_atom(hello, A) — atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(hello, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"hello")
(pl-io-test!
"term_to_atom(42, A) — number"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(42, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"42")
(pl-io-test!
"term_to_atom(foo(a,b), 'foo(a, b)') — succeeds when Atom matches"
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(foo(a,b), 'foo(a, b)')" {})
(pl-mk-trail))
true)
(pl-io-test!
"term_to_atom(hello, world) — fails on mismatch"
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(hello, world)" {})
(pl-mk-trail))
false)
;; ─── term_to_atom/2 — parse direction (Atom bound, Term unbound) ───────────
(pl-io-test!
"term_to_atom(T, 'foo(a)') — parse direction gives compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(T, 'foo(a)')" env)
(pl-mk-trail))
(let
((t (pl-walk-deep (dict-get env "T"))))
(and (pl-compound? t) (= (pl-fun t) "foo"))))
true)
(pl-io-test!
"term_to_atom(T, hello) — parse direction gives atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(T, hello)" env)
(pl-mk-trail))
(let
((t (pl-walk-deep (dict-get env "T"))))
(and (pl-atom? t) (= (pl-atom-name t) "hello"))))
true)
;; ─── term_string/2 — alias ──────────────────────────────────────────────────
(pl-io-test!
"term_string(bar(x), A) — same as term_to_atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_string(bar(x), A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"bar(x)")
(pl-io-test!
"term_string(42, A) — number to string"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_string(42, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"42")
;; ─── writeln/1 ─────────────────────────────────────────────────────────────
(pl-io-test!
"writeln(hello) writes 'hello\n'"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), writeln(hello))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello
")
(pl-io-test!
"writeln(42) writes '42\n'"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), writeln(42))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"42
")
;; ─── with_output_to/2 ──────────────────────────────────────────────────────
(pl-io-test!
"with_output_to(atom(X), write(foo)) — captures write output"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), write(foo))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"foo")
(pl-io-test!
"with_output_to(atom(X), (write(a), write(b))) — concat output"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), (write(a), write(b)))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"ab")
(pl-io-test!
"with_output_to(atom(X), nl) — captures newline"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), nl)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"
")
(pl-io-test!
"with_output_to(atom(X), true) — captures empty string"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), true)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"")
(pl-io-test!
"with_output_to(string(X), write(hello)) — string sink works"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(string(X), write(hello))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello")
(pl-io-test!
"with_output_to(atom(X), fail) — fails when goal fails"
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), fail)" {})
(pl-mk-trail))
false)
;; ─── format/1 ──────────────────────────────────────────────────────────────
(pl-io-test!
"format('hello~n') — tilde-n becomes newline"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('hello~n'))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello
")
(pl-io-test!
"format('~~') — double tilde becomes single tilde"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~~'))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"~")
(pl-io-test!
"format('abc') — plain text passes through"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format(abc))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"abc")
;; ─── format/2 ──────────────────────────────────────────────────────────────
(pl-io-test!
"format('~w+~w', [1,2]) — two ~w args"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~w+~w', [1,2]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"1+2")
(pl-io-test!
"format('hello ~a!', [world]) — ~a with atom arg"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('hello ~a!', [world]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello world!")
(pl-io-test!
"format('n=~d', [42]) — ~d with integer arg"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('n=~d', [42]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"n=42")
(pl-io-test!
"format('~w', [foo(a)]) — ~w with compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~w', [foo(a)]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"foo(a)")
(define
pl-io-predicates-tests-run!
(fn
()
{:failed pl-io-test-fail
:passed pl-io-test-pass
:total pl-io-test-count
:failures pl-io-test-failures}))

View File

@@ -1,320 +0,0 @@
;; lib/prolog/tests/iso_predicates.sx — succ/2, plus/3, between/3, length/2, last/2, nth0/3, nth1/3, max/min arith
(define pl-ip-test-count 0)
(define pl-ip-test-pass 0)
(define pl-ip-test-fail 0)
(define pl-ip-test-failures (list))
(define
pl-ip-test!
(fn
(name got expected)
(begin
(set! pl-ip-test-count (+ pl-ip-test-count 1))
(if
(= got expected)
(set! pl-ip-test-pass (+ pl-ip-test-pass 1))
(begin
(set! pl-ip-test-fail (+ pl-ip-test-fail 1))
(append!
pl-ip-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ip-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-ip-db (pl-mk-db))
;; ── succ/2 ──
(define pl-ip-env-s1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(3, X)" pl-ip-env-s1)
(pl-mk-trail))
(pl-ip-test!
"succ(3, X) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s1 "X")))
4)
(define pl-ip-env-s2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(0, X)" pl-ip-env-s2)
(pl-mk-trail))
(pl-ip-test!
"succ(0, X) → X=1"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s2 "X")))
1)
(define pl-ip-env-s3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(X, 5)" pl-ip-env-s3)
(pl-mk-trail))
(pl-ip-test!
"succ(X, 5) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s3 "X")))
4)
(pl-ip-test!
"succ(X, 0) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(X, 0)" {})
(pl-mk-trail))
false)
;; ── plus/3 ──
(define pl-ip-env-p1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(2, 3, X)" pl-ip-env-p1)
(pl-mk-trail))
(pl-ip-test!
"plus(2, 3, X) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p1 "X")))
5)
(define pl-ip-env-p2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(2, X, 7)" pl-ip-env-p2)
(pl-mk-trail))
(pl-ip-test!
"plus(2, X, 7) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p2 "X")))
5)
(define pl-ip-env-p3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(X, 3, 7)" pl-ip-env-p3)
(pl-mk-trail))
(pl-ip-test!
"plus(X, 3, 7) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p3 "X")))
4)
(pl-ip-test!
"plus(0, 0, 0) succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(0, 0, 0)" {})
(pl-mk-trail))
true)
;; ── between/3 ──
(pl-ip-test!
"between(1, 3, X): 3 solutions"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(1, 3, X)" {})
(pl-mk-trail))
3)
(pl-ip-test!
"between(1, 3, 2) succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 3, 2)" {})
(pl-mk-trail))
true)
(pl-ip-test!
"between(1, 3, 5) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 3, 5)" {})
(pl-mk-trail))
false)
(pl-ip-test!
"between(5, 3, X): 0 solutions (empty range)"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(5, 3, X)" {})
(pl-mk-trail))
0)
(define pl-ip-env-b1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 5, X)" pl-ip-env-b1)
(pl-mk-trail))
(pl-ip-test!
"between(1, 5, X): first solution X=1"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-b1 "X")))
1)
(pl-ip-test!
"between + condition: between(1,5,X), X > 3 → 2 solutions"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(1, 5, X), X > 3" {})
(pl-mk-trail))
2)
;; ── length/2 ──
(define pl-ip-env-l1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([1,2,3], N)" pl-ip-env-l1)
(pl-mk-trail))
(pl-ip-test!
"length([1,2,3], N) → N=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-l1 "N")))
3)
(define pl-ip-env-l2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([], N)" pl-ip-env-l2)
(pl-mk-trail))
(pl-ip-test!
"length([], N) → N=0"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-l2 "N")))
0)
(pl-ip-test!
"length([a,b], 2) check succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([a,b], 2)" {})
(pl-mk-trail))
true)
(define pl-ip-env-l3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length(L, 3)" pl-ip-env-l3)
(pl-mk-trail))
(pl-ip-test!
"length(L, 3): L is a list of length 3"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length(L, 3), is_list(L)" pl-ip-env-l3)
(pl-mk-trail))
true)
;; ── last/2 ──
(define pl-ip-env-la1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([1,2,3], X)" pl-ip-env-la1)
(pl-mk-trail))
(pl-ip-test!
"last([1,2,3], X) → X=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-la1 "X")))
3)
(define pl-ip-env-la2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([a], X)" pl-ip-env-la2)
(pl-mk-trail))
(pl-ip-test!
"last([a], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-la2 "X")))
"a")
(pl-ip-test!
"last([], X) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([], X)" {})
(pl-mk-trail))
false)
;; ── nth0/3 ──
(define pl-ip-env-n0 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(0, [a,b,c], X)" pl-ip-env-n0)
(pl-mk-trail))
(pl-ip-test!
"nth0(0, [a,b,c], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n0 "X")))
"a")
(define pl-ip-env-n1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(2, [a,b,c], X)" pl-ip-env-n1)
(pl-mk-trail))
(pl-ip-test!
"nth0(2, [a,b,c], X) → X=c"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1 "X")))
"c")
(pl-ip-test!
"nth0(5, [a,b,c], X) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(5, [a,b,c], X)" {})
(pl-mk-trail))
false)
;; ── nth1/3 ──
(define pl-ip-env-n1a {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth1(1, [a,b,c], X)" pl-ip-env-n1a)
(pl-mk-trail))
(pl-ip-test!
"nth1(1, [a,b,c], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1a "X")))
"a")
(define pl-ip-env-n1b {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth1(3, [a,b,c], X)" pl-ip-env-n1b)
(pl-mk-trail))
(pl-ip-test!
"nth1(3, [a,b,c], X) → X=c"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1b "X")))
"c")
;; ── max/min in arithmetic ──
(define pl-ip-env-m1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is max(3, 5)" pl-ip-env-m1)
(pl-mk-trail))
(pl-ip-test!
"X is max(3, 5) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m1 "X")))
5)
(define pl-ip-env-m2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is min(3, 5)" pl-ip-env-m2)
(pl-mk-trail))
(pl-ip-test!
"X is min(3, 5) → X=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m2 "X")))
3)
(define pl-ip-env-m3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is max(7, 2) + min(1, 4)" pl-ip-env-m3)
(pl-mk-trail))
(pl-ip-test!
"X is max(7,2) + min(1,4) → X=8"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m3 "X")))
8)
(define pl-iso-predicates-tests-run! (fn () {:failed pl-ip-test-fail :passed pl-ip-test-pass :total pl-ip-test-count :failures pl-ip-test-failures}))

View File

@@ -1,335 +0,0 @@
;; lib/prolog/tests/list_predicates.sx — ==/2, \==/2, flatten/2, numlist/3,
;; atomic_list_concat/2,3, sum_list/2, max_list/2, min_list/2, delete/3
(define pl-lp-test-count 0)
(define pl-lp-test-pass 0)
(define pl-lp-test-fail 0)
(define pl-lp-test-failures (list))
(define
pl-lp-test!
(fn
(name got expected)
(begin
(set! pl-lp-test-count (+ pl-lp-test-count 1))
(if
(= got expected)
(set! pl-lp-test-pass (+ pl-lp-test-pass 1))
(begin
(set! pl-lp-test-fail (+ pl-lp-test-fail 1))
(append!
pl-lp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-lp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-lp-db (pl-mk-db))
;; ── ==/2 ───────────────────────────────────────────────────────────
(pl-lp-test!
"==(a, a) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(a, a)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"==(a, b) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(a, b)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"==(1, 1) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 1)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"==(1, 2) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 2)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"==(f(a,b), f(a,b)) succeeds"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "==(f(a,b), f(a,b))" {})
(pl-mk-trail))
true)
(pl-lp-test!
"==(f(a,b), f(a,c)) fails"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "==(f(a,b), f(a,c))" {})
(pl-mk-trail))
false)
;; unbound var vs atom: fails (different tags)
(pl-lp-test!
"==(X, a) fails (unbound var vs atom)"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(X, a)" {}) (pl-mk-trail))
false)
;; two unbound vars with SAME name in same env share the same runtime var
(define pl-lp-env-same-var {})
(pl-lp-goal "==(X, X)" pl-lp-env-same-var)
(pl-lp-test!
"==(X, X) succeeds (same runtime var)"
(pl-solve-once!
pl-lp-db
(pl-instantiate
(nth (first (pl-parse "g :- ==(X, X).")) 2)
pl-lp-env-same-var)
(pl-mk-trail))
true)
;; ── \==/2 ──────────────────────────────────────────────────────────
(pl-lp-test!
"\\==(a, b) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, b)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"\\==(a, a) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, a)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"\\==(X, a) succeeds (unbound var differs from atom)"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(X, a)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"\\==(1, 2) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(1, 2)" {}) (pl-mk-trail))
true)
;; ── flatten/2 ──────────────────────────────────────────────────────
(define pl-lp-env-fl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([], F)" pl-lp-env-fl1)
(pl-mk-trail))
(pl-lp-test!
"flatten([], []) -> empty"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl1 "F")))
"[]")
(define pl-lp-env-fl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([1,2,3], F)" pl-lp-env-fl2)
(pl-mk-trail))
(pl-lp-test!
"flatten([1,2,3], F) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl2 "F")))
".(1, .(2, .(3, [])))")
(define pl-lp-env-fl3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([1,[2,[3]],4], F)" pl-lp-env-fl3)
(pl-mk-trail))
(pl-lp-test!
"flatten([1,[2,[3]],4], F) -> [1,2,3,4]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl3 "F")))
".(1, .(2, .(3, .(4, []))))")
(define pl-lp-env-fl4 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([[a,b],[c]], F)" pl-lp-env-fl4)
(pl-mk-trail))
(pl-lp-test!
"flatten([[a,b],[c]], F) -> [a,b,c]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl4 "F")))
".(a, .(b, .(c, [])))")
;; ── numlist/3 ──────────────────────────────────────────────────────
(define pl-lp-env-nl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(1, 5, L)" pl-lp-env-nl1)
(pl-mk-trail))
(pl-lp-test!
"numlist(1,5,L) -> [1,2,3,4,5]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl1 "L")))
".(1, .(2, .(3, .(4, .(5, [])))))")
(define pl-lp-env-nl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(3, 3, L)" pl-lp-env-nl2)
(pl-mk-trail))
(pl-lp-test!
"numlist(3,3,L) -> [3]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl2 "L")))
".(3, [])")
(pl-lp-test!
"numlist(5, 3, L) fails (Low > High)"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(5, 3, L)" {})
(pl-mk-trail))
false)
;; ── atomic_list_concat/2 ───────────────────────────────────────────
(define pl-lp-env-alc1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([a, b, c], R)" pl-lp-env-alc1)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([a,b,c], R) -> abc"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc1 "R")))
"abc")
(define pl-lp-env-alc2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([hello, world], R)" pl-lp-env-alc2)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([hello,world], R) -> helloworld"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc2 "R")))
"helloworld")
;; ── atomic_list_concat/3 ───────────────────────────────────────────
(define pl-lp-env-alcs1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([a, b, c], '-', R)" pl-lp-env-alcs1)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([a,b,c], '-', R) -> a-b-c"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs1 "R")))
"a-b-c")
(define pl-lp-env-alcs2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([x], '-', R)" pl-lp-env-alcs2)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([x], '-', R) -> x (single element, no sep)"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs2 "R")))
"x")
;; ── sum_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-sl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([1,2,3], S)" pl-lp-env-sl1)
(pl-mk-trail))
(pl-lp-test!
"sum_list([1,2,3], S) -> 6"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl1 "S")))
6)
(define pl-lp-env-sl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([10], S)" pl-lp-env-sl2)
(pl-mk-trail))
(pl-lp-test!
"sum_list([10], S) -> 10"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl2 "S")))
10)
(define pl-lp-env-sl3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([], S)" pl-lp-env-sl3)
(pl-mk-trail))
(pl-lp-test!
"sum_list([], S) -> 0"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl3 "S")))
0)
;; ── max_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-mx1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "max_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mx1)
(pl-mk-trail))
(pl-lp-test!
"max_list([3,1,4,1,5,9,2,6], M) -> 9"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx1 "M")))
9)
(define pl-lp-env-mx2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "max_list([7], M)" pl-lp-env-mx2)
(pl-mk-trail))
(pl-lp-test!
"max_list([7], M) -> 7"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx2 "M")))
7)
;; ── min_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-mn1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "min_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mn1)
(pl-mk-trail))
(pl-lp-test!
"min_list([3,1,4,1,5,9,2,6], M) -> 1"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn1 "M")))
1)
(define pl-lp-env-mn2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "min_list([5,2,8], M)" pl-lp-env-mn2)
(pl-mk-trail))
(pl-lp-test!
"min_list([5,2,8], M) -> 2"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn2 "M")))
2)
;; ── delete/3 ───────────────────────────────────────────────────────
(define pl-lp-env-del1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([1,2,3,2,1], 2, R)" pl-lp-env-del1)
(pl-mk-trail))
(pl-lp-test!
"delete([1,2,3,2,1], 2, R) -> [1,3,1]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del1 "R")))
".(1, .(3, .(1, [])))")
(define pl-lp-env-del2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([a,b,c], d, R)" pl-lp-env-del2)
(pl-mk-trail))
(pl-lp-test!
"delete([a,b,c], d, R) -> [a,b,c] (nothing deleted)"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del2 "R")))
".(a, .(b, .(c, [])))")
(define pl-lp-env-del3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([], x, R)" pl-lp-env-del3)
(pl-mk-trail))
(pl-lp-test!
"delete([], x, R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del3 "R")))
"[]")
(define pl-list-predicates-tests-run! (fn () {:failed pl-lp-test-fail :passed pl-lp-test-pass :total pl-lp-test-count :failures pl-lp-test-failures}))

View File

@@ -1,197 +0,0 @@
;; lib/prolog/tests/meta_call.sx — forall/2, maplist/2, maplist/3, include/3, exclude/3
(define pl-mc-test-count 0)
(define pl-mc-test-pass 0)
(define pl-mc-test-fail 0)
(define pl-mc-test-failures (list))
(define
pl-mc-test!
(fn
(name got expected)
(begin
(set! pl-mc-test-count (+ pl-mc-test-count 1))
(if
(= got expected)
(set! pl-mc-test-pass (+ pl-mc-test-pass 1))
(begin
(set! pl-mc-test-fail (+ pl-mc-test-fail 1))
(append!
pl-mc-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mc-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-mc-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(else t))))
(define
pl-mc-list-sx
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) "."))
(cons
(pl-mc-term-to-sx (first (pl-args w)))
(pl-mc-list-sx (nth (pl-args w) 1))))
(else (list :not-list))))))
(define pl-mc-db (pl-mk-db))
(pl-db-load!
pl-mc-db
(pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
(pl-db-load! pl-mc-db (pl-parse "double(X, Y) :- Y is X * 2."))
(pl-db-load! pl-mc-db (pl-parse "even(X) :- 0 is X mod 2."))
;; -- forall/2 --
(pl-mc-test!
"forall(member(X,[2,4,6]), 0 is X mod 2) — all even"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(X,[2,4,6]), 0 is X mod 2)" {})
(pl-mk-trail))
true)
(pl-mc-test!
"forall(member(X,[2,3,6]), 0 is X mod 2) — 3 is odd, fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(X,[2,3,6]), 0 is X mod 2)" {})
(pl-mk-trail))
false)
(pl-mc-test!
"forall(member(_,[]), true) — vacuously true"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(_,[]), true)" {})
(pl-mk-trail))
true)
;; -- maplist/2 --
(pl-mc-test!
"maplist(atom, [a,b,c]) — all atoms"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"maplist(atom, [a,1,c]) — 1 is not atom, fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [a,1,c])" {})
(pl-mk-trail))
false)
(pl-mc-test!
"maplist(atom, []) — vacuously true"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [])" {})
(pl-mk-trail))
true)
;; -- maplist/3 --
(pl-mc-test!
"maplist(double, [1,2,3], [2,4,6]) — deterministic check"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], [2,4,6])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"maplist(double, [1,2,3], [2,4,7]) — wrong result fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], [2,4,7])" {})
(pl-mk-trail))
false)
(define pl-mc-env-ml3 {:L (pl-mk-rt-var "L")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], L)" pl-mc-env-ml3)
(pl-mk-trail))
(pl-mc-test!
"maplist(double, [1,2,3], L) — L bound to [2,4,6]"
(pl-mc-list-sx (dict-get pl-mc-env-ml3 "L"))
(list 2 4 6))
;; -- include/3 --
(pl-mc-test!
"include(even, [1,2,3,4,5,6], [2,4,6])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [1,2,3,4,5,6], [2,4,6])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"include(even, [], [])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [], [])" {})
(pl-mk-trail))
true)
(define pl-mc-env-inc {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [1,2,3,4,5,6], R)" pl-mc-env-inc)
(pl-mk-trail))
(pl-mc-test!
"include(even, [1,2,3,4,5,6], R) — R bound to [2,4,6]"
(pl-mc-list-sx (dict-get pl-mc-env-inc "R"))
(list 2 4 6))
;; -- exclude/3 --
(pl-mc-test!
"exclude(even, [1,2,3,4,5,6], [1,3,5])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [1,2,3,4,5,6], [1,3,5])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"exclude(even, [], [])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [], [])" {})
(pl-mk-trail))
true)
(define pl-mc-env-exc {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [1,2,3,4,5,6], R)" pl-mc-env-exc)
(pl-mk-trail))
(pl-mc-test!
"exclude(even, [1,2,3,4,5,6], R) — R bound to [1,3,5]"
(pl-mc-list-sx (dict-get pl-mc-env-exc "R"))
(list 1 3 5))
(define pl-meta-call-tests-run! (fn () {:failed pl-mc-test-fail :passed pl-mc-test-pass :total pl-mc-test-count :failures pl-mc-test-failures}))

View File

@@ -1,252 +0,0 @@
;; lib/prolog/tests/meta_predicates.sx — \+/1, not/1, once/1, ignore/1, ground/1, sort/2, msort/2, atom_number/2, number_string/2
(define pl-mp-test-count 0)
(define pl-mp-test-pass 0)
(define pl-mp-test-fail 0)
(define pl-mp-test-failures (list))
(define
pl-mp-test!
(fn
(name got expected)
(begin
(set! pl-mp-test-count (+ pl-mp-test-count 1))
(if
(= got expected)
(set! pl-mp-test-pass (+ pl-mp-test-pass 1))
(begin
(set! pl-mp-test-fail (+ pl-mp-test-fail 1))
(append!
pl-mp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-mp-db (pl-mk-db))
(pl-db-load!
pl-mp-db
(pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
;; -- \+/1 --
(pl-mp-test!
"\\+(fail) succeeds"
(pl-solve-once! pl-mp-db (pl-mp-goal "\\+(fail)" {}) (pl-mk-trail))
true)
(pl-mp-test!
"\\+(true) fails"
(pl-solve-once! pl-mp-db (pl-mp-goal "\\+(true)" {}) (pl-mk-trail))
false)
(pl-mp-test!
"\\+(member(d, [a,b,c])) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(member(d, [a,b,c]))" {})
(pl-mk-trail))
true)
(pl-mp-test!
"\\+(member(a, [a,b,c])) fails"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(member(a, [a,b,c]))" {})
(pl-mk-trail))
false)
(define pl-mp-env-neg {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(X = 5)" pl-mp-env-neg)
(pl-mk-trail))
(pl-mp-test!
"\\+(X=5) fails, X stays unbound (bindings undone)"
(nil? (pl-var-binding (dict-get pl-mp-env-neg "X")))
true)
;; -- not/1 --
(pl-mp-test!
"not(fail) succeeds"
(pl-solve-once! pl-mp-db (pl-mp-goal "not(fail)" {}) (pl-mk-trail))
true)
(pl-mp-test!
"not(true) fails"
(pl-solve-once! pl-mp-db (pl-mp-goal "not(true)" {}) (pl-mk-trail))
false)
;; -- once/1 --
(pl-mp-test!
"once(member(X,[1,2,3])) succeeds once"
(pl-solve-count!
pl-mp-db
(pl-mp-goal "once(member(X,[1,2,3]))" {})
(pl-mk-trail))
1)
(define pl-mp-env-once {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "once(member(X,[1,2,3]))" pl-mp-env-once)
(pl-mk-trail))
(pl-mp-test!
"once(member(X,[1,2,3])): X=1 (first solution)"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-once "X")))
1)
(pl-mp-test!
"once(fail) fails"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "once(fail)" {})
(pl-mk-trail))
false)
;; -- ignore/1 --
(pl-mp-test!
"ignore(true) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ignore(true)" {})
(pl-mk-trail))
true)
(pl-mp-test!
"ignore(fail) still succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ignore(fail)" {})
(pl-mk-trail))
true)
;; -- ground/1 --
(pl-mp-test!
"ground(foo(1, a)) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(foo(1, a))" {})
(pl-mk-trail))
true)
(pl-mp-test!
"ground(foo(X, a)) fails (X unbound)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(foo(X, a))" {})
(pl-mk-trail))
false)
(pl-mp-test!
"ground(42) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(42)" {})
(pl-mk-trail))
true)
;; -- sort/2 --
(pl-mp-test!
"sort([b,a,c], [a,b,c])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([b,a,c], [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"sort([b,a,a,c], [a,b,c]) (removes duplicates)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([b,a,a,c], [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"sort([], [])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([], [])" {})
(pl-mk-trail))
true)
;; -- msort/2 --
(pl-mp-test!
"msort([b,a,a,c], [a,a,b,c]) (keeps duplicates)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "msort([b,a,a,c], [a,a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"msort([3,1,2,1], [1,1,2,3])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "msort([3,1,2,1], [1,1,2,3])" {})
(pl-mk-trail))
true)
;; -- atom_number/2 --
(define pl-mp-env-an1 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number('42', N)" pl-mp-env-an1)
(pl-mk-trail))
(pl-mp-test!
"atom_number('42', N) -> N=42"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-an1 "N")))
42)
(define pl-mp-env-an2 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number(A, 7)" pl-mp-env-an2)
(pl-mk-trail))
(pl-mp-test!
"atom_number(A, 7) -> A='7'"
(pl-atom-name (pl-walk-deep (dict-get pl-mp-env-an2 "A")))
"7")
(pl-mp-test!
"atom_number(foo, N) fails (not a number)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number(foo, N)" {})
(pl-mk-trail))
false)
;; -- number_string/2 --
(define pl-mp-env-ns1 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "number_string(42, S)" pl-mp-env-ns1)
(pl-mk-trail))
(pl-mp-test!
"number_string(42, S) -> S='42'"
(pl-atom-name (pl-walk-deep (dict-get pl-mp-env-ns1 "S")))
"42")
(define pl-mp-env-ns2 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "number_string(N, '3.14')" pl-mp-env-ns2)
(pl-mk-trail))
(pl-mp-test!
"number_string(N, '3.14') -> N=3.14"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-ns2 "N")))
3.14)
(define pl-meta-predicates-tests-run! (fn () {:failed pl-mp-test-fail :passed pl-mp-test-pass :total pl-mp-test-count :failures pl-mp-test-failures}))

View File

@@ -1,193 +0,0 @@
;; lib/prolog/tests/operators.sx — operator-table parsing + comparison built-ins.
(define pl-op-test-count 0)
(define pl-op-test-pass 0)
(define pl-op-test-fail 0)
(define pl-op-test-failures (list))
(define
pl-op-test!
(fn
(name got expected)
(begin
(set! pl-op-test-count (+ pl-op-test-count 1))
(if
(= got expected)
(set! pl-op-test-pass (+ pl-op-test-pass 1))
(begin
(set! pl-op-test-fail (+ pl-op-test-fail 1))
(append!
pl-op-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define pl-op-empty-db (pl-mk-db))
(define
pl-op-body
(fn (src) (nth (first (pl-parse (str "g :- " src "."))) 2)))
(define pl-op-goal (fn (src env) (pl-instantiate (pl-op-body src) env)))
;; ── parsing tests ──
(pl-op-test!
"infix +"
(pl-op-body "a + b")
(list "compound" "+" (list (list "atom" "a") (list "atom" "b"))))
(pl-op-test!
"infix * tighter than +"
(pl-op-body "a + b * c")
(list
"compound"
"+"
(list
(list "atom" "a")
(list "compound" "*" (list (list "atom" "b") (list "atom" "c"))))))
(pl-op-test!
"parens override precedence"
(pl-op-body "(a + b) * c")
(list
"compound"
"*"
(list
(list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
(list "atom" "c"))))
(pl-op-test!
"+ is yfx (left-assoc)"
(pl-op-body "a + b + c")
(list
"compound"
"+"
(list
(list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
(list "atom" "c"))))
(pl-op-test!
"; is xfy (right-assoc)"
(pl-op-body "a ; b ; c")
(list
"compound"
";"
(list
(list "atom" "a")
(list "compound" ";" (list (list "atom" "b") (list "atom" "c"))))))
(pl-op-test!
"= folds at 700"
(pl-op-body "X = 5")
(list "compound" "=" (list (list "var" "X") (list "num" 5))))
(pl-op-test!
"is + nests via 700>500>400"
(pl-op-body "X is 2 + 3 * 4")
(list
"compound"
"is"
(list
(list "var" "X")
(list
"compound"
"+"
(list
(list "num" 2)
(list "compound" "*" (list (list "num" 3) (list "num" 4))))))))
(pl-op-test!
"< parses at 700"
(pl-op-body "2 < 3")
(list "compound" "<" (list (list "num" 2) (list "num" 3))))
(pl-op-test!
"mod parses as yfx 400"
(pl-op-body "10 mod 3")
(list "compound" "mod" (list (list "num" 10) (list "num" 3))))
(pl-op-test!
"comma in body folds right-assoc"
(pl-op-body "a, b, c")
(list
"compound"
","
(list
(list "atom" "a")
(list "compound" "," (list (list "atom" "b") (list "atom" "c"))))))
;; ── solver tests via infix ──
(pl-op-test!
"X is 2 + 3 binds X = 5"
(let
((env {}) (trail (pl-mk-trail)))
(begin
(pl-solve-once! pl-op-empty-db (pl-op-goal "X is 2 + 3" env) trail)
(pl-num-val (pl-walk-deep (dict-get env "X")))))
5)
(pl-op-test!
"infix conjunction parses + solves"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "X = 5, X = 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"infix mismatch fails"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "X = 5, X = 6" {})
(pl-mk-trail))
false)
(pl-op-test!
"infix disjunction picks left"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "true ; fail" {})
(pl-mk-trail))
true)
(pl-op-test!
"2 < 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "2 < 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"5 < 2 fails"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "5 < 2" {})
(pl-mk-trail))
false)
(pl-op-test!
"5 >= 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "5 >= 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"3 =< 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "3 =< 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"infix < with arithmetic both sides"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "1 + 2 < 2 * 3" {})
(pl-mk-trail))
true)
(define pl-operators-tests-run! (fn () {:failed pl-op-test-fail :passed pl-op-test-pass :total pl-op-test-count :failures pl-op-test-failures}))

View File

@@ -1,5 +0,0 @@
%% append/3 list concatenation, classic Prolog
%% Two clauses: empty-prefix base case + recursive cons-prefix.
%% Bidirectional works in all modes: build, check, split.
append([], L, L).
append([H|T], L, [H|R]) :- append(T, L, R).

View File

@@ -1,114 +0,0 @@
;; lib/prolog/tests/programs/append.sx — append/3 test runner
;;
;; Mirrors the Prolog source in append.pl (embedded as a string here because
;; the SX runtime has no file-read primitive yet).
(define pl-ap-test-count 0)
(define pl-ap-test-pass 0)
(define pl-ap-test-fail 0)
(define pl-ap-test-failures (list))
(define
pl-ap-test!
(fn
(name got expected)
(begin
(set! pl-ap-test-count (+ pl-ap-test-count 1))
(if
(= got expected)
(set! pl-ap-test-pass (+ pl-ap-test-pass 1))
(begin
(set! pl-ap-test-fail (+ pl-ap-test-fail 1))
(append!
pl-ap-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ap-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-ap-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-ap-term-to-sx (first (pl-args w)))
(pl-ap-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-ap-list-to-sx (fn (t) (pl-ap-list-walked (pl-walk-deep t))))
(define
pl-ap-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-ap-prog-src
"append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(define pl-ap-db (pl-mk-db))
(pl-db-load! pl-ap-db (pl-parse pl-ap-prog-src))
(define pl-ap-env-1 {})
(define pl-ap-goal-1 (pl-ap-goal "append([], [a, b], X)" pl-ap-env-1))
(pl-solve-once! pl-ap-db pl-ap-goal-1 (pl-mk-trail))
(pl-ap-test!
"append([], [a, b], X) → X = [a, b]"
(pl-ap-list-to-sx (dict-get pl-ap-env-1 "X"))
(list "a" "b"))
(define pl-ap-env-2 {})
(define pl-ap-goal-2 (pl-ap-goal "append([1, 2], [3, 4], X)" pl-ap-env-2))
(pl-solve-once! pl-ap-db pl-ap-goal-2 (pl-mk-trail))
(pl-ap-test!
"append([1, 2], [3, 4], X) → X = [1, 2, 3, 4]"
(pl-ap-list-to-sx (dict-get pl-ap-env-2 "X"))
(list 1 2 3 4))
(pl-ap-test!
"append([1], [2, 3], [1, 2, 3]) succeeds"
(pl-solve-once!
pl-ap-db
(pl-ap-goal "append([1], [2, 3], [1, 2, 3])" {})
(pl-mk-trail))
true)
(pl-ap-test!
"append([1, 2], [3], [1, 2, 4]) fails"
(pl-solve-once!
pl-ap-db
(pl-ap-goal "append([1, 2], [3], [1, 2, 4])" {})
(pl-mk-trail))
false)
(pl-ap-test!
"append(X, Y, [1, 2, 3]) backtracks 4 times"
(pl-solve-count!
pl-ap-db
(pl-ap-goal "append(X, Y, [1, 2, 3])" {})
(pl-mk-trail))
4)
(define pl-ap-env-6 {})
(define pl-ap-goal-6 (pl-ap-goal "append(X, [3], [1, 2, 3])" pl-ap-env-6))
(pl-solve-once! pl-ap-db pl-ap-goal-6 (pl-mk-trail))
(pl-ap-test!
"append(X, [3], [1, 2, 3]) deduces X = [1, 2]"
(pl-ap-list-to-sx (dict-get pl-ap-env-6 "X"))
(list 1 2))
(define pl-append-tests-run! (fn () {:failed pl-ap-test-fail :passed pl-ap-test-pass :total pl-ap-test-count :failures pl-ap-test-failures}))

View File

@@ -1,24 +0,0 @@
%% family facts + transitive ancestor + derived relations.
%% Five-generation tree: tom -> bob -> {ann, pat} -> jim, plus tom's
%% other child liz.
parent(tom, bob).
parent(tom, liz).
parent(bob, ann).
parent(bob, pat).
parent(pat, jim).
male(tom).
male(bob).
male(jim).
male(pat).
female(liz).
female(ann).
father(F, C) :- parent(F, C), male(F).
mother(M, C) :- parent(M, C), female(M).
ancestor(X, Y) :- parent(X, Y).
ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).
sibling(X, Y) :- parent(P, X), parent(P, Y), \=(X, Y).

View File

@@ -1,116 +0,0 @@
;; lib/prolog/tests/programs/family.sx — facts + ancestor + sibling relations.
(define pl-fa-test-count 0)
(define pl-fa-test-pass 0)
(define pl-fa-test-fail 0)
(define pl-fa-test-failures (list))
(define
pl-fa-test!
(fn
(name got expected)
(begin
(set! pl-fa-test-count (+ pl-fa-test-count 1))
(if
(= got expected)
(set! pl-fa-test-pass (+ pl-fa-test-pass 1))
(begin
(set! pl-fa-test-fail (+ pl-fa-test-fail 1))
(append!
pl-fa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-fa-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-fa-prog-src
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(bob, pat). parent(pat, jim). male(tom). male(bob). male(jim). male(pat). female(liz). female(ann). father(F, C) :- parent(F, C), male(F). mother(M, C) :- parent(M, C), female(M). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y). sibling(X, Y) :- parent(P, X), parent(P, Y), \\=(X, Y).")
(define pl-fa-db (pl-mk-db))
(pl-db-load! pl-fa-db (pl-parse pl-fa-prog-src))
(pl-fa-test!
"parent(tom, bob) is a fact"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "parent(tom, bob)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"parent(tom, ann) — not a direct parent"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "parent(tom, ann)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"5 parent/2 facts in total"
(pl-solve-count!
pl-fa-db
(pl-fa-goal "parent(X, Y)" {})
(pl-mk-trail))
5)
(pl-fa-test!
"ancestor(tom, jim) — three-step transitive"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "ancestor(tom, jim)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"tom has 5 ancestors-of: bob, liz, ann, pat, jim"
(pl-solve-count!
pl-fa-db
(pl-fa-goal "ancestor(tom, X)" {})
(pl-mk-trail))
5)
(pl-fa-test!
"father(bob, ann) succeeds"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "father(bob, ann)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"father(liz, ann) fails (liz is female)"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "father(liz, ann)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"mother(liz, X) fails (liz has no children)"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "mother(liz, X)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"sibling(ann, pat) succeeds"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "sibling(ann, pat)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"sibling(ann, ann) fails by \\="
(pl-solve-once!
pl-fa-db
(pl-fa-goal "sibling(ann, ann)" {})
(pl-mk-trail))
false)
(define pl-family-tests-run! (fn () {:failed pl-fa-test-fail :passed pl-fa-test-pass :total pl-fa-test-count :failures pl-fa-test-failures}))

View File

@@ -1,4 +0,0 @@
%% member/2 list membership.
%% Generates all solutions on backtracking when the element is unbound.
member(X, [X|_]).
member(X, [_|T]) :- member(X, T).

View File

@@ -1,91 +0,0 @@
;; lib/prolog/tests/programs/member.sx — member/2 generator.
(define pl-mb-test-count 0)
(define pl-mb-test-pass 0)
(define pl-mb-test-fail 0)
(define pl-mb-test-failures (list))
(define
pl-mb-test!
(fn
(name got expected)
(begin
(set! pl-mb-test-count (+ pl-mb-test-count 1))
(if
(= got expected)
(set! pl-mb-test-pass (+ pl-mb-test-pass 1))
(begin
(set! pl-mb-test-fail (+ pl-mb-test-fail 1))
(append!
pl-mb-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mb-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-mb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(define pl-mb-db (pl-mk-db))
(pl-db-load! pl-mb-db (pl-parse pl-mb-prog-src))
(pl-mb-test!
"member(2, [1, 2, 3]) succeeds"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(2, [1, 2, 3])" {})
(pl-mk-trail))
true)
(pl-mb-test!
"member(4, [1, 2, 3]) fails"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(4, [1, 2, 3])" {})
(pl-mk-trail))
false)
(pl-mb-test!
"member(X, []) fails"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(X, [])" {})
(pl-mk-trail))
false)
(pl-mb-test!
"member(X, [a, b, c]) generates 3 solutions"
(pl-solve-count!
pl-mb-db
(pl-mb-goal "member(X, [a, b, c])" {})
(pl-mk-trail))
3)
(define pl-mb-env-1 {})
(define pl-mb-goal-1 (pl-mb-goal "member(X, [11, 22, 33])" pl-mb-env-1))
(pl-solve-once! pl-mb-db pl-mb-goal-1 (pl-mk-trail))
(pl-mb-test!
"member(X, [11, 22, 33]) first solution X = 11"
(pl-num-val (pl-walk-deep (dict-get pl-mb-env-1 "X")))
11)
(pl-mb-test!
"member(2, [1, 2, 3, 2, 1]) matches twice on backtrack"
(pl-solve-count!
pl-mb-db
(pl-mb-goal "member(2, [1, 2, 3, 2, 1])" {})
(pl-mk-trail))
2)
(pl-mb-test!
"member with unbound list cell unifies"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(a, [X, b, c])" {})
(pl-mk-trail))
true)
(define pl-member-tests-run! (fn () {:failed pl-mb-test-fail :passed pl-mb-test-pass :total pl-mb-test-count :failures pl-mb-test-failures}))

View File

@@ -1,27 +0,0 @@
%% nqueens permutation-and-test formulation.
%% Caller passes the row list [1..N]; queens/2 finds N column placements
%% s.t. no two queens attack on a diagonal. Same-column attacks are
%% structurally impossible Qs is a permutation, all distinct.
%%
%% No `>/2` `</2` `=</2` built-ins yet, so range/3 is omitted; tests pass
%; the literal range list. Once the operator table lands and arithmetic
%% comparison built-ins are in, range/3 can be added.
queens(L, Qs) :- permute(L, Qs), safe(Qs).
permute([], []).
permute(L, [H|T]) :- select(H, L, R), permute(R, T).
select(X, [X|T], T).
select(X, [H|T], [H|R]) :- select(X, T, R).
safe([]).
safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1).
no_attack(_, [], _).
no_attack(Q, [Q1|Qs], D) :-
is(D2, +(Q, D)),
\=(D2, Q1),
is(D3, -(Q, D)),
\=(D3, Q1),
is(D1, +(D, 1)),
no_attack(Q, Qs, D1).

View File

@@ -1,108 +0,0 @@
;; lib/prolog/tests/programs/nqueens.sx — N-queens via permute + safe.
(define pl-nq-test-count 0)
(define pl-nq-test-pass 0)
(define pl-nq-test-fail 0)
(define pl-nq-test-failures (list))
(define
pl-nq-test!
(fn
(name got expected)
(begin
(set! pl-nq-test-count (+ pl-nq-test-count 1))
(if
(= got expected)
(set! pl-nq-test-pass (+ pl-nq-test-pass 1))
(begin
(set! pl-nq-test-fail (+ pl-nq-test-fail 1))
(append!
pl-nq-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-nq-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-nq-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-nq-term-to-sx (first (pl-args w)))
(pl-nq-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-nq-list-to-sx (fn (t) (pl-nq-list-walked (pl-walk-deep t))))
(define
pl-nq-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-nq-prog-src
"queens(L, Qs) :- permute(L, Qs), safe(Qs). permute([], []). permute(L, [H|T]) :- select(H, L, R), permute(R, T). select(X, [X|T], T). select(X, [H|T], [H|R]) :- select(X, T, R). safe([]). safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1). no_attack(_, [], _). no_attack(Q, [Q1|Qs], D) :- is(D2, +(Q, D)), \\=(D2, Q1), is(D3, -(Q, D)), \\=(D3, Q1), is(D1, +(D, 1)), no_attack(Q, Qs, D1).")
(define pl-nq-db (pl-mk-db))
(pl-db-load! pl-nq-db (pl-parse pl-nq-prog-src))
(pl-nq-test!
"queens([1], Qs) → 1 solution"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1], Qs)" {})
(pl-mk-trail))
1)
(pl-nq-test!
"queens([1, 2], Qs) → 0 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2], Qs)" {})
(pl-mk-trail))
0)
(pl-nq-test!
"queens([1, 2, 3], Qs) → 0 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3], Qs)" {})
(pl-mk-trail))
0)
(pl-nq-test!
"queens([1, 2, 3, 4], Qs) → 2 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3, 4], Qs)" {})
(pl-mk-trail))
2)
(pl-nq-test!
"queens([1, 2, 3, 4, 5], Qs) → 10 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3, 4, 5], Qs)" {})
(pl-mk-trail))
10)
(define pl-nq-env-1 {})
(define pl-nq-goal-1 (pl-nq-goal "queens([1, 2, 3, 4], Qs)" pl-nq-env-1))
(pl-solve-once! pl-nq-db pl-nq-goal-1 (pl-mk-trail))
(pl-nq-test!
"queens([1..4], Qs) first solution = [2, 4, 1, 3]"
(pl-nq-list-to-sx (dict-get pl-nq-env-1 "Qs"))
(list 2 4 1 3))
(define pl-nqueens-tests-run! (fn () {:failed pl-nq-test-fail :passed pl-nq-test-pass :total pl-nq-test-count :failures pl-nq-test-failures}))

View File

@@ -1,7 +0,0 @@
%% reverse/2 — naive reverse via append/3.
%% Quadratic accumulates the reversed prefix one append per cons.
reverse([], []).
reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R).
append([], L, L).
append([H|T], L, [H|R]) :- append(T, L, R).

View File

@@ -1,113 +0,0 @@
;; lib/prolog/tests/programs/reverse.sx — naive reverse/2 via append/3.
;;
;; Mirrors reverse.pl (embedded as a string here).
(define pl-rv-test-count 0)
(define pl-rv-test-pass 0)
(define pl-rv-test-fail 0)
(define pl-rv-test-failures (list))
(define
pl-rv-test!
(fn
(name got expected)
(begin
(set! pl-rv-test-count (+ pl-rv-test-count 1))
(if
(= got expected)
(set! pl-rv-test-pass (+ pl-rv-test-pass 1))
(begin
(set! pl-rv-test-fail (+ pl-rv-test-fail 1))
(append!
pl-rv-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-rv-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-rv-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-rv-term-to-sx (first (pl-args w)))
(pl-rv-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-rv-list-to-sx (fn (t) (pl-rv-list-walked (pl-walk-deep t))))
(define
pl-rv-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-rv-prog-src
"reverse([], []). reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R). append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(define pl-rv-db (pl-mk-db))
(pl-db-load! pl-rv-db (pl-parse pl-rv-prog-src))
(define pl-rv-env-1 {})
(define pl-rv-goal-1 (pl-rv-goal "reverse([], X)" pl-rv-env-1))
(pl-solve-once! pl-rv-db pl-rv-goal-1 (pl-mk-trail))
(pl-rv-test!
"reverse([], X) → X = []"
(pl-rv-list-to-sx (dict-get pl-rv-env-1 "X"))
(list))
(define pl-rv-env-2 {})
(define pl-rv-goal-2 (pl-rv-goal "reverse([1], X)" pl-rv-env-2))
(pl-solve-once! pl-rv-db pl-rv-goal-2 (pl-mk-trail))
(pl-rv-test!
"reverse([1], X) → X = [1]"
(pl-rv-list-to-sx (dict-get pl-rv-env-2 "X"))
(list 1))
(define pl-rv-env-3 {})
(define pl-rv-goal-3 (pl-rv-goal "reverse([1, 2, 3], X)" pl-rv-env-3))
(pl-solve-once! pl-rv-db pl-rv-goal-3 (pl-mk-trail))
(pl-rv-test!
"reverse([1, 2, 3], X) → X = [3, 2, 1]"
(pl-rv-list-to-sx (dict-get pl-rv-env-3 "X"))
(list 3 2 1))
(define pl-rv-env-4 {})
(define pl-rv-goal-4 (pl-rv-goal "reverse([a, b, c, d], X)" pl-rv-env-4))
(pl-solve-once! pl-rv-db pl-rv-goal-4 (pl-mk-trail))
(pl-rv-test!
"reverse([a, b, c, d], X) → X = [d, c, b, a]"
(pl-rv-list-to-sx (dict-get pl-rv-env-4 "X"))
(list "d" "c" "b" "a"))
(pl-rv-test!
"reverse([1, 2, 3], [3, 2, 1]) succeeds"
(pl-solve-once!
pl-rv-db
(pl-rv-goal "reverse([1, 2, 3], [3, 2, 1])" {})
(pl-mk-trail))
true)
(pl-rv-test!
"reverse([1, 2], [1, 2]) fails"
(pl-solve-once!
pl-rv-db
(pl-rv-goal "reverse([1, 2], [1, 2])" {})
(pl-mk-trail))
false)
(define pl-reverse-tests-run! (fn () {:failed pl-rv-test-fail :passed pl-rv-test-pass :total pl-rv-test-count :failures pl-rv-test-failures}))

View File

@@ -1,127 +0,0 @@
;; lib/prolog/tests/query_api.sx — tests for pl-load/pl-query-all/pl-query-one/pl-query
(define pl-qa-test-count 0)
(define pl-qa-test-pass 0)
(define pl-qa-test-fail 0)
(define pl-qa-test-failures (list))
(define
pl-qa-test!
(fn
(name got expected)
(begin
(set! pl-qa-test-count (+ pl-qa-test-count 1))
(if
(= got expected)
(set! pl-qa-test-pass (+ pl-qa-test-pass 1))
(begin
(set! pl-qa-test-fail (+ pl-qa-test-fail 1))
(append!
pl-qa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-qa-src
"parent(tom, bob). parent(tom, liz). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).")
(define pl-qa-db (pl-load pl-qa-src))
;; ── pl-load ──
(pl-qa-test!
"pl-load returns a usable DB (pl-query-all non-nil)"
(not (nil? pl-qa-db))
true)
;; ── pl-query-all: basic fact lookup ──
(pl-qa-test!
"query-all parent(tom, X): 2 solutions"
(len (pl-query-all pl-qa-db "parent(tom, X)"))
2)
(pl-qa-test!
"query-all parent(tom, X): first solution X=bob"
(dict-get (first (pl-query-all pl-qa-db "parent(tom, X)")) "X")
"bob")
(pl-qa-test!
"query-all parent(tom, X): second solution X=liz"
(dict-get (nth (pl-query-all pl-qa-db "parent(tom, X)") 1) "X")
"liz")
;; ── pl-query-all: no solutions ──
(pl-qa-test!
"query-all no solutions returns empty list"
(pl-query-all pl-qa-db "parent(liz, X)")
(list))
;; ── pl-query-all: boolean query (no vars) ──
(pl-qa-test!
"boolean success: 1 solution (empty dict)"
(len (pl-query-all pl-qa-db "parent(tom, bob)"))
1)
(pl-qa-test!
"boolean success: solution has no bindings"
(empty? (keys (first (pl-query-all pl-qa-db "parent(tom, bob)"))))
true)
(pl-qa-test!
"boolean fail: 0 solutions"
(len (pl-query-all pl-qa-db "parent(bob, tom)"))
0)
;; ── pl-query-all: multi-var ──
(pl-qa-test!
"query-all parent(X, Y): 3 solutions total"
(len (pl-query-all pl-qa-db "parent(X, Y)"))
3)
;; ── pl-query-all: rule-based (ancestor/2) ──
(pl-qa-test!
"query-all ancestor(tom, X): 3 descendants (bob, liz, ann)"
(len (pl-query-all pl-qa-db "ancestor(tom, X)"))
3)
;; ── pl-query-all: built-in in query ──
(pl-qa-test!
"query with is/2 built-in"
(dict-get (first (pl-query-all pl-qa-db "X is 2 + 3")) "X")
"5")
;; ── pl-query-one ──
(pl-qa-test!
"query-one returns first solution"
(dict-get (pl-query-one pl-qa-db "parent(tom, X)") "X")
"bob")
(pl-qa-test!
"query-one returns nil for no solutions"
(pl-query-one pl-qa-db "parent(liz, X)")
nil)
;; ── pl-query convenience ──
(pl-qa-test!
"pl-query convenience: count solutions"
(len (pl-query "likes(alice, bob). likes(alice, carol)." "likes(alice, X)"))
2)
(pl-qa-test!
"pl-query convenience: first solution"
(dict-get (first (pl-query "likes(alice, bob). likes(alice, carol)." "likes(alice, X)")) "X")
"bob")
(pl-qa-test!
"pl-query with empty source (built-ins only)"
(dict-get (first (pl-query "" "X is 6 * 7")) "X")
"42")
(define pl-query-api-tests-run! (fn () {:failed pl-qa-test-fail :passed pl-qa-test-pass :total pl-qa-test-count :failures pl-qa-test-failures}))

View File

@@ -1,195 +0,0 @@
;; lib/prolog/tests/set_predicates.sx — foldl/4, list_to_set/2, intersection/3, subtract/3, union/3
(define pl-sp-test-count 0)
(define pl-sp-test-pass 0)
(define pl-sp-test-fail 0)
(define pl-sp-test-failures (list))
(define
pl-sp-test!
(fn
(name got expected)
(begin
(set! pl-sp-test-count (+ pl-sp-test-count 1))
(if
(= got expected)
(set! pl-sp-test-pass (+ pl-sp-test-pass 1))
(begin
(set! pl-sp-test-fail (+ pl-sp-test-fail 1))
(append!
pl-sp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-sp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; DB with add/3 for foldl tests
(define pl-sp-db (pl-mk-db))
(pl-db-load! pl-sp-db (pl-parse "add(X, Acc, NAcc) :- NAcc is Acc + X."))
;; ── foldl/4 ────────────────────────────────────────────────────────
(define pl-sp-env-fl1 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [1,2,3,4], 0, S)" pl-sp-env-fl1)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[1,2,3,4],0,S) -> S=10"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl1 "S")))
10)
(define pl-sp-env-fl2 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [], 5, S)" pl-sp-env-fl2)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[],5,S) -> S=5"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl2 "S")))
5)
(define pl-sp-env-fl3 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [1,2,3], 0, S)" pl-sp-env-fl3)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[1,2,3],0,S) -> S=6"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl3 "S")))
6)
;; ── list_to_set/2 ──────────────────────────────────────────────────
(define pl-sp-env-lts1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([1,2,3,2,1], R)" pl-sp-env-lts1)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([1,2,3,2,1],R) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts1 "R")))
".(1, .(2, .(3, [])))")
(define pl-sp-env-lts2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([], R)" pl-sp-env-lts2)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts2 "R")))
"[]")
(define pl-sp-env-lts3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([a,b,a,c], R)" pl-sp-env-lts3)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([a,b,a,c],R) -> [a,b,c]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts3 "R")))
".(a, .(b, .(c, [])))")
;; ── intersection/3 ─────────────────────────────────────────────────
(define pl-sp-env-int1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([1,2,3,4], [2,4,6], R)" pl-sp-env-int1)
(pl-mk-trail))
(pl-sp-test!
"intersection([1,2,3,4],[2,4,6],R) -> [2,4]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int1 "R")))
".(2, .(4, []))")
(define pl-sp-env-int2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([1,2,3], [4,5,6], R)" pl-sp-env-int2)
(pl-mk-trail))
(pl-sp-test!
"intersection([1,2,3],[4,5,6],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int2 "R")))
"[]")
(define pl-sp-env-int3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([], [1,2,3], R)" pl-sp-env-int3)
(pl-mk-trail))
(pl-sp-test!
"intersection([],[1,2,3],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int3 "R")))
"[]")
;; ── subtract/3 ─────────────────────────────────────────────────────
(define pl-sp-env-sub1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([1,2,3,4], [2,4], R)" pl-sp-env-sub1)
(pl-mk-trail))
(pl-sp-test!
"subtract([1,2,3,4],[2,4],R) -> [1,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub1 "R")))
".(1, .(3, []))")
(define pl-sp-env-sub2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([1,2,3], [], R)" pl-sp-env-sub2)
(pl-mk-trail))
(pl-sp-test!
"subtract([1,2,3],[],R) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub2 "R")))
".(1, .(2, .(3, [])))")
(define pl-sp-env-sub3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([], [1,2], R)" pl-sp-env-sub3)
(pl-mk-trail))
(pl-sp-test!
"subtract([],[1,2],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub3 "R")))
"[]")
;; ── union/3 ────────────────────────────────────────────────────────
(define pl-sp-env-uni1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([1,2,3], [2,3,4], R)" pl-sp-env-uni1)
(pl-mk-trail))
(pl-sp-test!
"union([1,2,3],[2,3,4],R) -> [1,2,3,4]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni1 "R")))
".(1, .(2, .(3, .(4, []))))")
(define pl-sp-env-uni2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([], [1,2], R)" pl-sp-env-uni2)
(pl-mk-trail))
(pl-sp-test!
"union([],[1,2],R) -> [1,2]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni2 "R")))
".(1, .(2, []))")
(define pl-sp-env-uni3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([1,2], [], R)" pl-sp-env-uni3)
(pl-mk-trail))
(pl-sp-test!
"union([1,2],[],R) -> [1,2]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni3 "R")))
".(1, .(2, []))")
;; ── Runner ─────────────────────────────────────────────────────────
(define pl-set-predicates-tests-run! (fn () {:failed pl-sp-test-fail :passed pl-sp-test-pass :total pl-sp-test-count :failures pl-sp-test-failures}))

View File

@@ -1,618 +0,0 @@
;; lib/prolog/tests/solve.sx — DFS solver unit tests
(define pl-s-test-count 0)
(define pl-s-test-pass 0)
(define pl-s-test-fail 0)
(define pl-s-test-failures (list))
(define
pl-s-test!
(fn
(name got expected)
(begin
(set! pl-s-test-count (+ pl-s-test-count 1))
(if
(= got expected)
(set! pl-s-test-pass (+ pl-s-test-pass 1))
(begin
(set! pl-s-test-fail (+ pl-s-test-fail 1))
(append!
pl-s-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-s-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-s-empty-db (pl-mk-db))
(pl-s-test!
"true succeeds"
(pl-solve-once! pl-s-empty-db (pl-s-goal "true" {}) (pl-mk-trail))
true)
(pl-s-test!
"fail fails"
(pl-solve-once! pl-s-empty-db (pl-s-goal "fail" {}) (pl-mk-trail))
false)
(pl-s-test!
"= identical atoms"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(a, a)" {})
(pl-mk-trail))
true)
(pl-s-test!
"= different atoms"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(a, b)" {})
(pl-mk-trail))
false)
(pl-s-test!
"= var to atom"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, foo)" {})
(pl-mk-trail))
true)
(define pl-s-env-bind {})
(define pl-s-trail-bind (pl-mk-trail))
(define pl-s-goal-bind (pl-s-goal "=(X, foo)" pl-s-env-bind))
(pl-solve-once! pl-s-empty-db pl-s-goal-bind pl-s-trail-bind)
(pl-s-test!
"X bound to foo after =(X, foo)"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-bind "X")))
"foo")
(pl-s-test!
"true , true succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "true, true" {})
(pl-mk-trail))
true)
(pl-s-test!
"true , fail fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "true, fail" {})
(pl-mk-trail))
false)
(pl-s-test!
"consistent X bindings succeed"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, a), =(X, a)" {})
(pl-mk-trail))
true)
(pl-s-test!
"conflicting X bindings fail"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, a), =(X, b)" {})
(pl-mk-trail))
false)
(define pl-s-db1 (pl-mk-db))
(pl-db-load!
pl-s-db1
(pl-parse "parent(tom, bob). parent(bob, liz). parent(bob, ann)."))
(pl-s-test!
"fact lookup hit"
(pl-solve-once!
pl-s-db1
(pl-s-goal "parent(tom, bob)" {})
(pl-mk-trail))
true)
(pl-s-test!
"fact lookup miss"
(pl-solve-once!
pl-s-db1
(pl-s-goal "parent(tom, liz)" {})
(pl-mk-trail))
false)
(pl-s-test!
"all parent solutions"
(pl-solve-count!
pl-s-db1
(pl-s-goal "parent(X, Y)" {})
(pl-mk-trail))
3)
(pl-s-test!
"fixed first arg solutions"
(pl-solve-count!
pl-s-db1
(pl-s-goal "parent(bob, Y)" {})
(pl-mk-trail))
2)
(define pl-s-db2 (pl-mk-db))
(pl-db-load!
pl-s-db2
(pl-parse
"parent(tom, bob). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
(pl-s-test!
"rule direct ancestor"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(tom, bob)" {})
(pl-mk-trail))
true)
(pl-s-test!
"rule transitive ancestor"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(tom, ann)" {})
(pl-mk-trail))
true)
(pl-s-test!
"rule no path"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(ann, tom)" {})
(pl-mk-trail))
false)
(define pl-s-env-undo {})
(define pl-s-trail-undo (pl-mk-trail))
(define pl-s-goal-undo (pl-s-goal "=(X, a), fail" pl-s-env-undo))
(pl-solve-once! pl-s-empty-db pl-s-goal-undo pl-s-trail-undo)
(pl-s-test!
"trail undone after failure leaves X unbound"
(pl-var-bound? (dict-get pl-s-env-undo "X"))
false)
(define pl-s-db-cut1 (pl-mk-db))
(pl-db-load! pl-s-db-cut1 (pl-parse "g :- !. g :- true."))
(pl-s-test!
"bare cut succeeds"
(pl-solve-once! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
true)
(pl-s-test!
"cut commits to first matching clause"
(pl-solve-count! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
1)
(define pl-s-db-cut2 (pl-mk-db))
(pl-db-load! pl-s-db-cut2 (pl-parse "a(1). a(2). g(X) :- a(X), !."))
(pl-s-test!
"cut commits to first a solution"
(pl-solve-count! pl-s-db-cut2 (pl-s-goal "g(X)" {}) (pl-mk-trail))
1)
(define pl-s-db-cut3 (pl-mk-db))
(pl-db-load!
pl-s-db-cut3
(pl-parse "a(1). a(2). g(X) :- a(X), !, fail. g(99)."))
(pl-s-test!
"cut then fail blocks alt clauses"
(pl-solve-count! pl-s-db-cut3 (pl-s-goal "g(X)" {}) (pl-mk-trail))
0)
(define pl-s-db-cut4 (pl-mk-db))
(pl-db-load!
pl-s-db-cut4
(pl-parse "a(1). b(10). b(20). g(X, Y) :- a(X), !, b(Y)."))
(pl-s-test!
"post-cut goal backtracks freely"
(pl-solve-count!
pl-s-db-cut4
(pl-s-goal "g(X, Y)" {})
(pl-mk-trail))
2)
(define pl-s-db-cut5 (pl-mk-db))
(pl-db-load!
pl-s-db-cut5
(pl-parse "r(1). r(2). q :- r(X), !. p :- q. p :- true."))
(pl-s-test!
"inner cut does not commit outer predicate"
(pl-solve-count! pl-s-db-cut5 (pl-s-goal "p" {}) (pl-mk-trail))
2)
(pl-s-test!
"\\= different atoms succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(a, b)" {})
(pl-mk-trail))
true)
(pl-s-test!
"\\= same atoms fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(a, a)" {})
(pl-mk-trail))
false)
(pl-s-test!
"\\= var-vs-atom would unify so fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(X, a)" {})
(pl-mk-trail))
false)
(define pl-s-env-ne {})
(define pl-s-trail-ne (pl-mk-trail))
(define pl-s-goal-ne (pl-s-goal "\\=(X, a)" pl-s-env-ne))
(pl-solve-once! pl-s-empty-db pl-s-goal-ne pl-s-trail-ne)
(pl-s-test!
"\\= leaves no bindings"
(pl-var-bound? (dict-get pl-s-env-ne "X"))
false)
(pl-s-test!
"; left succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(true, fail)" {})
(pl-mk-trail))
true)
(pl-s-test!
"; right succeeds when left fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(fail, true)" {})
(pl-mk-trail))
true)
(pl-s-test!
"; both fail"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(fail, fail)" {})
(pl-mk-trail))
false)
(pl-s-test!
"; both branches counted"
(pl-solve-count!
pl-s-empty-db
(pl-s-goal ";(true, true)" {})
(pl-mk-trail))
2)
(define pl-s-db-call (pl-mk-db))
(pl-db-load! pl-s-db-call (pl-parse "p(1). p(2)."))
(pl-s-test!
"call(true) succeeds"
(pl-solve-once!
pl-s-db-call
(pl-s-goal "call(true)" {})
(pl-mk-trail))
true)
(pl-s-test!
"call(p(X)) yields all solutions"
(pl-solve-count!
pl-s-db-call
(pl-s-goal "call(p(X))" {})
(pl-mk-trail))
2)
(pl-s-test!
"call of bound goal var resolves"
(pl-solve-once!
pl-s-db-call
(pl-s-goal "=(G, true), call(G)" {})
(pl-mk-trail))
true)
(define pl-s-db-ite (pl-mk-db))
(pl-db-load! pl-s-db-ite (pl-parse "p(1). p(2). q(yes). q(no)."))
(pl-s-test!
"if-then-else: cond true → then runs"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" {})
(pl-mk-trail))
true)
(define pl-s-env-ite1 {})
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" pl-s-env-ite1)
(pl-mk-trail))
(pl-s-test!
"if-then-else: cond true binds via then"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite1 "X")))
"ok")
(pl-s-test!
"if-then-else: cond false → else"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" {})
(pl-mk-trail))
true)
(define pl-s-env-ite2 {})
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" pl-s-env-ite2)
(pl-mk-trail))
(pl-s-test!
"if-then-else: cond false binds via else"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite2 "X")))
"fallback")
(pl-s-test!
"if-then-else: cond commits to first solution (count = 1)"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(p(X), =(Y, found)), =(Y, none))" {})
(pl-mk-trail))
1)
(pl-s-test!
"if-then-else: then can backtrack"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(true, p(X)), =(X, none))" {})
(pl-mk-trail))
2)
(pl-s-test!
"if-then-else: else can backtrack"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ignored)), p(X))" {})
(pl-mk-trail))
2)
(pl-s-test!
"standalone -> with true cond succeeds"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal "->(true, =(X, hi))" {})
(pl-mk-trail))
true)
(pl-s-test!
"standalone -> with false cond fails"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal "->(fail, =(X, hi))" {})
(pl-mk-trail))
false)
(pl-s-test!
"write(hello)"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(hello)" {})
(pl-mk-trail))
pl-output-buffer)
"hello")
(pl-s-test!
"nl outputs newline"
(begin
(pl-output-clear!)
(pl-solve-once! pl-s-empty-db (pl-s-goal "nl" {}) (pl-mk-trail))
pl-output-buffer)
"\n")
(pl-s-test!
"write(42) outputs digits"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(42)" {})
(pl-mk-trail))
pl-output-buffer)
"42")
(pl-s-test!
"write(foo(a, b)) formats compound"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(foo(a, b))" {})
(pl-mk-trail))
pl-output-buffer)
"foo(a, b)")
(pl-s-test!
"write conjunction"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(a), write(b)" {})
(pl-mk-trail))
pl-output-buffer)
"ab")
(pl-s-test!
"write of bound var walks binding"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, hello), write(X)" {})
(pl-mk-trail))
pl-output-buffer)
"hello")
(pl-s-test!
"write then nl"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(hi), nl" {})
(pl-mk-trail))
pl-output-buffer)
"hi\n")
(define pl-s-env-arith1 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, 42)" pl-s-env-arith1)
(pl-mk-trail))
(pl-s-test!
"is(X, 42) binds X to 42"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith1 "X")))
42)
(define pl-s-env-arith2 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, +(2, 3))" pl-s-env-arith2)
(pl-mk-trail))
(pl-s-test!
"is(X, +(2, 3)) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith2 "X")))
5)
(define pl-s-env-arith3 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, *(2, 3))" pl-s-env-arith3)
(pl-mk-trail))
(pl-s-test!
"is(X, *(2, 3)) binds X to 6"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith3 "X")))
6)
(define pl-s-env-arith4 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, -(10, 3))" pl-s-env-arith4)
(pl-mk-trail))
(pl-s-test!
"is(X, -(10, 3)) binds X to 7"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith4 "X")))
7)
(define pl-s-env-arith5 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, /(10, 2))" pl-s-env-arith5)
(pl-mk-trail))
(pl-s-test!
"is(X, /(10, 2)) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith5 "X")))
5)
(define pl-s-env-arith6 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, mod(10, 3))" pl-s-env-arith6)
(pl-mk-trail))
(pl-s-test!
"is(X, mod(10, 3)) binds X to 1"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith6 "X")))
1)
(define pl-s-env-arith7 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, abs(-(0, 5)))" pl-s-env-arith7)
(pl-mk-trail))
(pl-s-test!
"is(X, abs(-(0, 5))) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith7 "X")))
5)
(define pl-s-env-arith8 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, +(2, *(3, 4)))" pl-s-env-arith8)
(pl-mk-trail))
(pl-s-test!
"is(X, +(2, *(3, 4))) binds X to 14 (nested)"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith8 "X")))
14)
(pl-s-test!
"is(5, +(2, 3)) succeeds (LHS num matches)"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(5, +(2, 3))" {})
(pl-mk-trail))
true)
(pl-s-test!
"is(6, +(2, 3)) fails (LHS num mismatch)"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(6, +(2, 3))" {})
(pl-mk-trail))
false)
(pl-s-test!
"is propagates bound vars on RHS"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(Y, 4), is(X, +(Y, 1)), =(X, 5)" {})
(pl-mk-trail))
true)
(define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures}))

View File

@@ -1,273 +0,0 @@
;; lib/prolog/tests/string_agg.sx -- sub_atom/5 + aggregate_all/3
(define pl-sa-test-count 0)
(define pl-sa-test-pass 0)
(define pl-sa-test-fail 0)
(define pl-sa-test-failures (list))
(define
pl-sa-test!
(fn
(name got expected)
(begin
(set! pl-sa-test-count (+ pl-sa-test-count 1))
(if
(= got expected)
(set! pl-sa-test-pass (+ pl-sa-test-pass 1))
(begin
(set! pl-sa-test-fail (+ pl-sa-test-fail 1))
(append!
pl-sa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-sa-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-sa-db (pl-mk-db))
(define
pl-sa-num-val
(fn (env key) (pl-num-val (pl-walk-deep (dict-get env key)))))
(define
pl-sa-list-to-atoms
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-atom-name (first (pl-args w)))
(pl-sa-list-to-atoms (nth (pl-args w) 1))))
(true (list))))))
(define pl-sa-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(pl-db-load! pl-sa-db (pl-parse pl-sa-prog-src))
;; -- sub_atom/5 --
(pl-sa-test!
"sub_atom ground: sub_atom(abcde,0,3,2,abc)"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 3, 2, abc)" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom ground: sub_atom(abcde,2,2,1,cd)"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 2, 2, 1, cd)" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom ground mismatch fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 2, 3, cd)" {})
(pl-mk-trail))
false)
(pl-sa-test!
"sub_atom empty sub at start"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 0, 5, '')" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom whole string"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(hello, 0, 5, 0, hello)" {})
(pl-mk-trail))
true)
(define pl-sa-env-b1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, B, 2, A, cd)" pl-sa-env-b1)
(pl-mk-trail))
(pl-sa-test!
"sub_atom bound SubAtom gives B=2"
(pl-sa-num-val pl-sa-env-b1 "B")
2)
(pl-sa-test!
"sub_atom bound SubAtom gives A=1"
(pl-sa-num-val pl-sa-env-b1 "A")
1)
(define pl-sa-env-b2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(hello, B, L, A, ello)" pl-sa-env-b2)
(pl-mk-trail))
(pl-sa-test! "sub_atom ello: B=1" (pl-sa-num-val pl-sa-env-b2 "B") 1)
(pl-sa-test! "sub_atom ello: L=4" (pl-sa-num-val pl-sa-env-b2 "L") 4)
(pl-sa-test! "sub_atom ello: A=0" (pl-sa-num-val pl-sa-env-b2 "A") 0)
(pl-sa-test!
"sub_atom ab: 6 total solutions"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, sub_atom(ab, _, _, _, _), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
6)
(pl-sa-test!
"sub_atom a: 3 total solutions"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, sub_atom(a, _, _, _, _), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
3)
;; -- aggregate_all/3 --
(pl-sa-test!
"aggregate_all count member [a,b,c] = 3"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, member(_, [a,b,c]), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
3)
(pl-sa-test!
"aggregate_all count fail = 0"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, fail, N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
0)
(pl-sa-test!
"aggregate_all count always succeeds"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, fail, _)" {})
(pl-mk-trail))
true)
(define pl-sa-env-bag1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(bag(X), member(X, [a,b,c]), L)" pl-sa-env-bag1)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all bag [a,b,c]"
(pl-sa-list-to-atoms (dict-get pl-sa-env-bag1 "L"))
(list "a" "b" "c"))
(define pl-sa-env-bag2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(bag(X), member(X, []), L)" pl-sa-env-bag2)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all bag empty goal = []"
(pl-sa-list-to-atoms (dict-get pl-sa-env-bag2 "L"))
(list))
(pl-sa-test!
"aggregate_all sum [1,2,3,4] = 10"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(sum(X), member(X, [1,2,3,4]), S)" env)
(pl-mk-trail))
(pl-sa-num-val env "S"))
10)
(pl-sa-test!
"aggregate_all max [3,1,4,1,5,9,2,6] = 9"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(max(X), member(X, [3,1,4,1,5,9,2,6]), M)" env)
(pl-mk-trail))
(pl-sa-num-val env "M"))
9)
(pl-sa-test!
"aggregate_all max empty fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(max(X), member(X, []), M)" {})
(pl-mk-trail))
false)
(pl-sa-test!
"aggregate_all min [3,1,4,1,5,9,2,6] = 1"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(min(X), member(X, [3,1,4,1,5,9,2,6]), M)" env)
(pl-mk-trail))
(pl-sa-num-val env "M"))
1)
(pl-sa-test!
"aggregate_all min empty fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(min(X), member(X, []), M)" {})
(pl-mk-trail))
false)
(define pl-sa-env-set1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal
"aggregate_all(set(X), member(X, [b,a,c,a,b]), S)"
pl-sa-env-set1)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all set [b,a,c,a,b] = [a,b,c]"
(pl-sa-list-to-atoms (dict-get pl-sa-env-set1 "S"))
(list "a" "b" "c"))
(define pl-sa-env-set2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(set(X), fail, S)" pl-sa-env-set2)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all set fail = []"
(pl-sa-list-to-atoms (dict-get pl-sa-env-set2 "S"))
(list))
(pl-sa-test!
"aggregate_all sum empty = 0"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(sum(X), fail, S)" env)
(pl-mk-trail))
(pl-sa-num-val env "S"))
0)
(define pl-string-agg-tests-run! (fn () {:failed pl-sa-test-fail :passed pl-sa-test-pass :total pl-sa-test-count :failures pl-sa-test-failures}))

View File

@@ -1,147 +0,0 @@
;; lib/prolog/tests/term_inspect.sx — copy_term/2, functor/3, arg/3.
(define pl-tt-test-count 0)
(define pl-tt-test-pass 0)
(define pl-tt-test-fail 0)
(define pl-tt-test-failures (list))
(define
pl-tt-test!
(fn
(name got expected)
(begin
(set! pl-tt-test-count (+ pl-tt-test-count 1))
(if
(= got expected)
(set! pl-tt-test-pass (+ pl-tt-test-pass 1))
(begin
(set! pl-tt-test-fail (+ pl-tt-test-fail 1))
(append!
pl-tt-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-tt-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-tt-db (pl-mk-db))
;; ── copy_term/2 ──
(pl-tt-test!
"copy_term ground compound succeeds + copy = original"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(foo(a, b), X), X = foo(a, b)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"copy_term preserves var aliasing in source"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 5" {})
(pl-mk-trail))
true)
(pl-tt-test!
"copy_term distinct vars stay distinct"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 6" {})
(pl-mk-trail))
false)
(define pl-tt-env-1 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(X, Y), Y = 5" pl-tt-env-1)
(pl-mk-trail))
(pl-tt-test!
"copy_term: binding the copy doesn't bind the source"
(pl-var-bound? (dict-get pl-tt-env-1 "X"))
false)
;; ── functor/3 ──
(define pl-tt-env-2 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(foo(a, b, c), F, N)" pl-tt-env-2)
(pl-mk-trail))
(pl-tt-test!
"functor of compound: F = foo"
(pl-atom-name (pl-walk-deep (dict-get pl-tt-env-2 "F")))
"foo")
(pl-tt-test!
"functor of compound: N = 3"
(pl-num-val (pl-walk-deep (dict-get pl-tt-env-2 "N")))
3)
(define pl-tt-env-3 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(hello, F, N)" pl-tt-env-3)
(pl-mk-trail))
(pl-tt-test!
"functor of atom: F = hello"
(pl-atom-name (pl-walk-deep (dict-get pl-tt-env-3 "F")))
"hello")
(pl-tt-test!
"functor of atom: N = 0"
(pl-num-val (pl-walk-deep (dict-get pl-tt-env-3 "N")))
0)
(pl-tt-test!
"functor construct compound: T unifies with foo(a, b)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(T, foo, 2), T = foo(a, b)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"functor construct atom: T = hello"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(T, hello, 0), T = hello" {})
(pl-mk-trail))
true)
;; ── arg/3 ──
(pl-tt-test!
"arg(1, foo(a, b, c), a)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(1, foo(a, b, c), a)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"arg(2, foo(a, b, c), X) → X = b"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(2, foo(a, b, c), X), X = b" {})
(pl-mk-trail))
true)
(pl-tt-test!
"arg out-of-range high fails"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(4, foo(a, b, c), X)" {})
(pl-mk-trail))
false)
(pl-tt-test!
"arg(0, ...) fails (1-indexed)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(0, foo(a), X)" {})
(pl-mk-trail))
false)
(define pl-term-inspect-tests-run! (fn () {:failed pl-tt-test-fail :passed pl-tt-test-pass :total pl-tt-test-count :failures pl-tt-test-failures}))

View File

@@ -0,0 +1,96 @@
# HS conformance — blockers drain
Goal: take hyperscript conformance from **1277/1496 (85.4%)** to **1496/1496 (100%)** by clearing the blocked clusters and the design-done Bucket E subsystems.
This plan exists because the per-iteration `loops/hs` agent can't fit these into its 30-min budget — they need dedicated multi-commit sit-downs. Track progress here; refer to `plans/hs-conformance-to-100.md` for the canonical cluster ledger.
## Current state (2026-04-25)
- Loop running in `/root/rose-ash-loops/hs` (branch `loops/hs`)
- sx-tree MCP **fixed** (was a session-stale binary issue — restart of claude in the tmux window picked it up). Loop hinted to retry **#32**, **#29** first.
- Recent loop progress: ~1 commit/6h — easy wins drained, what's left needs focused attention.
## Remaining work
### Bucket-A/B/C blockers (small, in-place fixes)
| # | Cluster | Tests | Effort | Blocker | Fix sketch |
|---|---------|------:|--------|---------|------------|
| **17** | `tell` semantics | +3 | ~1h | Implicit-default-target ambiguity. `bare add .bar` inside `tell X` should target `X` but explicit `to me` must reach the original element. | Add `beingTold` symbol distinct from `me`; bare commands compile to `beingTold-or-me`; explicit `me` always the original. |
| **22** | window global fn fallback | +2-4 | ~1h | `foo()` where `foo` isn't SX-defined needs to fall back to `(host-global "foo")`. Three attempts failed: guard (host-level error not catchable), `env-has?` (not in HS kernel), `hs-win-call` (NativeFn not callable from CALL). | Add `symbol-bound?` predicate to HS kernel **OR** a host-call-fn primitive with arity-agnostic dispatch. |
| **29** | `hyperscript:before:init` / `:after:init` / `:parse-error` events | +4-6 | ~30m (post sx-tree fix) | Was sx-tree MCP outage. Now unblocked — loop should retry. 4 of 6 tests need stricter parser error-rejection (out of scope; mark partial). | Edit `integration.sx` to fire DOM events at activation boundaries. |
### Bucket D — medium features
| # | Cluster | Tests | Effort | Status |
|---|---------|------:|--------|--------|
| **31** | runtime null-safety error reporting | **+15-18** | **2-4h** | **THIS SESSION'S TARGET.** Plan node fully spec'd: 5 pieces of work. |
| **32** | MutationObserver mock + `on mutation` | +10-15 | ~2h | Was sx-tree-blocked. Now unblocked — loop hinted to retry. Multi-file: parser, compiler, runtime, runner mock, generator skip-list. |
| **33** | cookie API | +2 (remaining) | ~30m | Partial done (+3). Remaining 2 need `hs-method-call` runtime fallback for unknown methods + `hs-for-each` recognising host-array/proxy collections. |
| 34 | event modifier DSL | +6-8 | ~1-2h | `elsewhere`, `every`, count filters (`once`/`twice`/`3 times`/ranges), `from elsewhere`. Pending. |
| 35 | namespaced `def` | +3 | ~30m | Pending. |
### Bucket E — subsystems (design docs landed, multi-commit each)
Each has a design doc with a step-by-step checklist. These are 1-2 days of focused work each, not loop-fits.
| # | Subsystem | Tests | Design doc | Branch |
|---|-----------|------:|------------|--------|
| 36 | WebSocket + `socket` + RPC Proxy | +12-16 | `plans/designs/e36-websocket.md` | `worktree-agent-a9daf73703f520257` |
| 37 | Tokenizer-as-API | +16-17 | `plans/designs/e37-tokenizer-api.md` | `worktree-agent-a6bb61d59cc0be8b4` |
| 38 | SourceInfo API | +4 | `plans/designs/e38-sourceinfo.md` | `agent-e38-sourceinfo` |
| 39 | WebWorker plugin (parser-only stub) | +1 | `plans/designs/e39-webworker.md` | `hs-design-e39-webworker` |
| 40 | Real Fetch / non-2xx / before-fetch | +7 | `plans/designs/e40-real-fetch.md` | `worktree-agent-a94612a4283eaa5e0` |
### Bucket F — generator translation gaps
~25 tests SKIP'd because `tests/playwright/generate-sx-tests.py` bails with `return None`. Single dedicated generator-repair sit-down once Bucket D is drained. ~half-day.
## Order of attack
In approximate cost-per-test order:
1. **Loop self-heal** (no human work) — wait for #29, #32 to land via the running loop ⏱️ ~next 1-2 hours
2. **#31 null-safety** — biggest scoped single win, dedicated worktree agent (this session)
3. **#33 cookie API remainder** — quick partial completion
4. **#17 / #22 / #34 / #35** — small fiddly fixes, one sit-down each
5. **Bucket E** — pick one subsystem at a time. **#39 (WebWorker stub) first** — single commit, smallest. Then **#38 (SourceInfo)** — 4 commits. Then the bigger three (#36, #37, #40).
6. **Bucket F** — generator repair sweep at the end.
Estimated total to 100%: ~10-15 days of focused work, parallelisable across branches.
## Cluster #31 spec (full detail)
The plan note from `hs-conformance-to-100.md`:
> 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put.
**Required pieces:**
1. **Generator-side `eval-hs-error` helper + recognizer** for `expect(await error("HS")).toBe("MSG")` blocks. In `tests/playwright/generate-sx-tests.py`.
2. **Runtime helpers** in `lib/hyperscript/runtime.sx`:
- `hs-null-error!` raising `'<sel>' is null`
- `hs-named-target` — wraps a query result with the original selector source
- `hs-named-target-list` — same for list results
3. **Compiler patches at every target-position `(query SEL)` emit** — wrap in named-target carrying the original selector source. ~17 command emit paths in `lib/hyperscript/compiler.sx`:
add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take.
4. **Function-call null-check** at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name (`'x'` / `'x.y'`) from the parse tree.
5. **Possessive-base null-check** (`set x's y to true``'x' is null`).
**Files in scope:**
- `lib/hyperscript/runtime.sx` (new helpers)
- `lib/hyperscript/compiler.sx` (~17 emit-path edits)
- `tests/playwright/generate-sx-tests.py` (test recognizer)
- `tests/hs-run-filtered.js` (if mock helpers needed)
- `shared/static/wasm/sx/hs-runtime.sx` + `hs-compiler.sx` (WASM staging copies)
**Approach:** target-named pieces incrementally — runtime helpers first (no compiler change), then compiler emit paths in batches (group similar commands), then function-call/possessive at the end. Each batch is one commit if it lands +N tests; mark partial if it only unlocks part.
**Watch for:** smoke-range regressions (tests flipping pass→fail). Each commit: rerun smoke 0-195 and the `runtimeErrors` suite.
## Notes for future sessions
- `plans/hs-conformance-to-100.md` is the canonical cluster ledger — update it on every commit.
- `plans/hs-conformance-scoreboard.md` is the live tally — bump `Merged:` and the bucket roll-up.
- Loop has scope rule "never edit `spec/evaluator.sx` or broader SX kernel" — most fixes here stay in `lib/hyperscript/**`, `tests/`, generator. If a fix needs kernel work, surface to the user; don't merge silently.
- Cluster #22's `symbol-bound?` predicate would be a kernel addition — that's a real cross-boundary scope expansion.

View File

@@ -4,10 +4,10 @@ Live tally for `plans/hs-conformance-to-100.md`. Update after every cluster comm
```
Baseline: 1213/1496 (81.1%)
Merged: 1277/1496 (85.4%) delta +64
Merged: 1303/1496 (87.1%) delta +90
Worktree: all landed
Target: 1496/1496 (100.0%)
Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial)
```
## Cluster ledger
@@ -42,7 +42,7 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
| 19 | `pick` regex + indices | done | +13 | 4be90bf2 |
| 20 | `repeat` property for-loops + where | done | +3 | c932ad59 |
| 21 | `possessiveExpression` property access via its | done | +1 | f0c41278 |
| 22 | window global fn fallback | blocked | | |
| 22 | window global fn fallback | done | +1 | d31565d5 |
| 23 | `me symbol works in from expressions` | done | +1 | 0d38a75b |
| 24 | `properly interpolates values 2` | done | +1 | cb37259d |
| 25 | parenthesized commands and features | done | +1 | d7a88d85 |
@@ -54,18 +54,18 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
| 26 | resize observer mock + `on resize` | done | +3 | 304a52d2 |
| 27 | intersection observer mock + `on intersection` | done | +3 | 0c31dd27 |
| 28 | `ask`/`answer` + prompt/confirm mock | done | +4 | 6c1da921 |
| 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | blocked | | |
| 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | partial | +2 | e01a3baa |
| 30 | `logAll` config | done | +1 | 64bcefff |
### Bucket D — medium features
| # | Cluster | Status | Δ |
|---|---------|--------|---|
| 31 | runtime null-safety error reporting | pending | (+1518 est) |
| 32 | MutationObserver mock + `on mutation` | pending | (+1015 est) |
| 33 | cookie API | pending | (+5 est) |
| 34 | event modifier DSL | pending | (+68 est) |
| 35 | namespaced `def` | pending | (+3 est) |
| 31 | runtime null-safety error reporting | blocked | — |
| 32 | MutationObserver mock + `on mutation` | done | +7 |
| 33 | cookie API | partial | +4 |
| 34 | event modifier DSL | partial | +7 |
| 35 | namespaced `def` | done | +3 |
### Bucket E — subsystems (design docs landed, pending review + implementation)
@@ -86,9 +86,9 @@ Defer until AD drain. Estimated ~25 recoverable tests.
| Bucket | Done | Partial | In-prog | Pending | Blocked | Design-done | Total |
|--------|-----:|--------:|--------:|--------:|--------:|------------:|------:|
| A | 12 | 4 | 0 | 0 | 1 | — | 17 |
| B | 6 | 0 | 0 | 0 | 1 | — | 7 |
| C | 4 | 0 | 0 | 0 | 1 | — | 5 |
| D | 0 | 0 | 0 | 5 | 0 | — | 5 |
| B | 7 | 0 | 0 | 0 | 0 | — | 7 |
| C | 4 | 1 | 0 | 0 | 0 | — | 5 |
| D | 2 | 2 | 0 | 0 | 1 | — | 5 |
| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 |
| F | — | — | — | ~10 | — | — | ~10 |

View File

@@ -69,7 +69,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
10. **[done (+1)] `swap` variable ↔ property** — `swap / can swap a variable with a property` (1 test). Swap command doesn't handle mixed var/prop targets. Expected: +1.
11. **[done (+3) — partial, `hide element then show element retains original display` remains; needs `on click N` count-filtered event handlers, out of scope for this cluster] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4.
11. **[done (+4)] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4.
12. **[done (+2)] `show` multi-element + display retention** — `show / can show multiple elements with inline-block`, `can filter over a set of elements using the its symbol` (2 tests). Expected: +2.
@@ -93,7 +93,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
21. **[done (+1)] `possessiveExpression` property access via its** — `possessive / can access its properties` (1 test, Expected `foo` got ``). Expected: +1.
22. **[blocked: tried three compile-time emits — (1) guard (can't catch Undefined symbol since it's a host-level error, not an SX raise), (2) env-has? (primitive not loaded in HS kernel — `Unhandled exception: "env-has?"`), and (3) hs-win-call runtime helper (works when reached but SX can't CALL a host-handle function directly — `Not callable: {:__host_handle N}` because NativeFn is not callable here). Needs either a host-call-fn primitive with arity-agnostic dispatch OR a symbol-bound? predicate in the HS kernel.] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + unlocks several others. When calling `foo()` where `foo` isn't SX-defined, fall back to `(host-global "foo")`. Design decision: either compile-time emit `(or foo (host-global "foo"))` via a helper, or add runtime lookup in the dispatch path. Expected: +2-4.
22. **[done (+1)] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + `can refer to function in init blocks`. Added `host-call-fn` FFI primitive (commit 337c8265), `hs-win-call` runtime helper, simplified compiler emit (direct hs-win-call, no guard), `def` now also registers fn on `window[name]`. Generator: fixed `\"` escaping in hs-compile string literals. Expected: +2-4.
23. **[done (+1)] `me symbol works in from expressions`** — `regressions` (1 test, Expected `Foo`). Check `from` expression compilation. Expected: +1.
@@ -109,21 +109,21 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
28. **[done (+4)] `ask`/`answer` + prompt/confirm mock** — `askAnswer` 4 tests. **Requires test-name-keyed mock**: first test wants `confirm → true`, second `confirm → false`, third `prompt → "Alice"`, fourth `prompt → null`. Keyed via `_current-test-name` in the runner. Expected: +4.
29. **[blocked: sx-tree MCP tools returning Yojson Type_error on every file op. Can't edit integration.sx to add before:init/after:init dispatch. Also 4 of the 6 tests fundamentally require stricter parser error-rejection (add - to currently succeeds as SX expression; on click blargh end accepts blargh as symbol), which is larger than a single cluster budget.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6.
29. **[done (+2) — partial, 4 parser-error tests remain (basic parse error messages, parse-error event, EOF newline crash, evaluate-api-first-error). All require stricter parser error-rejection `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Plus emit-error-collection runtime + hyperscript:parse-error event with detail.errors. Larger than a single cluster budget; recommend bucket-D plan-first.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6.
30. **[done (+1)] `logAll` config** — 1 test. Global config that console.log's each command. Expected: +1.
### Bucket D: medium features (bigger commits, plan-first)
31. **[pending] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18.
31. **[blocked: Bucket-D plan-first scope, doesn't fit one cluster budget. All 18 tests are SKIP (untranslated) — generator has no `error("HS")` helper. Required pieces: (a) generator-side `eval-hs-error` helper + recognizer for `expect(await error("HS")).toBe("MSG")` blocks; (b) runtime helpers `hs-null-error!` / `hs-named-target` / `hs-named-target-list` raising `'<sel>' is null`; (c) compiler patches at every target-position `(query SEL)` emit to wrap in named-target carrying the original selector source — that's ~17 command emit paths (add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take); (d) function-call null-check at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name `'x'` / `'x.y'` from the parse tree; (e) possessive-base null-check (`set x's y to true``'x' is null`). Each piece is straightforward in isolation but the cross-cutting compiler change touches every emit path and needs a coordinated design pass. Recommend a dedicated design doc + multi-commit worktree like buckets E36-E40.] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18.
32. **[pending] MutationObserver mock + `on mutation` dispatch** — 15 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15.
32. **[done (+7)] MutationObserver mock + `on mutation` dispatch** — 7 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15.
33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
33. **[done (+4) — partial, 1 test remains: `iterate cookies values work` needs `hs-for-each` to recognise host-array/proxy collections (currently `(list? collection)` returns false for the JS Proxy so the loop body never runs). Out of scope.] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
34. **[pending] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8.
34. **[done (+7) — partial, 1 test remains: `every` keyword multi-handler-execute test needs handler-queue semantics where `wait for X` doesn't block subsequent invocations of the same handler — current `hs-on-every` shares the same dom-listen plumbing as `hs-on` and queues events implicitly via JS event loop, so the third synthetic click waits for the prior handler's `wait for customEvent` to settle. Out of single-cluster scope.] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8.
35. **[pending] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3.
35. **[done (+3)] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3.
### Bucket E: subsystems (DO NOT LOOP — human-driven)
@@ -177,6 +177,39 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests
(Reverse chronological — newest at top.)
### 2026-04-25 — Bucket F: in-expression filter semantics (+1)
- **67a5f137** — `HS: in-expression filter semantics (+1 test)`. `1 in [1, 2, 3]` was returning boolean `true` instead of the filtered list `(list 1)`. Root cause: `in?` compiled to `hs-contains?` which returns boolean for scalar items. Fix: (a) `runtime.sx` adds `hs-in?` returning filtered list for all cases, plus `hs-in-bool?` which wraps with `(not (hs-falsy? ...))` for boolean contexts; (b) `compiler.sx` changes `in?` clause to emit `(hs-in? collection item)` and adds new `in-bool?` clause emitting `(hs-in-bool? collection item)`; (c) `parser.sx` changes `is in` and `am in` comparison forms to produce `in-bool?` so those stay boolean. Suite hs-upstream-expressions/in: 8/9 → 9/9. Smoke 0-195: 173/195 unchanged.
### 2026-04-25 — cluster 22 window global fn fallback (+1)
- **d31565d5** — `HS cluster 22: simplify win-call emit + def→window + init-blocks test (+1)`. Two-part change building on 337c8265 (host-call-fn FFI + hs-win-call runtime). (a) `compiler.sx` removes the guard wrapper from bare-call and method-call `hs-win-call` emit paths — direct `(hs-win-call name (list args))` is sufficient since hs-win-call returns nil for unknown names; `def` compilation now also emits `(host-set! (host-global "window") name fn)` so every HS-defined function is reachable via window lookup. (b) `generate-sx-tests.py` fixes a quoting bug: `\"here\"` was being embedded as three SX nodes (`""` + symbol + `""`) instead of a single escaped-quote string; fixed with `\\\"` escaping. Hand-rolled deftest for `can refer to function in init blocks` now passes. Suite hs-upstream-core/regressions: 13/16 → 14/16. Smoke 0-195: 172/195 → 173/195.
### 2026-04-25 — cluster 11/33 followups: hide strategy + cookie clear (+2)
- **5ff2b706** — `HS: cluster 11/33 followups (+2 tests)`. Three orthogonal fixes that pick up tests now unblocked by earlier work. (a) `parser.sx` `parse-hide-cmd`/`parse-show-cmd`: added `on` to the keyword set that flips the implicit-`me` target. Previously `on click 1 hide on click 2 show` silently parsed as `(hs-hide! nil ...)` because `parse-expr` started consuming `on` and returned nil; now hide/show recognise a sibling feature and default to `me`. (b) `runtime.sx` `hs-method-call` fallback for non-built-in methods: SX-callables (lambdas) call via `apply`, JS-native functions (e.g. `cookies.clear`) dispatch via `(apply host-call (cons obj (cons method args)))` so the native receives the args list. (c) Generator `hs-cleanup!` body wrapped in `begin` (fn body evaluates only the last expr) and now resets `hs-set-default-hide-strategy! nil` + `hs-set-log-all! false` between tests — the prior `can set default to custom strategy` cluster-11 test had been leaking `_hs-default-hide-strategy` into the rest of the suite, breaking `hide element then show element retains original display`. New cluster-33 hand-roll for `basic clear cookie values work` exercises the method-call fallback. Suite hs-upstream-hide: 15/16 → 16/16. Suite hs-upstream-expressions/cookies: 3/5 → 4/5. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 35 namespaced def + script-tag globals (+3)
- **122053ed** — `HS: namespaced def + script-tag global functions (+3 tests)`. Two-part change: (a) `runtime.sx` `hs-method-call` gains a fallback for unknown methods — `(let ((fn-val (host-get obj method))) (if (callable? fn-val) (apply fn-val args) nil))`. This lets `utils.foo()` dispatch through `(host-get utils "foo")` when `utils` is an SX dict whose `foo` is an SX lambda. (b) Generator hand-rolls 3 deftests since the SX runtime has no `<script type='text/hyperscript'>` tag boot. For `is called synchronously` / `can call asynchronously`: `(eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() ... end")))))` registers the function in the global eval env (eval-expr-cek processes `(define foo (fn ...))` at top scope), then a click div is built via dom-set-attr + hs-boot-subtree!. For `functions can be namespaced`: define `utils` as a dict, register `__utils_foo` as a fresh-named global def, then `(host-set! utils "foo" __utils_foo)` populates the dict; click handler `call utils.foo()` compiles to `(hs-method-call utils "foo")` which now dispatches through the new runtime fallback. Skip-list cleared of the 3 def entries. Suite hs-upstream-def: 24/27 → 27/27. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 34 elsewhere / from-elsewhere modifier (+2)
- **3044a168** — `HS: elsewhere / from elsewhere modifier (+2 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` parses an optional `elsewhere` (or `from elsewhere`) modifier between event-name and source. The `from elsewhere` variant uses a one-token lookahead so plain `from #target` keeps parsing as a source expression. Emits `:elsewhere true` part. (b) `compiler.sx` `scan-on` threads `elsewhere?` (10th param) through every recursive call + new `:elsewhere` cond branch. The dispatch case becomes a 3-way `cond` over target: elsewhere → `(dom-body)` (listener attaches to body and bubble sees every click), source → from-source, default → `me`. The `compiled-body` build is wrapped with `(when (not (host-call me "contains" (host-get event "target"))) BODY)` so handlers fire only on outside-of-`me` clicks. (c) Generator drops `supports "elsewhere" modifier` and `supports "from elsewhere" modifier` from `SKIP_TEST_NAMES`. Suite hs-upstream-on: 48/70 → 50/70. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 34 count-filtered events + first modifier (+5 partial)
- **19c97989** — `HS: count-filtered events + first modifier (+5 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` accepts `first` keyword before event-name (sets `cnt-min/max=1`), then optionally parses a count expression after event-name: bare number = exact count, `N to M` = inclusive range, `N and on` = unbounded above. Number tokens coerced via `parse-number`. New parts entry `:count-filter {"min" N "max" M-or--1}`. (b) `compiler.sx` `scan-on` gains a 9th `count-filter-info` param threaded through every recursive call + a new `:count-filter` cond branch. The handler binding now wraps the `(fn (event) BODY)` in `(let ((__hs-count 0)) (fn (event) (begin (set! __hs-count (+ __hs-count 1)) (when COUNT-CHECK BODY))))` when count info is present. Each `on EVENT N ...` clause produces its own closure-captured counter, so `on click 1` / `on click 2` / `on click 3` fire on their respective Nth click (mix-ranges test). (c) Generator drops 5 entries from `SKIP_TEST_NAMES``can filter events based on count`/`...count range`/`...unbounded count range`/`can mix ranges`/`on first click fires only once`. Suite hs-upstream-on: 43/70 → 48/70. Smoke 0-195 unchanged at 172/195. Remaining cluster-34 work (`elsewhere`/`from elsewhere`/`every`-keyword multi-handler) is independent from count filters and would need a separate iteration.
### 2026-04-25 — cluster 29 hyperscript init events (+2 partial)
- **e01a3baa** — `HS: hyperscript:before:init / :after:init events (+2 tests)`. `integration.sx` `hs-activate!` now wraps the activation block in `(when (dom-dispatch el "hyperscript:before:init" nil) ...)``dom-dispatch` builds a CustomEvent with `bubbles:true`, the mock El's `cancelable` defaults to true, `dispatchEvent` returns `!ev.defaultPrevented`, so `when` skips the activate body if a listener called `preventDefault()`. After activation completes successfully it dispatches `hyperscript:after:init`. Generator (`tests/playwright/generate-sx-tests.py`) gains two hand-rolled deftests: `fires hyperscript:before:init and hyperscript:after:init` builds a wa container, attaches listeners that append to a captured `events` list, sets innerHTML to a div with `_=`, calls `hs-boot-subtree!`, asserts the events list. `hyperscript:before:init can cancel initialization` attaches a preventDefault listener and asserts `data-hyperscript-powered` is absent on the inner div after boot. Suite hs-upstream-core/bootstrap: 20/26 → 22/26. Smoke 0-195: 170 → 172. Remaining 4 cluster-29 tests (basic parse error messages, parse-error event, EOF newline, eval-API throws on first error) all need stricter parser error-rejection plus a parse-error collector — recommend bucket-D plan-first multi-commit, not a single iteration.
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (+7)
- **13e02542** — `HS: MutationObserver mock + on mutation dispatch (+7 tests)`. Five-part change: (a) `parser.sx` `parse-on-feat` now consumes `of <FILTER>` after `mutation` event-name. FILTER is one of `attributes`/`childList`/`characterData` (ident tokens) or one or more `@name` attr-tokens chained by `or`. Emits `:of-filter {"type" T "attrs" L?}` part. (b) `compiler.sx` `scan-on` threads new `of-filter-info` param; the dispatch case becomes a `cond` over `event-name` — for `"mutation"` it emits `(do on-call (hs-on-mutation-attach! target MODE ATTRS))` where ATTRS is `(cons 'list attr-list)` so the list survives compile→eval. (c) `runtime.sx` `hs-on-mutation-attach!` builds a config dict (`attributes`/`childList`/`characterData`/`subtree`/`attributeFilter`) matched to mode, constructs a real `MutationObserver(cb)`, calls `mo.observe(target, opts)`, and the cb dispatches a `"mutation"` event on target. (d) `tests/hs-run-filtered.js` replaces the no-op MO with `HsMutationObserver` (global registry, decodes SX-list `attributeFilter`); prototype hooks on `El.setAttribute/appendChild/removeChild/_setInnerHTML` fire matching observers synchronously, with `__hsMutationActive` re-entry guard so handlers that mutate the DOM don't infinite-loop. Per-test reset clears registry + flag. (e) `generate-sx-tests.py` drops 7 mutation entries from `SKIP_TEST_NAMES` and adds two body patterns: `evaluate(() => document.querySelector(SEL).setAttribute(N,V))``(dom-set-attr ...)`, and `evaluate(() => document.querySelector(SEL).appendChild(document.createElement(T)))``(dom-append … (dom-create-element …))`. Suite hs-upstream-on: 36/70 → 43/70. Smoke 0-195 unchanged at 170/195.
### 2026-04-25 — cluster 33 cookie API (partial +3)
- No `.sx` edits needed — `set cookies.foo to 'bar'` already compiles to `(dom-set-prop cookies "foo" "bar")` which becomes `(host-set! cookies "foo" "bar")` once the `dom` module is loaded, and `cookies.foo` becomes `(host-get cookies "foo")`. So a JS-only Proxy + Python generator change does the trick. Two parts: (a) `tests/hs-run-filtered.js` adds a per-test `__hsCookieStore` Map, a `globalThis.cookies` Proxy with `length`/`clear`/named-key get traps and a set trap that writes the store, and a `Object.defineProperty(document, 'cookie', …)` getter/setter that reads and writes the same store (so the upstream `length is 0` test's pre-clear loop over `document.cookie` works). Per-test reset clears the store. (b) `tests/playwright/generate-sx-tests.py` declares `(define cookies (host-global "cookies"))` in the test header and emits hand-rolled deftests for the three tractable tests (`basic set`, `update`, `length is 0`). Suite hs-upstream-expressions/cookies: 0/5 → 3/5. Smoke 0-195 unchanged at 170/195. Remaining `basic clear` and `iterate` tests need runtime.sx edits (hs-method-call fallback + hs-for-each host-array recognition) — out of scope for a JS-only iteration.
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (blocked)
- Two issues conspire: (1) `loops/hs` worktree has no pre-built sx-tree binary so MCP tools aren't loaded, and the block-sx-edit hook prevents raw `Edit`/`Read`/`Write` on `.sx` files. Built `hosts/ocaml/_build/default/bin/mcp_tree.exe` via `dune build` this iteration but tools don't surface mid-session. (2) Cluster scope is genuinely big: parser must learn `on mutation of <filter>` (currently drops body after `of` — verified via compile dump: `on mutation of attributes put "Mutated" into me``(hs-on me "mutation" (fn (event) nil))`), compiler needs `:of-filter` plumbing similar to intersection's `:having`, runtime needs `hs-on-mutation-attach!`, JS runner mock needs a real MutationObserver (currently no-op `class{observe(){}disconnect(){}}` at hs-run-filtered.js:348) plus `setAttribute`/`appendChild` instrumentation, and 7 entries removed from `SKIP_TEST_NAMES`. Recommended next step: dedicated worktree where sx-tree loads at session start, multi-commit shape (parser → compiler+attach → mock+runner → generator skip-list).
### 2026-04-25 — cluster 31 runtime null-safety error reporting (blocked)
- All 18 tests are `SKIP (untranslated)` — generator has no `error("HS")` helper at all. Inspected representative compile outputs: `add .foo to #doesntExist``(for-each ... (hs-query-all "#doesntExist"))` (silently no-ops on empty list, no error); `hide #doesntExist``(hs-hide! (hs-query-all "#doesntExist") "display")` (likewise); `put 'foo' into #doesntExist``(hs-set-inner-html! (hs-query-first "#doesntExist") "foo")` (passes nil through); `x()``(x)` (raises `Undefined symbol: x`, wrong format); `x.y.z()``(hs-method-call (host-get x "y") "z")`. Implementing this requires generator helper + 17 compiler emit-path patches + function-call/method-call/possessive-base null guards + new `hs-named-target`/`hs-named-target-list` runtime — too many surfaces for a single-iteration commit. Bucket D explicitly says "plan-first" — recommended path is a dedicated design doc and multi-commit worktree like E36-E40, not a loop iteration.
### 2026-04-24 — cluster 29 hyperscript:before:init / :after:init / :parse-error (blocked)
- **2b486976** — `HS-plan: mark cluster 29 blocked`. sx-tree MCP file ops returning `Yojson__Safe.Util.Type_error("Expected string, got null")` on every file-based call (sx_read_subtree, sx_find_all, sx_replace_by_pattern, sx_summarise, sx_pretty_print, sx_write_file). Only in-memory ops work (sx_eval, sx_build, sx_env). Without sx-tree I can't edit integration.sx to add before:init/after:init dispatch on hs-activate!. Investigated the 6 tests: 2 bootstrap (before/after init) need dispatchEvent wrapping activate; 4 parser tests require stricter parser error-rejection — `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Fundamental parser refactor is out of single-cluster budget regardless of sx-tree availability.

View File

@@ -39,91 +39,59 @@ Representation choices (finalise in phase 1, document here):
## Roadmap
### Phase 1 — tokenizer + term parser (no operator table)
- [x] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
- [x] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
- [x] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
- [x] Unit tests in `lib/prolog/tests/parse.sx` — 25 pass
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
- [ ] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
- [ ] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
- [ ] Unit tests in `lib/prolog/tests/parse.sx`
### Phase 2 — unification + trail
- [x] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
- [x] Occurs-check off by default, exposed as flag
- [x] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs — 47 pass
- [ ] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
- [ ] Occurs-check off by default, exposed as flag
- [ ] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs
### Phase 3 — clause DB + DFS solver + cut + first classic programs
- [x] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts`pl-mk-db` / `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal`, 14 tests in `tests/clausedb.sx`
- [x] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next — first cut: trail-based undo + CPS k (no shift/reset yet, per briefing gotcha). Built-ins so far: `true/0`, `fail/0`, `=/2`, `,/2`. Refactor to delimited conts later.
- [x] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier — two-cut-box scheme: each `pl-solve-user!` creates a fresh inner-cut-box (set by `!` in this predicate's body) AND snapshots the outer-cut-box state on entry. After body fails, abandon clause alternatives if (a) inner was set or (b) outer transitioned false→true during this call. Lets post-cut goals backtrack normally while blocking pre-cut alternatives. 6 cut tests cover bare cut, clause-commit, choice-commit, cut+fail, post-cut backtracking, nested-cut isolation.
- [x] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0` — all 11 done. `write/1` and `nl/0` use a global `pl-output-buffer` string + `pl-output-clear!` for testability; `pl-format-term` walks deep then renders atoms/nums/strs/compounds/vars (var → `_<id>`). Note: cut-transparency via `;` not testable yet without operator support — `;(,(a,!), b)` parser-rejects because `,` is body-operator-only; revisit in phase 4.
- [x] Arithmetic `is/2` with `+ - * / mod abs``pl-eval-arith` walks deep, recurses on compounds, dispatches on functor; binary `+ - * / mod`, binary AND unary `-`, unary `abs`. `is/2` evaluates RHS, wraps as `("num" v)`, unifies via `pl-solve-eq!`. 11 tests cover each op + nested + ground LHS match/mismatch + bound-var-on-RHS chain.
- [x] Classic programs in `lib/prolog/tests/programs/`:
- [x] `append.pl` — list append (with backtracking)`lib/prolog/tests/programs/append.{pl,sx}`. 6 tests cover: build (`append([], L, X)`, `append([1,2], [3,4], X)`), check ground match/mismatch, full split-backtracking (`append(X, Y, [1,2,3])` → 4 solutions), single-deduce (`append(X, [3], [1,2,3])` → X=[1,2]).
- [x] `reverse.pl` — naive reverse`lib/prolog/tests/programs/reverse.{pl,sx}`. Naive reverse via append: `reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R)`. 6 tests cover empty, singleton, 3-list, 4-atom-list, ground match, ground mismatch.
- [x] `member.pl` — generate all solutions via backtracking`lib/prolog/tests/programs/member.{pl,sx}`. Classic 2-clause `member(X, [X|_])` + `member(X, [_|T]) :- member(X, T)`. 7 tests cover bound-element hit/miss, empty list, generator (count = list length), first-solution binding, duplicate matches counted twice, anonymous head-cell unification.
- [x] `nqueens.pl` — 8-queens`lib/prolog/tests/programs/nqueens.{pl,sx}`. Permute-and-test formulation: `queens(L, Qs) :- permute(L, Qs), safe(Qs)` + `select` + `safe` + `no_attack`. Tested at N=1 (1), N=2 (0), N=3 (0), N=4 (2), N=5 (10) plus first-solution check at N=4 = `[2, 4, 1, 3]`. N=8 omitted — interpreter is too slow (40320 perms); add once compiled clauses or constraint-style placement land. `range/3` skipped pending arithmetic-comparison built-ins (`>/2` etc.).
- [x] `family.pl` — facts + rules (parent/ancestor)`lib/prolog/tests/programs/family.{pl,sx}`. 5 parent facts + male/female + derived `father`/`mother`/`ancestor`/`sibling`. 10 tests cover direct facts, fact count, transitive ancestor through 3 generations, descendant counting, gender-restricted father/mother, sibling via shared parent + `\=`.
- [x] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` — bash script feeds load + eval epoch script to sx_server, parses each suite's `{:failed N :passed N :total N :failures (...)}` line, writes JSON (machine) + MD (human) scoreboards. Exit non-zero on any failure. `SX_SERVER` env var overrides binary path. First scoreboard: 183 / 183.
- [x] Target: all 5 classic programs passing — append (6) + reverse (6) + member (7) + nqueens (6) + family (10) = 35 program tests, all green. Phase 3 architecturally complete bar the conformance harness/scoreboard.
- [ ] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts
- [ ] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next
- [ ] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier
- [ ] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0`
- [ ] Arithmetic `is/2` with `+ - * / mod abs`
- [ ] Classic programs in `lib/prolog/tests/programs/`:
- [ ] `append.pl` — list append (with backtracking)
- [ ] `reverse.pl` — naive reverse
- [ ] `member.pl` — generate all solutions via backtracking
- [ ] `nqueens.pl` — 8-queens
- [ ] `family.pl` — facts + rules (parent/ancestor)
- [ ] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
- [ ] Target: all 5 classic programs passing
### Phase 4 — operator table + more built-ins (next run)
- [x] Operator table parsing (prefix/infix/postfix, precedence, assoc)`pl-op-table` (15 entries: `, ; -> = \= is < > =< >= + - * / mod`); precedence-climbing parser via `pp-parse-primary` + `pp-parse-term-prec` + `pp-parse-op-rhs`. Parens override precedence. Args inside compounds parsed at 999 so `,` stays as separator. xfx/xfy/yfx supported; prefix/postfix deferred (so `-5` still tokenises as bare atom + num as before). Comparison built-ins `</2 >/2 =</2 >=/2` added. New `tests/operators.sx` 19 tests cover assoc/precedence/parens + solver via infix.
- [x] `assert/1`, `asserta/1`, `assertz/1`, `retract/1``assert` aliases `assertz`. Helpers `pl-rt-to-ast` (deep-walk + replace runtime vars with `_G<id>` parse markers) + `pl-build-clause` (detect `:-` head). `assertz` uses `pl-db-add!`; `asserta` uses new `pl-db-prepend!`. `retract` walks goal, looks up by functor/arity, tries each clause via unification, removes first match by index (`pl-list-without`). 11 tests in `tests/dynamic.sx`. Rule-asserts now work — `:-` added to op table (prec 1200 xfx) with fix to `pl-token-op` accepting `"op"` token type. 15 tests in `tests/assert_rules.sx`.
- [x] `findall/3`, `bagof/3`, `setof/3` — shared `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template (via `pl-deep-copy` with var-map for shared-var preservation) on each success, returns false to backtrack, then restores trail. `findall` always succeeds with a (possibly empty) list. `bagof` fails on empty. `setof` builds a string-keyed dict via `pl-format-term` for sort+dedupe (via `keys` + `sort`), fails on empty. Existential `^` deferred (operator). 11 tests in `tests/findall.sx`.
- [x] `copy_term/2`, `functor/3`, `arg/3`, `=../2``copy_term/2` reuses `pl-deep-copy` with a fresh var-map (preserves source aliasing). `functor/3` handles 4 modes: compound→{name, arity}, atom→{atom, 0}, num→{num, 0}, var with ground name+arity→constructed term (`pl-make-fresh-args` for compound case). `arg/3` extracts 1-indexed arg from compound. **`=../2` deferred** — the tokenizer treats `.` as the clause terminator unconditionally, so `=..` lexes as `=` + `.` + `.`; needs special-case lex (or surface syntax via a different name). 14 tests in `tests/term_inspect.sx`.
- [x] String/atom predicates
- [ ] Operator table parsing (prefix/infix/postfix, precedence, assoc)
- [ ] `assert/1`, `asserta/1`, `assertz/1`, `retract/1`
- [ ] `findall/3`, `bagof/3`, `setof/3`
- [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2`
- [ ] String/atom predicates
### Phase 5 — Hyperscript integration
- [x] `prolog-query` primitive callable from SX/Hyperscript
- [ ] Hyperscript DSL: `when allowed(user, :edit) then …`**blocked** (needs `lib/hyperscript/**`, out of scope)
- [ ] `prolog-query` primitive callable from SX/Hyperscript
- [ ] Hyperscript DSL: `when allowed(user, :edit) then …`
- [ ] Integration suite
### Phase 6 — ISO conformance
- [x] Vendor Hirst's conformance tests
- [x] Drive scoreboard to 200+
- [ ] Vendor Hirst's conformance tests
- [ ] Drive scoreboard to 200+
### Phase 7 — compiler (later, optional)
- [x] Compile clauses to SX continuations for speed
- [x] Keep interpreter as the reference
- [ ] Compile clauses to SX continuations for speed
- [ ] Keep interpreter as the reference
## Progress log
_Newest first. Agent appends on every commit._
- 2026-04-25 — `pl-compiled-matches-interp?` cross-validator in `compiler.sx`: loads source into both a plain and a compiled DB, runs the same goal, returns true iff solution counts match. `tests/cross_validate.sx` applies this to 17 goals across append/member/ancestor/cut/arithmetic/if-then-else, locking the interpreter as the reference against which any future compiler change must agree. Total **551** (+17).
- 2026-04-25 — Clause compiler (`lib/prolog/compiler.sx`): `pl-compile-clause` converts parse-AST clauses to SX closures `(fn (goal trail db cut-box k) bool)`. Pre-collects var names at compile time; `pl-cmp-build-term` reconstructs fresh runtime terms per call. `pl-compile-db!` compiles all clauses in a DB and stores them in `:compiled` table. `pl-solve-user!` in runtime.sx auto-dispatches to compiled lambdas when present, falls back to interpreted. `pl-try-compiled-clauses!` mirrors `pl-try-clauses!` cut semantics. 17 tests in `tests/compiler.sx`. Total **534** (+17).
- 2026-04-25 — `predsort/3` (insertion-sort with 3-arg comparator predicate, deduplicates `=` pairs), `term_variables/2` (collect unbound vars left-to-right, dedup by id), arithmetic extensions (`floor/1`, `ceiling/1`, `truncate/1`, `round/1`, `sign/1`, `sqrt/1`, `pow/2`, `**/2`, `^/2`, `integer/1`, `float/1`, `float_integer_part/1`, `float_fractional_part/1`). 21 tests in `tests/advanced.sx`. Total **517** (+21).
- 2026-04-25 — `sub_atom/5` (non-deterministic substring enumeration; CPS loop over all (start,sublen) pairs; trail-undo only on backtrack) + `aggregate_all/3` (6 templates: count/bag/sum/max/min/set; uses `pl-collect-solutions`). 25 tests in `tests/string_agg.sx`. Total **496** (+25).
- 2026-04-25 — `:-` operator + assert with rules: added `(list ":-" 1200 "xfx")` to `pl-op-table`; fixed `pl-token-op` to accept `"op"` token type (tokenizer emits `:-` as `"op"`, not `"atom"`). `pl-build-clause` already handled `("compound" ":-" ...)`. `assert((head :- body))` now works for facts+rules. 15 tests in `tests/assert_rules.sx`. Total **471** (+15).
- 2026-04-25 — IO/term predicates: `term_to_atom/2` (bidirectional: format term or parse atom), `term_string/2` (alias), `with_output_to/2` (atom/string sinks — saves/restores `pl-output-buffer`), `writeln/1`, `format/1` (~n/~t/~~), `format/2` (~w/~a/~d pull from arg list). 24 tests in `tests/io_predicates.sx`. Total **456** (+24).
- 2026-04-25 — Char predicates: `char_type/2` (9 modes: alpha/alnum/digit/digit(N)/space/white/upper(L)/lower(U)/ascii(C)/punct), `upcase_atom/2`, `downcase_atom/2`, `string_upper/2`, `string_lower/2`. 10 helpers using `char-code`/`char-from-code` SX primitives. 27 tests in `tests/char_predicates.sx`. Total **432** (+27).
- 2026-04-25 — Set/fold predicates: `foldl/4` (CPS fold-left, threads accumulator via `pl-apply-goal`), `list_to_set/2` (dedup preserving first-occurrence), `intersection/3`, `subtract/3`, `union/3` (all via `pl-struct-eq?`). 3 new helpers, 15 tests in `tests/set_predicates.sx`. Total **405** (+15).
- 2026-04-25 — Meta-call predicates: `forall/2` (negation-of-counterexample), `maplist/2` (goal over list), `maplist/3` (map goal building output list), `include/3` (filter by goal success), `exclude/3` (filter by goal failure). New `pl-apply-goal` helper extends a goal with extra args. 15 tests in `tests/meta_call.sx`. Total **390** (+15).
- 2026-04-25 — List/utility predicates: `==/2`, `\==/2` (structural equality/inequality via `pl-struct-eq?`), `flatten/2` (deep Prolog-list flatten), `numlist/3` (integer range list), `atomic_list_concat/2` (join with no sep), `atomic_list_concat/3` (join with separator), `sum_list/2`, `max_list/2`, `min_list/2` (arithmetic folds), `delete/3` (remove all struct-equal elements). 7 new helpers, 33 tests in `tests/list_predicates.sx`. Total **375** (+33).
- 2026-04-25 — Meta/logic predicates: `\+/1` (negation-as-failure, trail-undo on success), `not/1` (alias), `once/1` (commit to first solution via if-then-else), `ignore/1` (always succeed), `ground/1` (all vars bound), `sort/2` (sort + dedup by formatted key), `msort/2` (sort, keep dups), `atom_number/2` (bidirectional), `number_string/2` (bidirectional). 2 helpers (`pl-ground?`, `pl-sort-pairs-dedup`). 25 tests in `tests/meta_predicates.sx`. Total **342** (+25).
- 2026-04-25 — ISO utility predicates batch: `succ/2` (bidirectional), `plus/3` (3-mode bidirectional), `between/3` (backtracking range generator), `length/2` (bidirectional list length + var-list constructor), `last/2`, `nth0/3`, `nth1/3`, `max/2` + `min/2` in arithmetic eval. 6 new helper functions (`pl-list-length`, `pl-make-list-of-vars`, `pl-between-loop!`, `pl-solve-between!`, `pl-solve-last!`, `pl-solve-nth0!`). 29 tests in `tests/iso_predicates.sx`. Phase 6 complete: scoreboard already at 317, far above 200+ target. Hyperscript DSL blocked (needs `lib/hyperscript/**`). Total **317** (+29).
- 2026-04-25 — `prolog-query` SX API (`lib/prolog/query.sx`). New public API layer: `pl-load source-str → db`, `pl-query-all db query-str → list of solution dicts`, `pl-query-one db query-str → dict or nil`, `pl-query src query → list` (convenience). Each solution dict maps variable name strings to their formatted term strings. Var names extracted from pre-instantiation parse AST. Trail is marked before solve and reset after to ensure clean state. 16 tests in `tests/query_api.sx` cover fact lookup, no-solution, boolean queries, multi-var, recursive rules, is/2 built-in, query-one, convenience form. Total **288** (+16).
- 2026-04-25 — String/atom predicates. Type-test predicates: `var/1`, `nonvar/1`, `atom/1`, `number/1`, `integer/1`, `float/1` (always-fail), `compound/1`, `callable/1`, `atomic/1`, `is_list/1`. String/atom operations: `atom_length/2`, `atom_concat/3` (3 modes: both-ground, result+first, result+second), `atom_chars/2` (bidirectional), `atom_codes/2` (bidirectional), `char_code/2` (bidirectional), `number_codes/2`, `number_chars/2`. 7 helper functions in runtime.sx (`pl-list-to-prolog`, `pl-proper-list?`, `pl-prolog-list-to-sx`, `pl-solve-atom-concat!`, `pl-solve-atom-chars!`, `pl-solve-atom-codes!`, `pl-solve-char-code!`). 34 tests in `tests/atoms.sx`. Total **272** (+34).
- 2026-04-25 — `copy_term/2` + `functor/3` + `arg/3` (term inspection). `copy_term` is a one-line dispatch to existing `pl-deep-copy`. `functor/3` is bidirectional — decomposes a bound compound/atom/num into name+arity OR constructs from ground name+arity (atom+positive-arity → compound with N anonymous fresh args via `pl-make-fresh-args`; arity 0 → atom/num). `arg/3` extracts 1-indexed arg with bounds-fail. New helper `pl-solve-eq2!` for paired-unification with shared trail-undo. 14 tests in `tests/term_inspect.sx`. Total **238** (+14). `=..` deferred — `.` always tokenizes as clause terminator; needs special lexer case.
- 2026-04-25 — `findall/3` + `bagof/3` + `setof/3`. Shared collector `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template per success (`pl-deep-copy` walks term, allocates fresh runtime vars via shared var-map so co-occurrences keep aliasing), returns false to keep backtracking, then `pl-trail-undo-to!` to clean up. `findall` always builds a list. `bagof` fails on empty. `setof` uses a `pl-format-term`-keyed dict + SX `sort` for dedupe + ordering. New `tests/findall.sx` 11 tests. Total **224** (+11). Existential `^` deferred — needs operator.
- 2026-04-25 — Dynamic clauses: `assert/1`, `assertz/1`, `asserta/1`, `retract/1`. New helpers `pl-rt-to-ast` (deep-walk runtime term → parse-AST, mapping unbound runtime vars to `_G<id>` markers so `pl-instantiate-fresh` produces fresh vars per call) + `pl-build-clause` + `pl-db-prepend!` + `pl-list-without`. `retract` keeps runtime vars (so the caller's vars get bound), walks head for the functor/arity key, tries each stored clause via `pl-unify!`, removes the first match by index. 11 tests in `tests/dynamic.sx`; conformance script gained dynamic row. Total **213** (+11). Rule-form asserts (`(H :- B)`) deferred until `:-` is in the op table.
- 2026-04-25 — Phase 4 starts: operator-table parsing. Parser rewrite uses precedence climbing (xfx/xfy/yfx); 15-op table covers control (`, ; ->`), comparison (`= \\= is < > =< >=`), arithmetic (`+ - * / mod`). Parens override. Backwards-compatible: prefix-syntax compounds (`=(X, Y)`, `+(2, 3)`) still parse as before; existing 183 tests untouched. Added comparison built-ins `</2 >/2 =</2 >=/2` to runtime (eval both sides, compare). New `tests/operators.sx` 19 tests; conformance script gained an operators row. Total **202** (+19). Prefix/postfix deferred — `-5` keeps old bare-atom semantics.
- 2026-04-25 — Conformance harness landed. `lib/prolog/conformance.sh` runs all 9 suites in one sx_server epoch, parses the `{:failed/:passed/:total/:failures}` summary lines, and writes `scoreboard.json` + `scoreboard.md`. `SX_SERVER` env var overrides the binary path; default points at the main-repo build. Phase 3 fully complete: 183 / 183 passing across parse/unify/clausedb/solve/append/reverse/member/nqueens/family.
- 2026-04-25 — `family.pl` fifth classic program — completes the 5-program target. 5-fact pedigree + male/female + derived father/mother/ancestor/sibling. 10 tests cover fact lookup + count, transitive ancestor through 3 generations, descendant counting (5), gender-restricted derivations, sibling via shared parent guarded by `\=`. Total 183 (+10). All 5 classic programs ticked; Phase 3 needs only conformance harness + scoreboard left.
- 2026-04-25 — `nqueens.pl` fourth classic program. Permute-and-test variant exercises every Phase-3 feature: lists with `[H|T]` cons sugar, multi-clause backtracking, recursive `permute`/`select`/`safe`/`no_attack`, `is/2` arithmetic on diagonals, `\=/2` for diagonal-conflict check. 6 tests at N ∈ {1,2,3,4,5} with expected counts {1,0,0,2,10} + first-solution `[2,4,1,3]`. N=5 takes ~30s (120 perms × safe-check); N=8 omitted as it would be ~thousands of seconds. Total 173 (+6).
- 2026-04-25 — `member.pl` third classic program. Standard 2-clause definition; 7 tests cover bound-element hit/miss, empty-list fail, generator-count = list length, first-solution binding (X=11), duplicate elements matched twice on backtrack, anonymous-head unification (`member(a, [X, b, c])` binds X=a). Total 167 (+7).
- 2026-04-25 — `reverse.pl` second classic program. Naive reverse defined via append. 6 tests (empty/singleton/3-list/4-atom-list/ground match/ground mismatch). Confirms the solver handles non-trivial recursive composition: `reverse([1,2,3], R)` recurses to depth 3 then unwinds via 3 nested `append`s. Total 160 (+6).
- 2026-04-25 — `append.pl` first classic program. `lib/prolog/tests/programs/append.pl` is the canonical 2-clause source; `append.sx` embeds the source as a string (no file-read primitive in SX yet) and runs 6 tests covering build, check, full split-backtrack (4 solutions), and deduction modes. Helpers `pl-ap-list-to-sx` / `pl-ap-term-to-sx` convert deep-walked Prolog lists (`("compound" "." (h t))` / `("atom" "[]")`) to SX lists for structural assertion. Total 154 (+6).
- 2026-04-25 — `is/2` arithmetic landed. `pl-eval-arith` recursively evaluates ground RHS expressions (binary `+ - * /`, `mod`; binary+unary `-`; unary `abs`); `is/2` wraps the value as `("num" v)` and unifies via `pl-solve-eq!`, so it works in all three modes — bind unbound LHS, check ground LHS for equality, propagate from earlier var bindings on RHS. 11 tests, total 148 (+11). Without operator support, expressions must be written prefix: `is(X, +(2, *(3, 4)))`.
- 2026-04-25 — `write/1` + `nl/0` landed using global string buffer (`pl-output-buffer` + `pl-output-clear!` + `pl-output-write!`). `pl-format-term` walks deep + dispatches on atom/num/str/compound/var; `pl-format-args` recursively comma-joins. 7 new tests cover atom/num/compound formatting, conjunction order, var-walk, and `nl`. Built-ins box (`=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2`, `call/1`, `write/1`, `nl/0`) now ticked. Total 137 (+7).
- 2026-04-25 — `->/2` if-then-else landed (both `;(->(C,T), E)` and standalone `->(C, T)``(C -> T ; fail)`). `pl-solve-or!` now special-cases `->` in left arg → `pl-solve-if-then-else!`. Cond runs in a fresh local cut-box (ISO opacity for cut inside cond). Then-branch can backtrack, else-branch can backtrack, but cond commits to first solution. 9 new tests covering both forms, both branches, binding visibility, cond-commit, then-backtrack, else-backtrack. Total 130 (+9).
- 2026-04-25 — Built-ins `\=/2`, `;/2`, `call/1` landed. `pl-solve-not-eq!` (try unify, always undo, succeed iff unify failed). `pl-solve-or!` (try left, on failure check cut and only try right if not cut). `call/1` opens a fresh inner cut-box (ISO opacity: cut inside `call(G)` commits G, not caller). 11 new tests in `tests/solve.sx` cover atoms+vars for `\=`, both branches + count for `;`, and `call/1` against atoms / compounds / bound goal vars. Total 121 (+11). Box not yet ticked — `->/2`, `write/1`, `nl/0` still pending.
- 2026-04-25 — Cut (`!/0`) landed. `pl-cut?` predicate; solver functions all take a `cut-box`; `pl-solve-user!` creates a fresh inner-cut-box and snapshots `outer-was-cut`; `pl-try-clauses!` abandons alternatives when inner.cut OR (outer.cut transitioned false→true during this call). 6 new cut tests in `tests/solve.sx` covering bare cut, clause-commit, choice-commit, cut+fail blocks alt clauses, post-cut goal backtracks freely, inner cut isolation. Total 110 (+6).
- 2026-04-25 — Phase 3 DFS solver landed (CPS, trail-based backtracking; delimited conts deferred). `pl-solve!` + `pl-solve-eq!` + `pl-solve-user!` + `pl-try-clauses!` + `pl-solve-once!` + `pl-solve-count!` in runtime.sx. Built-ins: `true/0`, `fail/0`, `=/2`, `,/2`. New `tests/solve.sx` 18/18 green covers atomic goals, =, conjunction, fact lookup, multi-solution count, recursive ancestor rule, trail-undo verification. Bug fix: `pl-instantiate` had no `("clause" h b)` case → vars in rule head/body were never instantiated, so rule resolution silently failed against runtime-var goals. Added clause case to recurse with shared var-env. Total 104 (+18).
- 2026-04-24 — Phase 3 clause DB landed: `pl-mk-db` + `pl-head-key` / `pl-clause-key` / `pl-goal-key` + `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal` in runtime.sx. New `tests/clausedb.sx` 14/14 green. Total 86 (+14). Loader preserves declaration order (append!).
- 2026-04-24 — Verified phase 1+2 already implemented on loops/prolog: `pl-parse-tests-run!` 25/25, `pl-unify-tests-run!` 47/47 (72 total). Ticked phase 1+2 boxes.
- _(awaiting phase 1)_
## Blockers
_Shared-file issues that need someone else to fix. Minimal repro only._
- **Phase 5 Hyperscript DSL** — `lib/hyperscript/**` is out of scope for this loop. Needs `lib/hyperscript/parser.sx` + evaluator to add `when allowed(user, :edit) then …` syntax. Skipping; Phase 5 item 1 (`prolog-query` SX API) is done.
- _(none yet)_

View File

@@ -164,13 +164,16 @@
every?
catch-info
finally-info
having-info)
having-info
of-filter-info
count-filter-info
elsewhere?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (if source (hs-to-sx source) (quote me))))
((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (quote me)))))
(let
((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list))))
(let
@@ -178,30 +181,51 @@
(let
((raw-compiled (hs-to-sx stripped-body)))
(let
((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled)))
((compiled-body (let ((base (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) (if elsewhere? (list (quote when) (list (quote not) (list (quote host-call) (quote me) "contains" (list (quote host-get) (quote event) "target"))) base) base))))
(let
((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(let
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))))
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
(let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(if
(= event-name "intersection")
(list
(quote do)
on-call
(cond
((= event-name "mutation")
(list
(quote hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil)))
on-call)))))))))))
(quote do)
on-call
(list
(quote hs-on-mutation-attach!)
target
(if
of-filter-info
(get of-filter-info "type")
"any")
(if
of-filter-info
(let
((a (get of-filter-info "attrs")))
(if
a
(cons (quote list) a)
nil))
nil))))
((= event-name "intersection")
(list
(quote do)
on-call
(list
(quote
hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil))))
(true on-call))))))))))))
((= (first items) :from)
(scan-on
(rest (rest items))
@@ -210,7 +234,10 @@
every?
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :filter)
(scan-on
(rest (rest items))
@@ -219,7 +246,10 @@
every?
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :every)
(scan-on
(rest (rest items))
@@ -228,7 +258,10 @@
true
catch-info
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :catch)
(scan-on
(rest (rest items))
@@ -237,7 +270,10 @@
every?
(nth items 1)
finally-info
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :finally)
(scan-on
(rest (rest items))
@@ -246,7 +282,10 @@
every?
catch-info
(nth items 1)
having-info))
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :having)
(scan-on
(rest (rest items))
@@ -255,6 +294,45 @@
every?
catch-info
finally-info
(nth items 1)
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :of-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
(nth items 1)
count-filter-info
elsewhere?))
((= (first items) :count-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
(nth items 1)
elsewhere?))
((= (first items) :elsewhere)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
(nth items 1)))
(true
(scan-on
@@ -264,8 +342,11 @@
every?
catch-info
finally-info
having-info)))))
(scan-on (rest parts) nil nil false nil nil nil)))))
having-info
of-filter-info
count-filter-info
elsewhere?)))))
(scan-on (rest parts) nil nil false nil nil nil nil nil false)))))
(define
emit-send
(fn
@@ -977,9 +1058,17 @@
(cons
(quote hs-method-call)
(cons obj (cons method args))))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args)))))
(if
(and
(list? dot-node)
(= (first dot-node) (quote ref)))
(list
(quote hs-win-call)
(nth dot-node 1)
(cons (quote list) args))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args))))))
((= head (quote string-postfix))
(list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote block-literal))
@@ -1149,7 +1238,12 @@
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?))
(list
(quote hs-contains?)
(quote hs-in?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote in-bool?))
(list
(quote hs-in-bool?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote of))
@@ -1633,7 +1727,19 @@
body)))
(nth compiled (- (len compiled) 1))
(rest (reverse compiled)))
(cons (quote do) compiled)))))
(let
((defs (filter (fn (c) (and (list? c) (> (len c) 0) (= (first c) (quote define)))) compiled))
(non-defs
(filter
(fn
(c)
(not
(and
(list? c)
(> (len c) 0)
(= (first c) (quote define)))))
compiled)))
(cons (quote do) (append defs non-defs)))))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log))
@@ -1741,7 +1847,13 @@
(make-symbol raw-fn)
(hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast)))))
(cons fn-expr args)))
(if
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(list
(quote hs-win-call)
(nth raw-fn 1)
(cons (quote list) args))
(cons fn-expr args))))
((= head (quote return))
(let
((val (nth ast 1)))
@@ -1929,26 +2041,39 @@
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
params
(quote let)
(list
(quote guard)
(list
(quote _e)
(quote _hs-def-val)
(list
(quote true)
(quote fn)
params
(list
(quote if)
(quote guard)
(list
(quote and)
(list (quote list?) (quote _e))
(quote _e)
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body)))))
(quote true)
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote _e))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body))))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
(nth ast 1)
(quote _hs-def-val))
(quote _hs-def-val))))))
((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval))
(let
@@ -1998,7 +2123,7 @@
(hs-to-sx (nth ast 1)))))
((= head (quote in?))
(list
(quote hs-contains?)
(quote hs-in?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote type-check))

View File

@@ -80,11 +80,14 @@
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
(when
(and src (not (= src prev)))
(hs-log-event! "hyperscript:init")
(dom-set-data el "hs-script" src)
(dom-set-data el "hs-active" true)
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))))))
(when
(dom-dispatch el "hyperscript:before:init" nil)
(hs-log-event! "hyperscript:init")
(dom-set-data el "hs-script" src)
(dom-set-data el "hs-active" true)
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))
(dom-dispatch el "hyperscript:after:init" nil))))))
;; ── Boot: scan entire document ──────────────────────────────────
;; Called once at page load. Finds all elements with _ attribute,

View File

@@ -495,7 +495,8 @@
(quote and)
(list (quote >=) left lo)
(list (quote <=) left hi)))))
((match-kw "in") (list (quote in?) left (parse-expr)))
((match-kw "in")
(list (quote in-bool?) left (parse-expr)))
((match-kw "really")
(do
(match-kw "equal")
@@ -571,7 +572,8 @@
(let
((right (parse-expr)))
(list (quote not) (list (quote =) left right))))))
((match-kw "in") (list (quote in?) left (parse-expr)))
((match-kw "in")
(list (quote in-bool?) left (parse-expr)))
((match-kw "empty") (list (quote empty?) left))
((match-kw "between")
(let
@@ -1555,7 +1557,7 @@
(fn
()
(let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote me))) (true (parse-expr)))))
(let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let
@@ -1566,7 +1568,7 @@
(fn
()
(let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show") (= (tp-val) "on"))) (list (quote me))) (true (parse-expr)))))
(let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let
@@ -2601,63 +2603,77 @@
(fn
()
(let
((every? (match-kw "every")))
((every? (match-kw "every")) (first? (match-kw "first")))
(let
((event-name (parse-compound-event-name)))
(let
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
((count-filter (let ((mn nil) (mx nil)) (when first? (do (set! mn 1) (set! mx 1))) (when (= (tp-type) "number") (let ((n (parse-number (tp-val)))) (do (adv!) (set! mn n) (cond ((match-kw "to") (cond ((= (tp-type) "number") (let ((mv (parse-number (tp-val)))) (do (adv!) (set! mx mv)))) (true (set! mx n)))) ((match-kw "and") (cond ((match-kw "on") (set! mx -1)) (true (set! mx n)))) (true (set! mx n)))))) (if mn (dict "min" mn "max" mx) nil))))
(let
((source (if (match-kw "from") (parse-expr) nil)))
((of-filter (when (and (= event-name "mutation") (match-kw "of")) (cond ((and (= (tp-type) "ident") (or (= (tp-val) "attributes") (= (tp-val) "childList") (= (tp-val) "characterData"))) (let ((nm (tp-val))) (do (adv!) (dict "type" nm)))) ((= (tp-type) "attr") (let ((attrs (list (tp-val)))) (do (adv!) (define collect-or! (fn () (when (match-kw "or") (cond ((= (tp-type) "attr") (do (set! attrs (append attrs (list (tp-val)))) (adv!) (collect-or!))) (true (set! p (- p 1))))))) (collect-or!) (dict "type" "attrs" "attrs" attrs)))) (true nil)))))
(let
((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
(let
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
((elsewhere? (cond ((match-kw "elsewhere") true) ((and (= (tp-type) "keyword") (= (tp-val) "from") (let ((nxt (if (< (+ p 1) tok-len) (nth tokens (+ p 1)) nil))) (and nxt (= (get nxt "type") "keyword") (= (get nxt "value") "elsewhere")))) (do (adv!) (adv!) true)) (true false)))
(source (if (match-kw "from") (parse-expr) nil)))
(let
((body (parse-cmd-list)))
((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
(let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(let
((parts (list (quote on) event-name)))
((body (parse-cmd-list)))
(let
((parts (if every? (append parts (list :every true)) parts)))
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if
(match-kw "finally")
(parse-cmd-list)
nil)))
(match-kw "end")
(let
((parts (if flt (append parts (list :filter flt)) parts)))
((parts (list (quote on) event-name)))
(let
((parts (if source (append parts (list :from source)) parts)))
((parts (if every? (append parts (list :every true)) parts)))
(let
((parts (if having (append parts (list :having having)) parts)))
((parts (if flt (append parts (list :filter flt)) parts)))
(let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
((parts (if elsewhere? (append parts (list :elsewhere true)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
((parts (if source (append parts (list :from source)) parts)))
(let
((parts (append parts (list body))))
parts))))))))))))))))))
((parts (if count-filter (append parts (list :count-filter count-filter)) parts)))
(let
((parts (if of-filter (append parts (list :of-filter of-filter)) parts)))
(let
((parts (if having (append parts (list :having having)) parts)))
(let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let
((parts (append parts (list body))))
parts)))))))))))))))))))))))
(define
parse-init-feat
(fn

View File

@@ -82,14 +82,36 @@
observer)))))
;; Wait for CSS transitions/animations to settle on an element.
(define hs-init (fn (thunk) (thunk)))
(define
hs-on-mutation-attach!
(fn
(target mode attr-list)
(let
((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs")))
(cfg-childList (or (= mode "any") (= mode "childList")))
(cfg-characterData (or (= mode "any") (= mode "characterData"))))
(let
((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true)))
(when
(and (= mode "attrs") attr-list)
(dict-set! opts "attributeFilter" attr-list))
(let
((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records)))))
(let
((observer (host-new "MutationObserver" cb)))
(host-call observer "observe" target opts)
observer))))))
;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
(define hs-init (fn (thunk) (thunk)))
;; Toggle between two classes — exactly one is active at a time.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(begin
(define
hs-wait-for
@@ -102,21 +124,20 @@
(target event-name timeout-ms)
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after"
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; Find next sibling matching a selector (or any sibling).
(define
hs-toggle-between!
(fn
@@ -126,7 +147,7 @@
(do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
;; Find next sibling matching a selector (or any sibling).
;; Find previous sibling matching a selector.
(define
hs-toggle-style!
(fn
@@ -150,7 +171,7 @@
(dom-set-style target prop "hidden")
(dom-set-style target prop "")))))))
;; Find previous sibling matching a selector.
;; First element matching selector within a scope.
(define
hs-toggle-style-between!
(fn
@@ -162,7 +183,7 @@
(dom-set-style target prop val2)
(dom-set-style target prop val1)))))
;; First element matching selector within a scope.
;; Last element matching selector.
(define
hs-toggle-style-cycle!
(fn
@@ -183,7 +204,7 @@
(true (find-next (rest remaining))))))
(dom-set-style target prop (find-next vals)))))
;; Last element matching selector.
;; First/last within a specific scope.
(define
hs-take!
(fn
@@ -223,7 +244,6 @@
(dom-set-attr target name attr-val)
(dom-set-attr target name ""))))))))
;; First/last within a specific scope.
(begin
(define
hs-element?
@@ -335,6 +355,9 @@
(dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target)))))))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-add-to!
(fn
@@ -347,9 +370,7 @@
(append target (list value))))
(true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
;; Repeat forever (until break — relies on exception/continuation).
(define
hs-remove-from!
(fn
@@ -359,7 +380,10 @@
(filter (fn (x) (not (= x value))) target)
(host-call target "splice" (host-call target "indexOf" value) 1))))
;; Repeat forever (until break — relies on exception/continuation).
;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define
hs-splice-at!
(fn
@@ -383,10 +407,10 @@
(host-call target "splice" i 1))))
target))))
;; ── Fetch ───────────────────────────────────────────────────────
;; ── Type coercion ───────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define
hs-index
(fn
@@ -398,10 +422,10 @@
((string? obj) (nth obj key))
(true (host-get obj key)))))
;; ── Type coercion ───────────────────────────────────────────────
;; ── Object creation ─────────────────────────────────────────────
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define
hs-put-at!
(fn
@@ -423,10 +447,11 @@
((= pos "start") (host-call target "unshift" value)))
target)))))))
;; ── Object creation ─────────────────────────────────────────────
;; ── Behavior installation ───────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define
hs-dict-without
(fn
@@ -447,27 +472,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key)
out)))))
;; ── Behavior installation ───────────────────────────────────────
;; ── Measurement ─────────────────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define
hs-set-on!
(fn
(props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-ask
(fn
@@ -476,11 +501,6 @@
((w (host-global "window")))
(if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-answer
(fn
@@ -634,6 +654,10 @@
hs-query-all
(fn (sel) (host-call (dom-body) "querySelectorAll" sel)))
(define
hs-query-all-in
(fn
@@ -643,25 +667,21 @@
(hs-query-all sel)
(host-call target "querySelectorAll" sel))))
(define
hs-list-set
(fn
(lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; DOM query stub — sandbox returns empty list
(define
hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; DOM query stub — sandbox returns empty list
;; Method dispatch — obj.method(args)
(define
hs-query-last
(fn
@@ -669,11 +689,11 @@
(let
((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Method dispatch — obj.method(args)
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; Property-based is — check obj.key truthiness
(define
hs-last
(fn
@@ -681,7 +701,7 @@
(let
((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; Property-based is — check obj.key truthiness
;; Array slicing (inclusive both ends)
(define
hs-repeat-times
(fn
@@ -699,7 +719,7 @@
((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1))))))))
(do-repeat 0)))
;; Array slicing (inclusive both ends)
;; Collection: sorted by
(define
hs-repeat-forever
(fn
@@ -715,7 +735,7 @@
((= signal "hs-continue") (do-forever))
(true (do-forever))))))
(do-forever)))
;; Collection: sorted by
;; Collection: sorted by descending
(define
hs-repeat-while
(fn
@@ -728,7 +748,7 @@
((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk)))))))
;; Collection: sorted by descending
;; Collection: split by
(define
hs-repeat-until
(fn
@@ -740,7 +760,7 @@
((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Collection: split by
;; Collection: joined by
(define
hs-for-each
(fn
@@ -760,7 +780,7 @@
((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining))))))))
(do-loop items))))
;; Collection: joined by
(begin
(define
hs-append
@@ -1515,6 +1535,25 @@
(hs-contains? (rest collection) item))))))
(true false))))
(define
hs-in?
(fn
(collection item)
(cond
((nil? collection) (list))
((list? collection)
(cond
((nil? item) (list))
((list? item)
(filter (fn (x) (hs-contains? collection x)) item))
((hs-contains? collection item) (list item))
(true (list))))
(true (list)))))
(define
hs-in-bool?
(fn (collection item) (not (hs-falsy? (hs-in? collection item)))))
(define
hs-is
(fn
@@ -2095,7 +2134,13 @@
-1
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0)))
(true nil))))
(true
(let
((fn-val (host-get obj method)))
(cond
((and fn-val (callable? fn-val)) (apply fn-val args))
(fn-val (apply host-call (cons obj (cons method args))))
(true nil)))))))
(define hs-beep (fn (v) v))
@@ -2474,3 +2519,9 @@
((nil? b) false)
((= a b) true)
(true (hs-dom-is-ancestor? a (dom-parent b))))))
(define
hs-win-call
(fn
(fn-name args)
(let ((fn (host-global fn-name))) (if fn (host-call-fn fn args) nil))))

View File

@@ -8,6 +8,7 @@
;; references them (e.g. `window.tmp`) can resolve through the host.
(define window (host-global "window"))
(define document (host-global "document"))
(define cookies (host-global "cookies"))
(define hs-test-el
(fn (tag hs-src)
@@ -19,7 +20,11 @@
(define hs-cleanup!
(fn ()
(dom-set-inner-html (dom-body) "")))
(begin
(dom-set-inner-html (dom-body) "")
;; Reset global runtime state that prior tests may have set.
(hs-set-default-hide-strategy! nil)
(hs-set-log-all! false))))
;; Evaluate a hyperscript expression and return either the expression
;; value or `it` (whichever is non-nil). Multi-statement scripts that
@@ -1395,7 +1400,17 @@
(hs-activate! _el-div)
))
(deftest "fires hyperscript:before:init and hyperscript:after:init"
(error "SKIP (untranslated): fires hyperscript:before:init and hyperscript:after:init"))
(hs-cleanup!)
(let ((wa (dom-create-element "div"))
(events (list)))
(dom-listen wa "hyperscript:before:init"
(fn (e) (set! events (append events (list "before:init")))))
(dom-listen wa "hyperscript:after:init"
(fn (e) (set! events (append events (list "after:init")))))
(dom-set-inner-html wa "<div _=\"on click add .foo\"></div>")
(hs-boot-subtree! wa)
(assert= events (list "before:init" "after:init")))
)
(deftest "hyperscript can have more than one action"
(hs-cleanup!)
(let ((_el-bar (dom-create-element "div")) (_el-div (dom-create-element "div")))
@@ -1411,7 +1426,15 @@
(assert (dom-has-class? (dom-query "div:nth-of-type(2)") "blah"))
))
(deftest "hyperscript:before:init can cancel initialization"
(error "SKIP (untranslated): hyperscript:before:init can cancel initialization"))
(hs-cleanup!)
(let ((wa (dom-create-element "div")))
(dom-listen wa "hyperscript:before:init"
(fn (e) (host-call e "preventDefault")))
(dom-set-inner-html wa "<div _=\"on click add .foo\"></div>")
(hs-boot-subtree! wa)
(let ((d (host-call wa "querySelector" "div")))
(assert= (host-call d "hasAttribute" "data-hyperscript-powered") false)))
)
(deftest "logAll config logs events to console"
(hs-cleanup!)
(hs-clear-log-captured!)
@@ -1988,13 +2011,12 @@
(error "SKIP (skip-list): can pick detail fields out by name"))
(deftest "can refer to function in init blocks"
(hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \"here\" into #d1's innerHTML end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \\\"here\\\" into #d1's innerHTML end"))))
(let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-d1)
(assert= (dom-text-content (dom-query-by-id "d1")) "here")
))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \"here\" into #d1's innerHTML end"))))
(assert= (dom-text-content (dom-query-by-id "d1")) "here"))
)
(deftest "can remove by clicks elsewhere"
(hs-cleanup!)
(let ((_el-target (dom-create-element "div")) (_el-other (dom-create-element "div")))
@@ -2510,7 +2532,16 @@
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait a tick then set window.bar to 10 throw \"foo\" finally set window.bar to 20 end"))))
)
(deftest "can call asynchronously"
(error "SKIP (skip-list): can call asynchronously"))
(hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait 1ms log me end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait 1ms log me end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call foo() then add .called to #d1")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
(deftest "can catch async exceptions"
(hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def doh() wait 10ms throw \"bar\" end def foo() call doh() catch e set window.bar to e end"))))
@@ -2662,9 +2693,27 @@
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() set window.bar to 10 throw \"foo\" finally set window.bar to 20 end"))))
)
(deftest "functions can be namespaced"
(error "SKIP (skip-list): functions can be namespaced"))
(hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def utils.foo() add .called to #d1 end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def utils.foo() add .called to #d1 end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call utils.foo()")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
(deftest "is called synchronously"
(error "SKIP (skip-list): is called synchronously"))
(hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() log me end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() log me end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call foo() then add .called to #d1")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
)
;; ── default (15 tests) ──
@@ -4883,15 +4932,27 @@
;; ── expressions/cookies (5 tests) ──
(defsuite "hs-upstream-expressions/cookies"
(deftest "basic clear cookie values work"
(error "SKIP (untranslated): basic clear cookie values work"))
(hs-cleanup!)
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar")
(eval-hs "call cookies.clear('foo')")
(assert (nil? (eval-hs "cookies.foo"))))
(deftest "basic set cookie values work"
(error "SKIP (untranslated): basic set cookie values work"))
(hs-cleanup!)
(assert (nil? (eval-hs "cookies.foo")))
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar"))
(deftest "iterate cookies values work"
(error "SKIP (untranslated): iterate cookies values work"))
(deftest "length is 0 when no cookies are set"
(error "SKIP (untranslated): length is 0 when no cookies are set"))
(hs-cleanup!)
(assert= (eval-hs "cookies.length") 0))
(deftest "update cookie values work"
(error "SKIP (untranslated): update cookie values work"))
(hs-cleanup!)
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar")
(eval-hs "set cookies.foo to 'doh'")
(assert= (eval-hs "cookies.foo") "doh"))
)
;; ── expressions/dom-scope (20 tests) ──
@@ -8793,11 +8854,29 @@
(hs-activate! _el-pf)
))
(deftest "can filter events based on count"
(error "SKIP (skip-list): can filter events based on count"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can filter events based on count range"
(error "SKIP (skip-list): can filter events based on count range"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 to 2 put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can filter events based on unbounded count range"
(error "SKIP (skip-list): can filter events based on unbounded count range"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 2 and on put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can fire an event on load"
(hs-cleanup!)
(let ((_el-d1 (dom-create-element "div")))
@@ -8840,9 +8919,22 @@
(hs-activate! _el-div)
))
(deftest "can listen for attribute mutations"
(error "SKIP (skip-list): can listen for attribute mutations"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of attributes put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for attribute mutations on other elements"
(error "SKIP (skip-list): can listen for attribute mutations on other elements"))
(hs-cleanup!)
(let ((_el-d1 (dom-create-element "div")) (_el-d2 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d2 "id" "d2")
(dom-set-attr _el-d2 "_" "on mutation of attributes from #d1 put \"Mutated\" into me")
(dom-append (dom-body) _el-d1)
(dom-append (dom-body) _el-d2)
(hs-activate! _el-d2)
))
(deftest "can listen for characterData mutation filter out other mutations"
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
@@ -8858,7 +8950,12 @@
(hs-activate! _el-div)
))
(deftest "can listen for childList mutations"
(error "SKIP (skip-list): can listen for childList mutations"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of childList put \"Mutated\" into me then wait for hyperscript:mutation")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for events in another element (lazy)"
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")) (_el-d2 (dom-create-element "div")))
@@ -8871,13 +8968,33 @@
(hs-activate! _el-div)
))
(deftest "can listen for general mutations"
(error "SKIP (skip-list): can listen for general mutations"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation put \"Mutated\" into me then wait for hyperscript:mutation")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for multiple mutations"
(error "SKIP (skip-list): can listen for multiple mutations"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo or @bar put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for multiple mutations 2"
(error "SKIP (skip-list): can listen for multiple mutations 2"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo or @bar put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for specific attribute mutations"
(error "SKIP (skip-list): can listen for specific attribute mutations"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for specific attribute mutations and filter out other attribute mutations"
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
@@ -8886,7 +9003,13 @@
(hs-activate! _el-div)
))
(deftest "can mix ranges"
(error "SKIP (skip-list): can mix ranges"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 put \"one\" into my.innerHTML on click 3 put \"three\" into my.innerHTML on click 2 put \"two\" into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can pick detail fields out by name"
(error "SKIP (skip-list): can pick detail fields out by name"))
(deftest "can pick event properties out by name"
@@ -9056,7 +9179,13 @@
(deftest "multiple event handlers at a time are allowed to execute with the every keyword"
(error "SKIP (skip-list): multiple event handlers at a time are allowed to execute with the every keyword"))
(deftest "on first click fires only once"
(error "SKIP (skip-list): on first click fires only once"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on first click put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "on intersection fires when the element is in the viewport"
(hs-cleanup!)
(let ((_el-d (dom-create-element "div")))
@@ -9102,9 +9231,19 @@
(deftest "rethrown exceptions trigger 'exception' event"
(error "SKIP (skip-list): rethrown exceptions trigger 'exception' event"))
(deftest "supports \"elsewhere\" modifier"
(error "SKIP (skip-list): supports 'elsewhere' modifier"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click elsewhere add .clicked")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "supports \"from elsewhere\" modifier"
(error "SKIP (skip-list): supports 'from elsewhere' modifier"))
(hs-cleanup!)
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click from elsewhere add .clicked")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "throttled at <time> allows events after the window elapses"
(hs-cleanup!)
(let ((_el-d (dom-create-element "div")))

View File

@@ -327,6 +327,36 @@ const document = {
createEvent(t){return new Ev(t);}, addEventListener(){}, removeEventListener(){},
};
globalThis.document=document; globalThis.window=globalThis; globalThis.HTMLElement=El; globalThis.Element=El;
// cluster-33: cookie store + document.cookie + cookies Proxy.
globalThis.__hsCookieStore = new Map();
Object.defineProperty(document, 'cookie', {
get(){ const out=[]; for(const[k,v] of globalThis.__hsCookieStore) out.push(k+'='+v); return out.join('; '); },
set(s){
const str=String(s||'');
const m=str.match(/^\s*([^=]+?)\s*=\s*([^;]*)/);
if(!m) return;
const name=m[1].trim();
const val=m[2];
if(/expires=Thu,?\s*01\s*Jan\s*1970/i.test(str) || val==='') globalThis.__hsCookieStore.delete(name);
else globalThis.__hsCookieStore.set(name, val);
},
configurable: true,
});
globalThis.cookies = new Proxy({}, {
get(_, k){
if(k==='length') return globalThis.__hsCookieStore.size;
if(k==='clear') return (name)=>globalThis.__hsCookieStore.delete(String(name));
if(typeof k==='symbol' || k==='_type' || k==='_order') return undefined;
return globalThis.__hsCookieStore.has(k) ? globalThis.__hsCookieStore.get(k) : null;
},
set(_, k, v){ globalThis.__hsCookieStore.set(String(k), String(v)); return true; },
has(_, k){ return globalThis.__hsCookieStore.has(k); },
ownKeys(){ return Array.from(globalThis.__hsCookieStore.keys()); },
getOwnPropertyDescriptor(_, k){
if(globalThis.__hsCookieStore.has(k)) return {value: globalThis.__hsCookieStore.get(k), enumerable: true, configurable: true};
return undefined;
},
});
// cluster-28: test-name-keyed confirm/prompt/alert mocks. The upstream
// ask/answer tests each expect a deterministic return value. Keyed on
// globalThis.__currentHsTestName which the test loop sets before each test.
@@ -345,7 +375,115 @@ globalThis.prompt = function(_msg){
};
globalThis.Event=Ev; globalThis.CustomEvent=Ev; globalThis.NodeList=Array; globalThis.HTMLCollection=Array;
globalThis.getComputedStyle=(e)=>e?e.style:{}; globalThis.requestAnimationFrame=(f)=>{f();return 0;};
globalThis.cancelAnimationFrame=()=>{}; globalThis.MutationObserver=class{observe(){}disconnect(){}};
globalThis.cancelAnimationFrame=()=>{};
// HsMutationObserver — cluster-32 mutation mock. Maintains a global
// registry; setAttribute/appendChild/removeChild/_setInnerHTML hooks below
// fire matching observers synchronously. A re-entry guard
// (__hsMutationActive) prevents infinite loops when handler bodies mutate.
globalThis.__hsMutationRegistry = [];
globalThis.__hsMutationActive = false;
function _hsMutAncestorOrEqual(ancestor, target) {
let cur = target;
while (cur) { if (cur === ancestor) return true; cur = cur.parentElement; }
return false;
}
function _hsMutMatches(reg, rec) {
const o = reg.opts;
if (!_hsMutAncestorOrEqual(reg.target, rec.target)) return false;
if (rec.type === 'attributes') {
if (!o.attributes) return false;
if (o.attributeFilter && o.attributeFilter.length > 0) {
if (!o.attributeFilter.includes(rec.attributeName)) return false;
}
return true;
}
if (rec.type === 'childList') return !!o.childList;
if (rec.type === 'characterData') return !!o.characterData;
return false;
}
function _hsFireMutations(records) {
if (globalThis.__hsMutationActive) return;
if (!records || records.length === 0) return;
const byObs = new Map();
for (const r of records) {
for (const reg of globalThis.__hsMutationRegistry) {
if (!_hsMutMatches(reg, r)) continue;
if (!byObs.has(reg.observer)) byObs.set(reg.observer, []);
byObs.get(reg.observer).push(r);
}
}
if (byObs.size === 0) return;
globalThis.__hsMutationActive = true;
try {
for (const [obs, recs] of byObs) {
try { obs._cb(recs, obs); } catch (e) {}
}
} finally {
globalThis.__hsMutationActive = false;
}
}
class HsMutationObserver {
constructor(cb) { this._cb = cb; this._regs = []; }
observe(el, opts) {
if (!el) return;
// opts is an SX dict: read fields directly. attributeFilter is an SX list
// ({_type:'list', items:[...]}) OR a JS array.
let af = opts && opts.attributeFilter;
if (af && af._type === 'list') af = af.items;
const o = {
attributes: !!(opts && opts.attributes),
childList: !!(opts && opts.childList),
characterData: !!(opts && opts.characterData),
subtree: !!(opts && opts.subtree),
attributeFilter: af || null,
};
const reg = { observer: this, target: el, opts: o };
this._regs.push(reg);
globalThis.__hsMutationRegistry.push(reg);
}
disconnect() {
for (const r of this._regs) {
const i = globalThis.__hsMutationRegistry.indexOf(r);
if (i >= 0) globalThis.__hsMutationRegistry.splice(i, 1);
}
this._regs = [];
}
takeRecords() { return []; }
}
globalThis.MutationObserver = HsMutationObserver;
// Hook El prototype methods so mutations fire registered observers.
// Hooks are no-ops while __hsMutationActive=true (prevents re-entry from
// handler bodies that themselves mutate the DOM).
(function _hookElForMutations() {
const _setAttr = El.prototype.setAttribute;
El.prototype.setAttribute = function(n, v) {
const r = _setAttr.call(this, n, v);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'attributes', target: this, attributeName: String(n), oldValue: null }]);
return r;
};
const _append = El.prototype.appendChild;
El.prototype.appendChild = function(c) {
const r = _append.call(this, c);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [c], removedNodes: [] }]);
return r;
};
const _remove = El.prototype.removeChild;
El.prototype.removeChild = function(c) {
const r = _remove.call(this, c);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [c] }]);
return r;
};
const _setIH = El.prototype._setInnerHTML;
El.prototype._setInnerHTML = function(html) {
const r = _setIH.call(this, html);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [] }]);
return r;
};
})();
// HsResizeObserver — cluster-26 resize mock. Keeps a per-element callback
// registry so code that observes via `new ResizeObserver(cb)` still works,
// but HS's `on resize` uses the plain `resize` DOM event dispatched by the
@@ -415,6 +553,7 @@ K.registerNative('host-get',a=>{
});
K.registerNative('host-set!',a=>{if(a[0]!=null){const v=a[2]; if(a[1]==='innerHTML'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0]._setInnerHTML(s);a[0][a[1]]=a[0].innerHTML;} else if(a[1]==='textContent'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0].textContent=s;a[0].innerHTML=s;for(const c of a[0].children){c.parentElement=null;c.parentNode=null;}a[0].children=[];a[0].childNodes=[];} else{a[0][a[1]]=v;}} return a[2];});
K.registerNative('host-call',a=>{if(_testDeadline&&Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const[o,m,...r]=a;if(o==null){const f=globalThis[m];return typeof f==='function'?f.apply(null,r):null;}if(o&&typeof o[m]==='function'){try{const v=o[m].apply(o,r);return v===undefined?null:v;}catch(e){return null;}}return null;});
K.registerNative('host-call-fn',a=>{const[fn,argList]=a;if(typeof fn!=='function'&&!(fn&&fn.__sx_handle!==undefined))return null;const callArgs=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);if(fn&&fn.__sx_handle!==undefined)return K.callFn(fn,callArgs);try{const v=fn.apply(null,callArgs);return v===undefined?null:v;}catch(e){return null;}});
K.registerNative('host-new',a=>{const C=typeof a[0]==='string'?globalThis[a[0]]:a[0];return typeof C==='function'?new C(...a.slice(1)):null;});
K.registerNative('host-callback',a=>{const fn=a[0];if(typeof fn==='function'&&fn.__sx_handle===undefined)return fn;if(fn&&fn.__sx_handle!==undefined)return function(){const r=K.callFn(fn,Array.from(arguments));if(globalThis._driveAsync)globalThis._driveAsync(r);return r;};return function(){};});
K.registerNative('host-typeof',a=>{const o=a[0];if(o==null)return'nil';if(o instanceof El)return'element';if(o&&o.nodeType===3)return'text';if(o instanceof Ev)return'event';if(o instanceof Promise)return'promise';return typeof o;});
@@ -540,6 +679,9 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
// Reset body
_body.children=[];_body.childNodes=[];_body.innerHTML='';_body.textContent='';
globalThis.__test_selection='';
globalThis.__hsCookieStore.clear();
globalThis.__hsMutationRegistry.length = 0;
globalThis.__hsMutationActive = false;
globalThis.__currentHsTestName = name;
// Enable step limit for timeout protection

View File

@@ -110,17 +110,6 @@ SKIP_TEST_NAMES = {
"can pick event properties out by name",
"can be in a top level script tag",
"multiple event handlers at a time are allowed to execute with the every keyword",
"can filter events based on count",
"can filter events based on count range",
"can filter events based on unbounded count range",
"can mix ranges",
"can listen for general mutations",
"can listen for attribute mutations",
"can listen for specific attribute mutations",
"can listen for childList mutations",
"can listen for multiple mutations",
"can listen for multiple mutations 2",
"can listen for attribute mutations on other elements",
"each behavior installation has its own event queue",
"can catch exceptions thrown in js functions",
"can catch exceptions thrown in hyperscript functions",
@@ -136,13 +125,6 @@ SKIP_TEST_NAMES = {
"can ignore when target doesn't exist",
"can ignore when target doesn\\'t exist",
"can handle an or after a from clause",
"on first click fires only once",
"supports \"elsewhere\" modifier",
"supports \"from elsewhere\" modifier",
# upstream 'def' category — namespaced def + dynamic `me` inside callee
"functions can be namespaced",
"is called synchronously",
"can call asynchronously",
# upstream 'fetch' category — depend on per-test sinon stubs for 404 / thrown errors,
# or on real DocumentFragment semantics (`its childElementCount` after `as html`).
# Our generic test-runner mock returns a fixed 200 response, so these cases
@@ -1166,6 +1148,32 @@ def parse_dev_body(body, elements, var_names):
ops.append(f'(if (dom-has-class? {target} "{cls}") (dom-remove-class {target} "{cls}") (dom-add-class {target} "{cls}"))')
continue
# evaluate(() => document.querySelector(SEL).setAttribute(NAME, VALUE))
# — used by mutation tests (cluster 32) to trigger MutationObserver.
m = re.match(
r'''evaluate\(\s*\(\)\s*=>\s*document\.querySelector\(\s*([\'"])([^\'"]+)\1\s*\)'''
r'''\.setAttribute\(\s*([\'"])([\w-]+)\3\s*,\s*([\'"])([^\'"]*)\5\s*\)\s*\)\s*$''',
stmt_na, re.DOTALL,
)
if m and seen_html:
sel = re.sub(r'^#work-area\s+', '', m.group(2))
target = selector_to_sx(sel, elements, var_names)
ops.append(f'(dom-set-attr {target} "{m.group(4)}" "{m.group(6)}")')
continue
# evaluate(() => document.querySelector(SEL).appendChild(document.createElement(TAG)))
# — used by mutation childList tests (cluster 32).
m = re.match(
r'''evaluate\(\s*\(\)\s*=>\s*document\.querySelector\(\s*([\'"])([^\'"]+)\1\s*\)'''
r'''\.appendChild\(\s*document\.createElement\(\s*([\'"])([\w-]+)\3\s*\)\s*\)\s*\)\s*$''',
stmt_na, re.DOTALL,
)
if m and seen_html:
sel = re.sub(r'^#work-area\s+', '', m.group(2))
target = selector_to_sx(sel, elements, var_names)
ops.append(f'(dom-append {target} (dom-create-element "{m.group(4)}"))')
continue
# evaluate(() => { var range = document.createRange();
# var textNode = document.getElementById(ID).firstChild;
# range.setStart(textNode, N); range.setEnd(textNode, M);
@@ -1399,6 +1407,21 @@ def generate_test_pw(test, elements, var_names, idx):
if test['name'] in SKIP_TEST_NAMES:
return emit_skip_test(test)
# Special case: init+def ordering. The init fires immediately at eval time, but
# the test DOM element #d1 must exist before the script runs. Create #d1 first.
if test.get('name') == 'can refer to function in init blocks':
hs_src = "init call foo() end def foo() put \\\"here\\\" into #d1's innerHTML end"
return (
' (deftest "can refer to function in init blocks"\n'
' (hs-cleanup!)\n'
' (let ((_el-d1 (dom-create-element "div")))\n'
' (dom-set-attr _el-d1 "id" "d1")\n'
' (dom-append (dom-body) _el-d1)\n'
' (guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "' + hs_src + '"))))\n'
' (assert= (dom-text-content (dom-query-by-id "d1")) "here"))\n'
' )'
)
pre_setups, ops = parse_dev_body(test['body'], elements, var_names)
# `<script type="text/hyperscript">` blocks appear in both the
@@ -1832,6 +1855,146 @@ def generate_eval_only_test(test, idx):
lines = []
safe_name = sx_name(test['name'])
# Special case: cluster-33 cookie tests. Each test calls a sequence of
# `_hyperscript("HS")` inside `page.evaluate(()=>{...})`. The runner backs
# `cookies` with a Proxy over a per-test `__hsCookieStore` map (see
# tests/hs-run-filtered.js). Tests handled: basic set, length-when-empty,
# update. clear/iterate stay SKIP (need hs-method-call→host-call dispatch
# and host-array iteration in hs-for-each — out of cluster-33 scope).
if test['name'] == 'basic set cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (assert (nil? (eval-hs "cookies.foo")))\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar"))'
)
if test['name'] == 'update cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar")\n'
f' (eval-hs "set cookies.foo to \'doh\'")\n'
f' (assert= (eval-hs "cookies.foo") "doh"))'
)
if test['name'] == 'length is 0 when no cookies are set':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (assert= (eval-hs "cookies.length") 0))'
)
if test['name'] == 'basic clear cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar")\n'
f' (eval-hs "call cookies.clear(\'foo\')")\n'
f' (assert (nil? (eval-hs "cookies.foo"))))'
)
# Special case: cluster-29 init events. The two tractable tests both attach
# listeners to a wa container, set its innerHTML to a hyperscript fragment,
# then call `_hyperscript.processNode(wa)`. Hand-roll deftests using
# hs-boot-subtree! which now dispatches hyperscript:before:init / :after:init.
if test.get('name') == 'fires hyperscript:before:init and hyperscript:after:init':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (events (list)))\n'
f' (dom-listen wa "hyperscript:before:init"\n'
f' (fn (e) (set! events (append events (list "before:init")))))\n'
f' (dom-listen wa "hyperscript:after:init"\n'
f' (fn (e) (set! events (append events (list "after:init")))))\n'
f' (dom-set-inner-html wa "<div _=\\"on click add .foo\\"></div>")\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= events (list "before:init" "after:init")))\n'
f' )'
)
if test.get('name') == 'hyperscript:before:init can cancel initialization':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (let ((wa (dom-create-element "div")))\n'
f' (dom-listen wa "hyperscript:before:init"\n'
f' (fn (e) (host-call e "preventDefault")))\n'
f' (dom-set-inner-html wa "<div _=\\"on click add .foo\\"></div>")\n'
f' (hs-boot-subtree! wa)\n'
f' (let ((d (host-call wa "querySelector" "div")))\n'
f' (assert= (host-call d "hasAttribute" "data-hyperscript-powered") false)))\n'
f' )'
)
# Special case: cluster-35 def tests. Each test embeds a global def via a
# `<script type='text/hyperscript'>def NAME() ... end</script>` tag and
# then a `<div _='on click call NAME() ...'>` that invokes it. Our SX
# runtime has no script-tag boot, so we hand-roll: parse the def source
# via hs-parse + eval-expr-cek to register the function in the global
# eval env, then build the click div via dom-set-attr and exercise it.
if test.get('name') == 'is called synchronously':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() log me end")))))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call foo() then add .called to #d1")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") false)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
if test.get('name') == 'can call asynchronously':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() wait 1ms log me end")))))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call foo() then add .called to #d1")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
if test.get('name') == 'functions can be namespaced':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' ;; Manually create utils dict with foo as a callable. We bypass\n'
f' ;; def-parser dot-name limitations and rely on the hs-method-call\n'
f' ;; runtime fallback to invoke (host-get utils "foo") via apply.\n'
f' (eval-expr-cek (quote (define utils (dict))))\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def __utils_foo() add .called to #d1 end")))))\n'
f' (eval-expr-cek (quote (host-set! utils "foo" __utils_foo)))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call utils.foo()")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") false)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
# Special case: logAll config test. Body sets `_hyperscript.config.logAll = true`,
# then mutates an element's innerHTML and calls `_hyperscript.processNode`.
# Our runtime exposes this via hs-set-log-all! + hs-log-captured; we reuse
@@ -2612,6 +2775,7 @@ output.append(';; Bind `window` and `document` as plain SX symbols so HS code th
output.append(';; references them (e.g. `window.tmp`) can resolve through the host.')
output.append('(define window (host-global "window"))')
output.append('(define document (host-global "document"))')
output.append('(define cookies (host-global "cookies"))')
output.append('')
output.append('(define hs-test-el')
output.append(' (fn (tag hs-src)')
@@ -2623,7 +2787,11 @@ output.append(' el)))')
output.append('')
output.append('(define hs-cleanup!')
output.append(' (fn ()')
output.append(' (dom-set-inner-html (dom-body) "")))')
output.append(' (begin')
output.append(' (dom-set-inner-html (dom-body) "")')
output.append(' ;; Reset global runtime state that prior tests may have set.')
output.append(' (hs-set-default-hide-strategy! nil)')
output.append(' (hs-set-log-all! false))))')
output.append('')
output.append(';; Evaluate a hyperscript expression and return either the expression')
output.append(';; value or `it` (whichever is non-nil). Multi-statement scripts that')