| 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 | (* Difference with ograph_extended ? why not share code ? could, but |
| 13 | * in ograph_extended we dont force the user to have a key and we |
| 14 | * generate those keys as he add nodes. Here we assume the user already |
| 15 | * have an idea of what kind of key he wants to use (a string, a |
| 16 | * filename, a, int, whatever) |
| 17 | *) |
| 18 | |
| 19 | class ['key, 'a,'b] ograph_mutable = |
| 20 | let build_assoc () = new oassocb [] in |
| 21 | let build_set () = new osetb Setb.empty in |
| 22 | |
| 23 | object(o) |
| 24 | |
| 25 | |
| 26 | val mutable succ = build_assoc() |
| 27 | val mutable pred = build_assoc() |
| 28 | val mutable nods = (build_assoc() : ('key, 'a) Oassocb.oassocb) |
| 29 | |
| 30 | method add_node i (e: 'a) = |
| 31 | nods <- nods#add (i, e); |
| 32 | pred <- pred#add (i, build_set() ); |
| 33 | succ <- succ#add (i, build_set() ); |
| 34 | |
| 35 | method del_node (i) = |
| 36 | (* check: e is effectively the index associated with e, |
| 37 | and check that already in *) |
| 38 | |
| 39 | (* todo: assert that have no pred and succ, otherwise |
| 40 | * will have some dangling pointers |
| 41 | *) |
| 42 | nods <- nods#delkey i; |
| 43 | pred <- pred#delkey i; |
| 44 | succ <- succ#delkey i; |
| 45 | |
| 46 | method del_leaf_node_and_its_edges (i) = |
| 47 | let succ = o#successors i in |
| 48 | if not (succ#null) |
| 49 | then failwith "del_leaf_node_and_its_edges: have some successors" |
| 50 | else begin |
| 51 | let pred = o#predecessors i in |
| 52 | pred#tolist +> List.iter (fun (k, edge) -> |
| 53 | o#del_arc (k,i) edge; |
| 54 | ); |
| 55 | o#del_node i |
| 56 | end |
| 57 | |
| 58 | method leaf_nodes () = |
| 59 | let (set : 'key Oset.oset) = build_set () in |
| 60 | o#nodes#tolist +> List.fold_left (fun acc (k,v) -> |
| 61 | if (o#successors k)#null |
| 62 | then acc#add k |
| 63 | else acc |
| 64 | ) set |
| 65 | |
| 66 | |
| 67 | method replace_node i (e: 'a) = |
| 68 | assert (nods#haskey i); |
| 69 | nods <- nods#replkey (i, e); |
| 70 | |
| 71 | method add_arc (a,b) (v: 'b) = |
| 72 | succ <- succ#replkey (a, (succ#find a)#add (b, v)); |
| 73 | pred <- pred#replkey (b, (pred#find b)#add (a, v)); |
| 74 | method del_arc (a,b) v = |
| 75 | succ <- succ#replkey (a, (succ#find a)#del (b,v)); |
| 76 | pred <- pred#replkey (b, (pred#find b)#del (a,v)); |
| 77 | |
| 78 | method successors e = succ#find e |
| 79 | method predecessors e = pred#find e |
| 80 | |
| 81 | method nodes = nods |
| 82 | method allsuccessors = succ |
| 83 | |
| 84 | (* detect if no loop ? *) |
| 85 | method ancestors k = |
| 86 | let empty_set = build_set() in |
| 87 | |
| 88 | |
| 89 | let rec aux acc x = |
| 90 | if acc#mem x |
| 91 | then |
| 92 | (* bugfix: have_loop := true; ? not, not necessarally. |
| 93 | * if you got a diamon, seeing a second time the same |
| 94 | * x does not mean we are in a loop |
| 95 | *) |
| 96 | acc |
| 97 | else |
| 98 | let acc = acc#add x in |
| 99 | let prefs = o#predecessors x in |
| 100 | let prefs = prefs#tolist +> List.map fst in |
| 101 | prefs +> List.fold_left (fun acc x -> aux acc x) acc |
| 102 | in |
| 103 | let set = aux empty_set k in |
| 104 | let set = set#del k in |
| 105 | set |
| 106 | |
| 107 | |
| 108 | |
| 109 | |
| 110 | end |
| 111 | |
| 112 | |
| 113 | let print_ograph_generic ~str_of_key ~str_of_node filename g = |
| 114 | Common.with_open_outfile filename (fun (pr,_) -> |
| 115 | pr "digraph misc {\n" ; |
| 116 | pr "size = \"10,10\";\n" ; |
| 117 | |
| 118 | let nodes = g#nodes in |
| 119 | nodes#iter (fun (k,node) -> |
| 120 | pr (spf "%s [label=\"%s\"];\n" (str_of_key k) (str_of_node k node)) |
| 121 | ); |
| 122 | nodes#iter (fun (k,node) -> |
| 123 | let succ = g#successors k in |
| 124 | succ#iter (fun (j,edge) -> |
| 125 | pr (spf "%s -> %s;\n" (str_of_key k) (str_of_key j)); |
| 126 | ); |
| 127 | ); |
| 128 | pr "}\n" ; |
| 129 | ); |
| 130 | () |