From 33181d550a286d325823640ca338f567e8ad5267 Mon Sep 17 00:00:00 2001 From: kevin Date: Thu, 10 Dec 2020 19:25:16 +0100 Subject: [PATCH] basic and advanced bipartite matching working --- Makefile | 20 ++++- graphs/graph1 | 20 +++-- graphs/graph2 | 17 ++++ src/BGAlgorithm.ml | 130 +++++++++++++++++++++++++++++ src/BGAlgorithm.mli | 9 ++ src/BLF.ml | 6 ++ src/BPgfile.ml | 120 ++++++++++++++++++++++++++ src/BPgfile.mli | 17 ++++ src/FFAlgorithm.ml | 121 --------------------------- src/FFAlgorithm.mli | 18 ---- src/MSgfile.ml | 119 -------------------------- src/MSgfile.mli | 12 --- src/bp.ml | 66 +++++++++++++++ src/bp.mli | 28 +++++++ src/ftest_advanced.ml | 54 ++++++++++++ src/{MSftest.ml => ftest_basic.ml} | 33 +++++--- src/gfile.ml | 119 ++++++++++++++++++++++++++ src/gfile.mli | 19 +++++ src/moneySharing.ml | 80 ------------------ src/moneySharing.mli | 21 ----- src/tool.ml | 4 +- src/tool.mli | 2 + 22 files changed, 643 insertions(+), 392 deletions(-) create mode 100644 graphs/graph2 create mode 100644 src/BGAlgorithm.ml create mode 100644 src/BGAlgorithm.mli create mode 100644 src/BPgfile.ml create mode 100644 src/BPgfile.mli delete mode 100644 src/FFAlgorithm.ml delete mode 100644 src/FFAlgorithm.mli delete mode 100644 src/MSgfile.ml delete mode 100644 src/MSgfile.mli create mode 100644 src/bp.ml create mode 100644 src/bp.mli create mode 100644 src/ftest_advanced.ml rename src/{MSftest.ml => ftest_basic.ml} (62%) create mode 100644 src/gfile.ml create mode 100644 src/gfile.mli delete mode 100644 src/moneySharing.ml delete mode 100644 src/moneySharing.mli diff --git a/Makefile b/Makefile index 1c59b5e..5ed0d91 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ build: @echo "\n==== COMPILING ====\n" - ocamlbuild MSftest.native + ocamlbuild ftest_advanced.native format: ocp-indent --inplace src/* @@ -9,6 +9,14 @@ format: edit: code . -n +basic: + @echo "\n==== COMPILING ====\n" + ocamlbuild ftest_basic.native + +advanced: + @echo "\n==== COMPILING ====\n" + ocamlbuild ftest_advanced.native + demo: build @echo "\n==== EXECUTING ====\n" ./ftest.native graphs/graph1 1 2 outfile @@ -17,4 +25,12 @@ demo: build clean: -rm -rf _build/ - -rm MSftest.native + -rm ftest_advanced.native + +clean_basic: + -rm -rf _build/ + -rm ftest_basic.native + +clean_advanced: + -rm -rf _build/ + -rm ftest_advanced.native diff --git a/graphs/graph1 b/graphs/graph1 index 4ccc4ce..64788c2 100644 --- a/graphs/graph1 +++ b/graphs/graph1 @@ -2,11 +2,19 @@ %% Nodes -u Gaby -u Flo -u Macha +n 1 1 +n 2 2 +n 3 3 +n 4 4 +n 5 5 +%% format to test basic program : +%% e id1 id2 cost capacity +e 1 2 7 30 +e 1 3 6 20 +e 2 3 5 25 +e 2 4 4 10 +e 3 4 2 20 +e 3 5 2 25 +e 4 5 1 20 -p Flo -> Gaby,Flo,Macha : 30.0€ -p Gaby -> Gaby,Flo : 20.0€ -p Macha -> Gaby,Macha : 20.0€ \ No newline at end of file diff --git a/graphs/graph2 b/graphs/graph2 new file mode 100644 index 0000000..d1f9b02 --- /dev/null +++ b/graphs/graph2 @@ -0,0 +1,17 @@ + +%% + +s a,b,c,d,e,f +s j1,j2,j3,j4,j5,j6 + +%% preferences' format : p x -> y : pref n°Z +%% (Z from 1 to size of the second set (|S2|) ) + +p a -> j2 : pref n°1 +p a -> j3 : pref n°2 +p c -> j1 : pref n°1 +p c -> j4 : pref n°2 +p d -> j3 : pref n°1 +p e -> j3 : pref n°1 +p e -> j4 : pref n°2 +p f -> j6 : pref n°1 \ No newline at end of file diff --git a/src/BGAlgorithm.ml b/src/BGAlgorithm.ml new file mode 100644 index 0000000..6cdb4e0 --- /dev/null +++ b/src/BGAlgorithm.ml @@ -0,0 +1,130 @@ +open Graph +open Tool +open BLF + +let g_to_string gr = gmap gr (fun (a,b) -> (string_of_int a, string_of_int b) ) +let g_to_int gr = gmap gr (fun (a,b) -> (int_of_string a, int_of_string b) ) + + +(* 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 capacity of a path's edge*) +let get_min_capa_from_path (graph : (int * int) graph) (path : (id * id) list) = + let min = 999999999 in + List.fold_left + ( + fun acu (id1, id2) -> + let label = ( match find_arc graph id1 id2 with + |None -> 999999999 + |Some (_,capa) -> capa) in + if label < acu then label else acu + ) min path + +(* Return the total cost of a path in the graph*) +let get_cost_from_path (graph : (int * int) graph) (path : (id * id) list) = + List.fold_left + ( + fun acu (id1, id2) -> + match find_arc graph id1 id2 with + |None -> acu + |Some (cost,_) -> acu + cost + ) 0 path + +(* Add a value to the capacity of every egde of a path in the graph*) +let add_capa_to_arcs (graph : (int * int) graph) (path : (id * id) list) (capa : int) = + List.fold_left + ( + fun acu (id1, id2) -> + add_capa acu id1 id2 capa + ) + graph path + +(* Add a value to every egde of a path *) +let add_cost_to_arcs (graph : (int * int) graph) (path : (id * id) list) (min : int)= + List.fold_left + ( + fun acu (id1, id2) -> + let (cost,capa)=match find_arc graph id1 id2 with + |None -> raise Not_found + |Some (cost,capa)->(cost,capa) in + new_arc acu id2 id1 (Int.neg cost,Int.add min capa) + ) + 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 "flow:x" where x + is the value of the flow of the opposite arc in the residual graph*) +let get_final_graph (initGraph : (int * int) graph) (residualGraph : (int * int) graph) = + + (* First get the initial and residual graph as string graphs *) + 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 (cost,"flow:x"), + (cost,"flow:0") otherwise*) + e_fold initGraph + ( + fun acu id1 id2 (cost_x,capa_x) -> + let label_rev_arc = match find_arc residualGraph id2 id1 with + |None -> 0 + |Some (cost_x,capa_x) -> (match find_arc initGraph id2 id1 with + |None -> capa_x + |Some (cost_y, capa_y) -> Int.sub capa_x capa_y ) in + let label_rev_arc = if (label_rev_arc > 0) then "flow:"^(string_of_int label_rev_arc) else "flow:0" in + new_arc acu id1 id2 ((string_of_int cost_x), label_rev_arc) + ) + finalGraph + + +let busacker_gowen_algorithm (graph : (int * int) graph) (origin : id) (sink : id) = + let flow = 0 in + let totalCost = 0 in + + let initGraph = graph in + let rec boucle graph origin sink flow totalCost = + + let path = get_path graph origin sink in + match path with + |None -> (flow, totalCost, graph) + |Some x -> begin + let path = x in + let arcs = create_arcs_from_nodes path in + + (* Find the min capacity of the path *) + let minPath = get_min_capa_from_path graph arcs in + let costPath = get_cost_from_path graph arcs in + + (* Substract the min capacity to every arc of the path *) + let graph = add_capa_to_arcs graph arcs (Int.neg minPath) in + + (* Get the reverse path *) + + (* Add the cost to every arc of the reverse path *) + (*blf prend chemin seulement si capa non saturé, donc dans tous les cas on met un arc inverse avec -cout et un arc normal avec +cout*) + let graph = add_cost_to_arcs graph arcs minPath in + + (* Add the min to the flow *) + let flow = Int.add flow minPath in + let totalCost = Int.add totalCost (costPath * minPath) in + + boucle graph origin sink flow totalCost + end in + + let (maxFlow, totalCost, residualGraph) = boucle graph origin sink flow totalCost in + + let finalGraph = get_final_graph initGraph residualGraph in + (maxFlow, totalCost , finalGraph) diff --git a/src/BGAlgorithm.mli b/src/BGAlgorithm.mli new file mode 100644 index 0000000..9009471 --- /dev/null +++ b/src/BGAlgorithm.mli @@ -0,0 +1,9 @@ +open Graph +open Tool +open BLF + +(* Return a (int * int) graph from a (string * string) graph *) +val g_to_int: (string * string) graph -> (int * int) graph + +(* Return a (string * string) graph after applying the busacker-gowen algorithm on a (int * int) graph (cost, capacity)*) +val busacker_gowen_algorithm : (int * int) graph -> id -> id -> (int * int * (string * string) graph) diff --git a/src/BLF.ml b/src/BLF.ml index 9839b9b..5844a14 100644 --- a/src/BLF.ml +++ b/src/BLF.ml @@ -1,4 +1,5 @@ open Graph +open Printf type path = id list @@ -8,6 +9,9 @@ type t_cost={ mutable father:int } +let print_t_cost t_cost = + printf "cout=%d, pere=%d\n" t_cost.cout t_cost.father + 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 @@ -29,6 +33,7 @@ let blf gr id_src id_dest= match l_out_arc with |[]-> blf_rec gr file (a::file_marque) |(id,(lcout,lcapa))::d-> + (*let () = printf "id=%d, cout=%d, capacite=%d\n" id lcout lcapa in*) if lcapa <> 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); @@ -42,6 +47,7 @@ let blf gr id_src id_dest= (*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 () = Array.iter (print_t_cost) blf_tab 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 diff --git a/src/BPgfile.ml b/src/BPgfile.ml new file mode 100644 index 0000000..482e410 --- /dev/null +++ b/src/BPgfile.ml @@ -0,0 +1,120 @@ +open Graph +open Printf +open Bp +open Str + +type path = string + +(* Format of text files: + % + + % + s a,b,c,d,e,f + s j1,j2,j3,j4,j5,j6 + + % + p a -> j2 : pref n°1 + p a -> j3 : pref n°1 + p c -> j1 : pref n°1 + p c -> j4 : pref n°1 + p d -> j3 : pref n°1 + p e -> j3 : pref n°1 + p e -> j4 : pref n°1 + p f -> j6 : pref n°1 + +*) + + +let write_file (path : path) (graph: 'a graph) (lId : (string * id * int) list) = + + (* Open a write-file. *) + let ff = open_out path in + + fprintf ff "%% Matching results :\n\n" ; + + (* Write all arcs *) + e_iter graph (fun id1 id2 lbl -> fprintf ff " %s -> %s \n"(get_nodeName id1 lId) (get_nodeName id2 lId)) ; + + close_out ff ; + () + + +let read_comment graph line = + try Scanf.sscanf line " %%" graph + with _ -> + Printf.printf "Unknown line:\n%s\n%!" line ; + failwith "from_file" + +(* Reads a line with a user. *) +let read_set graph id lId setNumber line = + (* let regexSplit = Str.regexp "(\\[|,|\\])" in *) + try Scanf.sscanf line "s %s" (fun set -> set_lNodes graph (String.split_on_char ',' set) id lId setNumber ) + 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_preference graph lId line = + try Scanf.sscanf line "p %s -> %s : pref n°%s" + (fun nodeSet1 nodeSet2 weight -> set_preference graph nodeSet1 nodeSet2 weight lId) + 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 lId setNumber= + try + let line = input_line infile in + + (* Remove leading and trailing spaces. *) + let line = String.trim line in + + let ((n2, graph2, l2) , setNumber2) = + (* Ignore empty lines *) + if line = "" then ((n, graph, lId), setNumber) + + (* The first character of a line determines its content : u or p. *) + else match line.[0] with + | 's' -> (read_set graph n lId setNumber line, setNumber+1) + | 'p' -> ((n, read_preference graph lId line, lId), 0) + + (* It should be a comment, otherwise we complain. *) + | _ -> ((n, read_comment graph line, lId), 1) + in + loop n2 graph2 l2 setNumber2 + + with End_of_file -> (graph, lId) (* Done *) + in + let (graph, lId) = loop 1 empty_graph [] 1 in + + (* Users with negative balance linked to the origin + Users with positive balance linked to sink *) + let graph = create_source_sink_and_link graph lId in + (* Link users between themselves with *) + (*let graph = link_users graph lId in *) + close_in infile ; + (graph, lId) + + +(* 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 (cout,capa) -> fprintf ff "\t%d -> %d [ label = \"%s, %s\" ];\n" id1 id2 cout capa) ; + + fprintf ff "}\n" ; + + close_out ff ; + () diff --git a/src/BPgfile.mli b/src/BPgfile.mli new file mode 100644 index 0000000..54d0611 --- /dev/null +++ b/src/BPgfile.mli @@ -0,0 +1,17 @@ +open Graph +open Printf +open Bp +open Str + +type path = string + +(* Read a (string * string) graph (cost,capacity) from a path. + Return the graph and a (string * id * int) list (name, id, setNumber) *) +val from_file: path -> ((string * string) graph * (string * id * int) list) + +(* Write the matching results in the file "path" *) +val write_file: path -> 'a graph -> (string * id * int) list -> unit + +(* Export a (string * string) graph (cout,flow) in the file "path".dot *) +val export: path -> (string * string) graph -> unit + diff --git a/src/FFAlgorithm.ml b/src/FFAlgorithm.ml deleted file mode 100644 index 148e290..0000000 --- a/src/FFAlgorithm.ml +++ /dev/null @@ -1,121 +0,0 @@ -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_capa_from_path (graph : (int * int) graph) (path : (id * id) list) = - let min = 999999999 in - List.fold_left - ( - fun acu (id1, id2) -> - let label = ( match find_arc graph id1 id2 with - |None -> 999999999 - |Some (cout,capa) -> capa) in - if label < acu then label else acu - ) min path - - -(* Add a value to every egde of a path *) -let add_capa_to_arcs (graph : (int * int) graph) (path : (id * id) list) (value : int) = - List.fold_left - ( - fun acu (id1, id2) -> - add_arc acu id1 id2 value - ) - graph path - -(* Add a value to every egde of a path *) -let add_cost_to_arcs (graph : (int * int) graph) (path : (id * id) list) (min : int)= - List.fold_left - ( - fun acu (id1, id2) -> - let (cout,capa)=match find_arc graph id1 id2 with - |None -> raise Not_Found - |Some (cout,capa)->(cout,capa) in - new_arc acu id2 id1 (Int.neg cout,Int.add min capa) - ) - 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 : (int * int) graph) (residualGraph : (int * int) 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" otherwise*) - e_fold initGraph - ( - fun acu id1 id2 (cout_x,capa_x) -> - let label_rev_arc = match find_arc residualGraphString id2 id1 with - |None -> 0 - |Some (cout_x,capa_x) -> (match find_arc initGraphString id2 id1 with - |None -> capa_x - |Some (cout_y, capa_y) -> Int.sub capa_x capa_y ) in - let label_rev_arc = if (label_rev_arc > 0) then (string_of_int label_rev_arc) else "capa:0" in - new_arc acu id1 id2 ((string_of_int cout_x), label_rev_arc) - ) - finalGraph - -let get_cout_total (residualGraph : (int * int) graph) = - e_fold residualGraph (fun acu id1 id2 (l_cout, l_capa) -> if l_cout > 0 then (Int.add acu (Int.mul l_capa l_cout) else acu) 0 - -(*ne pas oublier d'afficher le cout*) -let ford_fulk_algorithm (graph : (int * int) graph) (origin : id) (sink : id) = - let flow = 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 capacity of the path *) - let min = get_min_capa_from_path graph arcs in - - (* Substract the min capacity to every arc of the path *) - let graph = add_capa_to_arcs graph arcs (Int.neg min) in - - (* Get the reverse path *) - (*let reverse = rev_arcs arcs in*) - - (* Add the cost to every arc of the reverse path *) - (*blf prend chemin seulement si capa non saturé, donc dans tous les cas on met un arc inverse avec -cout et un arc normal avec +cout*) - let graph = add_cost_to_arcs graph arcs min in - - (* Add the min to the flow *) - let flow = Int.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 - let cout_total = get_cout_total residualGraph in - (maxFlow, cout_total,finalGraph) diff --git a/src/FFAlgorithm.mli b/src/FFAlgorithm.mli deleted file mode 100644 index 44823dc..0000000 --- a/src/FFAlgorithm.mli +++ /dev/null @@ -1,18 +0,0 @@ -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/MSgfile.ml b/src/MSgfile.ml deleted file mode 100644 index 16e6243..0000000 --- a/src/MSgfile.ml +++ /dev/null @@ -1,119 +0,0 @@ -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 deleted file mode 100644 index 15bac9c..0000000 --- a/src/MSgfile.mli +++ /dev/null @@ -1,12 +0,0 @@ -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/bp.ml b/src/bp.ml new file mode 100644 index 0000000..1ede6ca --- /dev/null +++ b/src/bp.ml @@ -0,0 +1,66 @@ +open Graph +open Tool + + +let set_node_get_lId graph nodeName id lId setNumber = + let graph = new_node graph id in + (graph, (nodeName,id,setNumber)::lId) + + +let rec set_lNodes graph (lNodes : string list) (id : int) lId setNumber = match lNodes with + |[] -> (id, graph, lId) + |nodeName :: rest -> + begin + let (graph, lId) = set_node_get_lId graph nodeName id lId setNumber in + set_lNodes graph rest (id+1) lId setNumber + end + + +let rec get_id nodeName lId = match lId with + |[]-> raise Not_found + |(nom,id,_)::rest-> if nom = nodeName then id else get_id nodeName rest + + +let rec get_nodeName idNode lId = match lId with + |[]-> raise Not_found + |(nom,id,_)::rest-> if id = idNode then nom else get_nodeName idNode rest + +let set_preference graph (nodeNameSet1 : string) (nodeNameSet2 : string) (weight : string) (lId : (string * id * int) list) = + let idS1 = get_id nodeNameSet1 lId in + let idS2 = get_id nodeNameSet2 lId in + new_arc graph idS1 idS2 (weight, "1") + + +let link_node_to_set graph lId nodeId = + List.fold_left ( + fun acu (_,id,setNumber) -> + if setNumber = 1 + then new_arc acu nodeId id ("1", "1") + else acu + ) graph lId + + +let link_set_to_node graph lId nodeId = + List.fold_left ( + fun acu (_,id,setNumber) -> + if setNumber = 2 + then new_arc acu id nodeId ("1", "1") + else acu + ) graph lId + + +let create_source_sink_and_link graph lId = + let graph = new_node graph 0 in + let sinkId = (get_max_id graph)+1 in + let graph = new_node graph sinkId in + let graph = link_node_to_set graph lId 0 in + link_set_to_node graph lId sinkId + + let remove_source_sink_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 (cout,capa) -> + if capa <> "flow:0" && node_exists acu id1 && node_exists acu id2 + then new_arc acu id1 id2 (cout,capa) + else acu + ) trimedGraph \ No newline at end of file diff --git a/src/bp.mli b/src/bp.mli new file mode 100644 index 0000000..1089d36 --- /dev/null +++ b/src/bp.mli @@ -0,0 +1,28 @@ +open Graph +open Tool + +(*Context : Maximum bipartite matching. We are trying to match as many element as possible from a first set S1 to a second set S2. + S2 elements have a limited capacity (i.e they can only be matched by n elements, most often n < |S1|). + We have to take into account S1 elements' preferences. Each one will represent a certain cost so that we can use our max-flow min-cost algorithm*) + +(* Retrieve the id corresponding to a certain nodeName in the (string * id * int) list*) +val get_id: string -> (string * id * int) list -> id + +(* Retrieve the nodeName corresponding to a certain id in the (string * id * int) list*) +val get_nodeName: id -> (string * id * int) list -> string + +(* Creates n nodes in a (string * string) graph from id to id+n-1. + Store the correspondance (nodeName, id, setNumber) in a list. + The setNumber will be later used to identify to which set a node belongs*) +val set_lNodes : (string * string ) graph -> string list -> id -> (string * id * int) list -> int -> (int * (string * string ) graph * (string * id * int) list ) + +(* Creates an arc between two nodes with a certain weight (cost) and a capacity of 1 (weigth, 1) in a (string * string) graph *) +val set_preference : (string * string ) graph -> string -> string -> string -> (string * id * int) list -> (string * string ) graph + +(* Creates a source with id=0 and a sink with id=n+1, n number of nodes in the graph. + Then creates an arc between the source and every node with setNumber=1 + and an arc between the sink and every node with setNumber=2*) +val create_source_sink_and_link : (string * string ) graph -> (string * id * int) list -> (string * string ) graph + +(* Create a new graph without : the source and its arcs, the sink and its arcs, every arc whose flow=0 *) +val remove_source_sink_zeroes : (string * string) graph -> (string * string) graph diff --git a/src/ftest_advanced.ml b/src/ftest_advanced.ml new file mode 100644 index 0000000..7fbd929 --- /dev/null +++ b/src/ftest_advanced.ml @@ -0,0 +1,54 @@ +open BPgfile +open Tool +open BGAlgorithm +open BLF +open Format +open Sys +open Printf +open Bp + +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)*) + + + + let infile = Sys.argv.(1) + and outfile = Sys.argv.(2) + + in + + let () = printf "debug args\n" in + + (* These command-line arguments are not used for the moment. *) + + (* Open file *) + let (initGraph, lId) = from_file infile in + let initGraph = g_to_int initGraph in + let idMax = get_max_id initGraph in + + + let (flow, cost, finalGraph) = busacker_gowen_algorithm initGraph 0 idMax in + let finalGraph = remove_source_sink_zeroes finalGraph in + let () = printf "max flow = %d, cost = %d\n" flow cost in + + let () = write_file outfile finalGraph lId in + let () = export outfile finalGraph in + + + (*Uncomment the following line if you have graphviz installed *) + (*let retour = command ("dot -Tsvg "^outfile^".dot > "^outfile^".svg") in *) + () + diff --git a/src/MSftest.ml b/src/ftest_basic.ml similarity index 62% rename from src/MSftest.ml rename to src/ftest_basic.ml index e19b4ba..1f8c0ae 100644 --- a/src/MSftest.ml +++ b/src/ftest_basic.ml @@ -1,11 +1,11 @@ -open MSgfile +open Gfile open Tool -open FFAlgorithm +open BGAlgorithm open BLF open Format open Sys -open MoneySharing open Printf +open Bp let () = @@ -14,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 <> 3 then + if Array.length Sys.argv <> 5 then begin Printf.printf "\nUsage: %s infile source sink outfile\n\n%!" Sys.argv.(0) ; exit 0 @@ -23,23 +23,34 @@ let () = (* Arguments are : infile(1) source-id(2) sink-id(3) outfile(4) *) + + let infile = Sys.argv.(1) and outfile = Sys.argv.(2) + + + and _source = int_of_string Sys.argv.(3) + and _sink = int_of_string Sys.argv.(4) + in + let () = printf "debug args\n" 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 *) + let initGraph = from_file infile in + let () = export outfile initGraph in + let initGraph = g_to_int 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 (flow, cout, finalGraph) = busacker_gowen_algorithm initGraph _source _sink in + (*let finalGraph = remove_ss_zeroes finalGraph in*) + let () = printf "max flow = %d, cout = %d\n" flow cout in + + let () = write_file outfile finalGraph in let () = export outfile finalGraph in (* let () = export infile graph in *) diff --git a/src/gfile.ml b/src/gfile.ml new file mode 100644 index 0000000..dff9a13 --- /dev/null +++ b/src/gfile.ml @@ -0,0 +1,119 @@ +open Graph +open Printf + +type path = string + +(* Format of text files: + % This is a comment + + % A node with its coordinates (which are not used). + n 88.8 209.7 + n 408.9 183.0 + + % The first node has id 0, the next is 1, and so on. + + % Edges: e source dest label + e 3 1 11 + e 0 2 8 + +*) + +let write_file path graph = + + (* Open a write-file. *) + let ff = open_out path in + + (* Write in this file. *) + fprintf ff "%% This is a graph.\n\n" ; + + (* Write all nodes (with fake coordinates) *) + n_iter_sorted graph (fun id -> fprintf ff "n %.1f 1.0\n" (float_of_int id)) ; + fprintf ff "\n" ; + + (* Write all arcs *) + e_iter graph (fun id1 id2 (a,b) -> fprintf ff "e %d %d %s %s\n" id1 id2 a b) ; + + fprintf ff "\n%% End of graph\n" ; + + + + close_out ff ; + () + +(* Reads a line with a node. *) +let read_node id graph line = + try Scanf.sscanf line "n %f %f" (fun _ _ -> new_node graph id) + with e -> + Printf.printf "Cannot read node in line - %s:\n%s\n%!" (Printexc.to_string e) line ; + failwith "from_file" + +(* Ensure that the given node exists in the graph. If not, create it. + * (Necessary because the website we use to create online graphs does not generate correct files when some nodes have been deleted.) *) +let ensure graph id = if node_exists graph id then graph else new_node graph id + +(* Reads a line with an arc. *) +let read_arc graph line = + try Scanf.sscanf line "e %d %d %s %s" + (fun id1 id2 cout capa -> new_arc (ensure (ensure graph id1) id2) id1 id2 (cout,capa)) + with e -> + Printf.printf "Cannot read arc in line - %s:\n%s\n%!" (Printexc.to_string e) line ; + failwith "from_file" + +(* Reads a comment or fail. *) +let read_comment graph line = + try Scanf.sscanf line " %%" graph + with _ -> + Printf.printf "Unknown line:\n%s\n%!" 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 = + try + let line = input_line infile in + + (* Remove leading and trailing spaces. *) + let line = String.trim line in + + let (n2, graph2) = + (* Ignore empty lines *) + if line = "" then (n, graph) + + (* The first character of a line determines its content : n or e. *) + else match line.[0] with + | 'n' -> (n+1, read_node n graph line) + | 'e' -> (n, read_arc graph line) + + (* It should be a comment, otherwise we complain. *) + | _ -> (n, read_comment graph line) + in + loop n2 graph2 + + with End_of_file -> graph (* Done *) + in + + let final_graph = loop 0 empty_graph in + + close_in infile ; + final_graph + + +(* 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 (a,b) -> fprintf ff "\t%d -> %d [ label = \"%s, %s\" ];\n" id1 id2 a b) ; + + fprintf ff "}\n" ; + + close_out ff ; + () diff --git a/src/gfile.mli b/src/gfile.mli new file mode 100644 index 0000000..bc92df0 --- /dev/null +++ b/src/gfile.mli @@ -0,0 +1,19 @@ +(* Read a graph from a file, + * Write a graph to a file. *) + +open Graph + +type path = string + +(* Values are read as strings. *) +val from_file: path -> (string * string) graph + +(* Similarly, we write only a string graph. + * If necessary, use gmap (to be written by you) to prepare the input graph. *) +val write_file: path -> (string * string) graph -> unit + +val export: path -> (string * string) graph -> unit + +(* The format of files is compatible with the files generated by: + https://www-m9.ma.tum.de/graph-algorithms/flow-ford-fulkerson/index_en.html +*) diff --git a/src/moneySharing.ml b/src/moneySharing.ml deleted file mode 100644 index 287245a..0000000 --- a/src/moneySharing.ml +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 index ae1d034..0000000 --- a/src/moneySharing.mli +++ /dev/null @@ -1,21 +0,0 @@ -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 index 2453968..9a23da3 100644 --- a/src/tool.ml +++ b/src/tool.ml @@ -15,8 +15,8 @@ let gmap gr f = let add_capa g id1 id2 capa = let f = find_arc g id1 id2 in match f with - |None->raise Not_Found + |None-> raise Not_found |Some (l_cout,l_capa)->new_arc g id1 id2 (l_cout,(Int.add capa l_capa)) let get_max_id graph = - n_fold graph (fun acu id -> max id acu) 0 \ No newline at end of file + n_fold graph (fun acu id -> max id acu) 0 diff --git a/src/tool.mli b/src/tool.mli index da02bf4..8c6b12a 100644 --- a/src/tool.mli +++ b/src/tool.mli @@ -6,6 +6,8 @@ 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 +(* Add a value to the capacity of the arc id1 id2 in the graph*) val add_capa: (int * int) graph -> id -> id -> int -> (int * int) graph +(* Return the highest id value in the graph*) val get_max_id : 'a graph -> id \ No newline at end of file