grew_graph.ml 20.8 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
(* ================================================================================ *)
13
module P_deco = struct
pj2m's avatar
pj2m committed
14
  type t =
15 16
      { nodes: Pid.t list;
	edges: (Pid.t * P_edge.t * Pid.t) 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 27 28 29 30 31 32
(* ================================================================================ *)
module G_deco = struct
  type t =
      { nodes: Gid.t list;
	edges: (Gid.t * G_edge.t * Gid.t) list;
      }

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

34 35 36
(* ================================================================================ *)
module P_graph = struct
  type t = P_node.t Pid_map.t
pj2m's avatar
pj2m committed
37

38 39
  let empty = Pid_map.empty
  let find = Pid_map.find
pj2m's avatar
pj2m committed
40 41

  let map_add_edge map id_src label id_tar =
42
    let node_src =
pj2m's avatar
pj2m committed
43
      (* Not found can be raised when adding an edge from pos to neg *)
44 45
      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
46
    | None -> None
47
    | Some new_node -> Some (Pid_map.add id_src new_node map)
pj2m's avatar
pj2m committed
48

49
  let build_filter table (ast_node, loc) =
50
    let pid = Id.build ~loc ast_node.Ast.node_id table in
51
    let fs = P_fs.build ast_node.Ast.fs in
52 53
    (pid, fs)

54
  let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
bguillaum's avatar
bguillaum committed
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
    (* 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

71
    let (named_nodes : (Id.name * P_node.t) list) =
bguillaum's avatar
bguillaum committed
72 73 74 75 76 77 78 79 80 81
      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
82

pj2m's avatar
pj2m committed
83 84 85 86 87
    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
88 89

    (* the nodes, in the same order *)
bguillaum's avatar
bguillaum committed
90 91
    let map_without_edges = List_.foldi_left
      (fun i acc elt -> Pid_map.add (Pid.Pos i) elt acc)
bguillaum's avatar
bguillaum committed
92
      Pid_map.empty node_list in
93

bguillaum's avatar
bguillaum committed
94
    let (map : t) =
pj2m's avatar
pj2m committed
95 96 97 98
      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
99
	  let edge = P_edge.build ~locals (ast_edge, loc) in
bguillaum's avatar
bguillaum committed
100
	  (match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
pj2m's avatar
pj2m committed
101
	  | Some g -> g
102
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
103
                (P_edge.to_string edge)
bguillaum's avatar
bguillaum committed
104
                (Loc.to_string loc)
pj2m's avatar
pj2m committed
105 106
	  )
	) map_without_edges full_edge_list in
bguillaum's avatar
bguillaum committed
107 108 109
    (map, table, [](* List.map (build_filter table) constraints *))


110

111
  (* a type for extension of graph: a former graph exists:
112
     in grew the former is a positive pattern and an extension is a "without" *)
113 114 115
  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
116
    }
117

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

120
    let built_nodes = List.map P_node.build full_node_list in
pj2m's avatar
pj2m committed
121

122 123
    let (old_nodes, new_nodes) =
      List.partition
124 125
        (function (id,_) when Array_.dicho_mem id old_table -> true | _ -> false)
        built_nodes in
pj2m's avatar
pj2m committed
126 127 128 129 130 131 132
	
    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
133 134 135 136

    (* the nodes, in the same order stored with index -1, -2, ... -N *)
    let ext_map_without_edges =
      List_.foldi_left
bguillaum's avatar
bguillaum committed
137
	(fun i acc elt -> Pid_map.add (Pid.Neg i) elt acc)
138
	Pid_map.empty
pj2m's avatar
pj2m committed
139
	new_node_list in
140 141 142

    let old_map_without_edges =
      List.fold_left
bguillaum's avatar
bguillaum committed
143
	(fun acc (id,node) -> Pid_map.add (Pid.Pos (Array_.dicho_find id old_table)) node acc)
144
	Pid_map.empty
pj2m's avatar
pj2m committed
145 146
	old_nodes in

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

