-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 =
- match G.V.label v with
- [d] -> d
- | _ -> assert false
- 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 mk_vertex = mk_vertex () in
- let graph = G.create () in
- let varcs = mapi (fun (x,y) -> mk_vertex x,mk_vertex y) arcs in
- iteri (fun (x,y) -> G.add_edge graph x y) varcs;
- 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,varcs
-;;