grew_graph.ml 25.3 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
  let list_num test =
bguillaum's avatar
bguillaum committed
227 228 229 230 231 232
    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

310 311 312 313 314 315 316 317 318 319 320 321 322
          List.fold_left
            (fun acc2 (gov, dep_lab) ->
              if gov=0
              then acc
              else
                let gov_node =
                  try Gid_map.find (Gid.Old gov) acc
                  with Not_found ->
                    Error.build ?loc "[G_graph.of_conll] the line refers to unknown gov %d" gov in
                match G_node.add_edge (G_edge.make ?loc dep_lab) (Gid.Old line.Conll.num) gov_node with
                  | None -> acc
                  | Some new_node -> Gid_map.add (Gid.Old gov) new_node acc2
            ) acc line.Conll.deps
bguillaum's avatar
bguillaum committed
323
        ) nodes lines in
324

325
    {meta=[]; map=nodes_with_edges}
bguillaum's avatar
bguillaum committed
326

bguillaum's avatar
bguillaum committed
327
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
pj2m's avatar
pj2m committed
328
  (* Update functions *)
bguillaum's avatar
bguillaum committed
329
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
330

bguillaum's avatar
bguillaum committed
331
  (* -------------------------------------------------------------------------------- *)
332
  let rename mapping graph =
333 334 335 336 337 338 339 340
    {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
    }
341

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

bguillaum's avatar
bguillaum committed
353
  (* -------------------------------------------------------------------------------- *)
354
  let del_node graph node_id =
355 356 357 358 359 360 361 362
    {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
363

bguillaum's avatar
bguillaum committed
364
  (* -------------------------------------------------------------------------------- *)
365 366
  let add_neighbour loc graph node_id label =
    let index = match node_id with
bguillaum's avatar
bguillaum committed
367
      | Gid.Old id ->
bguillaum's avatar
bguillaum committed
368 369 370 371
        (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"
        )
372
      | Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
pj2m's avatar
pj2m committed
373

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

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

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

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

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

392 393 394 395 396 397 398 399
    { 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
400

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

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

410 411 412 413 414 415 416 417 418 419 420 421 422 423
    {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
    }
424

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

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
431 432
    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
433

434
    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
435 436
    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
437

438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454
    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
455

bguillaum's avatar
bguillaum committed
456
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
457 458 459
  let merge_node loc graph src_gid tar_gid =
    let se_graph = shift_edges loc graph src_gid tar_gid in

460 461
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
462

463
    match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
464
    | Some new_fs ->
465 466 467 468 469 470 471
      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)
          )
           }
472
    | None -> None
bguillaum's avatar
bguillaum committed
473

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

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


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

bguillaum's avatar
bguillaum committed
503 504 505 506 507
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Output functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

  (* -------------------------------------------------------------------------------- *)
508 509
  let to_gr graph =
    let buff = Buffer.create 32 in
510

511 512
    bprintf buff "graph {\n";

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

bguillaum's avatar
bguillaum committed
519
    (* nodes *)
520 521 522 523
    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) ->
524
        bprintf buff "  N_%s %s;\n" (Gid.to_string id) (G_node.to_gr node)
525
      ) sorted_nodes;
526

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

536 537 538
    bprintf buff "}\n";
    Buffer.contents buff

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

bguillaum's avatar
bguillaum committed
564
  (* -------------------------------------------------------------------------------- *)
565
  let to_dep ?filter ?main_feat ?(deco=G_deco.empty) graph =
bguillaum's avatar
bguillaum committed
566 567 568
    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

569 570 571 572
    let buff = Buffer.create 32 in
    bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";
    bprintf buff "[WORDS] { \n";

bguillaum's avatar
bguillaum committed
573
    (* nodes *)
574
    List.iter
