diff --git a/src/BLF.ml b/src/BLF.ml new file mode 100644 index 0000000..ea7c757 --- /dev/null +++ b/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 diff --git a/src/BLF.mli b/src/BLF.mli new file mode 100644 index 0000000..970c64b --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/FFAlgorithm.ml b/src/FFAlgorithm.ml new file mode 100644 index 0000000..7035f90 --- /dev/null +++ b/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) diff --git a/src/FFAlgorithm.mli b/src/FFAlgorithm.mli new file mode 100644 index 0000000..44823dc --- /dev/null +++ b/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 *) \ No newline at end of file diff --git a/src/MSftest.ml b/src/MSftest.ml new file mode 100644 index 0000000..e19b4ba --- /dev/null +++ b/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 *) + () + diff --git a/src/MSgfile.ml b/src/MSgfile.ml new file mode 100644 index 0000000..16e6243 --- /dev/null +++ b/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 ; + () \ No newline at end of file diff --git a/src/MSgfile.mli b/src/MSgfile.mli new file mode 100644 index 0000000..15bac9c --- /dev/null +++ b/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 + diff --git a/src/graph.ml b/src/graph.ml new file mode 100644 index 0000000..33f7a15 --- /dev/null +++ b/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 + diff --git a/src/graph.mli b/src/graph.mli new file mode 100644 index 0000000..416e158 --- /dev/null +++ b/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 + + diff --git a/src/moneySharing.ml b/src/moneySharing.ml new file mode 100644 index 0000000..287245a --- /dev/null +++ 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 diff --git a/src/moneySharing.mli b/src/moneySharing.mli new file mode 100644 index 0000000..ae1d034 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/tool.ml b/src/tool.ml new file mode 100644 index 0000000..318984d --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/tool.mli b/src/tool.mli new file mode 100644 index 0000000..a699194 --- /dev/null +++ b/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 \ No newline at end of file