fichiers_de_base

src/BLF.ml

@@ -0,0 +1,50 @@
+open Graph
+
+type path = id list
+
+(*type record avec id noeud et son cout*)
+type t_cost={
+    mutable cout:int;
+    mutable father:int 
+    }
+
+let blf gr id_src id_dest=
+    (*je compte le nb de noeuds dans le graphe pour instancier mon tableau*)
+    let nb_n=n_fold gr (fun acu id->acu+1) 0 in
+    
+    let cost ={cout=max_int; father=(-1)} in
+
+    let acu =Array.make nb_n cost in
+    (*je fais un fold_left pour pouvoir individualiser au niveau de la mémoire les cases de la table*)
+    let blf_tab=n_fold gr (fun acu id->acu.(id)<-{cout=max_int; father=(-1)}; acu ) acu in
+    blf_tab.(id_src).cout<-0.0;
+    let file_id=[id_src] in
+    let file_marque =[] in
+
+    let rec blf_rec gr file_id file_marque= match file_id with
+        |[]-> blf_tab
+        |a::b-> 
+        let l_out_arc=out_arcs gr a in
+            let rec loop_suc l_out_arc blf_tab file =
+                match l_out_arc with
+                |[]-> blf_rec gr file (a::file_marque)
+                |(id,(lcout,lcapa))::d-> 
+                    if lcout <> 0.0 && (Int.add blf_tab.(a).cout lcout)<(blf_tab.(id).cout) then
+                    begin
+                        blf_tab.(id).cout<-(Int.add blf_tab.(a).cout lcout);
+                        blf_tab.(id).father<-a; 
+                        if not (List.mem id file_marque) then loop_suc d blf_tab (id::file) else loop_suc d blf_tab file
+                    end
+                    else loop_suc d blf_tab file in
+        loop_suc l_out_arc blf_tab b in
+    blf_rec gr file_id file_marque 
+
+(*avec blf_tab, on retrace chemin avec les pères*)
+let get_path gr id_src id_dest=
+    let blf_tab=blf gr id_src id_dest in
+    let path=[id_dest] in
+    let rec loop path blf_tab id_src id_dest= 
+        let father_id=blf_tab.(id_dest).father in match father_id with
+           |(-1)->None 
+           |a->if a == id_src then Some (id_src::path) else loop (a::path) blf_tab id_src a in
+    loop path blf_tab id_src id_dest

src/BLF.mli

@@ -0,0 +1,12 @@
+open Graph
+
+type path = id list
+
+type t_cost={
+    mutable cout:int;
+    mutable father:int 
+    }
+
+val blf: (int * int) graph -> id -> id -> t_cost array
+
+val get_path: (int * int) graph -> id -> id -> path option

src/FFAlgorithm.ml

