16 Commits

Author SHA1 Message Date
373d57cbcb prolog: assert/asserta/assertz/retract for facts, 11 tests
Some checks are pending
Test, Build, and Deploy / test-build-deploy (push) Waiting to run
2026-04-25 07:32:09 +00:00
3190e770fb prolog: operator-table parser + < > =< >= built-ins, 19 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 06:57:48 +00:00
e018ba9423 prolog: conformance.sh + scoreboard.{json,md}, 183/183 baseline
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 06:19:54 +00:00
09683b8a18 prolog: family.pl + family.sx, 10 tests; 5/5 classic programs done
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 05:52:28 +00:00
64e3b3f44e prolog: nqueens.pl + nqueens.sx (N=1..5), 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 05:24:49 +00:00
1302f5a3cc prolog: member.pl + member.sx generator, 7 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 04:54:32 +00:00
93b31b6c8a prolog: reverse.pl + reverse.sx (naive via append), 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 04:26:20 +00:00
ffc3716b0e prolog: append.pl + append.sx classic, 6 tests (build/check/split/deduce)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 03:58:12 +00:00
7fb4c52159 prolog: is/2 arithmetic with + - * / mod abs, 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 03:27:56 +00:00
072735a6de prolog: write/1 + nl/0 via output buffer, 7 tests; built-ins box done
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 02:56:31 +00:00
1846be0bd8 prolog: ->/2 if-then-else (in ; and standalone), 9 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 02:23:44 +00:00
3adad8e50e prolog: \=/2 + ;/2 + call/1 built-ins, 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 01:48:57 +00:00
f019d42727 prolog: cut !/0 with two-cut-box barrier scheme, 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 01:14:12 +00:00
738f44e47d prolog: DFS solver (CPS, trail-based) + true/fail/=/conj built-ins, 18 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 00:38:50 +00:00
1888c272f9 prolog: clause DB + loader (functor/arity → clauses), 14 tests green
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-24 23:59:46 +00:00
60b7f0d7bb prolog: tick phase 1+2 boxes (parse 25/25, unify 47/47 green)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-24 16:58:30 +00:00
22 changed files with 2476 additions and 110 deletions

108
lib/prolog/conformance.sh Executable file
View File

