diff --git a/lib/relations/api.sx b/lib/relations/api.sx index 1cdbedbf..61880e00 100644 --- a/lib/relations/api.sx +++ b/lib/relations/api.sx @@ -84,3 +84,19 @@ (define relations/acyclic? (fn (kind) (relations-acyclic? (relations-ensure-db!) kind))) + +(define + relations/siblings + (fn (node kind) (relations-siblings (relations-ensure-db!) node kind))) + +(define + relations/out-degree + (fn (node kind) (relations-out-degree (relations-ensure-db!) node kind))) + +(define + relations/in-degree + (fn (node kind) (relations-in-degree (relations-ensure-db!) node kind))) + +(define + relations/connected? + (fn (a b kind) (relations-connected? (relations-ensure-db!) a b kind))) diff --git a/lib/relations/conformance.conf b/lib/relations/conformance.conf index eb83b880..db0bb321 100644 --- a/lib/relations/conformance.conf +++ b/lib/relations/conformance.conf @@ -26,4 +26,5 @@ SUITES=( "reach:lib/relations/tests/reach.sx:(relations-reach-tests-run!)" "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!)" ) diff --git a/lib/relations/engine.sx b/lib/relations/engine.sx index b165cd47..1b934ac1 100644 --- a/lib/relations/engine.sx +++ b/lib/relations/engine.sx @@ -1,8 +1,14 @@ -;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles. +;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles + +;; shape queries. ;; -;; The whole engine is one Datalog ruleset, derived from the EFFECTIVE relation -;; `erel`, not raw `rel`. `erel` unions local edges with trust-gated federated -;; edges: +;; The Datalog ruleset is deliberately MINIMAL — every dl-query re-saturates it, +;; so each added recursive relation taxes every query in every suite. Reachability +;; (`reach`/`reach_any`), node membership (`rnode`) and root/leaf are the only +;; derived relations; the shape queries (siblings, undirected connectivity) are +;; computed in SX over the fast direct `erel` queries, NOT as extra closures. +;; +;; The ruleset derives from the EFFECTIVE relation `erel`, not raw `rel`. `erel` +;; unions local edges with trust-gated federated edges: ;; ;; erel(S,D,K) :- rel(S,D,K). ; local edge, always ;; erel(S,D,K) :- peer_rel(P,S,D,K), trust(P). ; peer edge, gated by trust @@ -18,13 +24,11 @@ ;; reach(K,X,Y) :- erel(X,Y,K). ; one hop ;; reach(K,X,Y) :- erel(X,Z,K), reach(K,Z,Y). ; transitive ;; -;; `reach_any` is the kind-agnostic closure (any edge, any kind) used for -;; mixed-kind reachability — distinct from single-kind `reach`. -;; -;; rnode collects the nodes touched by a kind; root/leaf are those with no -;; incoming / no outgoing edge (stratified negation over has_parent/has_child). -;; Cycles are ordinary data: `reach(K,X,X)` simply holds for nodes on a cycle — -;; cycle?/acyclic? are queries, not errors. Do not assume a DAG. +;; `reach_any` is the kind-agnostic closure (any edge, any kind) for mixed-kind +;; reachability. rnode collects the nodes touched by a kind; root/leaf are those +;; with no incoming / no outgoing edge (stratified negation). Cycles are ordinary +;; data: `reach(K,X,X)` simply holds for nodes on a cycle — cycle?/acyclic? are +;; queries, not errors. Do not assume a DAG. (define relations-rules @@ -47,6 +51,44 @@ relations-pluck (fn (substs key) (map (fn (s) (get s key)) substs))) +;; Membership without host-name clashes (schema.sx defines relations-member?, +;; but engine.sx may load before schema in ad-hoc sessions — keep a local copy). +(define + relations-eng-member? + (fn + (x xs) + (cond + ((= (len xs) 0) false) + ((= (first xs) x) true) + (else (relations-eng-member? x (rest xs)))))) + +(define + relations-concat-map + (fn + (f xs) + (if + (= (len xs) 0) + (list) + (append (f (first xs)) (relations-concat-map f (rest xs)))))) + +(define + relations-dedup + (fn + (xs) + (if + (= (len xs) 0) + (list) + (let + ((r (relations-dedup (rest xs)))) + (if + (relations-eng-member? (first xs) r) + r + (append (list (first xs)) r)))))) + +(define + relations-without + (fn (x xs) (filter (fn (e) (not (= e x))) xs))) + ;; Direct children: every Dst with an effective edge erel(node, Dst, kind). (define relations-children-of @@ -144,3 +186,51 @@ (= (len (dl-query db (list (quote reach) kind (quote X) (quote X)))) 0))) + +;; Siblings: nodes sharing a parent with node under kind (excluding node). +;; Computed in SX over direct queries — no extra Datalog closure. +(define + relations-siblings + (fn + (db node kind) + (relations-without + node + (relations-dedup + (relations-concat-map + (fn (p) (relations-children-of db p kind)) + (relations-parents-of db node kind)))))) + +;; Out-degree: number of direct children under kind. +(define + relations-out-degree + (fn (db node kind) (len (relations-children-of db node kind)))) + +;; In-degree: number of direct parents under kind. +(define + relations-in-degree + (fn (db node kind) (len (relations-parents-of db node kind)))) + +;; Undirected BFS frontier expansion: grow `visited` by neighbours (either +;; direction) until the frontier is empty. Reuses the fast `erel` queries. +(define + relations-ureach-bfs + (fn + (db kind frontier visited) + (if + (= (len frontier) 0) + visited + (let + ((fresh (filter (fn (n) (not (relations-eng-member? n visited))) (relations-dedup (relations-concat-map (fn (n) (relations-related db n kind)) frontier))))) + (relations-ureach-bfs db kind fresh (append visited fresh)))))) + +;; Weakly connected: a and b joined by a path ignoring edge direction, under +;; kind. (Reflexive — a node is connected to itself.) +(define + relations-connected? + (fn + (db a b kind) + (or + (= a b) + (relations-eng-member? + b + (relations-ureach-bfs db kind (list a) (list a)))))) diff --git a/lib/relations/scoreboard.json b/lib/relations/scoreboard.json index 29896f59..08679104 100644 --- a/lib/relations/scoreboard.json +++ b/lib/relations/scoreboard.json @@ -1,13 +1,14 @@ { "lang": "relations", - "total_passed": 92, + "total_passed": 110, "total_failed": 0, - "total": 92, + "total": 110, "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":"fed","passed":22,"failed":0,"total":22}, + {"name":"shape","passed":18,"failed":0,"total":18} ], - "generated": "2026-06-07T12:14:10+00:00" + "generated": "2026-06-07T12:55:58+00:00" } diff --git a/lib/relations/scoreboard.md b/lib/relations/scoreboard.md index e67ca3c1..bffff9d0 100644 --- a/lib/relations/scoreboard.md +++ b/lib/relations/scoreboard.md @@ -1,6 +1,6 @@ # relations scoreboard -**92 / 92 passing** (0 failure(s)). +**110 / 110 passing** (0 failure(s)). | Suite | Passed | Total | Status | |-------|--------|-------|--------| @@ -8,3 +8,4 @@ | reach | 24 | 24 | ok | | path | 24 | 24 | ok | | fed | 22 | 22 | ok | +| shape | 18 | 18 | ok | diff --git a/lib/relations/tests/shape.sx b/lib/relations/tests/shape.sx new file mode 100644 index 00000000..06e40d88 --- /dev/null +++ b/lib/relations/tests/shape.sx @@ -0,0 +1,161 @@ +;; lib/relations/tests/shape.sx — extension: siblings, degree, undirected +;; connectivity. + +(define relations-st-pass 0) +(define relations-st-fail 0) +(define relations-st-failures (list)) + +(define + relations-st-check! + (fn + (name got expected) + (if + (= got expected) + (set! relations-st-pass (+ relations-st-pass 1)) + (do + (set! relations-st-fail (+ relations-st-fail 1)) + (append! + relations-st-failures + (str name "\n expected: " expected "\n got: " got)))))) + +(define + relations-st-subset? + (fn + (xs ys) + (cond + ((= (len xs) 0) true) + ((relations-member? (first xs) ys) + (relations-st-subset? (rest xs) ys)) + (else false)))) + +(define + relations-st-set=? + (fn + (xs ys) + (and + (= (len xs) (len ys)) + (relations-st-subset? xs ys) + (relations-st-subset? ys xs)))) + +;; A small tree plus a disconnected pair. +;; parent: p->a, p->b, p->c, a->d ; q->r (disconnected) +;; member: m->x, m->y (a different kind, same db) +(define + relations-st-fixture + (fn + () + (relations-build-db + (list + (relations-rel (quote p) (quote a) (quote parent)) + (relations-rel (quote p) (quote b) (quote parent)) + (relations-rel (quote p) (quote c) (quote parent)) + (relations-rel (quote a) (quote d) (quote parent)) + (relations-rel (quote q) (quote r) (quote parent)) + (relations-rel (quote m) (quote x) (quote member)) + (relations-rel (quote m) (quote y) (quote member)))))) + +(define + relations-st-run-all! + (fn + () + (let + ((db (relations-st-fixture))) + (do + (relations-st-check! + "siblings of a" + (relations-st-set=? + (relations-siblings db (quote a) (quote parent)) + (list (quote b) (quote c))) + true) + (relations-st-check! + "only child has no siblings" + (relations-siblings db (quote d) (quote parent)) + (list)) + (relations-st-check! + "siblings respect kind" + (relations-st-set=? + (relations-siblings db (quote x) (quote member)) + (list (quote y))) + true) + (relations-st-check! + "no cross-kind siblings" + (relations-siblings db (quote a) (quote member)) + (list)) + (relations-st-check! + "out-degree of p" + (relations-out-degree db (quote p) (quote parent)) + 3) + (relations-st-check! + "out-degree of a" + (relations-out-degree db (quote a) (quote parent)) + 1) + (relations-st-check! + "out-degree of leaf" + (relations-out-degree db (quote d) (quote parent)) + 0) + (relations-st-check! + "in-degree of a" + (relations-in-degree db (quote a) (quote parent)) + 1) + (relations-st-check! + "in-degree of root" + (relations-in-degree db (quote p) (quote parent)) + 0) + (relations-st-check! + "siblings are connected" + (relations-connected? db (quote b) (quote c) (quote parent)) + true) + (relations-st-check! + "cousin connected (b <-> d)" + (relations-connected? db (quote b) (quote d) (quote parent)) + true) + (relations-st-check! + "self connected" + (relations-connected? db (quote a) (quote a) (quote parent)) + true) + (relations-st-check! + "disconnected components not connected" + (relations-connected? db (quote a) (quote q) (quote parent)) + false) + (relations-st-check! + "directed-unreachable but undirected-connected" + (and + (not + (relations-reachable? db (quote b) (quote c) (quote parent))) + (relations-connected? db (quote b) (quote c) (quote parent))) + true) + (relations-st-check! + "connectivity respects kind" + (relations-connected? db (quote a) (quote x) (quote member)) + false) + (do + (relations/load! + (list + (relations-rel (quote g) (quote h) (quote parent)) + (relations-rel (quote g) (quote i) (quote parent)))) + (relations-st-check! + "api siblings" + (relations-st-set=? + (relations/siblings (quote h) (quote parent)) + (list (quote i))) + true) + (relations-st-check! + "api out-degree" + (relations/out-degree (quote g) (quote parent)) + 2) + (relations-st-check! + "api connected" + (relations/connected? (quote h) (quote i) (quote parent)) + true) + (relations/load! (list))))))) + +(define + relations-shape-tests-run! + (fn + () + (do + (set! relations-st-pass 0) + (set! relations-st-fail 0) + (set! relations-st-failures (list)) + (relations-st-run-all!) + {:failures relations-st-failures :total (+ relations-st-pass relations-st-fail) :passed relations-st-pass :failed relations-st-fail}))) diff --git a/plans/relations-on-sx.md b/plans/relations-on-sx.md index 56ec10e6..8d78768c 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` → **92/92** (Phases 1–4 complete) +`bash lib/relations/conformance.sh` → **110/110** (Phases 1–4 complete + extensions) ## Ground rules @@ -98,8 +98,27 @@ lib/relations/federation.sx - [x] `lib/relations/tests/fed.sx` — federated reachability chains, trust gating, revocation +## Extensions (post-roadmap) + +- [x] **shape queries** — `siblings` (nodes sharing a parent), `out-degree`/ + `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`. + ## Progress log +- **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 + added `sibling`/`uedge`/`ureach` as Datalog rules in the global `relations-rules`; + because every `dl-query` re-saturates the whole program, the extra recursive + undirected closure taxed EVERY query in EVERY suite and the full run blew past + 10 min. Reverted the ruleset to the Phase-4 set and compute these in SX instead: + siblings = children-of(parents-of(node)) − node; connected? = undirected BFS + expanding `relations-related` (children ∪ parents) per frontier with a visited + set. No new saturation cost; other suites unaffected. NB: the full 110-test + conformance takes several minutes under shared-machine contention (sibling loops) + — run with `timeout 1200` in the background; individual suites run in seconds. - **Phase 4 — federation** (92/92). Re-derived acl's trust-gate shape (not copied). engine.sx now derives the whole engine from an EFFECTIVE relation `erel` rather than raw `rel`: `erel(S,D,K) :- rel(S,D,K)` (local, always) and