You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

81 lines
2.3 KiB

  1. module M = import "data/map.ml"
  2. module S = import "data/set.ml"
  3. open import "prelude.ml"
  4. type t 'a <- M.t 'a (S.t 'a)
  5. let sccs (graph : t 'a) =
  6. let rec dfs (node : 'a) (path : M.t 'a int) (sccs : M.t 'a 'a) =
  7. let shallower old candidate =
  8. match M.lookup old path, M.lookup candidate path with
  9. | _, None -> old
  10. | None, _ -> candidate
  11. | Some a, Some b ->
  12. if b < a then candidate else old
  13. let children =
  14. match M.lookup node graph with
  15. | Some t -> t
  16. | None -> error "Node not in graph?"
  17. let go (folded, shallowest) child =
  18. match M.lookup child path with
  19. | Some _ ->
  20. (folded, shallower shallowest child)
  21. | _ ->
  22. let scc = dfs child (M.insert node (length path) path) folded
  23. let sfc =
  24. match M.lookup child scc with
  25. | Some x -> x
  26. | None -> error "no child in scc?"
  27. (scc, shallower shallowest sfc)
  28. let (new, shallowest) =
  29. S.members children |> foldl go (sccs, node)
  30. M.insert node shallowest new
  31. let go sccs next =
  32. match M.lookup next sccs with
  33. | Some _ -> sccs
  34. | _ -> dfs next M.empty sccs
  35. graph
  36. |> M.keys
  37. |> foldl go M.empty
  38. let toposort (graph : t 'a) : list 'a =
  39. let nodes = M.keys graph
  40. let l = ref []
  41. let temp = ref S.empty
  42. let perm = ref S.empty
  43. let rec visit n =
  44. if n `S.member` !perm then
  45. ()
  46. else if n `S.member` !temp then
  47. error "not a dag"
  48. else
  49. let o_temp = !temp
  50. temp := S.insert n o_temp
  51. match M.lookup n graph with
  52. | None -> ()
  53. | Some xs -> iter visit (S.members xs)
  54. temp := o_temp
  55. perm := S.insert n !perm
  56. l := n :: !l
  57. iter visit nodes
  58. reverse !l
  59. let groups_of_sccs (graph : t 'a) =
  60. let sccs = sccs graph
  61. let edges_of n =
  62. match M.lookup n graph with
  63. | None -> error "not in graph"
  64. | Some v -> v
  65. let components =
  66. sccs
  67. |> M.assocs
  68. |> map (fun (k, s) -> M.singleton s (S.singleton k))
  69. |> foldl (M.union_by (fun _ -> S.union)) M.empty
  70. let comp_deps =
  71. components
  72. |> M.assocs
  73. |> map (fun (node, edges) -> (node, edges_of node `S.difference` edges))
  74. |> M.from_list
  75. let ordering = toposort comp_deps
  76. [ x | with k <- ordering, with Some x <- [M.lookup k components] ]