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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

bguillaum's avatar
bguillaum committed
296
  (* -------------------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
297
  let of_conll ?loc lines =
bguillaum's avatar
bguillaum committed
298 299 300
    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
301 302

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

bguillaum's avatar
bguillaum committed
304
    let map_without_edges =
bguillaum's avatar
bguillaum committed
305 306 307
      List_.foldi_left
        (fun i acc line -> Gid_map.add (Gid.Old i) (G_node.of_conll line) acc)
        Gid_map.empty sorted_lines in
bguillaum's avatar
bguillaum committed
308 309

    let map_with_edges =
bguillaum's avatar
bguillaum committed
310 311
      List.fold_left
        (fun acc line ->
bguillaum's avatar
bguillaum committed
312 313
          (* add line number information in loc *)
          let loc = Loc.opt_set_line line.Conll.line_num loc in
bguillaum's avatar
bguillaum committed
314
          let dep_id = Id.build ?loc line.Conll.num table in
315 316
          List.fold_left
            (fun acc2 (gov, dep_lab) ->
bguillaum's avatar
bguillaum committed
317 318 319 320 321 322 323 324
              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 -> "")
	      )
325
            ) acc line.Conll.deps
bguillaum's avatar
bguillaum committed
326 327
        ) map_without_edges lines in
    {meta=[]; map=map_with_edges}
bguillaum's avatar
bguillaum committed
328

bguillaum's avatar
bguillaum committed
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
  (* -------------------------------------------------------------------------------- *)
  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
351
                  let new_node = G_node.set_fs (G_node.set_pos G_node.empty (float i)) new_fs in
bguillaum's avatar
bguillaum committed
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
                  (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
376
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
pj2m's avatar
pj2m committed
377
  (* Update functions *)
bguillaum's avatar
bguillaum committed
378
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
379

bguillaum's avatar
bguillaum committed
380
  (* -------------------------------------------------------------------------------- *)
381
  let rename mapping graph =
382 383 384 385 386 387 388 389
    {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
    }
390

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

bguillaum's avatar
bguillaum committed
402
  (* -------------------------------------------------------------------------------- *)
403
  let del_node graph node_id =
404 405 406 407 408 409 410 411
    {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
412

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

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

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

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

bguillaum's avatar
bguillaum committed
434
  (* -------------------------------------------------------------------------------- *)
435
  let shift_in loc graph src_gid tar_gid =
436
    let tar_node = Gid_map.find tar_gid graph.map in
437 438

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

441 442 443 444 445 446 447 448
    { 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
449

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

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

459 460 461 462 463 464 465 466 467 468 469 470 471 472
    {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
    }
473

bguillaum's avatar
bguillaum committed
474
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
475
  let shift_edges loc graph src_gid tar_gid =
476 477
    let src_node = Gid_map.find src_gid graph.map in
    let tar_node = Gid_map.find tar_gid graph.map in
478 479

    if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
480 481
    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
482

483
    if Massoc_gid.mem_key src_gid (G_node.get_next tar_node)
484 485
    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
486

487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
    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
504

bguillaum's avatar
bguillaum committed
505
  (* -------------------------------------------------------------------------------- *)
pj2m's avatar
pj2m committed
506 507 508
  let merge_node loc graph src_gid tar_gid =
    let se_graph = shift_edges loc graph src_gid tar_gid in

509 510
    let src_node = Gid_map.find src_gid se_graph.map in
    let tar_node = Gid_map.find tar_gid se_graph.map in
511

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

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

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


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

bguillaum's avatar
bguillaum committed
552 553 554 555 556
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
  (* Output functions *)
  (* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

  (* -------------------------------------------------------------------------------- *)
557 558
  let to_gr graph =
    let buff = Buffer.create 32 in
559

560 561
    bprintf buff "graph {\n";

562 563 564 565 566 567
    (* meta data *)
    List.iter
      (fun (name, value) ->
        bprintf buff "  %s = \"%s\";\n" name value
      ) graph.meta;

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

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

585 586 587
    bprintf buff "}\n";
    Buffer.contents buff

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

bguillaum's avatar
bguillaum committed
613
  (* -------------------------------------------------------------------------------- *)
614
  let to_dep ?filter ?main_feat ?(deco=G_deco.empty) graph =
bguillaum's avatar
bguillaum committed
615 616 617
    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

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

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

    bprintf buff "} \n";
647 648
    Buffer.contents buff

bguillaum's avatar
bguillaum committed
649
  (* -------------------------------------------------------------------------------- *)
650
  let to_dot ?main_feat ?(deco=G_deco.empty) graph =
651
    let buff = Buffer.create 32 in
652

653
    bprintf buff "digraph G {\n";
bguillaum's avatar
bguillaum committed
654
    (* bprintf buff "  rankdir=LR;\n"; *)
655 656
    bprintf buff "  node [shape=Mrecord];\n";

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

    (* edges *)
667 668
    Gid_map.iter
      (fun id node ->
669 670 671 672
	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)
673
	  ) (G_node.get_next node)
674
      ) graph.map;
675

676 677
    bprintf buff "}\n";
    Buffer.contents buff
678 679 680 681 682 683

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

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

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

    (* 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
720 721
    List.iter
      (fun (gid, node) ->
bguillaum's avatar
bguillaum committed
722 723 724 725 726 727 728 729 730
        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
731 732 733 734
              else
                match compare (String_.to_float g1) (String_.to_float g2) with
                  | 0 -> compare l1 l2
                  | x -> x
bguillaum's avatar
bguillaum committed
735 736 737
            ) gov_labs in

        let (govs,labs) = List.split sorted_gov_labs in
bguillaum's avatar
bguillaum committed
738
        let fs = G_node.get_fs node in
bguillaum's avatar
bguillaum committed
739 740 741 742 743 744 745 746 747
          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
748
      )
749
      snodes;
bguillaum's avatar
bguillaum committed
750 751
    Buffer.contents buff

752 753
end (* module G_graph *)
(* ================================================================================ *)