Mettre à jour 'README.md'

Makefile

@@ -0,0 +1,42 @@
+
+build:
+	@echo "\n==== COMPILING ====\n"
+	ocamlbuild ftest_advanced.native
+
+format:
+	ocp-indent --inplace src/*
+
+edit:
+	code . -n
+
+basic:
+	@echo "\n==== COMPILING ====\n"
+	ocamlbuild ftest_basic.native
+
+advanced:
+	@echo "\n==== COMPILING ====\n"
+	ocamlbuild ftest_advanced.native
+
+demo_advanced: build
+	@echo "\n==== EXECUTING ====\n"
+	./ftest_advanced.native graphs/graph2 graphs/graph4
+	@echo "\n==== RESULT ==== (content of outfile) \n"
+	@cat graphs/graph4
+
+demo_basic: build
+	@echo "\n==== EXECUTING ====\n"
+	./ftest_basic.native graphs/graph1 graphs/graph3 1 5
+	@echo "\n==== RESULT ==== (content of outfile) \n"
+	@cat graphs/graph3
+
+clean:
+	-rm -rf _build/
+	-rm ftest_advanced.native
+
+clean_basic:
+	-rm -rf _build/
+	-rm ftest_basic.native
+
+clean_advanced:
+	-rm -rf _build/
+	-rm ftest_advanced.native

README.md

@@ -0,0 +1,43 @@
+Better project for Ocaml project on Ford-Fulkerson. The min-cost max-flow algorithm implemented is the Busacker-Gowen algorithm.
+
+This branch features 2 versions of the project : 
+* The basic version to test the algorithm with any graph having a cost and a capacity for every edge.  
+The input file's format is almost the same as the one for the acceptable project (see gfile.ml and graphs/graph1). 
+
+  
+* The advanced version to test bipartite matching problems from a certain input file's format (see BPgfile.ml and graphs/graph2).
+
+
+A makefile provides some useful commands:
+ - `make build` to compile an algorithm which will accept an advanced file entry. This creates an ftest_advanced.native executable.
+ - `make advanced` to compile an algorithm which will accept an advanced file entry. This creates an ftest_advanced.native executable.
+ - `make basic` to compile an algorithm which will accept a basic file entry. This creates an ftest_basic.native executable.
+ - `make demo_advanced` to run the `ftest_advanced` program with some arguments
+ - `make demo_basic` to run the `ftest_basic` 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 on the ftest_advanced.native file
+ - `make clean_advanced` to remove build artifacts on the ftest_advanced.native file
+ - `make clean_basic` to remove build artifacts on the ftest_basic.native file  
+ 
+
+You can also test the 2 versions individually with any graph of your choice as long as the file you use follows the appropriate format :
+- The command to test the basic version is "./ftest_basic.native **[path_input_file] [path_output_file] [source] [sink]**"  
+- The command to test the advanced version is "./ftest_advanced.native **[path_input_file] [path_output_file]**"  
+**[path_input_file]** is the path of your file containing the graph's data.  
+**[path_output_file]** is the file's path where the results will be stored after the algorithm is executed. **It does not have to exist prior to running the command.**  
+**[source]** is the id of the source in your graph (a number)  
+**[sink]** is the id of the sink in your graph (a number)
+
+remarks for improvement: 
+
+- always work on integers rather than floats because of the round up than can lead to a huge ga between values
+- biased choice : 
+        reflect on people who choose only one option out of three, will they be advantaged or on the contrary, left behind
+        what do we want to achieve first, the maximum people or attribute the maximum first choices ?
+- small random cost to everyone in order to avoid biased choice from one roud of attribution to another
+        
+                  
+
+
+

_tags

@@ -0,0 +1,3 @@
+<src/**>: include
+
+

graphs/graph1

@@ -0,0 +1,20 @@
+%% Test graph #1
+
+%% Nodes
+
+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
+

graphs/graph1.svg

@@ -0,0 +1,106 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN"
+ "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd" [
+ <!ATTLIST svg xmlns:xlink CDATA #FIXED "http://www.w3.org/1999/xlink">
+]>
+<!-- Generated by dot version 2.7.20060111.0540 (Fri Sep  3 08:16:42 UTC 2010)
+     For user: (lebotlan) D. Le Botlan,,, -->
+<!-- Title: finite_state_machine Pages: 1 -->
+<svg width="689px" height="302px"
+ viewBox = "0 0 517 227"
+ xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<g id="graph0" class="graph" style="font-family:Times-Roman;font-size:14.00;">
+<title>finite_state_machine</title>
+<polygon style="fill:white;stroke:white;" points="0,227 0,-11 528,-11 528,227 0,227"/>
+<!-- 0 -->
+<g id="node1" class="node"><title>0</title>
+<ellipse style="fill:none;stroke:black;" cx="29" cy="112" rx="18" ry="18"/>
+<text text-anchor="middle" x="29" y="119">0</text>
+</g>
+<!-- 2 -->
+<g id="node3" class="node"><title>2</title>
+<ellipse style="fill:none;stroke:black;" cx="259" cy="43" rx="18" ry="18"/>
+<text text-anchor="middle" x="259" y="50">2</text>
+</g>
+<!-- 0&#45;&gt;2 -->
+<g id="edge2" class="edge"><title>0&#45;&gt;2</title>
+<path style="fill:none;stroke:black;" d="M51,100C59,95 68,90 77,86 127,64 140,59 192,48 201,47 212,46 221,44"/>
+<polygon style="fill:black;stroke:black;" points="221,39 235,44 221,48 221,39"/>
+<text text-anchor="middle" x="144" y="52">8</text>
+</g>
+<!-- 3 -->
+<g id="node5" class="node"><title>3</title>
+<ellipse style="fill:none;stroke:black;" cx="144" cy="112" rx="18" ry="18"/>
+<text text-anchor="middle" x="144" y="119">3</text>
+</g>
+<!-- 0&#45;&gt;3 -->
+<g id="edge4" class="edge"><title>0&#45;&gt;3</title>
+<path style="fill:none;stroke:black;" d="M53,112C69,112 89,112 107,112"/>
+<polygon style="fill:black;stroke:black;" points="107,107 120,112 107,116 107,107"/>
+<text text-anchor="middle" x="87" y="108">10</text>
+</g>
+<!-- 1 -->
+<g id="node7" class="node"><title>1</title>
+<ellipse style="fill:none;stroke:black;" cx="259" cy="191" rx="18" ry="18"/>
+<text text-anchor="middle" x="259" y="198">1</text>
+</g>
+<!-- 0&#45;&gt;1 -->
+<g id="edge6" class="edge"><title>0&#45;&gt;1</title>
+<path style="fill:none;stroke:black;" d="M48,127C65,142 93,160 120,170 153,182 192,187 221,188"/>
+<polygon style="fill:black;stroke:black;" points="221,184 235,190 221,192 221,184"/>
+<text text-anchor="middle" x="144" y="162">7</text>
+</g>
+<!-- 4 -->
+<g id="node9" class="node"><title>4</title>
+<ellipse style="fill:none;stroke:black;" cx="373" cy="120" rx="18" ry="18"/>
+<text text-anchor="middle" x="373" y="127">4</text>
+</g>
+<!-- 2&#45;&gt;4 -->
+<g id="edge8" class="edge"><title>2&#45;&gt;4</title>
+<path style="fill:none;stroke:black;" d="M279,56C296,68 321,86 343,99"/>
+<polygon style="fill:black;stroke:black;" points="345,95 353,107 340,103 345,95"/>
+<text text-anchor="middle" x="316" y="72">12</text>
+</g>
+<!-- 3&#45;&gt;2 -->
+<g id="edge12" class="edge"><title>3&#45;&gt;2</title>
+<path style="fill:none;stroke:black;" d="M165,99C183,90 207,75 225,63"/>
+<polygon style="fill:black;stroke:black;" points="224,59 237,55 229,66 224,59"/>
+<text text-anchor="middle" x="201" y="71">2</text>
+</g>
+<!-- 3&#45;&gt;1 -->
+<g id="edge14" class="edge"><title>3&#45;&gt;1</title>
+<path style="fill:none;stroke:black;" d="M161,128C171,136 181,146 192,152 203,159 215,167 225,172"/>
+<polygon style="fill:black;stroke:black;" points="228,168 237,179 224,176 228,168"/>
+<text text-anchor="middle" x="201" y="148">11</text>
+</g>
+<!-- 3&#45;&gt;4 -->
+<g id="edge10" class="edge"><title>3&#45;&gt;4</title>
+<path style="fill:none;stroke:black;" d="M168,114C208,115 288,118 336,119"/>
+<polygon style="fill:black;stroke:black;" points="336,114 349,119 336,123 336,114"/>
+<text text-anchor="middle" x="259" y="114">5</text>
+</g>
+<!-- 1&#45;&gt;4 -->
+<g id="edge16" class="edge"><title>1&#45;&gt;4</title>
+<path style="fill:none;stroke:black;" d="M280,179C293,171 311,162 325,152 331,150 336,146 343,142"/>
+<polygon style="fill:black;stroke:black;" points="340,138 353,135 344,146 340,138"/>
+<text text-anchor="middle" x="316" y="148">1</text>
+</g>
+<!-- 5 -->
+<g id="node15" class="node"><title>5</title>
+<ellipse style="fill:none;stroke:black;" cx="488" cy="168" rx="18" ry="18"/>
+<text text-anchor="middle" x="488" y="175">5</text>
+</g>
+<!-- 1&#45;&gt;5 -->
+<g id="edge18" class="edge"><title>1&#45;&gt;5</title>
+<path style="fill:none;stroke:black;" d="M283,188C311,186 357,182 397,178 415,175 433,174 451,172"/>
+<polygon style="fill:black;stroke:black;" points="451,168 464,171 451,176 451,168"/>
+<text text-anchor="middle" x="373" y="174">21</text>
+</g>
+<!-- 4&#45;&gt;5 -->
+<g id="edge20" class="edge"><title>4&#45;&gt;5</title>
+<path style="fill:none;stroke:black;" d="M396,130C412,138 435,147 453,154"/>
+<polygon style="fill:black;stroke:black;" points="455,150 465,159 451,158 455,150"/>
+<text text-anchor="middle" x="431" y="138">14</text>
+</g>
+</g>
+</svg>

graphs/graph2

@@ -0,0 +1,31 @@
+
+%% Enter the 2 sets one after the other
+%% each element separated by a coma
+
+s a,b,c,d,e,f 
+s j1,j2,j3,j4,j5,j6	
+
+%% Enter the capacity for the second set   /!\ INT only
+%% either a single number which will be the capacity of every second set's element
+%% or a list of number such as |list| = |S2|
+%% ex : 
+%%      s a,b,c,d,e,f,g,h,i,j,k,l
+%%      s j1,j2,j3
+%%      c 5,20,10
+%%      (c 5  <=> c 5,5,5 in this case)
+
+c 1
+
+%% Enter the preferences one by one with the format : elemS1 -> elemS2 : pref n°X    /!\ INT only for X
+%% with X from 1 to |S2|, 1 being the most desired, |S2| being the least desired
+%% (You can actually put any number, the rule is that for X and Y, X < Y, 
+%% the element corresponding to X is more preferred than the one corresponding to Y)
+
+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

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) 

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)

src/BLF.ml

@@ -0,0 +1,56 @@
+open Graph
+open Printf
+
+type path = id list
+
+(*type record avec id noeud et son cout*)
+type t_cost={
+    mutable cout:int;
+    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
+    
+    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,(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);
+                        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 () = 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
+           |(-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

src/BLF.mli

@@ -0,0 +1,12 @@
+open Graph
+
+type path = id list
+
+type t_cost={
+    mutable cout:int;
+    mutable father:int 
+    }
+
+val blf: (int * int) graph -> id -> id -> t_cost array
+
+val get_path: (int * int) graph -> id -> id -> path option

src/BPgfile.ml

@@ -0,0 +1,142 @@
+open Graph
+open Printf
+open Bp
+open Str
+
+type path = string
+
+(* Format of text files:
+   %% Enter the 2 sets one after the other
+   %% each element separated by a coma
+
+   s a,b,c,d,e,f
+   s j1,j2,j3,j4,j5,j6	
+
+  %% Enter the capacity for the second set   /!\ INT only
+  %% either a single number which will be the capacity of every second set's element
+  %% or a list of number such as |list| = |S2|
+  %% ex : 
+  %%      s a,b,c,d,e,f,g,h,i,j,k,l
+  %%      s j1,j2,j3
+  %%      c 5,20,10
+  %%      (c 5  <=> c 5,5,5 in this case)
+  
+  c 1 
+
+  %% Enter the preferences one by one with the format : elemS1 -> elemS2 : pref n°X    /!\ INT only for X
+  %% with X from 1 to |S2|, 1 being the most desired, |S2| being the least desired
+  %% (You can actually put any number, the rule is that for X and Y, X < Y, 
+  %% the element corresponding to X is more preferred than the one corresponding to Y)
+
+   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
+
+*)
+
+
+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 set of nodes. *)
+let read_set graph id lId setNumber line =
+  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 set in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
+    failwith "from_file"
+
+(* Reads a line with a preference. *)
+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 preference in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
+    failwith "from_file"
+
+(* Reads a line with the capacity for the second set. *)
+let read_capacity line =
+  try Scanf.sscanf line "c %s"
+        (fun capacity -> (String.split_on_char ',' capacity))
+  with e ->
+    Printf.printf "Cannot read capacity 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 capacitySet2=
+    try
+      let line = input_line infile in 
+
+      (* Remove leading and trailing spaces. *)
+      let line = String.trim line in
+
+      let ((n2, graph2, l2) , setNumber2, capacitySet22) =
+        (* Ignore empty lines *)
+        if line = "" then ((n, graph, lId), setNumber, capacitySet2 )
+
+        (* 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, capacitySet2)
+          | 'p' -> ((n, read_preference graph lId line, lId), 0, capacitySet2)
+          | 'c' -> ((n, graph, lId), 0, read_capacity line)
+
+          (* It should be a comment, otherwise we complain. *)
+          | _ -> ((n, read_comment graph line, lId), 1, capacitySet2)
+      in      
+      loop n2 graph2 l2 setNumber2 capacitySet22
+
+    with End_of_file -> (graph, lId, capacitySet2) (* Done *)
+  in
+  let (graph, lId, capacitySet2) = 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 capacitySet2 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 ;
+  ()

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
+

src/bp.ml

@@ -0,0 +1,84 @@
+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")
+
+
+(* Link the source to every node with "setNumber"=1 with cost=capacity=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
+
+
+(* Link the every node with "setNumber"=2 to the sink with cost=1 and capacity=capacitySet2 
+    Corresponds to the case where every node should have the same capacity*)
+let rec link_set_to_node_single graph lId nodeId capacitySet2 = 
+  List.fold_left (
+  fun acu (_,id,setNumber) ->
+    if setNumber = 2 
+    then new_arc acu id nodeId  ("1",List.hd capacitySet2)
+    else acu
+  ) graph lId
+    
+(* Link the every node with "setNumber"=2 to the sink with cost=1 and different capacities 
+   Corresponds to the case where every node should have a different capacity*)
+let rec link_set_to_node_multiple graph lId nodeId capacitySet2 = match lId with
+   |[] -> graph
+   |(_,id,setNumber) :: rest1 -> if setNumber = 2 then
+    begin 
+    match capacitySet2 with
+    |[]-> graph
+    |e :: rest2 -> link_set_to_node_multiple (new_arc graph id nodeId ("1",e)) rest1 nodeId rest2
+    end
+    else link_set_to_node_multiple graph rest1 nodeId capacitySet2
+
+
+let create_source_sink_and_link graph lId capacitySet2 = 
+	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
+  if List.length capacitySet2 = 1 
+  then link_set_to_node_single graph lId sinkId capacitySet2
+  else link_set_to_node_multiple graph lId sinkId capacitySet2
+  
+  
+  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

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, with n the 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 with the specified capacities, either a single number or a set of capacity*)
+val create_source_sink_and_link : (string * string ) graph -> (string * id * int) list -> string 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

src/ftest_advanced.ml

@@ -0,0 +1,49 @@
+open BPgfile
+open Tool
+open BGAlgorithm
+open BLF
+open Sys
+open Printf
+open Bp
+
+let () =
+ 
+  (*/!\ Format de la commande pour lancer le test : 
+        ./ftest_advanced.native [nom_fichier_lecture] [nom_fichier_ecriture]
+   ex : ./ftest_advanced.native graphs/graph2 graphs/graph4 *)
+
+  (* 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
+
+  (* 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 *)
+  ()
+

src/ftest_basic.ml

@@ -0,0 +1,54 @@
+open Gfile
+open Tool
+open BGAlgorithm
+open Sys
+open Printf
+
+let () =
+ 
+  (*/!\ Format de la commande pour lancer le test : 
+        ./ftest_basic.native [nom_fichier_lecture] [nom_fichier_ecriture] [id_source] [id_dest]
+   ex : ./ftest_basic.native graphs/graph1 graphs/graph3 0 5 *)
+
+  (* Check the number of command-line arguments *)
+
+
+  if Array.length Sys.argv <> 5 then
+    begin
+      Printf.printf "\nUsage: %s infile source sink outfile\n\n%!" Sys.argv.(0) ;
+      exit 0
+    end ;
+
+  (* Arguments are : infile(1) outfile(2) source-id(3) sink-id(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
+
+  (* These command-line arguments are not used for the moment. *)
+
+  (* Open file *)
+  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, cout, finalGraph) = busacker_gowen_algorithm initGraph _source _sink in
+  let () = printf "max flow = %d, cout = %d\n" flow cout in
+
+  let () = write_file outfile finalGraph 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*)
+  ()
+

src/gfile.ml

@@ -0,0 +1,121 @@
+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.
+
+   %% Enter the edges from one node to another one by one
+   %% format to test basic program : 
+   %% e id1 id2 cost capacity
+   e 3 1 5 20
+   e 0 2 8 10
+
+*)
+
+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 ;
+  ()

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

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
+

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

src/tool.ml

@@ -0,0 +1,22 @@
+(* Yes, we have to repeat open Graph. *)
+open Graph
+
+(* assert false is of type ∀α.α, so the type-checker is happy. *)
+
+
+let clone_nodes gr = n_fold gr new_node empty_graph 
+
+
+(* Clone the nodes first then clone every arc but change their label by applying f*)
+let gmap gr f = 
+  let new_graph = clone_nodes gr in
+  e_fold gr (fun acu id1 id2 x -> new_arc acu id1 id2 (f x)) new_graph 
+
+let add_capa g id1 id2 capa =
+    let f = find_arc g id1 id2  in
+    match f with
+    |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 

src/tool.mli

@@ -0,0 +1,13 @@
+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
+
+(* 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