Blame view

pre/prePaths.ml 29.2 KB
Wojciech Jaworski authored
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
(*
 *  ENIAM: Categorial Syntactic-Semantic Parser for Polish
 *  Copyright (C) 2016 Wojciech Jaworski <wjaworski atSPAMfree mimuw dot edu dot pl>
 *  Copyright (C) 2016 Institute of Computer Science Polish Academy of Sciences
 *
 *  This program is free software: you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation, either version 3 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

open Xstd
open PreTypes
Wojciech Jaworski authored
23
let to_string (paths,last) =
Wojciech Jaworski authored
24
25
26
  String.concat "\n" (Xlist.map paths (fun t -> PreTokenizer.string_of_tokens 0 (Token t)))
  ^ Printf.sprintf "\nlast=%d" last
Wojciech Jaworski authored
27
28
let to_string_indexed (paths,last) =
  String.concat "\n" (Xlist.map paths (fun (i,j,t) ->
Wojciech Jaworski authored
29
30
31
32
    Printf.sprintf "%2d %2d %s" i j (PreTokenizer.string_of_tokens 0 (Token t))))
  ^ Printf.sprintf "\nlast=%d" last

(*let indexed_token_record_to_xml i j t =
Wojciech Jaworski authored
33
  let lemma,pos,tags =
Wojciech Jaworski authored
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
    match t.token with
      Lemma(lemma,pos,tags) -> lemma,pos,tags
    | _ -> failwith "indexed_token_record_to_xml" in
  Xml.Element("token",["i",string_of_int i;"j",string_of_int j;
                       "beg",string_of_int t.beg;"len",string_of_int t.len;"weight",string_of_float t.weight],[
    Xml.Element("orth",[],[Xml.PCData t.orth]);
    Xml.Element("lemma",[],[Xml.PCData lemma]);
    Xml.Element("pos",[],[Xml.PCData pos]);
    Xml.Element("tags",[],Xlist.map tags (fun l ->
      Xml.Element("variant",[],[Xml.PCData (String.concat ":" (Xlist.map l (fun l2 -> String.concat "." l2)))])));
    Xml.Element("valence",[],Xlist.map t.valence WalXmlOf.num_frame);
    Xml.Element("senses",[],
      Xlist.map t.senses (fun (sense,hipero,weight) ->
        Xml.Element("sense",["name",sense;"weight",string_of_float weight],
          Xlist.map hipero (fun s -> Xml.Element("hipero",[],[Xml.PCData s])))))])
Wojciech Jaworski authored
49
50

let to_xml (paths,last) =
Wojciech Jaworski authored
51
52
  Xml.Element("paths",["last",string_of_int last],
    Xlist.map paths (fun (i,j,t) -> indexed_token_record_to_xml i j t))  *)
Wojciech Jaworski authored
53
Wojciech Jaworski authored
54
55
56
57
58
59
60
let compare_token_record p r =
  let v = compare p.beg r.beg in
  if v <> 0 then v else
  let v = compare p.next r.next in
  if v <> 0 then v else
  compare p r
Wojciech Jaworski authored
61
let sort (paths,last) =
Wojciech Jaworski authored
62
63
64
65
66
67
  Xlist.sort paths compare_token_record, last

let rec uniq_rec rev = function
    [] -> List.rev rev
  | [p] -> List.rev (p :: rev)
  | p :: r :: l -> if p = r then uniq_rec rev (r :: l) else uniq_rec (p :: rev) (r :: l)
Wojciech Jaworski authored
68
69

let uniq (paths,last) =
Wojciech Jaworski authored
70
  uniq_rec [] paths, last
Wojciech Jaworski authored
71
Wojciech Jaworski authored
72
73
74
75
let rec translate_into_paths_rec paths = function
    Token t -> t :: paths
  | Seq l -> Xlist.fold l paths translate_into_paths_rec
  | Variant l -> Xlist.fold l paths translate_into_paths_rec
Wojciech Jaworski authored
76
77
78

let translate_into_paths tokens =
  let paths = Xlist.fold tokens [] (fun paths token ->
Wojciech Jaworski authored
79
80
81
82
    translate_into_paths_rec paths token) in
  let last = if paths = [] then 0 else (List.hd paths).next in
  let paths = sort (paths,last) in
  let paths = uniq paths in
Wojciech Jaworski authored
83
84
  paths
Wojciech Jaworski authored
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
(**********************************************************************************)

let excluded_interps = StringSet.of_list [
  "praet:sg:f:ter:perf";
  "praet:sg:f:ter:imperf.perf";
  "praet:sg:f:ter:imperf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:ter:perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:ter:imperf.perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:ter:imperf";
  "praet:pl:m1.p1:ter:perf";
  "praet:pl:m1.p1:ter:imperf.perf";
  "praet:pl:m1.p1:ter:imperf";
  "praet:sg:m1.m2.m3:ter:perf";
  "praet:sg:m1.m2.m3:ter:imperf.perf";
  "praet:sg:m1.m2.m3:ter:imperf";
  "praet:sg:n1.n2:ter:perf";
  "praet:sg:n1.n2:ter:imperf.perf";
  "praet:sg:n1.n2:ter:imperf";
  "cond:sg:m1.m2.m3:ter:perf";
  "cond:sg:m1.m2.m3:ter:imperf.perf";
  "cond:sg:m1.m2.m3:ter:imperf";
  "cond:sg:m1.m2.m3:sec:perf";
  "cond:sg:m1.m2.m3:sec:imperf.perf";
  "cond:sg:m1.m2.m3:sec:imperf";
  "cond:sg:m1.m2.m3:pri:perf";
  "cond:sg:m1.m2.m3:pri:imperf.perf";
  "cond:sg:m1.m2.m3:pri:imperf";
  "cond:sg:m1.m2.m3:perf";
  "cond:sg:m1.m2.m3:imperf.perf";
  "cond:sg:m1.m2.m3:imperf";
  "cond:sg:f:ter:perf";
  "cond:sg:f:ter:imperf.perf";
  "cond:sg:f:ter:imperf";
  "cond:sg:f:sec:perf";
  "cond:sg:f:sec:imperf.perf";
  "cond:sg:f:sec:imperf";
  "cond:sg:f:pri:perf";
  "cond:sg:f:pri:imperf.perf";
  "cond:sg:f:pri:imperf";
  "cond:sg:f:perf";
  "cond:sg:f:imperf.perf";
  "cond:sg:f:imperf";
  "cond:sg:n1.n2:ter:perf";
  "cond:sg:n1.n2:ter:imperf.perf";
  "cond:sg:n1.n2:ter:imperf";
  "cond:sg:n1.n2:sec:perf";
  "cond:sg:n1.n2:sec:imperf.perf";
  "cond:sg:n1.n2:sec:imperf";
  "cond:sg:n1.n2:pri:perf";
  "cond:sg:n1.n2:pri:imperf.perf";
  "cond:sg:n1.n2:pri:imperf";
  "cond:sg:n1.n2:perf";
  "cond:sg:n1.n2:imperf.perf";
  "cond:sg:n1.n2:imperf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:ter:perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:ter:imperf.perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:ter:imperf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:sec:perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:sec:imperf.perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:sec:imperf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:pri:perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:pri:imperf.perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:pri:imperf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:imperf.perf";
  "cond:pl:m2.m3.f.n1.n2.p2.p3:imperf";
  "cond:pl:m1.p1:ter:perf";
  "cond:pl:m1.p1:ter:imperf.perf";
  "cond:pl:m1.p1:ter:imperf";
  "cond:pl:m1.p1:sec:perf";
  "cond:pl:m1.p1:sec:imperf.perf";
  "cond:pl:m1.p1:sec:imperf";
  "cond:pl:m1.p1:pri:perf";
  "cond:pl:m1.p1:pri:imperf.perf";
  "cond:pl:m1.p1:pri:imperf";
  "cond:pl:m1.p1:perf";
  "cond:pl:m1.p1:imperf.perf";
  "cond:pl:m1.p1:imperf";
  "winien:sg:n1.n2:ter:imperf";
  "winien:sg:n1.n2:sec:imperf";
  "winien:sg:n1.n2:pri:imperf";
(*   "winien:sg:n1.n2:imperf"; *)
  "winien:sg:m1.m2.m3:ter:imperf";
  "winien:sg:m1.m2.m3:sec:imperf";
  "winien:sg:m1.m2.m3:pri:imperf";
(*   "winien:sg:m1.m2.m3:imperf"; *)
  "winien:sg:f:ter:imperf";
  "winien:sg:f:sec:imperf";
  "winien:sg:f:pri:imperf";
(*   "winien:sg:f:imperf"; *)
  "winien:pl:m2.m3.f.n1.n2.p2.p3:ter:imperf";
  "winien:pl:m2.m3.f.n1.n2.p2.p3:sec:imperf";
  "winien:pl:m2.m3.f.n1.n2.p2.p3:pri:imperf";
(*   "winien:pl:m2.m3.f.n1.n2.p2.p3:imperf"; *)
  "winien:pl:m1.p1:ter:imperf";
  "winien:pl:m1.p1:sec:imperf";
  "winien:pl:m1.p1:pri:imperf";
(*   "winien:pl:m1.p1:imperf"; *)
  ]

let transformed_interps = Xlist.fold [
  "praet:sg:f:perf:agl","praet:sg:f:perf";
  "praet:sg:f:imperf.perf:agl","praet:sg:f:imperf.perf";
  "praet:sg:f:imperf:agl","praet:sg:f:imperf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:perf:agl","praet:pl:m2.m3.f.n1.n2.p2.p3:perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:imperf.perf:agl","praet:pl:m2.m3.f.n1.n2.p2.p3:imperf.perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:imperf:agl","praet:pl:m2.m3.f.n1.n2.p2.p3:imperf";
  "praet:pl:m1.p1:perf:agl","praet:pl:m1.p1:perf";
  "praet:pl:m1.p1:imperf.perf:agl","praet:pl:m1.p1:imperf.perf";
  "praet:pl:m1.p1:imperf:agl","praet:pl:m1.p1:imperf";
  "praet:sg:m1.m2.m3:perf:agl","praet:sg:m1.m2.m3:perf";
  "praet:sg:m1.m2.m3:imperf.perf:agl","praet:sg:m1.m2.m3:imperf.perf";
  "praet:sg:m1.m2.m3:imperf:agl","praet:sg:m1.m2.m3:imperf";
  "praet:sg:n1.n2:perf:agl","praet:sg:n1.n2:perf";
  "praet:sg:n1.n2:imperf.perf:agl","praet:sg:n1.n2:imperf.perf";
  "praet:sg:n1.n2:imperf:agl","praet:sg:n1.n2:imperf";
  "praet:sg:f:perf:nagl","praet:sg:f:perf";
  "praet:sg:f:imperf.perf:nagl","praet:sg:f:imperf.perf";
  "praet:sg:f:imperf:nagl","praet:sg:f:imperf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:perf:nagl","praet:pl:m2.m3.f.n1.n2.p2.p3:perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:imperf.perf:nagl","praet:pl:m2.m3.f.n1.n2.p2.p3:imperf.perf";
  "praet:pl:m2.m3.f.n1.n2.p2.p3:imperf:nagl","praet:pl:m2.m3.f.n1.n2.p2.p3:imperf";
  "praet:pl:m1.p1:perf:nagl","praet:pl:m1.p1:perf";
  "praet:pl:m1.p1:imperf.perf:nagl","praet:pl:m1.p1:imperf.perf";
  "praet:pl:m1.p1:imperf:nagl","praet:pl:m1.p1:imperf";
  "praet:sg:m1.m2.m3:perf:nagl","praet:sg:m1.m2.m3:perf";
  "praet:sg:m1.m2.m3:imperf.perf:nagl","praet:sg:m1.m2.m3:imperf.perf";
  "praet:sg:m1.m2.m3:imperf:nagl","praet:sg:m1.m2.m3:imperf";
  "praet:sg:n1.n2:perf:nagl","praet:sg:n1.n2:perf";
  "praet:sg:n1.n2:imperf.perf:nagl","praet:sg:n1.n2:imperf.perf";
  "praet:sg:n1.n2:imperf:nagl","praet:sg:n1.n2:imperf";
  ] StringMap.empty (fun map (k,v) -> StringMap.add map k v)
Wojciech Jaworski authored
217
Wojciech Jaworski authored
218
219
220
221
222
223
224
225
226
227
228
229
230
231
let merge_lemmata l =
  let map = Xlist.fold l StringMap.empty (fun map (lemma,interp,quantity,attrs) ->
    let interp = if interp = "num:comp" then "numc" else interp in
    if StringSet.mem excluded_interps interp then map else
    let interp = try StringMap.find transformed_interps interp with Not_found -> interp in
    let s = lemma ^ "#" ^ String.concat "|" attrs in
    StringMap.add_inc map s (lemma,quantity,[interp],attrs) (fun (_,q,l,_) -> lemma,q+quantity,interp :: l,attrs)) in
  let map = StringMap.map map (fun (lemma,quantity,interps,attrs) ->
    lemma,
    Xlist.fold interps StringMap.empty (fun map interp ->
      Xlist.fold (PreTokenizer.parse_postags interp) map (fun map (pos,tags) ->
        StringMap.add_inc map pos [tags] (fun l -> tags :: l))),
    max 1 (quantity / Xlist.size interps),
    attrs) in
Wojciech Jaworski authored
232
  StringMap.fold map [] (fun l _ (lemma,map,quantity,attrs) ->
Wojciech Jaworski authored
233
234
235
236
237
238
    StringMap.fold map l (fun l cat interp ->
      (lemma,cat,interp,quantity,attrs) :: l))

let uppercase lemma cl ll =
  let n = String.length lemma in
  let nll = String.length ll in
Wojciech Jaworski authored
239
240
241
  cl ^ String.sub lemma nll (n - nll)

let quant_mod quantity =
Wojciech Jaworski authored
242
  log10 (float quantity)
Wojciech Jaworski authored
243
244
245
246

let lemmatize_token = function
  | {token=AllSmall s} as t ->
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
247
         {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs=attrs @ t.attrs}))
