relations: tree/DAG queries (common-ancestors, lca, topo-order) in SX + 16 tests

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>

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!)"
 )

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"
 }

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 |

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})))

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)))

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