coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

prolog: assert/asserta/assertz/retract for facts, 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-25 07:32:09 +00:00
parent 3190e770fb
commit 373d57cbcb
6 changed files with 293 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
lib/prolog/conformance.sh
View File

@@ -21,6 +21,7 @@ SUITES=(
"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!"

125
lib/prolog/runtime.sx
View File

@@ -284,6 +284,123 @@
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"))))
@@ -367,6 +484,14 @@
(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

8
lib/prolog/scoreboard.json
View File

@@ -1,7 +1,7 @@
{
"total_passed": 202,
"total_passed": 213,
"total_failed": 0,
"total": 202,
"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},"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-25T06:57:26+00:00"
"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"
}

5
lib/prolog/scoreboard.md
View File

@@ -1,7 +1,7 @@
# Prolog scoreboard
**202 / 202 passing** (0 failure(s)).
Generated 2026-04-25T06:57:26+00:00.
**213 / 213 passing** (0 failure(s)).
Generated 2026-04-25T07:31:46+00:00.
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
@@ -10,6 +10,7 @@ Generated 2026-04-25T06:57:26+00:00.
| 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 |

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}))

3
plans/prolog-on-sx.md
View File

@@ -66,7 +66,7 @@ Representation choices (finalise in phase 1, document here):
### Phase 4 — operator table + more built-ins (next run)
- [x] Operator table parsing (prefix/infix/postfix, precedence, assoc) — `pl-op-table` (15 entries: `, ; -> = \= is < > =< >= + - * / mod`); precedence-climbing parser via `pp-parse-primary` + `pp-parse-term-prec` + `pp-parse-op-rhs`. Parens override precedence. Args inside compounds parsed at 999 so `,` stays as separator. xfx/xfy/yfx supported; prefix/postfix deferred (so `-5` still tokenises as bare atom + num as before). Comparison built-ins `</2 >/2 =</2 >=/2` added. New `tests/operators.sx` 19 tests cover assoc/precedence/parens + solver via infix.
- [ ] `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`
- [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2`
- [ ] String/atom predicates
@@ -88,6 +88,7 @@ Representation choices (finalise in phase 1, document here):
_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.