grew_graph.ml 19.5 KB
Newer Older
pj2m's avatar
pj2m committed
1 2 3
open Printf
open Log

bguillaum's avatar
bguillaum committed
4 5
open Grew_utils
open Grew_ast
pj2m's avatar
pj2m committed
6 7 8
open Grew_edge
open Grew_fs
open Grew_node
bguillaum's avatar
bguillaum committed
9
open Grew_command
pj2m's avatar
pj2m committed
10 11


12
(* ================================================================================ *)
pj2m's avatar
pj2m committed
13 14 15
module Deco = struct
  type t =
      { nodes: int list;
16
	edges: (int * G_edge.t * int) list;
pj2m's avatar
pj2m committed
17 18 19 20
      }

  let empty = {nodes=[]; edges=[]}
end
21
(* ================================================================================ *)
pj2m's avatar
pj2m committed
22 23


24 25 26
(* ================================================================================ *)
module P_graph = struct
  type t = P_node.t Pid_map.t
pj2m's avatar
pj2m committed
27

28 29
  let empty = Pid_map.empty
  let find = Pid_map.find
pj2m's avatar
pj2m committed
30 31 32 33

  let map_add_edge map id_src label id_tar =
    let node_src = 
      (* Not found can be raised when adding an edge from pos to neg *)
34 35
      try Pid_map.find id_src map with Not_found -> P_node.empty in
    match P_node.add_edge label id_tar node_src with
pj2m's avatar
pj2m committed
36
    | None -> None
37
    | Some new_node -> Some (Pid_map.add id_src new_node map)
pj2m's avatar
pj2m committed
38

39
  let build_filter table (ast_node, loc) = 
40
    let pid = Id.build ~loc ast_node.Ast.node_id table in
41
    let fs = P_fs.build ast_node.Ast.fs in
42 43
    (pid, fs)

bguillaum's avatar
bguillaum committed
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
  let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list = 
    (* let (named_nodes, constraints) =  *)
    (*   let rec loop already_bound = function *)
    (*     | [] -> ([],[]) *)
    (*     | (ast_node, loc) :: tail -> *)
    (*         let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in *)
    (*         if List.mem ast_node.Ast.node_id already_bound *)
    (*         then (tail_nodes, (ast_node, loc)::tail_const) *)
    (*         else (P_node.build ?pat_vars (ast_node, loc) :: tail_nodes, tail_const) in *)
    (*   loop [] full_node_list in *)

    let rec insert (ast_node, loc) = function
      | [] -> [P_node.build ?pat_vars (ast_node, loc)]
      | (n,h)::t when ast_node.Ast.node_id = n ->
          (n, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) h) :: t
      | h::t -> h :: (insert (ast_node, loc) t) in

    let (named_nodes : (Id.name * P_node.t) list) = 
      let rec loop = function
        | [] -> []
        | ast_node :: tail ->
            let tail_nodes = loop tail in
            insert ast_node tail_nodes in
            (* let old_node = List.find (fun n -> P_node.get_name) *)
            (* if List.mem ast_node.Ast.node_id already_bound *)
            (* then (tail_nodes, (ast_node, loc)::tail_const) *)
            (* else (P_node.build ?pat_vars (ast_node, loc) :: tail_nodes, tail_const) in *)
      loop full_node_list in
72

pj2m's avatar
pj2m committed
73 74 75 76 77 78 79
    let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
    let (sorted_ids, node_list) = List.split sorted_nodes in

    (* table contains the sorted list of node ids *)
    let table = Array.of_list sorted_ids in
    
    (* the nodes, in the same order *) 
80
    let map_without_edges = List_.foldi_left (fun i acc elt -> Pid_map.add i elt acc) Pid_map.empty node_list in
pj2m's avatar
pj2m committed
81
    
bguillaum's avatar
bguillaum committed
82
    let (map : t) =
