Compare commits
2 commits
master
...
acceptable
| Author | SHA1 | Date | |
|---|---|---|---|
| 6c88eb310c | |||
| e0f35908b2 |
38 changed files with 83 additions and 854 deletions
|
|
@ -11,7 +11,7 @@ edit:
|
|||
|
||||
demo: build
|
||||
@echo "\n==== EXECUTING ====\n"
|
||||
./ftest.native graphs/graph1 1 2 outfile
|
||||
./ftest.native graphs/graph1 0 5 outfile
|
||||
@echo "\n==== RESULT ==== (content of outfile) \n"
|
||||
@cat outfile
|
||||
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
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)<blf_tab.(id).cout then
|
||||
begin
|
||||
blf_tab.(id).cout<-(blf_tab.(a).cout+label);
|
||||
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
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
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 *)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
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
|
||||
|
Before Width: | Height: | Size: 4.8 KiB After Width: | Height: | Size: 4.8 KiB |
|
|
@ -1,21 +0,0 @@
|
|||
|
||||
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 MSftest.native
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
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`).
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
<src/**>: include
|
||||
|
||||
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
%% 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
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
<?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->2 -->
|
||||
<g id="edge2" class="edge"><title>0->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->3 -->
|
||||
<g id="edge4" class="edge"><title>0->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->1 -->
|
||||
<g id="edge6" class="edge"><title>0->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->4 -->
|
||||
<g id="edge8" class="edge"><title>2->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->2 -->
|
||||
<g id="edge12" class="edge"><title>3->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->1 -->
|
||||
<g id="edge14" class="edge"><title>3->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->4 -->
|
||||
<g id="edge10" class="edge"><title>3->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->4 -->
|
||||
<g id="edge16" class="edge"><title>1->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->5 -->
|
||||
<g id="edge18" class="edge"><title>1->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->5 -->
|
||||
<g id="edge20" class="edge"><title>4->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>
|
||||
|
Before Width: | Height: | Size: 4.8 KiB |
|
|
@ -1,50 +0,0 @@
|
|||
open Graph
|
||||
|
||||
type path = id list
|
||||
|
||||
(*type record avec id noeud et son cout*)
|
||||
type t_cost={
|
||||
mutable cout:float;
|
||||
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_float; 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_float; 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,label)::d->
|
||||
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;
|
||||
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
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
open Graph
|
||||
|
||||
type path = id list
|
||||
|
||||
type t_cost={
|
||||
mutable cout:float;
|
||||
mutable father:int
|
||||
}
|
||||
|
||||
val blf: float graph -> id -> id -> t_cost array
|
||||
|
||||
val get_path: float graph -> id -> id -> path option
|
||||
|
|
@ -1,137 +0,0 @@
|
|||
open Graph
|
||||
open Tool
|
||||
open BLF
|
||||
|
||||
let g_to_string gr = gmap gr string_of_float
|
||||
let g_to_float gr = gmap gr float_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 = Some 999.0 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.0
|
||||
|Some x -> x
|
||||
|
||||
|
||||
(* 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
|
||||
|
||||
|
||||
(* Removes the edges whose label = 0 *)
|
||||
let remove_zeroes (graph : float graph) =
|
||||
let initGraph = clone_nodes graph in
|
||||
e_fold graph
|
||||
(
|
||||
fun acu id1 id2 x ->
|
||||
if x = 0.0 then acu else new_arc acu id1 id2 x
|
||||
) initGraph
|
||||
|
||||
(* Remove bi-directional edges between 2 nodes*)
|
||||
let only_one_edge (graph : float 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.0
|
||||
|Some x -> x) in
|
||||
let mini = min x label_rev in
|
||||
let gr = add_value_to_arcs graph path (Float.neg mini) in
|
||||
if x = 0.0 || mini = 0.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 : float graph) (residualGraph : float 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.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 : float graph) (origin : id) (sink : id) =
|
||||
let flow = 0.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 (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)
|
||||
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
open Graph
|
||||
open Tool
|
||||
open BLF
|
||||
|
||||
|
||||
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 *)
|
||||
|
||||
(* val rev_arcs: (id * id) list -> (id * id) list
|
||||
|
||||
val add_value_to_arcs: float graph -> (id * id) list -> float -> float graph
|
||||
|
||||
val get_final_graph: float graph -> float graph -> string graph *)
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
open MSgfile
|
||||
open Tool
|
||||
open FFAlgorithm
|
||||
open BLF
|
||||
open Format
|
||||
open Sys
|
||||
|
||||
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 <> 5 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.(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)
|
||||
in
|
||||
|
||||
(* Open file *)
|
||||
let (graph, l_id) = from_file infile in
|
||||
let initGraph = graph in
|
||||
|
||||
(* Rewrite the graph that has been read. *)
|
||||
|
||||
let (flow,finalGraph) = ford_fulk_algorithm initGraph _source _sink 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*)
|
||||
()
|
||||
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
open Graph
|
||||
open Printf
|
||||
open MoneySharing
|
||||
|
||||
type path = string
|
||||
|
||||
(* Format of text files:
|
||||
% Welcome to MoneySharing, your favorite tool to ease your reimbursements !
|
||||
|
||||
% Please, type the name of all users of your group:
|
||||
u Gaby
|
||||
u Flo
|
||||
u Macha
|
||||
|
||||
% You can now enter your payements as it follows: p userWhoPaid [forWhichUser1; forWhichUser2 ..] amount
|
||||
p Flo Gaby,Flo,Macha 11.0
|
||||
p Gaby Flo 8.5
|
||||
|
||||
*)
|
||||
|
||||
|
||||
let write_file path graph l_id=
|
||||
|
||||
(* Open a write-file. *)
|
||||
let ff = open_out path in
|
||||
|
||||
(* Write in this file. *)
|
||||
fprintf ff "%% Here is your MoneySharing graph.\n\n" ;
|
||||
|
||||
(* Write all users *)
|
||||
n_iter_sorted graph (fun id -> fprintf ff "u %s\n" (get_user id l_id)) ;
|
||||
fprintf ff "\n" ;
|
||||
|
||||
fprintf ff "%% Here are the reimbursements to be made.\n\n" ;
|
||||
|
||||
(* Write all arcs *)
|
||||
e_iter graph (fun id1 id2 lbl -> fprintf ff "p %s %s %s\n" (get_user id1 l_id) (get_user id2 l_id) lbl) ;
|
||||
|
||||
fprintf ff "\n%% End of reimbursements\n" ;
|
||||
|
||||
close_out ff ;
|
||||
()
|
||||
|
||||
let read_comment graph line l_id=
|
||||
try Scanf.sscanf line " %%" (graph, l_id)
|
||||
with _ ->
|
||||
Printf.printf "Unknown line:\n%s\n%!" line ;
|
||||
failwith "from_file"
|
||||
|
||||
(* Reads a line with a user. *)
|
||||
let read_user id graph l_id line =
|
||||
try Scanf.sscanf line "u %s" (fun user -> init_node graph user id l_id )
|
||||
with e ->
|
||||
Printf.printf "Cannot read node in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
|
||||
failwith "from_file"
|
||||
|
||||
(* Reads a line with a payement. *)
|
||||
let read_payement graph l_id line =
|
||||
try Scanf.sscanf line "p %s %s %f"
|
||||
(fun user l_user label -> paiement graph user (String.split_on_char ',' l_user) label l_id)
|
||||
with e ->
|
||||
Printf.printf "Cannot read arc in line - %s:\n%s\n%!" (Printexc.to_string e) line ;
|
||||
failwith "from_file"
|
||||
|
||||
let from_file path =
|
||||
|
||||
let infile = open_in path in
|
||||
|
||||
(* Read all lines until end of file.
|
||||
* n is the current node counter. *)
|
||||
let rec loop n graph l_id=
|
||||
try
|
||||
let line = input_line infile in
|
||||
|
||||
(* Remove leading and trailing spaces. *)
|
||||
let line = String.trim line in
|
||||
|
||||
let (n2, (graph2, l2)) =
|
||||
(* Ignore empty lines *)
|
||||
if line = "" then (n, (graph, l_id))
|
||||
|
||||
(* The first character of a line determines its content : u or p. *)
|
||||
else match line.[0] with
|
||||
| 'u' -> (n+1, read_user n graph l_id line)
|
||||
| 'p' -> (n, read_payement graph l_id line)
|
||||
|
||||
(* It should be a comment, otherwise we complain. *)
|
||||
| _ -> (n, read_comment graph line l_id)
|
||||
in
|
||||
loop n2 graph2 l2
|
||||
|
||||
with End_of_file -> (graph, l_id) (* Done *)
|
||||
in
|
||||
let final_graph_lid= loop 0 empty_graph [] in
|
||||
|
||||
close_in infile ;
|
||||
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 ;
|
||||
()
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
open Graph
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
|
||||
(* 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
|
||||
|
||||
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
open Graph
|
||||
open Tool
|
||||
|
||||
|
||||
(*fonction qui créé le noeud associé à un utilisateur et rentre la correspondance dans la table des id*)
|
||||
let init_node g user id l_id=
|
||||
( (new_node g id), ((user,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
|
||||
|
||||
(*fonction qui renvoie le nom correspondant à un id*)
|
||||
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
|
||||
|
||||
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)))))
|
||||
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 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
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
open Graph
|
||||
|
||||
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
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(* 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 (Float.add n x)
|
||||
50
src/BLF.ml
Normal file
50
src/BLF.ml
Normal 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 graph idSrc =
|
||||
(*je compte le nb de noeuds dans le graphe pour instancier mon tableau*)
|
||||
let nb_n = n_fold graph (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 blfTab = n_fold graph (fun acu id->acu.(id)<-{cout = max_int; father = (-1) }; acu ) acu in
|
||||
blfTab.(idSrc).cout <- 0;
|
||||
let fileId = [idSrc] in
|
||||
let fileMarquee = [] in
|
||||
|
||||
let rec blf_rec graph fileId fileMarquee= match fileId with
|
||||
|[]-> blfTab
|
||||
|a::b->
|
||||
let lOutArcs = out_arcs graph a in
|
||||
let rec loop_suc lOutArcs blfTab file =
|
||||
match lOutArcs with
|
||||
|[] -> blf_rec graph file (a::fileMarquee)
|
||||
|(id,label)::d ->
|
||||
if label != 0 && (blfTab.(a).cout+label) < blfTab.(id).cout then
|
||||
begin
|
||||
blfTab.(id).cout <- (blfTab.(a).cout+label);
|
||||
blfTab.(id).father <- a;
|
||||
if not (List.mem id fileMarquee) then loop_suc d blfTab (id::file) else loop_suc d blfTab file
|
||||
end
|
||||
else loop_suc d blfTab file in
|
||||
loop_suc lOutArcs blfTab b in
|
||||
blf_rec graph fileId fileMarquee
|
||||
|
||||
(*avec blfTab, on retrace chemin avec les pères*)
|
||||
let get_path graph idSrc idDst =
|
||||
let blfTab = blf graph idSrc in
|
||||
let path = [idDst] in
|
||||
let rec loop path blfTab idSrc idDst =
|
||||
let fatherId = blfTab.(idDst).father in match fatherId with
|
||||
|(-1) -> None
|
||||
|a -> if a == idSrc then Some (idSrc::path) else loop (a::path) blfTab idSrc a in
|
||||
loop path blfTab idSrc idDst
|
||||
14
src/BLF.mli
Normal file
14
src/BLF.mli
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
open Graph
|
||||
|
||||
type path = id list
|
||||
|
||||
type t_cost={
|
||||
mutable cout:int;
|
||||
mutable father:int
|
||||
}
|
||||
|
||||
(* Execute the Bellman-Ford algorithm on a graph from the node with the specified id *)
|
||||
val blf: int graph -> id -> t_cost array
|
||||
|
||||
(* Return a path option from a source node to a destination node *)
|
||||
val get_path: int graph -> id -> id -> path option
|
||||
|
|
@ -60,17 +60,17 @@ let get_final_graph (initGraph : int graph) (residualGraph : int graph) =
|
|||
e_fold initGraph
|
||||
(
|
||||
fun acu id1 id2 x ->
|
||||
let label_arc = (match find_arc initGraphString id1 id2 with
|
||||
let labelArc = (match find_arc initGraphString id1 id2 with
|
||||
|None -> 0
|
||||
|Some x -> x) in
|
||||
let label_rev_arc = match find_arc residualGraphString id2 id1 with
|
||||
let labelRevArc = match find_arc residualGraphString id2 id1 with
|
||||
|None -> 0
|
||||
|Some x -> (match find_arc initGraphString id2 id1 with
|
||||
|None -> x
|
||||
|Some y -> x-y) in
|
||||
let label_arc = string_of_int label_arc in
|
||||
let label_rev_arc = if (label_rev_arc > 0) then (string_of_int label_rev_arc) else "0" in
|
||||
new_arc acu id1 id2 (label_rev_arc^"/"^label_arc)
|
||||
let labelArc = string_of_int labelArc in
|
||||
let labelRevArc = if (labelRevArc > 0) then (string_of_int labelRevArc) else "0" in
|
||||
new_arc acu id1 id2 (labelRevArc^"/"^labelArc)
|
||||
)
|
||||
finalGraph
|
||||
|
||||
|
|
@ -87,15 +87,12 @@ let ford_fulk_algorithm (graph : int graph) (origin : id) (sink : id) =
|
|||
(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
|
||||
|
||||
|
|
@ -105,6 +102,7 @@ let ford_fulk_algorithm (graph : int graph) (origin : id) (sink : id) =
|
|||
(* 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)
|
||||
9
src/FFAlgorithm.mli
Normal file
9
src/FFAlgorithm.mli
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
open Graph
|
||||
open Tool
|
||||
open BLF
|
||||
|
||||
(* Return a int graph from a string graph *)
|
||||
val g_to_int: string graph -> int graph
|
||||
|
||||
(* Return a string graph after applying the ford-fulkerson algorithm on an int graph (capacity) *)
|
||||
val ford_fulk_algorithm : int graph -> id -> id -> (int * string graph)
|
||||
|
|
@ -8,7 +8,7 @@ open Sys
|
|||
let () =
|
||||
|
||||
(*/!\ Format de la commande pour lancer le test :
|
||||
./ftest.native [nom_fichier_lecture] [id_source] [id_dest] [nom_fichier_ecriture]
|
||||
./ftest.native [path_input_file] [source] [sink] [path_output_file]
|
||||
ex : ./ftest.native graphs/graph1 0 5 graphs/graph3 *)
|
||||
|
||||
(* Check the number of command-line arguments *)
|
||||
|
|
@ -39,8 +39,6 @@ let () =
|
|||
let () = printf "max flow = %d\n" flow in
|
||||
let () = write_file outfile finalGraph 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*)
|
||||
|
|
@ -6,4 +6,5 @@ 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
|
||||
(* Add a value to the capacity of the arc id1 id2 in the graph*)
|
||||
val add_arc: int graph -> id -> id -> int -> int graph
|
||||
Loading…
Reference in a new issue