From f0b0e8554dffcf7c7af94341d8ba3677bc52da2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onie=20Gallois?= Date: Fri, 20 Nov 2020 16:41:52 +0100 Subject: [PATCH] mediumproject --- Makefile => acceptable_project/Makefile | 0 README.md => acceptable_project/README.md | 0 _tags => acceptable_project/_tags | 0 {graphs => acceptable_project/graphs}/graph1 | 0 .../graphs}/graph1.svg | 0 {src => acceptable_project/src}/BLF.ml | 0 {src => acceptable_project/src}/BLF.mli | 0 .../src}/FFAlgorithm.ml | 0 .../src}/FFAlgorithm.mli | 0 {src => acceptable_project/src}/ftest.ml | 0 {src => acceptable_project/src}/gfile.ml | 0 {src => acceptable_project/src}/gfile.mli | 0 {src => acceptable_project/src}/graph.ml | 0 {src => acceptable_project/src}/graph.mli | 0 {src => acceptable_project/src}/tool.ml | 0 {src => acceptable_project/src}/tool.mli | 0 medium_project/Makefile | 21 +++ medium_project/README.md | 21 +++ medium_project/_tags | 3 + medium_project/graphs/graph1 | 24 +++ medium_project/graphs/graph1.svg | 106 ++++++++++++++ medium_project/src/BLF.ml | 50 +++++++ medium_project/src/BLF.mli | 12 ++ medium_project/src/FFAlgorithm.ml | 137 ++++++++++++++++++ medium_project/src/FFAlgorithm.mli | 20 +++ {src => medium_project/src}/MSftest.ml | 2 +- {src => medium_project/src}/MSgfile.ml | 18 ++- {src => medium_project/src}/MSgfile.mli | 3 + medium_project/src/gfile.mli | 19 +++ medium_project/src/graph.ml | 49 +++++++ medium_project/src/graph.mli | 63 ++++++++ {src => medium_project/src}/moneySharing.ml | 8 +- {src => medium_project/src}/moneySharing.mli | 0 medium_project/src/tool.ml | 19 +++ medium_project/src/tool.mli | 9 ++ 35 files changed, 578 insertions(+), 6 deletions(-) rename Makefile => acceptable_project/Makefile (100%) rename README.md => acceptable_project/README.md (100%) rename _tags => acceptable_project/_tags (100%) rename {graphs => acceptable_project/graphs}/graph1 (100%) rename {graphs => acceptable_project/graphs}/graph1.svg (100%) rename {src => acceptable_project/src}/BLF.ml (100%) rename {src => acceptable_project/src}/BLF.mli (100%) rename {src => acceptable_project/src}/FFAlgorithm.ml (100%) rename {src => acceptable_project/src}/FFAlgorithm.mli (100%) rename {src => acceptable_project/src}/ftest.ml (100%) rename {src => acceptable_project/src}/gfile.ml (100%) rename {src => acceptable_project/src}/gfile.mli (100%) rename {src => acceptable_project/src}/graph.ml (100%) rename {src => acceptable_project/src}/graph.mli (100%) rename {src => acceptable_project/src}/tool.ml (100%) rename {src => acceptable_project/src}/tool.mli (100%) create mode 100644 medium_project/Makefile create mode 100644 medium_project/README.md create mode 100644 medium_project/_tags create mode 100644 medium_project/graphs/graph1 create mode 100644 medium_project/graphs/graph1.svg create mode 100644 medium_project/src/BLF.ml create mode 100644 medium_project/src/BLF.mli create mode 100644 medium_project/src/FFAlgorithm.ml create mode 100644 medium_project/src/FFAlgorithm.mli rename {src => medium_project/src}/MSftest.ml (99%) rename {src => medium_project/src}/MSgfile.ml (86%) rename {src => medium_project/src}/MSgfile.mli (78%) create mode 100644 medium_project/src/gfile.mli create mode 100644 medium_project/src/graph.ml create mode 100644 medium_project/src/graph.mli rename {src => medium_project/src}/moneySharing.ml (66%) rename {src => medium_project/src}/moneySharing.mli (100%) create mode 100644 medium_project/src/tool.ml create mode 100644 medium_project/src/tool.mli diff --git a/Makefile b/acceptable_project/Makefile similarity index 100% rename from Makefile rename to acceptable_project/Makefile diff --git a/README.md b/acceptable_project/README.md similarity index 100% rename from README.md rename to acceptable_project/README.md diff --git a/_tags b/acceptable_project/_tags similarity index 100% rename from _tags rename to acceptable_project/_tags diff --git a/graphs/graph1 b/acceptable_project/graphs/graph1 similarity index 100% rename from graphs/graph1 rename to acceptable_project/graphs/graph1 diff --git a/graphs/graph1.svg b/acceptable_project/graphs/graph1.svg similarity index 100% rename from graphs/graph1.svg rename to acceptable_project/graphs/graph1.svg diff --git a/src/BLF.ml b/acceptable_project/src/BLF.ml similarity index 100% rename from src/BLF.ml rename to acceptable_project/src/BLF.ml diff --git a/src/BLF.mli b/acceptable_project/src/BLF.mli similarity index 100% rename from src/BLF.mli rename to acceptable_project/src/BLF.mli diff --git a/src/FFAlgorithm.ml b/acceptable_project/src/FFAlgorithm.ml similarity index 100% rename from src/FFAlgorithm.ml rename to acceptable_project/src/FFAlgorithm.ml diff --git a/src/FFAlgorithm.mli b/acceptable_project/src/FFAlgorithm.mli similarity index 100% rename from src/FFAlgorithm.mli rename to acceptable_project/src/FFAlgorithm.mli diff --git a/src/ftest.ml b/acceptable_project/src/ftest.ml similarity index 100% rename from src/ftest.ml rename to acceptable_project/src/ftest.ml diff --git a/src/gfile.ml b/acceptable_project/src/gfile.ml similarity index 100% rename from src/gfile.ml rename to acceptable_project/src/gfile.ml diff --git a/src/gfile.mli b/acceptable_project/src/gfile.mli similarity index 100% rename from src/gfile.mli rename to acceptable_project/src/gfile.mli diff --git a/src/graph.ml b/acceptable_project/src/graph.ml similarity index 100% rename from src/graph.ml rename to acceptable_project/src/graph.ml diff --git a/src/graph.mli b/acceptable_project/src/graph.mli similarity index 100% rename from src/graph.mli rename to acceptable_project/src/graph.mli diff --git a/src/tool.ml b/acceptable_project/src/tool.ml similarity index 100% rename from src/tool.ml rename to acceptable_project/src/tool.ml diff --git a/src/tool.mli b/acceptable_project/src/tool.mli similarity index 100% rename from src/tool.mli rename to acceptable_project/src/tool.mli diff --git a/medium_project/Makefile b/medium_project/Makefile new file mode 100644 index 0000000..bcf222f --- /dev/null +++ b/medium_project/Makefile @@ -0,0 +1,21 @@ + +build: + @echo "\n==== COMPILING ====\n" + #ocamlbuild ftest.native# + ocamlbuild MSftest.native + +format: + ocp-indent --inplace src/* + +edit: + code . -n + +demo: build + @echo "\n==== EXECUTING ====\n" + ./ftest.native graphs/graph1 1 2 outfile + @echo "\n==== RESULT ==== (content of outfile) \n" + @cat outfile + +clean: + -rm -rf _build/ + -rm ftest.native diff --git a/medium_project/README.md b/medium_project/README.md new file mode 100644 index 0000000..2ee1f32 --- /dev/null +++ b/medium_project/README.md @@ -0,0 +1,21 @@ +Base project for Ocaml project on Ford-Fulkerson. This project contains some simple configuration files to facilitate editing Ocaml in VSCode. + +To use, you should install the *OCaml* extension in VSCode. Other extensions might work as well but make sure there is only one installed. +Then open VSCode in the root directory of this repository (command line: `code path/to/ocaml-maxflow-project`). + +Features : + - full compilation as VSCode build task (Ctrl+Shift+b) + - highlights of compilation errors as you type + - code completion + - automatic indentation on file save + + +A makefile provides some useful commands: + - `make build` to compile. This creates an ftest.native executable + - `make demo` to run the `ftest` program with some arguments + - `make format` to indent the entire project + - `make edit` to open the project in VSCode + - `make clean` to remove build artifacts + +In case of trouble with the VSCode extension (e.g. the project does not build, there are strange mistakes), a common workaround is to (1) close vscode, (2) `make clean`, (3) `make build` and (4) reopen vscode (`make edit`). + diff --git a/medium_project/_tags b/medium_project/_tags new file mode 100644 index 0000000..e8bfe6d --- /dev/null +++ b/medium_project/_tags @@ -0,0 +1,3 @@ +: include + + diff --git a/medium_project/graphs/graph1 b/medium_project/graphs/graph1 new file mode 100644 index 0000000..54b8523 --- /dev/null +++ b/medium_project/graphs/graph1 @@ -0,0 +1,24 @@ +%% Test graph #1 + +%% 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. + + +%% 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 diff --git a/medium_project/graphs/graph1.svg b/medium_project/graphs/graph1.svg new file mode 100644 index 0000000..0e114ab --- /dev/null +++ b/medium_project/graphs/graph1.svg @@ -0,0 +1,106 @@ + + +]> + + + + +finite_state_machine + + +0 + +0 + + +2 + +2 + + +0->2 + + +8 + + +3 + +3 + + +0->3 + + +10 + + +1 + +1 + + +0->1 + + +7 + + +4 + +4 + + +2->4 + + +12 + + +3->2 + + +2 + + +3->1 + + +11 + + +3->4 + + +5 + + +1->4 + + +1 + + +5 + +5 + + +1->5 + + +21 + + +4->5 + + +14 + + + diff --git a/medium_project/src/BLF.ml b/medium_project/src/BLF.ml new file mode 100644 index 0000000..11316de --- /dev/null +++ b/medium_project/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; + 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,label)::d-> + if label != 0 && (blf_tab.(a).cout+label)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/medium_project/src/BLF.mli b/medium_project/src/BLF.mli new file mode 100644 index 0000000..e8dc9e4 --- /dev/null +++ b/medium_project/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 graph -> id -> id -> t_cost array + +val get_path: int graph -> id -> id -> path option \ No newline at end of file diff --git a/medium_project/src/FFAlgorithm.ml b/medium_project/src/FFAlgorithm.ml new file mode 100644 index 0000000..79ffba9 --- /dev/null +++ b/medium_project/src/FFAlgorithm.ml @@ -0,0 +1,137 @@ +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 : int graph) (path : (id * id) list) = + let min = Some 999 in + let min = List.fold_left + ( + fun acu (id1, id2) -> + let label = find_arc graph id1 id2 in + if label < acu then label else acu + ) min path in + match min with + |None -> 999 + |Some x -> x + + +(* Add a value to every egde of a path *) +let add_value_to_arcs (graph : int graph) (path : (id * id) list) (value : int) = + 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 + + +(* Removes the edges whose label = 0 *) +let remove_zeroes (graph : int graph) = + let initGraph = clone_nodes graph in + e_fold graph + ( + fun acu id1 id2 x -> + if x = 0 then acu else new_arc acu id1 id2 x + ) initGraph + +(* Remove bi-directional edges between 2 nodes*) +let only_one_edge (graph : int graph) = + let graphWithZeroes = e_fold graph + ( + fun acu id1 id2 x -> + let path = [(id1,id2);(id2,id1)] in + + let label_rev = (match find_arc graph id2 id1 with + |None -> 0 + |Some x -> x) in + let mini = min x label_rev in + let gr = add_value_to_arcs graph path (-mini) in + if x = 0 || mini = 0 then acu else gr + ) + graph in + let graphWithoutZeroes = remove_zeroes graphWithZeroes in + graphWithoutZeroes + + +(* Get the final graph after the FFalgorithm + The label of every arc becomes "x/max_capacity" where x + is the value of the opposite arc on the residual graph*) +let get_final_graph (initGraph : int graph) (residualGraph : int graph) = + + (* First get the initial and residual graph as string graphs *) + let initGraphString = g_to_string initGraph in + let residualGraphString = g_to_string 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*) + e_fold initGraph + ( + fun acu id1 id2 x -> + let label_arc = (match find_arc initGraphString id1 id2 with + |None -> "-1" + |Some x -> x) in + let label_rev_arc = find_arc residualGraphString id2 id1 in + match label_rev_arc with + |None -> new_arc acu id1 id2 ("0/"^label_arc) + |Some x -> new_arc acu id1 id2 (""^x^"/"^label_arc) + ) + finalGraph + +let ford_fulk_algorithm (graph : int graph) (origin : id) (sink : id) = + let flow = 0 in + + let graph = only_one_edge graph 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 + + (*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 (-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 = 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) + \ No newline at end of file diff --git a/medium_project/src/FFAlgorithm.mli b/medium_project/src/FFAlgorithm.mli new file mode 100644 index 0000000..8a19f29 --- /dev/null +++ b/medium_project/src/FFAlgorithm.mli @@ -0,0 +1,20 @@ +open Graph +open Tool +open BLF + + +val g_to_int: string graph -> int graph + +val ford_fulk_algorithm : int graph -> id -> id -> (int * string graph) + +(* val g_to_string: int graph -> string graph *) + +(* val only_one_edge: int graph -> int graph *) + +(* for testing purpose *) + +(* val rev_arcs: (id * id) list -> (id * id) list + +val add_value_to_arcs: int graph -> (id * id) list -> int -> int graph + +val get_final_graph: int graph -> int graph -> string graph *) \ No newline at end of file diff --git a/src/MSftest.ml b/medium_project/src/MSftest.ml similarity index 99% rename from src/MSftest.ml rename to medium_project/src/MSftest.ml index 1dcb436..b648041 100644 --- a/src/MSftest.ml +++ b/medium_project/src/MSftest.ml @@ -1,4 +1,4 @@ -open Gfile +open MSgfile open Tool open FFAlgorithm open BLF diff --git a/src/MSgfile.ml b/medium_project/src/MSgfile.ml similarity index 86% rename from src/MSgfile.ml rename to medium_project/src/MSgfile.ml index 43ddba5..e80670a 100644 --- a/src/MSgfile.ml +++ b/medium_project/src/MSgfile.ml @@ -96,4 +96,20 @@ let from_file path = let final_graph_lid= loop 0 empty_graph [] in close_in infile ; - final_graph_lid \ No newline at end of file + final_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 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/medium_project/src/MSgfile.mli similarity index 78% rename from src/MSgfile.mli rename to medium_project/src/MSgfile.mli index 2a78ae8..aa15b64 100644 --- a/src/MSgfile.mli +++ b/medium_project/src/MSgfile.mli @@ -5,3 +5,6 @@ type path = string val from_file: path -> (string graph, (string,id) list) val write_file: path -> string graph -> (string,id) list-> unit + +val export: path -> string graph -> unit + diff --git a/medium_project/src/gfile.mli b/medium_project/src/gfile.mli new file mode 100644 index 0000000..f94c5e4 --- /dev/null +++ b/medium_project/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 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 graph -> unit + +val export: path -> 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/medium_project/src/graph.ml b/medium_project/src/graph.ml new file mode 100644 index 0000000..33f7a15 --- /dev/null +++ b/medium_project/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/medium_project/src/graph.mli b/medium_project/src/graph.mli new file mode 100644 index 0000000..416e158 --- /dev/null +++ b/medium_project/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/medium_project/src/moneySharing.ml similarity index 66% rename from src/moneySharing.ml rename to medium_project/src/moneySharing.ml index f87cafb..263b2e3 100644 --- a/src/moneySharing.ml +++ b/medium_project/src/moneySharing.ml @@ -17,11 +17,11 @@ let get_user id1 l_id= match l_id with |(nom,a)::b-> if a=id1 then nom else get_user id1 b (*fonction qui rentre les paiements réalisés*) -let rec paiement g utilisateur l_utilisateurs montant l_id= - let id1=(get_id utilisateur l_id) in - match l_utilisateurs with +let rec paiement g utilisateur l_utilisateurs montant l_id= match l_utilisateurs with |[]-> (g, l_id) - |a::b-> paiement (add_arc g id1 (get_id a l_id) montant) id1 b montant l_id + |a::b-> if not(a=utlisateur) + then paiement (add_arc g (get_id utilisateur l_id) (get_id a l_id) (montant/(List.length l_utilisateurs))) utilisateur b montant l_id + else paiement g utilisateur b montant l_id diff --git a/src/moneySharing.mli b/medium_project/src/moneySharing.mli similarity index 100% rename from src/moneySharing.mli rename to medium_project/src/moneySharing.mli diff --git a/medium_project/src/tool.ml b/medium_project/src/tool.ml new file mode 100644 index 0000000..aa680f9 --- /dev/null +++ b/medium_project/src/tool.ml @@ -0,0 +1,19 @@ +(* 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 (n+x) diff --git a/medium_project/src/tool.mli b/medium_project/src/tool.mli new file mode 100644 index 0000000..0ca3797 --- /dev/null +++ b/medium_project/src/tool.mli @@ -0,0 +1,9 @@ +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 graph -> id -> id -> int -> int graph \ No newline at end of file