grew_node.ml 6.45 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

11
open Printf
12
open Conll
13

bguillaum's avatar
bguillaum committed
14
open Grew_base
15 16
open Grew_types

bguillaum's avatar
bguillaum committed
17
open Grew_ast
pj2m's avatar
pj2m committed
18 19 20
open Grew_edge
open Grew_fs

21 22
(* ================================================================================ *)
module G_node = struct
23 24 25 26
  type position =
  | Ordered of float
  | Unordered of int

pj2m's avatar
pj2m committed
27
  type t = {
28
      name: Id.name option;
29
      fs: G_fs.t;
30
      next: G_edge.t Massoc_gid.t;
31 32
      succ: Gid.t option;
      prec: Gid.t option;
33
      position: position;
34
      conll_root: bool;
35
      efs: (string * string) list;
pj2m's avatar
pj2m committed
36 37
    }

38
  let get_fs t = t.fs
39
  let set_fs fs t = {t with fs }
40

41
  let get_next t = t.next
42
  let set_next next t = {t with next }
43

44
  let get_position t = t.position
45 46 47
  let set_position p t = { t with position = Ordered p }

  let get_float t = match t.position with Ordered p -> p | Unordered i -> float i
48

49 50 51
  let get_prec t = t.prec
  let get_succ t = t.succ

bguillaum's avatar
bguillaum committed
52 53 54
  let set_succ id t = { t with succ = Some id }
  let set_prec id t = { t with prec = Some id }

55 56 57
  let remove_succ t = { t with succ = None }
  let remove_prec t = { t with prec = None }

58 59
  let get_name gid t = match t.name with
    | Some n -> n
Bruno Guillaume's avatar
Bruno Guillaume committed
60
    | None -> sprintf "_%s_" (Gid.to_string gid)
61

62
  let empty = { name=None; fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = Unordered 0; conll_root=false; efs=[] }
63 64

  let is_conll_root t = t.conll_root
65

bguillaum's avatar
bguillaum committed
66
  let to_string ?domain t =
bguillaum's avatar
bguillaum committed
67
    Printf.sprintf "  fs=[%s]\n  next=%s\n"
68
      (G_fs.to_string t.fs)
bguillaum's avatar
bguillaum committed
69
      (Massoc_gid.to_string (G_edge.to_string ?domain) t.next)
70

71
  let to_gr t = sprintf "[%s] " (G_fs.to_gr t.fs)
72 73

  let add_edge g_edge gid_tar t =
74
    match Massoc_gid.add gid_tar g_edge t.next with
75 76
    | Some l -> Some {t with next = l}
    | None -> None
pj2m's avatar
pj2m committed
77

Bruno Guillaume's avatar
Bruno Guillaume committed
78 79
  let get_efs n = n.efs

80 81 82 83
  let string_efs n = match n.efs with
    | [] -> "_"
    | list -> String.concat "|" (List.map (fun (f,v) -> sprintf "%s=%s" f v) list)

84 85 86 87
  let current_index = ref 0
  let fresh_index () = decr current_index; !current_index

  let build ?domain ?prec ?succ ?position (ast_node, loc) =
bguillaum's avatar
bguillaum committed
88
    let fs = G_fs.build ?domain ast_node.Ast.fs in
89 90
    let pos = match position with None -> Unordered (fresh_index ()) | Some p -> Ordered p in
    { empty with name=Some ast_node.Ast.node_id; fs; position = pos; prec; succ }
91

92 93 94 95 96
  let float_of_conll_id = function
  | (i,None) -> float i
  | (i, Some j) when j >0 && j < 10 -> (float i) +. (float j) /. 10.
  | _ -> Error.bug "[float_of_conll_id]"

bguillaum's avatar
bguillaum committed
97
  let of_conll ?loc ?prec ?succ ?domain line =
bguillaum's avatar
bguillaum committed
98
    if line = Conll.root
99
    then { empty with conll_root=true; succ; position = Ordered 0.}
100
    else { empty with fs = G_fs.of_conll ?loc ?domain line; position = Ordered (float_of_conll_id line.Conll.id); prec; succ; efs=line.Conll.efs }
bguillaum's avatar
bguillaum committed
101

102
  let pst_leaf ?loc ?domain phon position =
103
    { empty with fs = G_fs.pst_leaf ?loc ?domain phon; position = Ordered (float position) }
104
  let pst_node ?loc ?domain cat position =
105
    { empty with fs = G_fs.pst_node ?loc ?domain cat; position = Ordered (float position) } (* TODO : change to Unordered *)