Wojciech Jaworski authored
248
249
  | {token=SmallLetter s} as t ->
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
250
         {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs=attrs @ t.attrs}))
Wojciech Jaworski authored
251
252
  | {token=FirstCap(s,lower,cl,ll)} as t ->
       let l = Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
253
254
           {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs="notvalidated proper" :: attrs @ t.attrs}) in
       let b = Xlist.fold l false (fun b t -> if Xlist.mem t.attrs "lemma not validated" || Xlist.mem t.attrs "token not found" then b else true) in
Wojciech Jaworski authored
255
256
       if b then t :: l else
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations lower)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
257
           {t with token=Lemma(uppercase lemma cl ll,cat,interp); weight=t.weight+.(quant_mod quantity); attrs="notvalidated proper" :: "lemmatized as lowercase" :: attrs @ t.attrs}))
Wojciech Jaworski authored
258
259
  | {token=AllCap(s,_,_)} as t ->
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
260
         {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs="notvalidated proper" :: attrs @ t.attrs}))
Wojciech Jaworski authored
261
262
  | {token=CapLetter(s,_)} as t ->
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
263
         {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs="notvalidated proper" :: attrs @ t.attrs}))
Wojciech Jaworski authored
264
265
  | {token=SomeCap s} as t ->
       t :: (Xlist.map (merge_lemmata (Inflexion.get_interpretations s)) (fun (lemma,cat,interp,quantity,attrs) ->
Wojciech Jaworski authored
266
267
         {t with token=Lemma(lemma,cat,interp); weight=t.weight+.(quant_mod quantity); attrs="notvalidated proper" :: attrs @ t.attrs}))
  | t -> [t]
