grew_fs.ml 9.01 KB
Newer Older
bguillaum's avatar
bguillaum committed
1
open Printf
pj2m's avatar
pj2m committed
2
open Log
bguillaum's avatar
bguillaum committed
3 4 5

open Grew_utils
open Grew_ast
pj2m's avatar
pj2m committed
6

7 8 9
(* ==================================================================================================== *)
module Domain = struct
  let current = ref None
pj2m's avatar
pj2m committed
10

11
  let reset () = current := None
pj2m's avatar
pj2m committed
12

13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
  let init ast_domain = current := Some ast_domain

  let check ?loc name values = match !current with
  | None -> ()
  | Some d ->
      let rec loop = function
        | [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
        | ((Ast.Open n)::_) when n = name -> ()
        | ((Ast.Closed (n,vs))::_) when n = name -> 
            (match List_.sort_diff values vs with 
            | [] -> ()
            | l -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'" 
	          (List_.to_string (fun x->x) ", " l)
	          name
            )
        | _::t -> loop t in
      loop d
end

(* ==================================================================================================== *)
module G_feature = struct
  type t = string * string

  let get_name = fst
37

pj2m's avatar
pj2m committed
38 39
  let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)

40 41 42 43 44 45
  let build = function
    | ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
	Domain.check ~loc name [atom];
	(name, atom)
    | _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"

bguillaum's avatar
bguillaum committed
46 47 48 49 50 51
  let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name feat_val
      
  let to_dot (feat_name, feat_val) =
    match Str.split (Str.regexp ":C:") feat_val with
    | [] -> Error.bug "[G_feature.to_dot] feature value '%s'" feat_val
    | fv::_ -> sprintf "%s=%s" feat_name fv
52 53 54 55 56 57 58
end

(* ==================================================================================================== *)
module P_feature = struct
  (* feature= (feature_name, disjunction of atomic values) *) 

  type v = 
bguillaum's avatar
bguillaum committed
59
    | Equal of string list  (* with Equal constr, the list MUST never be empty *)
60 61 62 63 64 65 66 67 68
    | Different of string list
    | Param of int 

  type t = string * v

  let get_name = fst

  let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)

