rose-ash/lib/relations/tree.sx

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