Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/FLINT/src/comp-lib/scc.sml
ViewVC logotype

Annotation of /sml/branches/FLINT/src/comp-lib/scc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 89 - (view) (download)
Original Path: sml/trunk/src/comp-lib/scc.sml

1 : monnier 89 (* scc.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 Bell Laboratories.
4 :     *
5 :     * Calculate strongly-connected components of directed graph.
6 :     * The graph can have nodes with self-loops.
7 :     *
8 :     * author: Matthias Blume
9 :     *
10 :     *)
11 :    
12 :     signature SCCNODE = sig
13 :     type node
14 :     val eq: node * node -> bool
15 :     val lt: node * node -> bool
16 :     end
17 :    
18 :     signature SCC = sig
19 :    
20 :     structure Node: SCCNODE
21 :    
22 :     datatype component =
23 :     SIMPLE of Node.node (* singleton, no self-loop *)
24 :     | RECURSIVE of Node.node list
25 :    
26 :     (* take root node and follow function and return
27 :     * list of topologically sorted strongly-connected components;
28 :     * root component goes first *)
29 :     val topOrder:
30 :     { root: Node.node, follow: Node.node -> Node.node list } ->
31 :     component list
32 :     end
33 :    
34 :     functor SCCUtilFun (structure Node: SCCNODE): SCC = struct
35 :    
36 :     exception SccBug
37 :    
38 :     structure Node = Node
39 :    
40 :     structure NodeOrdSet = struct
41 :     type elem = Node.node
42 :     val (op <) = Node.lt
43 :     end
44 :    
45 :     structure Map = MapF (NodeOrdSet)
46 :    
47 :     type node = Node.node
48 :    
49 :     datatype component =
50 :     SIMPLE of node
51 :     | RECURSIVE of node list
52 :    
53 :     fun topOrder { root, follow } = let
54 :    
55 :     fun getNode (n, nm as (npre, m)) =
56 :     (nm, (Map.lookup m n))
57 :     handle Map.MapF => let
58 :     val r = { pre = npre, low = ref npre }
59 :     val m' = Map.add (m, n, r)
60 :     in
61 :     ((npre + 1, m'), r)
62 :     end
63 :    
64 :     fun theNode x y = Node.eq (x, y)
65 :    
66 :     fun component (x, []) =
67 :     if List.exists (theNode x) (follow x) then
68 :     RECURSIVE [x]
69 :     else
70 :     SIMPLE x
71 :     | component (x, xl) = RECURSIVE (x :: xl)
72 :    
73 :     (* depth-first search in continuation-passing, state-passing style *)
74 :     fun dfs args = let
75 :    
76 :     (* the nodemap represents the mapping from nodes to
77 :     * pre-order numbers and low-numbers. The latter are ref-cells.
78 :     * nodemap also remembers the next available pre-order number. *)
79 :     val { node, node_pre, node_low, parent_low, nodemap,
80 :     stack, sccl, cont } = args
81 :    
82 :     (* loop over the follow-set of a node *)
83 :     fun loop [] (nodemap, stack, sccl) =
84 :     let
85 :     val nl = !node_low
86 :     in
87 :     if nl = node_pre then
88 :     let
89 :     fun grab (top :: stack, scc) =
90 :     if Node.eq (top, node) then
91 :     cont (nodemap, stack,
92 :     component (top, scc) :: sccl)
93 :     else
94 :     grab (stack, top :: scc)
95 :     | grab _ = raise SccBug
96 :     in
97 :     grab (stack, [])
98 :     end
99 :     else let
100 :     val _ =
101 :     (* propagate node_low up *)
102 :     if nl < (!parent_low) then parent_low := nl else ()
103 :     in
104 :     (* `return' *)
105 :     cont (nodemap, stack, sccl)
106 :     end
107 :     end
108 :     | loop (tn :: tnl) (nodemap as (npre, theMap), stack, sccl) = let
109 :     val { pre = tn_pre, low = tn_low } = Map.lookup theMap tn
110 :     (* the lookup succeeded -> we have seen tn before *)
111 :     val tl = !tn_low
112 :     in
113 :     if tl < (!node_low) andalso
114 :     List.exists (theNode tn) stack then
115 :     node_low := tl
116 :     else ();
117 :     loop tnl (nodemap, stack, sccl)
118 :     end handle Map.MapF => let
119 :     (* lookup failed -> tn is a new node *)
120 :     val tn_pre = npre
121 :     val tn_low = ref npre
122 :     val npre = npre + 1
123 :     val theMap = Map.add (theMap, tn,
124 :     { pre = tn_pre, low = tn_low })
125 :     val nodemap = (npre, theMap)
126 :     in
127 :     dfs { node = tn, node_pre = tn_pre, node_low = tn_low,
128 :     parent_low = node_low,
129 :     nodemap = nodemap,
130 :     stack = tn :: stack,
131 :     sccl = sccl,
132 :     cont = loop tnl }
133 :     end
134 :     in
135 :     loop (follow node) (nodemap, stack, sccl)
136 :     end
137 :    
138 :     val root_low = ref 0
139 :     in
140 :     dfs { node = root, node_pre = 0, node_low = root_low,
141 :     parent_low = ref 0, (* dummy *)
142 :     nodemap = (1, Map.singleton (root, { pre = 0, low = root_low })),
143 :     stack = [root],
144 :     sccl = [],
145 :     cont = fn (_, _, sccl) => sccl }
146 :     end
147 :     end
148 :    
149 :     (*
150 :     * $Log: scc.sml,v $
151 :     * Revision 1.1.1.1 1998/04/08 18:39:14 george
152 :     * Version 110.5
153 :     *
154 :     *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0