@@ -0,0 +1,104 @@
+open Graph
+open Tool
+open BLF
+
+let g_to_string gr = gmap gr string_of_int
+let g_to_int gr = gmap gr int_of_string
+
+
+(* Create a list of pairs (origin,end) from a list of nodes *)
+let rec create_arcs_from_nodes = function
+  | [] -> []
+  | a :: [] -> []
+  | a :: b :: rest -> (a,b) :: (create_arcs_from_nodes (b :: rest))
+  
+
+
+(* Return the minimum value of a path's edge*)
+let get_min_label_from_path (graph : float graph) (path : (id * id) list) =
+  let min = 999999999.0 in
+  List.fold_left
+    (
+      fun acu (id1, id2) -> 
+        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
+
+
+(* Add a value to every egde of a path *)
+let add_value_to_arcs (graph : float graph) (path : (id * id) list) (value : float) = 
+  List.fold_left 
+    (
+      fun acu (id1, id2) -> 
+        add_arc acu id1 id2 value    
+    ) 
+    graph path
+ 
+
+(* Reverse a path and its edges 
+   ex :[(a, b);(b, c)] -> [(b,a);(c, b)] *)
+let rev_arcs (path : (id * id) list) =
+  List.map (fun (id1, id2) -> (id2, id1)) path
+
+   
+(* Get the final graph after the FFalgorithm 
+  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) =
+  
+  (* First get the initial and residual graph as string graphs *)
+  let initGraphString = initGraph in
+  let residualGraphString = residualGraph in
+  let finalGraph = clone_nodes initGraph in
+  
+  (* For every arc in the initial graph we get the label of 
+     the opposite arc in the residual graph. 
+     If it exists then the arc of the final graph gets the label "x",
+     "0.0" otherwise*)
+  e_fold initGraph
+  (
+    fun acu id1 id2 x ->
+    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_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  
+  )
+  finalGraph
+
+
+let ford_fulk_algorithm (graph : float graph) (origin : id) (sink : id) = 
+  let flow = 0.0 in
+
+  let initGraph = graph in
+  let rec boucle graph origin sink flow = 
+    
+    let path = get_path graph origin sink in
+    match path with
+      |None -> (flow, graph)
+      |Some x ->
+        (let path = x in 
+        let arcs = create_arcs_from_nodes path 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
+    
+        (* Add the min to every arc of the reverse path *)
+        let graph = add_value_to_arcs graph reverse min in
+    
+        (* Add the min to the flow *) 
+        let flow = Float.add flow min in
+        boucle graph origin sink flow) in
+  let (maxFlow, residualGraph) = boucle graph origin sink flow in
+  let finalGraph = get_final_graph initGraph residualGraph in 
+  (maxFlow, finalGraph) 

src/FFAlgorithm.mli

@@ -0,0 +1,18 @@
+open Graph
+open Tool
+open BLF
+
+
+val g_to_int: string graph -> (int * int) graph
+
+val ford_fulk_algorithm : (int * int) graph -> id -> id -> ((int * int) * string graph)
+
+(* val only_one_edge: (int * int) graph -> (int * int) graph *)
+
+(* for testing purpose *)
+
+(* val rev_arcs: (id * id) list -> (id * id) list
+
+val add_value_to_arcs: (int * int) graph -> (id * id) list -> (int * int) -> (int * int) graph
+
+val get_final_graph: (int * int) graph -> (int * int) graph -> string graph *)

src/MSftest.ml

@@ -0,0 +1,50 @@
+open MSgfile
+open Tool
+open FFAlgorithm
+open BLF
+open Format
+open Sys
+open MoneySharing
+open Printf
+
+let () =
+ 
+  (*/!\ Format de la commande pour lancer le test : 
+        ./ftest.native [nom_fichier_lecture] [id_source] [id_dest] [nom_fichier_ecriture]
+   ex : ./ftest.native graphs/graph1 0 5 graphs/graph3 *)
+
+  (* Check the number of command-line arguments *)
+  if Array.length Sys.argv <> 3 then
+    begin
+      Printf.printf "\nUsage: %s infile source sink outfile\n\n%!" Sys.argv.(0) ;
+      exit 0
+    end ;
+
+
+  (* Arguments are : infile(1) source-id(2) sink-id(3) outfile(4) *)
+
+  let infile = Sys.argv.(1)
+  and outfile = Sys.argv.(2)
+  in
+
+  (* These command-line arguments are not used for the moment. *)
+
+  (* Open file *)
+  let (initGraph, l_id) = from_file infile 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 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
+  (* let () = export infile graph in *) 
+
+  
+  (*Uncomment the following line if you have graphviz installed  *)
+  (*let retour = command ("dot -Tsvg "^outfile^".dot > "^outfile^".svg") in *)
+  ()
+

src/MSgfile.ml

@@ -0,0 +1,119 @@
+open Graph
+open Printf
+open MoneySharing
+
+type path = string
+
+(* Format of text files:
+   % Welcome to MoneySharing, your favorite tool to ease your reimbursements !
+
+   % Please, type the name of all users of your group:
+   u Gaby
+   u Flo
+   u Macha
+
+   % You can now enter your payements as it follows: p userWhoPaid [forWhichUser1; forWhichUser2 ..] amount
+   p Flo -> Gaby,Flo,Macha : 11.0€
+   p Gaby -> Flo : 8.5€
+
+*)
+
+
+let write_file path graph l_id =
+
+  (* Open a write-file. *)
+  let ff = open_out path in
+
+  (* Write in this file. *)
+  fprintf ff "%% Here is your MoneySharing graph.\n\n" ;
+
+  (* Write all users *)
+  n_iter_sorted graph (fun id -> fprintf ff "u %s\n" (get_user id l_id)) ;
+  fprintf ff "\n" ;
+
+  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) ;
+
+  fprintf ff "\n%% End of reimbursements\n" ;
+
+  close_out ff ;
+  ()
+
+let read_comment graph line l_id =
+  try Scanf.sscanf line " %%" (graph, l_id)
+  with _ ->
+    Printf.printf "Unknown line:\n%s\n%!" line ;
+    failwith "from_file"
+
+(* Reads a line with a user. *)
+let read_user id graph l_id line =
+  try Scanf.sscanf line "u %s" (fun user -> init_node graph user id l_id )
+  with e ->
+    Printf.printf "Cannot read node in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
+    failwith "from_file"
+
+(* Reads a line with a payement. *)
+let read_payement graph l_id line =
+  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 ;
+    failwith "from_file"
+
+let from_file path =
+
+  let infile = open_in path in
+
+  (* Read all lines until end of file. 
+   * n is the current node counter. *)
+  let rec loop n graph l_id=
+    try
+      let line = input_line infile in 
+
+      (* Remove leading and trailing spaces. *)
+      let line = String.trim line in
+
+      let (n2, (graph2, l2)) =
+        (* Ignore empty lines *)
+        if line = "" then (n, (graph, l_id))
+
+        (* The first character of a line determines its content : u or p. *)
+        else match line.[0] with
+          | 'u' -> (n+1, read_user n graph l_id line)
+          | 'p' -> (n, read_payement graph l_id line)
+
+          (* It should be a comment, otherwise we complain. *)
+          | _ -> (n, read_comment graph line l_id)
+      in      
+      loop n2 graph2 l2
+
+    with End_of_file -> (graph, l_id) (* Done *)
+  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 ;
+  (graph, l_id)
+
+  
+(* Write the graph in a .dot file*)
+let export path graph =
+  (* Open a write-file. *)
+  let ff = open_out (path^".dot") in
+
+  (* Write in this file. *)
+  fprintf ff "digraph graphique1 {\n\tsize=\"20\"\n\tnode [shape = circle];\n";
+
+  (* Write all arcs *)
+  e_iter graph (fun id1 id2 lbl -> fprintf ff "\t%d -> %d [ label = \"%s\" ];\n" id1 id2 lbl) ;
+
+  fprintf ff "}\n" ;
+
+  close_out ff ;
+  ()

src/MSgfile.mli

@@ -0,0 +1,12 @@
+open Graph
+open Printf
+open MoneySharing
+
+type path = string
+
+val from_file: path -> (float graph * (string * id * float) list)
+
+val write_file: path -> string graph -> (string * id * float) list -> unit
+
+val export: path -> string graph -> unit
+

src/graph.ml

@@ -0,0 +1,49 @@
+type id = int
+
+type 'a out_arcs = (id * 'a) list
+
+(* A graph is just a list of pairs: a node & its outgoing arcs. *)
+type 'a graph = (id * 'a out_arcs) list
+
+exception Graph_error of string
+
+let empty_graph = []
+
+let node_exists gr id = List.mem_assoc id gr
+
+let out_arcs gr id =
+  try List.assoc id gr
+  with Not_found -> raise (Graph_error ("Node " ^ string_of_int id ^ " does not exist in this graph."))
+
+let find_arc gr id1 id2 =
+  let out = out_arcs gr id1 in
+  try Some (List.assoc id2 out)
+  with Not_found -> None
+
+let new_node gr id =
+  if node_exists gr id then raise (Graph_error ("Node " ^ string_of_int id ^ " already exists in the graph."))
+  else (id, []) :: gr
+
+let new_arc gr id1 id2 lbl =
+
+  (* Existing out-arcs *)
+  let outa = out_arcs gr id1 in
+
+  (* Update out-arcs.
+   * remove_assoc does not fail if id2 is not bound.  *)
+  let outb = (id2, lbl) :: List.remove_assoc id2 outa in
+
+  (* Replace out-arcs in the graph. *)
+  let gr2 = List.remove_assoc id1 gr in
+  (id1, outb) :: gr2
+
+let n_iter gr f = List.iter (fun (id, _) -> f id) gr
+
+let n_iter_sorted gr f = n_iter (List.sort compare gr) f
+
+let n_fold gr f acu = List.fold_left (fun acu (id, _) -> f acu id) acu gr
+
+let e_iter gr f = List.iter (fun (id1, out) -> List.iter (fun (id2, x) -> f id1 id2 x) out) gr
+
+let e_fold gr f acu = List.fold_left (fun acu (id1, out) -> List.fold_left (fun acu (id2, x) -> f acu id1 id2 x) acu out) acu gr
+

