diff --git a/lib/relations/conformance.conf b/lib/relations/conformance.conf index db0bb321..a2a88c9a 100644 --- a/lib/relations/conformance.conf +++ b/lib/relations/conformance.conf @@ -19,6 +19,7 @@ PRELOADS=( lib/relations/api.sx lib/relations/explain.sx lib/relations/federation.sx + lib/relations/tree.sx ) SUITES=( @@ -27,4 +28,5 @@ SUITES=( "path:lib/relations/tests/path.sx:(relations-path-tests-run!)" "fed:lib/relations/tests/fed.sx:(relations-fed-tests-run!)" "shape:lib/relations/tests/shape.sx:(relations-shape-tests-run!)" + "tree:lib/relations/tests/tree.sx:(relations-tree-tests-run!)" ) diff --git a/lib/relations/scoreboard.json b/lib/relations/scoreboard.json index 08679104..08613c5b 100644 --- a/lib/relations/scoreboard.json +++ b/lib/relations/scoreboard.json @@ -1,14 +1,15 @@ { "lang": "relations", - "total_passed": 110, + "total_passed": 126, "total_failed": 0, - "total": 110, + "total": 126, "suites": [ {"name":"direct","passed":22,"failed":0,"total":22}, {"name":"reach","passed":24,"failed":0,"total":24}, {"name":"path","passed":24,"failed":0,"total":24}, {"name":"fed","passed":22,"failed":0,"total":22}, - {"name":"shape","passed":18,"failed":0,"total":18} + {"name":"shape","passed":18,"failed":0,"total":18}, + {"name":"tree","passed":16,"failed":0,"total":16} ], - "generated": "2026-06-07T12:55:58+00:00" + "generated": "2026-06-07T13:07:14+00:00" } diff --git a/lib/relations/scoreboard.md b/lib/relations/scoreboard.md index bffff9d0..8974ab10 100644 --- a/lib/relations/scoreboard.md +++ b/lib/relations/scoreboard.md @@ -1,6 +1,6 @@ # relations scoreboard -**110 / 110 passing** (0 failure(s)). +**126 / 126 passing** (0 failure(s)). | Suite | Passed | Total | Status | |-------|--------|-------|--------| @@ -9,3 +9,4 @@ | path | 24 | 24 | ok | | fed | 22 | 22 | ok | | shape | 18 | 18 | ok | +| tree | 16 | 16 | ok | diff --git a/lib/relations/tests/tree.sx b/lib/relations/tests/tree.sx new file mode 100644 index 00000000..96020631 --- /dev/null +++ b/lib/relations/tests/tree.sx @@ -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}))) diff --git a/lib/relations/tree.sx b/lib/relations/tree.sx new file mode 100644 index 00000000..931ef883 --- /dev/null +++ b/lib/relations/tree.sx @@ -0,0 +1,118 @@ +;; lib/relations/tree.sx — tree/DAG queries: common ancestors, LCA, topo order. +;; +;; All computed in SX over the engine's fast `reach`/`ancestors`/`rnode` queries +;; — no new Datalog closures (every dl-query re-saturates, so derived graph +;; algorithms stay in SX). Kind-parameterised throughout, like the rest of the +;; engine. LCA returns a SET (a DAG may have several lowest common ancestors; a +;; tree yields exactly one). topo-order returns nil for a cyclic kind. + +(define + relations-tree-any? + (fn + (pred xs) + (cond + ((= (len xs) 0) false) + ((pred (first xs)) true) + (else (relations-tree-any? pred (rest xs)))))) + +(define + relations-intersect + (fn (xs ys) (filter (fn (x) (relations-eng-member? x ys)) xs))) + +(define + relations-subset? + (fn + (xs ys) + (cond + ((= (len xs) 0) true) + ((relations-eng-member? (first xs) ys) + (relations-subset? (rest xs) ys)) + (else false)))) + +;; All nodes touched by a kind (the materialised rnode relation — one query). +(define + relations-nodes + (fn + (db kind) + (relations-dedup + (relations-pluck + (dl-query db (list (quote rnode) kind (quote X))) + :X)))) + +;; Common ancestors of a and b under kind (set intersection of the two +;; ancestor sets). +(define + relations-common-ancestors + (fn + (db a b kind) + (relations-intersect + (relations-ancestors db a kind) + (relations-ancestors db b kind)))) + +;; Lowest common ancestors: common ancestors with no other common ancestor +;; strictly below them (none reachable from them). A tree gives a singleton; a +;; DAG may give several. Empty when a and b share no ancestor. +(define + relations-lca + (fn + (db a b kind) + (let + ((common (relations-common-ancestors db a b kind))) + (filter + (fn + (x) + (not + (relations-tree-any? + (fn + (y) + (and (not (= x y)) (relations-reachable? db x y kind))) + common))) + common)))) + +;; Kahn-style topological order: repeatedly place every node whose parents are +;; all already placed. Returns the node list in topological order, or nil if the +;; kind has a cycle. +(define + relations-topo-kahn + (fn + (db kind remaining placed) + (if + (= (len remaining) 0) + placed + (let + ((ready (filter (fn (n) (relations-subset? (relations-parents-of db n kind) placed)) remaining))) + (if + (= (len ready) 0) + placed + (relations-topo-kahn + db + kind + (filter + (fn (n) (not (relations-eng-member? n ready))) + remaining) + (append placed ready))))))) + +(define + relations-topo-order + (fn + (db kind) + (if + (relations-acyclic? db kind) + (relations-topo-kahn db kind (relations-nodes db kind) (list)) + nil))) + +;; --- current-db convenience layer --- + +(define + relations/common-ancestors + (fn + (a b kind) + (relations-common-ancestors (relations-ensure-db!) a b kind))) + +(define + relations/lca + (fn (a b kind) (relations-lca (relations-ensure-db!) a b kind))) + +(define + relations/topo-order + (fn (kind) (relations-topo-order (relations-ensure-db!) kind))) diff --git a/plans/relations-on-sx.md b/plans/relations-on-sx.md index 8d78768c..768a69bc 100644 --- a/plans/relations-on-sx.md +++ b/plans/relations-on-sx.md @@ -18,7 +18,7 @@ links. Reuses `lib/datalog/` — does not reimplement the engine. ## Status (rolling) -`bash lib/relations/conformance.sh` → **110/110** (Phases 1–4 complete + extensions) +`bash lib/relations/conformance.sh` → **126/126** (Phases 1–4 complete + extensions) ## Ground rules @@ -104,9 +104,23 @@ lib/relations/federation.sx `in-degree`, weakly-connected `connected?` (undirected reachability). Computed in SX over the fast direct `erel` queries (BFS) — deliberately NOT added as Datalog closures, to keep the per-query saturation cheap. `lib/relations/tests/shape.sx`. +- [x] **tree/DAG queries** — `common-ancestors` (ancestor-set intersection), `lca` + (lowest common ancestors — a set; tree → singleton, DAG → may be several), + `topo-order` (Kahn-style; nil for cyclic kinds). New `lib/relations/tree.sx`, + computed in SX over `reach`/`ancestors`/`rnode`. `lib/relations/tests/tree.sx`. ## Progress log +- **Extension: tree/DAG queries** (126/126). New `lib/relations/tree.sx`: + `relations-common-ancestors` (intersection of the two ancestor sets), + `relations-lca` (common ancestors with no other common ancestor reachable below + them — a SET, since a DAG can have several lowest common ancestors; a tree gives + one), `relations-topo-order` (Kahn-style level-by-level: place every node whose + parents are all placed; nil for a cyclic kind) + `relations-nodes` (the `rnode` + set) and `relations/...` wrappers. All in SX over the engine's fast queries — + again no new Datalog closures. `tree.sx` (16 tests) covers diamond common + ancestors, LCA on tree vs converging-DAG, no-common-ancestor, topo validity + (parents precede children), and cyclic-kind → nil. - **Extension: shape queries** (110/110). Added `relations-siblings`, `relations-out-degree`/`-in-degree`, `relations-connected?` (+ `relations/...` current-db wrappers) and `shape.sx` (18 tests). Design note: an earlier attempt