prolog: findall/3 + bagof/3 + setof/3, 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
This commit is contained in:
@@ -22,6 +22,7 @@ SUITES=(
|
||||
"solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!"
|
||||
"operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!"
|
||||
"dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!"
|
||||
"findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!"
|
||||
"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!"
|
||||
|
||||
@@ -364,6 +364,112 @@
|
||||
trail
|
||||
k))))))))
|
||||
|
||||
(define
|
||||
pl-deep-copy
|
||||
(fn
|
||||
(t var-map)
|
||||
(let
|
||||
((w (pl-walk t)))
|
||||
(cond
|
||||
((pl-var? w)
|
||||
(let
|
||||
((id-key (str (pl-var-id w))))
|
||||
(cond
|
||||
((dict-has? var-map id-key) (dict-get var-map id-key))
|
||||
(true
|
||||
(let
|
||||
((nv (pl-mk-rt-var (dict-get w :name))))
|
||||
(begin (dict-set! var-map id-key nv) nv))))))
|
||||
((pl-compound? w)
|
||||
(list
|
||||
"compound"
|
||||
(pl-fun w)
|
||||
(map (fn (a) (pl-deep-copy a var-map)) (pl-args w))))
|
||||
(true w)))))
|
||||
|
||||
(define
|
||||
pl-each-into-dict!
|
||||
(fn
|
||||
(terms d)
|
||||
(cond
|
||||
((empty? terms) nil)
|
||||
(true
|
||||
(begin
|
||||
(dict-set! d (pl-format-term (first terms)) (first terms))
|
||||
(pl-each-into-dict! (rest terms) d))))))
|
||||
|
||||
(define
|
||||
pl-sort-uniq-terms
|
||||
(fn
|
||||
(terms)
|
||||
(let
|
||||
((kv {}))
|
||||
(begin
|
||||
(pl-each-into-dict! terms kv)
|
||||
(let
|
||||
((sorted-keys (sort (keys kv))))
|
||||
(map (fn (k) (dict-get kv k)) sorted-keys))))))
|
||||
|
||||
(define
|
||||
pl-collect-solutions
|
||||
(fn
|
||||
(db template-rt goal-rt trail)
|
||||
(let
|
||||
((box {:results (list)}) (mark (pl-trail-mark trail)))
|
||||
(begin
|
||||
(pl-solve!
|
||||
db
|
||||
goal-rt
|
||||
trail
|
||||
{:cut false}
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(append!
|
||||
(dict-get box :results)
|
||||
(pl-deep-copy template-rt {}))
|
||||
false)))
|
||||
(pl-trail-undo-to! trail mark)
|
||||
(dict-get box :results)))))
|
||||
|
||||
(define
|
||||
pl-solve-findall!
|
||||
(fn
|
||||
(db template-rt goal-rt third-rt trail k)
|
||||
(let
|
||||
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
||||
(let
|
||||
((rl (pl-mk-list-term items (pl-nil-term))))
|
||||
(pl-solve-eq! third-rt rl trail k)))))
|
||||
|
||||
(define
|
||||
pl-solve-bagof!
|
||||
(fn
|
||||
(db template-rt goal-rt third-rt trail k)
|
||||
(let
|
||||
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
||||
(cond
|
||||
((empty? items) false)
|
||||
(true
|
||||
(let
|
||||
((rl (pl-mk-list-term items (pl-nil-term))))
|
||||
(pl-solve-eq! third-rt rl trail k)))))))
|
||||
|
||||
(define
|
||||
pl-solve-setof!
|
||||
(fn
|
||||
(db template-rt goal-rt third-rt trail k)
|
||||
(let
|
||||
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
||||
(cond
|
||||
((empty? items) false)
|
||||
(true
|
||||
(let
|
||||
((sorted (pl-sort-uniq-terms items)))
|
||||
(let
|
||||
((rl (pl-mk-list-term sorted (pl-nil-term))))
|
||||
(pl-solve-eq! third-rt rl trail k))))))))
|
||||
|
||||
(define
|
||||
pl-retract-try-each
|
||||
(fn
|
||||
@@ -492,6 +598,30 @@
|
||||
(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))
|
||||
((and (pl-compound? g) (= (pl-fun g) "findall") (= (len (pl-args g)) 3))
|
||||
(pl-solve-findall!
|
||||
db
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
(nth (pl-args g) 2)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "bagof") (= (len (pl-args g)) 3))
|
||||
(pl-solve-bagof!
|
||||
db
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
(nth (pl-args g) 2)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "setof") (= (len (pl-args g)) 3))
|
||||
(pl-solve-setof!
|
||||
db
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
(nth (pl-args g) 2)
|
||||
trail
|
||||
k))
|
||||
(true (pl-solve-user! db g trail cut-box k))))))
|
||||
|
||||
(define
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
{
|
||||
"total_passed": 213,
|
||||
"total_passed": 224,
|
||||
"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"
|
||||
"total": 224,
|
||||
"suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"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-25T08:06:14+00:00"
|
||||
}
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
# Prolog scoreboard
|
||||
|
||||
**213 / 213 passing** (0 failure(s)).
|
||||
Generated 2026-04-25T07:31:46+00:00.
|
||||
**224 / 224 passing** (0 failure(s)).
|
||||
Generated 2026-04-25T08:06:14+00:00.
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
@@ -11,6 +11,7 @@ Generated 2026-04-25T07:31:46+00:00.
|
||||
| solve | 62 | 62 | ok |
|
||||
| operators | 19 | 19 | ok |
|
||||
| dynamic | 11 | 11 | ok |
|
||||
| findall | 11 | 11 | ok |
|
||||
| append | 6 | 6 | ok |
|
||||
| reverse | 6 | 6 | ok |
|
||||
| member | 7 | 7 | ok |
|
||||
|
||||
167
lib/prolog/tests/findall.sx
Normal file
167
lib/prolog/tests/findall.sx
Normal file
@@ -0,0 +1,167 @@
|
||||
;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3.
|
||||
|
||||
(define pl-fb-test-count 0)
|
||||
(define pl-fb-test-pass 0)
|
||||
(define pl-fb-test-fail 0)
|
||||
(define pl-fb-test-failures (list))
|
||||
|
||||
(define
|
||||
pl-fb-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(begin
|
||||
(set! pl-fb-test-count (+ pl-fb-test-count 1))
|
||||
(if
|
||||
(= got expected)
|
||||
(set! pl-fb-test-pass (+ pl-fb-test-pass 1))
|
||||
(begin
|
||||
(set! pl-fb-test-fail (+ pl-fb-test-fail 1))
|
||||
(append!
|
||||
pl-fb-test-failures
|
||||
(str name "\n expected: " expected "\n got: " got)))))))
|
||||
|
||||
(define
|
||||
pl-fb-term-to-sx
|
||||
(fn
|
||||
(t)
|
||||
(cond
|
||||
((pl-num? t) (pl-num-val t))
|
||||
((pl-atom? t) (pl-atom-name t))
|
||||
(true (list :complex)))))
|
||||
|
||||
(define
|
||||
pl-fb-list-walked
|
||||
(fn
|
||||
(w)
|
||||
(cond
|
||||
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
|
||||
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
|
||||
(cons
|
||||
(pl-fb-term-to-sx (first (pl-args w)))
|
||||
(pl-fb-list-walked (nth (pl-args w) 1))))
|
||||
(true (list :not-list)))))
|
||||
|
||||
(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t))))
|
||||
|
||||
(define
|
||||
pl-fb-goal
|
||||
(fn
|
||||
(src env)
|
||||
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
|
||||
|
||||
(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
|
||||
|
||||
(define pl-fb-db (pl-mk-db))
|
||||
(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src))
|
||||
|
||||
;; ── findall ──
|
||||
|
||||
(define pl-fb-env-1 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"findall member [a, b, c]"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-1 "L"))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
(define pl-fb-env-2 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"findall with comparison filter"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-2 "L"))
|
||||
(list 2 3))
|
||||
|
||||
(define pl-fb-env-3 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "findall(X, fail, L)" pl-fb-env-3)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"findall on fail succeeds with empty list"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-3 "L"))
|
||||
(list))
|
||||
|
||||
(pl-fb-test!
|
||||
"findall(X, fail, L) the goal succeeds"
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "findall(X, fail, L)" {})
|
||||
(pl-mk-trail))
|
||||
true)
|
||||
|
||||
(define pl-fb-env-4 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal
|
||||
"findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)"
|
||||
pl-fb-env-4)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"findall over compound template — count = 4"
|
||||
(len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L")))
|
||||
4)
|
||||
|
||||
;; ── bagof ──
|
||||
|
||||
(pl-fb-test!
|
||||
"bagof succeeds when results exist"
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {})
|
||||
(pl-mk-trail))
|
||||
true)
|
||||
|
||||
(pl-fb-test!
|
||||
"bagof fails on empty"
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "bagof(X, fail, L)" {})
|
||||
(pl-mk-trail))
|
||||
false)
|
||||
|
||||
(define pl-fb-env-5 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"bagof preserves order"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-5 "L"))
|
||||
(list "c" "a" "b"))
|
||||
|
||||
;; ── setof ──
|
||||
|
||||
(define pl-fb-env-6 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"setof sorts + dedupes atoms"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-6 "L"))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
(pl-fb-test!
|
||||
"setof fails on empty"
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "setof(X, fail, L)" {})
|
||||
(pl-mk-trail))
|
||||
false)
|
||||
|
||||
(define pl-fb-env-7 {})
|
||||
(pl-solve-once!
|
||||
pl-fb-db
|
||||
(pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7)
|
||||
(pl-mk-trail))
|
||||
(pl-fb-test!
|
||||
"setof sorts + dedupes nums"
|
||||
(pl-fb-list-to-sx (dict-get pl-fb-env-7 "L"))
|
||||
(list 1 2 3))
|
||||
|
||||
(define pl-findall-tests-run! (fn () {:failed pl-fb-test-fail :passed pl-fb-test-pass :total pl-fb-test-count :failures pl-fb-test-failures}))
|
||||
@@ -67,7 +67,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.
|
||||
- [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`
|
||||
- [x] `findall/3`, `bagof/3`, `setof/3` — shared `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template (via `pl-deep-copy` with var-map for shared-var preservation) on each success, returns false to backtrack, then restores trail. `findall` always succeeds with a (possibly empty) list. `bagof` fails on empty. `setof` builds a string-keyed dict via `pl-format-term` for sort+dedupe (via `keys` + `sort`), fails on empty. Existential `^` deferred (operator). 11 tests in `tests/findall.sx`.
|
||||
- [ ] `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 — `findall/3` + `bagof/3` + `setof/3`. Shared collector `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template per success (`pl-deep-copy` walks term, allocates fresh runtime vars via shared var-map so co-occurrences keep aliasing), returns false to keep backtracking, then `pl-trail-undo-to!` to clean up. `findall` always builds a list. `bagof` fails on empty. `setof` uses a `pl-format-term`-keyed dict + SX `sort` for dedupe + ordering. New `tests/findall.sx` 11 tests. Total **224** (+11). Existential `^` deferred — needs operator.
|
||||
- 2026-04-25 — Dynamic clauses: `assert/1`, `assertz/1`, `asserta/1`, `retract/1`. New helpers `pl-rt-to-ast` (deep-walk runtime term → parse-AST, mapping unbound runtime vars to `_G<id>` markers so `pl-instantiate-fresh` produces fresh vars per call) + `pl-build-clause` + `pl-db-prepend!` + `pl-list-without`. `retract` keeps runtime vars (so the caller's vars get bound), walks head for the functor/arity key, tries each stored clause via `pl-unify!`, removes the first match by index. 11 tests in `tests/dynamic.sx`; conformance script gained dynamic row. Total **213** (+11). Rule-form asserts (`(H :- B)`) deferred until `:-` is in the op table.
|
||||
- 2026-04-25 — Phase 4 starts: operator-table parsing. Parser rewrite uses precedence climbing (xfx/xfy/yfx); 15-op table covers control (`, ; ->`), comparison (`= \\= is < > =< >=`), arithmetic (`+ - * / mod`). Parens override. Backwards-compatible: prefix-syntax compounds (`=(X, Y)`, `+(2, 3)`) still parse as before; existing 183 tests untouched. Added comparison built-ins `</2 >/2 =</2 >=/2` to runtime (eval both sides, compare). New `tests/operators.sx` 19 tests; conformance script gained an operators row. Total **202** (+19). Prefix/postfix deferred — `-5` keeps old bare-atom semantics.
|
||||
- 2026-04-25 — Conformance harness landed. `lib/prolog/conformance.sh` runs all 9 suites in one sx_server epoch, parses the `{:failed/:passed/:total/:failures}` summary lines, and writes `scoreboard.json` + `scoreboard.md`. `SX_SERVER` env var overrides the binary path; default points at the main-repo build. Phase 3 fully complete: 183 / 183 passing across parse/unify/clausedb/solve/append/reverse/member/nqueens/family.
|
||||
|
||||
Reference in New Issue
Block a user