grew_graph.ml 23.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
(* ==================================================================================================== *)
13
module P_deco = struct
bguillaum's avatar
bguillaum committed
14 15 16 17
  type t = {
    nodes: Pid.t list;
    edges: (Pid.t * P_edge.t * Pid.t) list;
  }
pj2m's avatar
pj2m committed
18 19

  let empty = {nodes=[]; edges=[]}
bguillaum's avatar
bguillaum committed
20
end (* module P_deco *)
pj2m's avatar
pj2m committed
21

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

26 27
  let empty = Pid_map.empty
  let find = Pid_map.find
pj2m's avatar
pj2m committed
28 29

  let map_add_edge map id_src label id_tar =
30
    let node_src =
pj2m's avatar
pj2m committed
31
      (* Not found can be raised when adding an edge from pos to neg *)
32 33
      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
34
    | None -> None
35
    | Some new_node -> Some (Pid_map.add id_src new_node map)
pj2m's avatar
pj2m committed
36

bguillaum's avatar
bguillaum committed
37 38 39 40 41
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Build functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

  (* -------------------------------------------------------------------------------- *)
42
  let build_filter table (ast_node, loc) =
43
    let pid = Id.build ~loc ast_node.Ast.node_id table in
44
    let fs = P_fs.build ast_node.Ast.fs in
45 46
    (pid, fs)

bguillaum's avatar
bguillaum committed
47
  (* -------------------------------------------------------------------------------- *)
48
  let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
bguillaum's avatar
bguillaum committed
49

