Attention une mise à jour du serveur va être effectuée le vendredi 16 avril entre 12h et 12h30. Cette mise à jour va générer une interruption du service de quelques minutes.

grew_graph.ml 28.7 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

bguillaum's avatar
bguillaum committed
11
module Str_map = Map.Make (String)
pj2m's avatar
pj2m committed
12

13
(* ==================================================================================================== *)
14
module P_deco = struct
bguillaum's avatar
bguillaum committed
15 16 17 18
  type t = {
    nodes: Pid.t list;
    edges: (Pid.t * P_edge.t * Pid.t) list;
  }
pj2m's avatar
pj2m committed
19 20

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

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

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

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

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

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

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

51
    (* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
52
    (* 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
53 54
    let rec insert (ast_node, loc) = function
      | [] -> [P_node.build ?pat_vars (ast_node, loc)]
55 56 57
      | (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
58

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

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

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

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

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

90

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

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

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

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

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

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

129
    let ext_map_with_all_edges =
pj2m's avatar
pj2m committed
130 131
      List.fold_left
	(fun acc (ast_edge, loc) ->
132 133
          let src = ast_edge.Ast.src
          and tar = ast_edge.Ast.tar in
134
	  let i1 =
135
	    match Id.build_opt src pos_table with
bguillaum's avatar
bguillaum committed
136
              | Some i -> Pid.Pos i
137
              | None -> Pid.Neg (Id.build ~loc src new_table) in
138
	  let i2 =
139
	    match Id.build_opt tar pos_table with
bguillaum's avatar
bguillaum committed
140
              | Some i -> Pid.Pos i
141
              | None -> Pid.Neg (Id.build ~loc tar new_table) in
142
	  let edge = P_edge.build ~locals (ast_edge, loc) in
pj2m's avatar
pj2m committed
143 144
	  match map_add_edge acc i1 edge i2 with
	  | Some map -> map
145
	  | None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
pj2m's avatar
pj2m committed
146 147 148 149 150 151 152 153 154
	) ext_map_without_edges full_edge_list in
    ({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 =
155 156
      Pid_map.fold
	(fun _ node acc ->
bguillaum's avatar
bguillaum committed
157
	  Massoc_pid.fold
pj2m's avatar
pj2m committed
158 159
	    (fun acc2 tar _ ->
	      if !tree_prop
160
	      then
bguillaum's avatar
bguillaum committed
161
		if Pid_set.mem tar acc2
pj2m's avatar
pj2m committed
162
		then (tree_prop := false; acc2)
bguillaum's avatar
bguillaum committed
163 164
		else Pid_set.add tar acc2
	      else Pid_set.add tar acc2
165
	    ) acc (P_node.get_next node)
bguillaum's avatar
bguillaum committed
166
	) graph Pid_set.empty in
pj2m's avatar
pj2m committed
167 168

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

pj2m's avatar
pj2m committed
176 177 178
    (!tree_prop, roots)

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

181 182 183 184 185 186 187 188 189
(* ==================================================================================================== *)
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 *)
190

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

bguillaum's avatar
bguillaum committed
198
(* ==================================================================================================== *)
199
module G_graph = struct
200 201 202 203 204 205 206 207 208 209
  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
210

211 212 213 214 215 216 217 218
(* 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! *)
219

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

223 224 225 226
  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
227

bguillaum's avatar
bguillaum committed
228
  let list_num test =
bguillaum's avatar
bguillaum committed
229 230 231 232 233 234
    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
235 236
  (* is there an edge e out of node i ? *)
  let edge_out graph node_id p_edge =
237
    let node = Gid_map.find node_id graph.map in
bguillaum's avatar
bguillaum committed
238
    Massoc_gid.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
239

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

bguillaum's avatar
bguillaum committed
254 255 256 257
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Build functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

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

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

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

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

296
    {meta=gr_ast.Ast.meta; map=map}
297

bguillaum's avatar
bguillaum committed
298
  (* -------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
299
  let of_conll ?loc lines =
bguillaum's avatar
bguillaum committed
300 301 302
    let sorted_lines =
      Conll.root ::
      (List.sort (fun line1 line2 -> Pervasives.compare line1.Conll.num line2.Conll.num) lines) in
bguillaum's avatar
bguillaum committed
303 304

    let table = Array.of_list (List.map (fun line -> line.Conll.num) sorted_lines) in
305

bguillaum's avatar
bguillaum committed
306
    let map_without_edges =
bguillaum's avatar
bguillaum committed
307
      List_.foldi_left
308 309 310
        (fun i acc line ->
          let loc = Loc.opt_set_line i loc in
          Gid_map.add (Gid.Old i) (G_node.of_conll ?loc line) acc)
bguillaum's avatar
bguillaum committed
311
        Gid_map.empty sorted_lines in
bguillaum's avatar
bguillaum committed
312 313

    let map_with_edges =
bguillaum's avatar
bguillaum committed
314 315
      List.fold_left
        (fun acc line ->
bguillaum's avatar
bguillaum committed
316 317
          (* add line number information in loc *)
          let loc = Loc.opt_set_line line.Conll.line_num loc in
bguillaum's avatar
bguillaum committed
318
          let dep_id = Id.build ?loc line.Conll.num table in
319 320
          List.fold_left
            (fun acc2 (gov, dep_lab) ->
bguillaum's avatar
bguillaum committed
321 322 323 324 325 326 327 328
              let gov_id = Id.build ?loc gov table in
              let edge = if gov = "0" then G_edge.root else G_edge.make ?loc dep_lab in
              (match map_add_edge acc2 (Gid.Old gov_id) edge (Gid.Old dep_id) with
	        | Some g -> g
	        | None -> Error.build "[GRS] [Graph.of_conll] try to build a graph with twice the same edge %s %s"
                  (G_edge.to_string edge)
                  (match loc with Some l -> Loc.to_string l | None -> "")
	      )
329
            ) acc line.Conll.deps
bguillaum's avatar
bguillaum committed
330 331
        ) map_without_edges lines in
    {meta=[]; map=map_with_edges}
bguillaum's avatar
bguillaum committed
332

bguillaum's avatar
bguillaum committed
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354
  (* -------------------------------------------------------------------------------- *)
  let opt_att atts name =
    try Some (List.assoc name atts)
    with Not_found -> None

  (** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
  let of_xml d_xml =
    match d_xml with
      | Xml.Element ("D", _, t_or_r_list) ->
        let (t_list, r_list) = List.partition (function Xml.Element ("T",_,_) -> true | _ -> false) t_or_r_list in
        let (nodes_without_edges, mapping) =
          List_.foldi_left
            (fun i (acc, acc_map) t_xml ->
              match t_xml with
                | Xml.Element ("T", t_atts, [Xml.PCData phon]) ->
                  let id = List.assoc "id" t_atts in
                  let other_feats = List.filter (fun (n,_) -> not (List.mem n ["id"; "start"; "end"; "label"])) t_atts in
                  let new_fs =
                    List.fold_left
                      (fun acc2 (fn,fv) -> G_fs.set_feat fn fv acc2)
                      G_fs.empty
                      (("phon", phon) :: ("cat", (List.assoc "label" t_atts)) :: other_feats) in
bguillaum's avatar
bguillaum committed
355
                  let new_node = G_node.set_fs (G_node.set_pos G_node.empty (float i)) new_fs in
bguillaum's avatar
bguillaum committed
356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
                  (Gid_map.add (Gid.Old i) new_node acc, Str_map.add id (Gid.Old i) acc_map)
                | _ -> Log.critical "[G_graph.of_xml] Not a wellformed <T> tag"
            ) (Gid_map.empty, Str_map.empty) t_list in
        let final_map =
          List.fold_left
            (fun acc r_xml ->
              match r_xml with
                | Xml.Element ("R", r_atts, _) ->
                  let src = List.assoc "from" r_atts
                  and tar = List.assoc "to" r_atts
                  and label = List.assoc "label" r_atts in
                  let gid_tar = Str_map.find tar mapping in
                  let gid_src = Str_map.find src mapping in
                  let old_node = Gid_map.find gid_src acc in
                  let new_map =
                    match G_node.add_edge (G_edge.make label) gid_tar old_node with
                      | Some new_node -> Gid_map.add gid_src new_node acc
                      | None -> Log.critical "[G_graph.of_xml] Fail to add edge" in
                  new_map
                | _ -> Log.critical "[G_graph.of_xml] Not a wellformed <R> tag"
            ) nodes_without_edges r_list in
        {meta=[]; map=final_map}
      | _ -> Log.critical "[G_graph.of_xml] Not a <D> tag"

bguillaum's avatar
bguillaum committed
380
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
pj2m's avatar
pj2m committed
381
  (* Update functions *)
bguillaum's avatar
bguillaum committed
382
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
383

bguillaum's avatar
bguillaum committed
384
  (* -------------------------------------------------------------------------------- *)
385
  let rename mapping graph =
386 387 388 389 390 391 392 393
    {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
    }
394

bguillaum's avatar
bguillaum committed
395
  (* -------------------------------------------------------------------------------- *)
396 397
  let del_edge ?edge_ident loc graph id_src label id_tar =
    let node_src =
398
      try Gid_map.find id_src graph.map
399
      with Not_found ->
400 401 402
        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
403
    try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map}
404
    with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
pj2m's avatar
pj2m committed
405

bguillaum's avatar
bguillaum committed
406
  (* -------------------------------------------------------------------------------- *)
407
  let del_node graph node_id =
408 409 410 411 412 413 414 415
    {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
416

bguillaum's avatar
bguillaum committed
417
  (* -------------------------------------------------------------------------------- *)
418 419
  let add_neighbour loc graph node_id label =
    let index = match node_id with
bguillaum's avatar
bguillaum committed
420
      | Gid.Old id ->
bguillaum's avatar
bguillaum committed
421 422 423 424
        (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"
        )
425
      | Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
pj2m's avatar
pj2m committed
426

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

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

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

bguillaum's avatar
bguillaum committed
438
  (* -------------------------------------------------------------------------------- *)
439
  let shift_in loc graph src_gid tar_gid =
440
    let tar_node = Gid_map.find tar_gid graph.map in
441 442

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

445 446 447 448 449 450 451 452
    { 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
453

bguillaum's avatar
bguillaum committed
454
  (* -------------------------------------------------------------------------------- *)
455
  (* move all out-edges from id_src are moved to out-edges out off node id_tar *)
456
  let shift_out loc graph src_gid tar_gid =
457 458
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
459 460

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

463 464 465 466 467 468 469 470 471 472 473 474 475 476
    {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
    }
477

bguillaum's avatar
bguillaum committed
478
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
479
  let shift_edges loc graph src_gid tar_gid =
480 481
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
482 483

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
484 485
    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
486

487
    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
488 489
    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
490

491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
    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
508

bguillaum's avatar
bguillaum committed
509
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
510 511 512
  let merge_node loc graph src_gid tar_gid =
    let se_graph = shift_edges loc graph src_gid tar_gid in

513 514
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
515

516
    match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
517
    | Some new_fs ->
518 519 520 521 522 523 524
      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)
          )
           }
525
    | None -> None
bguillaum's avatar
bguillaum committed
526

bguillaum's avatar
bguillaum committed
527
  (* -------------------------------------------------------------------------------- *)
528
  let set_feat ?loc graph node_id feat_name new_value =
529
    let node = Gid_map.find node_id graph.map in
530
    let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
531
    { graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
bguillaum's avatar
bguillaum committed
532

bguillaum's avatar
bguillaum committed
533
  (* -------------------------------------------------------------------------------- *)
534
  let update_feat ?loc graph tar_id tar_feat_name item_list =
535 536 537
    let strings_to_concat =
      List.map
        (function
bguillaum's avatar
bguillaum committed
538
          | Concat_item.Feat (node_gid, feat_name) ->
539
              let node = Gid_map.find node_gid graph.map in
bguillaum's avatar
bguillaum committed
540
              (match G_fs.get_string_atom feat_name (G_node.get_fs node) with
bguillaum's avatar
bguillaum committed
541
              | Some atom -> atom
bguillaum's avatar
bguillaum committed
542
              | None -> Error.run ?loc "Cannot update_feat, some feature (named \"%s\") is not defined" feat_name
bguillaum's avatar
bguillaum committed
543
              )
bguillaum's avatar
bguillaum committed
544
          | Concat_item.String s -> s
545 546
        ) item_list in
    let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
547
    (set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
bguillaum's avatar
bguillaum committed
548 549


bguillaum's avatar
bguillaum committed
550
  (* -------------------------------------------------------------------------------- *)
551
  let del_feat graph node_id feat_name =
552
    let node = Gid_map.find node_id graph.map in
553
    let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
554
    { graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
555

bguillaum's avatar
bguillaum committed
556 557 558 559 560
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Output functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

  (* -------------------------------------------------------------------------------- *)
561 562
  let to_gr graph =
    let buff = Buffer.create 32 in
563

564 565
    bprintf buff "graph {\n";

566 567 568 569 570 571
    (* meta data *)
    List.iter
      (fun (name, value) ->
        bprintf buff "  %s = \"%s\";\n" name value
      ) graph.meta;

bguillaum's avatar
bguillaum committed
572
    (* nodes *)
573 574 575 576
    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) ->
577
        bprintf buff "  N_%s %s;\n" (Gid.to_string id) (G_node.to_gr node)
578
      ) sorted_nodes;
579

bguillaum's avatar
bguillaum committed
580
    (* edges *)
581 582
    Gid_map.iter
      (fun id node ->
583 584
	Massoc_gid.iter
	  (fun tar edge ->
585
	    bprintf buff "  N_%s -[%s]-> N_%s;\n" (Gid.to_string id) (G_edge.to_string edge) (Gid.to_string tar)
586
	  ) (G_node.get_next node)
587
      ) graph.map;
588

589 590 591
    bprintf buff "}\n";
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
592
  (* -------------------------------------------------------------------------------- *)
593
  let to_sentence ?main_feat graph =
594
    let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
595 596 597 598 599 600 601 602 603 604 605
    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
606 607
        " -t-", "-t-";
        "_-_", "-";
608 609
        "_", " ";
        "' ", "'";
610 611
        " ,", ",";
        " .", ".";
612 613 614 615
        "( ", "(";
        " )", ")";
        "\\\"", "\"";
      ]
616

bguillaum's avatar
bguillaum committed
617
  (* -------------------------------------------------------------------------------- *)
618
  let to_dep ?filter ?main_feat ?(deco=G_deco.empty) graph =
bguillaum's avatar
bguillaum committed
619 620 621
    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

622 623 624 625
    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
626
    (* nodes *)
627
    List.iter
628
      (fun (id, node) ->
bguillaum's avatar
bguillaum committed
629 630
        let fs = G_node.get_fs node in
        let dep_fs = G_fs.to_dep ?filter ?main_feat fs in
bguillaum's avatar
bguillaum committed
631
        let style = match (List.mem id deco.G_deco.nodes, G_fs.get_string_atom "void" fs) with
bguillaum's avatar
bguillaum committed
632
          | (true, _) -> "; forecolor=red; subcolor=red; "
bguillaum's avatar
bguillaum committed
633
          | (false, Some "y") -> "; forecolor=red; subcolor=red; "
bguillaum's avatar
bguillaum committed
634 635
          | _ -> "" in
	bprintf buff "N_%s { %s%s }\n" (Gid.to_string id) dep_fs style
636 637
      ) snodes;
    bprintf buff "} \n";
638

bguillaum's avatar
bguillaum committed
639
    (* edges *)
640
    bprintf buff "[EDGES] { \n";
641
    Gid_map.iter
642
      (fun gid elt ->
643 644 645 646
	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)
647
	  ) (G_node.get_next elt)
648
      ) graph.map;
bguillaum's avatar
bguillaum committed
649 650

    bprintf buff "} \n";
651 652
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
653
  (* -------------------------------------------------------------------------------- *)
654
  let to_dot ?main_feat ?(deco=G_deco.empty) graph =
655
    let buff = Buffer.create 32 in
656

657
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
658
    (* bprintf buff "  rankdir=LR;\n"; *)
659 660
    bprintf buff "  node [shape=Mrecord];\n";

bguillaum's avatar
bguillaum committed
661
    (* nodes *)
662 663
    Gid_map.iter
      (fun id node ->
664 665 666 667
	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")
668
      ) graph.map;
bguillaum's avatar
bguillaum committed
669 670

    (* edges *)
671 672
    Gid_map.iter
      (fun id node ->
673 674 675 676
	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)
677
	  ) (G_node.get_next node)
678
      ) graph.map;
