Wojciech Jaworski / ENIAM

(*
 *  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 ENIAMtokenizerTypes
open ENIAMwalTypes
open ENIAMlexSemanticsTypes
open Xstd

let dir_of_dir = function
   Forward -> LCGtypes.Forward
 | Backward  -> LCGtypes.Backward
 | Both -> LCGtypes.Both

let arg_of_ctype = function
    Int -> LCGtypes.Atom "int"
  | Rel -> LCGtypes.Atom "rel"
  | Sub -> LCGtypes.Atom "sub"
  | Coord -> LCGtypes.Atom "coord"
  | CompTypeUndef -> LCGtypes.Top
  | CompTypeAgr -> LCGtypes.Atom "ctype"

open LCGtypes

(* let simplify_impset = function
    ImpSet(s,[]),LambdaSet([],sem) -> s,sem
  | ImpSet(s,[d,t]),LambdaSet([v],sem) -> Imp(s,d,t),Lambda(v,sem)
  | s,sem -> s,sem
 *)
let make_tensor_type quant l =
  Xlist.map l (fun s ->
    let b = Xlist.fold quant false (fun b (t,_,_) -> if t = s then true else b) in
    if b then AVar s else Atom s)

(* let rec internal_substitute var_name t = function
  | Atom x -> Atom x
  | AVar x -> if x = var_name then t else AVar x
  | With l -> With (Xlist.map l (internal_substitute var_name t))
  | Zero -> Zero
  | Top -> Top

let rec substitute var_name t = function
  | Tensor l -> Tensor (Xlist.map l (internal_substitute var_name t))
  | Plus l -> Plus (Xlist.map l (substitute var_name t))
  | Imp(s,d,t2) -> Imp(substitute var_name t s,d,substitute var_name t t2)
  | One -> One
  | ImpSet(s,l) -> ImpSet(substitute var_name t s, Xlist.map l (fun (d,s) -> d, substitute var_name t s))
  | WithVar(v,g,e,s) -> if v = var_name then WithVar(v,g,e,s) else WithVar(v,internal_substitute var_name t g,e,substitute var_name t s)
  | Star s -> Star (substitute var_name t s)
  | Bracket(lf,rf,s) -> Bracket(lf,rf,substitute var_name t s)
  | BracketSet d -> BracketSet d
  | Maybe s -> Maybe (substitute var_name t s) *)

(* let rec internal_count_avar var_name = function
    Atom _ -> 0
  | AVar x -> if x = var_name then 1 else 0
  | With l -> Xlist.fold l 0 (fun b t -> internal_count_avar var_name t + b)
  | Zero -> 0
  | Top -> 0

let rec count_avar var_name = function
  | Tensor l -> Xlist.fold l 0 (fun b t -> internal_count_avar var_name t + b)
  | Plus l -> Xlist.fold l 0 (fun b t -> count_avar var_name t + b)
  | Imp(s,d,t2) -> count_avar var_name s + count_avar var_name t2
  | One -> 0
  | ImpSet(s,l) -> count_avar var_name s + Xlist.fold l 0 (fun b (_,t) -> count_avar var_name t + b)
  | WithVar(v,g,e,s) -> if v = var_name then 0 else count_avar var_name s +  internal_count_avar var_name g
  | Star t -> count_avar var_name t
  | Bracket(lf,rf,s) -> count_avar var_name s
  | BracketSet _ -> 0
  | Maybe t -> count_avar var_name t
 *)
(* let rec substitute_substvar v g = function
    Var v as t -> t
  | Tuple l -> Tuple(Xlist.map l (substitute_substvar v g))
(*   | LetIn(l,s,t) -> LetIn(l,substitute_substvar v g s,substitute_substvar v g t) *)
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i,substitute_substvar v g t))
  | VariantVar(v2,t) -> if v2 = v then VariantVar(v2,t) else VariantVar(v2,substitute_substvar v g t)
  | SubstVar v2 -> if v2 = v then g else SubstVar v2
  | Case(t,l) -> Case(substitute_substvar v g t,Xlist.map l (fun (x,t) -> x,substitute_substvar v g t))
  | App(s,t) -> App(substitute_substvar v g s,substitute_substvar v g t)
  | Lambda(v2,t) -> Lambda(v2,substitute_substvar v g t)
  | LambdaSet(l,t) -> LambdaSet(l,substitute_substvar v g t)
  | Dot -> Dot
  | Val s -> Val s
  | SetAttr(e,s,t) -> SetAttr(e,substitute_substvar v g s,substitute_substvar v g t)
  | Fix(s,t) -> Fix(substitute_substvar v g s,substitute_substvar v g t)
  | Node t -> Node{t with attrs=Xlist.map t.attrs (fun (e,t) -> e, substitute_substvar v g t);
                          gs=substitute_substvar v g t.gs;
                          args=substitute_substvar v g t.args}
  | Morf m -> Morf m
  | Gf s -> Gf s
  | Cut t -> Cut(substitute_substvar v g t)
  | t -> failwith ("substitute_substvar: " ^ LCGstringOf.linear_term 0 t) *)

