medium project working

graphs/graph1

@@ -2,23 +2,11 @@
 
 %% Nodes
 
-n 88 209     % This is node #0, with its coordinates (which are not used by the algorithms).
+u Gaby
-n 408 183
+u Flo
-n 269 491
+u Macha
-n 261 297
-n 401 394
-n 535 294    % This is node #5.
 
 
-%% Edges
+p Flo -> Gaby,Flo,Macha : 30.0€
-
+p Gaby -> Gaby,Flo : 20.0€
-e 3 1 11     % An edge from 3 to 1, labeled "11".
+p Macha -> Gaby,Macha : 20.0€
-e 3 2 2
-e 1 5 21
-e 4 5 14
-e 1 4 1
-e 0 1 7
-e 0 3 10
-e 3 4 5
-e 2 4 12
-e 0 2 8

src/BLF.ml

@@ -29,7 +29,7 @@ let blf gr id_src id_dest=
                 match l_out_arc with
                 |[]-> blf_rec gr file (a::file_marque)
                 |(id,label)::d-> 
-                    if label != 0.0 && (Float.add blf_tab.(a).cout label)<(blf_tab.(id).cout) then
+                    if label <> 0.0 && (Float.add blf_tab.(a).cout label)<(blf_tab.(id).cout) then
                     begin
                         blf_tab.(id).cout<-(Float.add blf_tab.(a).cout label);
                         blf_tab.(id).father<-a; 

src/FFAlgorithm.ml

@@ -16,16 +16,15 @@ let rec create_arcs_from_nodes = function
 
 (* Return the minimum value of a path's edge*)
 let get_min_label_from_path (graph : float graph) (path : (id * id) list) =
-  let min = Some 999.0 in
+  let min = 999999999.0 in
-  let min = List.fold_left
+  List.fold_left
     (
       fun acu (id1, id2) -> 
-        let label = find_arc graph id1 id2 in 
+        let label = ( match find_arc graph id1 id2 with
+        |None -> 999999999.0
+        |Some x -> x) in 
         if label < acu then label else acu
-    ) min path in
+    ) min path
-    match min with
-    |None -> 999.0
-    |Some x -> x
 
 
 (* Add a value to every egde of a path *)
@@ -45,7 +44,7 @@ let rev_arcs (path : (id * id) list) =
 
    
 (* Get the final graph after the FFalgorithm 
-  The label of every arc becomes "x/max_capacity" where x 
+  The label of every arc becomes "x" where x 
   is the value of the opposite arc on the residual graph*)
 let get_final_graph (initGraph : float graph) (residualGraph : float graph) =
   
@@ -54,29 +53,24 @@ let get_final_graph (initGraph : float graph) (residualGraph : float graph) =
   let residualGraphString = residualGraph in
   let finalGraph = clone_nodes initGraph in
   
-  (* For every arc in the initial graph, we get its label (aka max_capacity)
+  (* For every arc in the initial graph we get the label of 
-    then, we get the label of the opposite arc in the residual graph. 
+     the opposite arc in the residual graph. 
-    If it exists then the arc of the final graph gets the label "x/max_capacity",
+     If it exists then the arc of the final graph gets the label "x",
-    "0/max_capacity" otherwise*)
+     "0.0" otherwise*)
   e_fold initGraph
   (
     fun acu id1 id2 x ->
-    let label_arc = (match find_arc initGraphString id1 id2 with
-      |None -> 0.0
-      |Some x -> x) in
     let label_rev_arc = match find_arc residualGraphString id2 id1 with
       |None -> 0.0
       |Some x -> (match find_arc initGraphString id2 id1 with
         |None -> x
         |Some y -> Float.sub x y ) in
-    let label_arc = string_of_float label_arc in
     let label_rev_arc = if (label_rev_arc > 0.0) then (string_of_float label_rev_arc) else "0" in
-    new_arc acu id1 id2 (label_rev_arc^"/"^label_arc)  
+    new_arc acu id1 id2 label_rev_arc  
   )
   finalGraph
 
 
-
 let ford_fulk_algorithm (graph : float graph) (origin : id) (sink : id) = 
   let flow = 0.0 in
 
@@ -90,15 +84,12 @@ let ford_fulk_algorithm (graph : float graph) (origin : id) (sink : id) =
         (let path = x in 
         let arcs = create_arcs_from_nodes path in
 
-        (*let () = printf "dans boucle\n" in*)
-        
         (* Find the min value of the path *)
         let min = get_min_label_from_path graph arcs in
     
         (* Substract the min to every arc of the path *)
         let graph = add_value_to_arcs graph arcs (Float.neg min) in
 
-
         (* Get the reverse path *)
         let reverse = rev_arcs arcs in
     

src/FFAlgorithm.mli

@@ -7,8 +7,6 @@ val g_to_float: string graph -> float graph
 
 val ford_fulk_algorithm : float graph -> id -> id -> (float * string graph)
 
-(* val g_to_string: float graph -> string graph *)
-
 (* val only_one_edge: float graph -> float graph *)
 
 (* for testing purpose *)

src/MSftest.ml

@@ -4,6 +4,8 @@ open FFAlgorithm
 open BLF
 open Format
 open Sys
+open MoneySharing
+open Printf
 
 let () =
  
@@ -12,7 +14,7 @@ let () =
    ex : ./ftest.native graphs/graph1 0 5 graphs/graph3 *)
 
   (* Check the number of command-line arguments *)