Wojciech Jaworski authored
268
269
270

let rec lemmatize_rec rev = function
    [] -> List.rev rev
Wojciech Jaworski authored
271
272
273
274
275
  | t :: l -> lemmatize_rec (lemmatize_token t @ rev) l

let lemmatize (paths,last) =
  List.rev (Xlist.fold (lemmatize_rec [] paths) [] (fun paths t ->
    match t.token with
Wojciech Jaworski authored
276
      Lemma _ -> if (Xlist.mem t.attrs "lemma not validated" || Xlist.mem t.attrs "token not found") &&
Wojciech Jaworski authored
277
278
279
        (Xlist.mem t.attrs "required validated lemmatization") then paths
        else t(*{t with attrs=List.remove "required validated lemmatization" t.attrs}*) :: paths
    | _ -> t :: paths)), last
Wojciech Jaworski authored
280
Wojciech Jaworski authored
281
282
283
284
285
(* TODO: docelowa lematyzacja:
- lematyzacja za pomocą półręcznie wytworzonych reguł lematyzacji i listy wyjątków
- walidacja lematów za pomocą listy znanych lematów zawierającej lemat, kategorię, rodzaj subst, aspekt verb (obejmuje też walidację akronimów)
- rozpoznawanie wyrażeń wielosłownych (mwe i mte) za pomocą listy zawierającej ich lematy i szablony odmiany
*)
Wojciech Jaworski authored
286
Wojciech Jaworski authored
287
(**********************************************************************************)
Wojciech Jaworski authored
288
Wojciech Jaworski authored
289
290