src/graph.mli

@@ -0,0 +1,63 @@
+
+(* Type of a directed graph in which arcs have labels of type 'a. *)
+type 'a graph
+
+(* Each node has a unique identifier (a number). *)
+type id = int
+
+exception Graph_error of string
+
+
+(**************  CONSTRUCTORS  **************)
+
+(* The empty graph. *)
+val empty_graph: 'a graph
+
+(* Add a new node with the given identifier.
+ * @raise Graph_error if the id already exists. *)
+val new_node: 'a graph -> id -> 'a graph
+
+(* new_arc gr id1 id2 lbl  : adds an arc from node id1 to node id2 with label lbl
+ * Both nodes must already exist in the graph.
+ * If the arc already exists, its label is replaced by lbl. 
+ * @raise Graph_error if node id1 or id2 does not exist in the graph. *)
+val new_arc: 'a graph -> id -> id -> 'a -> 'a graph
+
+
+(**************  GETTERS  *****************)
+
+(* node_exists gr id  indicates if the node with identifier id exists in graph gr. *)
+val node_exists: 'a graph -> id -> bool
+
+(* Type of lists of outgoing arcs of a node. 
+ * An arc is represented by a pair of the destination identifier and the arc label. *)
+type 'a out_arcs = (id * 'a) list
+
+(* Find the out_arcs of a node.
+ * @raise Graph_error if the id is unknown in the graph. *)
+val out_arcs: 'a graph -> id -> 'a out_arcs
+
+(* find_arc gr id1 id2  finds an arc between id1 and id2 and returns its label. Returns None if the arc does not exist. 
+ * @raise Graph_error if id1 is unknown. *)
+val find_arc: 'a graph -> id -> id -> 'a option
+
+
+(**************  COMBINATORS, ITERATORS  **************)
+
+(* Iterate on all nodes, in no special order. *)
+val n_iter: 'a graph -> (id -> unit) -> unit
+
+(* Like n_iter, but the nodes are sorted. *)
+val n_iter_sorted: 'a graph -> (id -> unit) -> unit
+
+(* Fold on all (unsorted) nodes. You must remember what List.fold_left does. *)
+val n_fold: 'a graph -> ('b -> id -> 'b) -> 'b -> 'b
+
+
+(* Iter on all arcs (edges) *)
+val e_iter: 'a graph -> (id -> id -> 'a -> unit) -> unit
+
+(* Fold on all arcs (edges) *)
+val e_fold: 'a graph -> ('b -> id -> id -> 'a -> 'b) -> 'b -> 'b
+
+