-  if Array.length Sys.argv <> 5 then
+  if Array.length Sys.argv <> 3 then
     begin
       Printf.printf "\nUsage: %s infile source sink outfile\n\n%!" Sys.argv.(0) ;
       exit 0
@@ -22,20 +24,20 @@ let () =
   (* Arguments are : infile(1) source-id(2) sink-id(3) outfile(4) *)
 
   let infile = Sys.argv.(1)
-  and outfile = Sys.argv.(4)
+  and outfile = Sys.argv.(2)
-
-  (* 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)
   in
 
+  (* These command-line arguments are not used for the moment. *)
+
   (* Open file *)
-  let (graph, l_id) = from_file infile in
+  let (initGraph, l_id) = from_file infile in
-  let initGraph = graph in
+  let max_id = get_max_id initGraph in
+  (* let () = export outfile initGraph in *)
 
   (* Rewrite the graph that has been read. *)
  
-  let (flow,finalGraph) = ford_fulk_algorithm initGraph _source _sink in
+  let (flow,finalGraph) = ford_fulk_algorithm initGraph 0 max_id in
+  let finalGraph = remove_ss_zeroes finalGraph in
   let () = printf "max flow = %f\n" flow in
   let () = write_file outfile finalGraph l_id in 
   let () = export outfile finalGraph in

src/MSgfile.ml

@@ -13,8 +13,8 @@ type path = string
    u Macha
 
    % You can now enter your payements as it follows: p userWhoPaid [forWhichUser1; forWhichUser2 ..] amount
-   p Flo Gaby,Flo,Macha 11.0
+   p Flo -> Gaby,Flo,Macha : 11.0€
-   p Gaby Flo 8.5
+   p Gaby -> Flo : 8.5€
 
 *)
 
@@ -34,7 +34,7 @@ let write_file path graph l_id=
   fprintf ff "%% Here are the reimbursements to be made.\n\n" ;
 
   (* Write all arcs *)
-  e_iter graph (fun id1 id2 lbl -> fprintf ff "p %s %s %s\n" (get_user id1 l_id) (get_user id2 l_id) lbl) ;
+  e_iter graph (fun id1 id2 lbl -> fprintf ff "p %s -> %s : %s€\n" (get_user id1 l_id) (get_user id2 l_id) lbl) ;
 
   fprintf ff "\n%% End of reimbursements\n" ;
 
@@ -56,7 +56,7 @@ let read_user id graph l_id line =
 
 (* Reads a line with a payement. *)
 let read_payement graph l_id line =
-  try Scanf.sscanf line "p %s %s %f"
+  try Scanf.sscanf line "p %s -> %s : %f€"
         (fun user l_user label -> paiement graph user (String.split_on_char ',' l_user) label l_id)
   with e ->
     Printf.printf "Cannot read arc in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
@@ -91,10 +91,16 @@ let from_file path =
 
     with End_of_file -> (graph, l_id) (* Done *)
   in
-  let final_graph_lid= loop 0 empty_graph [] in
+  let (graph, l_id) = loop 1 empty_graph [] in
 
+  (* Users with negative balance linked to the origin
+     Users with positive balance linked to sink *)
+  let graph = set_sink_origin graph l_id in
+  (* Link users between themselves with *)
+  let graph = link_users graph l_id in
   close_in infile ;
-  final_graph_lid
+  (graph, l_id)
+
   
 (* Write the graph in a .dot file*)
 let export path graph =

src/MSgfile.mli

@@ -1,4 +1,6 @@
 open Graph
+open Printf
+open MoneySharing
 
 type path = string
 

src/moneySharing.ml

@@ -3,23 +3,24 @@ open Tool
 
 
 (*fonction qui créé le noeud associé à un utilisateur et rentre la correspondance dans la table des id*)
-let init_node g user id l_id=
+let init_node graph nom id l_id =
-    ( (new_node g id), ((user,id,0.0)::l_id) )
+    ( (new_node graph id), ((nom,id,0.0)::l_id) )
 
 
 (*fonction qui renvoie l'id d'un utilisateur*)   
 let rec get_id utilisateur l_id= match l_id with   
     |[]-> raise Not_found
-    |(a,id1,value)::b-> if a=utilisateur then id1 else get_id utilisateur b
+    |(nom,id,_)::rest-> if nom = utilisateur then id else get_id utilisateur rest
 
 (*fonction qui renvoie le nom correspondant à un id*)   
 let rec get_user id1 l_id = match l_id with   
     |[]-> raise Not_found