(**********************************************************************************)
Wojciech Jaworski authored
291
Wojciech Jaworski authored
292
(**********************************************************************************)
Wojciech Jaworski authored
293
294
295
Wojciech Jaworski authored
296
297
298
299
300
(*let rec get_beg_id = function
    Token t -> t.beg
  | Seq(t :: _) -> get_beg_id t
  | Variant(t :: _) -> get_beg_id t
  | _ -> failwith "get_beg_id"
Wojciech Jaworski authored
301
Wojciech Jaworski authored
302
303
304
305
306
307
let rec get_end_id = function
    Token t -> t.beg + t.len
  | Seq [] -> failwith "get_end_id"
  | Seq l -> get_end_id (List.hd (List.rev l))
  | Variant(t :: _) -> get_end_id t
  | _ -> failwith "get_end_id"*)
Wojciech Jaworski authored
308
Wojciech Jaworski authored
309
310
311
312
(*let rec lemmatize_tokens paths next_id = function
    Token({token=Dig(v,cat)} as t)-> PrePaths.add_edge paths t.beg next_id t.orth v (parse_postags cat) t.beg t.len
  | Token({token=Lemma(lemma,interp)} as t) -> PrePaths.add_edge paths t.beg next_id t.orth lemma (parse_postags interp) t.beg t.len
  | Token({token=Interp lemma} as t) -> PrePaths.add_edge paths t.beg next_id t.orth lemma (parse_postags "interp") t.beg t.len
Wojciech Jaworski authored
313
  | Token({token=AllSmall s} as t) ->
Wojciech Jaworski authored
314
315
316
317
318
319
320
321
322
323
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg next_id t.orth lemma (parse_postags postags) t.beg t.len)
  | Token({token=FirstCap(s,s2)} as t) -> (* FIXME: dodać wersję z s2 ; uporządkować słownik; dodać akronimy *)
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg next_id t.orth lemma (parse_postags postags) t.beg t.len)
  | Token _ -> paths
  | Seq [t] -> lemmatize_tokens paths next_id t
  | Seq(t :: next :: l) -> lemmatize_tokens (lemmatize_tokens paths (get_beg_id next) t) next_id (Seq(next :: l))
  | Seq [] -> failwith "lemmatize_tokens"
  | Variant l -> Xlist.fold l paths (fun paths t -> lemmatize_tokens paths next_id t)*)
Wojciech Jaworski authored
324
Wojciech Jaworski authored
325
326
(*let rec lemmatize_paths_tokens paths = function (* FIXME: uzgodnić postać lematów *)
    Token({token=Dig(v,cat)} as t)-> PrePaths.add_edge paths t.beg t.next t.orth v (parse_postags cat) t.attrs t.beg t.len
Wojciech Jaworski authored
327
  | Token({token=Lemma(lemma,interp)} as t) ->
Wojciech Jaworski authored
328
329
330
331
332
      if Xlist.mem t.attrs "lemmatized as lowercase" || Xlist.mem t.attrs "lemma not validated" then paths else (* FIXME *)
      PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags interp) t.attrs t.beg t.len
  | Token({token=Interp lemma} as t) -> PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags "interp") t.attrs t.beg t.len
  | Token({token=Proper _} as t) -> failwith "lemmatize_paths_tokens: ni"
  | Token({token=Compound _} as t) -> failwith "lemmatize_paths_tokens: ni"
Wojciech Jaworski authored
333
(*  | Token({token=AllSmall s} as t) ->
Wojciech Jaworski authored
334
335
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags postags) t.beg t.len)
Wojciech Jaworski authored
336
  | Token({token=SmallLetter s} as t) ->
