-let normalize_and_describe norm =
- let cache = Hashtbl.create 5393 in
- let canonicals = Hashtbl.create 5393 in
- let descriptions = Hashtbl.create 5393 in
- (function v ->
- let normalized = norm v in
- let _,_,dsc = G.V.label v in
- if not (List.mem dsc (Hashtbl.find_all cache normalized)) then
- Hashtbl.add cache normalized dsc;
- normalized),
- (function () ->
- let vertexes = uniq (Hashtbl.fold (fun k _ l -> k::l) cache []) in
- let xx =
- mapi
- (fun v -> v, List.sort w_compare (Hashtbl.find_all cache v)) vertexes in
- iteri (function (_,w::_) -> Hashtbl.add canonicals w () | _ -> ()) xx;
- let is_not_redundant =
- function
- [] | [_] -> true
- | _::w ->
- try Hashtbl.find canonicals w; true with Not_found -> false
- in
- iteri
- (function (v,x) ->
- Hashtbl.add descriptions v ((List.filter is_not_redundant x) : eqclass)) xx),
- Hashtbl.find descriptions
-;;
-
-let classify arcs =
- print_endline (string_of_int (List.length arcs) ^ " arcs to be classified");
- let graph = G.create () in
- iteri (fun (x,y) -> G.add_edge graph x y) arcs;
- print_endline ("<scc>");
- let classes,norm =
- let module SCC = Graph.Components.Make(G) in SCC.scc graph in
- print_endline (string_of_int classes ^ " classes");
- print_endline ("-----");
- norm,arcs
-;;
-
-let analyze (norm,arcs) =
- print_endline ("building class graph (" ^ string_of_int (List.length arcs) ^ ")");
- let normalize,finish,describe = normalize_and_describe norm in
- let arcs = uniq (mapi (fun (x,y) -> normalize x,normalize y) arcs) in
- print_endline "finish";
- finish ();
- print_endline ("collapse " ^ string_of_int (List.length arcs) ^ " arcs");
- let arcs = uniq (mapi (function (x,y) -> describe x,describe y) arcs) in
- print_endline ("build (" ^ string_of_int (List.length arcs) ^ " arcs)");
- let cgraph = GL.create () in
- iteri (function (x,y) -> if x <> y then GL.add_edge cgraph x y) arcs;
- print_endline "visualize";
- visualize cgraph;
- print_endline ("/////");
-;;