kcavaill/ocaml_project
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

medium project working

Browse source
This commit is contained in:
Kevin Cavailles 2020-11-25 20:09:26 +01:00
parent 04ae053231
commit f2cb28ca4f
11 changed files with 120 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
graphs/graph1
View file

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

2
src/BLF.ml
View file

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

35
src/FFAlgorithm.ml
View file

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

2
src/FFAlgorithm.mli
View file

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

26
src/MSftest.ml
View file

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

22
src/MSgfile.ml
View file

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

2
src/MSgfile.mli
View file

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

69
src/moneySharing.ml
View file

@ -3,39 +3,78 @@ open Tool
(*fonction qui créé le noeud associé à un utilisateur et rentre la correspondance dans la table des id*)
let init_node g user id l_id=
( (new_node g id), ((user,id,0.0)::l_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
|(a,id1,value)::b-> if a=utilisateur then id1 else get_id utilisateur b
|(nom,id,_)::rest-> if nom = utilisateur then id else get_id utilisateur rest
(*fonction qui renvoie le nom correspondant à un id*)
let rec get_user id1 l_id= match l_id with
let rec get_user id1 l_id = match l_id with
|[]-> raise Not_found
|(nom,a,value)::b-> if a=id1 then nom else get_user id1 b
|(nom,id,_)::rest-> if id = id1 then nom else get_user id1 rest
let set_val_du a l_id montant l_utilisateurs=
List.map (fun (nom,id,value)-> if nom=a
then (nom,id,(Float.sub value (Float.div montant (Float.of_int(List.length l_utilisateurs)))))
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=
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 g utilisateur l_utilisateurs montant l_id=
let rec paye g utilisateur l_utilisateurs montant l_id=match l_utilisateurs with
|[]-> (g, l_id)
|a::b-> paye g utilisateur b montant (set_val_du a l_id montant l_utilisateurs) in
let l_id= set_val_pret utilisateur montant l_id in
paye g utilisateur l_utilisateurs montant l_id
let 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

12
src/moneySharing.mli
View file

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

3
src/tool.ml
View file

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

4
src/tool.mli
View file

@ -6,4 +6,6 @@ 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: float graph -> id -> id -> float -> float graph
val add_arc: float graph -> id -> id -> float -> float graph
val get_max_id : 'a graph -> id