ENIAMwalTEI.ml 52.7 KB

Edit Raw Blame History

(*
 *  ENIAMwalenty, an interface for Polish Valence Dictionary "Walenty".
 *  Copyright (C) 2016 Wojciech Jaworski <wjaworski atSPAMfree mimuw dot edu dot pl>
 *  Copyright (C) 2016 Institute of Computer Science Polish Academy of Sciences
 *
 *  This library is free software: you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License as published by
 *  the Free Software Foundation, either version 3 of the License, or
 *  (at your option) any later version.
 *
 *  This library 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 Lesser General Public License for more details.
 *
 *  You should have received a copy of the GNU Lesser General Public License
 *  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

open ENIAMwalTypes

let parse_id s =
  if String.length s = 0 then empty_id else
  if String.length s < 6 then failwith "za krótkie id"  else
    let hash,s = if (String.get s 0) = '#' then true, String.sub s 1 (String.length s - 1) else false, s in
    if String.sub s 0 4 <> "wal_" then failwith "id nie ma wal" else
      let s,suf = match Str.split (Str.regexp "-") s with
          [s;suf] -> s,suf
        | _ -> failwith "zła ilość '-'" in
      let id = {hash = hash; suffix = suf; numbers = Xstring.split "\\." s} in
      id

(*let parse_id s =
  if String.length s = 0 then empty_id else
  if String.length s < 6 then failwith "za krótkie id"  else
    let hash,s = if (String.get s 0) = '#' then true, String.sub s 1 (String.length s - 1) else false, s in
    if String.sub s 0 4 <> "wal_" then failwith "id nie ma wal" else
      let s,suf = match Str.split (Str.regexp "-") s with
          [s;suf] -> s,suf
        | _ -> failwith "zła ilość '-'" in
      let id = {hash = hash; suffix = suf; numbers = (Str.split (Str.regexp "\\.") s)} in
      {id with numbers = [last id.numbers]}*)

type tei =
    Symbol of string
  | TEIstring of string
  | Binary of bool
  | Numeric of int
  | F of string * tei
  | Fset of string * tei list
  | Fs of string * tei list
  | Id of id
  | SameAs of id * string

let rec tei_to_string = function
    Symbol s -> Printf.sprintf "Symbol %s" s
  | TEIstring s -> Printf.sprintf "String %s" s
  | Binary b -> Printf.sprintf "Binary %s" (string_of_bool b)
  | Numeric n -> Printf.sprintf "Numeric %d" n
  | F(s,t) -> Printf.sprintf "F(%s,%s)" s (tei_to_string t)
  | Fset(s,l) -> Printf.sprintf "Fset(%s,[%s])" s (String.concat ";" (Xlist.map l tei_to_string))
  | Fs(s,l) -> Printf.sprintf "Fs(%s,[%s])" s (String.concat ";" (Xlist.map l tei_to_string))
  | Id id -> Printf.sprintf "Id"
  | SameAs(id,s) -> Printf.sprintf "F(Id,%s)" s

let rec parse_tei = function
    Xml.Element("f",["name",name],[Xml.Element("vColl",["org","set"],set)]) ->
    Fset(name,List.rev (Xlist.map set parse_tei))
  | Xml.Element("f", ["name",name],[]) -> Fset(name,[])
  | Xml.Element("f", ["name",name],[tei]) -> F(name,parse_tei tei)
  | Xml.Element("f", ["name",name],set) -> Fset(name,List.rev (Xlist.map set parse_tei))
  | Xml.Element("fs", ["type",name], l) -> Fs(name,List.rev (Xlist.rev_map l parse_tei))
  | Xml.Element("fs", ["xml:id",id;"type",name], l) -> Fs(name,Id(parse_id id) :: List.rev (Xlist.rev_map l parse_tei))
  | Xml.Element("symbol",["value",value],[]) -> Symbol value
  | Xml.Element("string",[], [Xml.PCData s]) -> TEIstring s
  | Xml.Element("string",[], []) -> TEIstring ""
  | Xml.Element("binary",["value",value],[]) -> Binary(try bool_of_string value with _ -> failwith "parse_tei")
  | Xml.Element("numeric",["value",value],[]) -> Numeric(try int_of_string value with _ -> failwith "parse_tei")
  | Xml.Element("fs", ["sameAs", same_as; "type",name], []) -> SameAs(parse_id same_as,name)
  | Xml.Element("fs", ["sameAs", same_as], []) -> SameAs(parse_id same_as,"")
  | xml -> failwith ("parse_tei: " ^ Xml.to_string_fmt xml)

let parse_gf = function
    "subj" -> SUBJ
  | "obj" -> OBJ
  | s -> failwith ("parse_gf: " ^ s)

let parse_control arg = function
    "controller" -> {arg with cr="1" :: arg.cr}
  | "controllee" -> {arg with ce="1" :: arg.cr}
  | "controller2" -> {arg with cr="2" :: arg.cr}
  | "controllee2" -> {arg with ce="2" :: arg.cr}
  | s -> failwith ("parse_control: " ^ s)

let parse_case = function
    "nom" -> Case "nom"
  | "gen" -> Case "gen"
  | "dat" -> Case "dat"
  | "acc" -> Case "acc"
  | "inst" -> Case "inst"
  | "loc" -> Case "loc"
  | "str" -> Str
  | "pred" -> Case "pred"
  | "part" -> Part
  | "postp" -> Case "postp"
  | "agr" -> CaseAgr
  | s -> failwith ("parse_case: " ^ s)

let parse_aspect = function
    "perf" -> Aspect "perf"
  | "imperf" -> Aspect "imperf"
  | "_" -> AspectUndef
  | "" -> AspectNA
  | s -> failwith ("parse_aspect: " ^ s)

let parse_negation = function
    "_" -> NegationUndef
  | "neg" -> Negation
  | "aff" -> Aff
  | "" -> NegationNA
  | s -> failwith ("parse_negation: " ^ s)

let parse_number = function
    "sg" -> Number "sg"
  | "pl" -> Number "pl"
  | "agr" -> NumberAgr
  | "_" -> NumberUndef
  | s -> failwith ("parse_number: " ^ s)

let parse_gender = function
    "m1" -> Gender "m1"
  | "m3" -> Gender "m3"
  | "n" -> Genders["n1";"n2"]
  | "f" -> Gender "f"
  | "m1.n" -> Genders["m1";"n1";"n2"]
  | "_" -> GenderUndef
  | "agr" -> GenderAgr
  | s -> failwith ("parse_gender: " ^ s)

let parse_grad = function
    "pos" -> Grad "pos"
  | "com" -> Grad "com"
  | "sup" -> Grad "sup"
  | "_" -> GradUndef
  | s -> failwith ("parse_grad: " ^ s)

let rec parse_restr = function
    "natr" -> Natr
  | "atr" -> Atr
  | "ratr" -> Ratr
  | "atr1" -> Atr1
  | "ratr1" -> Ratr1
  | s -> failwith ("parse_restr: " ^ s)


let parse_comp = function
    "int" -> Int,[]
  | "rel" -> Rel,[]
  | "co" -> CompTypeUndef,[Comp "co"] (* subst qub prep comp *)
  | "kto" -> CompTypeUndef,[Comp "kto"] (* subst *)
  | "ile" -> CompTypeUndef,[Comp "ile"] (* num adv *)
  | "jaki" -> CompTypeUndef,[Comp "jaki"] (* adj *)
  | "który" -> CompTypeUndef,[Comp "który"] (* adj *)
  | "czyj" -> CompTypeUndef,[Comp "czyj"] (* adj *)
  | "jak" -> CompTypeUndef,[Comp "jak"] (* prep conj adv *)
  | "kiedy" -> CompTypeUndef,[Comp "kiedy"] (* comp adv *)
  | "gdzie" -> CompTypeUndef,[Comp "gdzie"] (* qub adv *)
  | "odkąd" -> CompTypeUndef,[Comp "odkąd"] (* adv *)
  | "skąd" -> CompTypeUndef,[Comp "skąd"] (* adv *)
  | "dokąd" -> CompTypeUndef,[Comp "dokąd"] (* adv *)
  | "którędy" -> CompTypeUndef,[Comp "którędy"] (* adv *)
  | "dlaczego" -> CompTypeUndef,[Comp "dlaczego"] (* adv *)
  | "czemu" -> CompTypeUndef,[Comp "czemu"] (* adv *)
  | "czy" -> CompTypeUndef,[Comp "czy"] (* qub conj *)
  | "jakby" -> CompTypeUndef,[Comp "jakby"] (* qub comp *)
  | "jakoby" -> CompTypeUndef,[Comp "jakoby"] (* qub comp *)
  | "gdy" -> CompTypeUndef,[Gdy] (* adv; gdyby: qub comp *)
  | "dopóki" -> CompTypeUndef,[Comp "dopóki"] (* comp *)
  | "zanim" -> CompTypeUndef,[Comp "zanim"] (* comp *)
  | "jeśli" -> CompTypeUndef,[Comp "jeśli"] (* comp *)
  | "żeby2" -> CompTypeUndef,[Zeby]
  | "żeby" -> CompTypeUndef,[Comp "żeby"] (* qub comp *)
  | "że" -> CompTypeUndef,[Comp "że"] (* qub comp *)
  | "aż" -> CompTypeUndef,[Comp "aż"] (* qub comp *)
  | "bo" -> CompTypeUndef,[Comp "bo"] (* qub comp *)
  | s -> failwith ("parse_comp: " ^ s)

let load_type_constrains = function
  | Symbol value ->
    (match parse_comp value with
       CompTypeUndef,[c] -> c
     | _ -> failwith "load_type_constrains")
  | xml -> failwith ("load_type_constrains:\n " ^ tei_to_string xml)

let load_ctype = function
  | F("type",Fs("type_def", x)) ->
    (match x with
     | [F("conjunction",Symbol value)] -> parse_comp value
     | [F("conjunction",Symbol value);Fset("constraints",set)] ->
       (match parse_comp value with
          CompTypeUndef, _ -> failwith "load_ctype"
        | ctype,[] -> ctype, List.rev (Xlist.rev_map set load_type_constrains)
        | _ -> failwith "load_ctype")
     | l -> failwith ("load_ctype 2:\n " ^ String.concat "\n" (Xlist.map l tei_to_string)))
  | xml -> failwith ("load_ctype:\n " ^ tei_to_string xml)
(*Printf.printf "%s\n" (tei_to_string xml)*)

let load_lemmas_set = function
  | TEIstring mstring -> mstring
  | xml -> failwith ("load_lemmas_set:\n " ^ tei_to_string xml)

let check_lemma s =
  match Str.full_split (Str.regexp "(\\|)") s with
    [Str.Text s] -> Lexeme s
  | [Str.Text "E"; Str.Delim "("; Str.Text g; Str.Delim ")"] -> Elexeme(parse_gender g)
  | _ -> failwith "check_lemma"

let make_lemma = function
  | _,_,[lemma] -> check_lemma lemma
  | "XOR","concat",lemmas -> XOR(Xlist.map lemmas check_lemma)
  | "OR","coord",lemmas -> ORcoord(Xlist.map lemmas check_lemma)
  | "OR","concat",lemmas -> ORconcat(Xlist.map lemmas check_lemma)
  | _ -> failwith "make_lemma"

let process_lex_phrase lemma = function
    NP(case),number,GenderUndef,GradUndef,NegationUndef,ReflUndef -> [SUBST(number,case),lemma]
  | PrepNP(prep,case),number,GenderUndef,GradUndef,NegationUndef,ReflUndef -> [PREP case,Lexeme prep;SUBST(number,case),lemma]
  | AdjP(case),number,gender,grad,NegationUndef,ReflUndef -> [ADJ(number,case,gender,grad),lemma]
  | PrepAdjP(prep,case),number,gender,grad,NegationUndef,ReflUndef -> [PREP case,Lexeme prep;ADJ(number,case,gender,grad),lemma]
  | InfP(aspect),NumberUndef,GenderUndef,GradUndef,negation,refl -> [INF(aspect,negation,refl),lemma]
  | PpasP(case),number,gender,GradUndef,negation,ReflUndef -> [PPAS(number,case,gender,AspectUndef,negation),lemma]
  | PrepPpasP(prep,case),number,gender,GradUndef,negation,ReflUndef -> [PREP case,Lexeme prep;PPAS(number,case,gender,AspectUndef,negation),lemma]
  | PactP(case),number,gender,GradUndef,negation,refl -> [PACT(number,case,gender,AspectUndef,negation,refl),lemma]
  | PrepGerP(prep,case),number,GenderUndef,GradUndef,negation,refl -> [PREP case,Lexeme prep;GER(number,case,GenderUndef,AspectUndef,negation,refl),lemma]
  | Qub,NumberUndef,GenderUndef,GradUndef,NegationUndef,ReflUndef -> [QUB,lemma]
  | AdvP,NumberUndef,GenderUndef,grad,NegationUndef,ReflUndef -> [ADV grad,lemma]
  | phrase,number,gender,grad,negation,reflex ->
    Printf.printf "%s %s %s %s %s %s\n" (ENIAMwalStringOf.phrase phrase) (ENIAMwalStringOf.number number)
      (ENIAMwalStringOf.gender gender) (ENIAMwalStringOf.grad grad) (ENIAMwalStringOf.negation negation) (ENIAMwalStringOf.refl reflex); []

let new_schema r cr ce morfs =
  {psn_id=empty_id; gf=r; role=""; role_attr="";sel_prefs=[]; cr=cr; ce=ce; dir=Both; morfs=morfs}

let rec process_lex lex = function
  | PhraseAbbr(ComparP prep,[]),arguments,Lexeme "",Lexeme "" ->
    LexPhrase([COMPAR,Lexeme prep],(Ratrs,Xlist.map arguments (fun morf -> new_schema ARG [] [] [empty_id,morf])))
  | PhraseAbbr(Xp mode,[argument]),_,_,_ ->
    let lex = {lex with lex_argument=argument} in
    (match process_lex lex (lex.lex_argument,lex.lex_arguments,lex.lex_lemma,lex.lex_numeral_lemma) with
       LexPhrase(poss,mods) -> LexPhraseMode(mode,poss,mods)
     | LexPhraseMode(mode2,poss,mods) ->
       if mode <> mode2 then failwith "process_lex: multiple modes" else LexPhraseMode(mode,poss,mods)
     | _ -> failwith "process_lex")
  | PhraseAbbr(Advp mode,[]),[],lemma,Lexeme ""  ->
    let poss = process_lex_phrase lemma (AdvP,lex.lex_number,lex.lex_gender,lex.lex_degree,lex.lex_negation,lex.lex_reflex) in
    LexPhraseMode(mode,poss,lex.lex_modification)
  | Phrase (NumP(case)),[],lemma,num_lemma -> LexPhrase([NUM(case,GenderUndef,AcmUndef),num_lemma;SUBST(NumberUndef,CaseUndef),lemma],lex.lex_modification)
  | Phrase (PrepNumP(prep,case)),[],lemma,num_lemma  -> LexPhrase([PREP case,Lexeme prep;NUM(case,GenderUndef,AcmUndef),num_lemma;SUBST(NumberUndef,CaseUndef),lemma],lex.lex_modification)
  | PhraseComp(Cp,(ctype,[Comp comp])),[],lemma,Lexeme "" -> LexPhrase([COMP ctype,Lexeme comp;PERS(lex.lex_negation,lex.lex_reflex),lemma],lex.lex_modification)
  | PhraseComp(Cp,(ctype,[Comp comp1;Comp comp2])),[],lemma,Lexeme "" -> LexPhrase([COMP ctype,XOR[Lexeme comp1;Lexeme comp2];PERS(lex.lex_negation,lex.lex_reflex),lemma],lex.lex_modification)
  | Phrase phrase,[],lemma,Lexeme ""  ->
    let poss = process_lex_phrase lemma (phrase,lex.lex_number,lex.lex_gender,lex.lex_degree,lex.lex_negation,lex.lex_reflex) in
    LexPhrase(poss,lex.lex_modification)
  | (argument,arguments,lemma,numeral_lemma) ->
    let s = Printf.sprintf "%s [%s] %s %s\n" (ENIAMwalStringOf.morf argument)
      (String.concat ";" (Xlist.map arguments ENIAMwalStringOf.morf))
      (ENIAMwalStringOf.lex lemma) (ENIAMwalStringOf.lex numeral_lemma) in
    failwith ("process_lex: " ^ s)

let rec load_category = function
  | F("category",Fs("category_def",x)) ->
    (match x with
     | [F("name",Symbol value)] -> value, []
     | [F("name",Symbol value);Fset("constraints",set)] ->
       value, List.rev (Xlist.rev_map set (fun s -> snd (load_phrase s)))
     | l -> failwith ("load_category 2:\n " ^ String.concat "\n" (Xlist.map l tei_to_string)))
  | xml -> failwith ("load_category:\n " ^ tei_to_string xml)

and load_modification_def = function (*pomocnicza do load_lex *)
  | [F("type",Symbol value)] -> parse_restr value, []
  | [F("type",Symbol value); Fset("positions",set)] ->
    parse_restr value, List.rev (Xlist.rev_map set load_position)
  | x -> Printf.printf "%s\n" (tei_to_string (List.hd x));
    failwith "load_modification_def:\n"

and load_lex arg xml = match xml with (* wzajemnie rekurencyjne z load_phrase*)
  | F("argument",set) -> {arg with lex_argument = snd (load_phrase set)}
  | Fset("arguments",set) ->
    {arg with lex_arguments=List.rev (Xlist.fold set [] (fun l s -> (snd (load_phrase s)) :: l))}
  | F("modification",Fs("modification_def",x)) -> {arg with lex_modification = load_modification_def x}
  | F("lemma",Fs("lemma_def",[F("selection_mode",Symbol value1);
                              F("cooccurrence",Symbol value2);
                              Fset("lemmas",lemmas)])) ->
    {arg with lex_lemma = make_lemma (value1, value2, List.rev (Xlist.rev_map lemmas load_lemmas_set))}
  |  F("numeral_lemma",Fs("numeral_lemma_def",[F("selection_mode",Symbol value1);
                                               F("cooccurrence",Symbol value2);
                                               Fset("lemmas",lemmas)])) ->
    {arg with lex_numeral_lemma = make_lemma (value1, value2, List.rev (Xlist.rev_map lemmas load_lemmas_set))}
  | F("negation",Symbol value) -> {arg with lex_negation = parse_negation value}
  | F("degree",Symbol value) -> {arg with lex_degree = parse_grad value}
  | F("number",Symbol value) -> {arg with lex_number = parse_number value}
  | F("reflex",Binary true) -> {arg with lex_reflex = ReflTrue}
  | F("reflex",Binary false) -> {arg with lex_reflex = ReflFalse}
  | Fset("reflex",[]) -> {arg with lex_reflex = ReflEmpty}
  | Fset("gender",[Symbol value]) -> {arg with lex_gender = parse_gender value}
  | xml ->
    Printf.printf "%s\n" (tei_to_string xml);
    failwith "load_lex:\n "

and load_phrase xml:id * morf =
  let id, idtype, x =
    match xml with
    | Fs(_idtype,Id _id :: _x) -> (_id, _idtype, _x)
    | Fs(_idtype, _x) -> (empty_id, _idtype, _x)
    | _ -> failwith "load_phrase let id,idtype...\n" in
  match idtype, x with
  | "np",[F("case",Symbol a)] -> id, Phrase (NP(parse_case a));
  | "prepnp", [F("preposition",Symbol a);F("case",Symbol b)] -> id, Phrase (PrepNP(a, parse_case b))
  | "adjp", [F("case",Symbol a)] -> id, Phrase (AdjP(parse_case a))
  | "prepadjp", [F("preposition",Symbol a);F("case",Symbol b)] -> id, Phrase (PrepAdjP(a, parse_case b))
  | "comprepnp", [e;F("complex_preposition",TEIstring a)] -> id, Phrase (ComprepNP(a))
  | "comprepnp", [F("complex_preposition",TEIstring a)] -> id, Phrase (ComprepNP(a))
  | "cp", [a] -> id, PhraseComp(Cp,load_ctype a)
  | "ncp", [F("case",Symbol a);b] -> id, PhraseComp(Ncp(parse_case a),load_ctype b)
  | "prepncp", [F("preposition",Symbol a);F("case",Symbol b);c] -> id, PhraseComp(Prepncp(a, parse_case b),load_ctype c)
  | "infp", [F("aspect",Symbol a)] -> id, Phrase (InfP(parse_aspect a))
  | "xp", [a] -> let x,y = load_category a in id, PhraseAbbr(Xp x,y)
  | "xp", [e;a] -> let x,y = load_category a in   id, PhraseAbbr(Xp x,y)
  | "advp", [F("category",Symbol a)] -> id, PhraseAbbr(Advp(a),[])
  | "advp", [e;F("category",Symbol a)] -> id, PhraseAbbr(Advp(a),[])
  | "nonch", [] -> id, PhraseAbbr(Nonch,[])
  | "or", [] -> id, Phrase Or
  | "refl", [] -> id, Phrase Refl
  | "E", [] -> id, E Null
  | "lex", x ->
    let lex = Xlist.fold x empty_lex load_lex in
    id, process_lex lex (lex.lex_argument,lex.lex_arguments,lex.lex_lemma,lex.lex_numeral_lemma)
  | "fixed", [F("argument",a);F("string",TEIstring b)] -> id, Phrase (FixedP((*snd (load_phrase a),*)b))
  | "possp", [e] -> id, PhraseAbbr(Possp,[])
  | "possp", [] -> id, PhraseAbbr(Possp,[])
  | "recip", [] -> id, Phrase Recip
  | "distrp", [e] -> id, PhraseAbbr(Distrp,[])
  | "distrp", [] -> id, PhraseAbbr(Distrp,[])
  | "compar", [F("compar_category",Symbol value)] -> id, PhraseAbbr(ComparP value,[])
  | "gerp", [F("case",Symbol a)] -> id, Phrase (GerP(parse_case a))
  | "prepgerp", [F("preposition",Symbol a);F("case",Symbol b)] -> id, Phrase (PrepGerP(a, parse_case b))
  | "nump", [F("case",Symbol a)] -> id, Phrase (NumP(parse_case a))
  | "prepnump", [F("preposition",Symbol a);F("case",Symbol b)] -> id, Phrase (PrepNumP(a, parse_case b))
  | "ppasp", [F("case",Symbol a)] -> id, Phrase (PpasP(parse_case a))
  | "prepppasp", [F("preposition",Symbol a);F("case",Symbol b)] -> id, Phrase (PrepPpasP(a, parse_case b))
  | "qub", [] -> id, Phrase Qub
  | "pactp", [F("case",Symbol a)] -> id, Phrase (PactP(parse_case a))
  | "adverb",[F("adverb",Symbol s)] -> id, LexPhrase([ADV (Grad "pos"),Lexeme s],(Natr,[]))
  | _ -> failwith ("load_phrase match:\n " ^ tei_to_string xml)


and load_control arg = function
  | Symbol  value -> parse_control arg value
  | xml -> failwith ("load_control:\n " ^ tei_to_string xml)

and load_position_info arg = function
  | F("function",Symbol  value) -> {arg with gf = parse_gf value}
  | Fset("phrases",phrases_set) ->
    {arg with morfs = List.rev (Xlist.rev_map phrases_set load_phrase)}
  | Fset("control",control_set) -> Xlist.fold control_set arg load_control
  | Id id -> {arg with psn_id=id}
  | xml -> failwith ("load_position_info:\n " ^ tei_to_string xml)

and load_position = function
  | Fs("position", listt) ->
    Xlist.fold listt empty_position load_position_info
  | xml -> failwith ("load_position:\n " ^ tei_to_string xml)

let parse_opinion = function
    "pewny" -> Pewny
  | "cer" -> Pewny
  | "potoczny" -> Potoczny
  | "col" -> Potoczny
  | "wątpliwy" -> Watpliwy
  | "unc" -> Watpliwy
  | "archaiczny" -> Archaiczny
  | "dat" -> Archaiczny
  | "zły" -> Zly
  | "bad" -> Zly
  | "wulgarny" -> Wulgarny
  | "vul" -> Wulgarny
  | "dobry" -> Dobry
  | x -> failwith ("parse_opinion: " ^ x)

let load_schema_info (arg:schema) = function
  | F("opinion",Symbol opinion_value) -> {arg with opinion = parse_opinion opinion_value}
  | F("inherent_sie",Binary true) -> {arg with reflexiveMark = ReflTrue}
  | F("inherent_sie",Binary false) -> {arg with reflexiveMark = ReflFalse}
  | F("aspect",Symbol aspect_value) -> {arg with aspect = parse_aspect aspect_value}
  | Fset("aspect", []) -> arg
  | F("negativity",Symbol negativity_value) -> {arg with negativity = parse_negation negativity_value}
  | Fset("negativity",[]) -> arg
  | F("predicativity",Binary true) -> {arg with predicativity = PredTrue}
  | F("predicativity",Binary false) -> {arg with predicativity = PredFalse}
  | Fset("positions", positions) ->
    {arg with positions = List.rev (Xlist.rev_map positions load_position)}
  | F("text_rep",TEIstring text_rep) -> {arg with text_rep = text_rep}
  | Id id -> {arg with sch_id = id}
  | xml -> failwith ("load_schema_info\n " ^ tei_to_string xml)

let load_schema = function
    Fs("schema", schema) ->
    let result = {sch_id = empty_id; opinion = OpinionUndef; reflexiveMark = ReflUndef; aspect = AspectUndef;
                  negativity = NegationUndef; predicativity = PredUndef; positions = []; text_rep=""} in
    let result = Xlist.fold schema result load_schema_info in
    result
  | xml -> failwith ("load_schema:\n " ^ tei_to_string xml)

let load_syntax = function
    Fset("schemata",schemata_set) ->
    List.rev (Xlist.rev_map schemata_set load_schema)
  | xml -> failwith ("load_syntax:\n " ^ tei_to_string xml)

let load_phrases_set = function
  | SameAs(same_as,"phrase") -> {same_as with numbers = List.tl same_as.numbers}
  | xml -> failwith ("load_phrases_set :\n " ^ tei_to_string xml)

let load_example_info arg = function
  | F("meaning",SameAs(same_as,"lexical_unit")) -> {arg with meaning = same_as}
  | Fset("phrases",phrases_set) ->
    {arg with phrases = List.rev (Xlist.rev_map phrases_set load_phrases_set)}
  | F("sentence",TEIstring sentence_string) -> {arg with sentence = sentence_string}
  | F("source",Symbol source_value) -> {arg with source = source_value}
  | F("opinion",Symbol opinion_value) -> {arg with opinion = parse_opinion opinion_value}
  | F("note",TEIstring note_string) -> {arg with note = note_string}
  | Id id -> {arg with exm_id = id}
  | xml -> failwith ("load_example_info :\n " ^ tei_to_string xml)

let load_example = function
  | Fs("example",example_elements) ->
    let result = {exm_id = empty_id; meaning = empty_id; phrases = []; sentence = "";
                  source = ""; opinion = OpinionUndef; note = "";} in
    let result = Xlist.fold example_elements result load_example_info in
    result
  | xml -> failwith ("load_example :\n " ^ tei_to_string xml)

let load_examples = function
  | Fset("examples",examples_set) ->
    List.rev (Xlist.rev_map examples_set load_example)
  | xml -> failwith ("load_examples:\n " ^ tei_to_string xml)

let load_self_prefs_sets = function
  | Numeric value -> NumericP(value)
  | Symbol value -> SymbolP(value)
  | Fs("relation",[F("type",Symbol value);F("to",SameAs(same_as, "argument"))]) ->
    RelationP(value,same_as)
  | xml -> failwith ("load_self_prefs_sets :\n " ^ tei_to_string xml)

let load_argument_self_prefs = function
  | Fset(name,self_prefs_set) ->
    List.rev (Xlist.rev_map self_prefs_set load_self_prefs_sets)
  | xml -> failwith ("load_argument_self_prefs :\n " ^ tei_to_string xml)

let load_argument_info arg = function
  | F("role",Symbol value) -> {arg with role = value}
  | F("role_attribute",Symbol value) -> {arg with role_attribute = value}
  | F("sel_prefs",Fs("sel_prefs_groups", self_prefs)) ->
    {arg with sel_prefs = List.rev (Xlist.rev_map self_prefs load_argument_self_prefs)}
  | Id id -> {arg with arg_id = id}
  | xml -> failwith ("load_argument_info :\n " ^ tei_to_string xml)

let load_arguments_set = function
  | Fs("argument", info) ->
    let result = {arg_id = empty_id; role = ""; role_attribute = ""; sel_prefs = []} in
    let result = Xlist.fold info result load_argument_info in
    result
  | xml -> failwith ("load_arguments_set :\n " ^ tei_to_string xml)

let load_meanings_set = function
  | SameAs(same_as,"lexical_unit") -> same_as
  | xml -> failwith ("load_meanings_set :\n " ^ tei_to_string xml)

let load_frame = function
  | Fs("frame",[
      Id id;
      F("opinion",Symbol opinion);
      Fset("meanings",meanings_set);
      Fset("arguments",arguments_set)]) ->
    {frm_id = id;
     opinion = opinion;
     meanings = List.rev (Xlist.rev_map meanings_set load_meanings_set);
     arguments = List.rev (Xlist.rev_map arguments_set load_arguments_set)}
  | xml -> failwith ("load_frame :\n " ^ tei_to_string xml)

let load_semantic = function
  | Fset("frames",frame_set) ->
    List.rev (Xlist.rev_map frame_set load_frame)
  | xml -> failwith ("load_semantic:\n " ^ tei_to_string xml)

let load_meaning_info arg = function
  | F("name",TEIstring name_string) -> {arg with name = name_string}
  | F("variant",TEIstring variant_string) -> {arg with variant = variant_string}
  | F("plwnluid",Numeric value) -> {arg with plwnluid = value}
  | F("gloss",TEIstring gloss_string) -> {arg with gloss = gloss_string}
  | Id id -> {arg with mng_id = id}
  | xml -> failwith ("load_meaning_info:\n " ^ tei_to_string xml)


let load_meaning = function
  | Fs("lexical_unit", meaning_info) ->
    Xlist.fold meaning_info empty_meaning load_meaning_info
  | xml -> failwith ("load_meaning:\n " ^ tei_to_string xml)

let load_phrases_connections = function
  | SameAs(same_as,"phrase") -> same_as
  | xml -> failwith ("load_phrases_connections: \n " ^ tei_to_string xml)

let load_alter_connection = function
  | Fs("connection", [
      F("argument",SameAs(same_as,"argument"));
      Fset("phrases",phrases)]) ->
    {argument = same_as; phrases = List.rev (Xlist.rev_map phrases load_phrases_connections)}
  | xml -> failwith ("load_alter_connections: \n " ^ tei_to_string xml)

let load_alternations = function
  | Fs("alternation",[Fset("connections",connections_set)]) ->
    {connections = List.rev (Xlist.rev_map connections_set load_alter_connection)}
  | xml -> failwith ("load_alternations: \n " ^ tei_to_string xml)

let load_connections = function
  | Fset("alternations",alternations) ->
    List.rev (Xlist.rev_map alternations load_alternations)
  | xml -> failwith ("load_connections: \n " ^ tei_to_string xml)

let load_entry = function
  | Xml.Element("entry",["xml:id",id], l) ->
    let entry = {empty_entry with ent_id = parse_id id} in
    Xlist.fold l entry (fun e -> function
          Xml.Element("form", [], [
            Xml.Element("orth",[],[Xml.PCData orth]);
            Xml.Element("pos",[],[Xml.PCData pos])]) -> {e with form_orth=orth; form_pos=pos}
        | xml -> (match parse_tei xml with
            | Fs("syntactic_layer", [syntax]) -> {e with schemata = load_syntax syntax}
            | Fs("examples_layer", [examples]) -> {e with examples = load_examples examples}
            | Fs("semantic_layer", [semantic]) -> {e with frames = load_semantic semantic}
            | Fs("meanings_layer", [Fset("meanings",meanings_set)]) ->
              {e with meanings = List.rev (Xlist.rev_map meanings_set load_meaning)}
            | Fs("connections_layer",[connections]) -> {e with alternations = load_connections connections}
            | Fs("general_info",[F("status",TEIstring status)]) -> {e with status=status}
            | xml -> failwith ("load_entry: \n" ^ tei_to_string xml)))
   | xml -> failwith ("load_entry: \n" ^ Xml.to_string_fmt xml)

let load_walenty filename:entry list =
  begin
    match Xml.parse_file filename with
      Xml.Element("TEI", _,
                  [Xml.Element("teiHeader",_,_) ;
                   Xml.Element("text",[],[Xml.Element("body",[],entries)])]) ->
      List.rev (Xlist.rev_map entries load_entry)
    | _ -> failwith "load_walenty"
  end

type expansion = Phrases of morf list | Positions of position list

let load_expansion = function
    Fs("expansion",[F("opinion",Symbol opinion);Fset("phrases",set)]) -> Phrases(List.rev (Xlist.map set (fun p -> snd (load_phrase p))))
  | Fs("expansion",[F("opinion",Symbol opinion);Fset("positions",set)]) -> Positions(List.rev (Xlist.map set load_position))
  | tei -> failwith ("load_expansion: \n" ^ tei_to_string tei)

let load_rentry = function
  | Xml.Element("entry",["xml:id",id], [phrase;exp]) ->
    let id = parse_id id in
    let morf = snd (load_phrase (parse_tei phrase)) in
    let expansions = match parse_tei exp with
        | Fs("phrase_type_expansions", [Fset("expansions",expansions)]) -> List.rev (Xlist.map expansions load_expansion)
        | Fs("phrase_type_expansions", [F("expansions",expansion)]) -> [load_expansion expansion]
        | tei -> failwith ("load_entry: \n" ^ tei_to_string tei) in
    id,morf,expansions
  | xml -> failwith ("load_entry: \n" ^ Xml.to_string_fmt xml)

let load_expands filename =
  begin
    match Xml.parse_file filename with
      Xml.Element("TEI", _,
                  [Xml.Element("teiHeader",_,_) ;
                   Xml.Element("text",[],[Xml.Element("body",[],entries)])]) ->
      List.rev (Xlist.rev_map entries load_rentry)
    | _ -> failwith "load_walenty"
  end


   (* !!! Wczytywanie walentego *)
   (*let walenty = load_walenty Paths.walenty_filename *)
let walenty = load_walenty "/home/yacheu/Dokumenty/NLP resources/Walenty/walenty_20170304.xml"

let expands = load_expands "/home/yacheu/Dokumenty/NLP resources/Walenty/phrase_types_expand_20170304.xml"

let subtypes = ["int",[
    "co"; "czemu"; "czy"; "czyj"; "dlaczego"; "dokąd"; "gdzie"; "ile"; "jak";
    "jaki"; "kiedy"; "kto"; "którędy"; "który"; "odkąd"; "skąd"; "jakoby"];
                "rel",[
 "co"; "dokąd"; "gdzie"; "jak"; "jakby"; "jaki"; "jakoby"; "kiedy"; "kto";
 "którędy"; "który"; "odkąd"; "skąd"]]

let equivalents = ["jak","niczym"; "przeciw";"przeciwko"]

    nonch-->
                  co	[pewna]
                    coś	[pewna]
                    nic	[pewna]
to	[pewna]

     advp(pron)-->
   tak	[pewna]
     jak	[pewna]

(*
  Autor: Maciej Hołubowicz
*)

let przejdz funkcja poczym =
  let _ = List.rev (List.fold_left (fun l nazwa -> funkcja nazwa :: l) [] poczym) in
    ()

(*zwraca liste zwróconych wartosci przez funkcje*)
let przejdz_lista funkcja poczym =
  List.rev (List.fold_left (fun l nazwa -> funkcja nazwa :: l) [] poczym)

let przejdz_lista_second funkcja poczym =
  List.rev (List.fold_left (fun l nazwa -> (snd (funkcja nazwa)) :: l) [] poczym)

(*łączy listy zwróconych wartości przez funkcje*)
let przejdz_scal funkcja poczym =
  List.rev (List.fold_left (fun l nazwa -> funkcja nazwa @ l) [] poczym)

(*zapisuje wynik wywołania do zmiennej i wywołuje ze zmienną*)
let przejdz_zapisz funkcja zmienna poczym =
  List.fold_left (fun zmienna nazwa -> funkcja zmienna nazwa) zmienna poczym


let rec last l =
  match l with
  | [a] -> a
  | a::b -> last b
  | _ -> failwith "pusta lista"

let parse_full_id s =
  if String.length s = 0 then empty_id else
  if String.length s < 6 then failwith "za krótkie id"  else
  let hash,s = if (String.get s 0) = '#' then true, String.sub s 1 (String.length s - 1) else false, s in
  if String.sub s 0 4 <> "wal_" then failwith "id nie ma wal" else
  let s,suf = match Str.split (Str.regexp "-") s with
    [s;suf] -> s,suf
    | _ -> failwith "zła ilość '-'" in
  let id = {hash = hash; suffix = suf; numbers = (Str.split (Str.regexp "\\.") s)} in
   id

let parse_id s =
  if String.length s = 0 then empty_id else
  if String.length s < 6 then failwith "za krótkie id"  else
  let hash,s = if (String.get s 0) = '#' then true, String.sub s 1 (String.length s - 1) else false, s in
  if String.sub s 0 4 <> "wal_" then failwith "id nie ma wal" else
  let s,suf = match Str.split (Str.regexp "-") s with
    [s;suf] -> s,suf
    | _ -> failwith "zła ilość '-'" in
  let id = {hash = hash; suffix = suf; numbers = (Str.split (Str.regexp "\\.") s)} in
   {id with numbers = [last id.numbers]}


(* Początek kodu do wczytywania syntaticLayer *)
(*
type preposition = string
type case = string
type comp = string * (string list)(* oznaczony w xmlu jako "type" *)
type aspect = string
type lemmas = string list

type category =
  string * phrase list

and phrase =
    NP of case
  | PrepNP of preposition * case
  | AdjP of case
  | PrepAdjP of preposition * case
  | ComprepNP of preposition
  | CP of comp
  | NCP of case * comp
  | PrepNCP of preposition * case * comp
  | InfP of aspect
  | XP of category
  | AdvP of string
  | GerP of case
  | PrepGerP of preposition * case
  | NumP of case
  | PrepNumP of preposition * case
  | PpasP of case
  | PrepPpasP of preposition * case
  | PactP of case
  | PrepPactP of preposition * case
  | Qub
  | ComparP of string
  | Nonch
  | Or
  | Refl
  | Recip
  | E
  | DistrP
  | PossP
  | FixedP of phrase list * string
  | Lex of lex
  | Null

and lex = {
  phrases_list: phrase list;
  lemma: string * string * lemmas;
  numeral_lemma: string * string * lemmas;
  negation: string;
  degree: string;
  number: string;
  reflex: string;
  gender: string;
  modification: string * position list;
  }
and*) (*type position = {psn_id: id; gf: string; phrases: (id * morf) list; control: string list}*)


(* let _ = Printf.printf "loading: OK\n" *)

(* ******************************************* *)

(****


(*


(*sprawdzanie czy id jednoznacznie definiuje zawartość typu*)


(*meaningsLayer*)
module StringMap = Map.Make(String)

let cnt = ref 0;;

let add_new map meaning =
  let num_id = match meaning.mng_id with
    {hash=false; numbers=[num_id]; suffix="mng"} -> num_id
    | _ -> failwith "zła składnia id"  in
  if StringMap.mem num_id map then
    (Printf.printf "okkk\n";
    let meaning2 = StringMap.find num_id map in
    if meaning = meaning2 then map else
     failwith "różne1111")
  else (cnt:=!cnt+1;StringMap.add num_id meaning map)

let check_entry_menaings mapa entry =
  przejdz_zapisz add_new mapa entry.meanings

let check_meanings walenty =
  przejdz_zapisz check_entry_menaings StringMap.empty walenty

(*
let _ = check_meanings walenty
let _ = Printf.printf "meaning map.size: %d\n" !cnt
*)

(*semanticLayer*)

let cnt = ref 0;;

(*arg_id*)
let add_new map argument =
  let arg_id = match argument.arg_id with
    {hash=false; numbers=[num_id]; suffix="arg"} -> num_id
    | _ -> failwith "zła składnia id" in
  if StringMap.mem arg_id map then
    (Printf.printf "okkk\n";
    let val2 = StringMap.find arg_id map in
    let val1 = argument in
    if val1 = val2 then map else
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add arg_id argument map)


let check_frame mapa frame =
  przejdz_zapisz add_new mapa frame.arguments

let check_entry_frames mapa entry =
  przejdz_zapisz check_frame mapa entry.frames

let check_meanings walenty =
  przejdz_zapisz check_entry_frames StringMap.empty walenty

(*
let _ = check_meanings walenty
let _ = Printf.printf "entry.frame.argument map.size: %d\n" !cnt
*)
(*arg_id done*)


let cnt = ref 0;;
(*frm_id*)
let add_new map frame =
  let id = match frame.frm_id with
    {hash=false; numbers=[num_id]; suffix="frm"} -> num_id
    | _ -> failwith "zła składnia id" in
  if StringMap.mem id map then
    (Printf.printf "okkk\n";
    let val2 = StringMap.find id map in
    let val1 = frame in
    if val1 = val2 then map else
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add id frame map)

let check_entry_frames mapa entry =
  przejdz_zapisz add_new mapa entry.frames

let check_meanings walenty =
  przejdz_zapisz check_entry_frames StringMap.empty walenty

(*
let _ = check_meanings walenty
let _ = Printf.printf "entry.frame map.size: %d\n" !cnt
*)

(*frm.id done*)

(*examplesLayer*)
(*na razie zeruje phrases!!!!*)
let print_example example =
  Printf.printf "meaning: %s\n phrases: " example.meaning;
(*  print_endline (String.concat "; " example.phrases);*)
  Printf.printf "sentence: %s\n" example.sentence;
  Printf.printf "source: %s\n" example.source;
  Printf.printf "opinion: %s\n" example.opinion;
  Printf.printf "note: %s\n\n" example.note


let cnt = ref 0;;
let takiesame = ref 0;;

let add_new map example =
  let id = match example.exm_id with
    {hash=false; numbers=[num_id]; suffix="exm"} -> num_id
    | _ ->  failwith "zła składnia id" in
(*  let example = {example with phrases = []} in (*uwaga!!!! zeruje phrases!!!*)*)
  let example = {example with meaning = ""} in (*uwaga!!!! zeruje meaning!!!*)
  if StringMap.mem id map then
    (takiesame:=!takiesame+1;
   (* Printf.printf "okkk\n";*)
    let val2 = StringMap.find id map in
    let val1 = example in
    if val1 = val2 then map else
     let _ = print_example val1 in
     let _ = print_example val2 in
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add id example map)

let check_entry_example mapa entry =
      przejdz_zapisz add_new mapa entry.examples

let check_meanings walenty =
  przejdz_zapisz check_entry_example StringMap.empty walenty

(*
let _ = check_meanings walenty
let _ = Printf.printf "examples map.size: %d takich samych: %d\n" !cnt !takiesame
*)


(*syntatcticLayer position*)


let cnt = ref 0;;
let takiesame = ref 0;;

let add_new map position =
  let id = match position.psn_id with
    {hash=false; numbers=[num_id]; suffix="psn"} -> num_id
  | _ -> failwith "zła składnia id" in
(*  let position = {position with phrases = przejdz_lista (fun (x,y) -> (parse_id "",y)) position.phrases} in*)  (*uwaga!!!!*)
  if StringMap.mem id map then
    (takiesame:=!takiesame+1;
   (* Printf.printf "okkk\n";*)
    let val2 = StringMap.find id map in
    let val1 = position in
    if val1 = val2 then map else
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add id position map)

let check_schema mapa schema =
  przejdz_zapisz add_new mapa schema.positions

let check_entry mapa entry =
  przejdz_zapisz check_schema mapa entry.schemata

let check walenty =
  przejdz_zapisz check_entry StringMap.empty walenty

(*
let _ = check walenty
let _ = Printf.printf "syntactic...position map.size: %d takich samych: %d\n" !cnt !takiesame
*)

(* schema *)

let cnt = ref 0;;
let takiesame = ref 0;;

(*let clear_id (position:position) =
  let position = {position with phrases = [](*przejdz_lista (fun (x,y) -> (empty_id,y)) position.phrases*)} in  (*uwaga!!!!*)
  let position = {position with psn_id = empty_id} in
    position*)

let print_schema (schema:schema) =
  Printf.printf "schema.opinion= %s\n" schema.opinion;
  Printf.printf "schema.reflexiveMark= %s\n" schema.reflexiveMark;
  Printf.printf "schema.aspect= %s\n" schema.aspect;
  Printf.printf "schema.negativity= %s\n" schema.negativity;
  Printf.printf "schema.predicativity= %s\n___________________\n" schema.predicativity

let add_new map schema =
  let id = match schema.sch_id with
    {hash=false; numbers=[num_id]; suffix="sch"} -> num_id
  | _ ->  failwith "zła składnia id" in
  let schema = {schema with opinion = ""} in (*uwaga, zeruje opinie!!!*)
  if StringMap.mem id map then
    (takiesame:=!takiesame+1;
   (* Printf.printf "okkk\n";*)
    let val2 = StringMap.find id map in
    let val1 = schema in
    if val1 = val2 then map else
     let _ = print_schema val1 in
     let _ = print_schema val2 in
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add id schema map)


let check_schema mapa schema =
    add_new mapa schema

let check_entry mapa entry =
  przejdz_zapisz check_schema mapa entry.schemata

let check walenty =
  przejdz_zapisz check_entry StringMap.empty walenty

(*
let _ = check walenty
let _ = Printf.printf "syntactic...schema map.size: %d takich samych: %d\n" !cnt !takiesame
*)

(*phrases*)

let cnt = ref 0;;
let takiesame = ref 0;;

let add_new map (id, phrase) =
  let id = match id with
    {hash=false; numbers=[num_id]; suffix="phr"} -> num_id
  | _ ->  failwith "zła składnia id" in
  if StringMap.mem id map then
    (takiesame:=!takiesame+1;
   (* Printf.printf "okkk\n";*)
    let val2 = StringMap.find id map in
    let val1 = phrase in
    if val1 = val2 then map else
     failwith "różne1111")
  else (cnt:=!cnt+1; StringMap.add id phrase map)

let check_pos mapa (position:position) =
  przejdz_zapisz add_new mapa position.phrases

let check_schema mapa schema =
  przejdz_zapisz check_pos mapa schema.positions

let check_entry mapa entry =
  przejdz_zapisz check_schema mapa entry.schemata

let check walenty =
  przejdz_zapisz check_entry StringMap.empty walenty

*)

(*
let _ = check walenty
let _ = Printf.printf "syntactic...phrases map.size: %d takich samych: %d\n" !cnt !takiesame
*)


(*
loading: OK
meaning map.size: 32962
entry.frame.argument map.size: 10475
entry.frame map.size: 3463
examples map.size: 146536 takich samych: 64
syntactic...position map.size: 7021 takich samych: 195288
syntactic...schema map.size: 21247 takich samych: 51241
*)

(* author: Wojciech Jaworski *)

open Xstd

let rec parse_comp = function
    "int",[] -> ENIAMwalTypes.Int,[]
  | "rel",[] -> ENIAMwalTypes.Rel,[]
  | "int",l -> ENIAMwalTypes.Int, Xlist.map l (fun s -> ENIAMwalTypes.Comp s)
  | "rel",l -> ENIAMwalTypes.Rel, Xlist.map l (fun s -> ENIAMwalTypes.Comp s)
  | s,[] -> ENIAMwalTypes.CompTypeUndef,[ENIAMwalTypes.Comp s]
  | _ -> failwith "parse_comp"


let rec morf_of_phrase = function
    NP c -> ENIAMwalTypes.Phrase (ENIAMwalTypes.NP(ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | PrepNP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.PrepNP(ENIAMwalTypes.Sem,ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep],ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | AdjP c -> ENIAMwalTypes.Phrase (ENIAMwalTypes.AdjP(ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | PrepAdjP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.PrepAdjP(ENIAMwalTypes.Sem,ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep],ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | ComprepNP prep -> ENIAMwalTypes.Phrase (ENIAMwalTypes.ComprepNP(ENIAMwalTypes.Sem,ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep]))
  | CP(co) ->  ENIAMwalTypes.PhraseComp(ENIAMwalTypes.Cp,parse_comp co)
  | NCP(c,co) -> ENIAMwalTypes.PhraseComp(ENIAMwalTypes.Ncp(ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]),parse_comp co)
  | PrepNCP(prep,c,co) -> ENIAMwalTypes.PhraseComp(ENIAMwalTypes.Prepncp(ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep],ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]),parse_comp co)
  | InfP(a) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.InfP(ENIAMwalParser.parse_aspect [ENIAMwalTypes.Text a]))
  | XP(mode,phrases) -> ENIAMwalTypes.PhraseAbbr(ENIAMwalTypes.Xp(fst (ENIAMwalParser.parse_mode [ENIAMwalTypes.Text mode])), Xlist.map phrases morf_of_phrase)
  | AdvP mode -> ENIAMwalTypes.PhraseAbbr(ENIAMwalTypes.Advp(fst (ENIAMwalParser.parse_mode [ENIAMwalTypes.Text mode])), [])
  | NumP(c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.NumP(ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | PrepNumP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.PrepNumP(ENIAMwalTypes.Sem,ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep],ENIAMwalParser.parse_case [ENIAMwalTypes.Text c]))
  | ComparP prep -> ENIAMwalTypes.PhraseAbbr (ENIAMwalTypes.ComparP(ENIAMwalParser.parse_prep [ENIAMwalTypes.Text prep]),[])
  | Nonch -> ENIAMwalTypes.PhraseAbbr (ENIAMwalTypes.Nonch,[])
  | Or -> ENIAMwalTypes.Phrase ENIAMwalTypes.Or
  | Refl  -> ENIAMwalTypes.Phrase (ENIAMwalTypes.Lex "się")
  | Recip  -> ENIAMwalTypes.Phrase (ENIAMwalTypes.Lex "się")
  | E -> ENIAMwalTypes.E ENIAMwalTypes.Null
  | DistrP -> ENIAMwalTypes.PhraseAbbr (ENIAMwalTypes.Distrp,[])
  | PossP -> ENIAMwalTypes.PhraseAbbr (ENIAMwalTypes.Possp,[])
  | FixedP(_,s) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.FixedP s)
  | Lex lex -> (*print_endline "lex";*) ENIAMwalTypes.Phrase (ENIAMwalTypes.Null) (* FIXME: ni *)
  | Null -> ENIAMwalTypes.Phrase (ENIAMwalTypes.Null)
  | _ -> failwith "morf_of_phrase"