pj2m's avatar
pj2m committed
83 84 85 86
      List.fold_left
	(fun acc (ast_edge, loc) ->
	  let i1 = Id.build ~loc ast_edge.Ast.src table in
	  let i2 = Id.build ~loc ast_edge.Ast.tar table in
87
	  let edge = P_edge.build ~locals (ast_edge, loc) in
pj2m's avatar
pj2m committed
88 89
	  (match map_add_edge acc i1 edge i2 with
	  | Some g -> g
90
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s" 
91
                (P_edge.to_string edge)
bguillaum's avatar
bguillaum committed
92
                (Loc.to_string loc)
pj2m's avatar
pj2m committed
93 94
	  )
	) map_without_edges full_edge_list in
bguillaum's avatar
bguillaum committed
95 96 97
    (map, table, [](* List.map (build_filter table) constraints *))


98

99 100
  (* a type for extension of graph: a former graph exists: 
     in grew the former is a positive pattern and an extension is a "without" *)
101 102 103
  type extension = {
      ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New"  *)
      old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *) 	
pj2m's avatar
pj2m committed
104
    }
105

106
  let build_extension ?(locals=[||]) old_table full_node_list full_edge_list = 
pj2m's avatar
pj2m committed
107

108
    let built_nodes = List.map P_node.build full_node_list in
pj2m's avatar
pj2m committed
109

110 111 112 113
    let (old_nodes, new_nodes) = 
      List.partition 
        (function (id,_) when Array_.dicho_mem id old_table -> true | _ -> false)
        built_nodes in
pj2m's avatar
pj2m committed
114 115 116 117 118 119 120 121 122 123 124
	
    let new_sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) new_nodes in

    let (new_sorted_ids, new_node_list) = List.split new_sorted_nodes in

    (* table contains the sorted list of node ids *)
    let new_table = Array.of_list new_sorted_ids in
    
    (* the nodes, in the same order stored with index -1, -2, ... -N *) 
    let ext_map_without_edges = 
      List_.foldi_left 
125 126
	(fun i acc elt -> Pid_map.add (-i-1) elt acc) 
	Pid_map.empty 
pj2m's avatar
pj2m committed
127 128 129 130
	new_node_list in
    
    let old_map_without_edges = 
      List.fold_left 
131 132
	(fun acc (id,node) -> Pid_map.add (Array_.dicho_find id old_table) node acc) 
	Pid_map.empty 
