From 1888c272f9093789d19b3eb52ad33ecb05a102aa Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 23:59:46 +0000 Subject: [PATCH] =?UTF-8?q?prolog:=20clause=20DB=20+=20loader=20(functor/a?= =?UTF-8?q?rity=20=E2=86=92=20clauses),=2014=20tests=20green?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/prolog/runtime.sx | 48 +++++++++++++++++ lib/prolog/tests/clausedb.sx | 99 ++++++++++++++++++++++++++++++++++++ plans/prolog-on-sx.md | 3 +- 3 files changed, 149 insertions(+), 1 deletion(-) create mode 100644 lib/prolog/tests/clausedb.sx diff --git a/lib/prolog/runtime.sx b/lib/prolog/runtime.sx index d20a71cb..60d4f0ca 100644 --- a/lib/prolog/runtime.sx +++ b/lib/prolog/runtime.sx @@ -230,3 +230,51 @@ (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)))) diff --git a/lib/prolog/tests/clausedb.sx b/lib/prolog/tests/clausedb.sx new file mode 100644 index 00000000..83102713 --- /dev/null +++ b/lib/prolog/tests/clausedb.sx @@ -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})) diff --git a/plans/prolog-on-sx.md b/plans/prolog-on-sx.md index f89e3904..47f7b28a 100644 --- a/plans/prolog-on-sx.md +++ b/plans/prolog-on-sx.md @@ -50,7 +50,7 @@ Representation choices (finalise in phase 1, document here): - [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 -- [ ] 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 - [ ] 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` @@ -88,6 +88,7 @@ Representation choices (finalise in phase 1, document here): _Newest first. Agent appends on every commit._ +- 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)_