@@ -0,0 +1,108 @@
#!/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!"
"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!"
)
SCRIPT='(epoch 1)
(load "lib/prolog/tokenizer.sx")
(load "lib/prolog/parser.sx")
(load "lib/prolog/runtime.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,28 +1,20 @@
;; lib/prolog/parser.sx — tokens → Prolog AST ;; lib/prolog/parser.sx — tokens → Prolog AST
;; ;;
;; Phase 1 grammar (NO operator table yet): ;; Phase 4 grammar (with operator table):
;; Program := Clause* EOF ;; Program := Clause* EOF
;; Clause := Term "." | Term ":-" Term "." ;; Clause := Term[999] "." | Term[999] ":-" Term[1200] "."
;; Term := Atom | Var | Number | String | Compound | List ;; Term[Pmax] uses precedence climbing on the operator table:
;; Compound := atom "(" ArgList ")" ;; primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
;; ArgList := Term ("," Term)* ;; while next token is infix op `op` with prec(op) ≤ Pmax:
;; List := "[" "]" | "[" Term ("," Term)* ("|" Term)? "]" ;; consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
;; ;;
;; Term AST shapes (all tagged lists for uniform dispatch): ;; Op type → right-prec for op at precedence P:
;; ("atom" name) — atom ;; xfx → P-1 strict-both
;; ("var" name) — variable template (parser-time only) ;; xfy → P right-associative
;; ("num" value) — integer or float ;; yfx → P-1 left-associative
;; ("str" value) — string literal
;; ("compound" functor args) — compound term, args is list of term-ASTs
;; ("cut") — the cut atom !
;; ;;
;; A clause is (list "clause" head body). A fact is head with body = ("atom" "true"). ;; AST shapes are unchanged — operators just become compound terms.
;;
;; 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 (define
pp-peek pp-peek
(fn (fn
@@ -66,7 +58,6 @@
(if (= (get t :value) nil) "" (get t :value)) (if (= (get t :value) nil) "" (get t :value))
"'")))))) "'"))))))
;; ── AST constructors ────────────────────────────────────────────────
(define pl-mk-atom (fn (name) (list "atom" name))) (define pl-mk-atom (fn (name) (list "atom" name)))
(define pl-mk-var (fn (name) (list "var" name))) (define pl-mk-var (fn (name) (list "var" name)))
(define pl-mk-num (fn (n) (list "num" n))) (define pl-mk-num (fn (n) (list "num" n)))
@@ -74,18 +65,14 @@
(define pl-mk-compound (fn (f args) (list "compound" f args))) (define pl-mk-compound (fn (f args) (list "compound" f args)))
(define pl-mk-cut (fn () (list "cut"))) (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-tag (fn (t) (if (list? t) (first t) nil)))
(define pl-term-val (fn (t) (nth t 1))) (define pl-term-val (fn (t) (nth t 1)))
(define pl-compound-functor (fn (t) (nth t 1))) (define pl-compound-functor (fn (t) (nth t 1)))
(define pl-compound-args (fn (t) (nth t 2))) (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-nil-term (fn () (pl-mk-atom "[]")))
(define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t)))) (define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))
;; Build cons list from a list of terms + optional tail
(define (define
pl-mk-list-term pl-mk-list-term
(fn (fn
@@ -95,9 +82,60 @@
tail tail
(pl-mk-cons (first items) (pl-mk-list-term (rest items) tail))))) (pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))
;; ── Term parser ───────────────────────────────────────────────────── ;; ── Operator table (Phase 4) ──────────────────────────────────────
;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
(define (define
pp-parse-term 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 "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))))
((= ty "atom")
(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
(fn (fn
(st) (st)
(let (let
@@ -111,6 +149,12 @@
((and (= ty "op") (= vv "!")) ((and (= ty "op") (= vv "!"))
(do (pp-advance! st) (pl-mk-cut))) (do (pp-advance! st) (pl-mk-cut)))
((and (= ty "punct") (= vv "[")) (pp-parse-list st)) ((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") ((= ty "atom")
(do (do
(pp-advance! st) (pp-advance! st)
@@ -133,13 +177,51 @@
(if (= vv nil) "" vv) (if (= vv nil) "" vv)
"'")))))))) "'"))))))))
;; Parse one or more comma-separated terms (arguments). ;; 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.
(define (define
pp-parse-arg-list pp-parse-arg-list
(fn (fn
(st) (st)
(let (let
((first-arg (pp-parse-term st)) (args (list))) ((first-arg (pp-parse-term-prec st 999)) (args (list)))
(do (do
(append! args first-arg) (append! args first-arg)
(define (define
@@ -150,12 +232,12 @@
(pp-at? st "punct" ",") (pp-at? st "punct" ",")
(do (do
(pp-advance! st) (pp-advance! st)
(append! args (pp-parse-term st)) (append! args (pp-parse-term-prec st 999))
(loop))))) (loop)))))
(loop) (loop)
args)))) args))))
;; Parse a [ ... ] list literal. Consumes the "[". ;; List literal.
(define (define
pp-parse-list pp-parse-list
(fn (fn
@@ -168,7 +250,7 @@
(let (let
((items (list))) ((items (list)))
(do (do
(append! items (pp-parse-term st)) (append! items (pp-parse-term-prec st 999))
(define (define
comma-loop comma-loop
(fn (fn
@@ -177,52 +259,17 @@
(pp-at? st "punct" ",") (pp-at? st "punct" ",")
(do (do
(pp-advance! st) (pp-advance! st)
(append! items (pp-parse-term st)) (append! items (pp-parse-term-prec st 999))
(comma-loop))))) (comma-loop)))))
(comma-loop) (comma-loop)
(let (let
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term st)) (pl-nil-term)))) ((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
(do (pp-expect! st "punct" "]") (pl-mk-list-term items tail))))))))) (do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))
;; ── Body parsing ──────────────────────────────────────────────────── ;; ── Body parsing ────────────────────────────────────────────────────
;; A clause body is a comma-separated list of goals. We flatten into a ;; A body is a single term parsed at prec 1200 — operator parser folds
;; right-associative `,` compound: (A, B, C) → ','(A, ','(B, C)) ;; `,`, `;`, `->` automatically into right-associative compounds.
;; If only one goal, it's that goal directly. (define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))
(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 ────────────────────────────────────────────────── ;; ── Clause parsing ──────────────────────────────────────────────────
(define (define
@@ -230,12 +277,11 @@
(fn (fn
(st) (st)
(let (let
((head (pp-parse-term st))) ((head (pp-parse-term-prec st 999)))
(let (let
((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true")))) ((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)))))) (do (pp-expect! st "punct" ".") (list "clause" head body))))))
;; Parse an entire program — returns list of clauses.
(define (define
pl-parse-program pl-parse-program
(fn (fn
@@ -253,13 +299,9 @@
(ploop) (ploop)
clauses)))) clauses))))
;; Parse a single query term (no trailing "."). Returns the term.
(define (define
pl-parse-query pl-parse-query
(fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st)))) (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)))) (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)))) (define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))