-    |(nom,a,value)::b-> if a=id1 then nom else get_user id1 b
+    |(nom,id,_)::rest-> if id = id1 then nom else get_user id1 rest
 
-let set_val_du a l_id montant l_utilisateurs=
+let set_val_du utilisateur l_id montant l_utilisateurs =
-    List.map (fun (nom,id,value)-> if nom=a 
+    let length = List.length l_utilisateurs in
-                                 then (nom,id,(Float.sub value (Float.div montant (Float.of_int(List.length l_utilisateurs)))))
+    List.map (fun (nom,id,value)-> if nom = utilisateur 
+                                 then (nom,id,(Float.sub value (Float.div montant (Float.of_int(length)))))
                                  else (nom,id,value)
              ) l_id
 
@@ -30,12 +31,50 @@ let set_val_pret utilisateur montant l_id=
              ) l_id
     
 (*fonction qui rentre les paiements réalisés*)
-let paiement g utilisateur l_utilisateurs montant l_id= 
+let paiement graph utilisateur l_utilisateurs montant l_id = 
-    let rec paye g utilisateur l_utilisateurs montant l_id=match l_utilisateurs with
-        |[]-> (g, l_id)
-        |a::b-> paye g utilisateur b montant (set_val_du a l_id montant l_utilisateurs) in
     let l_id = set_val_pret utilisateur montant l_id in
-            paye g utilisateur l_utilisateurs montant l_id
+    let length = List.length l_utilisateurs in
+    let l_id = List.map (fun (nom,id,value) -> if List.mem nom l_utilisateurs
+                                    then (nom,id, (Float.sub value (Float.div montant (Float.of_int(length)))) )
+                                    else (nom, id, value)
+             ) l_id in
+    (graph, l_id) 
+    (* let rec paye graph utilisateur l_utilisateurs montant l_id = match l_utilisateurs with
+        |[]-> (graph, l_id)
+        |x::rest -> paye graph utilisateur rest montant (set_val_du x l_id montant l_utilisateurs) in
+    paye graph utilisateur l_utilisateurs montant l_id *)
 
 
+let link_users_helper graph user_id l_id =
+    List.fold_left (fun acu (nom, id, value) -> if id <> user_id then add_arc acu user_id id 999999999.0 else acu) graph l_id 
 
+let link_users graph l_id = 
+    List.fold_left (fun acu (_, id, _) -> (link_users_helper acu id l_id) ) graph l_id
+
+let link_users_sink_origin graph l_id source sink = 
+    List.fold_left (
+            fun acu (_,id,value) -> 
+            if value > 0.0 then 
+            add_arc acu id sink value
+            else 
+                if value < 0.0 then
+                add_arc acu source id (Float.neg value)
+                else acu 
+        ) graph l_id
+
+
+let set_sink_origin graph l_id =
+    let graph = new_node graph 0 in
+    let sink_id = (get_max_id graph)+1 in
+    let graph = new_node graph sink_id in
+    link_users_sink_origin graph l_id 0 sink_id 
+
+ 
+let remove_ss_zeroes graph =
+    let max_id = (get_max_id graph) in
+    let trimedGraph = n_fold graph (fun acu id -> if id > 0 && id < max_id then new_node acu id else acu) empty_graph in
+    e_fold graph ( fun acu id1 id2 label ->
+        if label <> "0" && node_exists acu id1 && node_exists acu id2 
+        then new_arc acu id1 id2 label
+        else acu
+    ) trimedGraph

src/moneySharing.mli

@@ -1,4 +1,6 @@
 open Graph
+open Tool
+
 
 val paiement: float graph -> string -> string list -> float -> (string * id * float) list -> (float graph * (string * id * float) list)
 
@@ -8,6 +10,12 @@ val get_id: string -> (string * id * float) list -> id
 
 val get_user: id -> (string * id * float) list -> string
 
-val set_val_du: string -> (string * id * float) list -> float -> string list -> (string * id * float) list
+(* val set_val_du: string -> (string * id * float) list -> float -> string list -> (string * id * float) list *)
 
-val set_val_pret: string -> float -> (string * id * float) list -> (string * id * float) list
+(* val set_val_pret: string -> float -> (string * id * float) list -> (string * id * float) list *)
+
+val link_users : float graph -> (string * id * float) list -> float graph
+
+val set_sink_origin : float graph -> (string * id * float) list -> float graph
+
+val remove_ss_zeroes : string graph -> string graph

src/tool.ml

@@ -17,3 +17,6 @@ let add_arc g id1 id2 n =
     match f with
     |None->new_arc g id1 id2 n
     |Some x->new_arc g id1 id2 (Float.add n x)
+
+let get_max_id graph = 
+  n_fold graph (fun acu id -> max id acu) 0 

src/tool.mli

@@ -7,3 +7,5 @@ val clone_nodes: 'a graph -> 'b graph
 val gmap: 'a graph -> ('a -> 'b) -> 'b graph
 
 val add_arc: float graph -> id -> id -> float -> float graph
+
+val get_max_id : 'a graph -> id