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/trunk/src/compiler/MiscUtil/util/feedback-old.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/MiscUtil/util/feedback-old.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 793 - (view) (download)

1 : dbm 793 (* feedback.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     structure Feedback :
8 :     sig val scc : (int * int list) list -> (int * int list) list list
9 :     (* Strongly-connected components of a graph *)
10 :     val feedback : (int * int list) list -> int list
11 :     (* Minimum feedback vertex set of a graph *)
12 :     end =
13 :     (* Input: A directed graph; that is, a list of vertex-numbers,
14 :     each node with a list of out-edges which indicate other vertices.
15 :     Output: A minimum feedback vertex set.
16 :    
17 :     Method: branch and bound
18 :    
19 :     NOTE: By setting MAXDEPTH=infinity, this algorithm will produce
20 :     the exact minimum feedback vertex set. With MAXDEPTH<infinity,
21 :     the result will still be a feedback vertex set, but not
22 :     always the minimum set. However, on almost all real programs,
23 :     MAXDEPTH=3 will give perfect and efficiently computed results.
24 :     Increasing MAXDEPTH will not make the algorithm take longer or
25 :     produce better results on "real" programs.
26 :    
27 :     *)
28 :    
29 :     struct
30 :    
31 :     (* I want to get rid of SortedList, so I fake the required routines here.
32 :     * Eventually, this module should be cleaned up!
33 :     * - Matthias 11/2000 *)
34 :    
35 :     val sluniq = SortedList.uniq
36 :     val slmember = SortedList.member
37 :     val sldiff = SortedList.difference
38 :    
39 :     type node = int * int list
40 :     type graph = node list
41 :    
42 :     val infinity = 1000000000
43 :    
44 :     fun minl l =
45 :     let fun f(i,nil) = i | f(i,j::rest) = if i<j then f(i,rest) else f(j,rest)
46 :     in f(infinity,l)
47 :     end
48 :    
49 :     fun all (a::rest) = a andalso all rest | all nil = true
50 :    
51 :     fun forall nil f = () | forall (a::r) f = (f a; forall r f)
52 :    
53 :     fun filter f nil = nil | filter f (x::rest) = if f x then x::filter f rest
54 :     else filter f rest
55 :    
56 :     val normalize : graph -> graph = map (fn(n,e)=>(n,sluniq e))
57 :    
58 :     fun scc nil = nil (* quickie special case; the general case still works
59 :     but is slower *)
60 :     | scc nodes =
61 :     let exception Unseen
62 :     type info = {dfsnum: int ref,
63 :     sccnum: int ref,
64 :     edges: int list}
65 :     val m : info IntHashTable.hash_table = IntHashTable.mkTable(32,Unseen)
66 :     val lookup = IntHashTable.lookup m
67 :    
68 :     val compnums = ref 0 and id = ref 0
69 :     val comps = ref (nil: (int * int list) list list)
70 :    
71 :     val stack : (int * info) list ref = ref nil
72 :    
73 :     fun scc' nodenum =
74 :     (* Find strongly-connected components of a graph;
75 :     return a list of components; each component is a graph
76 :     with no edges pointing out of the component *)
77 :     let val info as {dfsnum as ref d, sccnum, edges} = lookup nodenum
78 :     (* prune: gets rid of edges out of the component *)
79 :     fun prune c = filter (fn i => !(#sccnum(lookup i)) = c)
80 :    
81 :     fun gather(c,bag,(n' as (n,{sccnum,dfsnum,edges}))::rest) =
82 :     (sccnum := c; dfsnum := infinity;
83 :    
84 :     (* print n; print " "; print c; print "\n"; *)
85 :     if n=nodenum then (map (fn (n,{edges,...})=>
86 :     (n, prune c edges))
87 :     (n'::bag),
88 :     rest)
89 :     else gather(c,n'::bag,rest))
90 :     val v = !id
91 :     in if d >= 0 then d
92 :     else (id := v+1;
93 :     stack := (nodenum, info) :: !stack;
94 :     dfsnum := v;
95 :     let val b = minl(map scc' edges)
96 :     in if v <= b
97 :     then let val c = !compnums
98 :     val _ = compnums := c+1
99 :     val (newcomp,s) = gather(c,nil,!stack)
100 :     in stack := s;
101 :     comps := newcomp :: !comps;
102 :     v
103 :     end
104 :     else b
105 :     end)
106 :     end
107 :    
108 :     in (*print "\nInput: "; forall nodes (fn (i,_) => (print i; print " "));*)
109 :     forall nodes
110 :     (fn (f,edges) => IntHashTable.insert m
111 :     (f,{dfsnum=ref ~1, sccnum=ref ~1, edges=edges}));
112 :     forall nodes (fn (vertex,edges) => scc' vertex);
113 :     (* print "\nOutput:";
114 :     forall (!comps) (fn l =>
115 :     (forall l (fn (i:int,_) => (print i; print " "));
116 :     print "; "));
117 :     print "\n";
118 :     *) !comps
119 :     end
120 :    
121 :     (* A "trivial" component is just a single node with no self loop *)
122 :     fun trivial [(_,[])] = true
123 :     | trivial _ = false
124 :    
125 :     (*
126 :     val printlist = app( fn i:int => (print i; print " "))
127 :     (print "f "; print lim; print " "; printlist (map #1 left);
128 :     print "("; print x; print ") "; printlist (map #1 right); print "\n";
129 :     print "try "; print limit; print " "; printlist (map #1 nodes); print "\n";
130 :     *)
131 :    
132 :    
133 :    
134 :     fun feedb(limit,graph:graph, 0) =
135 :     if limit >= length graph
136 :     then ((* print "Approximating!";
137 :     app (fn (n,_)=>(print " "; print (Int.toString n))) graph; print "\n"; *)
138 :     SOME(map #1 graph))
139 :     else ( (*print "Pessimistic!\n";*) NONE)
140 :    
141 :    
142 :     | feedb(limit, graph, depth) =
143 :     (* return a minimum feedback vertex set for graph,
144 :     of size no bigger then limit; else return NONE *)
145 :     if depth<=0 andalso limit >= length graph
146 :     then ((* print "Approximating!";
147 :     app (fn (n,_)=>(print " "; print n)) graph; print "\n";*)
148 :     SOME(map #1 graph))
149 :     else
150 :     ( (*print (substring(".............................",0,!MAXDEPTH+1-depth));
151 :     print (length graph); print " "; print limit;
152 :     print "\n"; *)
153 :    
154 :     let val comps = filter (not o trivial) (scc graph)
155 :     fun g(lim, set, c::comps) =
156 :     if lim>0
157 :     then (case try(lim,c,depth)
158 :     of NONE => NONE
159 :     | SOME vl => g(lim-(length vl - 1), vl@set, comps))
160 :     else NONE
161 :     | g(lim, set, nil) = SOME set
162 :     in g(limit - length comps + 1, nil, comps)
163 :     end
164 :     )
165 :    
166 :     and try(limit, nodes: graph,depth) =
167 :     (* "nodes" is a strongly-connected component; remove each node in turn
168 :     and find the minimum feedback vertex set of the result.
169 :     The resulting set must be no bigger than limit, or don't bother. *)
170 :     let fun f(best,lim,left,nil) = best
171 :     | f(best,lim,left as _::_, (node as (_,[_]))::right) =
172 :     (* A node with only one out-edge can't be part of
173 :     a unique minimum feedback vertex set, unless they
174 :     all have one out-edge. *)
175 :     f(best,lim,node::left,right)
176 :     | f(best,lim,left,(node as (x,_))::right) =
177 :     let fun prune (n,el) = (n, filter (fn e=>e<>x) el)
178 :     val reduced = map prune (left@right)
179 :     in case feedb(lim-1, reduced,depth-1)
180 :     of SOME vl => f(SOME(x::vl), length vl,
181 :     node::left, right)
182 :     | NONE => f(best,lim,node::left,right)
183 :     end
184 :     in f(NONE, Int.min(limit,length nodes), nil, nodes)
185 :     end
186 :    
187 :     val scc = scc o normalize
188 :    
189 :     val MAXDEPTH= 3 (* let's approximate! *)
190 :    
191 :     fun feedback1 graph = case feedb(length graph, graph,MAXDEPTH)
192 :     of SOME set => set
193 :    
194 :     fun pruneMany (out,g) =
195 :     let val out' = sluniq out
196 :     fun pruneNode(n,e) = (n,sldiff(e,out'))
197 :     in map pruneNode g
198 :     end
199 :    
200 :     fun selfloops ((n,e)::rest) =
201 :     let val (selfn,nonselfn) = selfloops rest
202 :     in if slmember e n
203 :     then (n::selfn,nonselfn)
204 :     else (selfn,(n,e)::nonselfn)
205 :     end
206 :     | selfloops nil = (nil,nil)
207 :    
208 :     (* any node with an edge to itself MUST be in the minimum feedback
209 :     vertex set; remove these "selfnodes" first to make the problem easier.
210 :     Relies on the fact that out-edges are sorted (result of "normalize").
211 :     *)
212 :     val feedback2 = fn graph =>
213 :     let val (selfnodes,rest) = selfloops graph
214 :     in selfnodes @ feedback1 (pruneMany(selfnodes,rest))
215 :     end
216 :    
217 :     val feedback = feedback2 o normalize
218 :    
219 :     end
220 :    

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