Merge loops/relations into architecture: relations-on-sx — cross-domain relationship graph on Datalog
Reachability/ancestors/descendants, shortest path + all-route enumeration, cycle detection, roots/leaves, siblings/degree, ancestors/LCA/topo-order, weakly-connected components, trust-gated federation, and bulk lifecycle (relate-many/unrelate-node cascade). Engine derives from an effective relation erel (local edges + trust-gated peer links); graph algorithms computed in SX over the minimal Datalog ruleset (every query re-saturates). 158/158, 9 suites. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
141
lib/relations/api.sx
Normal file
141
lib/relations/api.sx
Normal file
@@ -0,0 +1,141 @@
|
||||
;; lib/relations/api.sx — relationship lifecycle + current-db convenience layer.
|
||||
;;
|
||||
;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts (and, for
|
||||
;; federation, peer_rel/trust facts) under the engine ruleset
|
||||
;; (lib/relations/engine.sx). The query functions live in engine.sx; this module
|
||||
;; owns db construction, the assert/retract lifecycle, and a current-db
|
||||
;; convenience layer for callers that load a fact base once and query without
|
||||
;; threading the db around. This mirrors lib/acl/api.sx.
|
||||
|
||||
(define
|
||||
relations-build-db
|
||||
(fn (facts) (dl-program-data facts relations-rules)))
|
||||
|
||||
(define relations-current-db nil)
|
||||
|
||||
(define
|
||||
relations/load!
|
||||
(fn
|
||||
(facts)
|
||||
(do
|
||||
(set! relations-current-db (relations-build-db facts))
|
||||
relations-current-db)))
|
||||
|
||||
(define
|
||||
relations-ensure-db!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(when
|
||||
(= relations-current-db nil)
|
||||
(set! relations-current-db (relations-build-db (list))))
|
||||
relations-current-db)))
|
||||
|
||||
;; Add a relationship to the current db (re-saturates).
|
||||
(define
|
||||
relations/relate
|
||||
(fn
|
||||
(src dst kind)
|
||||
(dl-assert! (relations-ensure-db!) (relations-rel src dst kind))))
|
||||
|
||||
;; Remove a relationship from the current db (re-saturates).
|
||||
(define
|
||||
relations/unrelate
|
||||
(fn
|
||||
(src dst kind)
|
||||
(dl-retract! (relations-ensure-db!) (relations-rel src dst kind))))
|
||||
|
||||
(define
|
||||
relations/children
|
||||
(fn (node kind) (relations-children-of (relations-ensure-db!) node kind)))
|
||||
|
||||
(define
|
||||
relations/parents
|
||||
(fn (node kind) (relations-parents-of (relations-ensure-db!) node kind)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(define
|
||||
relations-relate-many!
|
||||
(fn
|
||||
(db triples)
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(t)
|
||||
(dl-assert!
|
||||
db
|
||||
(relations-rel (first t) (nth t 1) (nth t 2))))
|
||||
triples)
|
||||
db)))
|
||||
|
||||
(define
|
||||
relations-unrelate-node!
|
||||
(fn
|
||||
(db node)
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(dl-retract! db (relations-rel node (get s :Dst) (get s :Kind))))
|
||||
(dl-query db (list (quote rel) node (quote Dst) (quote Kind))))
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(dl-retract! db (relations-rel (get s :Src) node (get s :Kind))))
|
||||
(dl-query db (list (quote rel) (quote Src) node (quote Kind))))
|
||||
db)))
|
||||
|
||||
(define
|
||||
relations/relate-many!
|
||||
(fn (triples) (relations-relate-many! (relations-ensure-db!) triples)))
|
||||
|
||||
(define
|
||||
relations/unrelate-node!
|
||||
(fn (node) (relations-unrelate-node! (relations-ensure-db!) node)))
|
||||
35
lib/relations/conformance.conf
Normal file
35
lib/relations/conformance.conf
Normal file
@@ -0,0 +1,35 @@
|
||||
# relations conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=relations
|
||||
MODE=dict
|
||||
|
||||
PRELOADS=(
|
||||
lib/datalog/tokenizer.sx
|
||||
lib/datalog/parser.sx
|
||||
lib/datalog/unify.sx
|
||||
lib/datalog/db.sx
|
||||
lib/datalog/builtins.sx
|
||||
lib/datalog/aggregates.sx
|
||||
lib/datalog/strata.sx
|
||||
lib/datalog/eval.sx
|
||||
lib/datalog/api.sx
|
||||
lib/datalog/magic.sx
|
||||
lib/relations/schema.sx
|
||||
lib/relations/engine.sx
|
||||
lib/relations/api.sx
|
||||
lib/relations/explain.sx
|
||||
lib/relations/federation.sx
|
||||
lib/relations/tree.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"direct:lib/relations/tests/direct.sx:(relations-direct-tests-run!)"
|
||||
"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!)"
|
||||
"tree:lib/relations/tests/tree.sx:(relations-tree-tests-run!)"
|
||||
"routes:lib/relations/tests/routes.sx:(relations-routes-tests-run!)"
|
||||
"bulk:lib/relations/tests/bulk.sx:(relations-bulk-tests-run!)"
|
||||
"comp:lib/relations/tests/comp.sx:(relations-comp-tests-run!)"
|
||||
)
|
||||
3
lib/relations/conformance.sh
Executable file
3
lib/relations/conformance.sh
Executable file
@@ -0,0 +1,3 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/relations/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
236
lib/relations/engine.sx
Normal file
236
lib/relations/engine.sx
Normal file
@@ -0,0 +1,236 @@
|
||||
;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles +
|
||||
;; shape queries.
|
||||
;;
|
||||
;; 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
|
||||
;;
|
||||
;; Trust is a body literal, re-checked every query, so revoking trust (or a peer
|
||||
;; link) takes effect on the next saturation. Trust is NOT transitive — only a
|
||||
;; peer's own links, under a local trust(P) fact, bind. With no peer_rel/trust
|
||||
;; facts, erel ≡ rel, so non-federated behaviour is unchanged.
|
||||
;;
|
||||
;; Reachability is the bottom-up transitive closure acl-on-sx uses for
|
||||
;; inheritance, parameterised by Kind so closures never leak across kinds:
|
||||
;;
|
||||
;; 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) 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
|
||||
(quote
|
||||
((erel S D K <- (rel S D K))
|
||||
(erel S D K <- (peer_rel P S D K) (trust P))
|
||||
(reach K X Y <- (erel X Y K))
|
||||
(reach K X Y <- (erel X Z K) (reach K Z Y))
|
||||
(reach_any X Y <- (erel X Y K))
|
||||
(reach_any X Y <- (erel X Z K) (reach_any Z Y))
|
||||
(rnode K X <- (erel X Y K))
|
||||
(rnode K Y <- (erel X Y K))
|
||||
(has_parent K Y <- (erel X Y K))
|
||||
(has_child K X <- (erel 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)))
|
||||
|
||||
;; 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
|
||||
(fn
|
||||
(db node kind)
|
||||
(relations-pluck
|
||||
(dl-query db (list (quote erel) node (quote Dst) kind))
|
||||
:Dst)))
|
||||
|
||||
;; Direct parents: every Src with an effective edge erel(Src, node, kind).
|
||||
(define
|
||||
relations-parents-of
|
||||
(fn
|
||||
(db node kind)
|
||||
(relations-pluck
|
||||
(dl-query db (list (quote erel) (quote Src) node kind))
|
||||
:Src)))
|
||||
|
||||
;; Directly related: neighbours in either direction under kind.
|
||||
(define
|
||||
relations-related
|
||||
(fn
|
||||
(db node kind)
|
||||
(append
|
||||
(relations-children-of db node kind)
|
||||
(relations-parents-of db node kind))))
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; Mixed-kind: descendants reachable from node over edges of ANY kind.
|
||||
(define
|
||||
relations-descendants-any
|
||||
(fn
|
||||
(db node)
|
||||
(relations-pluck
|
||||
(dl-query db (list (quote reach_any) node (quote Y)))
|
||||
:Y)))
|
||||
|
||||
;; Mixed-kind: is b reachable from a over edges of ANY kind?
|
||||
(define
|
||||
relations-reachable-any?
|
||||
(fn
|
||||
(db a b)
|
||||
(> (len (dl-query db (list (quote reach_any) 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)))
|
||||
|
||||
;; 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))))))
|
||||
112
lib/relations/explain.sx
Normal file
112
lib/relations/explain.sx
Normal file
@@ -0,0 +1,112 @@
|
||||
;; lib/relations/explain.sx — the connecting path: relations' answer to acl's
|
||||
;; proof tree.
|
||||
;;
|
||||
;; A `reach(K,a,b)` derivation is a chain of one-hop `rel` facts a→…→b. The path
|
||||
;; IS that derivation read off as the node sequence. lib/datalog/ records derived
|
||||
;; facts but not provenance, so we re-derive the chain over the saturated edge
|
||||
;; set — but breadth-first, so the path returned is a SHORTEST derivation (fewest
|
||||
;; hops). Every consecutive pair in the result is a real rel(x,y,kind) fact; no
|
||||
;; edges are invented. Cycles are handled by a visited set, so cyclic data
|
||||
;; terminates rather than looping.
|
||||
;;
|
||||
;; (relations-path db a b kind) → (a … b) | nil
|
||||
;; (relations-distance db a b k) → hop count | nil
|
||||
|
||||
(define relations-last (fn (xs) (nth xs (- (len xs) 1))))
|
||||
|
||||
(define
|
||||
relations-filter-unseen
|
||||
(fn (xs seen) (filter (fn (x) (not (relations-member? x seen))) xs)))
|
||||
|
||||
;; Breadth-first over the kind's edge set. `queue` is a list of partial paths
|
||||
;; (each a node list ending at its frontier node); `visited` is every node ever
|
||||
;; enqueued, so each node is expanded once and the first path to reach b is a
|
||||
;; shortest one.
|
||||
(define
|
||||
relations-path-bfs
|
||||
(fn
|
||||
(db b kind queue visited)
|
||||
(if
|
||||
(= (len queue) 0)
|
||||
nil
|
||||
(let
|
||||
((path (first queue)))
|
||||
(let
|
||||
((node (relations-last path)))
|
||||
(if
|
||||
(= node b)
|
||||
path
|
||||
(let
|
||||
((succs (relations-filter-unseen (relations-children-of db node kind) visited)))
|
||||
(relations-path-bfs
|
||||
db
|
||||
b
|
||||
kind
|
||||
(append
|
||||
(rest queue)
|
||||
(map (fn (s) (append path (list s))) succs))
|
||||
(append visited succs)))))))))
|
||||
|
||||
;; The connecting chain a→…→b under kind (shortest), or nil if unreachable.
|
||||
;; a = b returns the trivial one-node path.
|
||||
(define
|
||||
relations-path
|
||||
(fn
|
||||
(db a b kind)
|
||||
(if
|
||||
(= a b)
|
||||
(list a)
|
||||
(relations-path-bfs db b kind (list (list a)) (list a)))))
|
||||
|
||||
;; Hop count of the shortest path (0 for a=b), or nil if unreachable.
|
||||
(define
|
||||
relations-distance
|
||||
(fn
|
||||
(db a b kind)
|
||||
(let
|
||||
((p (relations-path db a b kind)))
|
||||
(if (= p nil) nil (- (len p) 1)))))
|
||||
|
||||
;; --- current-db convenience layer ---
|
||||
|
||||
(define
|
||||
relations-ap-dfs
|
||||
(fn
|
||||
(db b kind path node)
|
||||
(if
|
||||
(= node b)
|
||||
(list path)
|
||||
(relations-concat-map
|
||||
(fn
|
||||
(nbr)
|
||||
(if
|
||||
(relations-eng-member? nbr path)
|
||||
(list)
|
||||
(relations-ap-dfs db b kind (append path (list nbr)) nbr)))
|
||||
(relations-children-of db node kind)))))
|
||||
|
||||
(define
|
||||
relations-all-paths
|
||||
(fn
|
||||
(db a b kind)
|
||||
(if (= a b) (list (list a)) (relations-ap-dfs db b kind (list a) a))))
|
||||
|
||||
(define
|
||||
relations/path
|
||||
(fn (a b kind) (relations-path (relations-ensure-db!) a b kind)))
|
||||
|
||||
(define
|
||||
relations/distance
|
||||
(fn (a b kind) (relations-distance (relations-ensure-db!) a b kind)))
|
||||
|
||||
(define
|
||||
relations/descendants-any
|
||||
(fn (node) (relations-descendants-any (relations-ensure-db!) node)))
|
||||
|
||||
(define
|
||||
relations/reachable-any?
|
||||
(fn (a b) (relations-reachable-any? (relations-ensure-db!) a b)))
|
||||
|
||||
(define
|
||||
relations/all-paths
|
||||
(fn (a b kind) (relations-all-paths (relations-ensure-db!) a b kind)))
|
||||
70
lib/relations/federation.sx
Normal file
70
lib/relations/federation.sx
Normal file
@@ -0,0 +1,70 @@
|
||||
;; lib/relations/federation.sx — cross-instance links + trust + revocation.
|
||||
;;
|
||||
;; fed-sx replicates relationship facts between instances; this module models the
|
||||
;; local side. A peer's link arrives as `peer_rel(Peer, Src, Dst, Kind)` and only
|
||||
;; becomes an effective edge when a local `trust(Peer)` fact authorises it — the
|
||||
;; gating is the engine rule (lib/relations/engine.sx), re-checked every query,
|
||||
;; so revoking trust or a link takes effect on the next saturation. The network
|
||||
;; transport is fed-sx's job and is mocked here as a dict.
|
||||
;;
|
||||
;; Trust is NOT transitive: trusting peer α binds only links α itself asserts;
|
||||
;; α's own trust in some β does not flow.
|
||||
|
||||
;; A federated link asserted by `peer`: peer claims rel(src,dst,kind) holds.
|
||||
(define
|
||||
relations-peer-rel
|
||||
(fn (peer src dst kind) (list (quote peer_rel) peer src dst kind)))
|
||||
|
||||
;; Local trust in a peer. Gates that peer's links at query time.
|
||||
(define relations-trust (fn (peer) (list (quote trust) peer)))
|
||||
|
||||
;; Mock fed-sx pull: `transport` maps a peer address (its string name) to the
|
||||
;; list of peer_rel facts that peer asserts. Returns the facts for `addr`, or an
|
||||
;; empty list if the peer is unknown / unreachable.
|
||||
(define
|
||||
relations-fed-fetch
|
||||
(fn
|
||||
(transport addr)
|
||||
(let
|
||||
((k (if (symbol? addr) (symbol->string addr) addr)))
|
||||
(if (has-key? transport k) (get transport k) (list)))))
|
||||
|
||||
;; Gather peer_rel facts from every peer in `addrs` via the transport.
|
||||
(define
|
||||
relations-fed-collect
|
||||
(fn
|
||||
(transport addrs)
|
||||
(let
|
||||
((acc (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(addr)
|
||||
(for-each
|
||||
(fn (f) (append! acc f))
|
||||
(relations-fed-fetch transport addr)))
|
||||
addrs)
|
||||
acc))))
|
||||
|
||||
;; Build a db from local facts plus peer_rel facts pulled from `peers`. Local
|
||||
;; facts must carry the trust policy (trust(...) facts); replicated links are
|
||||
;; gated against it by the engine rule at query time.
|
||||
(define
|
||||
relations-fed-build-db
|
||||
(fn
|
||||
(local-facts transport peers)
|
||||
(let
|
||||
((all (list)))
|
||||
(do
|
||||
(for-each (fn (f) (append! all f)) local-facts)
|
||||
(for-each
|
||||
(fn (f) (append! all f))
|
||||
(relations-fed-collect transport peers))
|
||||
(relations-build-db all)))))
|
||||
|
||||
;; Ingest a newly replicated fact into a live db (re-saturates).
|
||||
(define relations-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))
|
||||
|
||||
;; Propagated revocation: retract a replicated link or a local trust fact from a
|
||||
;; live db. The next query re-saturates and reflects it.
|
||||
(define relations-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
|
||||
40
lib/relations/schema.sx
Normal file
40
lib/relations/schema.sx
Normal file
@@ -0,0 +1,40 @@
|
||||
;; lib/relations/schema.sx — relationship fact vocabulary over lib/datalog/.
|
||||
;;
|
||||
;; relations is content-agnostic: a node is an opaque id (a symbol or string);
|
||||
;; domains own what ids mean. A relationship is a single Datalog fact
|
||||
;;
|
||||
;; rel(Src, Dst, Kind)
|
||||
;;
|
||||
;; meaning "Src is related to Dst under Kind" (read directionally: Src is the
|
||||
;; parent/owner/origin, Dst the child/member/reply). Kind is an open vocabulary;
|
||||
;; the names below are the platform's well-known kinds but relate accepts any
|
||||
;; kind symbol — Datalog is untyped and domains may coin their own.
|
||||
|
||||
(define relations-kinds (quote (parent member reply variant origin link)))
|
||||
|
||||
(define relations-rel (fn (src dst kind) (list (quote rel) src dst kind)))
|
||||
|
||||
(define relations-rel-src (fn (f) (nth f 1)))
|
||||
|
||||
(define relations-rel-dst (fn (f) (nth f 2)))
|
||||
|
||||
(define relations-rel-kind (fn (f) (nth f 3)))
|
||||
|
||||
(define
|
||||
relations-member?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (relations-member? x (rest xs))))))
|
||||
|
||||
(define
|
||||
relations-known-kind?
|
||||
(fn (k) (relations-member? k relations-kinds)))
|
||||
|
||||
(define
|
||||
relations-fact-valid?
|
||||
(fn
|
||||
(f)
|
||||
(and (list? f) (= (len f) 4) (= (first f) (quote rel)))))
|
||||
18
lib/relations/scoreboard.json
Normal file
18
lib/relations/scoreboard.json
Normal file
@@ -0,0 +1,18 @@
|
||||
{
|
||||
"lang": "relations",
|
||||
"total_passed": 158,
|
||||
"total_failed": 0,
|
||||
"total": 158,
|
||||
"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":"tree","passed":16,"failed":0,"total":16},
|
||||
{"name":"routes","passed":9,"failed":0,"total":9},
|
||||
{"name":"bulk","passed":12,"failed":0,"total":12},
|
||||
{"name":"comp","passed":11,"failed":0,"total":11}
|
||||
],
|
||||
"generated": "2026-06-07T13:42:22+00:00"
|
||||
}
|
||||
15
lib/relations/scoreboard.md
Normal file
15
lib/relations/scoreboard.md
Normal file
@@ -0,0 +1,15 @@
|
||||
# relations scoreboard
|
||||
|
||||
**158 / 158 passing** (0 failure(s)).
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
| direct | 22 | 22 | ok |
|
||||
| reach | 24 | 24 | ok |
|
||||
| path | 24 | 24 | ok |
|
||||
| fed | 22 | 22 | ok |
|
||||
| shape | 18 | 18 | ok |
|
||||
| tree | 16 | 16 | ok |
|
||||
| routes | 9 | 9 | ok |
|
||||
| bulk | 12 | 12 | ok |
|
||||
| comp | 11 | 11 | ok |
|
||||
142
lib/relations/tests/bulk.sx
Normal file
142
lib/relations/tests/bulk.sx
Normal file
@@ -0,0 +1,142 @@
|
||||
;; lib/relations/tests/bulk.sx — extension: bulk lifecycle (relate-many,
|
||||
;; unrelate-node cascade cleanup).
|
||||
|
||||
(define relations-bk-pass 0)
|
||||
(define relations-bk-fail 0)
|
||||
(define relations-bk-failures (list))
|
||||
|
||||
(define
|
||||
relations-bk-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-bk-pass (+ relations-bk-pass 1))
|
||||
(do
|
||||
(set! relations-bk-fail (+ relations-bk-fail 1))
|
||||
(append!
|
||||
relations-bk-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
relations-bk-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-bk-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
relations-bk-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-bk-subset? xs ys)
|
||||
(relations-bk-subset? ys xs))))
|
||||
|
||||
(define
|
||||
relations-bk-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (relations-build-db (list))))
|
||||
(do
|
||||
(relations-relate-many!
|
||||
db
|
||||
(list
|
||||
(list (quote a) (quote b) (quote parent))
|
||||
(list (quote a) (quote c) (quote parent))
|
||||
(list (quote x) (quote a) (quote parent))
|
||||
(list (quote a) (quote m) (quote member))))
|
||||
(relations-bk-check!
|
||||
"relate-many: parent children of a"
|
||||
(relations-bk-set=?
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list (quote b) (quote c)))
|
||||
true)
|
||||
(relations-bk-check!
|
||||
"relate-many: member child of a"
|
||||
(relations-bk-set=?
|
||||
(relations-children-of db (quote a) (quote member))
|
||||
(list (quote m)))
|
||||
true)
|
||||
(relations-bk-check!
|
||||
"relate-many: x is a parent of a"
|
||||
(relations-bk-set=?
|
||||
(relations-parents-of db (quote a) (quote parent))
|
||||
(list (quote x)))
|
||||
true)
|
||||
(relations-unrelate-node! db (quote a))
|
||||
(relations-bk-check!
|
||||
"after cleanup: a has no parent children"
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list))
|
||||
(relations-bk-check!
|
||||
"after cleanup: a has no parent parents"
|
||||
(relations-parents-of db (quote a) (quote parent))
|
||||
(list))
|
||||
(relations-bk-check!
|
||||
"after cleanup: a has no member children"
|
||||
(relations-children-of db (quote a) (quote member))
|
||||
(list))
|
||||
(relations-bk-check!
|
||||
"after cleanup: x no longer points at a"
|
||||
(relations-children-of db (quote x) (quote parent))
|
||||
(list))))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-rel (quote c) (quote d) (quote parent))))))
|
||||
(do
|
||||
(relations-unrelate-node! db (quote a))
|
||||
(relations-bk-check!
|
||||
"cleanup leaves unrelated edge intact"
|
||||
(relations-bk-set=?
|
||||
(relations-children-of db (quote c) (quote parent))
|
||||
(list (quote d)))
|
||||
true)
|
||||
(relations-bk-check!
|
||||
"cleanup removed the a edge"
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list))))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent))))))
|
||||
(do
|
||||
(relations-unrelate-node! db (quote nobody))
|
||||
(relations-bk-check!
|
||||
"cleanup of unknown node is a no-op"
|
||||
(relations-bk-set=?
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list (quote b)))
|
||||
true)))
|
||||
(do
|
||||
(relations/load! (list))
|
||||
(relations/relate-many!
|
||||
(list
|
||||
(list (quote o) (quote i1) (quote member))
|
||||
(list (quote o) (quote i2) (quote member))))
|
||||
(relations-bk-check!
|
||||
"api relate-many"
|
||||
(relations-bk-set=?
|
||||
(relations/children (quote o) (quote member))
|
||||
(list (quote i1) (quote i2)))
|
||||
true)
|
||||
(relations/unrelate-node! (quote o))
|
||||
(relations-bk-check!
|
||||
"api unrelate-node"
|
||||
(relations/children (quote o) (quote member))
|
||||
(list))
|
||||
(relations/load! (list))))))
|
||||
|
||||
(define
|
||||
relations-bulk-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-bk-pass 0)
|
||||
(set! relations-bk-fail 0)
|
||||
(set! relations-bk-failures (list))
|
||||
(relations-bk-run-all!)
|
||||
{:failures relations-bk-failures :total (+ relations-bk-pass relations-bk-fail) :passed relations-bk-pass :failed relations-bk-fail})))
|
||||
144
lib/relations/tests/comp.sx
Normal file
144
lib/relations/tests/comp.sx
Normal file
@@ -0,0 +1,144 @@
|
||||
;; lib/relations/tests/comp.sx — extension: weakly-connected components.
|
||||
|
||||
(define relations-cp-pass 0)
|
||||
(define relations-cp-fail 0)
|
||||
(define relations-cp-failures (list))
|
||||
|
||||
(define
|
||||
relations-cp-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-cp-pass (+ relations-cp-pass 1))
|
||||
(do
|
||||
(set! relations-cp-fail (+ relations-cp-fail 1))
|
||||
(append!
|
||||
relations-cp-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
relations-cp-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-cp-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
relations-cp-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-cp-subset? xs ys)
|
||||
(relations-cp-subset? ys xs))))
|
||||
|
||||
;; Does `comps` (a list of node-lists) contain a component set-equal to `want`?
|
||||
(define
|
||||
relations-cp-has-comp?
|
||||
(fn
|
||||
(comps want)
|
||||
(cond
|
||||
((= (len comps) 0) false)
|
||||
((relations-cp-set=? (first comps) want) true)
|
||||
(else (relations-cp-has-comp? (rest comps) want)))))
|
||||
|
||||
;; Three parent components + a separate member graph.
|
||||
;; parent: a->b, b->c ; x->y ; z->z (self-loop, its own component)
|
||||
;; member: m->n
|
||||
(define
|
||||
relations-cp-fixture
|
||||
(fn
|
||||
()
|
||||
(relations-build-db
|
||||
(list
|
||||
(relations-rel (quote a) (quote b) (quote parent))
|
||||
(relations-rel (quote b) (quote c) (quote parent))
|
||||
(relations-rel (quote x) (quote y) (quote parent))
|
||||
(relations-rel (quote z) (quote z) (quote parent))
|
||||
(relations-rel (quote m) (quote n) (quote member))))))
|
||||
|
||||
(define
|
||||
relations-cp-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((db (relations-cp-fixture)))
|
||||
(do
|
||||
(relations-cp-check!
|
||||
"component of a"
|
||||
(relations-cp-set=?
|
||||
(relations-component db (quote a) (quote parent))
|
||||
(list (quote a) (quote b) (quote c)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"component of c (same as a, undirected)"
|
||||
(relations-cp-set=?
|
||||
(relations-component db (quote c) (quote parent))
|
||||
(list (quote a) (quote b) (quote c)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"self-loop node is its own component"
|
||||
(relations-cp-set=?
|
||||
(relations-component db (quote z) (quote parent))
|
||||
(list (quote z)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"three parent components"
|
||||
(relations-component-count db (quote parent))
|
||||
3)
|
||||
(relations-cp-check!
|
||||
"one member component"
|
||||
(relations-component-count db (quote member))
|
||||
1)
|
||||
(let
|
||||
((comps (relations-components db (quote parent))))
|
||||
(do
|
||||
(relations-cp-check!
|
||||
"partition includes a-b-c"
|
||||
(relations-cp-has-comp?
|
||||
comps
|
||||
(list (quote a) (quote b) (quote c)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"partition includes x-y"
|
||||
(relations-cp-has-comp? comps (list (quote x) (quote y)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"partition includes z"
|
||||
(relations-cp-has-comp? comps (list (quote z)))
|
||||
true)))
|
||||
(relations-cp-check!
|
||||
"kind isolation: member component count is 1"
|
||||
(relations-component-count db (quote member))
|
||||
1)
|
||||
(do
|
||||
(relations/load!
|
||||
(list
|
||||
(relations-rel (quote p) (quote q) (quote parent))
|
||||
(relations-rel (quote r) (quote s) (quote parent))))
|
||||
(relations-cp-check!
|
||||
"api component"
|
||||
(relations-cp-set=?
|
||||
(relations/component (quote p) (quote parent))
|
||||
(list (quote p) (quote q)))
|
||||
true)
|
||||
(relations-cp-check!
|
||||
"api component-count"
|
||||
(relations/component-count (quote parent))
|
||||
2)
|
||||
(relations/load! (list)))))))
|
||||
|
||||
(define
|
||||
relations-comp-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-cp-pass 0)
|
||||
(set! relations-cp-fail 0)
|
||||
(set! relations-cp-failures (list))
|
||||
(relations-cp-run-all!)
|
||||
{:failures relations-cp-failures :total (+ relations-cp-pass relations-cp-fail) :passed relations-cp-pass :failed relations-cp-fail})))
|
||||
197
lib/relations/tests/direct.sx
Normal file
197
lib/relations/tests/direct.sx
Normal file
@@ -0,0 +1,197 @@
|
||||
;; lib/relations/tests/direct.sx — Phase 1: schema + direct relations.
|
||||
|
||||
(define relations-dt-pass 0)
|
||||
(define relations-dt-fail 0)
|
||||
(define relations-dt-failures (list))
|
||||
|
||||
(define
|
||||
relations-dt-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-dt-pass (+ relations-dt-pass 1))
|
||||
(do
|
||||
(set! relations-dt-fail (+ relations-dt-fail 1))
|
||||
(append!
|
||||
relations-dt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; Order-insensitive membership: every x in xs is in ys.
|
||||
(define
|
||||
relations-dt-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-dt-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
relations-dt-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-dt-subset? xs ys)
|
||||
(relations-dt-subset? ys xs))))
|
||||
|
||||
;; Fixture: a small forest with two kinds.
|
||||
;; parent: a -> b, a -> c, b -> d
|
||||
;; reply: p -> q
|
||||
(define
|
||||
relations-dt-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 p) (quote q) (quote reply))))))
|
||||
|
||||
(define
|
||||
relations-dt-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((db (relations-dt-fixture)))
|
||||
(do
|
||||
(relations-dt-check!
|
||||
"direct children of a"
|
||||
(relations-dt-set=?
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list (quote b) (quote c)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"direct children of b"
|
||||
(relations-dt-set=?
|
||||
(relations-children-of db (quote b) (quote parent))
|
||||
(list (quote d)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"leaf has no children"
|
||||
(relations-children-of db (quote d) (quote parent))
|
||||
(list))
|
||||
(relations-dt-check!
|
||||
"direct parents of b"
|
||||
(relations-dt-set=?
|
||||
(relations-parents-of db (quote b) (quote parent))
|
||||
(list (quote a)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"root has no parents"
|
||||
(relations-parents-of db (quote a) (quote parent))
|
||||
(list))
|
||||
(relations-dt-check!
|
||||
"related is both directions"
|
||||
(relations-dt-set=?
|
||||
(relations-related db (quote b) (quote parent))
|
||||
(list (quote d) (quote a)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"kind isolation: parent query skips reply edge"
|
||||
(relations-children-of db (quote p) (quote parent))
|
||||
(list))
|
||||
(relations-dt-check!
|
||||
"reply children of p"
|
||||
(relations-dt-set=?
|
||||
(relations-children-of db (quote p) (quote reply))
|
||||
(list (quote q)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"unknown node -> empty"
|
||||
(relations-children-of db (quote zzz) (quote parent))
|
||||
(list))
|
||||
(let
|
||||
((db2 (relations-build-db (list (relations-rel (quote x) (quote y) (quote parent))))))
|
||||
(do
|
||||
(relations-dt-check!
|
||||
"before retract: y is a child of x"
|
||||
(relations-dt-set=?
|
||||
(relations-children-of db2 (quote x) (quote parent))
|
||||
(list (quote y)))
|
||||
true)
|
||||
(dl-retract!
|
||||
db2
|
||||
(relations-rel (quote x) (quote y) (quote parent)))
|
||||
(relations-dt-check!
|
||||
"after retract: x has no children"
|
||||
(relations-children-of db2 (quote x) (quote parent))
|
||||
(list))))
|
||||
(do
|
||||
(relations/load! (list))
|
||||
(relations/relate (quote o1) (quote li1) (quote member))
|
||||
(relations/relate (quote o1) (quote li2) (quote member))
|
||||
(relations-dt-check!
|
||||
"api relate then children"
|
||||
(relations-dt-set=?
|
||||
(relations/children (quote o1) (quote member))
|
||||
(list (quote li1) (quote li2)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"api parents"
|
||||
(relations-dt-set=?
|
||||
(relations/parents (quote li1) (quote member))
|
||||
(list (quote o1)))
|
||||
true)
|
||||
(relations/unrelate (quote o1) (quote li1) (quote member))
|
||||
(relations-dt-check!
|
||||
"api unrelate removes one child"
|
||||
(relations-dt-set=?
|
||||
(relations/children (quote o1) (quote member))
|
||||
(list (quote li2)))
|
||||
true)
|
||||
(relations/load! (list))
|
||||
(relations-dt-check!
|
||||
"api reload clears prior facts"
|
||||
(relations/children (quote o1) (quote member))
|
||||
(list)))
|
||||
(relations-dt-check!
|
||||
"rel constructor shape"
|
||||
(relations-rel (quote s) (quote d) (quote parent))
|
||||
(list (quote rel) (quote s) (quote d) (quote parent)))
|
||||
(relations-dt-check!
|
||||
"fact valid"
|
||||
(relations-fact-valid?
|
||||
(relations-rel (quote s) (quote d) (quote parent)))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"fact bad arity invalid"
|
||||
(relations-fact-valid? (list (quote rel) (quote s)))
|
||||
false)
|
||||
(relations-dt-check!
|
||||
"fact wrong head invalid"
|
||||
(relations-fact-valid?
|
||||
(list (quote edge) (quote s) (quote d) (quote parent)))
|
||||
false)
|
||||
(relations-dt-check!
|
||||
"known kind"
|
||||
(relations-known-kind? (quote parent))
|
||||
true)
|
||||
(relations-dt-check!
|
||||
"unknown kind"
|
||||
(relations-known-kind? (quote frobnicate))
|
||||
false)
|
||||
(relations-dt-check!
|
||||
"accessors"
|
||||
(list
|
||||
(relations-rel-src
|
||||
(relations-rel (quote s) (quote d) (quote k)))
|
||||
(relations-rel-dst
|
||||
(relations-rel (quote s) (quote d) (quote k)))
|
||||
(relations-rel-kind
|
||||
(relations-rel (quote s) (quote d) (quote k))))
|
||||
(list (quote s) (quote d) (quote k)))))))
|
||||
|
||||
(define
|
||||
relations-direct-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-dt-pass 0)
|
||||
(set! relations-dt-fail 0)
|
||||
(set! relations-dt-failures (list))
|
||||
(relations-dt-run-all!)
|
||||
{:failures relations-dt-failures :total (+ relations-dt-pass relations-dt-fail) :passed relations-dt-pass :failed relations-dt-fail})))
|
||||
203
lib/relations/tests/fed.sx
Normal file
203
lib/relations/tests/fed.sx
Normal file
@@ -0,0 +1,203 @@
|
||||
;; lib/relations/tests/fed.sx — Phase 4: federation (peer links, trust gating,
|
||||
;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
|
||||
|
||||
(define relations-ft-pass 0)
|
||||
(define relations-ft-fail 0)
|
||||
(define relations-ft-failures (list))
|
||||
|
||||
(define
|
||||
relations-ft-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-ft-pass (+ relations-ft-pass 1))
|
||||
(do
|
||||
(set! relations-ft-fail (+ relations-ft-fail 1))
|
||||
(append!
|
||||
relations-ft-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
relations-ft-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-ft-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
relations-ft-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-ft-subset? xs ys)
|
||||
(relations-ft-subset? ys xs))))
|
||||
|
||||
;; Local edge a->b; peerA claims b->c; peerB claims c->d. Local trust only in
|
||||
;; peerA. With trust gating, a reaches c (via peerA's b->c) but not d.
|
||||
(define
|
||||
relations-ft-facts
|
||||
(fn
|
||||
()
|
||||
(list
|
||||
(relations-rel (quote a) (quote b) (quote parent))
|
||||
(relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent))
|
||||
(relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent))
|
||||
(relations-trust (quote peerA)))))
|
||||
|
||||
(define
|
||||
relations-ft-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent))))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"untrusted link: c not a child of b"
|
||||
(relations-children-of db (quote b) (quote parent))
|
||||
(list))
|
||||
(relations-ft-check!
|
||||
"untrusted link: a cannot reach c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
false)))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"trusted link: c is a child of b"
|
||||
(relations-ft-set=?
|
||||
(relations-children-of db (quote b) (quote parent))
|
||||
(list (quote c)))
|
||||
true)
|
||||
(relations-ft-check!
|
||||
"trusted link: federated reachability a->c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
true)
|
||||
(relations-ft-check!
|
||||
"trusted link: connecting path crosses the federated edge"
|
||||
(relations-path db (quote a) (quote c) (quote parent))
|
||||
(list (quote a) (quote b) (quote c)))))
|
||||
(let
|
||||
((db (relations-build-db (relations-ft-facts))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"non-transitive: a reaches c (peerA trusted)"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
true)
|
||||
(relations-ft-check!
|
||||
"non-transitive: a does not reach d (peerB untrusted)"
|
||||
(relations-reachable? db (quote a) (quote d) (quote parent))
|
||||
false)
|
||||
(relations-ft-check!
|
||||
"non-transitive: d is not a child of c"
|
||||
(relations-children-of db (quote c) (quote parent))
|
||||
(list))))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"before link revoke: a reaches c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
true)
|
||||
(relations-revoke!
|
||||
db
|
||||
(relations-peer-rel
|
||||
(quote peerX)
|
||||
(quote b)
|
||||
(quote c)
|
||||
(quote parent)))
|
||||
(relations-ft-check!
|
||||
"after link revoke: a cannot reach c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
false)))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"before trust revoke: c is a child of b"
|
||||
(relations-ft-set=?
|
||||
(relations-children-of db (quote b) (quote parent))
|
||||
(list (quote c)))
|
||||
true)
|
||||
(relations-revoke! db (relations-trust (quote peerX)))
|
||||
(relations-ft-check!
|
||||
"after trust revoke: federated edge gone"
|
||||
(relations-children-of db (quote b) (quote parent))
|
||||
(list))
|
||||
(relations-ft-check!
|
||||
"after trust revoke: local edge survives"
|
||||
(relations-ft-set=?
|
||||
(relations-children-of db (quote a) (quote parent))
|
||||
(list (quote b)))
|
||||
true)))
|
||||
(let
|
||||
((transport {:peerB (list (relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent))) :peerA (list (relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent)))}))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"fed-fetch returns a peer's links"
|
||||
(len (relations-fed-fetch transport (quote peerA)))
|
||||
1)
|
||||
(relations-ft-check!
|
||||
"fed-fetch unknown peer -> empty"
|
||||
(relations-fed-fetch transport (quote nobody))
|
||||
(list))
|
||||
(relations-ft-check!
|
||||
"fed-collect over two peers"
|
||||
(len
|
||||
(relations-fed-collect
|
||||
transport
|
||||
(list (quote peerA) (quote peerB))))
|
||||
2)
|
||||
(let
|
||||
((db (relations-fed-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerA))) transport (list (quote peerA) (quote peerB)))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"fed-build: trusted peerA link binds (a->c)"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
true)
|
||||
(relations-ft-check!
|
||||
"fed-build: untrusted peerB link does not bind (a->d)"
|
||||
(relations-reachable? db (quote a) (quote d) (quote parent))
|
||||
false)))))
|
||||
(let
|
||||
((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerX))))))
|
||||
(do
|
||||
(relations-ft-check!
|
||||
"before fed-assert: a cannot reach c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
false)
|
||||
(relations-fed-assert!
|
||||
db
|
||||
(relations-peer-rel
|
||||
(quote peerX)
|
||||
(quote b)
|
||||
(quote c)
|
||||
(quote parent)))
|
||||
(relations-ft-check!
|
||||
"after fed-assert: a reaches c"
|
||||
(relations-reachable? db (quote a) (quote c) (quote parent))
|
||||
true)))
|
||||
(relations-ft-check!
|
||||
"peer-rel constructor shape"
|
||||
(relations-peer-rel (quote p) (quote s) (quote d) (quote k))
|
||||
(list (quote peer_rel) (quote p) (quote s) (quote d) (quote k)))
|
||||
(relations-ft-check!
|
||||
"trust constructor shape"
|
||||
(relations-trust (quote p))
|
||||
(list (quote trust) (quote p))))))
|
||||
|
||||
(define
|
||||
relations-fed-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-ft-pass 0)
|
||||
(set! relations-ft-fail 0)
|
||||
(set! relations-ft-failures (list))
|
||||
(relations-ft-run-all!)
|
||||
{:failures relations-ft-failures :total (+ relations-ft-pass relations-ft-fail) :passed relations-ft-pass :failed relations-ft-fail})))
|
||||
192
lib/relations/tests/path.sx
Normal file
192
lib/relations/tests/path.sx
Normal file
@@ -0,0 +1,192 @@
|
||||
;; lib/relations/tests/path.sx — Phase 3: typed relations, path, distance.
|
||||
|
||||
(define relations-pt-pass 0)
|
||||
(define relations-pt-fail 0)
|
||||
(define relations-pt-failures (list))
|
||||
|
||||
(define
|
||||
relations-pt-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-pt-pass (+ relations-pt-pass 1))
|
||||
(do
|
||||
(set! relations-pt-fail (+ relations-pt-fail 1))
|
||||
(append!
|
||||
relations-pt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
relations-pt-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-pt-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
relations-pt-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-pt-subset? xs ys)
|
||||
(relations-pt-subset? ys xs))))
|
||||
|
||||
;; Two kinds coexisting in one db.
|
||||
;; parent: a->b, b->c, c->d, a->c (shortcut), x->y (disconnected)
|
||||
;; member: c->m, m->n (crosses into a different kind)
|
||||
(define
|
||||
relations-pt-fixture
|
||||
(fn
|
||||
()
|
||||
(relations-build-db
|
||||
(list
|
||||
(relations-rel (quote a) (quote b) (quote parent))
|
||||
(relations-rel (quote b) (quote c) (quote parent))
|
||||
(relations-rel (quote c) (quote d) (quote parent))
|
||||
(relations-rel (quote a) (quote c) (quote parent))
|
||||
(relations-rel (quote x) (quote y) (quote parent))
|
||||
(relations-rel (quote c) (quote m) (quote member))
|
||||
(relations-rel (quote m) (quote n) (quote member))))))
|
||||
|
||||
;; A cycle with an exit: u->v->w->u, w->exit.
|
||||
(define
|
||||
relations-pt-cyc-fixture
|
||||
(fn
|
||||
()
|
||||
(relations-build-db
|
||||
(list
|
||||
(relations-rel (quote u) (quote v) (quote parent))
|
||||
(relations-rel (quote v) (quote w) (quote parent))
|
||||
(relations-rel (quote w) (quote u) (quote parent))
|
||||
(relations-rel (quote w) (quote exit) (quote parent))))))
|
||||
|
||||
(define
|
||||
relations-pt-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((db (relations-pt-fixture)) (cyc (relations-pt-cyc-fixture)))
|
||||
(do
|
||||
(relations-pt-check!
|
||||
"shortest path a->d"
|
||||
(relations-path db (quote a) (quote d) (quote parent))
|
||||
(list (quote a) (quote c) (quote d)))
|
||||
(relations-pt-check!
|
||||
"distance a->d is 2"
|
||||
(relations-distance db (quote a) (quote d) (quote parent))
|
||||
2)
|
||||
(relations-pt-check!
|
||||
"direct edge path a->c"
|
||||
(relations-path db (quote a) (quote c) (quote parent))
|
||||
(list (quote a) (quote c)))
|
||||
(relations-pt-check!
|
||||
"distance a->c is 1"
|
||||
(relations-distance db (quote a) (quote c) (quote parent))
|
||||
1)
|
||||
(relations-pt-check!
|
||||
"path b->d"
|
||||
(relations-path db (quote b) (quote d) (quote parent))
|
||||
(list (quote b) (quote c) (quote d)))
|
||||
(relations-pt-check!
|
||||
"self path"
|
||||
(relations-path db (quote a) (quote a) (quote parent))
|
||||
(list (quote a)))
|
||||
(relations-pt-check!
|
||||
"self distance is 0"
|
||||
(relations-distance db (quote a) (quote a) (quote parent))
|
||||
0)
|
||||
(relations-pt-check!
|
||||
"unknown target -> nil path"
|
||||
(relations-path db (quote a) (quote zzz) (quote parent))
|
||||
nil)
|
||||
(relations-pt-check!
|
||||
"unknown target -> nil distance"
|
||||
(relations-distance db (quote a) (quote zzz) (quote parent))
|
||||
nil)
|
||||
(relations-pt-check!
|
||||
"disconnected -> nil path"
|
||||
(relations-path db (quote a) (quote y) (quote parent))
|
||||
nil)
|
||||
(relations-pt-check!
|
||||
"no parent path crosses into member edge"
|
||||
(relations-path db (quote a) (quote m) (quote parent))
|
||||
nil)
|
||||
(relations-pt-check!
|
||||
"member path c->m"
|
||||
(relations-path db (quote c) (quote m) (quote member))
|
||||
(list (quote c) (quote m)))
|
||||
(relations-pt-check!
|
||||
"member path c->n"
|
||||
(relations-path db (quote c) (quote n) (quote member))
|
||||
(list (quote c) (quote m) (quote n)))
|
||||
(relations-pt-check!
|
||||
"mixed-kind reachable a->m"
|
||||
(relations-reachable-any? db (quote a) (quote m))
|
||||
true)
|
||||
(relations-pt-check!
|
||||
"mixed-kind reachable a->n"
|
||||
(relations-reachable-any? db (quote a) (quote n))
|
||||
true)
|
||||
(relations-pt-check!
|
||||
"single-kind a->m not reachable under parent"
|
||||
(relations-reachable? db (quote a) (quote m) (quote parent))
|
||||
false)
|
||||
(relations-pt-check!
|
||||
"mixed-kind descendants of a include cross-kind nodes"
|
||||
(relations-pt-set=?
|
||||
(relations-descendants-any db (quote a))
|
||||
(list (quote b) (quote c) (quote d) (quote m) (quote n)))
|
||||
true)
|
||||
(relations-pt-check!
|
||||
"single-kind descendants of a under parent only"
|
||||
(relations-pt-set=?
|
||||
(relations-descendants db (quote a) (quote parent))
|
||||
(list (quote b) (quote c) (quote d)))
|
||||
true)
|
||||
(relations-pt-check!
|
||||
"path out of a cycle"
|
||||
(relations-path cyc (quote u) (quote exit) (quote parent))
|
||||
(list (quote u) (quote v) (quote w) (quote exit)))
|
||||
(relations-pt-check!
|
||||
"distance out of a cycle is 3"
|
||||
(relations-distance cyc (quote u) (quote exit) (quote parent))
|
||||
3)
|
||||
(do
|
||||
(relations/load!
|
||||
(list
|
||||
(relations-rel (quote r1) (quote r2) (quote parent))
|
||||
(relations-rel (quote r2) (quote r3) (quote parent))
|
||||
(relations-rel (quote r3) (quote r4) (quote link))))
|
||||
(relations-pt-check!
|
||||
"api path"
|
||||
(relations/path (quote r1) (quote r3) (quote parent))
|
||||
(list (quote r1) (quote r2) (quote r3)))
|
||||
(relations-pt-check!
|
||||
"api distance"
|
||||
(relations/distance (quote r1) (quote r3) (quote parent))
|
||||
2)
|
||||
(relations-pt-check!
|
||||
"api mixed-kind reachable across parent+link"
|
||||
(relations/reachable-any? (quote r1) (quote r4))
|
||||
true)
|
||||
(relations-pt-check!
|
||||
"api single-kind not reachable across kinds"
|
||||
(relations/reachable? (quote r1) (quote r4) (quote parent))
|
||||
false)
|
||||
(relations/load! (list)))))))
|
||||
|
||||
(define
|
||||
relations-path-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-pt-pass 0)
|
||||
(set! relations-pt-fail 0)
|
||||
(set! relations-pt-failures (list))
|
||||
(relations-pt-run-all!)
|
||||
{:failures relations-pt-failures :total (+ relations-pt-pass relations-pt-fail) :passed relations-pt-pass :failed relations-pt-fail})))
|
||||
204
lib/relations/tests/reach.sx
Normal file
204
lib/relations/tests/reach.sx
Normal file
@@ -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})))
|
||||
130
lib/relations/tests/routes.sx
Normal file
130
lib/relations/tests/routes.sx
Normal file
@@ -0,0 +1,130 @@
|
||||
;; lib/relations/tests/routes.sx — extension: all simple paths (route enumeration).
|
||||
|
||||
(define relations-ro-pass 0)
|
||||
(define relations-ro-fail 0)
|
||||
(define relations-ro-failures (list))
|
||||
|
||||
(define
|
||||
relations-ro-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! relations-ro-pass (+ relations-ro-pass 1))
|
||||
(do
|
||||
(set! relations-ro-fail (+ relations-ro-fail 1))
|
||||
(append!
|
||||
relations-ro-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
relations-ro-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((relations-member? (first xs) ys)
|
||||
(relations-ro-subset? (rest xs) ys))
|
||||
(else false))))
|
||||
|
||||
;; Order-insensitive set equality; elements compared structurally (works for
|
||||
;; lists-of-paths since `=` is structural).
|
||||
(define
|
||||
relations-ro-set=?
|
||||
(fn
|
||||
(xs ys)
|
||||
(and
|
||||
(= (len xs) (len ys))
|
||||
(relations-ro-subset? xs ys)
|
||||
(relations-ro-subset? ys xs))))
|
||||
|
||||
;; Diamond + branch + a cycle with an exit.
|
||||
;; parent: a->b, a->c, b->d, c->d, b->e
|
||||
;; member: a->z (a different kind, to test isolation)
|
||||
;; parent cycle: g->h, h->g, h->out
|
||||
(define
|
||||
relations-ro-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 a) (quote z) (quote member))
|
||||
(relations-rel (quote g) (quote h) (quote parent))
|
||||
(relations-rel (quote h) (quote g) (quote parent))
|
||||
(relations-rel (quote h) (quote out) (quote parent))))))
|
||||
|
||||
(define
|
||||
relations-ro-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((db (relations-ro-fixture)))
|
||||
(do
|
||||
(relations-ro-check!
|
||||
"two routes a->d"
|
||||
(relations-ro-set=?
|
||||
(relations-all-paths db (quote a) (quote d) (quote parent))
|
||||
(list
|
||||
(list (quote a) (quote b) (quote d))
|
||||
(list (quote a) (quote c) (quote d))))
|
||||
true)
|
||||
(relations-ro-check!
|
||||
"single route a->e"
|
||||
(relations-all-paths db (quote a) (quote e) (quote parent))
|
||||
(list (list (quote a) (quote b) (quote e))))
|
||||
(relations-ro-check!
|
||||
"no route -> empty"
|
||||
(relations-all-paths db (quote a) (quote zzz) (quote parent))
|
||||
(list))
|
||||
(relations-ro-check!
|
||||
"self route is the singleton path"
|
||||
(relations-all-paths db (quote a) (quote a) (quote parent))
|
||||
(list (list (quote a))))
|
||||
(relations-ro-check!
|
||||
"route through a cycle terminates"
|
||||
(relations-all-paths db (quote g) (quote out) (quote parent))
|
||||
(list (list (quote g) (quote h) (quote out))))
|
||||
(relations-ro-check!
|
||||
"route count a->d is 2"
|
||||
(len (relations-all-paths db (quote a) (quote d) (quote parent)))
|
||||
2)
|
||||
(relations-ro-check!
|
||||
"kind isolation: no parent route to member target"
|
||||
(relations-all-paths db (quote a) (quote z) (quote parent))
|
||||
(list))
|
||||
(relations-ro-check!
|
||||
"member route a->z"
|
||||
(relations-all-paths db (quote a) (quote z) (quote member))
|
||||
(list (list (quote a) (quote z))))
|
||||
(do
|
||||
(relations/load!
|
||||
(list
|
||||
(relations-rel (quote p) (quote q) (quote parent))
|
||||
(relations-rel (quote p) (quote r) (quote parent))
|
||||
(relations-rel (quote q) (quote s) (quote parent))
|
||||
(relations-rel (quote r) (quote s) (quote parent))))
|
||||
(relations-ro-check!
|
||||
"api all-paths two routes p->s"
|
||||
(relations-ro-set=?
|
||||
(relations/all-paths (quote p) (quote s) (quote parent))
|
||||
(list
|
||||
(list (quote p) (quote q) (quote s))
|
||||
(list (quote p) (quote r) (quote s))))
|
||||
true)
|
||||
(relations/load! (list)))))))
|
||||
|
||||
(define
|
||||
relations-routes-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! relations-ro-pass 0)
|
||||
(set! relations-ro-fail 0)
|
||||
(set! relations-ro-failures (list))
|
||||
(relations-ro-run-all!)
|
||||
{:failures relations-ro-failures :total (+ relations-ro-pass relations-ro-fail) :passed relations-ro-pass :failed relations-ro-fail})))
|
||||
161
lib/relations/tests/shape.sx
Normal file
161
lib/relations/tests/shape.sx
Normal file
@@ -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})))
|
||||
206
lib/relations/tests/tree.sx
Normal file
206
lib/relations/tests/tree.sx
Normal 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})))
|
||||
161
lib/relations/tree.sx
Normal file
161
lib/relations/tree.sx
Normal file
@@ -0,0 +1,161 @@
|
||||
;; 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-component
|
||||
(fn
|
||||
(db node kind)
|
||||
(relations-ureach-bfs db kind (list node) (list node))))
|
||||
|
||||
(define
|
||||
relations-components-loop
|
||||
(fn
|
||||
(db kind remaining acc)
|
||||
(if
|
||||
(= (len remaining) 0)
|
||||
acc
|
||||
(let
|
||||
((comp (relations-component db (first remaining) kind)))
|
||||
(relations-components-loop
|
||||
db
|
||||
kind
|
||||
(filter (fn (n) (not (relations-eng-member? n comp))) remaining)
|
||||
(append acc (list comp)))))))
|
||||
|
||||
(define
|
||||
relations-component-count
|
||||
(fn (db kind) (len (relations-components db kind))))
|
||||
|
||||
(define
|
||||
relations-components
|
||||
(fn
|
||||
(db kind)
|
||||
(relations-components-loop db kind (relations-nodes db kind) (list))))
|
||||
|
||||
(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)))
|
||||
|
||||
(define
|
||||
relations/component
|
||||
(fn (node kind) (relations-component (relations-ensure-db!) node kind)))
|
||||
|
||||
(define
|
||||
relations/components
|
||||
(fn (kind) (relations-components (relations-ensure-db!) kind)))
|
||||
|
||||
(define
|
||||
relations/component-count
|
||||
(fn (kind) (relations-component-count (relations-ensure-db!) kind)))
|
||||
@@ -18,7 +18,7 @@ links. Reuses `lib/datalog/` — does not reimplement the engine.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/relations/conformance.sh` → **0/0** (not yet started)
|
||||
`bash lib/relations/conformance.sh` → **158/158** (Phases 1–4 complete + extensions)
|
||||
|
||||
## Ground rules
|
||||
|
||||
@@ -61,46 +61,176 @@ lib/relations/federation.sx
|
||||
|
||||
## Phase 1 — Schema + direct relations
|
||||
|
||||
- [ ] `lib/relations/schema.sx` — `rel(Src, Dst, Kind)` fact projection; a small
|
||||
- [x] `lib/relations/schema.sx` — `rel(Src, Dst, Kind)` fact projection; a small
|
||||
kind vocabulary (`parent`, `member`, `reply`, `variant`, `origin`, …) kept open
|
||||
- [ ] `lib/relations/api.sx` — `(relations/relate src dst kind)` / `(unrelate …)`
|
||||
- [x] `lib/relations/api.sx` — `(relations/relate src dst kind)` / `(unrelate …)`
|
||||
over a live Datalog db (assert/retract); `(children-of db node kind)`,
|
||||
`(parents-of db node kind)`, `(related db node kind)`
|
||||
- [ ] `lib/relations/tests/direct.sx` — assert/retract, direct children/parents,
|
||||
- [x] `lib/relations/tests/direct.sx` — assert/retract, direct children/parents,
|
||||
kind filtering, unknown node → empty
|
||||
- [ ] `lib/relations/conformance.sh` + scoreboard
|
||||
- [x] `lib/relations/conformance.sh` + scoreboard
|
||||
|
||||
## 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
|
||||
|
||||
- [ ] multiple kinds coexisting; mixed-kind vs single-kind reachability
|
||||
- [ ] `lib/relations/explain.sx` — `(path db a b kind)` returns the connecting
|
||||
- [x] multiple kinds coexisting; mixed-kind vs single-kind reachability
|
||||
- [x] `lib/relations/explain.sx` — `(path db a b kind)` returns the connecting
|
||||
chain (the relationship equivalent of acl's proof tree), nil if unreachable
|
||||
- [ ] `(distance db a b kind)` (hops) + shortest-path selection
|
||||
- [ ] `lib/relations/tests/path.sx` — path correctness, shortest among many, no-path
|
||||
- [x] `(distance db a b kind)` (hops) + shortest-path selection
|
||||
- [x] `lib/relations/tests/path.sx` — path correctness, shortest among many, no-path
|
||||
|
||||
## Phase 4 — Federation
|
||||
|
||||
- [ ] cross-instance relationships — a peer asserts `rel(local, remote, kind)`;
|
||||
- [x] cross-instance relationships — a peer asserts `rel(local, remote, kind)`;
|
||||
replicate rel facts via fed-sx (mock the transport in tests)
|
||||
- [ ] trust gating — a peer's link binds locally only under a local trust fact
|
||||
- [x] trust gating — a peer's link binds locally only under a local trust fact
|
||||
(mirror acl's non-transitive `trust`/gate-in-engine model; do NOT copy acl code,
|
||||
re-derive the shape)
|
||||
- [ ] revocation — retract a replicated link; reachability re-saturates
|
||||
- [ ] `lib/relations/tests/fed.sx` — federated reachability chains, trust gating,
|
||||
- [x] revocation — retract a replicated link; reachability re-saturates
|
||||
- [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`.
|
||||
- [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`.
|
||||
- [x] **route enumeration** — `all-paths` (all simple directed paths a→b, not just
|
||||
the shortest; cycle-safe DFS) in explain.sx. `lib/relations/tests/routes.sx`.
|
||||
- [x] **bulk lifecycle** — `relate-many!` (batch assert) + `unrelate-node!` (cascade
|
||||
cleanup: retract every local edge touching a node, all kinds, both directions —
|
||||
for domain object deletion; leaves federated peer links alone). api.sx,
|
||||
`lib/relations/tests/bulk.sx`.
|
||||
- [x] **weakly-connected components** — `component` (the undirected cluster of a
|
||||
node), `components` (partition of all nodes for a kind), `component-count`. In
|
||||
tree.sx, reusing `ureach-bfs`. `lib/relations/tests/comp.sx`.
|
||||
|
||||
## Progress log
|
||||
|
||||
(loop fills this in)
|
||||
- **Extension: weakly-connected components** (158/158). `relations-component`
|
||||
(the undirected cluster containing a node = `ureach-bfs` from it),
|
||||
`relations-components` (greedy partition: pop a remaining node, take its
|
||||
component, repeat) and `relations-component-count`, in tree.sx, + `relations/...`
|
||||
wrappers. `lib/relations/tests/comp.sx` (11 tests: cluster from either end, self-
|
||||
loop as its own component, partition contents, count, kind isolation, api).
|
||||
Engine surface now feels SATURATED — base roadmap + 5 graph-algorithm extensions
|
||||
cover direct/transitive/undirected reach, paths (shortest + all routes), cycles,
|
||||
roots/leaves, siblings/degree, ancestors/LCA/topo, components, federation, and
|
||||
bulk lifecycle. Pacing down.
|
||||
- **Extension: bulk lifecycle** (147/147). `relations-relate-many!` (batch
|
||||
`dl-assert!` over a list of (src dst kind) triples) and `relations-unrelate-node!`
|
||||
(query `rel` for every edge with the node as src or dst, across all kinds, then
|
||||
`dl-retract!` each — the cascade-cleanup a domain needs when it deletes the
|
||||
object a node id names). Federated `peer_rel` links are a peer's assertion and
|
||||
are deliberately left untouched. + `relations/relate-many!`/`unrelate-node!`
|
||||
wrappers, `lib/relations/tests/bulk.sx` (12 tests: batch assert, cascade across
|
||||
kinds/both directions, unrelated edges preserved, unknown-node no-op, api layer).
|
||||
- **Extension: route enumeration** (135/135). `relations-all-paths(db,a,b,kind)`
|
||||
in explain.sx — every simple (no repeated node) directed path a→b, not just the
|
||||
shortest one `relations-path` returns; DFS that skips nodes already on the
|
||||
current path so cyclic data terminates; a=b → `((a))`, no route → `()`. Reuses
|
||||
engine's `relations-concat-map`/`-eng-member?`/`children-of`. + `relations/all-paths`
|
||||
wrapper, `lib/relations/tests/routes.sx` (9 tests: two-route diamond, single
|
||||
route, no route, self, route-through-cycle, route count, kind isolation).
|
||||
- **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
|
||||
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
|
||||
`erel(S,D,K) :- peer_rel(P,S,D,K), trust(P)` (peer link, gated by a local trust
|
||||
fact). reach/reach_any/rnode/has_parent/has_child all read `erel`, and the
|
||||
direct-query fns moved into engine.sx to query `erel` too — so with no
|
||||
peer_rel/trust facts `erel ≡ rel` and Phases 1–3 are unchanged. Trust is a body
|
||||
literal, re-checked every saturation, so it is non-transitive (only a peer's own
|
||||
links bind, only under local trust(P)) and revocation is immediate. New
|
||||
federation.sx: `relations-peer-rel`/`relations-trust` constructors, a mock
|
||||
fed-sx transport (`relations-fed-fetch`/`-collect` over a peer→links dict),
|
||||
`relations-fed-build-db` (local facts + pulled peer links), and
|
||||
`relations-fed-assert!`/`relations-revoke!` over a live db. fed.sx covers
|
||||
untrusted-link-doesn't-bind, trusted-link-binds (child + federated reachability
|
||||
+ connecting path through the federated edge), non-transitive trust (peerB's
|
||||
link inert without trust(peerB)), link revocation, trust revocation (local edge
|
||||
survives), transport pull with selective trust, and live fed-assert!. The shared
|
||||
recursive-reachability shape with acl is flagged (Phase 2 note); the trust-gate
|
||||
is the same convergence — still NOT extracted, per ground rules.
|
||||
- **Phase 3 — typed relations + path explanation** (70/70). New `explain.sx`:
|
||||
`relations-path(db,a,b,kind)` is relations' answer to acl's proof tree — the
|
||||
`reach(K,a,b)` derivation read off as the node chain. lib/datalog/ keeps no
|
||||
provenance, so the chain is re-derived breadth-first over the saturated edge set
|
||||
(`relations-children-of` per frontier node) so the returned path is a SHORTEST
|
||||
derivation; every consecutive pair is a real `rel` fact (no invented edges) and
|
||||
a visited set makes cyclic data terminate. `relations-distance` = hops (0 for
|
||||
a=b, nil if unreachable). Mixed-kind reachability added to engine.sx as a
|
||||
kind-agnostic `reach_any` closure (`relations-descendants-any`,
|
||||
`relations-reachable-any?`) — distinct from single-kind `reach`, so tests show a
|
||||
parent+member graph where a→m is reachable cross-kind but not under `parent`
|
||||
alone. api/explain grew `relations/path`, `/distance`, `/descendants-any`,
|
||||
`/reachable-any?` current-db wrappers. path.sx covers shortest-among-many
|
||||
(a→c→d beats a→b→c→d), direct edge, self path, no-path/disconnected, kind
|
||||
isolation in paths, mixed vs single kind, and path-out-of-a-cycle. Note: the
|
||||
dict-mode conformance driver has no per-suite timeout and the shared machine is
|
||||
contended by sibling loops — a full run can take a few minutes; the path suite
|
||||
alone runs in <1s.
|
||||
- **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
|
||||
via `dl-program-data facts relations-rules` (Phase 1 rules empty — direct queries
|
||||
need none); `relations-children-of`/`-parents-of`/`-related` are plain `dl-query`
|
||||
on the `rel` relation, plucking the bound column from substitution dicts;
|
||||
current-db convenience layer (`relations/load!`, `relations/relate`,
|
||||
`relations/unrelate`, `relations/children`/`parents`/`related`) over `dl-assert!`/
|
||||
`dl-retract!`, mirroring lib/acl/api.sx. Tests cover direct children/parents, leaf/
|
||||
root empties, kind isolation (parent query skips reply edge), retract, the api
|
||||
layer, and schema/constructor shape. Note: query result order is nondeterministic
|
||||
— tests use an order-insensitive `set=?`.
|
||||
|
||||
## Blockers
|
||||
|
||||
|
||||
Reference in New Issue
Block a user