grew_fs.ml 7.88 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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
end

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

  type v = 
    | Equal of string list  (* with Equal constr, the list is MUST never be empty *)
    | 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)

  let to_string = function
    | (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)
    | (feat_name, Param index) -> sprintf "%s=$%d" feat_name index 

  let build ?pat_vars = function
    | ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
pj2m's avatar
pj2m committed
77
	let values = List.sort Pervasives.compare unsorted_values in
78
79
80
	Domain.check ~loc name values;
	(name, Equal values)
    | ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
pj2m's avatar
pj2m committed
81
	let values = List.sort Pervasives.compare unsorted_values in
82
83
84
	Domain.check ~loc name values;
	(name, Different values)
    | ({Ast.kind=Ast.Param var; name=name}, loc) ->
bguillaum's avatar
bguillaum committed
85
        match pat_vars with
86
        | None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
bguillaum's avatar
bguillaum committed
87
88
        | Some l -> 
            match List_.pos var l with
89
90
            | Some index -> (name, Param index)
            | None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
pj2m's avatar
pj2m committed
91
92
end

93
94
(* ==================================================================================================== *)
module G_fs = struct
pj2m's avatar
pj2m committed
95
  (* list are supposed to be striclty ordered wrt compare*)
96
  type t = G_feature.t list
bguillaum's avatar
bguillaum committed
97

98
  let empty = []
bguillaum's avatar
bguillaum committed
99

100
101
102
103
104
105
106
107
  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
108

109
  let del_feat = List_.sort_remove_assoc
110

111
112
  let get_atom = List_.sort_assoc

bguillaum's avatar
bguillaum committed
113
114
  let to_string t = List_.to_string G_feature.to_string "," t
  let to_gr = to_string
pj2m's avatar
pj2m committed
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
  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
135
136
137
138

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

141
142
143
    let rec loop = function
      | [] -> (None, t)
      | feat_name :: tail ->
144
145
146
          match List_.sort_assoc feat_name t with
          | Some atom -> (Some atom, List_.sort_remove_assoc feat_name t)
          | None -> loop tail in
147
    loop main_list
bguillaum's avatar
bguillaum committed
148

149
150
  let to_dot ?main_feat t =
    match get_main ?main_feat t with
bguillaum's avatar
bguillaum committed
151
    | (None, _) -> List_.to_string G_feature.to_dot "\\n" t
bguillaum's avatar
bguillaum committed
152
    | (Some atom, sub) -> sprintf "{%s|%s}" atom (List_.to_string G_feature.to_dot "\\n" sub)
153
          
154
155
156
  let to_dep ?main_feat t =
    let (main_opt, sub) = get_main ?main_feat t in
    sprintf " word=\"%s\"; subword=\"%s\"; " 
157
      (match main_opt with Some atom -> atom | None -> "")
bguillaum's avatar
bguillaum committed
158
      (List_.to_string G_feature.to_string "#" sub)
159
160
161
162
163
164
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
165

166
  let empty = []
pj2m's avatar
pj2m committed
167

168
169
170
  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
171

172
  let to_string t = List_.to_string P_feature.to_string "\\n" t
pj2m's avatar
pj2m committed
173

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

176
  exception Fail
pj2m's avatar
pj2m committed
177

178
179
180
  let match_ ?param pattern fs =
    let rec loop acc = function
      | [], _ -> acc
pj2m's avatar
pj2m committed
181

182
183
184
      (* 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
185

186
187
      (* 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
188

189
190
191
      (* 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
192

193
194
195
196
197
      | ((_, (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
198
              | None -> raise Fail
199
200
201
              | Some new_param -> loop (Some new_param) (t_pat,t)
              )
          )
pj2m's avatar
pj2m committed
202

203
204
205
      (* 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
206
207
208
209
210
211

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

212
213
      | ((fn1,_)::_, (fn2,_)::_) when fn1 < fn2 -> false
      | ((fn1,_)::_ as f1, (fn2,_)::t2) when fn1 > fn2 -> loop (f1, t2)
pj2m's avatar
pj2m committed
214
215

      (* all remaining case are fn1 = fn2 *)
216
217
218
      | ((_, (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
219

220
    in loop (fs_p, fs_g)
pj2m's avatar
pj2m committed
221
end