lib/mlton/basic/directed-graph.sig

   1 (* Copyright (C) 2009,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 signature DIRECTED_GRAPH =
  10    sig
  11       structure Node:
  12          sig
  13             type 'a edge
  14             type 'a t
  15
  16             val equals: 'a t * 'a t -> bool
  17             val hasEdge: {from: 'a t, to: 'a t} -> bool
  18             val layout: 'a t -> Layout.t
  19             val plist: 'a t -> PropertyList.t
  20             val successors: 'a t -> 'a edge list
  21          end
  22       structure Edge:
  23          sig
  24             type 'a t
  25
  26             val equals: 'a t * 'a t -> bool
  27             val layout: 'a t -> Layout.t
  28             val plist: 'a t -> PropertyList.t
  29             val to: 'a t -> 'a Node.t
  30          end
  31       sharing type Node.edge = Edge.t
  32
  33       (* depth first search *)
  34       structure DfsParam:
  35          sig
  36             type ('a, 'b, 'c, 'd, 'e) t =
  37                'b
  38                * ('a Node.t * 'b
  39                   -> ('c
  40                       * ('a Node.t * 'c -> ('d
  41                                             * ('a Edge.t * 'd -> 'd)
  42                                             * ('a Edge.t * 'd -> 'c * ('e -> 'd))
  43                                             * ('d -> 'e)))
  44                       * ('e -> 'b)))
  45             type ('a, 'b) u = ('a, 'b, 'b, 'b, 'b) t
  46
  47             val discoverFinishTimes:
  48                unit -> (('a, int) u * {discover: 'a Node.t -> int,
  49                                        finish: 'a Node.t -> int,
  50                                        destroy: unit -> unit})
  51             val finishNode: ('a Node.t -> unit) -> ('a, unit) u
  52             val startNode: ('a Node.t -> unit) -> ('a, unit) u
  53          end
  54
  55       (* the main graph type *)
  56       type 'a t
  57       type 'a u
  58
  59       val addEdge: 'a t * {from: 'a Node.t, to: 'a Node.t} -> 'a Edge.t
  60       val coerce: 'a t -> unit t * {edge: 'a Edge.t -> unit Edge.t,
  61                                     node: 'a Node.t -> unit Node.t}
  62       val dfs: 'a t * ('a, 'b, 'c, 'd, 'e) DfsParam.t -> 'b
  63       val dfsForest: 'a t * {roots: 'a Node.t vector,
  64                              nodeValue: 'a Node.t -> 'b} -> 'b Tree.t vector
  65       val dfsNodes: 'a t * 'a Node.t list * ('a, 'b, 'c, 'd, 'e) DfsParam.t -> 'b
  66       val dfsTree: 'a t * {root: 'a Node.t,
  67                            nodeValue: 'a Node.t -> 'b} -> 'b Tree.t
  68       val display:
  69          {graph: 'a t,
  70           layoutNode: 'a Node.t -> Layout.t,
  71           display: Layout.t -> unit} -> unit
  72       (* dominators (graph, {root})
  73        * Returns the immediate dominator relation for the subgraph of graph
  74        * rooted at root.
  75        *  idom n = Root           if n = root
  76        *  idom n = Idom n'        where n' is the immediate dominator of n
  77        *  idom n = Unreachable    if n is not reachable from root
  78        *)
  79       datatype 'a idomRes =
  80          Idom of 'a Node.t
  81        | Root
  82        | Unreachable
  83       val dominators: 'a t * {root: 'a Node.t} -> {idom: 'a Node.t -> 'a idomRes}
  84       val dominatorTree: 'a t * {root: 'a Node.t,
  85                                  nodeValue: 'a Node.t -> 'b} -> 'b Tree.t
  86       val foreachDescendent: 'a t * 'a Node.t * ('a Node.t -> unit) -> unit
  87       val foldNodes: 'a t * 'b * ('a Node.t * 'b -> 'b) -> 'b
  88       val foreachEdge: 'a t * ('a Node.t * 'a Edge.t -> unit) -> unit
  89       val foreachNode: 'a t * ('a Node.t -> unit) -> unit
  90       (* ignoreNodes (g, f) builds a graph g' that looks like g, except that g'
  91        * does not contain nodes n such that f n, and that for every path in g
  92        * of the form n0 -> n1 -> ... -> nm, where n0 and nm are not ignored and
  93        * n1, ..., n_m-1 are ignored, there is an edge in g'.
  94        *)
  95       val ignoreNodes:
  96          'a t * ('a Node.t -> bool)
  97          -> 'a u t * {destroy: unit -> unit,
  98                       newNode: 'a Node.t -> 'a u Node.t}
  99       val layoutDot:
 100          'a t * ({nodeName: 'a Node.t -> string}
 101                  -> {edgeOptions: 'a Edge.t -> Dot.EdgeOption.t list,
 102                      nodeOptions: 'a Node.t -> Dot.NodeOption.t list,
 103                      options: Dot.GraphOption.t list,
 104                      title: string})
 105          -> Layout.t
 106       structure LoopForest:
 107          sig
 108             type 'a t
 109
 110             val dest: 'a t -> {loops: {headers: 'a Node.t vector,
 111                                        child: 'a t} vector,
 112                                notInLoop: 'a Node.t vector}
 113             val layoutDot:
 114                'a t * {nodeName: 'a Node.t -> string,
 115                        options: Dot.GraphOption.t list,
 116                        title: string}
 117                -> Layout.t
 118          end
 119       val loopForestSteensgaard: 'a t * {root: 'a Node.t} -> 'a LoopForest.t
 120       val new: unit -> 'a t
 121       val newNode: 'a t -> 'a Node.t
 122       val nodes: 'a t -> 'a Node.t list
 123       val numNodes: 'a t -> int
 124       (* quotient (g, v)
 125        * Pre: v should be an equivalence relation on the nodes of g.  That is,
 126        *   each node in g should appear exactly once in some vector in v.
 127        * The result is a graph with one node per equivalence class, and an edge
 128        * between classes iff there is an edge between nodes in the classes.
 129        *)
 130       val quotient:
 131          'a t * ('a Node.t vector vector)
 132          -> 'a u t * {destroy: unit -> unit,
 133                       newNode: 'a Node.t -> 'a u Node.t}
 134       (* Removes node and incident edges. *)
 135       val removeNode: 'a t * 'a Node.t -> unit
 136       val removeDuplicateEdges: 'a t -> unit
 137       (* Strongly-connected components.
 138        * Each component is given as a list of nodes.
 139        * The components are returned topologically sorted.
 140        *)
 141       val stronglyConnectedComponents: 'a t -> 'a Node.t list list
 142       val subgraph:
 143          'a t * ('a Node.t -> bool)
 144          -> 'a u t * {destroy: unit -> unit,
 145                       newNode: 'a Node.t -> 'a u Node.t}
 146       (* topologicalSort g returns NONE if there is a cycle in g.
 147        * Otherwise, returns then nodes in g in a list such that if there is a
 148        * path in g from n to n', then n appears before n' in the list.
 149        *)
 150       val topologicalSort: 'a t -> 'a Node.t list option
 151       val transpose: 'a t -> 'a u t * {destroy: unit -> unit,
 152                                        newNode: 'a Node.t -> 'a u Node.t}
 153    end
 154
 155
 156 functor TestDirectedGraph (S: DIRECTED_GRAPH): sig end =
 157 struct
 158
 159 open S
 160
 161 (* Section 7.3 of Muchnick. *)
 162 local
 163    val g = new ()
 164    val {get = name, set = setName, ...} =
 165       Property.getSetOnce (Node.plist,
 166                            Property.initRaise ("name", Node.layout))
 167    val node = String.memoize (fn s =>
 168                               let
 169                                  val n = newNode g
 170                                  val _ = setName (n, s)
 171                               in n
 172                               end)
 173    val _ =
 174       List.foreach ([("entry\nfoo", "B1"),
 175                      ("B1", "B2"),
 176                      ("B1", "B3"),
 177                      ("B2", "exit"),
 178                      ("B3", "B4"),
 179                      ("B4", "B5"),
 180                      ("B4", "B6"),
 181                      ("B5", "exit"),
 182                      ("B6", "B4")], fn (from, to) =>
 183                     ignore (addEdge (g, {from = node from, to = node to})))
 184    val _ =
 185       File.withOut
 186       ("/tmp/z.dot", fn out =>
 187        let
 188           open Dot
 189        in
 190           Layout.output (layoutDot
 191                          (g, fn _ =>
 192                           {title = "Muchnick",
 193                            options = [],
 194                            edgeOptions = fn _ => [],
 195                            nodeOptions = fn n => [NodeOption.label (name n)]}),
 196                          out)
 197           ; Out.newline out
 198        end)
 199    val {idom} = dominators (g, {root = node "entry\nfoo"})
 200    val g2 = new ()
 201    val {get = oldNode, set = setOldNode, ...} =
 202       Property.getSetOnce (Node.plist,
 203                            Property.initRaise ("oldNode", Node.layout))
 204    val {get = newNode, ...} =
 205       Property.get (Node.plist,
 206                     Property.initFun (fn n =>
 207                                       let
 208                                          val n' = newNode g2
 209                                          val _ = setOldNode (n', n)
 210                                       in n'
 211                                       end))
 212    val _ = foreachNode (g, fn n =>
 213                         case idom n of
 214                            Idom n' =>
 215                               ignore (addEdge (g2, {from = newNode n',
 216                                                     to = newNode n}))
 217                          | _ => ())
 218    val _ =
 219       File.withOut
 220       ("/tmp/z2.dot", fn out =>
 221        let
 222           open Dot
 223        in
 224           Layout.output
 225           (layoutDot
 226            (g2, fn _ =>
 227             {title = "dom",
 228              options = [],
 229              edgeOptions = fn _ => [],
 230              nodeOptions = fn n => [NodeOption.label (name (oldNode n))]}),
 231            out)
 232           ; Out.newline out
 233        end)
 234 in
 235 end
 236
 237 end