|
|
@ -9,7 +9,7 @@ module SV = Set.Make(G.V)
|
|
|
|
|
|
|
|
|
|
|
|
let to_set l = List.fold_right SV.add l SV.empty ;;
|
|
|
|
let to_set l = List.fold_right SV.add l SV.empty ;;
|
|
|
|
|
|
|
|
|
|
|
|
let partition s w = snd(SV.partition (fun e -> e >= w) s);;
|
|
|
|
let partition s w = fst(SV.partition (fun e -> e >= w) s);;
|
|
|
|
|
|
|
|
|
|
|
|
let print_set s =
|
|
|
|
let print_set s =
|
|
|
|
String.join " " (List.map (fun e ->
|
|
|
|
String.join " " (List.map (fun e ->
|
|
|
@ -51,17 +51,11 @@ let init_block g =
|
|
|
|
t
|
|
|
|
t
|
|
|
|
;;
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
let get_notelem t n =
|
|
|
|
|
|
|
|
Hashtbl.find t.notelem n
|
|
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let rec unblock t n =
|
|
|
|
let rec unblock t n =
|
|
|
|
Printf.eprintf "unblock %d\n" (G.V.label n);
|
|
|
|
|
|
|
|
if Hashtbl.find t.blocked n then begin
|
|
|
|
if Hashtbl.find t.blocked n then begin
|
|
|
|
Hashtbl.replace t.blocked n false;
|
|
|
|
Hashtbl.replace t.blocked n false;
|
|
|
|
let l = get_notelem t n in
|
|
|
|
List.iter (unblock t) (Hashtbl.find t.notelem n);
|
|
|
|
List.iter (unblock t) l;
|
|
|
|
Hashtbl.replace t.notelem n [];
|
|
|
|
Hashtbl.replace t.notelem n []
|
|
|
|
|
|
|
|
end
|
|
|
|
end
|
|
|
|
;;
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
@ -69,10 +63,6 @@ let block t n =
|
|
|
|
Hashtbl.replace t.blocked n true
|
|
|
|
Hashtbl.replace t.blocked n true
|
|
|
|
;;
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
let is_bloked t n =
|
|
|
|
|
|
|
|
Hashtbl.find t.blocked n
|
|
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let find_all_cycles_johnson g =
|
|
|
|
let find_all_cycles_johnson g =
|
|
|
|
if not G.is_directed then
|
|
|
|
if not G.is_directed then
|
|
|
|
assert false;
|
|
|
|
assert false;
|
|
|
@ -85,76 +75,76 @@ let find_all_cycles_johnson g =
|
|
|
|
Stack.push thisnode path;
|
|
|
|
Stack.push thisnode path;
|
|
|
|
block t thisnode;
|
|
|
|
block t thisnode;
|
|
|
|
|
|
|
|
|
|
|
|
let (closed,result) =
|
|
|
|
let (closed,result) =
|
|
|
|
G.fold_succ (fun nextnode (c,r) ->
|
|
|
|
G.fold_succ (fun nextnode (c,r) ->
|
|
|
|
Printf.eprintf "startnode %d\n" (G.V.label startnode);
|
|
|
|
|
|
|
|
Printf.eprintf "nextnode %d\n" (G.V.label nextnode);
|
|
|
|
|
|
|
|
if G.V.equal nextnode startnode then begin
|
|
|
|
if G.V.equal nextnode startnode then begin
|
|
|
|
Printf.eprintf "closed = true 1\n";
|
|
|
|
(true, (stack_to_list path)::r)
|
|
|
|
(true,(Stack.copy path)::r)
|
|
|
|
end else begin
|
|
|
|
end else begin
|
|
|
|
if not(Hashtbl.find t.blocked nextnode) then begin
|
|
|
|
if not(is_bloked t nextnode) then
|
|
|
|
let c2, r2 = circuit t r nextnode startnode component in
|
|
|
|
circuit t r nextnode startnode component
|
|
|
|
(c || c2, r2)
|
|
|
|
else
|
|
|
|
end else
|
|
|
|
(c,r)
|
|
|
|
(c,r)
|
|
|
|
end
|
|
|
|
end
|
|
|
|
) component thisnode (false,result)
|
|
|
|
) component thisnode (false,result)
|
|
|
|
in
|
|
|
|
in
|
|
|
|
if closed then begin
|
|
|
|
if closed then begin
|
|
|
|
Printf.eprintf "closed = true 3\n";
|
|
|
|
|
|
|
|
unblock t thisnode
|
|
|
|
unblock t thisnode
|
|
|
|
end else
|
|
|
|
end else
|
|
|
|
G.iter_succ (fun nextnode ->
|
|
|
|
G.iter_succ (fun nextnode ->
|
|
|
|
let l = get_notelem t nextnode in
|
|
|
|
let l = Hashtbl.find t.notelem nextnode in
|
|
|
|
if List.mem thisnode l then
|
|
|
|
if not(List.mem thisnode l) then
|
|
|
|
Hashtbl.replace t.notelem nextnode (thisnode::l)
|
|
|
|
Hashtbl.replace t.notelem nextnode (thisnode::l)
|
|
|
|
) component thisnode;
|
|
|
|
) component thisnode;
|
|
|
|
|
|
|
|
|
|
|
|
ignore(Stack.pop path);
|
|
|
|
ignore(Stack.pop path);
|
|
|
|
(closed,result)
|
|
|
|
(closed, result)
|
|
|
|
in
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
|
|
(* Johnson's algorithm requires some ordering of the nodes. *)
|
|
|
|
(* Johnson's algorithm requires some ordering of the nodes. *)
|
|
|
|
let vertex_set = G.fold_vertex SV.add g SV.empty in
|
|
|
|
let vertex_set = G.fold_vertex SV.add g SV.empty in
|
|
|
|
Printf.eprintf "inital vertex set %s\n" (print_set vertex_set);
|
|
|
|
let result = SV.fold (fun s result ->
|
|
|
|
SV.fold (fun s result ->
|
|
|
|
|
|
|
|
(* Build the subgraph induced by s and following nodes in the ordering *)
|
|
|
|
(* Build the subgraph induced by s and following nodes in the ordering *)
|
|
|
|
Printf.eprintf "selected element %d\n" (G.V.label s);
|
|
|
|
|
|
|
|
let subset = SV.add s (partition vertex_set s) in
|
|
|
|
let subset = SV.add s (partition vertex_set s) in
|
|
|
|
Printf.eprintf "subset %s\n" (print_set subset);
|
|
|
|
|
|
|
|
let subgraph = extract_subgraph g subset in
|
|
|
|
let subgraph = extract_subgraph g subset in
|
|
|
|
|
|
|
|
|
|
|
|
if G.nb_edges subgraph > 0 then begin
|
|
|
|
(* Find the strongly connected component in the subgraph
|
|
|
|
(* Find the strongly connected component in the subgraph
|
|
|
|
* that contains the least node according to the ordering *)
|
|
|
|
* that contains the least node according to the ordering *)
|
|
|
|
let scc = G.Components.scc_list subgraph in
|
|
|
|
let scc = G.Components.scc_list subgraph in
|
|
|
|
let minnode = SV.min_elt subset in
|
|
|
|
let minnode = SV.min_elt subset in
|
|
|
|
let mincomp = List.find (fun l -> List.mem minnode l) scc in
|
|
|
|
Printf.eprintf "minnode %d\n" (G.V.label minnode);
|
|
|
|
|
|
|
|
let mincomp = List.find (fun l -> List.mem minnode l) scc in
|
|
|
|
|
|
|
|
Printf.eprintf "mincomp %s\n" (print_set ((to_set mincomp)));
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(* smallest node in the component according to the ordering *)
|
|
|
|
|
|
|
|
let startnode = minnode in
|
|
|
|
|
|
|
|
let component = extract_subgraph subgraph (to_set mincomp) in
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
G.dot_output component (Printf.sprintf "test-component%d.dot" (G.V.label s));
|
|
|
|
(* smallest node in the component according to the ordering *)
|
|
|
|
|
|
|
|
let component = extract_subgraph subgraph (to_set mincomp) in
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if G.nb_edges component > 0 then begin
|
|
|
|
(* init the block table for this component *)
|
|
|
|
(* init the block table for this component *)
|
|
|
|
let t = init_block component in
|
|
|
|
let t = init_block component in
|
|
|
|
|
|
|
|
|
|
|
|
snd(circuit t result startnode startnode component);
|
|
|
|
snd(circuit t result minnode minnode component);
|
|
|
|
end else begin
|
|
|
|
end else
|
|
|
|
Printf.eprintf "No edges to consider\n";
|
|
|
|
|
|
|
|
result
|
|
|
|
result
|
|
|
|
end
|
|
|
|
|
|
|
|
) vertex_set []
|
|
|
|
) vertex_set []
|
|
|
|
|
|
|
|
in
|
|
|
|
|
|
|
|
List.rev result
|
|
|
|
;;
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
|
|
|
let g = G.Rand.graph ~v:5 ~e:10 () in
|
|
|
|
if Array.length Sys.argv < 3 then begin
|
|
|
|
G.dot_output g "test.dot";
|
|
|
|
Printf.printf "usage: %s num_vertices [v1,v2...]\n" Sys.argv.(0);
|
|
|
|
|
|
|
|
exit 1;
|
|
|
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let v = int_of_string (Sys.argv.(1)) in
|
|
|
|
|
|
|
|
let g = G.create ~size:v () in
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
let a = Array.init v G.V.create in
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
for i = 2 to Array.length Sys.argv - 1 do
|
|
|
|
|
|
|
|
let v1, v2 = String.split Sys.argv.(i) "," in
|
|
|
|
|
|
|
|
G.add_edge g a.(int_of_string v1) a.(int_of_string v2);
|
|
|
|
|
|
|
|
done;
|
|
|
|
|
|
|
|
|
|
|
|
let ll = find_all_cycles_johnson g in
|
|
|
|
let ll = find_all_cycles_johnson g in
|
|
|
|
List.iter (fun path ->
|
|
|
|
List.iter (fun path ->
|
|
|
|
let path = stack_to_list path in
|
|
|
|
Printf.printf "%s\n"
|
|
|
|
Printf.printf "path : %s\n"
|
|
|
|
|
|
|
|
(String.join " " (List.map (fun e -> string_of_int (G.V.label e)) path))
|
|
|
|
(String.join " " (List.map (fun e -> string_of_int (G.V.label e)) path))
|
|
|
|
) ll
|
|
|
|
) ll
|
|
|
|