pj2m's avatar
pj2m committed
133 134 135 136 137 138 139 140 141 142 143
	old_nodes in

    let ext_map_with_all_edges = 
      List.fold_left
	(fun acc (ast_edge, loc) ->
	  let i1 = 
	    match Id.build_opt ast_edge.Ast.src old_table 
	    with Some i -> i | None -> -1-(Id.build ~loc ast_edge.Ast.src new_table) in
	  let i2 = 
	    match Id.build_opt ast_edge.Ast.tar old_table 
	    with Some i -> i | None -> -1-(Id.build ~loc ast_edge.Ast.tar new_table) in
144
	  let edge = P_edge.build ~locals (ast_edge, loc) in
pj2m's avatar
pj2m committed
145 146
	  match map_add_edge acc i1 edge i2 with
	  | Some map -> map
147
	  | None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
pj2m's avatar
pj2m committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161
	) ext_map_without_edges full_edge_list in
    
    ({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)

  (* ---------------------------------------------------------------------------------------------------- *)
  (* Topology functions *)
  (* ---------------------------------------------------------------------------------------------------- *)
  
  (* [tree_and_roots t] returns:
     - a boolean which is true iff the each node has at most one in-edge
     - the list of "roots" (i.e. nodes without in-edge *)
  let tree_and_roots graph =
    let tree_prop = ref true in
    let not_root =
162
      Pid_map.fold 
pj2m's avatar
pj2m committed
163 164 165 166 167 168 169 170 171
	(fun _ node acc -> 
	  Massoc.fold_left 
	    (fun acc2 tar _ ->
	      if !tree_prop
	      then 
		if IntSet.mem tar acc2
		then (tree_prop := false; acc2)
		else IntSet.add tar acc2
	      else IntSet.add tar acc2
172 173
	    ) acc (P_node.get_next node)
	) graph IntSet.empty in
pj2m's avatar
pj2m committed
174 175

    let roots =
176
      Pid_map.fold 
pj2m's avatar
pj2m committed
177 178 179 180
	(fun id _ acc -> 
	  if IntSet.mem id not_root
	  then acc 
	  else id::acc
181
	) graph [] in
pj2m's avatar
pj2m committed
182 183 184 185
    
    (!tree_prop, roots)

  let roots graph = snd (tree_and_roots graph)
186 187
end (* module P_graph *)
(* ================================================================================ *)
pj2m's avatar
pj2m committed
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


(* ================================================================================ *)
module G_graph = struct
  type t = {
      map: G_node.t Gid_map.t; (* node description *)
      lub: int;                (* least upper bound *)
    }

  let empty = {map = Gid_map.empty; lub = 0}

  let find node_id graph = Gid_map.find node_id graph.map

  type concat_item =
    | Feat of (Gid.t * string)
    | String of string

  let map_add_edge map id_src label id_tar =
    let node_src = 
      (* Not found can be raised when adding an edge from pos to neg *)
      try Gid_map.find id_src map with Not_found -> G_node.empty in
    match G_node.add_edge label id_tar node_src with
    | None -> None
    | Some new_node -> Some (Gid_map.add id_src new_node map)

214
  let build ?(locals=[||]) full_node_list full_edge_list = 
215

bguillaum's avatar
bguillaum committed
216
    let named_nodes = 
217
      let rec loop already_bound = function
bguillaum's avatar
bguillaum committed
218
        | [] -> []
219
        | (ast_node, loc) :: tail ->
bguillaum's avatar
bguillaum committed
220
            let tail = loop (ast_node.Ast.node_id :: already_bound) tail in
221
            if List.mem ast_node.Ast.node_id already_bound
222
            then Error.build "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" ast_node.Ast.node_id
223
            else G_node.build (ast_node, loc) :: tail in
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
      loop [] full_node_list in

    let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
    let (sorted_ids, node_list) = List.split sorted_nodes in

    (* table contains the sorted list of node ids *)
    let table = Array.of_list sorted_ids in
    
    (* the nodes, in the same order *) 
    let map_without_edges = List_.foldi_left (fun i acc elt -> Gid_map.add i elt acc) Gid_map.empty node_list in
    
    let map =
      List.fold_left
	(fun acc (ast_edge, loc) ->
	  let i1 = Id.build ~loc ast_edge.Ast.src table in
	  let i2 = Id.build ~loc ast_edge.Ast.tar table in
	  let edge = G_edge.build ~locals (ast_edge, loc) in
	  (match map_add_edge acc i1 edge i2 with
	  | Some g -> g
243
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s" 
244 245 246 247 248 249 250 251
                (G_edge.to_string edge)
                (Loc.to_string loc)
	  )
	) map_without_edges full_edge_list in
    
    {map=map;lub=Array.length table}


bguillaum's avatar
bguillaum committed
252
  let of_conll ?loc lines =
bguillaum's avatar
bguillaum committed
253
    
bguillaum's avatar
bguillaum committed
254 255
    let nodes = 
      List.fold_left
bguillaum's avatar
bguillaum committed
256 257
        (fun acc line -> 
          Gid_map.add line.Conll.num (G_node.of_conll line) acc) 
bguillaum's avatar
bguillaum committed
258 259 260 261 262
        Gid_map.empty lines in
    
    let nodes_with_edges = 
      List.fold_left
        (fun acc line ->
bguillaum's avatar
bguillaum committed
263 264 265
          (* add line number information in loc *)
          let loc = Loc.opt_set_line line.Conll.line_num loc in
          
bguillaum's avatar
bguillaum committed
266 267 268
          if line.Conll.gov=0
          then acc
          else 
bguillaum's avatar
bguillaum committed
269 270
            let gov_node = 
              try Gid_map.find line.Conll.gov acc 
bguillaum's avatar
bguillaum committed
271 272 273
              with Not_found -> 
                Error.build ?loc "[G_graph.of_conll] the line refers to unknown gov %d" line.Conll.gov in
            match G_node.add_edge (G_edge.make ?loc line.Conll.dep_lab) line.Conll.num gov_node with
bguillaum's avatar
bguillaum committed
274 275 276 277 278 279 280
            | None -> acc
            | Some new_node -> Gid_map.add line.Conll.gov new_node acc
        ) nodes lines in
        
        {map = nodes_with_edges; lub=1+(Gid_map.fold (fun _ _ acc -> acc+1) nodes_with_edges 0)}


281
  (* ---------------------------------------------------- *)
pj2m's avatar
pj2m committed
282
  (* Update functions *)
283 284 285 286 287 288 289 290 291 292 293 294 295
  (* ---------------------------------------------------- *)



  (* [add_edge graph id_src label id_tar] tries to add an edge grom [id_src] to [id_tar] with [label] to [graph].
     if it succeeds, [Some new_graph] is returned
     if it fails (the edge already exists), [None] is returned
   *)	  
  let add_edge graph id_src label id_tar =
    match map_add_edge graph.map id_src label id_tar with
    | Some new_map -> Some {graph with map = new_map}
    | None -> None

pj2m's avatar
pj2m committed
296 297 298

  (* remove (id_src -[label]-> id_tar) from graph.
     Log.critical if the edge is not in graph *)
299 300
  let del_edge ?edge_ident loc graph id_src label id_tar = 
    let node_src = 
301
      try Gid_map.find id_src graph.map 
302 303 304 305 306
      with Not_found -> 
        match edge_ident with
        | None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
        | Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
    
pj2m's avatar
pj2m committed
307
    try {graph with map =  
308 309
	 (* Gid_map.add id_src {node_src with Node.next = Massoc.remove id_tar label node_src.Node.next} graph.map *)
	 Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map
pj2m's avatar
pj2m committed
310
       }
311
    with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
pj2m's avatar
pj2m committed
312 313 314 315 316

  (* remove node i from graph, with all its incoming and outcoming edges *) 
  (* [graph] is unchanged if the node is not in it *)
  let del_node graph node_id = 
    let new_map = 
317
      Gid_map.fold 
pj2m's avatar
pj2m committed
318 319 320
	(fun id value acc ->
	  if id = node_id 
	  then acc
321 322 323
	  (* else Gid_map.add id {value with Node.next = try Massoc.remove_key node_id value.Node.next with Not_found -> value.Node.next} acc *)
	  else Gid_map.add id (G_node.remove_key node_id value) acc
	) graph.map Gid_map.empty in
pj2m's avatar
pj2m committed
324 325
    {graph with map = new_map}

326
  let add_neighbour loc graph node_id label = 
pj2m's avatar
pj2m committed
327 328

    (* index is a new number (higher then lub and uniquely defined by (node_id,label) *)
329
    let index = graph.lub + ((Label.to_int label) * graph.lub) + node_id in
pj2m's avatar
pj2m committed
330

331
    if Gid_map.mem index graph.map
pj2m's avatar
pj2m committed
332 333 334
    then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label);

    
335
    let node = Gid_map.find node_id graph.map in
pj2m's avatar
pj2m committed
336
    (* put the new node on the right of its "parent" *)
337 338
    let new_graph = {graph with map = Gid_map.add index (G_node.build_neighbour node) graph.map} in  
    match add_edge new_graph node_id label index with
pj2m's avatar
pj2m committed
339 340 341 342 343
    | Some g -> (index, g)
    | None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1



344 345
  (* move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *) 
  let shift_in loc graph src_gid tar_gid =
346
    let tar_node = Gid_map.find tar_gid graph.map in
347
    
348
    if Massoc.mem_key src_gid (G_node.get_next tar_node)
349 350 351
    then Error.run ~loc "[Graph.shift_in] dependency from tar to src";

    let new_map = 
352
      Gid_map.mapi
353
	(fun node_id node ->
354
          match G_node.merge_key src_gid tar_gid node with
355
          | Some new_node -> new_node
bguillaum's avatar
bguillaum committed
356
          | None -> Error.run ~loc "[Graph.shift_in] create duplicate edge"
357 358 359
	) graph.map

    in {graph with map = new_map}
pj2m's avatar
pj2m committed
360

361 362
  (* move all out-edges from id_src are moved to out-edges out off node id_tar *) 
  let shift_out loc graph src_gid tar_gid =
363 364
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
365
    
366
    if Massoc.mem_key tar_gid (G_node.get_next src_node)
bguillaum's avatar
bguillaum committed
367
    then Error.run ~loc "[Graph.shift_out] dependency from src to tar";
368 369

    let new_map = 
370
      Gid_map.mapi
371 372 373
	(fun node_id node ->
	  if node_id = src_gid 
	  then (* [src_id] becomes without out-edges *) 
374
            G_node.rm_out_edges node
375 376
	  else if node_id = tar_gid 
	  then
377 378
            match G_node.shift_out src_node tar_node with
            | Some n -> n
bguillaum's avatar
bguillaum committed
379
            | None -> Error.run ~loc "[Graph.shift_out] common successor"
380 381 382 383 384
	  else node (* other nodes don't change *)
	) graph.map
    in {graph with map = new_map}

  (* move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *) 
pj2m's avatar
pj2m committed
385
  let shift_edges loc graph src_gid tar_gid =
386 387
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
pj2m's avatar
pj2m committed
388
    
389
    if Massoc.mem_key tar_gid (G_node.get_next src_node) 
pj2m's avatar
pj2m committed
390 391
    then Error.run ~loc "[Graph.shift_edges] dependency from src to tar";

392
    if Massoc.mem_key src_gid (G_node.get_next tar_node) 
pj2m's avatar
pj2m committed
393 394 395
    then Error.run ~loc "[Graph.shift_edges] dependency from tar to src";

    let new_map = 
396
      Gid_map.mapi
pj2m's avatar
pj2m committed
397 398 399
	(fun node_id node ->
	  if node_id = src_gid 
	  then (* [src_id] becomes an isolated node *) 
400
            G_node.rm_out_edges node
pj2m's avatar
pj2m committed
401 402
	  else if node_id = tar_gid 
	  then
403 404 405 406 407 408 409
            match G_node.shift_out src_node tar_node with
            | Some n -> n
            | None -> Error.run ~loc "[Graph.shift_edges] common successor"
	  else
            match G_node.merge_key src_gid tar_gid node with
            | Some n -> n
            | None -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
pj2m's avatar
pj2m committed
410 411 412 413 414 415 416
	) graph.map

    in {graph with map = new_map}

  let merge_node loc graph src_gid tar_gid =
    let se_graph = shift_edges loc graph src_gid tar_gid in

417 418
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
pj2m's avatar
pj2m committed
419
    
420
    match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
pj2m's avatar
pj2m committed
421 422
    | Some new_fs -> 
	let new_map =
423
	  Gid_map.add
pj2m's avatar
pj2m committed
424
	    tar_gid 
425 426
            (G_node.set_fs tar_node new_fs)
	    (Gid_map.remove src_gid se_graph.map) in
pj2m's avatar
pj2m committed
427 428
	Some {se_graph with map = new_map}
    | None -> None 
bguillaum's avatar
bguillaum committed
429

430
  let set_feat ?loc graph node_id feat_name new_value =
bguillaum's avatar
bguillaum committed
431
    let node = Gid_map.find node_id graph.map in
432
    let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
bguillaum's avatar
bguillaum committed
433 434
    {graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map}

435
  let update_feat ?loc graph tar_id tar_feat_name item_list =
436 437 438 439
    let strings_to_concat =
      List.map
        (function
          | Feat (node_gid, feat_name) ->
440
              let node = Gid_map.find node_gid graph.map in
bguillaum's avatar
bguillaum committed
441 442 443 444
              (match G_fs.get_atom feat_name (G_node.get_fs node) with
              | Some atom -> atom
              | None -> Error.run ?loc "Some feature (named \"%s\") is not defined" feat_name
              )
445 446 447
          | String s -> s
        ) item_list in
    let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
448
    (set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
bguillaum's avatar
bguillaum committed
449 450


pj2m's avatar
pj2m committed
451 452 453 454
      
      (** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
	  If the feature is not present, [graph] is returned. *)
  let del_feat graph node_id feat_name = 
455
    let node =  Gid_map.find node_id graph.map in
456
    let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493
    {graph with map = Gid_map.add node_id (* {node with Node.fs = new_fs} *) (G_node.set_fs node new_fs) graph.map}

  let to_gr graph =
    let buff = Buffer.create 32 in
    
    bprintf buff "graph {\n";

    (* list of the nodes *)
    Gid_map.iter
      (fun id node ->
        bprintf buff "N%d %s;\n" id (G_node.to_gr node)
      ) graph.map;
    (* list of the edges *)
    Gid_map.iter
      (fun id node ->
	Massoc.iter
	  (fun tar edge -> 
	    bprintf buff "N%d -[%s]-> N%d;\n" id (G_edge.to_string edge) tar
	  ) (G_node.get_next node)
      ) graph.map;
    
    bprintf buff "}\n";
    Buffer.contents buff

  let to_dep ?main_feat ?(deco=Deco.empty) graph =
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";

    bprintf buff "[WORDS] { \n";

    let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
    let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.pos_comp n1 n2) nodes in

    List.iter
      (fun (id, node) -> 
	if List.mem id deco.Deco.nodes
	then bprintf buff 
494
            "N%d { %sforecolor=red; subcolor=red; }\n" id (G_fs.to_dep ?main_feat (G_node.get_fs node))
495
	else bprintf buff 
496
            "N%d { %s }\n" id (G_fs.to_dep ?main_feat (G_node.get_fs node))
497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515
      ) snodes;
    bprintf buff "} \n";
    
    bprintf buff "[EDGES] { \n";
    Gid_map.iter 
      (fun gid elt ->
	Massoc.iter
	  (fun tar g_edge -> 
	    let deco = List.mem (gid,g_edge,tar) deco.Deco.edges in
	    bprintf buff "N%d -> N%d %s\n" gid tar (G_edge.to_dep ~deco g_edge)
	  ) (G_node.get_next elt)
      ) graph.map;
      bprintf buff "} \n";
    Buffer.contents buff

  let to_dot ?main_feat ?(deco=Deco.empty) graph = 
    let buff = Buffer.create 32 in
    
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
516
    (* bprintf buff "  rankdir=LR;\n"; *)
517 518 519 520 521 522 523
    bprintf buff "  node [shape=Mrecord];\n";

    (* list of the nodes *)
    Gid_map.iter
      (fun id node ->
	bprintf buff "  N%d [label=\"%s\", color=%s]\n" 
	  id 
524
          (G_fs.to_dot ?main_feat (G_node.get_fs node)) 
525 526 527 528 529 530 531 532 533 534 535 536 537 538
          (if List.mem id deco.Deco.nodes then "red" else "black")
      ) graph.map;
    (* list of the edges *)
    Gid_map.iter
      (fun id node ->
	Massoc.iter
	  (fun tar g_edge -> 
	    let deco = List.mem (id,g_edge,tar) deco.Deco.edges in
	    bprintf buff "  N%d -> N%d%s\n" id tar (G_edge.to_dot ~deco g_edge)
	  ) (G_node.get_next node)
      ) graph.map;
    
    bprintf buff "}\n";
    Buffer.contents buff
pj2m's avatar
pj2m committed
539

540
  let equals t t' = Gid_map.equal (fun node1 node2 -> node1 = node2) t.map t'.map
pj2m's avatar
pj2m committed
541 542

  (* is there an edge e out of node i ? *)
543 544 545
  let edge_out graph node_id p_edge = 
    let node = Gid_map.find node_id graph.map in
    Massoc.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
pj2m's avatar
pj2m committed
546

547 548
end (* module G_graph *)
(* ================================================================================ *)