giles
a080ce656c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
dl-magic-rewrite rules query-rel adn args returns:
{:rules <rewritten-rules> :seed <magic-seed-fact>}
Worklist over (rel, adn) pairs starts from the query and stops
when no new pairs appear. For each rule with head matching a
worklist pair:
- Adorned rule: head :- magic_<rel>^<adn>(bound), body...
- Propagation rules: for each positive non-builtin body lit
at position i:
magic_<lit-rel>^<lit-adn>(bound-of-lit) :-
magic_<rel>^<adn>(bound-of-head),
body[0..i-1]
- Add (lit-rel, lit-adn) to the worklist.
Built-ins, negation, and aggregates pass through without
generating propagation rules. EDB facts are unchanged.
3 new tests cover seed structure, equivalence on chain-3 (full
closure, 6 ancestor tuples — magic helps only when the EDB has
nodes outside the seed's transitive cone), and same-query-answers
under the rewritten program. Total 202/202.
Wiring up a `dl-saturate-magic!` driver and large-graph perf
benchmarks is left for a future iteration.
236 lines
8.0 KiB
Plaintext
236 lines
8.0 KiB
Plaintext
;; lib/datalog/tests/magic.sx — adornment + SIPS analysis tests.
|
|
|
|
(define dl-mt-pass 0)
|
|
(define dl-mt-fail 0)
|
|
(define dl-mt-failures (list))
|
|
|
|
(define
|
|
dl-mt-deep=?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (list? a) (list? b))
|
|
(and (= (len a) (len b)) (dl-mt-deq-l? a b 0)))
|
|
((and (dict? a) (dict? b))
|
|
(let ((ka (keys a)) (kb (keys b)))
|
|
(and (= (len ka) (len kb)) (dl-mt-deq-d? a b ka 0))))
|
|
((and (number? a) (number? b)) (= a b))
|
|
(else (equal? a b)))))
|
|
|
|
(define
|
|
dl-mt-deq-l?
|
|
(fn
|
|
(a b i)
|
|
(cond
|
|
((>= i (len a)) true)
|
|
((not (dl-mt-deep=? (nth a i) (nth b i))) false)
|
|
(else (dl-mt-deq-l? a b (+ i 1))))))
|
|
|
|
(define
|
|
dl-mt-deq-d?
|
|
(fn
|
|
(a b ka i)
|
|
(cond
|
|
((>= i (len ka)) true)
|
|
((let ((k (nth ka i)))
|
|
(not (dl-mt-deep=? (get a k) (get b k))))
|
|
false)
|
|
(else (dl-mt-deq-d? a b ka (+ i 1))))))
|
|
|
|
(define
|
|
dl-mt-test!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-mt-deep=? got expected)
|
|
(set! dl-mt-pass (+ dl-mt-pass 1))
|
|
(do
|
|
(set! dl-mt-fail (+ dl-mt-fail 1))
|
|
(append!
|
|
dl-mt-failures
|
|
(str
|
|
name
|
|
"\n expected: " expected
|
|
"\n got: " got))))))
|
|
|
|
(define
|
|
dl-mt-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
;; Goal adornment.
|
|
(dl-mt-test! "adorn 0-ary"
|
|
(dl-adorn-goal (list (quote ready)))
|
|
"")
|
|
(dl-mt-test! "adorn all bound"
|
|
(dl-adorn-goal (list (quote p) 1 2 3))
|
|
"bbb")
|
|
(dl-mt-test! "adorn all free"
|
|
(dl-adorn-goal (list (quote p) (quote X) (quote Y)))
|
|
"ff")
|
|
(dl-mt-test! "adorn mixed"
|
|
(dl-adorn-goal (list (quote ancestor) (quote tom) (quote X)))
|
|
"bf")
|
|
(dl-mt-test! "adorn const var const"
|
|
(dl-adorn-goal (list (quote p) (quote a) (quote X) (quote b)))
|
|
"bfb")
|
|
|
|
;; dl-adorn-lit with explicit bound set.
|
|
(dl-mt-test! "adorn lit with bound"
|
|
(dl-adorn-lit (list (quote p) (quote X) (quote Y)) (list "X"))
|
|
"bf")
|
|
|
|
;; Rule SIPS — chain ancestor.
|
|
(dl-mt-test! "sips chain ancestor bf"
|
|
(dl-rule-sips
|
|
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
:body (list (list (quote parent) (quote X) (quote Y))
|
|
(list (quote ancestor) (quote Y) (quote Z)))}
|
|
"bf")
|
|
(list
|
|
{:lit (list (quote parent) (quote X) (quote Y)) :adornment "bf"}
|
|
{:lit (list (quote ancestor) (quote Y) (quote Z)) :adornment "bf"}))
|
|
|
|
;; SIPS — head fully bound.
|
|
(dl-mt-test! "sips head bb"
|
|
(dl-rule-sips
|
|
{:head (list (quote q) (quote X) (quote Y))
|
|
:body (list (list (quote p) (quote X) (quote Z))
|
|
(list (quote r) (quote Z) (quote Y)))}
|
|
"bb")
|
|
(list
|
|
{:lit (list (quote p) (quote X) (quote Z)) :adornment "bf"}
|
|
{:lit (list (quote r) (quote Z) (quote Y)) :adornment "bb"}))
|
|
|
|
;; SIPS — comparison; vars must be bound by prior body lit.
|
|
(dl-mt-test! "sips with comparison"
|
|
(dl-rule-sips
|
|
{:head (list (quote q) (quote X))
|
|
:body (list (list (quote p) (quote X))
|
|
(list (string->symbol "<") (quote X) 5))}
|
|
"f")
|
|
(list
|
|
{:lit (list (quote p) (quote X)) :adornment "f"}
|
|
{:lit (list (string->symbol "<") (quote X) 5) :adornment "bb"}))
|
|
|
|
;; SIPS — `is` binds its left arg.
|
|
(dl-mt-test! "sips with is"
|
|
(dl-rule-sips
|
|
{:head (list (quote q) (quote X) (quote Y))
|
|
:body (list (list (quote p) (quote X))
|
|
(list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1)))}
|
|
"ff")
|
|
(list
|
|
{:lit (list (quote p) (quote X)) :adornment "f"}
|
|
{:lit (list (quote is) (quote Y)
|
|
(list (string->symbol "+") (quote X) 1))
|
|
:adornment "fb"}))
|
|
|
|
;; Magic predicate naming.
|
|
(dl-mt-test! "magic-rel-name"
|
|
(dl-magic-rel-name "ancestor" "bf")
|
|
"magic_ancestor^bf")
|
|
|
|
;; Bound-args extraction.
|
|
(dl-mt-test! "bound-args bf"
|
|
(dl-bound-args (list (quote ancestor) (quote tom) (quote X)) "bf")
|
|
(list (quote tom)))
|
|
|
|
(dl-mt-test! "bound-args mixed"
|
|
(dl-bound-args (list (quote p) 1 (quote Y) 3) "bfb")
|
|
(list 1 3))
|
|
|
|
(dl-mt-test! "bound-args all-free"
|
|
(dl-bound-args (list (quote p) (quote X) (quote Y)) "ff")
|
|
(list))
|
|
|
|
;; Magic literal construction.
|
|
(dl-mt-test! "magic-lit"
|
|
(dl-magic-lit "ancestor" "bf" (list (quote tom)))
|
|
(list (string->symbol "magic_ancestor^bf") (quote tom)))
|
|
|
|
;; Magic-sets rewriter: structural sanity.
|
|
(dl-mt-test! "rewrite ancestor produces seed"
|
|
(let
|
|
((rules
|
|
(list
|
|
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
:body
|
|
(list (list (quote parent) (quote X) (quote Y))
|
|
(list (quote ancestor) (quote Y) (quote Z)))})))
|
|
(get
|
|
(dl-magic-rewrite rules "ancestor" "bf" (list (quote a)))
|
|
:seed))
|
|
(list (string->symbol "magic_ancestor^bf") (quote a)))
|
|
|
|
;; Equivalence: rewritten program derives same ancestor tuples.
|
|
;; In a chain a→b→c→d, magic-rewritten run still derives all
|
|
;; ancestor pairs reachable from any node a/b/c/d propagated via
|
|
;; magic_ancestor^bf — i.e. the full closure (6 tuples). Magic
|
|
;; saves work only when the EDB has irrelevant nodes outside
|
|
;; the seed's transitive cone.
|
|
(dl-mt-test! "magic-rewritten ancestor count"
|
|
(let
|
|
((rules
|
|
(list
|
|
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
:body
|
|
(list (list (quote parent) (quote X) (quote Y))
|
|
(list (quote ancestor) (quote Y) (quote Z)))}))
|
|
(edb (list
|
|
(list (quote parent) (quote a) (quote b))
|
|
(list (quote parent) (quote b) (quote c))
|
|
(list (quote parent) (quote c) (quote d)))))
|
|
(let
|
|
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
|
(db (dl-make-db)))
|
|
(do
|
|
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
|
(dl-add-fact! db (get rewritten :seed))
|
|
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
|
(dl-saturate! db)
|
|
(len (dl-relation db "ancestor")))))
|
|
6)
|
|
|
|
(dl-mt-test! "magic-rewritten finds same answers"
|
|
(let
|
|
((rules
|
|
(list
|
|
{:head (list (quote ancestor) (quote X) (quote Y))
|
|
:body (list (list (quote parent) (quote X) (quote Y)))}
|
|
{:head (list (quote ancestor) (quote X) (quote Z))
|
|
:body
|
|
(list (list (quote parent) (quote X) (quote Y))
|
|
(list (quote ancestor) (quote Y) (quote Z)))}))
|
|
(edb (list
|
|
(list (quote parent) (quote a) (quote b))
|
|
(list (quote parent) (quote b) (quote c)))))
|
|
(let
|
|
((rewritten (dl-magic-rewrite rules "ancestor" "bf" (list (quote a))))
|
|
(db (dl-make-db)))
|
|
(do
|
|
(for-each (fn (f) (dl-add-fact! db f)) edb)
|
|
(dl-add-fact! db (get rewritten :seed))
|
|
(for-each (fn (r) (dl-add-rule! db r)) (get rewritten :rules))
|
|
(dl-saturate! db)
|
|
(len (dl-query db (list (quote ancestor) (quote a) (quote X)))))))
|
|
2))))
|
|
|
|
(define
|
|
dl-magic-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! dl-mt-pass 0)
|
|
(set! dl-mt-fail 0)
|
|
(set! dl-mt-failures (list))
|
|
(dl-mt-run-all!)
|
|
{:passed dl-mt-pass
|
|
:failed dl-mt-fail
|
|
:total (+ dl-mt-pass dl-mt-fail)
|
|
:failures dl-mt-failures})))
|