17 [C;M;I], Le, [M;I]; (* ??? *)
19 [I;M;C], Ge, [I;M]; (* ??? *)
27 let swap = function Le -> Ge | Ge -> Le;;
32 | M::tl -> new_dir (swap dir) tl
33 | (C|I)::tl -> new_dir dir tl
36 let string_of_dir = function Le -> "<=" | Ge -> ">=";;
40 (List.map (function I -> "i" | C -> "c" | M -> "-") w)
43 let string_of_eqclass eqc =
44 let eqc = List.sort compare eqc in
45 String.concat "=" (List.map string_of_w eqc)
48 let print = List.iter (fun eqc -> prerr_endline (string_of_eqclass eqc));;
52 let (@@) l1 ll2 = List.map (function l2 -> l1 @ l2) ll2;;
58 | he::tl -> aux (if List.mem he l then l else he::l) tl
63 let rec apply_rule_at_beginning (lhs,dir',rhs) (w,dir) =
70 | x::lhs,x'::w when x = x' -> aux (lhs,w)
71 | _,_ -> raise NoMatch
73 rhs @@ apply_rules (aux (lhs,w),new_dir dir lhs)
74 and apply_rules (w,_ as w_and_dir) =
81 (try apply_rule_at_beginning rule w_and_dir
89 let apply_rules (w,dir as w_and_dir) =
90 List.map (fun w' -> w,dir,w')
91 (uniq (apply_rules w_and_dir))
94 let step (l : w list) =
99 List.map (fun x -> x@w)
100 (if List.mem M w then
103 [[I];[C](*;[M]*);[]])
108 let rec aux avoid x y =
111 (fun (x',z) -> x=x' && not (List.mem z avoid) && aux (z::avoid) z y) rels
116 let in_class rels eqc he =
119 | k::_ -> leq rels k he && leq rels he k
122 let add_class rels classes he =
124 let rec aux visited =
128 if in_class rels eqc he then
129 (he::eqc)::tl@visited
131 aux (eqc::visited) tl
136 let classify (l : w list) =
137 prerr_endline ("Classify: " ^ string_of_int (List.length l));
139 List.flatten (List.map (fun x -> apply_rules (x,Le) @ apply_rules (x,Ge)) l)
143 (function (x,rel,y) -> match rel with Le -> x,y | Ge -> y,x) rels)
146 let visualize graph =
148 (*Graph.Pack.Digraph.dot_output graph dot;*)
149 Graph.Pack.Digraph.display_with_gv graph;
152 let ch = open_out "/tmp/comb.dot" in
153 output_string ch dot;
155 Unix.system ("tred /tmp/comb.dot > /tmp/red.dot");
156 Unix.system ("dot -Tps /tmp/red.dot > /tmp/red.ps");
157 Unix.system ("ggv /tmp/red.ps");
163 let cache = ref [] in
173 | he::tl -> aux (acc * 4 + (match he with I -> 1 | C -> 2 | M -> 3)) tl
177 prerr_endline (string_of_w w ^ " => " ^ string_of_int n);
178 let v = Graph.Pack.Digraph.V.create n in
179 cache := (w,v)::!cache;
181 let graph = Graph.Pack.Digraph.create () in
184 Graph.Pack.Digraph.add_edge graph (mk_vertex x) (mk_vertex y)) arcs;
185 prerr_endline ("<CLASSI>");
186 let classes = Graph.Pack.Digraph.Components.scc_list graph in
187 List.iter (function l -> prerr_endline (String.concat "=" (List.map string_of_int (List.map Graph.Pack.Digraph.V.label l)))) classes;
188 prerr_endline ("</CLASSI>");
189 let classes,normalize = Graph.Pack.Digraph.Components.scc graph in
190 prerr_endline (string_of_int classes ^ " CLASSI");
191 let arcs = uniq (List.map (fun (x,y) -> normalize (mk_vertex x),normalize (mk_vertex y)) arcs) in
192 let cgraph = Graph.Pack.Digraph.create () in
195 Graph.Pack.Digraph.add_edge cgraph (Graph.Pack.Digraph.V.create x) (Graph.Pack.Digraph.V.create y)) arcs;
200 let arcs = analyze (classify l) in
201 (*print_graph' (analyze arcs);*)
203 iter (n - 1) (step l)