commons/ograph_extended.ml

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