From e5c1d4708bd0568a843129b8be701dafb1110389 Mon Sep 17 00:00:00 2001 From: Arnaud Vergnet Date: Thu, 19 Nov 2020 11:25:39 +0100 Subject: [PATCH] fully implement ff algo --- graphs/test1 | 10 ++++++ src/ffalgo.ml | 88 +++++++++++++++++++++++++++++++++++++------------- src/ffalgo.mli | 28 ++++++++++++++-- src/ftest.ml | 59 ++++++++++++++++++++++++++++++--- 4 files changed, 154 insertions(+), 31 deletions(-) create mode 100644 graphs/test1 diff --git a/graphs/test1 b/graphs/test1 new file mode 100644 index 0000000..58ec56a --- /dev/null +++ b/graphs/test1 @@ -0,0 +1,10 @@ +n 100 200 +n 241 300 +n 241 100 +n 382 200 + +e 0 1 2 +e 0 2 4 +e 1 2 3 +e 2 3 5 +e 1 3 1 \ No newline at end of file diff --git a/src/ffalgo.ml b/src/ffalgo.ml index ac8f725..0c5cb69 100644 --- a/src/ffalgo.ml +++ b/src/ffalgo.ml @@ -7,6 +7,11 @@ module Int_set = Set.Make(struct let compare = compare end) +module Int_map = Map.Make(struct + type t = int + let compare = compare + end) + type 'a network = { graph: 'a graph; origin: id; @@ -24,34 +29,57 @@ type path = (id * id) list (* int graph -> flow graph *) let initialize_graph gr = gmap gr (fun c -> { current = 0; capacity = c }) -(* flow graph -> int graph *) -let build_res_network gr = let gr_res = clone_nodes gr in - e_fold gr (fun g origin destination fl -> - let new_g = add_arc g origin destination (fl.capacity - fl.current) in - add_arc new_g destination origin fl.current ) gr_res +(* int graph -> int -> int -> int -> int graph *) +let add_res_arc gr origin destination value = match value with + | 0 -> gr + | _ -> add_arc gr origin destination value + + +(* flow graph -> int graph *) +let build_res_graph gr = let gr_res = clone_nodes gr in + e_fold gr (fun g origin destination fl -> + let forward = fl.capacity - fl.current in + let backward = fl.current in + let new_g = add_res_arc g origin destination forward in + add_res_arc new_g destination origin backward ) + gr_res + +(* Int_map -> id -> id -> path *) +let predecessors_to_path predecessors origin destination = + let rec loop o d acu = if o = d then + acu + else + match Int_map.find_opt d predecessors with + | None -> [] + | Some x -> let new_acu = (x, d) :: acu in + if x = o then new_acu else + loop o x new_acu + in + loop origin destination [] -(* pseudo code implémenté *) -(* TODO : trouver le chemin final *) -(* sauvegarder le prédécéseur quand on ajoute au queue ? *) -(* et quand trouvé dest, reverse ? *) (* int network -> path *) let find_path res_network = let queue = Queue.create () in let () = Queue.add res_network.origin queue in let visited = Int_set.add res_network.origin Int_set.empty in - let rec find_path_rec r_n q v acu = match Queue.take_opt q with - | None -> acu - | Some x -> let arcs = out_arcs r_n.graph x in - let arcs_seq = List.to_seq ( - List.map (fun (dest, _) -> dest) ( - List.filter (fun (dest, _) -> not (Int_set.mem dest v) ) arcs - ) - ) in - let new_v = Int_set.add_seq arcs_seq v in - let () = Queue.add_seq q arcs_seq in - find_path_rec r_n q new_v acu + let rec find_path_rec q v pred = match Queue.take_opt q with + | None -> predecessors_to_path pred res_network.origin res_network.destination + | Some x -> if x = res_network.destination then + predecessors_to_path pred res_network.origin res_network.destination + else + let arcs = out_arcs res_network.graph x in + let filtered_arcs = List.filter (fun (dest, _) -> not (Int_set.mem dest v) ) arcs in + let successors_seq = List.to_seq ( + List.map (fun (dest, _) -> dest) filtered_arcs + ) in + let predecessors_seq = List.to_seq ( + List.map (fun (dest, _) -> (dest, x)) filtered_arcs + ) in + let new_pred = Int_map.add_seq predecessors_seq pred in + let new_v = Int_set.add_seq successors_seq v in + let () = Queue.add_seq q successors_seq in + find_path_rec q new_v new_pred in - find_path_rec res_network queue visited [] - + find_path_rec queue visited Int_map.empty (* int graph -> path -> int *) @@ -71,6 +99,20 @@ let apply_path gr path aug = List.fold_left (fun new_gr (s, d) -> | Some x -> new_arc new_gr s d {current = x.current + aug; capacity = x.capacity}) gr path +(* flow network -> int *) +let get_max_flow flow_network = let arcs = out_arcs flow_network.graph flow_network.origin in + List.fold_left (fun current (dest, flow) -> current + flow.current ) 0 arcs -let run_ff network = assert false +(* int network -> flow network *) +let run_ff network = let flow_graph = initialize_graph network.graph in + let rec loop fl = + let res_graph = build_res_graph fl in + let path = find_path {graph = res_graph; origin = network.origin; destination = network.destination } in + match path with + | [] -> {graph = fl; origin = network.origin; destination = network.destination } + | _ -> + let aug = find_min res_graph path in + let new_fl = apply_path fl path aug in + loop new_fl + in loop flow_graph diff --git a/src/ffalgo.mli b/src/ffalgo.mli index 2f3f7db..8bc5251 100644 --- a/src/ffalgo.mli +++ b/src/ffalgo.mli @@ -1,9 +1,31 @@ open Graph + type 'a network = { graph: 'a graph; - origin: int; - destination: int; + origin: id; + destination: id; } -val run_ff: int network -> int \ No newline at end of file +type flow = { + current: int; + capacity: int; +} + +type path = (id * id) list + +(* // TODO REMOVE AFTER TESTS *) +val initialize_graph: int graph -> flow graph + +val apply_path: flow graph -> path -> int -> flow graph + +val build_res_graph: flow graph -> int graph + +val find_min: int graph -> path -> int + +val find_path: int network -> path + +(* KEEP THIS *) +val run_ff: int network -> flow network + +val get_max_flow: flow network -> int \ No newline at end of file diff --git a/src/ftest.ml b/src/ftest.ml index fa3ee0d..eb508d1 100644 --- a/src/ftest.ml +++ b/src/ftest.ml @@ -2,6 +2,44 @@ open Gfile open Tools open Ffalgo + +let flow_to_string gr = gmap gr (fun fl -> String.concat "/" [(string_of_int fl.current); (string_of_int fl.capacity)]) + +let test_ffalgo_init gr = + let graph_init = initialize_graph gr in + let () = export "graph_init" (flow_to_string graph_init) in + graph_init + +let test_ffalgo_apply gr = + let graph_apply = apply_path gr [(0, 3); (3, 1); (1, 4); (4, 5)] 1 in + let () = export "graph_apply" (flow_to_string graph_apply) in + graph_apply + +let test_ffalgo_res gr = + let graph_res = build_res_graph gr in + let () = export "graph_res" (gmap graph_res string_of_int) in + graph_res + +let test_ffalgo_min gr = + let min = find_min gr [(0, 3); (3, 1); (1, 4); (4, 5)] in + Printf.printf "min: %d\n%!" min + +let test_ffalgo_path gr = + let predecessors = find_path { + graph = gr; + origin = 0; + destination = 4; + } in + List.iter (fun (o, d) -> Printf.printf "%d -> %d\n%!" o d ) predecessors + +let test_ffalgo gr = + let graph_init = test_ffalgo_init gr in + let graph_apply = test_ffalgo_apply graph_init in + let graph_res = test_ffalgo_res graph_apply in + let () = test_ffalgo_min gr in + test_ffalgo_path graph_res + + let () = (* Check the number of command-line arguments *) @@ -16,19 +54,30 @@ let () = let infile = Sys.argv.(1) and outfile = Sys.argv.(4) - - (* These command-line arguments are not used for the moment. *) - and _source = int_of_string Sys.argv.(2) - and _sink = int_of_string Sys.argv.(3) + and source = int_of_string Sys.argv.(2) + and sink = int_of_string Sys.argv.(3) in (* Open file *) let graph = from_file infile in + (* Convert graph *) + let int_graph = (gmap graph int_of_string) in + (* Execute FF *) + let flow_network = run_ff {graph = int_graph; origin = source; destination = sink} in + (* Print max flow *) + let () = Printf.printf "Max flow: %d\n%!" (get_max_flow flow_network) in + (* Convert to string for export *) + let final_graph = flow_to_string flow_network.graph in + + (* TESTS *) + (* let () = test_ffalgo (gmap graph int_of_string) in *) (* let graph2 = clone_nodes graph in *) (* let graph2 = gmap (gmap (gmap graph int_of_string) (fun x -> x + 1)) string_of_int in *) (* let graph2 = gmap (add_arc (gmap graph int_of_string) 2 1 13) string_of_int in *) + (* END TESTS *) + (* Rewrite the graph that has been read. *) - let () = export outfile graph in + let () = export outfile final_graph in ()