lib/mlton/basic/directed-sub-graph.sig

   1 (* Copyright (C) 2009 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_SUB_GRAPH =
  10    sig
  11       (* the main graph type *)
  12       type t
  13
  14       structure Node:
  15          sig
  16             type graph
  17             type edge
  18             type t
  19
  20             val equals: t * t -> bool
  21             val hasEdge: graph * {from: t, to: t} -> bool
  22             val layout: t -> Layout.t
  23             val plist: t -> PropertyList.t
  24             val successors: graph * t -> edge list
  25          end
  26       structure Edge:
  27          sig
  28             type graph
  29             type node
  30             type t
  31
  32             val equals: t * t -> bool
  33             val from: graph * t -> node
  34             val plist: t -> PropertyList.t
  35             val to: graph * t -> node
  36          end
  37       sharing type Node.edge = Edge.t
  38       sharing type Edge.node = Node.t
  39       sharing type Node.graph = t
  40       sharing type Edge.graph = t
  41
  42       (* depth first search *)
  43       structure DfsParam:
  44          sig
  45             type t = {startNode: Node.t -> unit,
  46                       finishNode: Node.t -> unit,
  47                       handleTreeEdge: Edge.t -> unit,
  48                       handleNonTreeEdge: Edge.t -> unit,
  49                       startTree: Node.t -> unit,
  50                       finishTree: Node.t -> unit,
  51                       finishDfs: unit -> unit}
  52             val finishNode: (Node.t -> unit) -> t
  53             val ignore: 'a -> unit
  54             val combine: t * t -> t
  55          end
  56
  57       (* create a sub-graph from a graph *)
  58       val subGraph: t * {nodeP: Node.t -> bool, edgeP: Edge.t -> bool} -> t
  59       val supGraph: t -> t
  60
  61       val addEdge: t * {from: Node.t, to: Node.t} -> Edge.t
  62       val dfs: t * DfsParam.t -> unit
  63       val dfsNodes: t * Node.t list * DfsParam.t -> unit
  64       val discoverFinishTimes: t -> {discover: Node.t -> int,
  65                                      finish: Node.t -> int,
  66                                      destroy: unit -> unit,
  67                                      param: DfsParam.t}
  68       val display:
  69          {graph: t,
  70           layoutNode: Node.t -> Layout.t,
  71           display: Layout.t -> unit} -> unit
  72       (* dominators {graph, root}
  73        * Pre: All nodes in graph must be reachable from root.
  74        *      This condition is checked.
  75        * Returns idom, where
  76        *  idom n = the immediate dominator n.
  77        *  idom root = root.
  78        *)
  79       val dominators: t * {root: Node.t} -> {idom: Node.t -> Node.t}
  80       val dominatorTree: t * {root: Node.t, nodeValue: Node.t -> 'a} -> 'a Tree.t
  81       val foreachDescendent: t * Node.t * (Node.t -> unit) -> unit
  82       val foreachEdge: t * (Node.t * Edge.t -> unit) -> unit
  83       val foreachNode: t * (Node.t -> unit) -> unit
  84 (*      exception Input *)
  85 (*     val input: In.t * (In.t -> 'a)* (In.t -> 'b) -> t * 'a * (Edge.t -> 'b) *)
  86 (*      val isCyclic: t -> bool*)
  87       val layoutDot:
  88          t * {title: string,
  89               options: Dot.GraphOption.t list,
  90               edgeOptions: Edge.t -> Dot.EdgeOption.t list,
  91               nodeOptions: Node.t -> Dot.NodeOption.t list} -> Layout.t
  92       val loopForest:
  93          {headers: (* graph *) Node.t list -> (* graph *) Node.t list,
  94           graph: t,
  95           root: (* graph *) Node.t}
  96          -> {forest: t,
  97              graphToForest: (* graph *) Node.t -> (* forest *) Node.t,
  98              headers: (* graph *) Node.t list -> (* graph *) Node.t list,
  99              isHeader: (* graph *) Node.t -> bool,
 100              loopNodes: (* forest *) Node.t -> (* graph *) Node.t list,
 101              parent: (* forest *) Node.t -> (* forest *) Node.t option}
 102       val loopForestSteensgaard:
 103          {graph: t,
 104           root: (* graph *) Node.t}
 105          -> {forest: t,
 106              graphToForest: (* graph *) Node.t -> (* forest *) Node.t,
 107              headers: (* graph *) Node.t list -> (* graph *) Node.t list,
 108              isHeader: (* graph *) Node.t -> bool,
 109              loopNodes: (* forest *) Node.t -> (* graph *) Node.t list,
 110              parent: (* forest *) Node.t -> (* forest *) Node.t option}
 111       val new: unit -> t
 112       val newNode: t -> Node.t
 113       val nodes: t -> Node.t list
 114 (*      val random: {numNodes: int, numEdges: int} -> t*)
 115 (*      val removeBackEdges: t -> unit *)
 116       (* removeEdge fails if edge isn't there. *)
 117 (*      val removeEdge: t * Edge.t -> unit *)
 118       (* Strongly-connected components.
 119        * Each component is given as a list of nodes.
 120        * The components are returned topologically sorted.
 121        *)
 122       val stronglyConnectedComponents: t -> Node.t list list
 123       exception TopologicalSort
 124       val topologicalSort: t -> Node.t list
 125 (*      val transpose: t -> t *)
 126    end
 127
 128
 129 functor TestDirectedSubGraph (S: DIRECTED_SUB_GRAPH): sig end =
 130 struct
 131
 132 open S
 133
 134 (* Section 7.3 of Muchnick. *)
 135 local
 136    val g = new ()
 137    val {get = name, set = setName, ...} =
 138       Property.getSetOnce (Node.plist,
 139                            Property.initRaise ("name", Node.layout))
 140    val node = String.memoize (fn s =>
 141                               let
 142                                  val n = newNode g
 143                                  val _ = setName (n, s)
 144                               in n
 145                               end)
 146    val _ =
 147       List.foreach ([("entry\nfoo", "B1"),
 148                      ("B1", "B2"),
 149                      ("B1", "B3"),
 150                      ("B2", "exit"),
 151                      ("B3", "B4"),
 152                      ("B4", "B5"),
 153                      ("B4", "B6"),
 154                      ("B5", "exit"),
 155                      ("B6", "B4")], fn (from, to) =>
 156                     ignore (addEdge (g, {from = node from, to = node to})))
 157    val _ =
 158       File.withOut
 159       ("/tmp/z.dot", fn out =>
 160        let
 161           open Dot
 162        in
 163           Layout.output (layoutDot
 164                          (g,
 165                           {title = "Muchnick",
 166                            options = [],
 167                            edgeOptions = fn _ => [],
 168                            nodeOptions = fn n => [NodeOption.label (name n)]}),
 169                          out)
 170           ; Out.newline out
 171        end)
 172    val {idom} = dominators (g, {root = node "entry\nfoo"})
 173    val g2 = new ()
 174    val {get = oldNode, set = setOldNode, ...} =
 175       Property.getSetOnce (Node.plist,
 176                            Property.initRaise ("oldNode", Node.layout))
 177    val {get = newNode, ...} =
 178       Property.get (Node.plist,
 179                     Property.initFun (fn n =>
 180                                       let
 181                                          val n' = newNode g2
 182                                          val _ = setOldNode (n', n)
 183                                       in n'
 184                                       end))
 185    val _ = foreachNode (g, fn n =>
 186                         ignore (addEdge (g2, {from = newNode (idom n),
 187                                               to = newNode n})))
 188    val _ =
 189       File.withOut
 190       ("/tmp/z2.dot", fn out =>
 191        let
 192           open Dot
 193        in
 194           Layout.output
 195           (layoutDot
 196            (g2, {title = "dom",
 197                  options = [],
 198                  edgeOptions = fn _ => [],
 199                  nodeOptions = fn n => [NodeOption.label (name (oldNode n))]}),
 200            out)
 201           ; Out.newline out
 202        end)
 203 in
 204 end
 205
 206 end