679

680 681
    bprintf buff "}\n";
    Buffer.contents buff
682 683 684 685 686 687

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

bguillaum's avatar
bguillaum committed
690
    let get_num gid = list_num (fun (x,_) -> x=gid) raw_nodes in
691 692
    let edge_list = ref [] in
    Gid_map.iter
bguillaum's avatar
bguillaum committed
693
      (fun src_gid node ->
694
        Massoc_gid.iter
bguillaum's avatar
bguillaum committed
695 696
          (fun tar_gid edge ->
            edge_list := (get_num src_gid, G_edge.to_string edge, get_num tar_gid) :: !edge_list
697 698 699 700 701 702
          )
          (G_node.get_next node)
      )
      graph.map;
    (graph.meta, List.map snd raw_nodes, !edge_list)

bguillaum's avatar
bguillaum committed
703 704
  (* -------------------------------------------------------------------------------- *)
  let to_conll graph =
705
    let nodes = Gid_map.fold
706
      (fun gid node acc -> (gid,node)::acc)
707
      graph.map [] in
bguillaum's avatar
bguillaum committed
708
    let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.pos_comp n1 n2) nodes in
bguillaum's avatar
bguillaum committed
709
    let get_num gid = (list_num (fun (x,_) -> x=gid) snodes) in
bguillaum's avatar
bguillaum committed
710 711 712 713 714 715 716 717 718 719 720 721 722 723

    (* 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
bguillaum's avatar
bguillaum committed
724 725
    List.iter
      (fun (gid, node) ->
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
        if not (G_node.is_conll_root node)
        then
          let gov_labs = try Gid_map.find gid govs_labs with Not_found -> [] in

          let sorted_gov_labs =
            List.sort
              (fun (g1,l1) (g2,l2) ->
                if l1 <> "" && l1.[0] <> 'I' && l1.[0] <> 'D'
                then -1
                else if l2 <> "" && l2.[0] <> 'I' && l2.[0] <> 'D'
                then 1
                else
                  match compare (String_.to_float g1) (String_.to_float g2) with
                    | 0 -> compare l1 l2
                    | x -> x
              ) gov_labs in
          let (govs,labs) = List.split sorted_gov_labs in
          let fs = G_node.get_fs node in
bguillaum's avatar
bguillaum committed
744 745 746 747 748 749 750 751 752
          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)
bguillaum's avatar
bguillaum committed
753
      )
754
      snodes;
bguillaum's avatar
bguillaum committed
755 756
    Buffer.contents buff

757 758
end (* module G_graph *)
(* ================================================================================ *)