Wojciech Jaworski / ENIAM

(*
 *  ENIAMlexSemantics is a library that assigns tokens with lexicosemantic information.
 *  Copyright (C) 2016-2017 Wojciech Jaworski <wjaworski atSPAMfree mimuw dot edu dot pl>
 *  Copyright (C) 2016-2017 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
open Xstd

let expands,compreps,comprep_reqs,subtypes,equivs = ENIAMwalParser.load_realizations ()
(*let verb_frames = ENIAMwalParser.load_frames (Paths.walenty_path ^ Paths.verb_filename)
let noun_frames = ENIAMwalParser.load_frames (Paths.walenty_path ^ Paths.noun_filename)
let adj_frames = ENIAMwalParser.load_frames (Paths.walenty_path ^ Paths.adj_filename)
let adv_frames = ENIAMwalParser.load_frames (Paths.walenty_path ^ Paths.adv_filename)    *)

let walenty = (*StringMap.empty*)ENIAMwalTEI.load_walenty2 ()

(*let _ = StringMap.iter walenty (fun pos map ->
  StringMap.iter map (fun lexeme frames ->
    Printf.printf "%s %s %d\n%!" pos lexeme (Xlist.size frames)))*)

(*let all_frames =
  ["subst",noun_frames;
   "adj",adj_frames;
   "adv",adv_frames;
   "ger",verb_frames;
   "pact",verb_frames;
   "ppas",verb_frames;
   "fin",verb_frames;
   "praet",verb_frames;
   "impt",verb_frames;
   "imps",verb_frames;
   "inf",verb_frames;
   "pcon",verb_frames]*)

let rec get_role_and_sense = function
    Phrase(Lex "się") -> "Theme","", []
  | PhraseAbbr(Xp "abl",_) -> "Location","Source", []
  | PhraseAbbr(Xp "adl",_) -> "Location","Goal", []
  | PhraseAbbr(Xp "caus",_) -> "Condition","", []
  | PhraseAbbr(Xp "dest",_) -> "Purpose","", []
  | PhraseAbbr(Xp "dur",_) -> "Duration","", []
  | PhraseAbbr(Xp "instr",_) -> "Instrument","", []
  | PhraseAbbr(Xp "locat",_) -> "Location","", []
  | PhraseAbbr(Xp "mod",_) -> "Manner","", []
  | PhraseAbbr(Xp "perl",_) -> "Path","", []
  | PhraseAbbr(Xp "temp",_) -> "Time","", []
  | PhraseAbbr(Advp "abl",_) -> "Location","Source", []
  | PhraseAbbr(Advp "adl",_) -> "Location","Goal", []
  | PhraseAbbr(Advp "dur",_) -> "Duration","", []
  | PhraseAbbr(Advp "locat",_) -> "Location","", []
  | PhraseAbbr(Advp "mod",_) -> "Manner","", []
  | PhraseAbbr(Advp "perl",_) -> "Path","", []
  | PhraseAbbr(Advp "temp",_) -> "Time","", []
(*  | PhraseAbbr(Advp "pron",_) -> "Arg","", []
  | PhraseAbbr(Advp "misc",_) -> "Arg","", []*)
  | PhraseAbbr(Distrp,_) -> "Distributive","", [] (* FIXME: to jest kwantyfikator *)
  | PhraseAbbr(Possp,_) -> "Possesive","", []
  | LexPhraseMode("abl",_,_) -> "Location","Source", []
  | LexPhraseMode("adl",_,_) -> "Location","Goal", []
  | LexPhraseMode("caus",_,_) -> "Condition","", []
  | LexPhraseMode("dest",_,_) -> "Purpose","", []
  | LexPhraseMode("dur",_,_) -> "Duration","", []
  | LexPhraseMode("instr",_,_) -> "Instrument","", []
  | LexPhraseMode("locat",_,_) -> "Location","", []
  | LexPhraseMode("mod",_,_) -> "Manner","", []
  | LexPhraseMode("perl",_,_) -> "Path","", []
  | LexPhraseMode("temp",_,_) -> "Time","", []
  | _ -> "Arg","", []


(*let rec get_gf_role = function
    [],Phrase(NP case) -> "C", "", ["T"]
  | [],Phrase(AdjP case) -> "R", "", ["T"]
  | [],Phrase(NumP(case,_)) -> "C", "", ["T"]
  | [],Phrase(PrepNP _) -> "C", "", ["T"]
  | [],Phrase(PrepAdjP _) -> "C", "", ["T"]
  | [],Phrase(PrepNumP _) -> "C", "", ["T"]
  | [],Phrase(ComprepNP _) -> "C", "", ["T"]
  | [],Phrase(ComparP _) -> "C", "", ["T"]
  | [],Phrase(CP _) -> "C", "", ["T"]
  | [],Phrase(NCP(case,_,_)) -> "C", "", ["T"]
  | [],Phrase(PrepNCP _) -> "C", "", ["T"]
  | [],Phrase(InfP _) -> "C", "", ["T"]
  | [],Phrase(FixedP _) -> "C", "", ["T"]
  | [],Phrase Or -> "C", "", ["T"] (* FIXME: zbadać w walentym faktyczne użycia or, bo to nie tylko zdania, ale też np(nom) w cudzysłowach *)
  | [],Phrase(Lex "się") -> "C", "Ptnt", ["T"]
  | [],PhraseAbbr(Xp mode,_) -> "C", mode, ["T"]
  | [],PhraseAbbr(Advp "pron",_) -> "R", "", ["T"]
  | [],PhraseAbbr(Advp "misc",_) -> "R", "", ["T"]
  | [],PhraseAbbr(Advp mode,_) -> "C", mode, ["T"]
  | [],PhraseAbbr(Nonch,_) -> "C", "", ["T"]
  | [],PhraseAbbr(Distrp,_) -> "C", "Distr", ["T"]
  | [],PhraseAbbr(Possp,_) -> "C", "Poss", ["T"]
  | [],LexPhraseMode(mode,_,_) -> "C", mode, ["T"]
  | [],LexPhrase((SUBST(_,case),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((PREP _,_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((NUM(case,_,_),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((ADJ(_,case,_,_),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((ADV _,_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((GER(_,case,_,_,_,_),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((PACT(_,case,_,_,_,_),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((PPAS(_,case,_,_,_),_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((INF _,_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((QUB,_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((COMPAR,_) :: _,_) -> "C", "", ["T"]
  | [],LexPhrase((COMP _,_) :: _,_) -> "C", "", ["T"]
  | [],morf -> print_endline(*failwith*) ("get_gf: []," ^ ENIAMwalStringOf.morf morf);"","",[]
  | _,Phrase(InfP _) -> "X", "", ["T"]
  | _,Phrase(CP _) -> "X", "", ["T"]  (* zwykle możliwa koordynacja z infp *)
  | _,Phrase _ -> "X", "", ["T"]
  | _,PhraseAbbr _ -> "X", "", ["T"]
  | _,LexPhraseMode _ -> "X", "", ["T"]
  | _,LexPhrase((INF _,_) :: _,_) -> "X", "", ["T"]
  | _,LexPhrase _ -> "X", "", ["T"]
  | _,morf -> failwith ("get_gf: _," ^ ENIAMwalStringOf.morf morf)*)

(*let gf_rank = Xlist.fold [
  "",1;
  ] StringMap.empty (fun gf_rank (gf,v) -> StringMap.add gf_rank gf v)*)

(*let agregate_gfs s gfs_roles =
(*  fst (Xlist.fold gfs ("",0) (fun (best_gf,best_rank) gf ->
    let rank = try StringMap.find gf_rank gf with Not_found -> failwith ("agregate_gfs: " ^ gf) in
    if rank > best_rank then gf, rank else best_gf, best_rank))*)
(*  let gfs,roles = List.split gfs_roles in
  let gfs = StringSet.to_list (Xlist.fold gfs StringSet.empty StringSet.add) in
  if Xlist.size gfs > 1 then print_endline ("agregate_gfs: " ^ String.concat " " gfs);
  if Xlist.size roles > 1 then print_endline ("agregate_gfs: " ^ String.concat " " roles);*)
  let gf,role,prefs = List.hd gfs_roles in
  {s with gf=gf; role=role; prefs=prefs}

let rec make_gfs schema =
  let schema = Xlist.map schema (function
        {gf="subj"} as s -> {s with gf="SUBJ"; role="Agnt"; prefs=["T"]; morfs=make_gfs_morfs s.morfs}
      | {gf="obj"} as s -> {s with gf="OBJ"; role="Ptnt"; prefs=["T"]; morfs=make_gfs_morfs s.morfs}
      | {gf=""} as s -> agregate_gfs {s with morfs=make_gfs_morfs s.morfs} (Xlist.map s.morfs (fun morf -> get_gf_role (s.ce,morf)))
      | {gf=t} -> failwith ("make_gfs: " ^ t)) in
(*  let schema = List.rev (fst (Xlist.fold schema ([],StringMap.empty) (fun (schema,map) s ->
    try
      let n = StringMap.find map s.gf in
      {s with gf=s.gf ^ string_of_int (n+1)} :: schema,
      StringMap.add map s.gf (n+1)
    with Not_found ->
      s :: schema, StringMap.add map s.gf 1))) in*)
  schema

and make_gfs_morfs morfs =
  List.flatten (Xlist.map morfs (function
      Phrase _ as morf -> [morf]
    | PhraseAbbr(Advp _,[]) -> [Phrase AdvP]
    | PhraseAbbr(_,[]) -> failwith "make_gfs_morfs"
    | PhraseAbbr(_,morfs) -> make_gfs_morfs morfs
    | LexPhrase(pos_lex,(restr,schema)) -> [LexPhrase(pos_lex,(restr,make_gfs schema))]
    | LexPhraseMode(_,pos_lex,(restr,schema)) -> [LexPhrase(pos_lex,(restr,make_gfs schema))]
    | _ -> failwith "make_gfs_morfs"))*)

let mark_nosem_morfs morfs =
  Xlist.map morfs (function
      Phrase(PrepNP(_,prep,c)) -> Phrase(PrepNP(NoSem,prep,c))
    | Phrase(PrepAdjP(_,prep,c)) -> Phrase(PrepAdjP(NoSem,prep,c))
    | Phrase(PrepNumP(_,prep,c)) -> Phrase(PrepNumP(NoSem,prep,c))
(*     | Phrase(ComprepNP(_,prep)) -> Phrase(ComprepNP(NoSem,prep)) *) (* FIXME: na razie ComprepNP są zawsze semantyczne *)
(*    | Phrase(ComparNP(_,prep,c)) -> Phrase(ComparNP(NoSem,prep,c)) (* FIXME: pomijam niesemantyczny compar *)
    | Phrase(ComparPP(_,prep)) -> Phrase(ComparPP(NoSem,prep))*)
    | Phrase(PrepNCP(_,prep,c,ct,co)) -> Phrase(PrepNCP(NoSem,prep,c,ct,co))
    | t -> t)


let agregate_role_and_sense s l =
  let roles,senses = Xlist.fold l (StringSet.empty,StringSet.empty) (fun (roles,senses) (role,role_attr,sense) ->
    StringSet.add roles (role ^ " " ^ role_attr),
    Xlist.fold sense senses StringSet.add) in
  let roles = if StringSet.size roles = 1 then roles else StringSet.remove roles "Arg " in
  let role,role_attr =
    match Str.split (Str.regexp " ") (StringSet.min_elt roles) with
      [r;a] -> r,a
    | [r] -> r,""
    | _ -> failwith "agregate_role_and_sense" in
  {s with role=role; role_attr=role_attr(*; sel_prefs=StringSet.to_list senses*)}

let rec assign_role_and_sense schema =
  Xlist.map schema (function
        {gf=SUBJ} as s ->
          if s.role = "" then {s with role="Initiator"; sel_prefs=["ALL"]; morfs=assign_role_and_sense_morfs s.morfs}
          else {s with morfs=assign_role_and_sense_morfs (mark_nosem_morfs s.morfs)}
      | {gf=OBJ} as s ->
          if s.role = "" then {s with role="Theme"; sel_prefs=["ALL"]; morfs=assign_role_and_sense_morfs s.morfs}
          else {s with morfs=assign_role_and_sense_morfs (mark_nosem_morfs s.morfs)}
      | {gf=ARG} as s ->
           if s.role = "" then agregate_role_and_sense {s with sel_prefs=["ALL"]; morfs=assign_role_and_sense_morfs s.morfs}
             (Xlist.map s.morfs (fun morf -> get_role_and_sense morf))
           else {s with morfs=assign_role_and_sense_morfs (mark_nosem_morfs s.morfs)}
      | _ -> failwith "assign_role_and_sense")

and assign_role_and_sense_morfs morfs =
  List.flatten (Xlist.map morfs (function
      Phrase _ as morf -> [morf]
    | E _ as morf -> [morf]
    | PhraseAbbr(Advp _,[]) -> [Phrase AdvP]
    | PhraseAbbr(_,[]) -> failwith "assign_role_and_sense_morfs"
    | PhraseAbbr(_,morfs) -> assign_role_and_sense_morfs morfs
    | LexPhrase(pos_lex,(restr,schema)) -> [LexPhrase(pos_lex,(restr,assign_role_and_sense schema))]
    | LexPhraseMode(_,pos_lex,(restr,schema)) -> [LexPhrase(pos_lex,(restr,assign_role_and_sense schema))]
    | _ -> failwith "assign_role_and_sense_morfs"))

(*let _ =
  Xlist.iter walenty_filenames (fun filename ->
    print_endline filename;
    let frames = load_frames (walenty_path ^ filename) in
    StringMap.iter frames (fun _ l ->
      Xlist.iter l (fun (refl,opinion,negation,pred,aspect,schema) ->
        ignore (process_opinion opinion);
        ignore (process_negation [Text negation]);
        ignore (process_pred [Text pred]);
        ignore (process_aspect [Text aspect]);
        ignore (assign_pro_args (make_gfs (process_schema expands subtypes equivs schema))))))*)

let remove_trivial_args schema =
  Xlist.fold schema [] (fun l (_,_,_,morfs) ->
    let morfs = Xlist.fold morfs [] (fun morfs -> function
        Phrase(AdjP _) -> morfs
      | Phrase(NP(Case "gen")) -> morfs
      | Phrase(NCP(Case "gen",_,_)) -> morfs
      | Phrase(PrepNP _) -> morfs
      | Phrase(FixedP _) -> morfs
      | LexPhrase([ADJ _,_],_) -> morfs
      | LexPhrase([PPAS _,_],_) -> morfs
      | LexPhrase([PACT _,_],_) -> morfs
      | LexPhrase([SUBST(_,Case "gen"),_],_) -> morfs
      | LexPhrase([PREP _,_;_],_) -> morfs
      | morf -> morf :: morfs) in
    if morfs = [] then l else morfs :: l)

(* leksykalizacje do zmiany struktury
lex([PREP(gen),'z';SUBST(sg,gen),'nazwa'],atr1[OBL{lex([QUB,'tylko'],natr[])}])
lex([PREP(loc),'na';SUBST(sg,loc),'papier'],atr1[OBL{lex([QUB,'tylko'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(gen),'z';SUBST(sg,gen),'most'],ratr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(gen),'z';SUBST(sg,gen),'most'],ratr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
lex([PREP(acc),'w';SUBST(pl,acc),'oko'],atr1[OBL-MOD{lex([ADV(pos),'prosto'],natr[])}])
*)

let num_arg_schema_field morfs =
  {gf=CORE; role="QUANT-ARG"; role_attr=""; sel_prefs=["ALL"]; cr=[]; ce=[]; dir=Forward; morfs=morfs}

let std_arg_schema_field dir morfs =
  {gf=ARG; role="Arg"; role_attr=""; sel_prefs=["ALL"]; cr=[]; ce=[]; dir=dir; morfs=morfs}

let simple_arg_schema_field morfs =
  {gf=ARG; role=""; role_attr=""; sel_prefs=["ALL"]; cr=[]; ce=[]; dir=Both; morfs=morfs}

let nosem_refl_schema_field =
  {gf=NOSEM; role=""; role_attr=""; sel_prefs=["ALL"]; cr=[]; ce=[]; dir=Both; morfs=[Phrase(Lex "się")]}


let expand_lexicalizations = function
    Frame(atrs,schema) -> Frame(atrs,expand_lexicalizations_schema schema)
(*     ComprepFrame(s,morfs) -> ComprepFrame(atrs,expand_lexicalizations_morfs morfs) *)
  | _ -> failwith "expand_lexicalizations"


let prepare_schema_comprep expands subtypes equivs schema =
  assign_pro_args (assign_role_and_sense (ENIAMwalParser.expand_equivs_schema equivs (ENIAMwalParser.expand_subtypes subtypes (ENIAMwalParser.expand_schema expands schema))))

let prepare_schema expands subtypes equivs schema =
  prepare_schema_comprep expands subtypes equivs (ENIAMwalParser.parse_schema schema)

let prepare_schema_sem expands subtypes equivs schema =
  prepare_schema_comprep expands subtypes equivs schema


let convert_frame expands subtypes equivs lexemes valence lexeme pos (refl,opinion,negation,pred,aspect,schema) =
(*   Printf.printf "convert_frame %s %s\n" lexeme pos; *)
  try
    if refl = "się" && not (StringMap.mem lexemes "się") then raise ImpossibleSchema else
    let frame =
      try StringMap.find default_frames refl (* w refl jest przekazywana informacja o typie domyślnej ramki *)
      with Not_found ->
        Frame(DefaultAtrs([],ENIAMwalParser.parse_refl [Text refl],
          ENIAMwalParser.parse_opinion opinion,
          ENIAMwalParser.parse_negation [Text negation],
          ENIAMwalParser.parse_pred [Text pred],
          ENIAMwalParser.parse_aspect [Text aspect]),
          prepare_schema expands subtypes equivs schema) in
    let frame = if StringMap.is_empty lexemes then frame else reduce_schema_frame lexemes frame in
    let frame = expand_lexicalizations frame in
    Xlist.fold (extract_lex_frames lexeme pos [] frame) valence (fun valence -> function
        lexeme,pos,Frame(atrs,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [Frame(atrs,schema)] (fun l -> Frame(atrs,schema) :: l) in
             StringMap.add valence lexeme poss)
      | lexeme,pos,LexFrame(id,pos2,restr,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [LexFrame(id,pos2,restr,schema)] (fun l -> LexFrame(id,pos2,restr,schema) :: l) in
             StringMap.add valence lexeme poss)
      | _ -> failwith "convert_frame")
  with ImpossibleSchema -> valence

let convert_frame_sem expands subtypes equivs lexemes valence lexeme pos = function
  Frame(DefaultAtrs(meanings,refl,opinion,negation,pred,aspect),positions) ->
(*   Printf.printf "convert_frame_sem %s\n" (ENIAMwalStringOf.frame lexeme (Frame(DefaultAtrs(meanings,refl,opinion,negation,pred,aspect),positions))); *)
  (try
    if refl = ReflSie && not (StringMap.mem lexemes "się") then raise ImpossibleSchema else
    let frame =
        Frame(DefaultAtrs(meanings,refl,opinion,negation,pred,aspect),
          prepare_schema_sem expands subtypes equivs positions) in
    let frame = if StringMap.is_empty lexemes then frame else reduce_schema_frame lexemes frame in
    let frame = expand_lexicalizations frame in
    Xlist.fold (extract_lex_frames lexeme pos [] frame) valence (fun valence -> function
        lexeme,pos,Frame(atrs,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [Frame(atrs,schema)] (fun l -> Frame(atrs,schema) :: l) in
             StringMap.add valence lexeme poss)
      | lexeme,pos,LexFrame(id,pos2,restr,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [LexFrame(id,pos2,restr,schema)] (fun l -> LexFrame(id,pos2,restr,schema) :: l) in
             StringMap.add valence lexeme poss)
      | _ -> failwith "convert_frame_sem")
  with ImpossibleSchema -> valence)
  | _ -> failwith "convert_frame_sem"

let make_comprep_frames_of_schema s = function
    [{cr=[];ce=[]; morfs=[LexPhrase([pos,Lexeme lex],(restr,schema))]}] ->
      lex,
      (match get_pos lex pos with [pos] -> pos | _ -> failwith "make_comprep_frame_of_schema 2"),
      ComprepFrame(s,pos,restr,schema)
  | schema -> failwith ("make_comprep_frame_of_schema: " ^ ENIAMwalStringOf.schema schema)

let convert_comprep_frame expands subtypes equivs lexemes valence lexeme pos (s,morf) =
  try
    let schema = prepare_schema_comprep expands subtypes equivs [simple_arg_schema_field [morf]] in
    let schema = if StringMap.is_empty lexemes then schema else reduce_schema lexemes schema in
    let schema = expand_lexicalizations_schema schema in
    let lexeme,pos,frame = make_comprep_frames_of_schema s schema in
    Xlist.fold (extract_lex_frames lexeme pos [] frame) valence (fun valence -> function
        lexeme,pos,ComprepFrame(s,pos2,restr,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [ComprepFrame(s,pos2,restr,schema)] (fun l -> ComprepFrame(s,pos2,restr,schema) :: l) in
             StringMap.add valence lexeme poss)
      | lexeme,pos,LexFrame(id,pos2,restr,schema) ->
           let schemas = simplify_lex (split_xor (split_or_coord schema)) in
           Xlist.fold schemas valence (fun valence schema ->
             let poss = try StringMap.find valence lexeme with Not_found -> StringMap.empty in
             let poss = StringMap.add_inc poss pos [LexFrame(id,pos2,restr,schema)] (fun l -> LexFrame(id,pos2,restr,schema) :: l) in
             StringMap.add valence lexeme poss)
      | _ -> failwith "convert_comprep_frame")
  with ImpossibleSchema -> valence

let remove_pro_args schema = (* FIXME: sprawdzić czy Pro i Null są zawsze na początku *)
  List.rev (Xlist.fold schema [] (fun schema -> function
      {morfs=[Phrase Pro]} -> schema
    | {morfs=(Phrase Pro) :: morfs} as s -> {s with morfs=morfs} :: schema
    | {morfs=[Phrase Null]} -> schema
    | {morfs=(Phrase Null) :: morfs} as s -> {s with morfs=morfs} :: schema
    | s -> s :: schema))



(*let _ =
  let valence = Xlist.fold all_frames StringMap.empty (fun valence (pos,frame_map) ->
    print_endline pos;
    StringMap.fold frame_map valence (fun valence lexeme frames ->
      Xlist.fold frames valence (fun valence frame ->
(*         print_endline (ENIAMwalStringOf.unparsed_frame lexeme frame); *)
        convert_frame expands subtypes equivs StringMap.empty valence lexeme pos frame))) in
  print_endline "comprepnp";
  let valence = StringMap.fold compreps valence (fun valence lexeme frames ->
    Xlist.fold frames valence (fun valence (pos,frame) ->
      convert_comprep_frame expands subtypes equivs StringMap.empty valence lexeme pos frame)) in
  print_endline "expand_restr";
  let valence = StringMap.mapi valence (fun lexeme poss ->
    StringMap.mapi poss (fun pos frames ->
      List.flatten (Xlist.map frames (expand_restr valence lexeme pos)))) in
  print_endline "transform_frame";
  let _ = StringMap.mapi valence (fun lexeme poss ->
    StringMap.mapi poss (fun pos frames ->
(*       print_endline lexeme; *)
      List.flatten (Xlist.map frames (transform_frame lexeme pos)))) in
  print_endline "done";
  ()*)
(*  StringMap.iter valence (fun lexeme poss ->
    StringMap.iter poss (fun pos frames ->
      Xlist.iter frames (fun frame -> print_endline (ENIAMwalStringOf.frame lexeme frame))))*)