(*  | GerP(c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | PrepGerP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | PpasP(c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | PrepPpasP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | PPact(c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | PrepPactP(prep,c) -> ENIAMwalTypes.Phrase (ENIAMwalTypes.
  | Qub -> ENIAMwalTypes.Phrase (ENIAMwalTypes.*)


open ENIAMwalTypes

let process_phrases phrases =
  Xlist.fold phrases StringMap.empty (fun phrases (id,phrase) ->
    let id =
      match id with
        {hash=false; numbers=[(*_;_;_;*)id]; suffix="phr"} -> id
      | _ -> failwith "process_phrases" in
    StringMap.add phrases id phrase)

let process_positions positions =
  Xlist.fold positions StringMap.empty (fun positions position ->
    let id =
      match position.psn_id with
        {hash=false; numbers=[(*_;_;*)id]; suffix="psn"} -> id
      | _ -> failwith "process_positions" in
    let r,cr,ce = ENIAMwalParser.parse_roles (position.gf :: position.control) in
    let phrases = process_phrases position.phrases in
    StringMap.add positions id (r,cr,ce,phrases))

let process_schemata schemata =
  Xlist.fold schemata StringMap.empty (fun schemata schema ->
    let id =
      match schema.sch_id with
        {hash=false; numbers=[(*_;*)id]; suffix="sch"} -> id
      | _ -> failwith "process_schemata" in
    let schema_atrs = DefaultAtrs([],
      ENIAMwalParser.parse_refl [Text schema.reflexiveMark],
      ENIAMwalParser.parse_opinion schema.opinion,
      ENIAMwalParser.parse_negation [Text schema.negativity],
      ENIAMwalParser.parse_pred [Text schema.predicativity],
      ENIAMwalParser.parse_aspect [Text schema.aspect]) in
    let positions = process_positions schema.positions in
    StringMap.add schemata id (schema_atrs,positions))

let add_meanings meanings = function
    DefaultAtrs(_,r,o,n,p,a) -> DefaultAtrs(meanings,r,o,n,p,a)
  | _ -> failwith "add_meanings"

let process_arguments arguments =
  Xlist.fold arguments StringMap.empty (fun arguments argument ->
    let id =
      match argument.arg_id with
        {hash=false; numbers=[(*_;_;*)id]; suffix="arg"} -> id
      | _ -> failwith "process_arguments" in
    StringMap.add arguments id (argument.role,argument.role_attribute,argument.sel_prefs))

let get_meaning_id meaning =
  match parse_full_id meaning with
    {hash=true; numbers=[_;id]; suffix="mng"} -> id
  | _ -> failwith "get_meaning_id"

let get_schema_id alt =
  try
    match parse_full_id (List.hd ((List.hd alt.connections).phrases)) with
      {hash=true; numbers=[_;id;_;_]; suffix="phr"} -> id
    | _ -> failwith "get_schema_id 1"
  with _ -> failwith "get_schema_id 2"

let get_frame_id alt =
  try
    match parse_full_id ((List.hd alt.connections).argument) with
      {hash=true; numbers=[_;id;_]; suffix="arg"} -> id
    | _ -> failwith "get_frame_id"
  with _ -> failwith "get_frame_id"

let get_argument_id arg =
  match parse_full_id arg with
    {hash=true; numbers=[_;_;id]; suffix="arg"} -> id
  | _ -> failwith "get_argument_id"

let get_position_id phrases =
  try
    match parse_full_id (List.hd phrases) with
      {hash=true; numbers=[_;_;id;_]; suffix="phr"} -> id
    | _ -> failwith "get_position_id"
  with _ -> failwith "get_position_id"

let get_phrase_id arg =
  match parse_full_id arg with
    {hash=true; numbers=[_;_;_;id]; suffix="phr"} -> id
  | _ -> failwith "get_phrase_id"

let process_frames frames =
  Xlist.fold frames StringMap.empty (fun frames frame ->
    let id =
      match frame.frm_id with
        {hash=false; numbers=[(*_;*)id]; suffix="frm"} -> id
      | _ -> failwith "process_frames" in
      let arguments = process_arguments frame.arguments in
      let meaning_ids = Xlist.map frame.meanings get_meaning_id in
      StringMap.add frames id (meaning_ids,arguments))

let process_meanings meanings =
  Xlist.fold meanings StringMap.empty (fun meanings meaning ->
    let id =
      match meaning.mng_id with
        {hash=false; numbers=[(*_;*)id]; suffix="mng"} -> id
      | _ -> failwith "process_meanings" in
      StringMap.add meanings id (meaning.name ^ " " ^ meaning.variant))

let process_sel_pref = function
    Numeric s -> (try ENIAMplWordnet.synset_name s with Not_found -> "unknown")
  | Symbol s -> s
  | Relation(s,t) -> "REL" (* FIXME *)

let connect entry =
  let schemata = process_schemata entry.schemata in
  let frames = process_frames entry.frames in
  let meanings = process_meanings entry.meanings in
  Xlist.fold entry.alternations [] (fun found alt ->
    if alt.connections = [] then found else
    let schema_id = get_schema_id alt in
    let frame_id = get_frame_id alt in
    let schema_atrs,positions = StringMap.find schemata schema_id in
    let meaning_ids,arguments = StringMap.find frames frame_id in
    let positions = Xlist.fold alt.connections [] (fun positions2 conn ->
      let argument_id = get_argument_id conn.argument in
      let position_id = get_position_id conn.phrases in
      let r,cr,ce,phrases = StringMap.find positions position_id in
      let phrases = Xlist.fold conn.phrases [] (fun phrases2 id ->
        let phrase_id = get_phrase_id id in
        try StringMap.find phrases phrase_id :: phrases2
        with Not_found -> (*Printf.printf "%s\n%!" entry.form_orth;*)phrases2) in
      let role,role_attribute,sel_prefs = StringMap.find arguments argument_id in
      let sel_prefs = Xlist.map (List.flatten sel_prefs) process_sel_pref in
      {gf=r; role=role; role_attr=role_attribute; sel_prefs=sel_prefs;
       cr=cr; ce=ce; dir=Both; morfs=Xlist.map phrases morf_of_phrase} :: positions2) in
    let meanings = List.rev (Xlist.fold meaning_ids [] (fun l id ->
      (StringMap.find meanings id) :: l)) in
    let schema_atrs = add_meanings meanings schema_atrs in
    (entry.form_orth,entry.form_pos,Frame(schema_atrs,positions)) :: found)

let connect2 entry =
  let schemata = process_schemata entry.schemata in
  StringMap.fold schemata [] (fun found _ (schema_atrs,positions) ->
    let positions = StringMap.fold positions [] (fun positions2 _ (r,cr,ce,phrases) ->
      let phrases = StringMap.fold phrases [] (fun phrases2 _ phrase -> phrase :: phrases2) in
      {gf=r; role=""; role_attr=""; sel_prefs=[];
       cr=cr; ce=ce; dir=Both; morfs=Xlist.map phrases morf_of_phrase} :: positions2) in
    (entry.form_orth,entry.form_pos,Frame(schema_atrs,positions)) :: found)

let load_walenty2 () =
  let walenty = load_walenty walenty_filename in
  Xlist.fold walenty StringMap.empty (fun walenty entry ->
    if entry.frames = [] then Xlist.fold (connect2 entry) walenty (fun walenty (lemma,pos,frame) ->
      let map = try StringMap.find walenty pos with Not_found -> StringMap.empty in
      let map = StringMap.add_inc map lemma [frame] (fun l -> frame :: l) in
      StringMap.add walenty pos map)
    else Xlist.fold (connect entry) walenty (fun walenty (lemma,pos,frame) ->
      let map = try StringMap.find walenty pos with Not_found -> StringMap.empty in
      let map = StringMap.add_inc map lemma [frame] (fun l -> frame :: l) in
      StringMap.add walenty pos map))


let print_stringqmap filename qmap =
  let l = StringQMap.fold qmap [] (fun l k v -> (v,k) :: l) in
  File.file_out filename (fun file ->
    Xlist.iter (Xlist.sort l compare) (fun (v,k) ->
      Printf.fprintf file "%5d %s\n" v k))

let sel_prefs_quantities walenty =
  Xlist.fold walenty StringQMap.empty (fun quant e ->
    Xlist.fold e.frames quant (fun quant f ->
      Xlist.fold f.arguments quant (fun quant a ->
        Xlist.fold a.sel_prefs quant (fun quant l ->
          Xlist.fold l quant (fun quant -> function
              Numeric s ->
                let name = try ENIAMplWordnet.synset_name s with Not_found -> "unknown" in
                StringQMap.add quant ("N " ^ s ^ " " ^ name)
            | Symbol s -> StringQMap.add quant ("S " ^ s)
            | Relation(s,t) -> StringQMap.add quant ("R " ^ s ^ " | " ^ t))))))

(*let _ =
  let walenty = load_walenty walenty_filename in
  let quant = sel_prefs_quantities walenty in
  print_stringqmap "results/quant_sel_prefs.txt" quant*)

let print_entry filename lex =
  match Xml.parse_file filename with
    Xml.Element("TEI", _,
      [Xml.Element("teiHeader",_,_) ;
       Xml.Element("text",[],[Xml.Element("body",[],entries)])]) ->
         Xlist.iter entries (function
           Xml.Element("entry",_,Xml.Element("form", [], [Xml.Element("orth",[],[Xml.PCData orth]);_]) :: xml :: _) ->
             if orth = lex then print_endline (Xml.to_string_fmt xml)
         | _ -> failwith "print_entry")
  | _ -> failwith "print_entry"


(*let _ =
  print_entry walenty_filename "bębnić"*)

let print_full_entry filename lex =
  match Xml.parse_file filename with
    Xml.Element("TEI", _,
      [Xml.Element("teiHeader",_,_) ;
       Xml.Element("text",[],[Xml.Element("body",[],entries)])]) ->
         Xlist.iter entries (function
           Xml.Element("entry",e,Xml.Element("form",[],[Xml.Element("orth",[],[Xml.PCData orth]);p]) :: syn :: _ :: l) ->
             let xml = Xml.Element("entry",e,Xml.Element("form",[],[Xml.Element("orth",[],[Xml.PCData orth]);p]) :: syn :: l) in
             if orth = lex then print_endline (Xml.to_string_fmt xml)
         | _ -> failwith "print_full_entry")
  | _ -> failwith "print_full_entry"

(*let _ =
  print_full_entry walenty_filename "bębnić"*)

(*let _ =
  let walenty = load_walenty2 () in
  let frames_sem = try StringMap.find (StringMap.find walenty "verb") "bębnić" with Not_found -> failwith "walTEI" in
  Xlist.iter frames_sem (fun frame ->
    print_endline (WalStringOf.frame "bębnić" frame))*)
 ****)