View File

@@ -98,6 +98,11 @@
"compound" "compound"
fun fun
(map (fn (a) (pl-instantiate a var-env)) args)))) (map (fn (a) (pl-instantiate a var-env)) args))))
((= (first ast) "clause")
(let
((h (pl-instantiate (nth ast 1) var-env))
(b (pl-instantiate (nth ast 2) var-env)))
(list "clause" h b)))
(true ast)))) (true ast))))
(define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {}))) (define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {})))
@@ -230,3 +235,499 @@
(pl-unify! t1 t2 trail) (pl-unify! t1 t2 trail)
true true
(do (pl-trail-undo-to! trail mark) false))))) (do (pl-trail-undo-to! trail mark) false)))))
(define pl-mk-db (fn () {:clauses {}}))
(define
pl-head-key
(fn
(head)
(cond
((pl-compound? head) (str (pl-fun head) "/" (len (pl-args head))))
((pl-atom? head) (str (pl-atom-name head) "/0"))
(true (error "pl-head-key: invalid head")))))
(define pl-clause-key (fn (clause) (pl-head-key (nth clause 1))))
(define pl-goal-key (fn (goal) (pl-head-key goal)))
(define
pl-db-add!
(fn
(db clause)
(let
((key (pl-clause-key clause)) (table (dict-get db :clauses)))
(cond
((nil? (dict-get table key)) (dict-set! table key (list clause)))
(true (begin (append! (dict-get table key) clause) nil))))))
(define
pl-db-load!
(fn
(db program)
(cond
((empty? program) nil)
(true
(begin
(pl-db-add! db (first program))
(pl-db-load! db (rest program)))))))
(define
pl-db-lookup
(fn
(db key)
(let
((v (dict-get (dict-get db :clauses) key)))
(cond ((nil? v) (list)) (true v)))))
(define
pl-db-lookup-goal
(fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
(define
pl-rt-walk-to-ast
(fn
(w)
(cond
((pl-var? w) (list "var" (str "_G" (pl-var-id w))))
((and (list? w) (not (empty? w)) (= (first w) "compound"))
(list "compound" (nth w 1) (map pl-rt-walk-to-ast (nth w 2))))
(true w))))
(define pl-rt-to-ast (fn (t) (pl-rt-walk-to-ast (pl-walk-deep t))))
(define
pl-build-clause
(fn
(ast)
(cond
((and (list? ast) (= (first ast) "compound") (= (nth ast 1) ":-") (= (len (nth ast 2)) 2))
(list "clause" (first (nth ast 2)) (nth (nth ast 2) 1)))
(true (list "clause" ast (list "atom" "true"))))))
(define
pl-db-prepend!
(fn
(db clause)
(let
((key (pl-clause-key clause)) (table (dict-get db :clauses)))
(cond
((nil? (dict-get table key)) (dict-set! table key (list clause)))
(true (dict-set! table key (cons clause (dict-get table key))))))))
(define
pl-list-without
(fn
(lst i)
(cond
((empty? lst) (list))
((= i 0) (rest lst))
(true (cons (first lst) (pl-list-without (rest lst) (- i 1)))))))
(define
pl-solve-assertz!
(fn
(db term k)
(begin (pl-db-add! db (pl-build-clause (pl-rt-to-ast term))) (k))))
(define
pl-solve-asserta!
(fn
(db term k)
(begin (pl-db-prepend! db (pl-build-clause (pl-rt-to-ast term))) (k))))
(define
pl-solve-retract!
(fn
(db term trail k)
(let
((head-runtime (cond ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) (first (pl-args term))) (true term)))
(body-runtime
(cond
((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2))
(nth (pl-args term) 1))
(true (list "atom" "true")))))
(let
((wh (pl-walk head-runtime)))
(cond
((pl-var? wh) false)
(true
(let
((key (pl-head-key wh)))
(pl-retract-try-each
db
key
(pl-db-lookup db key)
head-runtime
body-runtime
0
trail
k))))))))
(define
pl-retract-try-each
(fn
(db key remaining head-rt body-rt idx trail k)
(cond
((empty? remaining) false)
(true
(let
((mark (pl-trail-mark trail))
(cl (pl-instantiate-fresh (first remaining))))
(cond
((and (pl-unify! head-rt (nth cl 1) trail) (pl-unify! body-rt (nth cl 2) trail))
(begin
(let
((all (pl-db-lookup db key)))
(dict-set!
(dict-get db :clauses)
key
(pl-list-without all idx)))
(let
((r (k)))
(cond
(r true)
(true (begin (pl-trail-undo-to! trail mark) false))))))
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-retract-try-each
db
key
(rest remaining)
head-rt
body-rt
(+ idx 1)
trail
k)))))))))
(define
pl-cut?
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
(define
pl-solve!
(fn
(db goal trail cut-box k)
(let
((g (pl-walk goal)))
(cond
((pl-var? g) false)
((pl-cut? g) (begin (dict-set! cut-box :cut true) (k)))
((and (pl-atom? g) (= (pl-atom-name g) "true")) (k))
((and (pl-atom? g) (= (pl-atom-name g) "fail")) false)
((and (pl-atom? g) (= (pl-atom-name g) "nl"))
(begin (pl-output-write! "\n") (k)))
((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2))
(pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k))
((and (pl-compound? g) (= (pl-fun g) "\\=") (= (len (pl-args g)) 2))
(pl-solve-not-eq!
(first (pl-args g))
(nth (pl-args g) 1)
trail
k))
((and (pl-compound? g) (= (pl-fun g) "is") (= (len (pl-args g)) 2))
(pl-solve-eq!
(first (pl-args g))
(list "num" (pl-eval-arith (nth (pl-args g) 1)))
trail
k))
((and (pl-compound? g) (= (pl-fun g) "<") (= (len (pl-args g)) 2))
(cond
((< (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
(k))
(true false)))
((and (pl-compound? g) (= (pl-fun g) ">") (= (len (pl-args g)) 2))
(cond
((> (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
(k))
(true false)))
((and (pl-compound? g) (= (pl-fun g) "=<") (= (len (pl-args g)) 2))
(cond
((<= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
(k))
(true false)))
((and (pl-compound? g) (= (pl-fun g) ">=") (= (len (pl-args g)) 2))
(cond
((>= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
(k))
(true false)))
((and (pl-compound? g) (= (pl-fun g) ",") (= (len (pl-args g)) 2))
(pl-solve!
db
(first (pl-args g))
trail
cut-box
(fn () (pl-solve! db (nth (pl-args g) 1) trail cut-box k))))
((and (pl-compound? g) (= (pl-fun g) ";") (= (len (pl-args g)) 2))
(pl-solve-or!
db
(first (pl-args g))
(nth (pl-args g) 1)
trail
cut-box
k))
((and (pl-compound? g) (= (pl-fun g) "->") (= (len (pl-args g)) 2))
(pl-solve-if-then-else!
db
(first (pl-args g))
(nth (pl-args g) 1)
(list "atom" "fail")
trail
cut-box
k))
((and (pl-compound? g) (= (pl-fun g) "call") (= (len (pl-args g)) 1))
(let
((call-cb {:cut false}))
(pl-solve! db (first (pl-args g)) trail call-cb k)))
((and (pl-compound? g) (= (pl-fun g) "write") (= (len (pl-args g)) 1))
(begin
(pl-output-write! (pl-format-term (first (pl-args g))))
(k)))
((and (pl-compound? g) (= (pl-fun g) "assertz") (= (len (pl-args g)) 1))
(pl-solve-assertz! db (first (pl-args g)) k))
((and (pl-compound? g) (= (pl-fun g) "assert") (= (len (pl-args g)) 1))
(pl-solve-assertz! db (first (pl-args g)) k))
((and (pl-compound? g) (= (pl-fun g) "asserta") (= (len (pl-args g)) 1))
(pl-solve-asserta! db (first (pl-args g)) k))
((and (pl-compound? g) (= (pl-fun g) "retract") (= (len (pl-args g)) 1))
(pl-solve-retract! db (first (pl-args g)) trail k))
(true (pl-solve-user! db g trail cut-box k))))))
(define
pl-solve-or!
(fn
(db a b trail cut-box k)
(cond
((and (pl-compound? a) (= (pl-fun a) "->") (= (len (pl-args a)) 2))
(pl-solve-if-then-else!
db
(first (pl-args a))
(nth (pl-args a) 1)
b
trail
cut-box
k))
(true
(let
((mark (pl-trail-mark trail)))
(let
((r (pl-solve! db a trail cut-box k)))
(cond
(r true)
((dict-get cut-box :cut) false)
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-solve! db b trail cut-box k))))))))))
(define
pl-solve-if-then-else!
(fn
(db cond-goal then-goal else-goal trail cut-box k)
(let
((mark (pl-trail-mark trail)))
(let
((local-cb {:cut false}))
(let
((found {:val false}))
(pl-solve!
db
cond-goal
trail
local-cb
(fn () (begin (dict-set! found :val true) true)))
(cond
((dict-get found :val) (pl-solve! db then-goal trail cut-box k))
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-solve! db else-goal trail cut-box k)))))))))
(define pl-output-buffer "")
(define pl-output-clear! (fn () (set! pl-output-buffer "")))
(define
pl-output-write!
(fn (s) (begin (set! pl-output-buffer (str pl-output-buffer s)) nil)))
(define
pl-format-args
(fn
(args)
(cond
((empty? args) "")
((= (len args) 1) (pl-format-term (first args)))
(true
(str
(pl-format-term (first args))
", "
(pl-format-args (rest args)))))))
(define
pl-format-term
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((pl-var? w) (str "_" (pl-var-id w)))
((pl-atom? w) (pl-atom-name w))
((pl-num? w) (str (pl-num-val w)))
((pl-str? w) (pl-str-val w))
((pl-compound? w)
(str (pl-fun w) "(" (pl-format-args (pl-args w)) ")"))
(true (str w))))))
(define
pl-eval-arith
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((pl-num? w) (pl-num-val w))
((pl-compound? w)
(let
((f (pl-fun w)) (args (pl-args w)))
(cond
((and (= f "+") (= (len args) 2))
(+
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "-") (= (len args) 2))
(-
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "-") (= (len args) 1))
(- 0 (pl-eval-arith (first args))))
((and (= f "*") (= (len args) 2))
(*
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "/") (= (len args) 2))
(/
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "mod") (= (len args) 2))
(mod
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "abs") (= (len args) 1))
(let
((v (pl-eval-arith (first args))))
(cond ((< v 0) (- 0 v)) (true v))))
(true 0))))
(true 0)))))
(define
pl-solve-not-eq!
(fn
(a b trail k)
(let
((mark (pl-trail-mark trail)))
(let
((unified (pl-unify! a b trail)))
(begin
(pl-trail-undo-to! trail mark)
(cond (unified false) (true (k))))))))
(define
pl-solve-eq!
(fn
(a b trail k)
(let
((mark (pl-trail-mark trail)))
(cond
((pl-unify! a b trail)
(let
((r (k)))
(cond
(r true)
(true (begin (pl-trail-undo-to! trail mark) false)))))
(true (begin (pl-trail-undo-to! trail mark) false))))))
(define
pl-solve-user!
(fn
(db goal trail outer-cut-box k)
(let
((inner-cut-box {:cut false}))
(let
((outer-was-cut (dict-get outer-cut-box :cut)))
(pl-try-clauses!
db
goal
trail
(pl-db-lookup-goal db goal)
outer-cut-box
outer-was-cut
inner-cut-box
k)))))
(define
pl-try-clauses!
(fn
(db goal trail clauses outer-cut-box outer-was-cut inner-cut-box k)
(cond
((empty? clauses) false)
(true
(let
((mark (pl-trail-mark trail)))
(let
((clause (pl-instantiate-fresh (first clauses))))
(let
((head (nth clause 1)) (body (nth clause 2)))
(cond
((pl-unify! goal head trail)
(let
((r (pl-solve! db body trail inner-cut-box k)))
(cond
(r true)
((dict-get inner-cut-box :cut)
(begin (pl-trail-undo-to! trail mark) false))
((and (not outer-was-cut) (dict-get outer-cut-box :cut))
(begin (pl-trail-undo-to! trail mark) false))
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-try-clauses!
db
goal
trail
(rest clauses)
outer-cut-box
outer-was-cut
inner-cut-box
k))))))
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-try-clauses!
db
goal
trail
(rest clauses)
outer-cut-box
outer-was-cut
inner-cut-box
k)))))))))))
(define
pl-solve-once!
(fn (db goal trail) (pl-solve! db goal trail {:cut false} (fn () true))))
(define
pl-solve-count!
(fn
(db goal trail)
(let
((box {:n 0}))
(pl-solve!
db
goal
trail
{:cut false}
(fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
(dict-get box :n))))

View File

@@ -0,0 +1,7 @@
{
"total_passed": 213,
"total_failed": 0,
"total": 213,
"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},"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}},
"generated": "2026-04-25T07:31:46+00:00"
}