pj2m's avatar
pj2m committed
164 165 166 167 168
    ({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)

  (* ---------------------------------------------------------------------------------------------------- *)
  (* Topology functions *)
  (* ---------------------------------------------------------------------------------------------------- *)
169

pj2m's avatar
pj2m committed
170 171 172 173 174 175
  (* [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 =
176 177
      Pid_map.fold
	(fun _ node acc ->
bguillaum's avatar
bguillaum committed
178
	  Massoc_pid.fold
pj2m's avatar
pj2m committed
179 180
	    (fun acc2 tar _ ->
	      if !tree_prop
181
	      then
bguillaum's avatar
bguillaum committed
182
		if Pid_set.mem tar acc2
pj2m's avatar
pj2m committed
183
		then (tree_prop := false; acc2)
bguillaum's avatar
bguillaum committed
184 185
		else Pid_set.add tar acc2
	      else Pid_set.add tar acc2
186
	    ) acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
187
	) graph Pid_set.empty in
pj2m's avatar
pj2m committed
188 189

    let roots =
190 191
      Pid_map.fold
	(fun id _ acc ->
bguillaum's avatar
bguillaum committed
192
	  if Pid_set.mem id not_root
193
	  then acc
pj2m's avatar
pj2m committed
194
	  else id::acc
195
	) graph [] in
196

pj2m's avatar
pj2m committed
197 198 199
    (!tree_prop, roots)

  let roots graph = snd (tree_and_roots graph)
200 201
end (* module P_graph *)
(* ================================================================================ *)
pj2m's avatar
pj2m committed
202

203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220


(* ================================================================================ *)
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 =
221
    let node_src =
222 223 224 225 226 227
      (* 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)

228
  let build ?(locals=[||]) full_node_list full_edge_list =
229

230
    let named_nodes =
231
      let rec loop already_bound = function
bguillaum's avatar
bguillaum committed
232
        | [] -> []
233
        | (ast_node, loc) :: tail ->
bguillaum's avatar
bguillaum committed
234
            let tail = loop (ast_node.Ast.node_id :: already_bound) tail in
235
            if List.mem ast_node.Ast.node_id already_bound
236
            then Error.build "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" ast_node.Ast.node_id
237
            else G_node.build (ast_node, loc) :: tail in
238 239 240 241 242 243 244
      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
245 246 247 248

    (* the nodes, in the same order *)
    let map_without_edges = List_.foldi_left (fun i acc elt -> Gid_map.add (Gid.Old i) elt acc) Gid_map.empty node_list in

249 250 251 252 253 254
    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
255
	  (match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
256
	  | Some g -> g
257
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
258 259 260 261
                (G_edge.to_string edge)
                (Loc.to_string loc)
	  )
	) map_without_edges full_edge_list in
262

263 264 265
    {map=map;lub=Array.length table}


bguillaum's avatar
bguillaum committed
266
  let of_conll ?loc lines =
267 268

    let nodes =
bguillaum's avatar
bguillaum committed
269
      List.fold_left
270 271
        (fun acc line ->
          Gid_map.add (Gid.Old line.Conll.num) (G_node.of_conll line) acc)
bguillaum's avatar
bguillaum committed
272
        Gid_map.empty lines in
273 274

    let nodes_with_edges =
bguillaum's avatar
bguillaum committed
275 276
      List.fold_left
        (fun acc line ->
bguillaum's avatar
bguillaum committed
277 278
          (* add line number information in loc *)
          let loc = Loc.opt_set_line line.Conll.line_num loc in
279

bguillaum's avatar
bguillaum committed
280 281
          if line.Conll.gov=0
          then acc
282 283 284 285
          else
            let gov_node =
              try Gid_map.find (Gid.Old line.Conll.gov) acc
              with Not_found ->
bguillaum's avatar
bguillaum committed
286
                Error.build ?loc "[G_graph.of_conll] the line refers to unknown gov %d" line.Conll.gov in
287
            match G_node.add_edge (G_edge.make ?loc line.Conll.dep_lab) (Gid.Old line.Conll.num) gov_node with
bguillaum's avatar
bguillaum committed
288
            | None -> acc
289
            | Some new_node -> Gid_map.add (Gid.Old line.Conll.gov) new_node acc
bguillaum's avatar
bguillaum committed
290
        ) nodes lines in
291

bguillaum's avatar
bguillaum committed
292 293 294
        {map = nodes_with_edges; lub=1+(Gid_map.fold (fun _ _ acc -> acc+1) nodes_with_edges 0)}


295
  (* ---------------------------------------------------- *)
pj2m's avatar
pj2m committed
296
  (* Update functions *)
297 298 299 300 301 302 303
  (* ---------------------------------------------------- *)



  (* [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
304
   *)	
305 306 307 308 309
  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
310 311 312

  (* remove (id_src -[label]-> id_tar) from graph.
     Log.critical if the edge is not in graph *)
313 314 315 316
  let del_edge ?edge_ident loc graph id_src label id_tar =
    let node_src =
      try Gid_map.find id_src graph.map
      with Not_found ->
317 318 319
        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
320 321

    try {graph with map =
322 323
	 (* 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
324
       }
325
    with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
pj2m's avatar
pj2m committed
326

327
  (* remove node i from graph, with all its incoming and outcoming edges *)
pj2m's avatar
pj2m committed
328
  (* [graph] is unchanged if the node is not in it *)
329 330 331
  let del_node graph node_id =
    let new_map =
      Gid_map.fold
pj2m's avatar
pj2m committed
332
	(fun id value acc ->
333
	  if id = node_id
pj2m's avatar
pj2m committed
334
	  then acc
335 336 337
	  (* 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
338 339
    {graph with map = new_map}

340
  let add_neighbour loc graph node_id label =
pj2m's avatar
pj2m committed
341 342

    (* index is a new number (higher then lub and uniquely defined by (node_id,label) *)
343 344 345 346 347
    (* let index = graph.lub + ((Label.to_int label) * graph.lub) + node_id in *)

    let index = match node_id with
      | Gid.Old id -> Gid.New (id, Label.to_int label)
      | Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
pj2m's avatar
pj2m committed
348

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

352
    let node = Gid_map.find node_id graph.map in
pj2m's avatar
pj2m committed
353
    (* put the new node on the right of its "parent" *)
354
    let new_graph = {graph with map = Gid_map.add index (G_node.build_neighbour node) graph.map} in
355
    match add_edge new_graph node_id label index with
pj2m's avatar
pj2m committed
356 357 358 359 360
    | Some g -> (index, g)
    | None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1



361
  (* move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
362
  let shift_in loc graph src_gid tar_gid =
363
    let tar_node = Gid_map.find tar_gid graph.map in
364 365

    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
366 367
    then Error.run ~loc "[Graph.shift_in] dependency from tar to src";

368
    let new_map =
369
      Gid_map.mapi
370
	(fun node_id node ->
371
          match G_node.merge_key src_gid tar_gid node with
372
          | Some new_node -> new_node
bguillaum's avatar
bguillaum committed
373
          | None -> Error.run ~loc "[Graph.shift_in] create duplicate edge"
374 375 376
	) graph.map

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

378
  (* move all out-edges from id_src are moved to out-edges out off node id_tar *)
379
  let shift_out loc graph src_gid tar_gid =
380 381
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
382 383

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
bguillaum's avatar
bguillaum committed
384
    then Error.run ~loc "[Graph.shift_out] dependency from src to tar";
385

386
    let new_map =
387
      Gid_map.mapi
388
	(fun node_id node ->
389 390
	  if node_id = src_gid
	  then (* [src_id] becomes without out-edges *)
391
            G_node.rm_out_edges node
392
	  else if node_id = tar_gid
393
	  then
394 395
            match G_node.shift_out src_node tar_node with
            | Some n -> n
bguillaum's avatar
bguillaum committed
396
            | None -> Error.run ~loc "[Graph.shift_out] common successor"
397 398 399 400
	  else node (* other nodes don't change *)
	) graph.map
    in {graph with map = new_map}

401
  (* 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
402
  let shift_edges loc graph src_gid tar_gid =
403 404
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
405 406

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
pj2m's avatar
pj2m committed
407 408
    then Error.run ~loc "[Graph.shift_edges] dependency from src to tar";

409
    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
pj2m's avatar
pj2m committed
410 411
    then Error.run ~loc "[Graph.shift_edges] dependency from tar to src";

412
    let new_map =
413
      Gid_map.mapi
pj2m's avatar
pj2m committed
414
	(fun node_id node ->
415 416
	  if node_id = src_gid
	  then (* [src_id] becomes an isolated node *)
417
            G_node.rm_out_edges node
418
	  else if node_id = tar_gid
pj2m's avatar
pj2m committed
419
	  then
420 421 422 423 424 425 426
            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
427 428 429 430 431 432 433
	) 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

434 435
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
436

437
    match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
438
    | Some new_fs ->
pj2m's avatar
pj2m committed
439
	let new_map =
440
	  Gid_map.add
441
	    tar_gid
442 443
            (G_node.set_fs tar_node new_fs)
	    (Gid_map.remove src_gid se_graph.map) in
pj2m's avatar
pj2m committed
444
	Some {se_graph with map = new_map}
445
    | None -> None
bguillaum's avatar
bguillaum committed
446

447
  let set_feat ?loc graph node_id feat_name new_value =
bguillaum's avatar
bguillaum committed
448
    let node = Gid_map.find node_id graph.map in
449
    let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
bguillaum's avatar
bguillaum committed
450 451
    {graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map}

452
  let update_feat ?loc graph tar_id tar_feat_name item_list =
453 454 455 456
    let strings_to_concat =
      List.map
        (function
          | Feat (node_gid, feat_name) ->
457
              let node = Gid_map.find node_gid graph.map in
bguillaum's avatar
bguillaum committed
458 459 460 461
              (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
              )
462 463 464
          | String s -> s
        ) item_list in
    let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
465
    (set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
bguillaum's avatar
bguillaum committed
466 467


468

pj2m's avatar
pj2m committed
469 470
      (** [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. *)
471
  let del_feat graph node_id feat_name =
472
    let node =  Gid_map.find node_id graph.map in
473
    let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
474 475 476 477
    {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
478

479 480 481 482 483
    bprintf buff "graph {\n";

    (* list of the nodes *)
    Gid_map.iter
      (fun id node ->
484
        bprintf buff "N_%s %s;\n" (Gid.to_string id) (G_node.to_gr node)
485 486 487 488
      ) graph.map;
    (* list of the edges *)
    Gid_map.iter
      (fun id node ->
489 490 491
	Massoc_gid.iter
	  (fun tar edge ->
	    bprintf buff "N_%s -[%s]-> N_%s;\n" (Gid.to_string id) (G_edge.to_string edge) (Gid.to_string tar)
492 493
	  ) (G_node.get_next node)
      ) graph.map;
494

495 496 497
    bprintf buff "}\n";
    Buffer.contents buff

498 499 500 501 502 503 504 505 506 507 508 509 510
  let to_sentence ?main_feat graph =
    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

    let words = List.map
      (fun (id, node) -> G_fs.to_word ?main_feat (G_node.get_fs node)
      ) snodes in
    List.fold_left
      (fun acc (regexp,repl) ->
        Str.global_replace (Str.regexp_string regexp) repl acc
      )
      (String.concat " " words)
      [
bguillaum's avatar
bguillaum committed
511 512
        " -t-", "-t-";
        "_-_", "-";
513 514
        "_", " ";
        "' ", "'";
515 516
        " ,", ",";
        " .", ".";
517 518 519 520
        "( ", "(";
        " )", ")";
        "\\\"", "\"";
      ]
521 522

  let to_dep ?main_feat ?(deco=G_deco.empty) graph =
523 524 525 526 527 528 529 530 531
    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
532 533 534 535 536 537
      (fun (id, node) ->
	if List.mem id deco.G_deco.nodes
	then bprintf buff
            "N_%s { %sforecolor=red; subcolor=red; }\n" (Gid.to_string id) (G_fs.to_dep ?main_feat (G_node.get_fs node))
	else bprintf buff
            "N_%s { %s }\n" (Gid.to_string id) (G_fs.to_dep ?main_feat (G_node.get_fs node))
538 539
      ) snodes;
    bprintf buff "} \n";
540

541
    bprintf buff "[EDGES] { \n";
542
    Gid_map.iter
543
      (fun gid elt ->
544 545 546 547
	Massoc_gid.iter
	  (fun tar g_edge ->
	    let deco = List.mem (gid,g_edge,tar) deco.G_deco.edges in
	    bprintf buff "N_%s -> N_%s %s\n" (Gid.to_string gid) (Gid.to_string tar) (G_edge.to_dep ~deco g_edge)
548 549 550 551 552
	  ) (G_node.get_next elt)
      ) graph.map;
      bprintf buff "} \n";
    Buffer.contents buff

553
  let to_dot ?main_feat ?(deco=G_deco.empty) graph =
554
    let buff = Buffer.create 32 in
555

556
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
557
    (* bprintf buff "  rankdir=LR;\n"; *)
558 559 560 561 562
    bprintf buff "  node [shape=Mrecord];\n";

    (* list of the nodes *)
    Gid_map.iter
      (fun id node ->
563 564 565 566
	bprintf buff "  N_%s [label=\"%s\", color=%s]\n"
	  (Gid.to_string id)
          (G_fs.to_dot ?main_feat (G_node.get_fs node))
          (if List.mem id deco.G_deco.nodes then "red" else "black")
567 568 569 570
      ) graph.map;
    (* list of the edges *)
    Gid_map.iter
      (fun id node ->
571 572 573 574
	Massoc_gid.iter
	  (fun tar g_edge ->
	    let deco = List.mem (id,g_edge,tar) deco.G_deco.edges in
	    bprintf buff "  N_%s -> N_%s%s\n" (Gid.to_string id) (Gid.to_string tar) (G_edge.to_dot ~deco g_edge)
575 576
	  ) (G_node.get_next node)
      ) graph.map;
577

578 579
    bprintf buff "}\n";
    Buffer.contents buff
pj2m's avatar
pj2m committed
580

581
  let equals t t' = Gid_map.equal (fun node1 node2 -> node1 = node2) t.map t'.map
pj2m's avatar
pj2m committed
582 583

  (* is there an edge e out of node i ? *)
584
  let edge_out graph node_id p_edge =
585
    let node = Gid_map.find node_id graph.map in
586
    Massoc_gid.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
pj2m's avatar
pj2m committed
587

588 589
end (* module G_graph *)
(* ================================================================================ *)