fully implement ff algo

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

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
 

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
+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

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
 
   ()