17 [C;M;I], Le, [M;I]; (* ??? *)
19 [I;M;C], Ge, [I;M]; (* ??? *)
31 let swap = function Le -> Ge | Ge -> Le;;
36 | M::tl -> new_dir (swap dir) tl
37 | (C|I)::tl -> new_dir dir tl
42 (List.map (function I -> "i" | C -> "c" | M -> "-") w)
47 let (@@) l1 ll2 = List.map (function l2 -> l1 @ l2) ll2;;
50 let rec aux acc = function
53 | h1::h2::tl when h1=h2 -> aux (h2::acc) tl
54 | h1::tl (* when h1 <> h2 *) -> aux (h1::acc) tl
56 List.rev (aux [] (List.sort compare l))
59 let rec apply_rule_at_beginning (lhs,dir',rhs) (w,dir) =
66 | x::lhs,x'::w when x = x' -> aux (lhs,w)
67 | _,_ -> raise NoMatch
69 rhs @@ apply_rules (aux (lhs,w),new_dir dir lhs)
70 and apply_rules (w,_ as w_and_dir) =
77 (try apply_rule_at_beginning rule w_and_dir
85 let apply_rules (w,dir as w_and_dir) =
86 List.map (fun w' -> w,dir,w')
87 (uniq (apply_rules w_and_dir))
90 let step (l : w list) =
95 List.map (fun x -> x@w)
96 (if List.length (List.filter (fun w -> w = M) w) >= 2 then
108 if i mod 1000 = 0 then
110 print_string ("@" ^ string_of_int i ^ " ");
113 aux (f he :: acc) (i+1) tl
115 let res = List.rev (aux [] 1 l) in
125 if i mod 1000 = 0 then
127 print_string ("@" ^ string_of_int i ^ " ");
136 let normalize (l : w list) =
137 print_endline (string_of_int (List.length l) ^ " nodes to be normalized");
140 (mapi (fun x -> apply_rules (x,Le) @ apply_rules (x,Ge)) l) in
142 List.rev (List.rev_map
143 (function (x,rel,y) -> match rel with Le -> x,y | Ge -> y,x) rels) in
144 let res = uniq arcs in
148 let visualize describe graph =
151 include Graph.Pack.Digraph;;
152 let edge_attributes _ = []
153 let default_edge_attributes _ = []
154 let get_subgraph _ = None
155 let vertex_attributes v = [`Label (describe (Graph.Pack.Digraph.V.label v))]
156 let vertex_name v = "v" ^ string_of_int (Graph.Pack.Digraph.V.label v)
157 let default_vertex_attributes _ = []
158 let graph_attributes _ = []
160 let module D = Graph.Graphviz.Dot(G) in
161 let ch = open_out "/tmp/comb.dot" in
162 D.output_graph ch graph;
164 ignore (Unix.system ("tred /tmp/comb.dot > /tmp/red.dot"));
165 ignore (Unix.system ("dot -Tps /tmp/red.dot > /tmp/red.ps"));
166 (*Unix.system ("ggv /tmp/red.ps");*)
169 let mk_vertex_and_dsc_vertex =
171 let cache1 = Hashtbl.create 5393 in
172 let cache2 = Hashtbl.create 5393 in
175 Hashtbl.find cache1 w
182 | he::tl -> aux (acc * 4 + (match he with I -> 1 | C -> 2 | M -> 3)) tl
186 let v = Graph.Pack.Digraph.V.create n in
187 Hashtbl.add cache1 w v;
188 Hashtbl.add cache2 v w;
190 (Hashtbl.find cache2)
195 let cache1 = Hashtbl.create 5393 in
198 Hashtbl.find cache1 n
201 let v = Graph.Pack.Digraph.V.create n in
202 Hashtbl.add cache1 n v;
206 let string_compare s1 s2 =
207 let c = compare (String.length s1) (String.length s2) in
208 if c = 0 then String.compare s1 s2 else c
211 let normalize_and_describe norm mk_vertex dsc_vertex =
212 let cache = Hashtbl.create 5393 in
213 let canonicals = Hashtbl.create 5393 in
214 let descriptions = Hashtbl.create 5393 in
216 let v = mk_vertex n in
217 let normalized = norm v in
218 let dsc = dsc_vertex v in
219 if not (List.mem dsc (Hashtbl.find_all cache normalized)) then
220 Hashtbl.add cache normalized dsc;
223 let vertexes = uniq (Hashtbl.fold (fun k _ l -> k::l) cache []) in
228 List.sort string_compare
229 (List.map string_of_w (Hashtbl.find_all cache v))
231 iteri (function (_,w::_) -> Hashtbl.add canonicals w () | _ -> ()) xx;
232 let is_not_redundant s =
233 let len = String.length s in
234 if len <= 1 then true
236 let w = String.sub s 1 (len - 1) in
237 try Hashtbl.find canonicals w; true with Not_found -> false
241 Hashtbl.add descriptions v
242 (let s = String.concat "=" (List.filter is_not_redundant x) in
243 if s = "" then "." else s)) xx),
244 Hashtbl.find descriptions
248 print_endline (string_of_int (List.length arcs) ^ " arcs to be classified");
249 let mk_vertex,dsc_vertex = mk_vertex_and_dsc_vertex () in
250 let graph = Graph.Pack.Digraph.create () in
253 Graph.Pack.Digraph.add_edge graph (mk_vertex x) (mk_vertex y)) arcs;
254 print_endline ("<scc>");
255 let classes,norm = Graph.Pack.Digraph.Components.scc graph in
256 print_endline (string_of_int classes ^ " classes");
257 print_endline ("-----");
258 norm,mk_vertex,dsc_vertex,arcs
261 let analyze (norm,mk_vertex,dsc_vertex,arcs) =
262 print_endline ("building class graph (" ^ string_of_int (List.length arcs) ^ ")");
263 let normalize,finish,describe =
264 normalize_and_describe norm mk_vertex dsc_vertex in
266 uniq (mapi (fun (x,y) -> normalize x,normalize y) arcs) in
267 let cgraph = Graph.Pack.Digraph.create () in
268 let mk_vertex2 = mk_vertex2 () in
272 Graph.Pack.Digraph.add_edge cgraph (mk_vertex2 x) (mk_vertex2 y)) arcs;
273 print_endline "finish";
275 print_endline "visualize";
276 visualize describe cgraph;
277 print_endline ("/////");
281 let pkg = classify (normalize l) in
283 iter (n - 1) (step l)