fichiers_de_base

This commit is contained in:
Leonie Gallois 2020-12-06 13:06:14 +01:00
parent 4ba9d5239b
commit ce37433fec
13 changed files with 611 additions and 0 deletions

50
src/BLF.ml Normal file
View file

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

12
src/BLF.mli Normal file
View file

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

104
src/FFAlgorithm.ml Normal file
View file

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

18
src/FFAlgorithm.mli Normal file
View file

@ -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 *)

50
src/MSftest.ml Normal file
View file

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

119
src/MSgfile.ml Normal file
View file

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

12
src/MSgfile.mli Normal file
View file

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

49
src/graph.ml Normal file
View file

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

63
src/graph.mli Normal file
View file

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

80
src/moneySharing.ml Normal file
View file

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

21
src/moneySharing.mli Normal file
View file

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

22
src/tool.ml Normal file
View file

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

11
src/tool.mli Normal file
View file

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