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

relations: tree/DAG queries (common-ancestors, lca, topo-order) in SX + 16 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Details

Browse Source 
lib/relations/tree.sx over reach/ancestors/rnode — no new Datalog closures. 126/126.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-07 13:07:50 +00:00
parent 1c46fc2a69
commit e6ffc60040
6 changed files with 348 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

206
lib/relations/tests/tree.sx Normal file
View File

@@ -0,0 +1,206 @@
;; lib/relations/tests/tree.sx — extension: common ancestors, LCA, topo order.
(define relations-tt-pass 0)
(define relations-tt-fail 0)
(define relations-tt-failures (list))
(define
relations-tt-check!
(fn
(name got expected)
(if
(= got expected)
(set! relations-tt-pass (+ relations-tt-pass 1))
(do
(set! relations-tt-fail (+ relations-tt-fail 1))
(append!
relations-tt-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
relations-tt-subset?
(fn
(xs ys)
(cond
((= (len xs) 0) true)
((relations-member? (first xs) ys)
(relations-tt-subset? (rest xs) ys))
(else false))))
(define
relations-tt-set=?
(fn
(xs ys)
(and
(= (len xs) (len ys))
(relations-tt-subset? xs ys)
(relations-tt-subset? ys xs))))
;; Is xs a valid topo order? every node appears once and no node precedes one of
;; its ancestors. We check the simpler invariant: for each edge u->v (parent),
;; u appears before v in the order.
(define
relations-tt-index-of
(fn
(x xs i)
(cond
((= (len xs) 0) -1)
((= (first xs) x) i)
(else (relations-tt-index-of x (rest xs) (+ i 1))))))
;; Diamond with an extra branch:
;; parent: a->b, a->c, b->d, c->d, b->e
;; member (different kind): m->n
(define
relations-tt-fixture
(fn
()
(relations-build-db
(list
(relations-rel (quote a) (quote b) (quote parent))
(relations-rel (quote a) (quote c) (quote parent))
(relations-rel (quote b) (quote d) (quote parent))
(relations-rel (quote c) (quote d) (quote parent))
(relations-rel (quote b) (quote e) (quote parent))
(relations-rel (quote m) (quote n) (quote member))))))
;; A cyclic kind, to confirm topo-order refuses it.
(define
relations-tt-cyc-fixture
(fn
()
(relations-build-db
(list
(relations-rel (quote x) (quote y) (quote parent))
(relations-rel (quote y) (quote x) (quote parent))))))
(define
relations-tt-run-all!
(fn
()
(let
((db (relations-tt-fixture)) (cyc (relations-tt-cyc-fixture)))
(do
(relations-tt-check!
"common ancestors of d and e"
(relations-tt-set=?
(relations-common-ancestors
db
(quote d)
(quote e)
(quote parent))
(list (quote a) (quote b)))
true)
(relations-tt-check!
"common ancestors of b and c"
(relations-tt-set=?
(relations-common-ancestors
db
(quote b)
(quote c)
(quote parent))
(list (quote a)))
true)
(relations-tt-check!
"no common ancestors across kinds"
(relations-common-ancestors db (quote d) (quote n) (quote parent))
(list))
(relations-tt-check!
"lca of d and e is b"
(relations-tt-set=?
(relations-lca db (quote d) (quote e) (quote parent))
(list (quote b)))
true)
(relations-tt-check!
"lca of b and c is a"
(relations-tt-set=?
(relations-lca db (quote b) (quote c) (quote parent))
(list (quote a)))
true)
(relations-tt-check!
"lca of d and d-sibling-path picks deepest"
(relations-tt-set=?
(relations-lca db (quote d) (quote d) (quote parent))
(list (quote b) (quote c)))
true)
(relations-tt-check!
"no lca when unrelated"
(relations-lca db (quote a) (quote n) (quote parent))
(list))
(let
((order (relations-topo-order db (quote parent))))
(do
(relations-tt-check!
"topo order covers all nodes"
(relations-tt-set=?
order
(list (quote a) (quote b) (quote c) (quote d) (quote e)))
true)
(relations-tt-check!
"topo: a before b"
(<
(relations-tt-index-of (quote a) order 0)
(relations-tt-index-of (quote b) order 0))
true)
(relations-tt-check!
"topo: b before d"
(<
(relations-tt-index-of (quote b) order 0)
(relations-tt-index-of (quote d) order 0))
true)
(relations-tt-check!
"topo: c before d"
(<
(relations-tt-index-of (quote c) order 0)
(relations-tt-index-of (quote d) order 0))
true)
(relations-tt-check!
"topo: b before e"
(<
(relations-tt-index-of (quote b) order 0)
(relations-tt-index-of (quote e) order 0))
true)))
(relations-tt-check!
"topo order of cyclic kind is nil"
(relations-topo-order cyc (quote parent))
nil)
(do
(relations/load!
(list
(relations-rel (quote r) (quote s) (quote parent))
(relations-rel (quote r) (quote t) (quote parent))
(relations-rel (quote s) (quote u) (quote parent))
(relations-rel (quote t) (quote u) (quote parent))))
(relations-tt-check!
"api common-ancestors"
(relations-tt-set=?
(relations/common-ancestors
(quote u)
(quote u)
(quote parent))
(list (quote r) (quote s) (quote t)))
true)
(relations-tt-check!
"api lca"
(relations-tt-set=?
(relations/lca (quote s) (quote t) (quote parent))
(list (quote r)))
true)
(relations-tt-check!
"api topo-order covers nodes"
(relations-tt-set=?
(relations/topo-order (quote parent))
(list (quote r) (quote s) (quote t) (quote u)))
true)
(relations/load! (list)))))))
(define
relations-tree-tests-run!
(fn
()
(do
(set! relations-tt-pass 0)
(set! relations-tt-fail 0)
(set! relations-tt-failures (list))
(relations-tt-run-all!)
{:failures relations-tt-failures :total (+ relations-tt-pass relations-tt-fail) :passed relations-tt-pass :failed relations-tt-fail})))