giles
148c3f2068
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Adds a user-facing strategy hook: dl-set-strategy! db strategy and dl-get-strategy db. Default :semi-naive; :magic is accepted but the actual transformation is deferred — the saturator currently falls back to semi-naive regardless. Lets us tick the Phase 6 "Optional pass — guarded behind dl-set-strategy!" checkbox while keeping the equivalence/perf tests pending future work. 3 new eval tests.
282 lines
8.9 KiB
Plaintext
282 lines
8.9 KiB
Plaintext
;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
|
|
|
|
(define dl-et-pass 0)
|
|
(define dl-et-fail 0)
|
|
(define dl-et-failures (list))
|
|
|
|
;; Same deep-equal helper used in other suites.
|
|
(define
|
|
dl-et-deep=?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (list? a) (list? b))
|
|
(and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
|
|
((and (dict? a) (dict? b))
|
|
(let
|
|
((ka (keys a)) (kb (keys b)))
|
|
(and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
|
|
((and (number? a) (number? b)) (= a b))
|
|
(else (equal? a b)))))
|
|
|
|
(define
|
|
dl-et-deq-l?
|
|
(fn
|
|
(a b i)
|
|
(cond
|
|
((>= i (len a)) true)
|
|
((not (dl-et-deep=? (nth a i) (nth b i))) false)
|
|
(else (dl-et-deq-l? a b (+ i 1))))))
|
|
|
|
(define
|
|
dl-et-deq-d?
|
|
(fn
|
|
(a b ka i)
|
|
(cond
|
|
((>= i (len ka)) true)
|
|
((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
|
|
false)
|
|
(else (dl-et-deq-d? a b ka (+ i 1))))))
|
|
|
|
;; Set-equality on lists (order-independent, uses dl-et-deep=?).
|
|
(define
|
|
dl-et-set=?
|
|
(fn
|
|
(a b)
|
|
(and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
|
|
|
|
(define
|
|
dl-et-subset?
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((= (len xs) 0) true)
|
|
((not (dl-et-contains? ys (first xs))) false)
|
|
(else (dl-et-subset? (rest xs) ys)))))
|
|
|
|
(define
|
|
dl-et-contains?
|
|
(fn
|
|
(xs target)
|
|
(cond
|
|
((= (len xs) 0) false)
|
|
((dl-et-deep=? (first xs) target) true)
|
|
(else (dl-et-contains? (rest xs) target)))))
|
|
|
|
(define
|
|
dl-et-test!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-et-deep=? got expected)
|
|
(set! dl-et-pass (+ dl-et-pass 1))
|
|
(do
|
|
(set! dl-et-fail (+ dl-et-fail 1))
|
|
(append!
|
|
dl-et-failures
|
|
(str name "\n expected: " expected "\n got: " got))))))
|
|
|
|
(define
|
|
dl-et-test-set!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-et-set=? got expected)
|
|
(set! dl-et-pass (+ dl-et-pass 1))
|
|
(do
|
|
(set! dl-et-fail (+ dl-et-fail 1))
|
|
(append!
|
|
dl-et-failures
|
|
(str
|
|
name
|
|
"\n expected (set): "
|
|
expected
|
|
"\n got: "
|
|
got))))))
|
|
|
|
(define
|
|
dl-et-throws?
|
|
(fn
|
|
(thunk)
|
|
(let
|
|
((threw false))
|
|
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
|
|
|
(define
|
|
dl-et-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
(dl-et-test-set!
|
|
"fact lookup any"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob). parent(bob, ann).")
|
|
(list (quote parent) (quote X) (quote Y)))
|
|
(list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
|
|
(dl-et-test-set!
|
|
"fact lookup constant arg"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
|
|
(list (quote parent) (quote tom) (quote Y)))
|
|
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
(dl-et-test-set!
|
|
"no match"
|
|
(dl-query
|
|
(dl-program "parent(tom, bob).")
|
|
(list (quote parent) (quote nobody) (quote X)))
|
|
(list))
|
|
(dl-et-test-set!
|
|
"ancestor closure"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(bob, ann). parent(ann, pat).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
|
(list (quote ancestor) (quote tom) (quote X)))
|
|
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
|
(dl-et-test-set!
|
|
"sibling"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n sibling(X, Y) :- parent(P, X), parent(P, Y).")
|
|
(list (quote sibling) (quote bob) (quote Y)))
|
|
(list {:Y (quote bob)} {:Y (quote liz)}))
|
|
(dl-et-test-set!
|
|
"same-generation"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n person(tom). person(bob). person(liz). person(ann). person(joe).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
|
|
(list (quote sg) (quote ann) (quote X)))
|
|
(list {:X (quote ann)} {:X (quote joe)}))
|
|
(dl-et-test!
|
|
"ancestor count"
|
|
(let
|
|
((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
|
6)
|
|
(dl-et-test-set!
|
|
"grandparent"
|
|
(dl-query
|
|
(dl-program
|
|
"parent(a, b). parent(b, c). parent(c, d).\n grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
|
|
(list (quote grandparent) (quote X) (quote Y)))
|
|
(list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
|
|
(dl-et-test!
|
|
"no recursion infinite loop"
|
|
(let
|
|
((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
|
|
(do (dl-saturate! db) (len (dl-relation db "reach"))))
|
|
9)
|
|
(dl-et-test!
|
|
"unsafe head var"
|
|
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
|
|
true)
|
|
(dl-et-test!
|
|
"unsafe — empty body"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- .")))
|
|
true)
|
|
;; Underscore in head is unsafe — it's a fresh existential per
|
|
;; occurrence after Phase 5d's anonymous-var renaming, and there's
|
|
;; nothing in the body to bind it. (Old behavior accepted this by
|
|
;; treating '_' as a literal name to skip; the renaming made it an
|
|
;; ordinary unbound variable.)
|
|
(dl-et-test!
|
|
"underscore in head — unsafe"
|
|
(dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
|
|
true)
|
|
(dl-et-test!
|
|
"underscore in body only — safe"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- q(X, _).")))
|
|
false)
|
|
(dl-et-test!
|
|
"var only in head — unsafe"
|
|
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
|
|
true)
|
|
(dl-et-test!
|
|
"head var bound by body"
|
|
(dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
|
|
false)
|
|
(dl-et-test!
|
|
"head subset of body"
|
|
(dl-et-throws?
|
|
(fn
|
|
()
|
|
(dl-program
|
|
"edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
|
|
false)
|
|
|
|
;; Anonymous variables: each occurrence must be independent.
|
|
(dl-et-test-set! "anon vars in rule are independent"
|
|
(dl-query
|
|
(dl-program
|
|
"p(a, b). p(c, d). q(X) :- p(X, _), p(_, Y).")
|
|
(list (quote q) (quote X)))
|
|
(list {:X (quote a)} {:X (quote c)}))
|
|
|
|
(dl-et-test-set! "anon vars in goal are independent"
|
|
(dl-query
|
|
(dl-program "p(1, 2, 3). p(4, 5, 6).")
|
|
(list (quote p) (quote _) (quote X) (quote _)))
|
|
(list {:X 2} {:X 5}))
|
|
|
|
;; dl-summary: relation -> tuple-count for inspection.
|
|
(dl-et-test! "dl-summary basic"
|
|
(dl-summary
|
|
(let
|
|
((db (dl-program "p(1). p(2). q(3).")))
|
|
(do (dl-saturate! db) db)))
|
|
{:p 2 :q 1})
|
|
|
|
(dl-et-test! "dl-summary empty IDB shown"
|
|
(dl-summary
|
|
(let
|
|
((db (dl-program "r(X) :- s(X).")))
|
|
(do (dl-saturate! db) db)))
|
|
{:r 0})
|
|
|
|
(dl-et-test! "dl-summary mixed EDB and IDB"
|
|
(dl-summary
|
|
(let
|
|
((db (dl-program
|
|
"parent(a, b).
|
|
ancestor(X, Y) :- parent(X, Y).
|
|
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
(do (dl-saturate! db) db)))
|
|
{:parent 1 :ancestor 1})
|
|
|
|
(dl-et-test! "dl-summary empty db"
|
|
(dl-summary (dl-make-db))
|
|
{})
|
|
|
|
;; Strategy hook: default semi-naive; :magic accepted but
|
|
;; falls back to semi-naive (the transformation itself is
|
|
;; deferred — Phase 6 in plan).
|
|
(dl-et-test! "default strategy"
|
|
(dl-get-strategy (dl-make-db))
|
|
:semi-naive)
|
|
|
|
(dl-et-test! "set strategy"
|
|
(let ((db (dl-make-db)))
|
|
(do (dl-set-strategy! db :magic) (dl-get-strategy db)))
|
|
:magic)
|
|
|
|
(dl-et-test-set! "magic-set still derives correctly"
|
|
(let
|
|
((db (dl-program
|
|
"parent(a, b). parent(b, c).
|
|
ancestor(X, Y) :- parent(X, Y).
|
|
ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
|
(do
|
|
(dl-set-strategy! db :magic)
|
|
(dl-query db (list (quote ancestor) (quote a) (quote X)))))
|
|
(list {:X (quote b)} {:X (quote c)})))))
|
|
|
|
(define
|
|
dl-eval-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! dl-et-pass 0)
|
|
(set! dl-et-fail 0)
|
|
(set! dl-et-failures (list))
|
|
(dl-et-run-all!)
|
|
{:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))
|