File: graph.ml

package info (click to toggle)
marionnet 0.90.6+bzr508-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 9,532 kB
  • sloc: ml: 18,130; sh: 5,384; xml: 1,152; makefile: 1,003; ansic: 275
file content (241 lines) | stat: -rw-r--r-- 8,711 bytes parent folder | download | duplicates (2)
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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
(* This file is part of Marionnet, a virtual network laboratory
   Copyright (C) 2007, 2008  Luca Saiu
   Copyright (C) 2009  Jean-Vincent Loddo
   Copyright (C) 2007, 2008, 2009  Université Paris 13

   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

(* open PreludeExtra.Prelude;; *) (* We want synchronous terminal output *)

(** A general-purpose polymorphic graph data structure, written in imperative
    style.
    Nodes are identified by automatically-assigned unique ids, which are used
    also to recognize endpoints, for each edge.
    The implementation should be reasonably efficient, but remove_node can be
    optimized. remove_edge is difficult to make better because of a (gratuitous,
    in my opinion) restriction in Hashtbl: it's not allowed to remove a pair
    <key, value>, but only to blindly remove the "current" binding of key.
    So I have to get all bindings, filter them out, remove all bindings from the
    table, and reinsert the surviving ones. *)

type id = int;;
let fresh_id = Counter.make_int_generator ()

type 'a graph =
    (* Nodes: *)
    (id, 'a) Hashtbl.t *
    (* Edges, as a set of ordered node pairs: *)
    ((id, id) Hashtbl.t) * (* for the edge "x |-> y" x is the key, y is the value *)
    (* Reversed edges, as a set of ordered node pairs: *)
    ((id, id) Hashtbl.t);;

let make_empty_graph () : 'a graph =
  Hashtbl.create 257, Hashtbl.create 257, Hashtbl.create 257;;

let add_node node (graph : 'a graph) =
  let nodes, _, _ = graph in
  let id = fresh_id () in
  Hashtbl.add nodes id node;
  id;;

let get_node_ids (graph : 'a graph) : id list =
  let nodes, _, _ = graph in
  Hashtbl.fold
    (fun id _ list -> id :: list)
    nodes
    [];;

let get_node (id : id) (graph : 'a graph) : 'a =
  let nodes, _, _ = graph in
  Hashtbl.find nodes id;;

let get_forward_star id (graph : 'a graph) =
  let _, edges, _ = graph in
  Hashtbl.find_all edges id;;

let get_backward_star id (graph : 'a graph) =
  let _, _, backward_edges = graph in
  Hashtbl.find_all backward_edges id;;

(** Print an understandable representation of a graph, given a function printing
    a node: *)
let print_graph (print_node : 'a -> unit) (graph : 'a graph) =
  let ids : id list = List.sort compare (get_node_ids graph) in
  print_string "Nodes:\n";
  List.iter
    (fun id ->
      let node : 'a = get_node id graph in
      Printf.printf "%i. " id;
      print_node node;
      print_string "\n")
    ids;
  print_string "Edges:\n";
  List.iter
    (fun from_id ->
      let forward_star = List.sort compare (get_forward_star from_id graph) in
      if forward_star <> [] then begin
        List.iter
          (fun to_id -> Printf.printf "%i -> %i; " from_id to_id)
          forward_star;
        print_string "\n";
      end)
    ids;;

let has_edge from_id to_id (graph : 'a graph) =
  List.exists
    (fun a_to_id -> a_to_id = to_id)
    (get_forward_star from_id graph);;

let add_edge source_id destination_id (graph : 'a graph) =
  if not (has_edge source_id destination_id graph) then begin
    let _, edges, reversed_edges = graph in
    Hashtbl.add edges source_id destination_id;
    Hashtbl.add reversed_edges destination_id source_id;
  end;;

let clear (graph : 'a graph) =
  let nodes, forward_edges, backward_edges = graph in
  Hashtbl.clear nodes;
  Hashtbl.clear forward_edges;
  Hashtbl.clear backward_edges;;

let get_forward_edges (graph : 'a graph) =
  let _, edges, _ = graph in
  Hashtbl.fold
    (fun from_id to_id list -> (from_id, to_id) :: list)
    edges
    [];;

let get_backward_edges (graph : 'a graph) =
  let _, edges, _ = graph in
  Hashtbl.fold
    (fun from_id to_id list -> (to_id, from_id) :: list)
    edges
    [];;

(** Remove the edge (from_id |-> to_id), if it exists, otherwise do nothing.
    In any case *don't* remove any node.
    Yes, this implementation sucks: see the comment at the beginning to
    understand why I had to do it this way. *)
let remove_edge from_id to_id (graph : 'a graph) =
  let _, forward_edges, backward_edges = graph in
  (* Get the current forward star of from_id and the current backward star of
     to_id: the edge we want to remove, if it exists, is in both: *)
  let forward_star = get_forward_star from_id graph in
  let backward_star = get_backward_star to_id graph in
  (* Temporarily remove all the edges from from_id and all the edges to to_id: *)
  List.iter
    (fun _ -> Hashtbl.remove forward_edges from_id)
    forward_star;
  List.iter
    (fun _ -> Hashtbl.remove backward_edges to_id)
    backward_star;
  (* Re-insert all the edges, except the one we want to remove: *)
  List.iter
    (fun a_to_id -> if a_to_id <> to_id then Hashtbl.add forward_edges from_id a_to_id)
    forward_star;
  List.iter
    (fun a_from_id -> if a_from_id <> from_id then Hashtbl.add backward_edges to_id a_from_id)
    backward_star;;

(** Remove the given node, if it exists; otherwise do nothing *)
let remove_node id (graph : 'a graph) =
  let nodes, _, _ = graph in
(*   print_string "================ Before:\n"; print_graph print_string graph; *)
  (* First remove all edges involving id... *)
  let forward_star = get_forward_star id graph in
  List.iter (fun to_node -> remove_edge id to_node graph) forward_star;
  let backward_star = get_backward_star id graph in
  List.iter (fun from_node -> remove_edge from_node id graph) backward_star;
(*   print_string "================ After edges removal:\n"; print_graph print_string graph; *)
  (* ...then remove the node: *)
  Hashtbl.remove nodes id;
(*   print_string "================ After node removal:\n"; print_graph print_string graph *)
  ;;


(** Given a graph and its root, return a list of the reachable node ids in some unspecified
    topological sort, where if a |-> b is an edge b precedes a in the result. Forward edges
    are taken as elements of a 'source depends on destination' relation.
    This also works when the graph is made of several distinct connected
    components: every node is returned (exactly once).
    If the graph is cyclic then the result is undefined. *)
let topological_sort (graph : 'a graph) =
  let nodes = get_node_ids graph in
  let touched_nodes = Hashtbl.create (List.length nodes) in
  let result = ref [] in
  let rec depth_first_visit root =
    if not (Hashtbl.mem touched_nodes root) then begin
      Hashtbl.add touched_nodes root ();
      List.iter depth_first_visit (get_forward_star root graph);
      result := root :: !result;
    end in
  List.iter
    depth_first_visit
    (List.filter
       (fun node -> get_backward_star node graph = [])
       nodes);
  List.rev !result;;


(*
(** Example *)
let rec print_list print_node g xs =
  match xs with
    [] -> print_string "\n";
  | id :: ys -> (print_node (get_node id g); print_string " "; print_list print_node g ys);;

let _ =
  let g = make_empty_graph () in
(*   let a = add_node "a" g in *)
(*   let b = add_node "b" g in *)
(*   let c = add_node "c" g in *)
(*   let _ = add_edge a b g in *)
(*   let _ = add_edge a c g in *)
(*   let _ = add_edge b c g in *)
(*   let _ = add_edge b b g in *)
(*   let _ = remove_node a g in *)
(*   let n1 = add_node "a" g in *)
(*   let n2 = add_node "b" g in *)
(*   let n3 = add_node "c" g in *)
(*   let n4 = add_node "d" g in *)
(*   let n5 = add_node "e" g in *)
(*   let n6 = add_node "f" g in *)
(*   let n7 = add_node "g" g in *)
(*   let n8 = add_node "h" g in *)
(*   let n9 = add_node "i" g in *)
  let n4 = add_node "d" g in
  let n2 = add_node "b" g in
  let n1 = add_node "a" g in
  let n8 = add_node "h" g in
  let n3 = add_node "c" g in
  let n6 = add_node "f" g in
  let n9 = add_node "i" g in
  let n5 = add_node "e" g in
  let n7 = add_node "g" g in
  let _ = add_edge n1 n2 g in
  let _ = add_edge n2 n3 g in
  let _ = add_edge n1 n4 g in
  let _ = add_edge n1 n5 g in
  let _ = add_edge n3 n5 g in
  let _ = add_edge n5 n6 g in
  let _ = add_edge n7 n4 g in
  let _ = add_edge n5 n8 g in
  let _ = add_edge n8 n7 g in

  print_graph print_string g;
  print_string "\nTopological sort: ";
  print_list print_string g (topological_sort g);
  print_string "\n";;
*)