giles
ffe3ec25ac
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
108 lines
3.2 KiB
Plaintext
108 lines
3.2 KiB
Plaintext
;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles.
|
|
;;
|
|
;; The whole engine is one Datalog ruleset. Reachability is the bottom-up
|
|
;; transitive closure acl-on-sx uses for inheritance, but parameterised by Kind
|
|
;; so closures never leak across kinds: `reach` carries the kind as its first
|
|
;; argument, so a `parent` walk can never cross a `reply` edge.
|
|
;;
|
|
;; reach(K,X,Y) :- rel(X,Y,K). ; one hop
|
|
;; reach(K,X,Y) :- rel(X,Z,K), reach(K,Z,Y). ; transitive
|
|
;;
|
|
;; `reach_any` is the kind-agnostic closure (any edge, any kind) used for
|
|
;; mixed-kind reachability — distinct from single-kind `reach`.
|
|
;;
|
|
;; rnode collects the nodes touched by a kind; root/leaf are those with no
|
|
;; incoming / no outgoing edge (stratified negation over has_parent/has_child).
|
|
;; Cycles are ordinary data: `reach(K,X,X)` simply holds for nodes on a cycle —
|
|
;; cycle?/acyclic? are queries, not errors. Do not assume a DAG.
|
|
|
|
(define
|
|
relations-rules
|
|
(quote
|
|
((reach K X Y <- (rel X Y K))
|
|
(reach K X Y <- (rel X Z K) (reach K Z Y))
|
|
(reach_any X Y <- (rel X Y K))
|
|
(reach_any X Y <- (rel X Z K) (reach_any Z Y))
|
|
(rnode K X <- (rel X Y K))
|
|
(rnode K Y <- (rel X Y K))
|
|
(has_parent K Y <- (rel X Y K))
|
|
(has_child K X <- (rel X Y K))
|
|
(root K X <- (rnode K X) {:neg (has_parent K X)})
|
|
(leaf K X <- (rnode K X) {:neg (has_child K X)}))))
|
|
|
|
;; Pull one column (by keyword key) out of a list of substitution dicts.
|
|
(define
|
|
relations-pluck
|
|
(fn (substs key) (map (fn (s) (get s key)) substs)))
|
|
|
|
;; Transitive descendants of node under kind (everything reachable forward).
|
|
(define
|
|
relations-descendants
|
|
(fn
|
|
(db node kind)
|
|
(relations-pluck
|
|
(dl-query db (list (quote reach) kind node (quote Y)))
|
|
:Y)))
|
|
|
|
;; Transitive ancestors of node under kind (everything that reaches node).
|
|
(define
|
|
relations-ancestors
|
|
(fn
|
|
(db node kind)
|
|
(relations-pluck
|
|
(dl-query db (list (quote reach) kind (quote X) node))
|
|
:X)))
|
|
|
|
;; Is b reachable from a under kind (transitive)?
|
|
(define
|
|
relations-reachable?
|
|
(fn
|
|
(db a b kind)
|
|
(> (len (dl-query db (list (quote reach) kind a b))) 0)))
|
|
|
|
;; 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)))
|