Wojciech Jaworski authored
337
338
339
340
341
342
343
344
345
346
347
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags postags) t.beg t.len)
  | Token({token=FirstCap(s,s2)} as t) -> (* FIXME: dodać wersję z s2 ; uporządkować słownik; dodać akronimy *)
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags postags) t.beg t.len)
  | Token({token=CapLetter(s,s2)} as t) -> (* FIXME: dodać wersję z s2 ; uporządkować słownik; dodać akronimy *)
       Xlist.fold (Inflexion.get_interpretations s) paths (fun paths (lemma,postags) ->
         PrePaths.add_edge paths t.beg t.next t.orth lemma (parse_postags postags) t.beg t.len)*)
  | Token _ -> paths
  | Seq l -> Xlist.fold l paths (fun paths t -> lemmatize_paths_tokens paths t)
  | Variant l -> Xlist.fold l paths (fun paths t -> lemmatize_paths_tokens paths t)
Wojciech Jaworski authored
348
Wojciech Jaworski authored
349
350
351
352
(*let rec lemmatize paths = function
    t :: next :: l -> lemmatize (lemmatize_tokens paths (get_beg_id next) t) (next :: l)
  | [t] -> lemmatize_tokens paths (get_end_id t) t
  | [] -> failwith "lemmatize"*)
Wojciech Jaworski authored
353
Wojciech Jaworski authored
354
355
356
let rec lemmatize_paths paths = function
    t :: l -> lemmatize_paths (lemmatize_paths_tokens paths t) l
  | [] -> paths  *)
Wojciech Jaworski authored
357
Wojciech Jaworski authored
358
(* FIXME: dodać 'co do' prep:gen *)
Wojciech Jaworski authored
359
360
Wojciech Jaworski authored
361
362
363
364
365
366
367
(* Dane do przekazania:
- lematy i interpretacje: generowanie typów i termów
- orths
- początki i długości: decydują o wyświetlaniu struktury składnikowej (zwłaszcza niejednoznacznej)
- struktura grafu: wyróżniki przy niejednoznaczności
- sensy wraz z hiperonimami
- <indent> *)
Wojciech Jaworski authored
368
369

(*
Wojciech Jaworski authored
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
Ala zjadła kota.
Ala subst:sg:nom:f imię -> istota
kot subst:sg:nom:m2 pospolita - kot 2 - istota 1 istota żywa 1 zwierzę 1 strunowiec 1 czaszkowiec 1 kręgowiec 1 tetrapod 1 owodniowiec 1 ssak 1 ssak żyworodny 1 łożyskowiec 1 ssak drapieżny 1 kot 1 kot 2
zjeść - zjeść 1 - CZASOWNIK 1 CZASOWNIK należący do określonego pola leksykalnego 1 CZASOWNIK oznaczający sytuację związaną z reakcją organizmu lub czynnością fizjologiczną 1 CZASOWNIK - AKT oznaczający reakcję organizmu lub czynność fizjologiczne 1 zjeść 1

Ala -> common("imię")
Ala -> proper("istota")
kot -> common("kot 2")

czas 3 doba 1=dzień 2
czas 3 miesiąc 1
czas 3 rok 1 rok 2

czas 3 termin 1 dzień 3
data 1=termin 1

czas 3 pora roku 1 lato 1

punkt lub odcinek czasu w obrębie doby, określany na podstawie wskazań zegara
"o godzinie 15:20."
czas 3 godzina 4

do opisu czasu trwania:
jednostka czasu 1: godzina 3, sekunda 2, (minuta 4 - nie podłączona) dzień 2, miesiąc 1, rok 1/2
Wojciech Jaworski authored
395
396
397
398
*)