21
lib/prolog/scoreboard.md Normal file
View File

@@ -0,0 +1,21 @@
# Prolog scoreboard
**213 / 213 passing** (0 failure(s)).
Generated 2026-04-25T07:31:46+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 |
| append | 6 | 6 | ok |
| reverse | 6 | 6 | ok |
| member | 7 | 7 | ok |
| nqueens | 6 | 6 | ok |
| family | 10 | 10 | ok |
Run `bash lib/prolog/conformance.sh` to refresh. Override the binary
with `SX_SERVER=path/to/sx_server.exe bash …`.

View File

@@ -0,0 +1,99 @@
;; 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}))

158
lib/prolog/tests/dynamic.sx Normal file
View File

@@ -0,0 +1,158 @@
;; 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

@@ -0,0 +1,193 @@
;; 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

@@ -0,0 +1,5 @@
%% 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

@@ -0,0 +1,114 @@
;; 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

@@ -0,0 +1,24 @@
%% 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

@@ -0,0 +1,116 @@
;; 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

@@ -0,0 +1,4 @@
%% 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

@@ -0,0 +1,91 @@
;; 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

@@ -0,0 +1,27 @@
%% 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

@@ -0,0 +1,108 @@
;; 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

@@ -0,0 +1,7 @@
%% 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