bguillaum's avatar
bguillaum committed
69 70 71 72 73 74 75 76 77
  let unif_value v1 v2 = 
    match (v1, v2) with
    | (Equal l1, Equal l2) -> 
        (match List_.sort_inter l1 l2 with
        | [] -> Error.build "Unification failure" 
        | l -> Equal l)
    | (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
    | _ -> Error.build "cannot unify heterogeneous pattern features"
        
bguillaum's avatar
bguillaum committed
78
  let to_string ?param_names = function
79 80 81
    | (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string (fun x->x) "|" atoms)
    | (feat_name, Different []) -> sprintf "%s=*" feat_name
    | (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string (fun x->x) "|" atoms)
bguillaum's avatar
bguillaum committed
82 83 84 85
    | (feat_name, Param index) -> 
      match param_names with
        | None -> sprintf "%s=$%d" feat_name index 
        | Some (l,_) -> sprintf "%s=%s" feat_name (List.nth l index)
86 87 88

  let build ?pat_vars = function
    | ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
pj2m's avatar
pj2m committed
89
	let values = List.sort Pervasives.compare unsorted_values in
90 91 92
	Domain.check ~loc name values;
	(name, Equal values)
    | ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
pj2m's avatar
pj2m committed
93
	let values = List.sort Pervasives.compare unsorted_values in
94 95 96
	Domain.check ~loc name values;
	(name, Different values)
    | ({Ast.kind=Ast.Param var; name=name}, loc) ->
bguillaum's avatar
bguillaum committed
97
        match pat_vars with
98
        | None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
bguillaum's avatar
bguillaum committed
99 100
        | Some l -> 
            match List_.pos var l with
101 102
            | Some index -> (name, Param index)
            | None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
pj2m's avatar
pj2m committed
103 104
end

105 106
(* ==================================================================================================== *)
module G_fs = struct
pj2m's avatar
pj2m committed
107
  (* list are supposed to be striclty ordered wrt compare*)
108
  type t = G_feature.t list
bguillaum's avatar
bguillaum committed
109

110
  let empty = []
bguillaum's avatar
bguillaum committed
111

112 113 114 115 116 117 118 119
  let set_feat ?loc feature_name atom t =
    Domain.check ?loc feature_name [atom];
    let rec loop = function
    | [] -> [(feature_name, atom)]
    | ((fn,_)::_) as t when feature_name < fn -> (feature_name, atom)::t
    | (fn,_)::t when feature_name = fn -> (feature_name, atom)::t
    | (fn,a)::t -> (fn,a) :: (loop t) 
    in loop t
120

121
  let del_feat = List_.sort_remove_assoc
122

123 124
  let get_atom = List_.sort_assoc

bguillaum's avatar
bguillaum committed
125 126
  let to_string t = List_.to_string G_feature.to_string "," t
  let to_gr = to_string
pj2m's avatar
pj2m committed
127

128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
  let build ast_fs =
    let unsorted = List.map (fun feat -> G_feature.build feat) ast_fs in
    List.sort G_feature.compare unsorted

  let of_conll line =
    let unsorted = ("phon", line.Conll.phon) :: ("lemma", line.Conll.lemma) :: ("cat", line.Conll.pos2) :: line.Conll.morph in
    List.sort G_feature.compare unsorted

  exception Fail_unif 
  let unif fs1 fs2 = 
    let rec loop = function
      | [], fs | fs, [] -> fs
      | (f1::t1, f2::t2) when G_feature.compare f1 f2 < 0 -> f1 :: loop (t1, f2::t2)
      | (f1::t1, f2::t2) when G_feature.compare f1 f2 > 0 -> f2 :: loop (f1::t1, t2)
                                                                    
      (* all remaining case are fn1 = fn2 *)
      | ((fn, a1)::t1, (_, a2)::t2) when a1=a2 -> (fn,a1) :: (loop (t1, t2))
      | _ -> raise Fail_unif
    in try Some (loop (fs1, fs2)) with Fail_unif -> None
147 148 149 150

  let get_main ?main_feat t =
    let main_list = match main_feat with
    | None -> []
bguillaum's avatar
bguillaum committed
151
    | Some string -> Str.split (Str.regexp "\\( *; *\\)\\|#") string in
152

153 154 155
    let rec loop = function
      | [] -> (None, t)
      | feat_name :: tail ->
156 157 158
          match List_.sort_assoc feat_name t with
          | Some atom -> (Some atom, List_.sort_remove_assoc feat_name t)
          | None -> loop tail in
159
    loop main_list
bguillaum's avatar
bguillaum committed
160

161 162
  let to_dot ?main_feat t =
    match get_main ?main_feat t with
bguillaum's avatar
bguillaum committed
163
    | (None, _) -> List_.to_string G_feature.to_dot "\\n" t
bguillaum's avatar
bguillaum committed
164
    | (Some atom, sub) -> sprintf "{%s|%s}" atom (List_.to_string G_feature.to_dot "\\n" sub)
165
          
166 167 168 169 170
  let to_word ?main_feat t =
    match get_main ?main_feat t with
      | (None, _) -> "#"
      | (Some atom, _) -> atom
        
171 172 173
  let to_dep ?main_feat t =
    let (main_opt, sub) = get_main ?main_feat t in
    sprintf " word=\"%s\"; subword=\"%s\"; " 
174
      (match main_opt with Some atom -> atom | None -> "")
bguillaum's avatar
bguillaum committed
175
      (List_.to_string G_feature.to_string "#" sub)
176 177 178 179 180 181
end
 
(* ==================================================================================================== *)
module P_fs = struct
  (* list are supposed to be striclty ordered wrt compare*)
  type t = P_feature.t list
pj2m's avatar
pj2m committed
182

183
  let empty = []
pj2m's avatar
pj2m committed
184

185 186 187
  let build ?pat_vars ast_fs =
    let unsorted = List.map (P_feature.build ?pat_vars) ast_fs in
    List.sort P_feature.compare unsorted 
pj2m's avatar
pj2m committed
188

189
  let to_string t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
190

bguillaum's avatar
bguillaum committed
191
  let to_dep param_names t = List_.to_string (P_feature.to_string ~param_names) "#" t
bguillaum's avatar
bguillaum committed
192

193
  let to_dot t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
194

195
  exception Fail
pj2m's avatar
pj2m committed
196

197 198 199
  let match_ ?param pattern fs =
    let rec loop acc = function
      | [], _ -> acc
pj2m's avatar
pj2m committed
200

201 202 203
      (* Two next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
      | _, [] -> raise Fail
      | ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
pj2m's avatar
pj2m committed
204

205 206
      (* a feature_name present only in instance -> Skip it *)
      | ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
pj2m's avatar
pj2m committed
207

208 209 210
      (* Next cases: fn_pat = fn *)
      | ((_, (P_feature.Equal fv))::t_pat, (_, fa)::t) when List_.sort_mem fa fv -> loop acc (t_pat,t)
      | ((_, (P_feature.Different fv))::t_pat, (_, fa)::t) when not (List_.sort_mem fa fv) -> loop acc (t_pat,t)
pj2m's avatar
pj2m committed
211

212 213 214 215 216
      | ((_, (P_feature.Param index))::t_pat, (_, atom)::t) ->
          (match acc with
          | None -> Log.bug "[P_fs.compatible] Illegal parametrized pattern feature"; exit 2
          | Some param ->
              (match Lex_par.filter index atom param with
217
              | None -> raise Fail
218 219 220
              | Some new_param -> loop (Some new_param) (t_pat,t)
              )
          )
pj2m's avatar
pj2m committed
221

222 223 224
      (* remaining cases: Equal and not list_mem  |  Diff and not list_mem -> fail*)  
      | _ -> raise Fail
    in loop param (pattern,fs)
pj2m's avatar
pj2m committed
225 226 227 228 229 230

  let filter fs_p fs_g = 
    let rec loop = function
      | [], fs -> true
      | fs, [] -> false

231 232
      | ((fn1,_)::_, (fn2,_)::_) when fn1 < fn2 -> false
      | ((fn1,_)::_ as f1, (fn2,_)::t2) when fn1 > fn2 -> loop (f1, t2)
pj2m's avatar
pj2m committed
233 234

      (* all remaining case are fn1 = fn2 *)
235 236 237
      | ((_, (P_feature.Equal fv))::t1, (_, atom)::t2) when List_.sort_mem atom fv -> loop (t1, t2)
      | ((_, (P_feature.Different fv))::t1, (_, atom)::t2) when not (List_.sort_mem atom fv) -> loop (t1, t2)
      | _ -> false
pj2m's avatar
pj2m committed
238

239
    in loop (fs_p, fs_g)
bguillaum's avatar
bguillaum committed
240 241 242 243 244 245 246 247 248 249 250 251

  let unif fs1 fs2 = 
    let rec loop = function
      | [], fs -> fs
      | fs, [] -> fs

      | ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 < fn2 -> (fn1,v1) :: (loop (t1,(fn2,v2)::t2))
      | ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 > fn2 -> (fn2,v2) :: (loop ((fn1,v1)::t1,t2))

      (* all remaining case are fn1 = fn2 *)
      | ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) -> (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
    in loop (fs1, fs2)      
pj2m's avatar
pj2m committed
252
end