src/moneySharing.ml

@@ -0,0 +1,80 @@
+open Graph
+open Tool
+
+
+(*fonction qui créé le noeud associé à un utilisateur et rentre la correspondance dans la table des id*)
+let init_node graph nom id 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
+    |(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,id,_)::rest-> if id = id1 then nom else get_user id1 rest
+
+let set_val_du utilisateur l_id montant l_utilisateurs =
+    let length = List.length l_utilisateurs in
+    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
+
+let set_val_pret utilisateur montant l_id = 
+    List.map (fun (nom,id,value)-> if nom=utilisateur 
+                                 then (nom,id,(Float.add value montant))
+                                 else (nom,id,value)
+             ) l_id
+    
+(*fonction qui rentre les paiements réalisés*)
+let paiement graph utilisateur l_utilisateurs montant l_id = 
+    let l_id = set_val_pret utilisateur montant l_id in
+    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

@@ -0,0 +1,21 @@
+open Graph
+open Tool
+
+
+val paiement: float graph -> string -> string list -> float -> (string * id * float) list -> (float graph * (string * id * float) list)
+
+val init_node: float graph -> string -> id -> (string * id * float) list-> (float graph * (string * id * float) list)
+
+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_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

@@ -0,0 +1,22 @@
+(* Yes, we have to repeat open Graph. *)
+open Graph
+
+(* assert false is of type ∀α.α, so the type-checker is happy. *)
+
+
+let clone_nodes gr = n_fold gr new_node empty_graph 
+
+
+(* Clone the nodes first then clone every arc but change their label by applying f*)
+let gmap gr f = 
+  let new_graph = clone_nodes gr in
+  e_fold gr (fun acu id1 id2 x -> new_arc acu id1 id2 (f x)) new_graph 
+
+let add_arc g id1 id2 n =
+    let f = find_arc g id1 id2  in
+    match f with
+    |None->new_arc g id1 id2 n
+    |Some x->new_arc g id1 id2 (Int.add n x)
+
+let get_max_id graph = 
+  n_fold graph (fun acu id -> max id acu) 0 

src/tool.mli

@@ -0,0 +1,11 @@
+open Graph
+
+(* Clone a graph by keeping only its nodes *)
+val clone_nodes: 'a graph -> 'b graph
+
+(* Apply a function f to every label of the graph's arcs *)
+val gmap: 'a graph -> ('a -> 'b) -> 'b graph
+
+val add_arc: (int * int) graph -> id -> id -> float -> (int * int) graph
+
+val get_max_id : 'a graph -> id