giles
e0c7de1a1c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Adds dl-demo-org-rules: (subordinate Mgr Emp) over a (manager EMP MGR) graph, and (headcount Mgr N) using count aggregation grouped by manager. Demonstrates real-world hierarchy queries (e.g. "everyone reporting up to the CEO") + per-manager rollup. 3 new demo tests: transitive subordinates of CEO (5 entries), CEO headcount, and direct manager headcount.
322 lines
9.9 KiB
Plaintext
322 lines
9.9 KiB
Plaintext
;; lib/datalog/tests/demo.sx — Phase 10 demo programs.
|
|
|
|
(define dl-demo-pass 0)
|
|
(define dl-demo-fail 0)
|
|
(define dl-demo-failures (list))
|
|
|
|
(define
|
|
dl-demo-deep=?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (list? a) (list? b))
|
|
(and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
|
|
((and (dict? a) (dict? b))
|
|
(let ((ka (keys a)) (kb (keys b)))
|
|
(and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
|
|
((and (number? a) (number? b)) (= a b))
|
|
(else (equal? a b)))))
|
|
|
|
(define
|
|
dl-demo-deq-l?
|
|
(fn
|
|
(a b i)
|
|
(cond
|
|
((>= i (len a)) true)
|
|
((not (dl-demo-deep=? (nth a i) (nth b i))) false)
|
|
(else (dl-demo-deq-l? a b (+ i 1))))))
|
|
|
|
(define
|
|
dl-demo-deq-d?
|
|
(fn
|
|
(a b ka i)
|
|
(cond
|
|
((>= i (len ka)) true)
|
|
((let ((k (nth ka i)))
|
|
(not (dl-demo-deep=? (get a k) (get b k))))
|
|
false)
|
|
(else (dl-demo-deq-d? a b ka (+ i 1))))))
|
|
|
|
(define
|
|
dl-demo-set=?
|
|
(fn
|
|
(a b)
|
|
(and
|
|
(= (len a) (len b))
|
|
(dl-demo-subset? a b)
|
|
(dl-demo-subset? b a))))
|
|
|
|
(define
|
|
dl-demo-subset?
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((= (len xs) 0) true)
|
|
((not (dl-demo-contains? ys (first xs))) false)
|
|
(else (dl-demo-subset? (rest xs) ys)))))
|
|
|
|
(define
|
|
dl-demo-contains?
|
|
(fn
|
|
(xs target)
|
|
(cond
|
|
((= (len xs) 0) false)
|
|
((dl-demo-deep=? (first xs) target) true)
|
|
(else (dl-demo-contains? (rest xs) target)))))
|
|
|
|
(define
|
|
dl-demo-test-set!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(dl-demo-set=? got expected)
|
|
(set! dl-demo-pass (+ dl-demo-pass 1))
|
|
(do
|
|
(set! dl-demo-fail (+ dl-demo-fail 1))
|
|
(append!
|
|
dl-demo-failures
|
|
(str
|
|
name
|
|
"\n expected (set): " expected
|
|
"\n got: " got))))))
|
|
|
|
(define
|
|
dl-demo-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
;; ── Federation ──────────────────────────────────────────
|
|
(dl-demo-test-set! "mutuals"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((follows alice bob) (follows bob alice)
|
|
(follows bob carol) (follows carol dave)))
|
|
dl-demo-federation-rules)
|
|
(quote (mutual alice X)))
|
|
(list {:X (quote bob)}))
|
|
|
|
(dl-demo-test-set! "reachable transitive"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((follows alice bob) (follows bob carol) (follows carol dave)))
|
|
dl-demo-federation-rules)
|
|
(quote (reachable alice X)))
|
|
(list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))
|
|
|
|
(dl-demo-test-set! "foaf"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((follows alice bob) (follows bob carol) (follows alice dave)))
|
|
dl-demo-federation-rules)
|
|
(quote (foaf alice X)))
|
|
(list {:X (quote carol)}))
|
|
|
|
;; ── Content ─────────────────────────────────────────────
|
|
(dl-demo-test-set! "popular posts"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((authored alice p1) (authored bob p2) (authored carol p3)
|
|
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
|
(liked u1 p2)))
|
|
dl-demo-content-rules)
|
|
(quote (popular P)))
|
|
(list {:P (quote p1)}))
|
|
|
|
(dl-demo-test-set! "interesting feed"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((follows me alice) (follows me bob)
|
|
(authored alice p1) (authored bob p2)
|
|
(liked u1 p1) (liked u2 p1) (liked u3 p1)
|
|
(liked u4 p2)))
|
|
dl-demo-content-rules)
|
|
(quote (interesting me P)))
|
|
(list {:P (quote p1)}))
|
|
|
|
(dl-demo-test-set! "post likes count"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((authored alice p1)
|
|
(liked u1 p1) (liked u2 p1) (liked u3 p1)))
|
|
dl-demo-content-rules)
|
|
(quote (post-likes p1 N)))
|
|
(list {:N 3}))
|
|
|
|
;; ── Permissions ─────────────────────────────────────────
|
|
(dl-demo-test-set! "direct group access"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((member alice editors)
|
|
(allowed editors blog)))
|
|
dl-demo-perm-rules)
|
|
(quote (can-access X blog)))
|
|
(list {:X (quote alice)}))
|
|
|
|
(dl-demo-test-set! "subgroup access"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((member bob writers)
|
|
(subgroup writers editors)
|
|
(allowed editors blog)))
|
|
dl-demo-perm-rules)
|
|
(quote (can-access X blog)))
|
|
(list {:X (quote bob)}))
|
|
|
|
(dl-demo-test-set! "transitive subgroup"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((member carol drafters)
|
|
(subgroup drafters writers)
|
|
(subgroup writers editors)
|
|
(allowed editors blog)))
|
|
dl-demo-perm-rules)
|
|
(quote (can-access X blog)))
|
|
(list {:X (quote carol)}))
|
|
|
|
;; ── Cooking posts (canonical Phase 10 example) ─────────
|
|
(dl-demo-test-set! "cooking posts by network"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((follows me alice) (follows alice bob) (follows alice carol)
|
|
(authored alice p1) (authored bob p2)
|
|
(authored carol p3) (authored carol p4)
|
|
(tagged p1 travel) (tagged p2 cooking)
|
|
(tagged p3 cooking) (tagged p4 books)))
|
|
dl-demo-cooking-rules)
|
|
(quote (cooking-post-by-network me P)))
|
|
(list {:P (quote p2)} {:P (quote p3)}))
|
|
|
|
(dl-demo-test-set! "cooking — direct follow only"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((follows me bob)
|
|
(authored bob p1) (authored bob p2)
|
|
(tagged p1 cooking) (tagged p2 books)))
|
|
dl-demo-cooking-rules)
|
|
(quote (cooking-post-by-network me P)))
|
|
(list {:P (quote p1)}))
|
|
|
|
(dl-demo-test-set! "cooking — none in network"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((follows me bob)
|
|
(authored bob p1) (tagged p1 books)))
|
|
dl-demo-cooking-rules)
|
|
(quote (cooking-post-by-network me P)))
|
|
(list))
|
|
|
|
;; ── Tag co-occurrence ──────────────────────────────────
|
|
(dl-demo-test-set! "cotagged posts"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((tagged p1 cooking) (tagged p1 vegetarian)
|
|
(tagged p2 cooking) (tagged p2 quick)
|
|
(tagged p3 vegetarian)))
|
|
dl-demo-tag-cooccur-rules)
|
|
(quote (cotagged P cooking vegetarian)))
|
|
(list {:P (quote p1)}))
|
|
|
|
(dl-demo-test-set! "tag pair count"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((tagged p1 cooking) (tagged p1 vegetarian)
|
|
(tagged p2 cooking) (tagged p2 quick)
|
|
(tagged p3 cooking) (tagged p3 vegetarian)))
|
|
dl-demo-tag-cooccur-rules)
|
|
(quote (tag-pair-count cooking vegetarian N)))
|
|
(list {:N 2}))
|
|
|
|
;; ── Shortest path on a weighted DAG ──────────────────
|
|
(dl-demo-test-set! "shortest a→d via DAG"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((edge a b 5) (edge b c 3) (edge a c 10) (edge c d 2)))
|
|
dl-demo-shortest-path-rules)
|
|
(quote (shortest a d W)))
|
|
(list {:W 10}))
|
|
|
|
(dl-demo-test-set! "shortest a→c picks 2-hop"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((edge a b 5) (edge b c 3) (edge a c 10)))
|
|
dl-demo-shortest-path-rules)
|
|
(quote (shortest a c W)))
|
|
(list {:W 8}))
|
|
|
|
(dl-demo-test-set! "shortest unreachable empty"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((edge a b 5) (edge b c 3)))
|
|
dl-demo-shortest-path-rules)
|
|
(quote (shortest a d W)))
|
|
(list))
|
|
|
|
;; ── Org chart + headcount ─────────────────────────────
|
|
(dl-demo-test-set! "ceo subordinate transitive"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
(manager mgr1 vp1) (manager ic3 vp1)
|
|
(manager vp1 ceo)))
|
|
dl-demo-org-rules)
|
|
(quote (subordinate ceo X)))
|
|
(list
|
|
{:X (quote vp1)} {:X (quote mgr1)} {:X (quote ic1)}
|
|
{:X (quote ic2)} {:X (quote ic3)}))
|
|
|
|
(dl-demo-test-set! "ceo headcount = 5"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
(manager mgr1 vp1) (manager ic3 vp1)
|
|
(manager vp1 ceo)))
|
|
dl-demo-org-rules)
|
|
(quote (headcount ceo N)))
|
|
(list {:N 5}))
|
|
|
|
(dl-demo-test-set! "mgr1 headcount = 2"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote
|
|
((manager ic1 mgr1) (manager ic2 mgr1)
|
|
(manager mgr1 vp1) (manager ic3 vp1)
|
|
(manager vp1 ceo)))
|
|
dl-demo-org-rules)
|
|
(quote (headcount mgr1 N)))
|
|
(list {:N 2}))
|
|
|
|
(dl-demo-test-set! "no access without grant"
|
|
(dl-query
|
|
(dl-demo-make
|
|
(quote ((member dave outsiders) (allowed editors blog)))
|
|
dl-demo-perm-rules)
|
|
(quote (can-access X blog)))
|
|
(list)))))
|
|
|
|
(define
|
|
dl-demo-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! dl-demo-pass 0)
|
|
(set! dl-demo-fail 0)
|
|
(set! dl-demo-failures (list))
|
|
(dl-demo-run-all!)
|
|
{:passed dl-demo-pass
|
|
:failed dl-demo-fail
|
|
:total (+ dl-demo-pass dl-demo-fail)
|
|
:failures dl-demo-failures})))
|