(**
Wojciech Jaworski authored
399
400
401
402
403
404
405
406
407
408
(* empty *)

let empty = IntMap.empty, 0, 0

let dict_empty = {lemmas=StringMap.empty; dbeg=0-1; dlen=0-1}

let poss_record_empty = {interp=[]; attrs=[]; proper=[]; senses=[]}

(* add *)
Wojciech Jaworski authored
409
let dict_add dict lemma postags attrs beg len =
Wojciech Jaworski authored
410
411
412
  if postags = [] then dict else
  let interps = try StringMap.find dict.lemmas lemma with Not_found -> StringMap.empty in
  let interps = Xlist.fold postags interps (fun interps (pos,tags) ->
Wojciech Jaworski authored
413
    StringMap.add_inc interps pos {poss_record_empty with interp=[tags]; attrs=attrs} (fun l ->
Wojciech Jaworski authored
414
415
416
417
418
419
420
421
422
423
424
425
426
      {l with interp=tags :: l.interp; attrs=StringSet.to_list (StringSet.union (StringSet.of_list l.attrs) (StringSet.of_list attrs))})) in
  if dict.dbeg <> beg && dict.dbeg <> -1 then failwith "dict_add" else
  if dict.dlen <> len && dict.dlen <> -1 then failwith "dict_add" else
  {lemmas=StringMap.add dict.lemmas lemma interps; dbeg=beg; dlen=len}

let add_simple map i j orth lemma postags attrs beg len =
  let map2 = try IntMap.find map i with Not_found -> IntMap.empty in
  let orths = try IntMap.find map2 j with Not_found -> StringMap.empty in
  let dict = try StringMap.find orths orth with Not_found -> dict_empty in
  let dict = dict_add dict lemma postags attrs beg len in
  let orths = StringMap.add orths orth dict in
  let map2 = IntMap.add map2 j orths in
  IntMap.add map i map2
Wojciech Jaworski authored
427
Wojciech Jaworski authored
428
429
let add_edge (map,last,n) i j orth lemma postags attrs beg len =
  add_simple map i j orth lemma postags attrs beg len, max j last, max j n
Wojciech Jaworski authored
430
Wojciech Jaworski authored
431
432
let rec add_path (map,last,n) i j = function
    [] -> failwith "add_path"
Wojciech Jaworski authored
433
  | [orth,lemma,postags,beg,len] ->
Wojciech Jaworski authored
434
     add_simple map i j orth lemma postags [] beg len, last, n
Wojciech Jaworski authored
435
  | (orth,lemma,postags,beg,len) :: l ->
Wojciech Jaworski authored
436
     add_path (add_simple map i (n+1) orth lemma postags [] beg len, last, n+1) (n+1) j l
Wojciech Jaworski authored
437
(*
Wojciech Jaworski authored
438
439
440
441
let insert (map,last,n) i j orth dict =
  let map2 = try IntMap.find map i with Not_found -> IntMap.empty in
  let orths = try IntMap.find map2 j with Not_found -> StringMap.empty in
  let orths = StringMap.add orths orth dict in
Wojciech Jaworski authored
442
  let map2 = IntMap.add map2 j orths in
Wojciech Jaworski authored
443
  IntMap.add map i map2, last, n
Wojciech Jaworski authored
444
Wojciech Jaworski authored
445
446
let rec insert_path (map,last,n) i j = function
    [] -> failwith "add_path"
Wojciech Jaworski authored
447
  | [orth,dict] ->
Wojciech Jaworski authored
448
     insert (map,last,n) i j orth dict
Wojciech Jaworski authored
449
  | (orth,dict) :: l ->
Wojciech Jaworski authored
450
     insert_path (insert (map,last,n+1) i (n+1) orth dict) (n+1) j l
Wojciech Jaworski authored
451
452

let set_sentence_begin (map,last,n) i j orth =
Wojciech Jaworski authored
453
454
455
456
457
458
  try
    let map2 = IntMap.find map i in
    let orths = IntMap.find map2 j in
    let dict = StringMap.find orths orth in
    let orths = StringMap.add orths orth {dict with sentence_begin=true} in
    let map2 = IntMap.add map2 j orths in
Wojciech Jaworski authored
459
    IntMap.add map i map2, last, n
Wojciech Jaworski authored
460
461
  with Not_found -> failwith "set_sentence_begin"
Wojciech Jaworski authored
462
let set_sentence_end (map,last,n) i j orth =
Wojciech Jaworski authored
463
464
465
466
467
468
  try
    let map2 = IntMap.find map i in
    let orths = IntMap.find map2 j in
    let dict = StringMap.find orths orth in
    let orths = StringMap.add orths orth {dict with sentence_end=true} in
    let map2 = IntMap.add map2 j orths in
Wojciech Jaworski authored
469
    IntMap.add map i map2, last, n
Wojciech Jaworski authored
470
471
  with Not_found -> failwith "set_sentence_end"
Wojciech Jaworski authored
472
let is_sentence_end (map,last,n) i j orth =
Wojciech Jaworski authored
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
  try
    let map2 = IntMap.find map i in
    let orths = IntMap.find map2 j in
    let dict = StringMap.find orths orth in
    dict.sentence_end
  with Not_found -> failwith "is_sentence_end"

let manage_sentence_end (map,last,n) =
  IntMap.map map (fun map2 ->
    IntMap.map map2 (fun orths ->
      StringMap.fold orths StringMap.empty (fun orths orth dict ->
        if orth = ".last_node" then StringMap.add orths "." {dict with sentence_end=true}
        else StringMap.add orths orth dict))),last,n

(* other *)

let remove (map,last,n) i j orth =
  try
    let map2 = IntMap.find map i in
    let orths = IntMap.find map2 j in
    let orths = StringMap.remove orths orth in
    let map2 = if StringMap.is_empty orths then IntMap.remove map2 j else IntMap.add map2 j orths in
    (if IntMap.is_empty map2 then IntMap.remove map i else IntMap.add map i map2), last, n
  with Not_found -> map,last,n


let rec find_paths_bound (map,last,n) k i =
  if i = last || k = 0 then [[]] else
  if not (IntMap.mem map i) then failwith "find_paths_bound" else
  IntMap.fold (IntMap.find map i) [] (fun paths j set ->
    let tails = find_paths_bound (map,last,n) (k-1) j in
    StringMap.fold set paths (fun paths s _ ->
      Xlist.fold tails paths (fun paths tail -> (s :: tail) :: paths)))
Wojciech Jaworski authored
506
Wojciech Jaworski authored
507
508
509
510
511
512
513
let rec find_paths_rec (map,last,n) i =
  if i = last then [[]] else
  if not (IntMap.mem map i) then failwith "find_paths_rec" else
  IntMap.fold (IntMap.find map i) [] (fun paths j set ->
    let tails = find_paths_rec (map,last,n) j in
    StringMap.fold set paths (fun paths s _ ->
      Xlist.fold tails paths (fun paths tail -> (s :: tail) :: paths)))
Wojciech Jaworski authored
514
Wojciech Jaworski authored
515
516
let find_paths (map,last,n) =
  find_paths_rec (map,last,n) 0
Wojciech Jaworski authored
517
518
*)
let has_lemma orths =
Wojciech Jaworski authored
519
520
  StringMap.fold orths false (fun b _ dict ->
    if StringMap.is_empty dict.lemmas then b else true)
Wojciech Jaworski authored
521
Wojciech Jaworski authored
522
523
524
525
526
527
528
let rec no_possible_path_rec map last i =
  if last = i then false else
  let map2 = try IntMap.find map i with Not_found -> IntMap.empty in
  IntMap.fold map2 true (fun b j orths ->
    if has_lemma orths then
      b && no_possible_path_rec map last j
    else b)
Wojciech Jaworski authored
529
Wojciech Jaworski authored
530
531
let no_possible_path (map,last,n) =
  no_possible_path_rec map last 0
Wojciech Jaworski authored
532
(*
Wojciech Jaworski authored
533
let rec match_path_rec map found i rev = function
Wojciech Jaworski authored
534
    [] -> (i :: rev) :: found
Wojciech Jaworski authored
535
536
537
538
539
  | s :: l ->
     let map2 = try IntMap.find map i with Not_found -> IntMap.empty in
     let found2 = IntMap.fold map2 [] (fun found2 j set ->
       if StringMap.mem set s then j :: found2 else found2) in
     Xlist.fold found2 found (fun found j -> match_path_rec map found j (i :: rev) l)
Wojciech Jaworski authored
540
Wojciech Jaworski authored
541
542
let match_path (map,last,n) = function
    [] -> failwith "match_path"
Wojciech Jaworski authored
543
  | s :: l ->
Wojciech Jaworski authored
544
545
546
547
548
     let found = IntMap.fold map [] (fun found i map2 ->
       IntMap.fold map2 found (fun found j set ->
         if StringMap.mem set s then (i,j) :: found else found)) in
     Xlist.fold found [] (fun found (i,j) -> match_path_rec map found j [i] l)
Wojciech Jaworski authored
549
let get_matched orths = function
Wojciech Jaworski authored
550
551
552
553
554
555
556
    Orth s -> if StringMap.mem orths s then [s] else []
  | Pos s -> (*print_endline ("a1 " ^ s);*) StringSet.to_list (StringMap.fold orths StringSet.empty (fun set orth dict ->
      StringMap.fold dict.lemmas set (fun set lemma interps ->
        StringMap.fold interps set (fun set pos _ ->
(*           print_endline ("a2 " ^ pos);  *)
          if s = pos then StringSet.add set orth else set))))
(*   | All -> orths *)
Wojciech Jaworski authored
557
Wojciech Jaworski authored
558
let rec match_path_ex_rec map found i rev = function
Wojciech Jaworski authored
559
    [] -> ((i,[]) :: rev) :: found
Wojciech Jaworski authored
560
561
562
563
564
565
  | s :: l ->
     let map2 = try IntMap.find map i with Not_found -> IntMap.empty in
     let found2 = IntMap.fold map2 [] (fun found2 j orths ->
       let l = get_matched orths s in
       if l <> [] then (j,l) :: found2 else found2) in
     Xlist.fold found2 found (fun found (j,l2) -> match_path_ex_rec map found j ((i,l2) :: rev) l)
Wojciech Jaworski authored
566
Wojciech Jaworski authored
567
568
let match_path_ex (map,last,n) = function
    [] -> failwith "match_path_ex"
Wojciech Jaworski authored
569
  | s :: l ->
Wojciech Jaworski authored
570
571
572
573
574
575
576
577
578
579
580
     let found = IntMap.fold map [] (fun found i map2 ->
       IntMap.fold map2 found (fun found j orths ->
       let l = get_matched orths s in
       if l <> [] then (i,j,l) :: found else found)) in
     Xlist.fold found [] (fun found (i,j,l2) -> (*print_endline ("b1 " );*) match_path_ex_rec map found j [i,l2] l)

let last_node (_,last,_) = last

let set_last_node (map,last,n) new_last = map, new_last, n

let find (map,last,n) i =
Wojciech Jaworski authored
581
  try
Wojciech Jaworski authored
582
583
584
585
586
587
    IntMap.fold (IntMap.find map i) [] (fun found j orths ->
      StringMap.fold orths found (fun found orth _ ->
        (i,j,orth) :: found))
  with Not_found -> []

let find_full (map,last,n) i =
Wojciech Jaworski authored
588
  try
Wojciech Jaworski authored
589
590
591
592
593
    IntMap.fold (IntMap.find map i) [] (fun found j orths ->
      StringMap.fold orths found (fun found orth dict ->
        (i,j,orth,dict) :: found))
  with Not_found -> []
*)
Wojciech Jaworski authored
594
let fold (map,last,n) s f =
Wojciech Jaworski authored
595
596
597
598
  IntMap.fold map s (fun s i map2 ->
    IntMap.fold map2 s (fun s j set ->
      StringMap.fold set s (fun s orth lemmas ->
        f s orth i j lemmas)))
Wojciech Jaworski authored
599
600
(*
let map (map,last,n) f =
Wojciech Jaworski authored
601
602
603
604
  IntMap.map map (fun map2 ->
    IntMap.map map2 (fun orths ->
      StringMap.map orths (fun lemmas ->
        f lemmas))), last, n
Wojciech Jaworski authored
605
606

let mapi (map,last,n) f =
Wojciech Jaworski authored
607
608
609
610
  IntMap.mapi map (fun i map2 ->
    IntMap.mapi map2 (fun j orths ->
      StringMap.mapi orths (fun orth lemmas ->
        f orth i j lemmas))), last, n
Wojciech Jaworski authored
611
612

let get_edges (map,_,_) i j =
Wojciech Jaworski authored
613
  IntMap.find (IntMap.find map i) j
Wojciech Jaworski authored
614
615

let get_edges_from (map,_,_) i =
Wojciech Jaworski authored
616
  IntMap.find map i
Wojciech Jaworski authored
617
*)
Wojciech Jaworski authored
618
let rec topological_sort_rec map visited l i =
Wojciech Jaworski authored
619
  if IntSet.mem visited i then (l,visited) else
Wojciech Jaworski authored
620
621
622
  let l, visited = IntMap.fold (try IntMap.find map i with Not_found -> IntMap.empty) (l,IntSet.add visited i) (fun (l,visited) j _ ->
    topological_sort_rec map visited l j) in
  i :: l, visited
Wojciech Jaworski authored
623
Wojciech Jaworski authored
624
625
626
627
628
629
630
631
632
let topological_sort (map,last,n) =
  let l, _ = topological_sort_rec map IntSet.empty [] 0 in
  let translation, k = Xlist.fold l (IntMap.empty,0) (fun (translation,k) i ->
    IntMap.add translation i k, k+1) in
  let map = IntMap.fold map IntMap.empty (fun map i map2 ->
    let map2 = IntMap.fold map2 IntMap.empty (fun map2 j orths ->
      try IntMap.add map2 (IntMap.find translation j) orths with Not_found -> map2) in
    try IntMap.add map (IntMap.find translation i) map2 with Not_found -> map) in
  map, (try IntMap.find translation last with Not_found -> failwith "topological_sort 3"), k-1
Wojciech Jaworski authored
633
Wojciech Jaworski authored
634
635
636
(*let interp_to_string interp =
  String.concat " " (Xlist.fold interp.interp [] (fun l tags ->
    (String.concat ":" (Xlist.map tags (String.concat "."))) :: l))
Wojciech Jaworski authored
637
Wojciech Jaworski authored
638
639
640
let interps_to_string interps =
  String.concat " " (StringMap.fold interps [] (fun l pos interp ->
    (pos ^ "[" ^ interp_to_string interp ^ "]") :: l))
Wojciech Jaworski authored
641
Wojciech Jaworski authored
642
643
644
let lemmas_to_string lemmas =
  String.concat " " (StringMap.fold lemmas [] (fun l lemma interps ->
    (lemma ^ "[" ^ interps_to_string interps ^ "]") :: l))
Wojciech Jaworski authored
645
646

let to_string (map,last,n) =
Wojciech Jaworski authored
647
648
  let l = IntMap.fold map [] (fun l i map2 ->
    IntMap.fold map2 l (fun l j orths ->
Wojciech Jaworski authored
649
      (Printf.sprintf "%5d %5d %s" i j (String.concat " " (StringMap.fold orths [] (fun l2 orths dict ->
Wojciech Jaworski authored
650
651
         (Printf.sprintf "%s %5d %5d [%s]" orths dict.dbeg dict.dlen (lemmas_to_string dict.lemmas)) :: l2)))) :: l)) in
  Printf.sprintf "last=%d n=%d\n  %s" last n (String.concat "\n  " (List.sort compare l))*)
Wojciech Jaworski authored
652
653
    (*
let make_unique_orths (map,last,n) =
Wojciech Jaworski authored
654
655
656
657
658
659
660
  let names = fold (map,last,n) StringQMap.empty (fun names orth _ _ _ ->
    StringQMap.add names orth) in
  let names = StringQMap.fold names StringSet.empty (fun names name n ->
    if n = 1 (*|| name = "."*) then names else StringSet.add names name) in (* FIXME: trzeba dodać usuwanie wszystkich orth zdefiniowanych w leksykonach POLFIE *)
  let map,_ = IntMap.fold map (IntMap.empty,StringMap.empty) (fun (map,used) i map2 ->
    let map2,used = IntMap.fold map2 (IntMap.empty,used) (fun (map2,used) j orths ->
      let orths,used = StringMap.fold orths (StringMap.empty,used) (fun (orths,used) orth lemmas ->
Wojciech Jaworski authored
661
        let orth,used =
Wojciech Jaworski authored
662
          if StringSet.mem names orth then
Wojciech Jaworski authored
663
664
            let n =
              try StringMap.find used orth + 1
Wojciech Jaworski authored
665
666
667
668
669
670
671
672
              with Not_found -> 1 in
            orth ^ "-" ^ string_of_int n, StringMap.add used orth n
          else orth,used in
        StringMap.add orths orth lemmas, used) in
      IntMap.add map2 j orths, used) in
    IntMap.add map i map2, used) in
  map,last,n
Wojciech Jaworski authored
673
674
675
*)

**)