(* let simplify_withvar = function
    WithVar(v,Atom t,e,s),VariantVar(_,sem) -> substitute v (Atom t) s, substitute_substvar v (LCGrules.make_subst e (Atom t)) sem
  | WithVar(v,g,e,s),VariantVar(v2,sem) ->
       if count_avar v s = 0 then
         s, substitute_substvar v (LCGrules.make_subst e g) sem
       else WithVar(v,g,e,s),VariantVar(v2,sem)
  | s -> s *)

let rec make_type_quantification l (t,sem) =
  match l with
    [] -> t,sem
  | (category,e,[]) :: l ->
      let t,sem = make_type_quantification l (t,sem) in
      simplify_withvar (WithVar(category,Zero,e,t), VariantVar(category,sem))
  | (category,e,[s]) :: l ->
      let t,sem = make_type_quantification l (t,sem) in
      simplify_withvar (WithVar(category,Atom s,e,t), VariantVar(category,sem))
  | (category,e,values) :: l ->
      let t,sem = make_type_quantification l (t,sem) in
      simplify_withvar (WithVar(category, With(Xlist.map values (function s -> Atom s)), e, t),VariantVar(category,sem))

let make_gs quant l =
  Tuple(Xlist.map l (fun s ->
    let b = Xlist.fold quant false (fun b (t,_,_) -> if t = s then true else b) in
    if b then SubstVar s else Val s))

