Compare commits
2 Commits
loops/prol
...
loops/hs
| Author | SHA1 | Date | |
|---|---|---|---|
| 7735eb7512 | |||
| 4e2e2c781c |
@@ -98,11 +98,6 @@
|
||||
"compound"
|
||||
fun
|
||||
(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))))
|
||||
|
||||
(define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {})))
|
||||
@@ -235,354 +230,3 @@
|
||||
(pl-unify! t1 t2 trail)
|
||||
true
|
||||
(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-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))
|
||||
(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)))
|
||||
(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))))
|
||||
|
||||
@@ -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}))
|
||||
@@ -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}))
|
||||
@@ -7,7 +7,7 @@ Baseline: 1213/1496 (81.1%)
|
||||
Merged: 1277/1496 (85.4%) delta +64
|
||||
Worktree: all landed
|
||||
Target: 1496/1496 (100.0%)
|
||||
Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
Remaining: ~219 tests (clusters 17/22/29/31/32 blocked; 31/32 need dedicated sx-tree worktree)
|
||||
```
|
||||
|
||||
## Cluster ledger
|
||||
@@ -61,8 +61,8 @@ Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
|
||||
|
||||
| # | Cluster | Status | Δ |
|
||||
|---|---------|--------|---|
|
||||
| 31 | runtime null-safety error reporting | pending | (+15–18 est) |
|
||||
| 32 | MutationObserver mock + `on mutation` | pending | (+10–15 est) |
|
||||
| 31 | runtime null-safety error reporting | blocked | — |
|
||||
| 32 | MutationObserver mock + `on mutation` | blocked | — |
|
||||
| 33 | cookie API | pending | (+5 est) |
|
||||
| 34 | event modifier DSL | pending | (+6–8 est) |
|
||||
| 35 | namespaced `def` | pending | (+3 est) |
|
||||
@@ -88,7 +88,7 @@ Defer until A–D drain. Estimated ~25 recoverable tests.
|
||||
| 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 |
|
||||
| D | 0 | 0 | 0 | 3 | 2 | — | 5 |
|
||||
| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 |
|
||||
| F | — | — | — | ~10 | — | — | ~10 |
|
||||
|
||||
|
||||
@@ -115,9 +115,9 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
|
||||
|
||||
### 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. **[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.
|
||||
|
||||
33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
|
||||
|
||||
@@ -177,6 +177,12 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests
|
||||
|
||||
(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)
|
||||
- **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.
|
||||
|
||||
|
||||
@@ -39,22 +39,22 @@ 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.
|
||||
- [ ] 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
|
||||
@@ -88,14 +88,6 @@ Representation choices (finalise in phase 1, document here):
|
||||
|
||||
_Newest first. Agent appends on every commit._
|
||||
|
||||
- 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
|
||||
|
||||
Reference in New Issue
Block a user