ahc-old/lib/graph.ml

module M = import "data/map.ml"
module S = import "data/set.ml"

open import "prelude.ml"

type t 'a <- M.t 'a (S.t 'a)

let sccs (graph : t 'a) =
  let rec dfs (node : 'a) (path : M.t 'a int) (sccs : M.t 'a 'a) =
    let shallower old candidate =
      match M.lookup old path, M.lookup candidate path with
      | _, None -> old
      | None, _ -> candidate
      | Some a, Some b ->
          if b < a then candidate else old
    let children =
      match M.lookup node graph with
      | Some t -> t
      | None -> error "Node not in graph?"
    let go (folded, shallowest) child =
        match M.lookup child path with
        | Some _ ->
            (folded, shallower shallowest child)
        | _ ->
            let scc = dfs child (M.insert node (length path) path) folded
            let sfc =
              match M.lookup child scc with
              | Some x -> x
              | None -> error "no child in scc?"
            (scc, shallower shallowest sfc)
    let (new, shallowest) =
      S.members children |> foldl go (sccs, node)
    M.insert node shallowest new
  let go sccs next =
    match M.lookup next sccs with
    | Some _ -> sccs
    | _ -> dfs next M.empty sccs
  graph
    |> M.keys
    |> foldl go M.empty

let toposort (graph : t 'a) : list 'a =
  let nodes = M.keys graph
  let l = ref []
  let temp = ref S.empty
  let perm = ref S.empty
  let rec visit n =
    if n `S.member` !perm then
      ()
    else if n `S.member` !temp then
      error "not a dag"
    else
      let o_temp = !temp
      temp := S.insert n o_temp
      match M.lookup n graph with
      | None -> ()
      | Some xs -> iter visit (S.members xs)
      temp := o_temp
      perm := S.insert n !perm
      l := n :: !l
  iter visit nodes
  reverse !l

let groups_of_sccs (graph : t 'a) =
  let sccs = sccs graph
  let edges_of n =
    match M.lookup n graph with
    | None -> error "not in graph"
    | Some v -> v
  let components =
    sccs
      |> M.assocs
      |> map (fun (k, s) -> M.singleton s (S.singleton k))
      |> foldl (M.union_by (fun _ -> S.union)) M.empty
  let comp_deps =
     components
       |> M.assocs
       |> map (fun (node, edges) -> (node, edges_of node `S.difference` edges))
       |> M.from_list
  let ordering = toposort comp_deps
  [ x | with k <- ordering, with Some x <- [M.lookup k components] ]