let make_arg_phrase = function
    NP(Case case) -> Tensor[Atom "np"; Top; Atom case; Top; Top]
  | NP NomAgr -> Tensor[Atom "np"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"]
  | NP GenAgr -> Tensor[Atom "np"; AVar "number"; Atom "gen"; AVar "gender"; AVar "person"]
  | NP AllAgr -> Tensor[Atom "np"; AVar "number"; AVar "case"; AVar "gender"; AVar "person"]
  | NP CaseAgr -> Tensor[Atom "np"; Top; AVar "case"; Top; Top]
  | NP CaseUndef -> Tensor[Atom "np"; Top; Top; Top; Top]
  | PrepNP(_,"",CaseUndef) -> Tensor[Atom "prepnp"; Top; Top]
  | PrepNP(_,prep,Case case) -> Tensor[Atom "prepnp"; Atom prep; Atom case]
  | AdjP(Case case) -> Tensor[Atom "adjp"; Top; Atom case; Top]
  | AdjP NomAgr -> Tensor[Atom "adjp"; AVar "number"; Atom "nom"; AVar "gender"]
  | AdjP AllAgr -> Tensor[Atom "adjp"; AVar "number"; AVar "case"; AVar "gender"]
  | AdjP CaseAgr -> Tensor[Atom "adjp"; Top; AVar "case"; Top]
  | PrepAdjP(_,"",CaseUndef) -> Tensor[Atom "prepnp"; Top; Top]
  | PrepAdjP(_,prep,Case case) -> Tensor[Atom "prepadjp"; Atom prep; Atom case]
  | NumP(Case case) -> Tensor[Atom "nump"; Top; Atom case; Top; Top]
  | NumP NomAgr -> Tensor[Atom "nump"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"]
  | NumP CaseAgr -> Tensor[Atom "nump"; Top; AVar "case"; Top; Top]
  | NumP CaseUndef -> Tensor[Atom "nump"; Top; Top; Top; Top]
  | PrepNumP(_,"",CaseUndef) -> Tensor[Atom "prepnp"; Top; Top]
  | PrepNumP(_,prep,Case case) -> Tensor[Atom "prepnump"; Atom prep; Atom case]
  | ComprepNP(_,"") -> Tensor[Atom "comprepnp"; Top]
  | ComprepNP(_,prep) -> Tensor[Atom "comprepnp"; Atom prep]
  | ComparNP(_,prep,Case case) -> Tensor[Atom "comparnp"; Atom prep; Atom case]
  | ComparPP(_,prep) -> Tensor[Atom "comparpp"; Atom prep]
  | IP -> Tensor[Atom "ip";Top;Top;Top]
  | CP (ctype,Comp comp) -> Tensor[Atom "cp"; arg_of_ctype ctype; Atom comp]
  | CP (ctype,CompUndef) -> Tensor[Atom "cp"; arg_of_ctype ctype; Top]
  | NCP(Case case,ctype,Comp comp) -> Tensor[Atom "ncp"; Top; Atom case; Top; Top; arg_of_ctype ctype; Atom comp]
  | NCP(Case case,CompTypeUndef,CompUndef) -> Tensor[Atom "ncp"; Top; Atom case; Top; Top; Top; Top]
  | NCP(NomAgr,ctype,Comp comp) -> Tensor[Atom "ncp"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"; arg_of_ctype ctype; Atom comp]
  | NCP(NomAgr,CompTypeUndef,CompUndef) -> Tensor[Atom "ncp"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"; Top; Top]
  | PrepNCP(_,prep,Case case,ctype,Comp comp) -> Tensor[Atom "prepncp"; Atom prep; Atom case; arg_of_ctype ctype; Atom comp]
  | InfP(Aspect aspect) -> Tensor[Atom "infp"; Atom aspect]
  | InfP AspectUndef -> Tensor[Atom "infp"; Top]
  | PadvP -> Tensor[Atom "padvp"]
  | AdvP -> Tensor[Atom "advp"]
  | FixedP lex -> Tensor[Atom "fixed"; Atom lex]
  | PrepP -> Tensor[Atom "prepp";Top]
  | Prep("",CaseAgr) -> Tensor[Atom "prep"; Top; AVar "case"]
  | Prep("",CaseUAgr) -> Tensor[Atom "prep"; Top; AVar "ucase"]
  | Num(AllAgr,Acm acm) -> Tensor[Atom "num"; AVar "number"; AVar "case"; AVar "gender"; AVar "person"; Atom acm]
  | Measure(AllUAgr) -> Tensor[Atom "measure"; AVar "unumber"; AVar "ucase"; AVar "ugender"; AVar "uperson"]
  | Or -> Tensor[Atom "or"]
  | Qub -> Tensor[Atom "qub"]
  | Inclusion -> Tensor[Atom "inclusion"]
  | Adja -> Tensor[Atom "adja"]
  | Aglt -> Tensor[Atom "aglt"; AVar "number"; AVar "person"]
  | AuxPast -> Tensor[Atom "aux-past"; AVar "number"; AVar "gender"; AVar "person"]
  | AuxFut -> Tensor[Atom "aux-fut"; AVar "number"; AVar "gender"; AVar "person"]
  | AuxImp -> Tensor[Atom "aux-imp"]
  | Pro -> One
  | ProNG -> One
  | Null -> One
  | X -> Tensor[Atom "X"]
  | Lex lex -> Tensor[Atom lex]
  | phrase -> failwith ("make_arg_phrase: " ^ ENIAMwalStringOf.phrase phrase)

let make_arg_pos = function (* wprowadzam uzgodnienia a nie wartości cech, bo wartości cech są wprowadzane przez leksem a uzgodnienia wiążą je z wartościami u nadrzędnika *)
  | SUBST(_,Case case) -> [Atom "subst"; Top; Atom case; Top; Top]
  | SUBST(_,NomAgr) -> [Atom "subst"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"]
  | SUBST(_,GenAgr) -> [Atom "subst"; AVar "number"; Atom "gen"; AVar "gender"; AVar "person"]
  | SUBST(_,AllAgr) -> [Atom "subst"; AVar "number"; AVar "case"; AVar "gender"; AVar "person"]
  | SUBST(_,CaseAgr) -> [Atom "subst"; Top; AVar "case"; Top; Top]
  | SUBST(_,CaseUndef) -> [Atom "subst"; Top; Top; Top; Top]
  | NUM(Case case,_,_) -> [Atom "num"; Top; Atom case; Top; Top]
  | NUM(NomAgr,_,_) -> [Atom "num"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"]
  | NUM(CaseAgr,_,_) -> [Atom "num"; Top; AVar "case"; Top; Top]
  | NUM(CaseUndef,_,_) -> [Atom "num"; Top; Top; Top; Top]
  | PREP(Case case) -> [Atom "prep"; Atom case]
  | ADJ(_,Case case,_,_) -> [Atom "adj"; Top; Atom case; Top]
  | ADJ(_,NomAgr,_,_) -> [Atom "adj"; AVar "number"; Atom "nom"; AVar "gender"]
  | ADJ(_,CaseAgr,_,_) -> [Atom "adj"; Top; AVar "case"; Top]
  | ADJ(_,AllAgr,_,_) -> [Atom "adj"; AVar "number"; AVar "case"; AVar "gender"]
  | ADV _ -> [Atom "adv"]
  | GER(_,Case case,_,_,_,_) -> [Atom "ger"; Top; Atom case; Top; Top]
  | GER(_,NomAgr,_,_,_,_) -> [Atom "ger"; AVar "number"; Atom "nom"; AVar "gender"; AVar "person"]
  | GER(_,CaseAgr,_,_,_,_) -> [Atom "ger"; Top; AVar "case"; Top; Top]
  | GER(_,CaseUndef,_,_,_,_) -> [Atom "ger"; Top; Top; Top; Top]
  | PACT(_,Case case,_,_,_,_) -> [Atom "pact"; Top; Atom case; Top]
  | PACT(_,NomAgr,_,_,_,_) -> [Atom "pact"; AVar "number"; Atom "nom"; AVar "gender"]
  | PACT(_,AllAgr,_,_,_,_) -> [Atom "pact"; AVar "number"; AVar "case"; AVar "gender"]
  | PACT(_,CaseAgr,_,_,_,_) -> [Atom "pact"; Top; AVar "case"; Top]
  | PPAS(_,Case case,_,_,_) -> [Atom "ppas"; Top; Atom case; Top]
  | PPAS(_,NomAgr,_,_,_) -> [Atom "ppas"; AVar "number"; Atom "nom"; AVar "gender"]
  | PPAS(_,AllAgr,_,_,_) -> [Atom "ppas"; AVar "number"; AVar "case"; AVar "gender"]
  | PPAS(_,CaseAgr,_,_,_) -> [Atom "ppas"; Top; AVar "case"; Top]
  | INF(Aspect aspect,_,_) -> [Atom "inf"; Atom aspect]
  | INF(AspectUndef,_,_) -> [Atom "inf"; Top]
  | QUB -> [Atom "qub"]
  | COMPAR -> [Atom "TODO"] (* FIXME: todo *)
  | COMP ctype -> [Atom "comp"; arg_of_ctype ctype]
  | PERS _ -> [Atom "TODO"] (* FIXME: todo *)
  | pos -> failwith ("make_arg_pos: " ^ ENIAMwalStringOf.pos pos)

let rec make_arg quant = function
    Phrase phrase -> make_arg_phrase phrase
  | E phrase -> make_arg_phrase phrase
  | LexArg(id,arg,lex) -> Tensor([Atom "lex";Atom id;Atom lex] @ make_arg_pos arg)
(*   | LexRealization(arg,lex) -> (match make_arg arg with Tensor l -> Tensor([Atom "lexr";Atom lex] @ l) | _ -> failwith "make_arg") *)
  | Raised(arg1,dir,arg2) -> Imp(Tensor(make_tensor_type quant arg1),dir_of_dir dir,Tensor(make_tensor_type quant arg2))
  | morf -> failwith ("make_arg: " ^ ENIAMwalStringOf.morf morf)

let empty_schema_field =
  {gf=NOGF; role=""; role_attr=""; sel_prefs=[]; cr=[]; ce=[]; dir=Both; morfs=[]}

(* let empty_node = {
  pred=""; cat=""; weight=0.; (*LCGtypes.*)id=0; gs=Dot; attrs=[]; args=Dot;
  agf=NOGF; amorf=Phrase Null; arole=""; arole_attr="";
  meaning=""; hipero=StringSet.empty; meaning_weight=0.;
  position=empty_schema_field;
} *)

(*let pro_id_counter = ref 0

let get_pro_id () =
  incr pro_id_counter;
  !pro_id_counter*)

let make_pro tokens lex_sems =
  let t = {empty_token with token=Lemma("pro","pro",[])} in
  let id = ExtArray.add tokens t in
  let _ = ExtArray.add lex_sems {empty_lex_sem with senses=["pro",["0"],0.]} in
  Node{empty_node with pred="pro"; cat="pro"; weight=0.; id=id; attrs=[]; args=Dot}

let make_prong tokens lex_sems =
  let t = {empty_token with token=Lemma("pro","pro",[])} in
  let id = ExtArray.add tokens t in
  let _ = ExtArray.add lex_sems {empty_lex_sem with senses=["pro",["0"],0.]} in
  Node{empty_node with pred="pro"; cat="pro"; weight=0.; id=id; attrs=["NUM",SubstVar "number";"GEND",SubstVar "gender";"PERS",SubstVar "person"]; args=Dot}

let make_pro_komunikat tokens lex_sems =
  let t = {empty_token with token=Lemma("pro-komunikat","pro",[])} in
  let id = ExtArray.add tokens t in
  let _ = ExtArray.add lex_sems {empty_lex_sem with senses=["pro-komunikat",["0"],0.]} in
  {empty_node with pred="pro-komunikat"; cat="pro"; weight=10.; id=id; attrs=[]; args=Dot}

let make_var vars gf =
  let v = try String.lowercase (String.sub gf 0 1) with _ -> "v" in
  let v = if v = "q" || v = "v" || v = "x" then "y" else v in
  try
    let i = StringMap.find vars v in
    v ^ string_of_int i, StringMap.add vars v (i+1)
  with Not_found -> v, StringMap.add vars v 2

(*let string_of_gf = function
    SUBJ -> "SUBJ"
  | OBJ -> "OBJ"
  | ARG -> "ARG"
  | CORE -> "CORE"
  | NOSEM -> "NOSEM"
  | ADJUNCT -> "ADJUNCT"
  | RAISED -> "RAISED"
  | NOGF -> "NOGF"
  | CLAUSE -> "CLAUSE"
  | SENTENCE -> "SENTENCE"*)

(*let string_of_gf = function
    SUBJ -> "subj"
  | OBJ -> "obj"
  | ARG -> "arg"
  | CORE -> "core"
  | NOSEM -> "nosem"
  | ADJUNCT -> "adjunct"
  | RAISED -> "raised"
  | NOGF -> "nogf"
  | CLAUSE -> "clause"
  | SENTENCE -> "sentence"*)

let make_args tokens lex_sems quant var_map v = function
    {gf=RAISED; morfs=[arg]} as s ->
      let arg = make_arg quant arg in
      ((dir_of_dir s.dir,arg),v,[],[Var v]),var_map
  | {gf=RAISED} -> failwith "make_args: RAISED"
(*  | {gf=NOSEM; morfs=[arg]} as s ->
      let arg = make_arg quant arg in
      ((dir_of_dir s.dir,arg),v,[Dot],[]),var_map
  | {gf=NOSEM} -> failwith "make_args: NOSEM"
  | {gf=NOGF} as s -> (* pro ani null nie może się tu pojawić; rolę tematyczną pomijamy *)
      let args2 = Xlist.map s.morfs (fun morf -> make_arg quant morf) in
(*       let pro_id = get_pro_id () in *)
      let sem_args = Xlist.map args2 (function
          One -> "q",Dot(*failwith "make_args 1"*)
        | _ -> "q",Var "q") in
      ((dir_of_dir s.dir,Plus args2),v,[Case(Var v,sem_args)],[]),var_map*)
  | {morfs=[Multi args]} as s -> (* pod multi nie może być Null, Pro ani ProNG *)
      let args2 = Xlist.map args (fun phrase -> make_arg_phrase phrase, Phrase phrase) in
      let sem_args =
        if s.role = "" then Xlist.map args2 (fun (_,morf) -> "q",SetAttr("GF",Gf s.gf,SetAttr("MORF",Morf morf,(*SetElem*)(Var "q"))))
        else Xlist.map args2 (fun (_,morf) -> "q",Cut(SetAttr("AROLE",Val s.role,SetAttr("GF",Gf s.gf,SetAttr("MORF",Morf morf,(*SetElem*)(Var "q")))))) in
      ((dir_of_dir s.dir,Maybe(Plus(Xlist.map args2 fst))),v,
         [Fix(Var v,Lambda("x"^v,Case(Var ("x"^v),sem_args)))],[]),var_map
  | s -> (* FIXME: argument pusty występuje tyle razy ile jest preferencji, a chyba powinien jeden raz *)
      let args2 = Xlist.map s.morfs (fun morf -> make_arg quant morf, morf) in
      let sem_args = Xlist.map args2 (function
          One, Phrase Pro -> SetAttr("MORF",Morf(Phrase Pro),make_pro tokens lex_sems) (*s.sel_prefs*)
        | One, Phrase ProNG -> SetAttr("MORF",Morf(Phrase ProNG),make_prong tokens lex_sems) (*s.sel_prefs*)
        | One, E Pro  -> SetAttr("MORF",Morf(E Pro ),make_pro tokens lex_sems) (*s.sel_prefs*)
        | One, E ProNG  -> SetAttr("MORF",Morf(E ProNG),make_prong tokens lex_sems) (*s.sel_prefs*)
        | One, Phrase Null -> Dot
        | One, _ -> failwith "make_args 3"
        | _,morf -> SetAttr("MORF",Morf morf,Var "q")) in
      let sem_args = if s.role = "" then sem_args else Xlist.map sem_args (function Dot -> Dot | t -> SetAttr("AROLE",Val s.role,t)) in
      let sem_args = Xlist.fold s.ce sem_args (fun sem_args e ->
        Xlist.map sem_args (function Dot -> Dot | t -> SetAttr("LABEL",Val e,t))) in
      let sem_args = Xlist.fold s.cr sem_args (fun sem_args e ->
        Xlist.map sem_args (function Dot -> Dot | t -> SetAttr("DEF",Val e,t))) in
      ((dir_of_dir s.dir,Plus(Xlist.map args2 fst)),v,
         [Case(Var v,Xlist.map sem_args (function Dot -> "q",Dot | t -> "q",Cut(SetAttr("AROLE",Val s.role,SetAttr("GF",Gf s.gf,(*SetElem*) t)))))],[]),var_map

let make_args2 tokens lex_sems quant var_map s =
  let v,var_map = make_var var_map (String.lowercase s.role) (*gf*) in
(*   let s = {s with morfs=List.flatten (Xlist.map s.morfs (function E l -> Xlist.map l (fun p -> E[p]) | m -> [m]))} in *)
  make_args tokens lex_sems quant var_map v s

let make_schema tokens lex_sems quant schema var_map =
  let schema,_,var_map = Xlist.fold schema ([],StringMap.empty,var_map) (fun (schema,labels,var_map) s ->
    let schema_pos,var_map = make_args2 tokens lex_sems quant var_map s in
    schema_pos :: schema, labels, var_map) in
  Xlist.fold schema ([],[],[],[]) (fun (args,vars,sem_args,raised_args) (arg,var,sem_arg,raised_arg) ->
    arg :: args, var :: vars, sem_arg @ sem_args, raised_arg @ raised_args), var_map

let add_x_args schema_list =
  [{gf=ADJUNCT; role="Unknown Backward"; role_attr="Backward"; sel_prefs=[]; cr=[]; ce=[]; dir=Backward; morfs=[Multi[X]]};
   {gf=ADJUNCT; role="Unknown Forward"; role_attr="Forward"; sel_prefs=[]; cr=[]; ce=[]; dir=Forward; morfs=[Multi[X]]}] :: schema_list

let make_frame x_flag tokens lex_sems quant schema_list tl d node = (* UWAGA: to zadziała, gdy jest conajwyżej jeden podniesiony typ *)
  let schema_list = if x_flag then add_x_args schema_list else schema_list in
  let args_vars_list,sem_args,raised_args,_ = Xlist.fold schema_list ([],[],[],StringMap.empty) (fun (args_vars_list,sem_args,raised_args,var_map) schema ->
(*     print_endline (ENIAMwalStringOf.schema schema); *)
    let (args,vars,sem_arg,raised_arg),var_map = make_schema tokens lex_sems quant schema var_map in
    (args,vars) :: args_vars_list, sem_arg @ sem_args, raised_arg @ raised_args, var_map) in
  let t = Tensor(make_tensor_type quant tl) in
  let at = Xlist.fold schema_list tl (fun at schema ->
    Xlist.fold schema at (fun at s ->
      Xlist.fold s.morfs at (fun at -> function
        Raised(arg1,dir,arg2) -> arg2
      | _ -> at))) in
(*   let dot_list = Xlist.map (List.tl at) (fun _ -> Dot) in *)
  let sem = (*Tuple( *)Node{node with args=Tuple(node.args :: sem_args); gs=make_gs quant at}(* :: dot_list)*) in
  let sem =
    match raised_args with
      [] -> sem
    | [raised_arg] -> App(raised_arg,sem)
    | _ -> failwith "make_frame: raised_args" in
  let t,sem = Xlist.fold args_vars_list (t,sem) (fun (t,sem) (args,vars) ->
    simplify_impset (ImpSet(t,args),LambdaSet(vars,sem))) in
  make_type_quantification quant (t,sem)

let make_frame_raised tokens lex_sems quant schema_list tl d node sem_mods =
  let args_vars_list,sem_args,raised_args,_ = Xlist.fold schema_list ([],[],[],StringMap.empty) (fun (args_vars_list,sem_args,raised_args,var_map) schema ->
    let (args,vars,sem_arg,raised_arg),var_map = make_schema tokens lex_sems quant schema var_map in
    (args,vars) :: args_vars_list, sem_arg @ sem_args, raised_arg @ raised_args, var_map) in
  let t = Tensor(make_tensor_type quant tl) in
  let at = Xlist.fold (List.rev schema_list) tl (fun at schema ->
    Xlist.fold schema at (fun at s ->
      Xlist.fold s.morfs at (fun at -> function
        Raised(arg1,dir,arg2) -> arg2
      | _ -> at))) in
(*   let dot_list = Xlist.map (List.tl at) (fun _ -> Dot) in *)
  let sem = (*Tuple( *)Node{node with args=Tuple(node.args :: sem_args); gs=make_gs quant at}(* :: dot_list)*) in
  let sem =
    match raised_args with
      [] -> sem
    | [raised_arg] -> App(raised_arg,sem)
    | [raised_arg2;raised_arg1] -> App(raised_arg2,App(raised_arg1,sem))
    | [raised_arg3;raised_arg2;raised_arg1] -> App(raised_arg3,App(raised_arg2,App(raised_arg1,sem)))
    | _ -> failwith "make_frame_raised: raised_args" in
  let sem = Xlist.fold sem_mods sem (fun sem (e,t) -> SetAttr(e,t,sem)) in
  let id = ExtArray.add tokens {empty_token with token=Lemma("raised","raised",[])} in (* FIXME: czy raised to jest to co tu być powinno? *)
  let _ = ExtArray.add lex_sems empty_lex_sem in
  let sem = Node{empty_node with args = Cut(SetAttr("GF",Gf CORE,sem)); id=id; gs=make_gs quant tl} in
  let t,sem = Xlist.fold args_vars_list (t,sem) (fun (t,sem) (args,vars) ->
    simplify_impset (ImpSet(t,args),LambdaSet(vars,sem))) in
  make_type_quantification quant (t,sem)

let make_frame_simple quant tl d node =
  let t = Tensor(make_tensor_type quant tl) in
(*   let dot_list = Xlist.map (List.tl tl) (fun _ -> Dot) in *)
  let sem = (*Tuple( *)Node{node with gs=make_gs quant tl} (*:: dot_list)*) in
  make_type_quantification quant (t,sem)

let make_conj_frame quant larg rarg tl d node =
  make_type_quantification quant
    (Imp(Imp(Tensor(make_tensor_type quant tl),Forward,larg),Backward,rarg),
     Lambda("x",Lambda("y",Node{node with gs=make_gs quant tl;
       args=Tuple[Cut(SetAttr("GF",Gf CORE,Var "x"));Cut(SetAttr("GF",Gf CORE,Var "y"))]})))

let make_quot_frame quant arg qarg tl d node =
  make_type_quantification quant
    (Imp(Imp(Tensor(make_tensor_type quant tl),Forward,qarg),Forward,arg),
     Lambda("x",Lambda("y",Node{node with gs=make_gs quant tl; args=Tuple[
       Cut(SetAttr("GF",Gf CORE,SetAttr("QUOT",Val "+",Var "x")));
       Cut(SetAttr("GF",Gf NOSEM,Var "y"))]})))

let make_inclusion_frame qarg d node =
  Imp(Imp(Tensor[Atom "inclusion"],Forward,qarg),Forward,Plus[
             Tensor[Atom "np"; Top; Top; Top; Top];
             Tensor[Atom "ip"; Top; Top; Top];
             Tensor[Atom "adjp"; Top; Top; Top];
             Tensor[Atom "prepnp"; Top; Top]]),
  Lambda("x",Lambda("y",Node{node with gs=make_gs [] ["inclusion"]; args=Tuple[
    Cut(SetAttr("AROLE",Val "Inclusion",SetAttr("GF",Gf CORE,SetAttr("INCLUSION",Val "+",Case(Var "x",["q",Var "q";"q",Var "q";"q",Var "q";"q",Var "q"])))));
    Cut(SetAttr("GF",Gf NOSEM,Var "y"))]}))

let or_frame node =
  Imp(Imp(Imp(Tensor[Atom "<root>"],Forward,
              Tensor[Atom "</speaker>"]),Forward,
          Imp(Tensor[Atom "ip"; Top; Top; Top],Forward,Tensor[Atom "or"])),Forward,
      Tensor[Atom "or2"]),
  Lambda("x",Lambda("y",Lambda("z",Node{node with gs=make_gs [] ["<root>"]; args=Tuple[
    Cut(SetAttr("AROLE",Val "Clause",SetAttr("GF",Gf CLAUSE,App(Var "y",Var "x"))))]})))


let label_counter = ref 0

let get_label () =
  incr label_counter;
  string_of_int (!label_counter)

(*let find_label labels e =
  try StringMap.find labels e, labels
  with Not_found -> let label = get_label () in label, StringMap.add labels e label*)

let rec get_controll_labels labels = function
    t :: l ->
        let labels = Xlist.fold t.cr labels (fun labels e ->
          if StringMap.mem labels e then labels else
          StringMap.add labels e (get_label ())) in
        get_controll_labels labels l
  | [] -> labels

let add_label_schema labels schema =
  try Xlist.map schema (fun t ->
    {t with cr=Xlist.map t.cr (StringMap.find labels);
            ce=Xlist.map t.ce (StringMap.find labels)})
  with Not_found -> failwith "add_label_schema" (* FIXME: pojawia się błąd co znaczy, że zdarzają się schematy z brakującymi cr *)

let make_controll frames =
  let labels = Xlist.fold frames StringMap.empty (fun labels -> function
      _,Frame(_,schema) -> get_controll_labels labels schema
    | _,LexFrame(_,_,_,schema) -> get_controll_labels labels schema
    | _,ComprepFrame(_,_,_,schema) -> get_controll_labels labels schema) in
  Xlist.map frames (function
      n,Frame(a,schema) -> n,Frame(a,add_label_schema labels schema)
    | n,LexFrame(a,b,r,schema) -> n,LexFrame(a,b,r,add_label_schema labels schema)
    | n,ComprepFrame(a,b,r,schema) -> n,ComprepFrame(a,b,r,add_label_schema labels schema))

(*  List.rev(fst (Xlist.fold schema ([],StringMap.empty) (fun (schema,labels) s ->
    let cr,labels = Xlist.fold s.cr ([],labels) (fun (cr,labels) e ->
      let label,labels = find_label labels e in
      label :: cr, labels) in
    let ce,labels = Xlist.fold s.ce ([],labels) (fun (ce,labels) e ->
      let label,labels = find_label labels e in
      label :: ce, labels) in
    {s with cr=cr; ce=ce} :: schema, labels)))*)