106

107 108
  let fresh ?prec ?succ pos = { empty with position = Ordered pos; prec; succ }
  let fresh_unordered () = { empty with position = Unordered (fresh_index ())}
bguillaum's avatar
bguillaum committed
109

110
  let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
bguillaum's avatar
bguillaum committed
111 112

  let remove_key node_id t =
113
    try {t with next = Massoc_gid.remove_key node_id t.next} with Not_found -> t
114

bguillaum's avatar
bguillaum committed
115
  let merge_key ?(strict=false) src_id tar_id t =
116 117
    try Some {t with next = Massoc_gid.merge_key src_id tar_id t.next}
    with Massoc_gid.Duplicate -> if strict then None else Some t
118

bguillaum's avatar
bguillaum committed
119
  let shift_out ?(strict=false) src_t tar_t =
120 121
    try Some {tar_t with next = Massoc_gid.disjoint_union src_t.next tar_t.next}
    with Massoc_gid.Not_disjoint -> if strict then None else Some tar_t
122

123
  let rm_out_edges t = {t with next = Massoc_gid.empty}
124

125
  (* let build_neighbour t = { empty with position = (get_position t) +. 0.01 }
126

127
  let build_new t = { empty with position = (get_position t) +. 0.01 } *)
bguillaum's avatar
bguillaum committed
128

129
  let position_comp n1 n2 = Pervasives.compare n1.position n2.position
130 131

  let rename mapping n = {n with next = Massoc_gid.rename mapping n.next}
bguillaum's avatar
bguillaum committed
132
end (* module G_node *)
133 134 135 136

(* ================================================================================ *)
module P_node = struct
  type t = {
bguillaum's avatar
bguillaum committed
137
      name: Id.name;
138
      fs: P_fs.t;
bguillaum's avatar
bguillaum committed
139
      next: P_edge.t Massoc_pid.t;
bguillaum's avatar
bguillaum committed
140
      loc: Loc.t option;
141 142
    }

Bruno Guillaume's avatar
Bruno Guillaume committed
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
  let to_json ?domain t =
    let json_next = `List (
      Massoc_pid.fold
        (fun acc pid p_edge ->
          `Assoc [
            ("id", `String (Pid.to_string pid));
            ("label", P_edge.to_json ?domain p_edge);
          ] :: acc
        ) [] t.next
    ) in
    `Assoc [
      ("node_name", `String t.name);
      ("fs", P_fs.to_json ?domain t.fs);
      ("next", json_next)
    ]

bguillaum's avatar
bguillaum committed
159
  let get_name t = t.name
160 161 162
  let get_fs t = t.fs
  let get_next t = t.next

bguillaum's avatar
bguillaum committed
163 164
  let unif_fs fs t = { t with fs = P_fs.unif fs t.fs }

bguillaum's avatar
bguillaum committed
165
  let empty = { fs = P_fs.empty; next = Massoc_pid.empty; name = ""; loc=None   }
bguillaum's avatar
bguillaum committed
166

bguillaum's avatar
bguillaum committed
167
  let build ?domain ?pat_vars (ast_node, loc) =
bguillaum's avatar
bguillaum committed
168 169
    (ast_node.Ast.node_id,
     {
bguillaum's avatar
bguillaum committed
170
       name = ast_node.Ast.node_id;
bguillaum's avatar
bguillaum committed
171
       fs = P_fs.build ?domain ?pat_vars ast_node.Ast.fs;
bguillaum's avatar
bguillaum committed
172
       next = Massoc_pid.empty;
bguillaum's avatar
bguillaum committed
173
       loc = Some loc;
174 175 176
     } )

  let add_edge p_edge pid_tar t =
bguillaum's avatar
bguillaum committed
177
    match Massoc_pid.add pid_tar p_edge t.next with
178 179
    | Some l -> Some {t with next = l}
    | None -> None
pj2m's avatar
pj2m committed
180

181 182
  let match_ ?param p_node g_node =
    (* (match param with None -> printf "<None>" | Some p -> printf "<Some>"; Lex_par.dump p); *)
183 184 185 186 187 188
    match G_node.get_position g_node with
    | G_node.Unordered _ -> None
    | G_node.Ordered p ->
      if P_fs.check_position ?param (Some p) p_node.fs
      then P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
      else raise P_fs.Fail
pj2m's avatar
pj2m committed
189

bguillaum's avatar
bguillaum committed
190
  let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc
Bruno Guillaume's avatar
Bruno Guillaume committed
191
end (* module P_node *)