-
Notifications
You must be signed in to change notification settings - Fork 0
/
graph.ml
53 lines (37 loc) · 1.34 KB
/
graph.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
type id = string
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 " ^ 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 add_node gr id =
if node_exists gr id then raise (Graph_error ("Node " ^ id ^ " already exists in the graph."))
else (id, []) :: gr
let add_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 v_iter gr f = List.iter (fun (id, out) -> f id out) gr
let v_fold gr f acu = List.fold_left (fun acu (id, out) -> f acu id out) acu gr
let rec map gr f =
let rec map_outs = function
| [] -> []
| (target, cost) :: rest -> (target, f cost) :: map_outs rest
in
match gr with
| [] -> []
| (id, outs) :: rest -> (id, map_outs outs) :: map rest f
;;