575
      (fun (id, node) ->
bguillaum's avatar
bguillaum committed
576 577 578 579 580 581 582
        let fs = G_node.get_fs node in
        let dep_fs = G_fs.to_dep ?filter ?main_feat fs in
        let style = match (List.mem id deco.G_deco.nodes, G_fs.get_string_atom "sem" fs) with
          | (true, _) -> "; forecolor=red; subcolor=red; "
          | (false, Some "void") -> "; forecolor=\"#AAAAAA\"; subcolor=\"#AAAAAA\"; "
          | _ -> "" in
	bprintf buff "N_%s { %s%s }\n" (Gid.to_string id) dep_fs style
583 584
      ) snodes;
    bprintf buff "} \n";
585

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

    bprintf buff "} \n";
598 599
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
600
  (* -------------------------------------------------------------------------------- *)
601
  let to_dot ?main_feat ?(deco=G_deco.empty) graph =
602
    let buff = Buffer.create 32 in
603

604
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
605
    (* bprintf buff "  rankdir=LR;\n"; *)
606 607
    bprintf buff "  node [shape=Mrecord];\n";

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

    (* edges *)
618 619
    Gid_map.iter
      (fun id node ->
620 621 622 623
	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)
624
	  ) (G_node.get_next node)
625
      ) graph.map;
626

627 628
    bprintf buff "}\n";
    Buffer.contents buff
629 630 631 632 633 634

  (* -------------------------------------------------------------------------------- *)
  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
bguillaum's avatar
bguillaum committed
635
    let raw_nodes = List.map (fun (gid,node) -> (gid, G_fs.to_raw (G_node.get_fs node))) snodes in
636

bguillaum's avatar
bguillaum committed
637
    let get_num gid = list_num (fun (x,_) -> x=gid) raw_nodes in
638 639
    let edge_list = ref [] in
    Gid_map.iter
bguillaum's avatar
bguillaum committed
640
      (fun src_gid node ->
641
        Massoc_gid.iter
bguillaum's avatar
bguillaum committed
642 643
          (fun tar_gid edge ->
            edge_list := (get_num src_gid, G_edge.to_string edge, get_num tar_gid) :: !edge_list
644 645 646 647 648 649
          )
          (G_node.get_next node)
      )
      graph.map;
    (graph.meta, List.map snd raw_nodes, !edge_list)

bguillaum's avatar
bguillaum committed
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
  (* -------------------------------------------------------------------------------- *)
  let to_conll graph =

    let nodes = Gid_map.fold (fun gid node acc -> (gid,node)::acc) graph.map [] in
    let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.pos_comp n1 n2) nodes in
    let get_num gid = list_num (fun (x,_) -> x=gid) snodes in

    (* Warning: [govs_labs] maps [gid]s to [num]s *)
    let govs_labs =
      Gid_map.fold
        (fun src_gid node acc ->
          let src_num = get_num src_gid in
          Massoc_gid.fold
            (fun acc2 tar_gid edge  ->
              let old = try Gid_map.find tar_gid acc2 with Not_found -> [] in
              Gid_map.add tar_gid ((string_of_int src_num, G_edge.to_string edge)::old) acc2
            ) acc (G_node.get_next node)
        ) graph.map Gid_map.empty in

    let buff = Buffer.create 32 in
    Gid_map.iter
      (fun gid node ->
        let (govs,labs) = List.split (try Gid_map.find gid govs_labs with Not_found -> []) in
        let fs = G_node.get_fs node in
        bprintf buff "%d\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t_\t_\n"
          (get_num gid)
          (match G_fs.get_string_atom "phon" fs with Some p -> p | None -> "NO_PHON")
          (match G_fs.get_string_atom "lemma" fs with Some p -> p | None -> "NO_LEMMA")
          (match G_fs.get_string_atom "cat" fs with Some p -> p | None -> "NO_CAT")
          (match G_fs.get_string_atom "pos" fs with Some p -> p | None -> "_")
          (G_fs.to_conll ~exclude: ["phon"; "lemma"; "cat"; "pos"; "position"] fs)
          (String.concat "|" govs)
          (String.concat "|" labs)
      )
      graph.map;
    Buffer.contents buff

687 688
end (* module G_graph *)
(* ================================================================================ *)