josch/cycles_johnson_abate
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

iterative and functional cycle code outputs correct results

Browse source
This commit is contained in:
josch 2012-07-04 09:55:47 +02:00
parent 054604d5cf
commit fa78ca1a30
2 changed files with 92 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
cycles_functional.ml
View file

@ -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;
@ -87,74 +77,74 @@ let find_all_cycles_johnson g =
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(is_bloked t nextnode) then if not(Hashtbl.find t.blocked nextnode) then begin
circuit t r nextnode startnode component let c2, r2 = circuit t r nextnode startnode component in
else (c || c2, r2)
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
Printf.eprintf "minnode %d\n" (G.V.label minnode);
let mincomp = List.find (fun l -> List.mem minnode l) scc in 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 *) (* smallest node in the component according to the ordering *)
let startnode = minnode in
let component = extract_subgraph subgraph (to_set mincomp) in let component = extract_subgraph subgraph (to_set mincomp) in
G.dot_output component (Printf.sprintf "test-component%d.dot" (G.V.label s)); 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

80
cycles_iter.ml
View file

@ -17,52 +17,48 @@ let find_all_cycles_johnson g =
(* list to accumulate the circuits found *) (* list to accumulate the circuits found *)
let result = ref [] in let result = ref [] in
let rec circuit thisnode startnode component = let rec unblock n =
if Hashtbl.find blocked n then begin
Hashtbl.replace blocked n false;
List.iter unblock (Hashtbl.find b n);
Hashtbl.replace b n [];
end
in
let stack_to_list s = let stack_to_list s =
let l = ref [] in let l = ref [] in
Stack.iter (fun e -> l:= e::!l) s; Stack.iter (fun e -> l:= e::!l) s;
!l !l
in in
let rec unblock thisnode = let rec circuit thisnode startnode component =
Printf.eprintf "unblock %d\n" (G.V.label thisnode);
if Hashtbl.find blocked thisnode then begin
Hashtbl.replace blocked thisnode false;
List.iter unblock (Hashtbl.find b thisnode);
Hashtbl.replace b thisnode []
end
in
let closed = ref false in let closed = ref false in
Stack.push thisnode path; Stack.push thisnode path;
Hashtbl.replace blocked thisnode true; Hashtbl.replace blocked thisnode true;
G.iter_succ (fun nextnode -> G.iter_succ (fun nextnode ->
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
result := ((stack_to_list path))::!result; result := ((stack_to_list path))::!result;
closed := true; closed := true;
Printf.eprintf "closed = true 1\n";
end else begin if not(Hashtbl.find blocked nextnode) then end else begin if not(Hashtbl.find blocked nextnode) then
if circuit nextnode startnode component then begin if circuit nextnode startnode component then begin
closed := true; closed := true;
Printf.eprintf "closed = true 2\n";
end end
end end
) component thisnode; ) component thisnode;
if !closed then begin if !closed then begin
Printf.eprintf "closed = true 3\n";
unblock thisnode unblock thisnode
end end
else else
G.iter_succ (fun nextnode -> G.iter_succ (fun nextnode ->
if List.mem thisnode (Hashtbl.find b nextnode) then let l = Hashtbl.find b nextnode in
Hashtbl.replace b nextnode (thisnode::(Hashtbl.find b nextnode)) if not(List.mem thisnode l) then
Hashtbl.replace b nextnode (thisnode::l)
) component thisnode; ) component thisnode;
ignore(Stack.pop path); ignore(Stack.pop path);
!closed !closed
in in
let module SV = Set.Make(G.V) in let module SV = Set.Make(G.V) in
let subgraph_ g s = let extract_subgraph g s =
let sg = G.create () in let sg = G.create () in
G.iter_edges (fun v1 v2 -> G.iter_edges (fun v1 v2 ->
if SV.mem v1 s then G.add_vertex sg v1; if SV.mem v1 s then G.add_vertex sg v1;
@ -77,47 +73,47 @@ let find_all_cycles_johnson g =
*) *)
let to_set l = List.fold_right SV.add l SV.empty in let to_set l = List.fold_right SV.add l SV.empty in
let vertex_set = G.fold_vertex SV.add g SV.empty in let vertex_set = G.fold_vertex SV.add g SV.empty in
let part s w = snd(SV.partition (fun e -> e >= w) s) in let part s w = fst(SV.partition (fun e -> e >= w) s) in
let print_set s =
String.join " " (List.map (fun e ->
string_of_int (G.V.label e)
) (SV.elements s))
in
Printf.eprintf "inital set %s\n" (print_set vertex_set);
SV.iter (fun s -> SV.iter (fun s ->
(* 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 (part vertex_set s) in let subset = SV.add s (part vertex_set s) in
Printf.eprintf "subset %s\n" (print_set subset); let subgraph = extract_subgraph g subset in
let subgraph = subgraph_ g subset in
if G.nb_edges subgraph > 0 then begin
let scc = G.Components.scc_list subgraph in let scc = G.Components.scc_list subgraph in
(* 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 minnode = SV.min_elt subset in let minnode = SV.min_elt subset in
Printf.eprintf "minnode %d\n" (G.V.label minnode);
let mincomp = List.find (fun l -> List.mem minnode l) scc in 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 *) (* smallest node in the component according to the ordering *)
let startnode = minnode in let component = extract_subgraph subgraph (to_set mincomp) in
let component = subgraph_ subgraph (to_set mincomp) in if G.nb_edges component > 0 then begin
G.dot_output component (Printf.sprintf "test-component%d.dot" (G.V.label s));
G.iter_vertex (fun node -> G.iter_vertex (fun node ->
Hashtbl.add blocked node false; Hashtbl.replace blocked node false;
Hashtbl.add b node []; Hashtbl.replace b node [];
) component; ) component;
ignore(circuit startnode startnode component); ignore(circuit minnode minnode component);
end else end
Printf.eprintf "No edges to consider\n"
) vertex_set; ) vertex_set;
!result 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 ->
Printf.printf "path : %s\n" Printf.printf "%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