@@ -0,0 +1,113 @@
;; 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}))

618
lib/prolog/tests/solve.sx Normal file
View File

@@ -0,0 +1,618 @@
;; 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

@@ -7,7 +7,7 @@ Baseline: 1213/1496 (81.1%)
Merged: 1277/1496 (85.4%) delta +64 Merged: 1277/1496 (85.4%) delta +64
Worktree: all landed Worktree: all landed
Target: 1496/1496 (100.0%) Target: 1496/1496 (100.0%)
Remaining: ~219 tests (clusters 17/22/29/31/32 blocked; 31/32 need dedicated sx-tree worktree) Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
``` ```
## Cluster ledger ## Cluster ledger
@@ -61,8 +61,8 @@ Remaining: ~219 tests (clusters 17/22/29/31/32 blocked; 31/32 need dedicated sx
| # | Cluster | Status | Δ | | # | Cluster | Status | Δ |
|---|---------|--------|---| |---|---------|--------|---|
| 31 | runtime null-safety error reporting | blocked | — | | 31 | runtime null-safety error reporting | pending | (+1518 est) |
| 32 | MutationObserver mock + `on mutation` | blocked | — | | 32 | MutationObserver mock + `on mutation` | pending | (+1015 est) |
| 33 | cookie API | pending | (+5 est) | | 33 | cookie API | pending | (+5 est) |
| 34 | event modifier DSL | pending | (+68 est) | | 34 | event modifier DSL | pending | (+68 est) |
| 35 | namespaced `def` | pending | (+3 est) | | 35 | namespaced `def` | pending | (+3 est) |
@@ -88,7 +88,7 @@ Defer until AD drain. Estimated ~25 recoverable tests.
| A | 12 | 4 | 0 | 0 | 1 | — | 17 | | A | 12 | 4 | 0 | 0 | 1 | — | 17 |
| B | 6 | 0 | 0 | 0 | 1 | — | 7 | | B | 6 | 0 | 0 | 0 | 1 | — | 7 |
| C | 4 | 0 | 0 | 0 | 1 | — | 5 | | C | 4 | 0 | 0 | 0 | 1 | — | 5 |
| D | 0 | 0 | 0 | 3 | 2 | — | 5 | | D | 0 | 0 | 0 | 5 | 0 | — | 5 |
| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 | | E | 0 | 0 | 0 | 0 | 0 | 5 | 5 |
| F | — | — | — | ~10 | — | — | ~10 | | F | — | — | — | ~10 | — | — | ~10 |

View File

@@ -115,9 +115,9 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
### Bucket D: medium features (bigger commits, plan-first) ### Bucket D: medium features (bigger commits, plan-first)
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. 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.
32. **[blocked: environment + scope. (env) The `loops/hs` worktree at `/root/rose-ash-loops/hs/` ships without a built sx-tree MCP binary; even after running `dune build bin/mcp_tree.exe` on this iteration, the tools don't surface to the current session — they'd need to load at session start, and rebuilding doesn't re-register them. CLAUDE.md mandates sx-tree for any `.sx` edit and a hook blocks Edit/Read/Write on `.sx`/`.sxc`. (scope) The cluster needs coordinated changes across `lib/hyperscript/parser.sx` (recognise `on mutation of <filter>` with attribute/childList/characterData/`@name [or @name]*`), `lib/hyperscript/compiler.sx` (analogue of intersection's `:having`-style attach call passing filter info), `lib/hyperscript/runtime.sx` (`hs-on-mutation-attach!` constructing real `MutationObserver` with config matched to filter, dispatching `mutation` event with detail), `tests/hs-run-filtered.js` (replace the no-op MutationObserver mock with a working version + hook `El.setAttribute`/`appendChild`/etc. to fire registered observers), `tests/playwright/generate-sx-tests.py` (drop 7 mutation entries from `SKIP_TEST_NAMES`). The current parser drops bodies after `of` because `parse-on-feat` only consumes `having` clauses — confirmed via compile snapshot (`on mutation of attributes put "Mutated" into me``(hs-on me "mutation" (fn (event) nil))`). Recommended path: dedicated worktree with sx-tree loaded at session start, multi-commit (parser, compiler+attach, mock+runner, generator skip-list pruning).] 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. **[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.
33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5. 33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
@@ -177,12 +177,6 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests
(Reverse chronological — newest at top.) (Reverse chronological — newest at top.)
### 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) ### 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. - **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,34 +39,34 @@ Representation choices (finalise in phase 1, document here):
## Roadmap ## Roadmap
### Phase 1 — tokenizer + term parser (no operator table) ### Phase 1 — tokenizer + term parser (no operator table)
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`) - [x] 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]` - [x] 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. - [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.
- [ ] Unit tests in `lib/prolog/tests/parse.sx` - [x] Unit tests in `lib/prolog/tests/parse.sx` — 25 pass
### Phase 2 — unification + trail ### Phase 2 — unification + trail
- [ ] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!` - [x] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
- [ ] Occurs-check off by default, exposed as flag - [x] 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 - [x] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs — 47 pass
### Phase 3 — clause DB + DFS solver + cut + first classic programs ### Phase 3 — clause DB + DFS solver + cut + first classic programs
- [ ] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts - [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`
- [ ] 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 - [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.
- [ ] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier - [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.
- [ ] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0` - [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.
- [ ] Arithmetic `is/2` with `+ - * / mod abs` - [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.
- [ ] Classic programs in `lib/prolog/tests/programs/`: - [ ] Classic programs in `lib/prolog/tests/programs/`:
- [ ] `append.pl` — list append (with backtracking) - [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]).
- [ ] `reverse.pl` — naive reverse - [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.
- [ ] `member.pl` — generate all solutions via backtracking - [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.
- [ ] `nqueens.pl` — 8-queens - [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.).
- [ ] `family.pl` — facts + rules (parent/ancestor) - [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 + `\=`.
- [ ] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` - [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.
- [ ] Target: all 5 classic programs passing - [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.
### Phase 4 — operator table + more built-ins (next run) ### Phase 4 — operator table + more built-ins (next run)
- [ ] Operator table parsing (prefix/infix/postfix, precedence, assoc) - [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.
- [ ] `assert/1`, `asserta/1`, `assertz/1`, `retract/1` - [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 deferred — `:-` not in op table yet, so only fact-shaped clauses for now.
- [ ] `findall/3`, `bagof/3`, `setof/3` - [ ] `findall/3`, `bagof/3`, `setof/3`
- [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2` - [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2`
- [ ] String/atom predicates - [ ] String/atom predicates
@@ -88,6 +88,22 @@ Representation choices (finalise in phase 1, document here):
_Newest first. Agent appends on every commit._ _Newest first. Agent appends on every commit._
- 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)_ - _(awaiting phase 1)_
## Blockers ## Blockers