rose-ash/lib/relations/engine.sx

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