| 1 | open Common |
| 2 | |
| 3 | open Ocollection |
| 4 | open Oset |
| 5 | open Oassoc |
| 6 | (* open Ograph *) |
| 7 | |
| 8 | open Oassocb |
| 9 | open Osetb |
| 10 | |
| 11 | (* |
| 12 | * graph structure: |
| 13 | * - node: index -> nodevalue |
| 14 | * - arc: (index * index) * edgevalue |
| 15 | * |
| 16 | * invariant: key in pred is also in succ (completness) and value in |
| 17 | * either assoc is a key also. |
| 18 | * |
| 19 | * How ? matrix ? but no growing array :( |
| 20 | * |
| 21 | * When need index ? Must have an index when can't just use nodevalue |
| 22 | * as a key, cos sometimes may have 2 times the same key, but it must |
| 23 | * be 2 different nodes. For instance in program f(); f(); we want 2 |
| 24 | * nodes, one per f(); hence the index. If each node is different, |
| 25 | * then no problem, can omit index. |
| 26 | * |
| 27 | * todo?: prend en parametre le type de finitemap et set a prendre |
| 28 | * todo?: add_arc doit ramer, car del la key, puis add => better to |
| 29 | * have a ref to a set. |
| 30 | * |
| 31 | * opti: graph with pointers and a tag visited => need keep global value |
| 32 | * visited_counter. check(that node is in, ...), display. |
| 33 | * opti: when the graph structure is stable, have a method compact, that |
| 34 | * transforms that in a matrix (assert that all number between 0 and |
| 35 | * free_index are used, or do some defrag-like-move/renaming). |
| 36 | * |
| 37 | *) |
| 38 | |
| 39 | type nodei = int |
| 40 | |
| 41 | class ['a,'b] ograph_extended = |
| 42 | let build_assoc () = new oassocb [] in (* opti?: = oassoch *) |
| 43 | let build_set () = new osetb Setb.empty in |
| 44 | |
| 45 | object(o) |
| 46 | (* inherit ['a] ograph *) |
| 47 | |
| 48 | val free_index = 0 |
| 49 | |
| 50 | val succ = build_assoc() |
| 51 | val pred = build_assoc() |
| 52 | val nods = build_assoc() |
| 53 | |
| 54 | method add_node (e: 'a) = |
| 55 | let i = free_index in |
| 56 | ({< |
| 57 | nods = nods#add (i, e); |
| 58 | pred = pred#add (i, build_set() ); |
| 59 | succ = succ#add (i, build_set() ); |
| 60 | free_index = i + 1; |
| 61 | >}, i) |
| 62 | |
| 63 | method add_nodei i (e: 'a) = |
| 64 | ({< |
| 65 | nods = nods#add (i, e); |
| 66 | pred = pred#add (i, build_set() ); |
| 67 | succ = succ#add (i, build_set() ); |
| 68 | free_index = (max free_index i) + 1; |
| 69 | >}, i) |
| 70 | |
| 71 | |
| 72 | method del_node (i) = |
| 73 | {< |
| 74 | (* check: e is effectively the index associated with e, |
| 75 | and check that already in *) |
| 76 | |
| 77 | (* todo: assert that have no pred and succ, otherwise |
| 78 | * will have some dangling pointers |
| 79 | *) |
| 80 | nods = nods#delkey i; |
| 81 | pred = pred#delkey i; |
| 82 | succ = succ#delkey i; |
| 83 | >} |
| 84 | |
| 85 | method replace_node (i, (e: 'a)) = |
| 86 | assert (nods#haskey i); |
| 87 | {< |
| 88 | nods = nods#replkey (i, e); |
| 89 | >} |
| 90 | |
| 91 | method add_arc ((a,b),(v: 'b)) = |
| 92 | {< |
| 93 | succ = succ#replkey (a, (succ#find a)#add (b, v)); |
| 94 | pred = pred#replkey (b, (pred#find b)#add (a, v)); |
| 95 | >} |
| 96 | method del_arc ((a,b),v) = |
| 97 | {< |
| 98 | succ = succ#replkey (a, (succ#find a)#del (b,v)); |
| 99 | pred = pred#replkey (b, (pred#find b)#del (a,v)); |
| 100 | >} |
| 101 | |
| 102 | method successors e = succ#find e |
| 103 | method predecessors e = pred#find e |
| 104 | |
| 105 | method nodes = nods |
| 106 | method allsuccessors = succ |
| 107 | |
| 108 | (* |
| 109 | method ancestors xs = |
| 110 | let rec aux xs acc = |
| 111 | match xs#view with (* could be done with an iter *) |
| 112 | | Empty -> acc |
| 113 | | Cons(x, xs) -> (acc#add x) |
| 114 | +> (fun newacc -> aux (o#predecessors x) newacc) |
| 115 | +> (fun newacc -> aux xs newacc) |
| 116 | in aux xs (f2()) (* (new osetb []) *) |
| 117 | |
| 118 | method children xs = |
| 119 | let rec aux xs acc = |
| 120 | match xs#view with (* could be done with an iter *) |
| 121 | | Empty -> acc |
| 122 | | Cons(x, xs) -> (acc#add x) |
| 123 | +> (fun newacc -> aux (o#successors x) newacc) |
| 124 | +> (fun newacc -> aux xs newacc) |
| 125 | in aux xs (f2()) (* (new osetb []) *) |
| 126 | |
| 127 | method brothers x = |
| 128 | let parents = o#predecessors x in |
| 129 | (parents#fold (fun acc e -> acc $++$ o#successors e) (f2()))#del x |
| 130 | |
| 131 | *) |
| 132 | |
| 133 | end |
| 134 | |
| 135 | |
| 136 | |
| 137 | |
| 138 | class ['a,'b] ograph_mutable = |
| 139 | let build_assoc () = new oassocb [] in |
| 140 | let build_set () = new osetb Setb.empty in |
| 141 | |
| 142 | object(o) |
| 143 | |
| 144 | val mutable free_index = 0 |
| 145 | |
| 146 | val mutable succ = build_assoc() |
| 147 | val mutable pred = build_assoc() |
| 148 | val mutable nods = build_assoc() |
| 149 | |
| 150 | method add_node (e: 'a) = |
| 151 | let i = free_index in |
| 152 | nods <- nods#add (i, e); |
| 153 | pred <- pred#add (i, build_set() ); |
| 154 | succ <- succ#add (i, build_set() ); |
| 155 | free_index <- i + 1; |
| 156 | i |
| 157 | |
| 158 | method add_nodei i (e: 'a) = |
| 159 | nods <- nods#add (i, e); |
| 160 | pred <- pred#add (i, build_set() ); |
| 161 | succ <- succ#add (i, build_set() ); |
| 162 | free_index <- (max free_index i) + 1; |
| 163 | |
| 164 | |
| 165 | method del_node (i) = |
| 166 | (* check: e is effectively the index associated with e, |
| 167 | and check that already in *) |
| 168 | |
| 169 | (* todo: assert that have no pred and succ, otherwise |
| 170 | * will have some dangling pointers |
| 171 | *) |
| 172 | nods <- nods#delkey i; |
| 173 | pred <- pred#delkey i; |
| 174 | succ <- succ#delkey i; |
| 175 | |
| 176 | method replace_node (i, (e: 'a)) = |
| 177 | assert (nods#haskey i); |
| 178 | nods <- nods#replkey (i, e); |
| 179 | |
| 180 | method add_arc ((a,b),(v: 'b)) = |
| 181 | succ <- succ#replkey (a, (succ#find a)#add (b, v)); |
| 182 | pred <- pred#replkey (b, (pred#find b)#add (a, v)); |
| 183 | method del_arc ((a,b),v) = |
| 184 | succ <- succ#replkey (a, (succ#find a)#del (b,v)); |
| 185 | pred <- pred#replkey (b, (pred#find b)#del (a,v)); |
| 186 | |
| 187 | method successors e = succ#find e |
| 188 | method predecessors e = pred#find e |
| 189 | |
| 190 | method nodes = nods |
| 191 | method allsuccessors = succ |
| 192 | |
| 193 | end |
| 194 | |
| 195 | |
| 196 | (* depth first search *) |
| 197 | let dfs_iter xi f g = |
| 198 | let already = Hashtbl.create 101 in |
| 199 | let rec aux_dfs xs = |
| 200 | xs +> List.iter (fun xi -> |
| 201 | if Hashtbl.mem already xi then () |
| 202 | else begin |
| 203 | Hashtbl.add already xi true; |
| 204 | f xi; |
| 205 | let succ = g#successors xi in |
| 206 | aux_dfs (succ#tolist +> List.map fst); |
| 207 | end |
| 208 | ) in |
| 209 | aux_dfs [xi] |
| 210 | |
| 211 | |
| 212 | let dfs_iter_with_path xi f g = |
| 213 | let already = Hashtbl.create 101 in |
| 214 | let rec aux_dfs path xi = |
| 215 | if Hashtbl.mem already xi then () |
| 216 | else begin |
| 217 | Hashtbl.add already xi true; |
| 218 | f xi path; |
| 219 | let succ = g#successors xi in |
| 220 | let succ' = succ#tolist +> List.map fst in |
| 221 | succ' +> List.iter (fun yi -> |
| 222 | aux_dfs (xi::path) yi |
| 223 | ); |
| 224 | end |
| 225 | in |
| 226 | aux_dfs [] xi |
| 227 | |
| 228 | |
| 229 | |
| 230 | let generate_ograph_generic g label fnode filename = |
| 231 | Common.with_open_outfile filename (fun (pr,_) -> |
| 232 | pr "digraph misc {\n" ; |
| 233 | pr "size = \"10,10\";\n" ; |
| 234 | (match label with |
| 235 | None -> () |
| 236 | | Some x -> pr (Printf.sprintf "label = \"%s\";\n" x)); |
| 237 | |
| 238 | let nodes = g#nodes in |
| 239 | nodes#iter (fun (k,node) -> |
| 240 | let (str,border_color,inner_color) = fnode (k, node) in |
| 241 | let color = |
| 242 | match inner_color with |
| 243 | None -> |
| 244 | (match border_color with |
| 245 | None -> "" |
| 246 | | Some x -> Printf.sprintf ", style=\"setlinewidth(3)\", color = %s" x) |
| 247 | | Some x -> |
| 248 | (match border_color with |
| 249 | None -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s" x |
| 250 | | Some x' -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s, color = %s" x x') in |
| 251 | (* so can see if nodes without arcs were created *) |
| 252 | pr (sprintf "%d [label=\"%s [%d]\"%s];\n" k str k color) |
| 253 | ); |
| 254 | |
| 255 | nodes#iter (fun (k,node) -> |
| 256 | let succ = g#successors k in |
| 257 | succ#iter (fun (j,edge) -> |
| 258 | pr (sprintf "%d -> %d;\n" k j); |
| 259 | ); |
| 260 | ); |
| 261 | pr "}\n" ; |
| 262 | ); |
| 263 | () |
| 264 | |
| 265 | |
| 266 | let generate_ograph_xxx g filename = |
| 267 | with_open_outfile filename (fun (pr,_) -> |
| 268 | pr "digraph misc {\n" ; |
| 269 | pr "size = \"10,10\";\n" ; |
| 270 | |
| 271 | let nodes = g#nodes in |
| 272 | nodes#iter (fun (k,(node, s)) -> |
| 273 | (* so can see if nodes without arcs were created *) |
| 274 | pr (sprintf "%d [label=\"%s [%d]\"];\n" k s k) |
| 275 | ); |
| 276 | |
| 277 | nodes#iter (fun (k,node) -> |
| 278 | let succ = g#successors k in |
| 279 | succ#iter (fun (j,edge) -> |
| 280 | pr (sprintf "%d -> %d;\n" k j); |
| 281 | ); |
| 282 | ); |
| 283 | pr "}\n" ; |
| 284 | ); |
| 285 | () |
| 286 | |
| 287 | |
| 288 | let launch_gv_cmd filename = |
| 289 | let _status = |
| 290 | Unix.system ("dot " ^ filename ^ " -Tps -o " ^ filename ^ ".ps;") in |
| 291 | let _status = Unix.system ("gv " ^ filename ^ ".ps &") |
| 292 | in |
| 293 | (* zarb: I need this when I launch the program via eshell, otherwise gv |
| 294 | do not get the chance to be launched *) |
| 295 | Unix.sleep 1; |
| 296 | () |
| 297 | |
| 298 | let print_ograph_extended g filename launchgv = |
| 299 | generate_ograph_xxx g filename; |
| 300 | if launchgv then launch_gv_cmd filename |
| 301 | |
| 302 | let print_ograph_mutable g filename launchgv = |
| 303 | generate_ograph_xxx g filename; |
| 304 | if launchgv then launch_gv_cmd filename |
| 305 | |
| 306 | let print_ograph_mutable_generic g label fnode ~output_file ~launch_gv = |
| 307 | generate_ograph_generic g label fnode output_file; |
| 308 | if launch_gv then launch_gv_cmd output_file |