50
    (* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
51
    (* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *)
bguillaum's avatar
bguillaum committed
52 53
    let rec insert (ast_node, loc) = function
      | [] -> [P_node.build ?pat_vars (ast_node, loc)]
54 55 56
      | (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
          (node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
      | head :: tail -> head :: (insert (ast_node, loc) tail) in
bguillaum's avatar
bguillaum committed
57

58
    let (named_nodes : (Id.name * P_node.t) list) =
59
      List.fold_left
60 61
        (fun acc ast_node -> insert ast_node acc)
        [] full_node_list in
62

pj2m's avatar
pj2m committed
63 64 65
    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

66 67
    (* [pos_table] contains the sorted list of node ids *)
    let pos_table = Array.of_list sorted_ids in
68 69

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

bguillaum's avatar
bguillaum committed
74
    let (map : t) =
pj2m's avatar
pj2m committed
75 76
      List.fold_left
	(fun acc (ast_edge, loc) ->
77 78
	  let i1 = Id.build ~loc ast_edge.Ast.src pos_table in
	  let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in
79
	  let edge = P_edge.build ~locals (ast_edge, loc) in
bguillaum's avatar
bguillaum committed
80
	  (match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
pj2m's avatar
pj2m committed
81
	  | Some g -> g
82
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
83
                (P_edge.to_string edge)
bguillaum's avatar
bguillaum committed
84
                (Loc.to_string loc)
pj2m's avatar
pj2m committed
85 86
	  )
	) map_without_edges full_edge_list in
87
    (map, pos_table)
bguillaum's avatar
bguillaum committed
88

89

bguillaum's avatar
bguillaum committed
90
  (* -------------------------------------------------------------------------------- *)
91
  (* a type for extension of graph: a former graph exists:
92
     in grew the former is a positive pattern and an extension is a "without" *)
93 94 95
  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
96
    }
97

bguillaum's avatar
bguillaum committed
98
  (* -------------------------------------------------------------------------------- *)
99
  let build_extension ?(locals=[||]) pos_table full_node_list full_edge_list =
pj2m's avatar
pj2m committed
100

101
    let built_nodes = List.map P_node.build full_node_list in
pj2m's avatar
pj2m committed
102

103 104
    let (old_nodes, new_nodes) =
      List.partition
105
        (function (id,_) when Array_.dicho_mem id pos_table -> true | _ -> false)
106
        built_nodes in
pj2m's avatar
pj2m committed
107 108 109 110 111 112 113
	
    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
114 115 116 117

    (* 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
118
	(fun i acc elt -> Pid_map.add (Pid.Neg i) elt acc)
119
	Pid_map.empty
pj2m's avatar
pj2m committed
120
	new_node_list in
121 122 123

    let old_map_without_edges =
      List.fold_left
124
	(fun acc (id,node) -> Pid_map.add (Pid.Pos (Array_.dicho_find id pos_table)) node acc)
125
	Pid_map.empty
pj2m's avatar
pj2m committed
126 127
	old_nodes in

128
    let ext_map_with_all_edges =
pj2m's avatar
pj2m committed
129 130
      List.fold_left
	(fun acc (ast_edge, loc) ->
131
	  let i1 =
132
	    match Id.build_opt ast_edge.Ast.src pos_table with
bguillaum's avatar
bguillaum committed
133 134
              | Some i -> Pid.Pos i
              | None -> Pid.Neg (Id.build ~loc ast_edge.Ast.src new_table) in
135
	  let i2 =
136
	    match Id.build_opt ast_edge.Ast.tar pos_table with
bguillaum's avatar
bguillaum committed
137
              | Some i -> Pid.Pos i
bguillaum's avatar
bguillaum committed
138
              | None -> Pid.Neg (Id.build ~loc ast_edge.Ast.tar new_table) in
139
	  let edge = P_edge.build ~locals (ast_edge, loc) in
pj2m's avatar
pj2m committed
140 141
	  match map_add_edge acc i1 edge i2 with
	  | Some map -> map
142
	  | None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
pj2m's avatar
pj2m committed
143
	) ext_map_without_edges full_edge_list in
144

pj2m's avatar
pj2m committed
145 146 147 148 149 150 151 152
    ({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)

  (* [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 =
153 154
      Pid_map.fold
	(fun _ node acc ->
bguillaum's avatar
bguillaum committed
155
	  Massoc_pid.fold
pj2m's avatar
pj2m committed
156 157
	    (fun acc2 tar _ ->
	      if !tree_prop
158
	      then
bguillaum's avatar
bguillaum committed
159
		if Pid_set.mem tar acc2
pj2m's avatar
pj2m committed
160
		then (tree_prop := false; acc2)
bguillaum's avatar
bguillaum committed
161 162
		else Pid_set.add tar acc2
	      else Pid_set.add tar acc2
163
	    ) acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
164
	) graph Pid_set.empty in
pj2m's avatar
pj2m committed
165 166

    let roots =
167 168
      Pid_map.fold
	(fun id _ acc ->
bguillaum's avatar
bguillaum committed
169
	  if Pid_set.mem id not_root
170
	  then acc
pj2m's avatar
pj2m committed
171
	  else id::acc
172
	) graph [] in
173

pj2m's avatar
pj2m committed
174 175 176
    (!tree_prop, roots)

  let roots graph = snd (tree_and_roots graph)
177
end (* module P_graph *)
pj2m's avatar
pj2m committed
178

179 180 181 182 183 184 185 186 187
(* ==================================================================================================== *)
module G_deco = struct
  type t = {
    nodes: Gid.t list;
    edges: (Gid.t * G_edge.t * Gid.t) list;
  }

  let empty = {nodes=[]; edges=[]}
end (* module G_deco *)
188

bguillaum's avatar
bguillaum committed
189 190 191 192 193 194
(* ==================================================================================================== *)
module Concat_item = struct
  type t =
    | Feat of (Gid.t * string)
    | String of string
end (* module Concat_item *)
195

bguillaum's avatar
bguillaum committed
196
(* ==================================================================================================== *)
197
module G_graph = struct
198 199 200 201 202 203 204 205 206 207
  type t = {
    meta: (string * string) list;
    map: G_node.t Gid_map.t; (* node description *)
  }

  let empty = {meta=[]; map=Gid_map.empty}

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

  let equals t t' = Gid_map.equal (fun node1 node2 -> node1 = node2) t.map t'.map
208

209 210 211 212 213 214 215 216
(* Ocaml < 3.12 doesn't have exists function for maps! *)
  exception True
  let node_exists fct t =
    try
      Gid_map.iter (fun _ v -> if fct v then raise True) t.map;
      false
    with True -> true
(* Ocaml < 3.12 doesn't have exists function for maps! *)
217

218 219
  let fold_gid fct t init =
    Gid_map.fold (fun gid _ acc -> fct gid acc) t.map init
220

221 222 223 224
  let max_binding t =
    match Gid_map.max_binding t.map with
      | (Gid.Old i,_) -> i
      | _ -> Error.bug "[G_graph.max_binding]"
bguillaum's avatar
bguillaum committed
225

bguillaum's avatar
bguillaum committed
226 227 228 229 230 231 232
  let list_search test =
    let rec loop n = function
      | [] -> raise Not_found
      | x::_ when test x -> n
      | _::t -> loop (n+1) t
    in loop 0

bguillaum's avatar
bguillaum committed
233 234
  (* is there an edge e out of node i ? *)
  let edge_out graph node_id p_edge =
235
    let node = Gid_map.find node_id graph.map in
bguillaum's avatar
bguillaum committed
236
    Massoc_gid.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
237

bguillaum's avatar
bguillaum committed
238
  (* -------------------------------------------------------------------------------- *)
239
  let map_add_edge map id_src label id_tar =
240
    let node_src =
241
      (* Not found can be raised when adding an edge from pos to neg *)
242
      try Gid_map.find id_src map with Not_found -> G_node.empty in
243 244
    match G_node.add_edge label id_tar node_src with
    | None -> None
245 246 247 248 249 250
    | Some new_node -> Some (Gid_map.add id_src new_node map)

  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
251

bguillaum's avatar
bguillaum committed
252 253 254 255
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Build functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

256 257 258
  let build ?(locals=[||]) gr_ast =
    let full_node_list = gr_ast.Ast.nodes
    and full_edge_list = gr_ast.Ast.edges in
259

260
    let named_nodes =
261
      let rec loop already_bound = function
bguillaum's avatar
bguillaum committed
262
        | [] -> []
263
        | (ast_node, loc) :: tail ->
bguillaum's avatar
bguillaum committed
264
            let tail = loop (ast_node.Ast.node_id :: already_bound) tail in
265
            if List.mem ast_node.Ast.node_id already_bound
266
            then Error.build "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" ast_node.Ast.node_id
267
            else G_node.build (ast_node, loc) :: tail in
268 269 270 271 272 273 274
      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
275 276 277 278

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

279 280 281 282 283 284
    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
285
	  (match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
286
	  | Some g -> g
287
	  | None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
288 289 290 291
                (G_edge.to_string edge)
                (Loc.to_string loc)
	  )
	) map_without_edges full_edge_list in
292

293
    {meta=gr_ast.Ast.meta; map=map}
294

bguillaum's avatar
bguillaum committed
295
  (* -------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
296
  let of_conll ?loc lines =
297 298

    let nodes =
bguillaum's avatar
bguillaum committed
299
      List.fold_left
300
        (fun acc line ->
bguillaum's avatar
bguillaum committed
301 302
          Gid_map.add (Gid.Old line.Conll.num) (G_node.of_conll line) acc
        ) Gid_map.empty lines in
303 304

    let nodes_with_edges =
bguillaum's avatar
bguillaum committed
305 306
      List.fold_left
        (fun acc line ->
bguillaum's avatar
bguillaum committed
307 308
          (* add line number information in loc *)
          let loc = Loc.opt_set_line line.Conll.line_num loc in
309

bguillaum's avatar
bguillaum committed
310 311
          if line.Conll.gov=0
          then acc
312 313 314 315
          else
            let gov_node =
              try Gid_map.find (Gid.Old line.Conll.gov) acc
              with Not_found ->
bguillaum's avatar
bguillaum committed
316
                Error.build ?loc "[G_graph.of_conll] the line refers to unknown gov %d" line.Conll.gov in
317
            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
318
            | None -> acc
319
            | Some new_node -> Gid_map.add (Gid.Old line.Conll.gov) new_node acc
bguillaum's avatar
bguillaum committed
320
        ) nodes lines in
321

322
    {meta=[]; map=nodes_with_edges}
bguillaum's avatar
bguillaum committed
323

bguillaum's avatar
bguillaum committed
324
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
pj2m's avatar
pj2m committed
325
  (* Update functions *)
bguillaum's avatar
bguillaum committed
326
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
327

bguillaum's avatar
bguillaum committed
328
  (* -------------------------------------------------------------------------------- *)
329
  let rename mapping graph =
330 331 332 333 334 335 336 337
    {graph with map = 
        Gid_map.fold
          (fun id node acc ->
            let new_id = try List.assoc id mapping with Not_found -> id in
            let new_node = G_node.rename mapping node in
            Gid_map.add new_id new_node acc
          ) graph.map Gid_map.empty
    }
338

bguillaum's avatar
bguillaum committed
339
  (* -------------------------------------------------------------------------------- *)
340 341
  let del_edge ?edge_ident loc graph id_src label id_tar =
    let node_src =
342
      try Gid_map.find id_src graph.map
343
      with Not_found ->
344 345 346
        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
347
    try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map}
348
    with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
pj2m's avatar
pj2m committed
349

bguillaum's avatar
bguillaum committed
350
  (* -------------------------------------------------------------------------------- *)
351
  let del_node graph node_id =
352 353 354 355 356 357 358 359
    {graph with map = 
        Gid_map.fold
          (fun id value acc ->
	    if id = node_id
	    then acc
	    else Gid_map.add id (G_node.remove_key node_id value) acc
          ) graph.map Gid_map.empty
    }
pj2m's avatar
pj2m committed
360

bguillaum's avatar
bguillaum committed
361
  (* -------------------------------------------------------------------------------- *)
362 363
  let add_neighbour loc graph node_id label =
    let index = match node_id with
bguillaum's avatar
bguillaum committed
364
      | Gid.Old id ->
bguillaum's avatar
bguillaum committed
365 366 367 368
        (match Label.to_int label with
          | Some label_int -> Gid.New (id, label_int)
          | None -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour with a local label"
        )
369
      | Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
pj2m's avatar
pj2m committed
370

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

374
    let node = Gid_map.find node_id graph.map in
pj2m's avatar
pj2m committed
375
    (* put the new node on the right of its "parent" *)
376
    let new_map = Gid_map.add index (G_node.build_neighbour node) graph.map in
bguillaum's avatar
bguillaum committed
377

378
    match map_add_edge new_map node_id label index with
bguillaum's avatar
bguillaum committed
379
    | Some g -> (index, {graph with map = g})
pj2m's avatar
pj2m committed
380 381
    | None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1

bguillaum's avatar
bguillaum committed
382
  (* -------------------------------------------------------------------------------- *)
383
  let shift_in loc graph src_gid tar_gid =
384
    let tar_node = Gid_map.find tar_gid graph.map in
385 386

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

389 390 391 392 393 394 395 396
    { graph with map =
        Gid_map.mapi
          (fun node_id node ->
            match G_node.merge_key src_gid tar_gid node with
              | Some new_node -> new_node
              | None -> Error.run ~loc "[Graph.shift_in] create duplicate edge"
          ) graph.map
    }
pj2m's avatar
pj2m committed
397

bguillaum's avatar
bguillaum committed
398
  (* -------------------------------------------------------------------------------- *)
399
  (* move all out-edges from id_src are moved to out-edges out off node id_tar *)
400
  let shift_out loc graph src_gid tar_gid =
401 402
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
403 404

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

407 408 409 410 411 412 413 414 415 416 417 418 419 420
    {graph with map =
        Gid_map.mapi
          (fun node_id node ->
	    if node_id = src_gid
	    then (* [src_id] becomes without out-edges *)
              G_node.rm_out_edges node
	    else if node_id = tar_gid
	    then
              match G_node.shift_out src_node tar_node with
                | Some n -> n
                | None -> Error.run ~loc "[Graph.shift_out] common successor"
	    else node (* other nodes don't change *)
          ) graph.map
    }
421

bguillaum's avatar
bguillaum committed
422
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
423
  let shift_edges loc graph src_gid tar_gid =
424 425
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
426 427

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
428 429
    then Error.run ~loc "[Graph.shift_edges] dependency from src (gid=%s) to tar (gid=%s)"
      (Gid.to_string src_gid) (Gid.to_string tar_gid);
pj2m's avatar
pj2m committed
430

431
    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
432 433
    then Error.run ~loc "[Graph.shift_edges] dependency from tar (gid=%s) to src (gid=%s)"
      (Gid.to_string tar_gid) (Gid.to_string src_gid);
pj2m's avatar
pj2m committed
434

435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451
    let new_map =
      Gid_map.mapi
        (fun node_id node ->
	  if node_id = src_gid
	  then (* [src_id] becomes an isolated node *)
            G_node.rm_out_edges node
	  else if node_id = tar_gid
	  then
            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"
        ) graph.map in
    { graph with map = new_map }
pj2m's avatar
pj2m committed
452

bguillaum's avatar
bguillaum committed
453
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
454 455 456
  let merge_node loc graph src_gid tar_gid =
    let se_graph = shift_edges loc graph src_gid tar_gid in

457 458
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
459

460
    match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
461
    | Some new_fs ->
462 463 464 465 466 467 468
      Some {graph with map =
          (Gid_map.add
	     tar_gid
             (G_node.set_fs tar_node new_fs)
	     (Gid_map.remove src_gid se_graph.map)
          )
           }
469
    | None -> None
bguillaum's avatar
bguillaum committed
470

bguillaum's avatar
bguillaum committed
471
  (* -------------------------------------------------------------------------------- *)
472
  let set_feat ?loc graph node_id feat_name new_value =
473
    let node = Gid_map.find node_id graph.map in
474
    let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
475
    { graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
bguillaum's avatar
bguillaum committed
476

bguillaum's avatar
bguillaum committed
477
  (* -------------------------------------------------------------------------------- *)
478
  let update_feat ?loc graph tar_id tar_feat_name item_list =
479 480 481
    let strings_to_concat =
      List.map
        (function
bguillaum's avatar
bguillaum committed
482
          | Concat_item.Feat (node_gid, feat_name) ->
483
              let node = Gid_map.find node_gid graph.map in
bguillaum's avatar
bguillaum committed
484
              (match G_fs.get_string_atom feat_name (G_node.get_fs node) with
bguillaum's avatar
bguillaum committed
485 486 487
              | Some atom -> atom
              | None -> Error.run ?loc "Some feature (named \"%s\") is not defined" feat_name
              )
bguillaum's avatar
bguillaum committed
488
          | Concat_item.String s -> s
489 490
        ) item_list in
    let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
491
    (set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
bguillaum's avatar
bguillaum committed
492 493


bguillaum's avatar
bguillaum committed
494
  (* -------------------------------------------------------------------------------- *)
495
  let del_feat graph node_id feat_name =
496
    let node = Gid_map.find node_id graph.map in
497
    let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
498
    { graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
499

bguillaum's avatar
bguillaum committed
500 501 502 503 504
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Output functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

  (* -------------------------------------------------------------------------------- *)
505 506
  let to_gr graph =
    let buff = Buffer.create 32 in
507

508 509
    bprintf buff "graph {\n";

510 511 512 513 514 515
    (* meta data *)
    List.iter
      (fun (name, value) ->
        bprintf buff "  %s = \"%s\";\n" name value
      ) graph.meta;

bguillaum's avatar
bguillaum committed
516
    (* nodes *)
517 518 519 520
    let nodes = Gid_map.fold (fun id node acc -> (id,node)::acc) graph.map [] in
    let sorted_nodes = List.sort (fun (_,n1) (_,n2) -> G_node.pos_comp n1 n2) nodes in
    List.iter
      (fun (id,node) ->
521
        bprintf buff "  N_%s %s;\n" (Gid.to_string id) (G_node.to_gr node)
522
      ) sorted_nodes;
523

bguillaum's avatar
bguillaum committed
524
    (* edges *)
525 526
    Gid_map.iter
      (fun id node ->
527 528
	Massoc_gid.iter
	  (fun tar edge ->
529
	    bprintf buff "  N_%s -[%s]-> N_%s;\n" (Gid.to_string id) (G_edge.to_string edge) (Gid.to_string tar)
530
	  ) (G_node.get_next node)
531
      ) graph.map;
532

533 534 535
    bprintf buff "}\n";
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
536
  (* -------------------------------------------------------------------------------- *)
537
  let to_sentence ?main_feat graph =
538
    let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
539 540 541 542 543 544 545 546 547 548 549
    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
550 551
        " -t-", "-t-";
        "_-_", "-";
552 553
        "_", " ";
        "' ", "'";
554 555
        " ,", ",";
        " .", ".";
556 557 558 559
        "( ", "(";
        " )", ")";
        "\\\"", "\"";
      ]
560

bguillaum's avatar
bguillaum committed
561
  (* -------------------------------------------------------------------------------- *)
562
  let to_dep ?main_feat ?(deco=G_deco.empty) graph =
563 564 565 566 567
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";

    bprintf buff "[WORDS] { \n";

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

bguillaum's avatar
bguillaum committed
571
    (* nodes *)
572
    List.iter
573 574 575 576 577 578
      (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))
579 580
      ) snodes;
    bprintf buff "} \n";
581

bguillaum's avatar
bguillaum committed
582
    (* edges *)
583
    bprintf buff "[EDGES] { \n";
584
    Gid_map.iter
585
      (fun gid elt ->
586 587 588 589
	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)
590
	  ) (G_node.get_next elt)
591
      ) graph.map;
bguillaum's avatar
bguillaum committed
592 593

    bprintf buff "} \n";
594 595
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
596
  (* -------------------------------------------------------------------------------- *)
597
  let to_dot ?main_feat ?(deco=G_deco.empty) graph =
598
    let buff = Buffer.create 32 in
599

600
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
601
    (* bprintf buff "  rankdir=LR;\n"; *)
602 603
    bprintf buff "  node [shape=Mrecord];\n";

bguillaum's avatar
bguillaum committed
604
    (* nodes *)
605 606
    Gid_map.iter
      (fun id node ->
607 608 609 610
	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")
611
      ) graph.map;
bguillaum's avatar
bguillaum committed
612 613

    (* edges *)
614 615
    Gid_map.iter
      (fun id node ->
616 617 618 619
	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)
620
	  ) (G_node.get_next node)
621
      ) graph.map;
622

623 624
    bprintf buff "}\n";
    Buffer.contents buff
625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645

  (* -------------------------------------------------------------------------------- *)
  let to_raw 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 raw_nodes = List.map (fun (pid,node) -> (pid, G_fs.to_raw (G_node.get_fs node))) snodes in

    let search pid = list_search (fun (x,_) -> x=pid) raw_nodes in
    let edge_list = ref [] in
    Gid_map.iter
      (fun src_pid node ->
        Massoc_gid.iter
          (fun tar_pid edge ->
            edge_list := (search src_pid, G_edge.to_string edge, search tar_pid) :: !edge_list
          )
          (G_node.get_next node)
      )
      graph.map;
    (graph.meta, List.map snd raw_nodes, !edge_list)

646 647
end (* module G_graph *)
(* ================================================================================ *)