diff --git a/lib/relations/api.sx b/lib/relations/api.sx index ac9ae314..3212e03e 100644 --- a/lib/relations/api.sx +++ b/lib/relations/api.sx @@ -1,25 +1,18 @@ -;; lib/relations/api.sx — relationship lifecycle + direct queries over lib/datalog/. +;; lib/relations/api.sx — relationship lifecycle + queries over lib/datalog/. ;; -;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts. Phase 1 -;; uses no rules — direct children/parents are plain queries on the rel -;; relation. Phase 2's engine.sx adds recursive reachability rules; build-db -;; will fold them in then. +;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts under the +;; engine ruleset (lib/relations/engine.sx). Direct children/parents are plain +;; queries on the rel relation; transitive reachability/roots/leaves/cycles come +;; from the engine's recursive rules. ;; ;; Two surfaces: db-threading core fns (relations-children-of db ...) and a ;; current-db convenience layer (relations/relate ...) for callers that load a ;; fact base once and query without passing the db around. This mirrors lib/acl. -(define relations-rules (list)) - (define relations-build-db (fn (facts) (dl-program-data facts relations-rules))) -;; Pull one column (by keyword key) out of a list of substitution dicts. -(define - relations-pluck - (fn (substs key) (map (fn (s) (get s key)) substs))) - ;; Direct children: every Dst with rel(node, Dst, kind). (define relations-children-of @@ -94,3 +87,31 @@ (define relations/related (fn (node kind) (relations-related (relations-ensure-db!) node kind))) + +(define + relations/descendants + (fn (node kind) (relations-descendants (relations-ensure-db!) node kind))) + +(define + relations/ancestors + (fn (node kind) (relations-ancestors (relations-ensure-db!) node kind))) + +(define + relations/reachable? + (fn (a b kind) (relations-reachable? (relations-ensure-db!) a b kind))) + +(define + relations/roots + (fn (kind) (relations-roots (relations-ensure-db!) kind))) + +(define + relations/leaves + (fn (kind) (relations-leaves (relations-ensure-db!) kind))) + +(define + relations/cycle? + (fn (node kind) (relations-cycle? (relations-ensure-db!) node kind))) + +(define + relations/acyclic? + (fn (kind) (relations-acyclic? (relations-ensure-db!) kind))) diff --git a/lib/relations/conformance.conf b/lib/relations/conformance.conf index 3acbb50d..129bb74b 100644 --- a/lib/relations/conformance.conf +++ b/lib/relations/conformance.conf @@ -15,9 +15,11 @@ PRELOADS=( lib/datalog/api.sx lib/datalog/magic.sx lib/relations/schema.sx + lib/relations/engine.sx lib/relations/api.sx ) SUITES=( "direct:lib/relations/tests/direct.sx:(relations-direct-tests-run!)" + "reach:lib/relations/tests/reach.sx:(relations-reach-tests-run!)" ) diff --git a/lib/relations/engine.sx b/lib/relations/engine.sx new file mode 100644 index 00000000..af75696b --- /dev/null +++ b/lib/relations/engine.sx @@ -0,0 +1,86 @@ +;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles. +;; +;; The whole engine is one Datalog ruleset. Reachability is the bottom-up +;; transitive closure acl-on-sx uses for inheritance, but parameterised by Kind +;; so closures never leak across kinds: `reach` carries the kind as its first +;; argument, so a `parent` walk can never cross a `reply` edge. +;; +;; reach(K,X,Y) :- rel(X,Y,K). ; one hop +;; reach(K,X,Y) :- rel(X,Z,K), reach(K,Z,Y). ; transitive +;; +;; 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. + +(define + relations-rules + (quote + ((reach K X Y <- (rel X Y K)) + (reach K X Y <- (rel X Z K) (reach K Z Y)) + (rnode K X <- (rel X Y K)) + (rnode K Y <- (rel X Y K)) + (has_parent K Y <- (rel X Y K)) + (has_child K X <- (rel X Y K)) + (root K X <- (rnode K X) {:neg (has_parent K X)}) + (leaf K X <- (rnode K X) {:neg (has_child K X)})))) + +;; Pull one column (by keyword key) out of a list of substitution dicts. +(define + relations-pluck + (fn (substs key) (map (fn (s) (get s key)) substs))) + +;; Transitive descendants of node under kind (everything reachable forward). +(define + relations-descendants + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote reach) kind node (quote Y))) + :Y))) + +;; Transitive ancestors of node under kind (everything that reaches node). +(define + relations-ancestors + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote reach) kind (quote X) node)) + :X))) + +;; Is b reachable from a under kind (transitive)? +(define + relations-reachable? + (fn + (db a b kind) + (> (len (dl-query db (list (quote reach) kind a b))) 0))) + +;; Roots: nodes touched by kind with no incoming edge. +(define + relations-roots + (fn + (db kind) + (relations-pluck (dl-query db (list (quote root) kind (quote X))) :X))) + +;; Leaves: nodes touched by kind with no outgoing edge. +(define + relations-leaves + (fn + (db kind) + (relations-pluck (dl-query db (list (quote leaf) kind (quote X))) :X))) + +;; Is node on a cycle under kind (reachable from itself)? +(define + relations-cycle? + (fn + (db node kind) + (> (len (dl-query db (list (quote reach) kind node node))) 0))) + +;; Has the kind any cycle at all? (no node reaches itself) +(define + relations-acyclic? + (fn + (db kind) + (= + (len (dl-query db (list (quote reach) kind (quote X) (quote X)))) + 0))) diff --git a/lib/relations/scoreboard.json b/lib/relations/scoreboard.json index 725f41bd..499c91f1 100644 --- a/lib/relations/scoreboard.json +++ b/lib/relations/scoreboard.json @@ -1,10 +1,11 @@ { "lang": "relations", - "total_passed": 22, + "total_passed": 46, "total_failed": 0, - "total": 22, + "total": 46, "suites": [ - {"name":"direct","passed":22,"failed":0,"total":22} + {"name":"direct","passed":22,"failed":0,"total":22}, + {"name":"reach","passed":24,"failed":0,"total":24} ], - "generated": "2026-06-07T11:41:50+00:00" + "generated": "2026-06-07T11:51:39+00:00" } diff --git a/lib/relations/scoreboard.md b/lib/relations/scoreboard.md index f46f795f..44e38ec5 100644 --- a/lib/relations/scoreboard.md +++ b/lib/relations/scoreboard.md @@ -1,7 +1,8 @@ # relations scoreboard -**22 / 22 passing** (0 failure(s)). +**46 / 46 passing** (0 failure(s)). | Suite | Passed | Total | Status | |-------|--------|-------|--------| | direct | 22 | 22 | ok | +| reach | 24 | 24 | ok | diff --git a/lib/relations/tests/reach.sx b/lib/relations/tests/reach.sx new file mode 100644 index 00000000..78e1abe1 --- /dev/null +++ b/lib/relations/tests/reach.sx @@ -0,0 +1,204 @@ +;; lib/relations/tests/reach.sx — Phase 2: reachability, roots/leaves, cycles. + +(define relations-rt-pass 0) +(define relations-rt-fail 0) +(define relations-rt-failures (list)) + +(define + relations-rt-check! + (fn + (name got expected) + (if + (= got expected) + (set! relations-rt-pass (+ relations-rt-pass 1)) + (do + (set! relations-rt-fail (+ relations-rt-fail 1)) + (append! + relations-rt-failures + (str name "\n expected: " expected "\n got: " got)))))) + +(define + relations-rt-subset? + (fn + (xs ys) + (cond + ((= (len xs) 0) true) + ((relations-member? (first xs) ys) + (relations-rt-subset? (rest xs) ys)) + (else false)))) + +(define + relations-rt-set=? + (fn + (xs ys) + (and + (= (len xs) (len ys)) + (relations-rt-subset? xs ys) + (relations-rt-subset? ys xs)))) + +;; Diamond + a disconnected pair under parent, plus a reply cross-edge. +;; parent: a->b, a->c, b->d, c->d ; e->f +;; reply: b->z +(define + relations-rt-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 e) (quote f) (quote parent)) + (relations-rel (quote b) (quote z) (quote reply)))))) + +;; Cycles: c1<->c2, self-loop s->s, plus acyclic t->u, all under parent. +(define + relations-rt-cyc-fixture + (fn + () + (relations-build-db + (list + (relations-rel (quote c1) (quote c2) (quote parent)) + (relations-rel (quote c2) (quote c1) (quote parent)) + (relations-rel (quote s) (quote s) (quote parent)) + (relations-rel (quote t) (quote u) (quote parent)))))) + +(define + relations-rt-run-all! + (fn + () + (let + ((db (relations-rt-fixture)) (cyc (relations-rt-cyc-fixture))) + (do + (relations-rt-check! + "descendants of a (diamond)" + (relations-rt-set=? + (relations-descendants db (quote a) (quote parent)) + (list (quote b) (quote c) (quote d))) + true) + (relations-rt-check! + "ancestors of d (diamond)" + (relations-rt-set=? + (relations-ancestors db (quote d) (quote parent)) + (list (quote a) (quote b) (quote c))) + true) + (relations-rt-check! + "reachable a->d" + (relations-reachable? db (quote a) (quote d) (quote parent)) + true) + (relations-rt-check! + "not reachable d->a" + (relations-reachable? db (quote d) (quote a) (quote parent)) + false) + (relations-rt-check! + "disconnected components" + (relations-reachable? db (quote a) (quote f) (quote parent)) + false) + (relations-rt-check! + "leaf has no descendants" + (relations-descendants db (quote d) (quote parent)) + (list)) + (relations-rt-check! + "root has no ancestors" + (relations-ancestors db (quote a) (quote parent)) + (list)) + (relations-rt-check! + "roots under parent" + (relations-rt-set=? + (relations-roots db (quote parent)) + (list (quote a) (quote e))) + true) + (relations-rt-check! + "leaves under parent" + (relations-rt-set=? + (relations-leaves db (quote parent)) + (list (quote d) (quote f))) + true) + (relations-rt-check! + "parent descendants exclude reply target" + (relations-member? + (quote z) + (relations-descendants db (quote a) (quote parent))) + false) + (relations-rt-check! + "reply reachable b->z" + (relations-reachable? db (quote b) (quote z) (quote reply)) + true) + (relations-rt-check! + "parent unreachable a->z" + (relations-reachable? db (quote a) (quote z) (quote parent)) + false) + (relations-rt-check! + "diamond is acyclic" + (relations-acyclic? db (quote parent)) + true) + (relations-rt-check! + "no node cycles in diamond" + (relations-cycle? db (quote a) (quote parent)) + false) + (relations-rt-check! + "c1 is on a cycle" + (relations-cycle? cyc (quote c1) (quote parent)) + true) + (relations-rt-check! + "self-loop counts as cycle" + (relations-cycle? cyc (quote s) (quote parent)) + true) + (relations-rt-check! + "acyclic node t not on cycle" + (relations-cycle? cyc (quote t) (quote parent)) + false) + (relations-rt-check! + "kind with a cycle is not acyclic" + (relations-acyclic? cyc (quote parent)) + false) + (relations-rt-check! + "cycle reachable both ways" + (and + (relations-reachable? cyc (quote c1) (quote c2) (quote parent)) + (relations-reachable? cyc (quote c2) (quote c1) (quote parent))) + true) + (relations-rt-check! + "node in cycle reaches itself" + (relations-member? + (quote c1) + (relations-descendants cyc (quote c1) (quote parent))) + true) + (do + (relations/load! + (list + (relations-rel (quote r) (quote m) (quote parent)) + (relations-rel (quote m) (quote n) (quote parent)))) + (relations-rt-check! + "api descendants" + (relations-rt-set=? + (relations/descendants (quote r) (quote parent)) + (list (quote m) (quote n))) + true) + (relations-rt-check! + "api reachable" + (relations/reachable? (quote r) (quote n) (quote parent)) + true) + (relations-rt-check! + "api roots" + (relations-rt-set=? + (relations/roots (quote parent)) + (list (quote r))) + true) + (relations-rt-check! + "api acyclic" + (relations/acyclic? (quote parent)) + true) + (relations/load! (list))))))) + +(define + relations-reach-tests-run! + (fn + () + (do + (set! relations-rt-pass 0) + (set! relations-rt-fail 0) + (set! relations-rt-failures (list)) + (relations-rt-run-all!) + {:failures relations-rt-failures :total (+ relations-rt-pass relations-rt-fail) :passed relations-rt-pass :failed relations-rt-fail}))) diff --git a/plans/relations-on-sx.md b/plans/relations-on-sx.md index 2436d83f..6cc26b6e 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` → **22/22** (Phase 1 complete) +`bash lib/relations/conformance.sh` → **46/46** (Phases 1–2 complete) ## Ground rules @@ -72,11 +72,11 @@ lib/relations/federation.sx ## Phase 2 — Reachability + cycles -- [ ] recursive reachability rules: `ancestors`, `descendants`, `reachable?(A,B)` +- [x] recursive reachability rules: `ancestors`, `descendants`, `reachable?(A,B)` (transitive closure over a kind, the acl inheritance shape) -- [ ] `roots` / `leaves` (no parents / no children) for a kind -- [ ] cycle detection: `cycle?(X)` ⇔ `reachable(X, X)`; `acyclic?(db, kind)` -- [ ] `lib/relations/tests/reach.sx` — deep chains, diamonds, disconnected nodes, +- [x] `roots` / `leaves` (no parents / no children) for a kind +- [x] cycle detection: `cycle?(X)` ⇔ `reachable(X, X)`; `acyclic?(db, kind)` +- [x] `lib/relations/tests/reach.sx` — deep chains, diamonds, disconnected nodes, self-loops, multi-kind isolation ## Phase 3 — Typed relations + path explanation @@ -100,6 +100,21 @@ lib/relations/federation.sx ## Progress log +- **Phase 2 — reachability + cycles** (46/46). New `engine.sx` is one Datalog + ruleset. Reachability is kind-parameterised — `reach(K,X,Y)` carries the kind as + its first arg so a transitive walk over `parent` never leaks through `reply` + edges (the acl inheritance shape, but closures can't cross kinds). `rnode` + collects touched nodes; `root`/`leaf` use stratified negation over + `has_parent`/`has_child`. Cycles are data, not errors: `cycle?(node,kind)` ⇔ + `reach(K,node,node)` holds, `acyclic?(kind)` ⇔ no `reach(K,X,X)`. Engine fns: + `relations-descendants/-ancestors/-reachable?/-roots/-leaves/-cycle?/-acyclic?`; + api.sx grew matching `relations/...` current-db wrappers. `relations-rules` and + `relations-pluck` moved from api.sx into engine.sx (engine now loads before api + in conformance.conf). reach.sx covers diamonds, deep chains, disconnected + components, self-loops, c1<->c2 cycles, and multi-kind isolation. acl + convergence: the `reach(X,Y):-edge(X,Y)` / `reach(X,Y):-edge(X,Z),reach(Z,Y)` + closure shape is shared with acl's eff_grant/eff_deny inheritance — flagged, not + extracted (per ground rules). - **Phase 1 — schema + direct relations** (22/22). `schema.sx`: `rel(Src,Dst,Kind)` fact constructor + accessors, open kind vocabulary (`parent member reply variant origin link`), `relations-fact-valid?`/`relations-known-kind?`. `api.sx`: db built