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 LCGtypes
open Xstd
open Printf

let empty_concept = 
  {c_sense=Dot;c_name=Dot;(* c_variable: string; c_visible_var: bool;*) c_quant=Dot; c_local_quant=true; (*c_modalities: (string * type_term) list;
   c_left_input_pos: int; c_right_input_pos: int;*) c_relations=Dot; c_variable="",""; c_pos=(-1)}
   
let empty_context = {cx_sense=Dot; cx_contents=Dot; cx_relations=Dot; cx_variable="",""; cx_pos=(-1)}

let rec remove_unimportant_attrs = function
  | ("FNUM",_) :: attrs -> remove_unimportant_attrs attrs
  | ("AROLE",_) :: attrs -> remove_unimportant_attrs attrs
  | (e,t) :: attrs -> (e,t) :: remove_unimportant_attrs attrs
  | [] -> []
   
let make_sem_args = function
    [] -> Dot
  | [s] -> Val s
  | l -> Variant(LCGreductions.get_variant_label (), fst (Xlist.fold l ([],1) (fun (l,i) t -> 
        (string_of_int i, Val t) :: l,i+1)))
   
let rec make_args_list = function 
    Tuple l -> List.flatten (Xlist.map l make_args_list)
  | t -> [t]
 
let symbols = StringSet.of_list [
  "symbol"; "date"; "date-interval"; "hour-minute"; "hour"; "hour-minute-interval"; "hour-interval"; 
  "year"; "year-interval"; "day"; "day-interval"; "day-month"; "day-month-interval"; "month-interval"; "roman"; "roman-interval"; 
  "match-result"; "url"; "email"; "obj-id";
  "month-lex"; "day-lex"]
 
let rec get_person = function
   ("PERS", Val s) :: _ -> s
 | ("PERS", _) :: _-> failwith "get_person"
 | _ :: l -> get_person l
 | [] -> ""
 
let rec create_normal_concept (*roles role_attrs*) paths t sem_args =
  let sem_args = if t.cat = "pro" then 
    match get_person t.attrs with
      "pri" -> ["indexical"]
    | "sec" -> ["indexical"]
    | "ter" -> ["coreferential";"deictic"]
    | "" -> ["indexical";"coreferential";"deictic"]
    | _ -> failwith "create_normal_concept: pro"
    else sem_args in (* FIXME: przesunąć to do rozszerzania path_array *)
  if t.agf = WalTypes.NOSEM then t.args else
  let c = {empty_concept with 
    c_sense = Val t.meaning; 
    c_relations=(*create_concepts paths*) t.args;
    c_quant=make_sem_args sem_args;
    c_variable=string_of_int t.id,"";
    c_pos=(*if t.id >= Array.length paths then -1 else*) paths.(t.id).PreTypes.beg;
    c_local_quant=true} in
  if t.cat = "subst" || t.cat = "depr" || t.cat = "ger" || t.cat = "unk" || StringSet.mem symbols t.cat then (* FIXME: wykrywanie plurale tantum *)
    let c = {c with c_local_quant=false} in
    let c,measure,cx_flag = Xlist.fold t.attrs (c,false,false) (fun (c,measure,cx_flag) -> function
        "SYN",Val "common" -> c,measure,cx_flag
      | "SYN",Val "proper" -> {c with c_name=Val t.pred; c_sense=if Val t.pred=c.c_sense then Dot else c.c_sense},measure,cx_flag (* Rozpoznawanie propoer names nieznanego typu - ryzykowne ale proste *)
      | "SYN",Val "pronoun" -> c(*{c with c_quant=Tuple[c.c_quant;Val "indexical"]}*),measure,cx_flag
      | "NSEM",Val "count" -> c(*{c with c_quant=Tuple[c.c_quant;Val "count"]}*),measure,cx_flag
      | "NSEM",Val "mass" -> {c with c_quant=Tuple[c.c_quant;Val "mass"]},measure,cx_flag
      | "NSEM",Val "measure" -> c,true,cx_flag
      | "NSEM",Val "time" -> c,measure,cx_flag(*failwith "create_normal_concept: time"*)
      | "NUM",t -> {c with c_quant=Tuple[c.c_quant;t]},measure,cx_flag
      | "CASE",_ -> c,measure,cx_flag
      | "GEND",_ -> c,measure,cx_flag
      | "PERS",Val "ter" -> c,measure,cx_flag
      | "PERS",Val "sec" -> {c with c_relations=Tuple[c.c_relations;SingleRelation(Val "impt")]},measure,true
      | "ASPECT",_ -> c,measure,cx_flag
      | "NEG",Val "+" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]},measure,cx_flag
      | "INCLUSION",_ -> c,measure ,cx_flag
      | "QUOT",Val "+" -> {c with c_relations=Tuple[c.c_relations;SingleRelation(Val "quot")]},measure,cx_flag
      | "LEX",_ -> c,measure,cx_flag (* FIXME *)
(*       | "TYPE",Val "int" -> {c with c_quant=Tuple[c.c_quant;Val "interrogative"]},measure *)
      | "TYPE",_ -> c,measure,cx_flag (* FIXME *)
      | e,t -> failwith ("create_normal_concept noun: " ^ e)) in
    let c = if t.cat = "depr" then {c with c_relations=Tuple[c.c_relations;SingleRelation(Val "depr")]} else c in
    if cx_flag then 
      Context{empty_context with cx_contents=Concept c; cx_variable=string_of_int (LCGrenderer.get_pro_id ()),""; cx_pos=c.c_pos}
    else Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "fin" || t.cat = "bedzie" || t.cat = "praet" || t.cat = "winien" || t.cat = "impt" || t.cat = "imps" || t.cat = "pred" || t.pred = "pro-komunikować" then 
    let c = {c with c_local_quant=false} in
    let c = Xlist.fold t.attrs c (fun c -> function
(*         "MEANING",t -> {c with c_sense=Tuple[c.c_sense;t]} *)
      | "NUM",t -> c
      | "GEND",_ -> c
      | "PERS",_ -> c
      | "ASPECT",_ -> c
      | "CTYPE",_ -> c (* FIXME *)
      | "TENSE",t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "MOOD",Val "indicative" -> c
      | "MOOD",Val "conditional" -> {c with c_relations=Tuple[c.c_relations;SingleRelation(Val "cond")]} (* FIXME *)
      | "MOOD",Val "imperative" -> {c with c_relations=Tuple[c.c_relations;SingleRelation(Val "impt")]} (* FIXME *)
      | "NEG",Val "+" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]}
      | e,t -> failwith ("create_normal_concept verb: " ^ e)) in
    let cx = {empty_context with cx_contents=Concept c; cx_variable=string_of_int (LCGrenderer.get_pro_id ()),""; cx_pos=c.c_pos} in
    if t.position.WalTypes.role <> "" || t.position.WalTypes.role_attr <> "" then failwith "create_normal_concept: verb" else
(*     Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Context cx) else *)
    Context cx else
  if t.cat = "inf" then 
    let c = {c with c_local_quant=false} in
    let c = Xlist.fold t.attrs c (fun c -> function
      | "ASPECT",_ -> c
      | "TENSE",t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "NEG",Val "+" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]}
      | e,t -> failwith ("create_normal_concept verb: " ^ e)) in
    let cx = {empty_context with cx_contents=Concept c; cx_variable=string_of_int (LCGrenderer.get_pro_id ()),""; cx_pos=c.c_pos} in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Context cx) else 
  if t.cat = "adj" || t.cat = "adjc" || t.cat = "adjp" || t.cat = "adja" || t.cat = "pact" || t.cat = "ppas" || t.cat = "ordnum" || t.cat = "roman-adj" then 
    let c = if t.cat = "pact" || t.cat = "ppas" then {c with c_local_quant=false} else c in
    let c = Xlist.fold t.attrs c (fun c -> function
(*         "MEANING",t -> {c with c_sense=Tuple[c.c_sense;t]} *)
      | "SYN",Val "common" -> c
      | "SYN",Val "pronoun" -> c(*{c with c_quant=Tuple[c.c_quant;Val "indexical"]}*)
      | "SYN",Val "proper" -> if t.cat = "roman-adj" then c else failwith "create_normal_concept adj: SYN=proper"
      | "NSEM",Val "count" -> if t.cat = "roman-adj" then c else failwith "create_normal_concept adj: NSEM=count"
      | "NUM",_ -> c
      | "CASE",_ -> c
      | "GEND",_ -> c
      | "GRAD",_ -> c
      | "ASPECT",_ -> c
(*       | "TYPE",Val "int" -> {c with c_quant=Tuple[c.c_quant;Val "interrogative"]} *)
      | "TYPE",_ -> c (* FIXME *)
      | "PERS",_ -> c
      | "NEG",Val "+" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]}
      | "LEX",_ -> c (* FIXME *)
      | e,t -> failwith ("create_normal_concept adj: " ^ e)) in
    if t.cat = "pact" || t.cat = "ppas" then 
      RevRelation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) 
    else Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "adv" || t.cat = "pcon" || t.cat = "pant" then 
    let c = if t.cat = "pcon" || t.cat = "pant" then {c with c_local_quant=false} else c in
    let c = Xlist.fold t.attrs c (fun c -> function
(*         "MEANING",t -> {c with c_sense=Tuple[c.c_sense;t]} *)
      | "GRAD",_ -> c
      | "ASPECT",_ -> c
(*       | "TYPE",Val "int" -> {c with c_quant=Tuple[c.c_quant;Val "interrogative"]} *)
      | "TYPE",_ -> c
      | "NEG",Val "+" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]}
      | e,t -> failwith ("create_normal_concept adv: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "pro" || t.cat = "ppron12" || t.cat = "ppron3" || t.cat = "siebie" then (* FIXME: indexicalność *)
    let c = {c with c_local_quant=false} in
    let c = Xlist.fold t.attrs c (fun c -> function
        "NUM",t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "GEND",t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "PERS",t2 -> if t.cat = "siebie" then c else {c with c_relations=Tuple[c.c_relations;SingleRelation t2]}
      | "CASE",_ -> c
      | "SYN",_ -> c
      | "NSEM",_ -> c
      | e,t -> failwith ("create_normal_concept pron: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "prep" then 
    if t.arole = "NOSEM" then Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,t.args) else
    let c = Xlist.fold t.attrs c (fun c -> function
      | "CASE",_ -> c
      | e,t -> failwith ("create_normal_concept prep: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "num" || t.cat = "intnum" || t.cat = "realnum" || t.cat = "intnum-interval" || t.cat = "realnum-interval" then 
    let c = Xlist.fold t.attrs c (fun c -> function
(*         "MEANING",t -> {c with c_sense=Tuple[c.c_sense;t]} *)
      | "ACM",_ -> c
      | "NUM",_ -> c
      | "CASE",_ -> c
      | "GEND",_ -> c
      | "PERS",_ -> c
      | "TYPE",_ -> c
      | e,t -> failwith ("create_normal_concept num: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,(*Quantifier*)(Concept c)) else
  if t.cat = "qub" && t.pred="się" then 
    let c = {c with c_quant=Tuple[c.c_quant;Val "coreferential"]} in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,(*Quantifier*)(Concept c)) else
  if t.cat = "qub" && (t.pred="czy" || t.pred="gdyby") then 
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,SetContextName(t.meaning,t.args)) else
  if t.cat = "qub" then 
    let c = Xlist.fold t.attrs c (fun c -> function
(*      | "TYPE",Val "int" -> {c with c_quant=Tuple[c.c_quant;Val "interrogative"]}
      | "TYPE",_ -> c*)
      | e,t -> failwith ("create_normal_concept qub: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Concept c) else
  if t.cat = "comp" then 
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,SetContextName(t.meaning,t.args)) else
  if t.cat = "conj" then 
    let c = {empty_context with cx_sense=Val t.meaning; cx_contents=RemoveRelation t.args; cx_variable=string_of_int t.id,""; cx_pos=c.c_pos} in 
    let c = Xlist.fold t.attrs c (fun c -> function
      | "NUM",_ -> c
      | "CASE",_ -> c
      | "GEND",_ -> c
      | "PERS",_ -> c
      | e,t -> failwith ("create_normal_concept conj: " ^ e)) in
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,Context c) else
  if t.cat = "interj" then Node t else
  if t.cat = "sinterj" then 
    let c = Xlist.fold t.attrs c (fun c -> function
      | e,t -> failwith ("create_normal_concept sinterj: " ^ e)) in
    Concept c else
  if t.cat = "interp" && t.pred = "</sentence>" then 
    let l = List.rev (make_args_list t.args) in
    Xlist.fold (List.tl l) (List.hd l) (fun t s -> AddRelation(RemoveRelation t,"Next","Clause",RemoveRelation s)) else
  if t.cat = "interp" && t.pred = "<sentence>" then t.args else     
  if t.cat = "interp" && t.pred = "”s" then 
    let l = List.rev (make_args_list t.args) in
    let x = Xlist.fold (List.tl l) (List.hd l) (fun t s -> AddRelation(RemoveRelation t,"Next","Sentence",RemoveRelation s)) in
    Relation(Val t.arole,Val t.arole_attr,x) else (* FIXME: czy na pewno tu i w następnych arole a nie position.role? *)
  if t.cat = "interp" && t.pred = "<or>" then 
    Relation(Val t.arole,Val t.arole_attr,t.args) else
  if t.cat = "interp" && t.pred = "<speaker>" then 
    Relation(Val t.arole,Val t.arole_attr,RemoveRelation t.args) else
  if t.cat = "interp" && t.pred = "</query>" then 
    let l = List.rev (make_args_list t.args) in
    let x = Xlist.fold (List.tl l) (List.hd l) (fun t s -> AddRelation(RemoveRelation t,"Next","Sentence",RemoveRelation s)) in
    if t.agf = WalTypes.OBJ then Relation(Val t.arole,Val t.arole_attr,x) else x else
  if t.cat = "interp" && t.pred = "<query1>" then t.args else     
  if t.cat = "interp" && t.pred = "<query2>" then t.args else     
  if t.cat = "interp" && t.pred = "<query4>" then t.args else     
  if t.cat = "interp" && t.pred = "<query5>" then 
    let l = List.rev (make_args_list t.args) in
    Xlist.fold (List.tl l) (List.hd l) (fun t s -> AddRelation(RemoveRelation t,"Next","Sentence",RemoveRelation s)) else
  if t.cat = "interp" && t.pred = "<query6>" then 
    let l = List.rev (make_args_list t.args) in
    Xlist.fold (List.tl l) (List.hd l) (fun t s -> AddRelation(RemoveRelation t,"Next","Sentence",RemoveRelation s)) else
  if t.cat = "interp" && t.pred = "?" then SingleRelation(Val "int") else     
  if t.cat = "interp" && t.pred = "„" then 
    Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,RemoveRelation t.args) else
  if t.cat = "interp" then Node t else
  if t.cat = "" then Relation(Val t.position.WalTypes.role,Val t.position.WalTypes.role_attr,t.args) else
  Node t

and create_concepts paths = function
    Node t -> 
(*       let agf = t.agf in *)
      let attrs =  remove_unimportant_attrs t.attrs in
(*       let attrs,roles,role_attrs = get_roles attrs in *)
       let t = {t with attrs=attrs} in 
      (match paths.(t.id).PreTypes.semantics with
        PreTypes.Normal -> 
          let t = create_normal_concept paths t [] in
(*           if agf = WalTypes.CORE then Core t else *) t
      | PreTypes.PrepSemantics _ -> 
          let t = create_normal_concept paths t [] in
(*           if agf = WalTypes.CORE then Core t else *) t
      | PreTypes.Special l -> 
          let t = create_normal_concept paths t l in
(*           if agf = WalTypes.CORE then Core t else *) t
(*      | PreTypes.SpecialNoun(lemma,_) -> 
          let t = create_normal_concept paths t in*)
(*           if agf = WalTypes.CORE then Core t else  t*)
      (*| _ -> failwith "create_concepts: ni"*))
  | Tuple l -> Tuple(Xlist.map l (create_concepts paths))
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, create_concepts paths t))
  | Dot -> Dot
  | Ref i -> Ref i
  | Choice choices -> Choice(StringMap.map choices (create_concepts paths))
  | t -> failwith ("create_concepts: " ^ LCGstringOf.linear_term 0 t)


let translate paths term =
  let sem = Array.copy term in
  Int.iter 0 (Array.length sem - 1) (fun i ->
    sem.(i) <- create_concepts paths sem.(i));
  sem
  
(***************************************************************************************)

let rec make_tree_choice references ei = function 
    Choice choice -> (try make_tree_variant references (StringMap.find choice ei) with Not_found -> failwith "make_tree_choice")
  | _ -> failwith "make_tree_choice"
  
and make_tree_variant references = function 
    Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) ->  i, make_tree_rec references (e ^ i) t))
  | _ -> failwith "make_tree_variant"
  
and make_tree_rec references ei = function 
    Node t -> Node{t with args=make_tree_rec references ei t.args}
  | Concept c -> Concept{c with c_relations=make_tree_rec references ei c.c_relations}
  | Context c -> Context{c with cx_contents=make_tree_rec references ei c.cx_contents; cx_relations=make_tree_rec references ei c.cx_relations}
  | Relation(r,a,t) -> Relation(r,a,make_tree_rec references ei t)
  | RevRelation(r,a,t) -> RevRelation(r,a,make_tree_rec references ei t)
  | SingleRelation r  -> SingleRelation r
  | AddRelation(t,r,a,s) -> AddRelation(make_tree_rec references ei t,r,a,make_tree_rec references ei s)
  | RemoveRelation t -> RemoveRelation(make_tree_rec references ei t)
  | SetContextName(s,t) -> SetContextName(s,make_tree_rec references ei t)
  | Tuple l -> Tuple(Xlist.map l (make_tree_rec references ei))
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, make_tree_rec references ei t))
  | Dot -> Dot
  | Val s -> Val s
  | Ref i -> make_tree_choice references ei references.(i)
  | t -> failwith ("make_tree_rec: " ^ LCGstringOf.linear_term 0 t)

let make_tree references =
  RemoveRelation(make_tree_variant references references.(0))
  
let rec simplify_tree_add_relation r a s = function
    Concept c -> Concept{c with c_relations=Tuple[Relation(Val r,Val a,s);c.c_relations]}
  | Context c -> Context{c with cx_relations=Tuple[Relation(Val r,Val a,s);c.cx_relations]}
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, simplify_tree_add_relation r a s t))
  | t -> AddRelation(t,r,a,s)    
  
let rec transpose_tuple_variant e ll = 
  match List.hd ll with 
    _,[] -> []
  | _ -> 
     let hd,tl = Xlist.fold ll ([],[]) (fun (hd,tl) (i,l) ->
       (i,List.hd l) :: hd, (i,List.tl l) :: tl) in
     (Variant (e,List.rev hd)) :: (transpose_tuple_variant e (List.rev tl))
 
(* FIXME TODO: 
Bryka chmara wieczorów: problem z wyborem relacji 
uzgadnianie preferencji i role tematyczne przy num, measure i prep:nosem
Witold bryka.: dezambiguacja
Niearanżowany szpak bryka.: lematyzacja 'Niearanżowany'

dobre:
Bryka na chmarze strusi.
Pięć strusi bryka.
*)
  
let rec simplify_tree = function
    Node t -> Node{t with args=simplify_tree t.args}
  | Concept c -> Concept{c with c_relations=simplify_tree c.c_relations}
  | Context c -> Context{c with cx_contents=simplify_tree c.cx_contents; cx_relations=simplify_tree c.cx_relations}
  | Relation(r,a,t) -> Relation(r,a,simplify_tree t)
  | RevRelation(r,a,t) -> RevRelation(r,a,simplify_tree t)
  | SingleRelation r  -> SingleRelation r
(*  | AddRelation(Concept c,r,a,s) -> simplify_tree (Concept{c with c_relations=Tuple[Relation(Val r,Val a,s);c.c_relations]})
  | AddRelation(Context c,r,a,s) -> simplify_tree (Context{c with cx_relations=Tuple[Relation(Val r,Val a,s);c.cx_relations]})*)
  | AddRelation(t,r,a,s) -> simplify_tree_add_relation r a (simplify_tree s) (simplify_tree t)
(*      let t = simplify_tree t in
      let s = simplify_tree s in
      (match t with 
        Concept c -> Concept{c with c_relations=Tuple[Relation(Val r,Val a,s);c.c_relations]}
      | Context c -> Context{c with cx_relations=Tuple[Relation(Val r,Val a,s);c.cx_relations]}
      | _ -> AddRelation(t,r,a,s))*)
  | RemoveRelation t ->
      (match simplify_tree t with
        Relation (_,_,t) -> t
      | Dot -> Dot
      | Variant(e,l) -> simplify_tree (Variant(e,Xlist.map l (fun (i,t) -> i,RemoveRelation t)))
      | Tuple l -> simplify_tree (Tuple(Xlist.map l (fun t -> RemoveRelation t)))
      | Context t -> Context t 
      | Concept t -> Concept t 
      | t -> RemoveRelation t)
  | SetContextName(s,t) ->
      (match simplify_tree t with
        Context t -> Context{t with cx_sense=Val s}
      | t ->  SetContextName(s,t))
  | Tuple l -> 
      let l = Xlist.fold l [] (fun l t ->
        match simplify_tree t with
          Dot -> l
        | t -> t :: l) in
      (match l with
        [] -> Dot
      | [t] -> t
      | l -> Tuple(List.rev l))
  | Variant(_,[_,t]) -> simplify_tree t
  | Variant(e,l) -> 
      let l = Xlist.map l (fun (i,t) -> i, simplify_tree t) in
      let _,t = List.hd l in
      let b = Xlist.fold (List.tl l) true (fun b (_,s) -> if s = t then b else false) in
      if b then t else 
      (try
        (match t with
           Concept c -> 
             let lt = Xlist.fold l [] (fun lt -> function
                 i,Concept c2 -> if c.c_sense = c2.c_sense && c.c_quant = c2.c_quant then (i,c2.c_relations) :: lt else raise Not_found
               | _ -> raise Not_found) in
             Concept{c with c_relations = simplify_tree (Variant(e,lt))}
         | Context c -> 
             let lt1,lt2 = Xlist.fold l ([],[]) (fun (lt1,lt2) -> function
                 i,Context c2 -> (i,c2.cx_contents) :: lt1, (i,c2.cx_relations) :: lt2
               | _ -> raise Not_found) in
             Context{c with cx_contents= simplify_tree (Variant(e,lt1)); cx_relations = simplify_tree (Variant(e,lt2))}
        | Tuple tl -> 
(*             print_endline ("V3: " ^ LCGstringOf.linear_term 0 (Variant l));  *)
            let n = Xlist.size tl in 
            let lt = Xlist.fold l [] (fun lt -> function
              i,Tuple tl -> if n = Xlist.size tl then (i,tl) :: lt else raise Not_found
            | _ -> raise Not_found) in
            let t = Tuple(transpose_tuple_variant e lt) in
(*             print_endline ("V4: " ^ LCGstringOf.linear_term 0 t); *)
            simplify_tree t
         | Dot -> if Xlist.fold l true (fun b -> function
              _,Dot -> b
            | _ -> false) then Dot else raise Not_found
         | _ -> raise Not_found)
      with Not_found -> Variant(e,l))
(*   Variant(e,Xlist.map l (fun (i,t) -> i, simplify_tree t)) *)
  | Dot -> Dot
  | Val s -> Val s
  | t -> failwith ("simplify_tree: " ^ LCGstringOf.linear_term 0 t)

let rec manage_quantification2 (quants,quant) = function
    Tuple l -> Xlist.fold l (quants,quant) manage_quantification2
  | Dot -> quants,quant
  | Val s -> quants,Tuple[Val s;quant]
  | t -> (Relation(Val "Quantifier",Val "",t)) :: quants,quant
  
let rec manage_quantification = function
    Node t -> Node{t with args=manage_quantification t.args}
  | Concept c -> 
       let quants,quant = manage_quantification2 ([],Dot) c.c_quant in
       Concept{c with c_quant=quant; c_relations=manage_quantification (Tuple(c.c_relations :: quants))}
  | Context c -> Context{c with cx_contents=manage_quantification c.cx_contents; cx_relations=manage_quantification c.cx_relations}
  | Relation(r,a,t) -> Relation(r,a,manage_quantification t)
  | RevRelation(r,a,t) -> RevRelation(r,a,manage_quantification t)
  | SingleRelation r  -> SingleRelation r
  | AddRelation(t,r,a,s) -> AddRelation(manage_quantification t,r,a,manage_quantification s)
  | RemoveRelation t -> RemoveRelation(manage_quantification t)
  | Tuple l -> Tuple(Xlist.map l manage_quantification)
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, manage_quantification t))
  | Dot -> Dot
  | Val s -> Val s
  | t -> failwith ("manage_quantification: " ^ LCGstringOf.linear_term 0 t)

let simplify_gender2 = function
    Variant(e,l) -> 
      (try
        let l2 = List.sort compare (Xlist.rev_map l (function (_,Val s) -> s | _ -> raise Not_found)) in
        match l2 with
          ["f"; "m1"; "m2"; "m3"; "n1"; "n2"; "p1"; "p2"; "p3"] -> Dot
        | ["m1"; "m2"; "m3"] -> Val "m"
        | ["n1"; "n2"] -> Val "n"
        | ["f"; "m2"; "m3"; "n1"; "n2"; "p2"; "p3"] -> Val "nmo"
        | ["m1"; "p1"] -> Val "mo"
        | ["f"; "m1"; "m2"; "m3"; "n1"; "n2"] -> Dot
        | ["pl"; "sg"] -> Dot
(*        |  -> Val ""
        |  -> Val ""*)
        | _ -> (*print_endline ("[\"" ^ String.concat "\"; \"" l2 ^ "\"]");*) Variant(e,l)
      with Not_found -> Variant(e,l))
  | t -> t
  
let rec simplify_gender = function
    Node t -> Node{t with args=simplify_gender t.args}
  | Concept c -> Concept{c with c_relations=simplify_gender c.c_relations}
  | Context c -> Context{c with cx_contents=simplify_gender c.cx_contents; cx_relations=simplify_gender c.cx_relations}
  | Relation(r,a,t) -> Relation(r,a,simplify_gender t)
  | RevRelation(r,a,t) -> RevRelation(r,a,simplify_gender t)
  | SingleRelation r  -> 
      let t = simplify_gender2 r in
      if t = Dot then Dot else SingleRelation t
  | AddRelation(t,r,a,s) -> AddRelation(simplify_gender t,r,a,simplify_gender s)
  | RemoveRelation t -> RemoveRelation(simplify_gender t)
  | Tuple l -> Tuple(Xlist.map l simplify_gender)
  | Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, simplify_gender t))
  | Dot -> Dot
  | Val s -> Val s
  | t -> failwith ("simplify_gender: " ^ LCGstringOf.linear_term 0 t)

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

let rec validate_semantics_quant = function
    Val _ -> true
  | Variant(e,l) -> Xlist.fold l true (fun b (_,t) -> b && validate_semantics_quant t)
  | Tuple l -> Xlist.fold l true (fun b t -> b && validate_semantics_quant t)
  | Dot -> true
  | t -> (*print_endline ("validate_semantics_quant: " ^ LCGstringOf.linear_term 0 t);*) false
  
let rec validate_semantics_sense = function
    Val _ -> true
  | Dot -> true
  | t -> (*print_endline ("validate_semantics_sense: " ^ LCGstringOf.linear_term 0 t);*) false
  
let rec validate_semantics_rel_name = function
    Val _ -> true
  | t -> (*print_endline ("validate_semantics_rel_name: " ^ LCGstringOf.linear_term 0 t);*) false
  
let rec validate_semantics = function
    Context c -> validate_semantics_sense c.cx_sense && validate_semantics_contents c.cx_contents && validate_semantics_relations c.cx_relations
  | Variant(e,l) -> Xlist.fold l true (fun b (_,t) -> b && validate_semantics t)
  | t -> (*print_endline ("validate_semantics: " ^ LCGstringOf.linear_term 0 t);*) false

and validate_semantics_relations = function
    SingleRelation r -> validate_semantics_rel_name r
  | Relation(r,a,t) -> validate_semantics_rel_name r && validate_semantics_rel_name a && validate_semantics_concept t
  | RevRelation(r,a,t) -> validate_semantics_rel_name r && validate_semantics_rel_name a && validate_semantics_concept t
  | Variant(e,l) -> Xlist.fold l true (fun b (_,t) -> b && validate_semantics_relations t)
  | Tuple l -> Xlist.fold l true (fun b t -> b && validate_semantics_relations t)
  | Dot -> true
  | t -> (*print_endline ("validate_semantics_relations: " ^ LCGstringOf.linear_term 0 t);*) false
  
and validate_semantics_concept = function
    Concept c -> validate_semantics_sense c.c_sense && validate_semantics_sense c.c_name && validate_semantics_quant c.c_quant && validate_semantics_relations c.c_relations
  | Context c -> validate_semantics_sense c.cx_sense && validate_semantics_contents c.cx_contents && validate_semantics_relations c.cx_relations
  | Variant(e,l) -> Xlist.fold l true (fun b (_,t) -> b && validate_semantics_concept t)
  | t -> (*print_endline ("validate_semantics_concept: " ^ LCGstringOf.linear_term 0 t);*) false

and validate_semantics_contents = function
    Concept c -> validate_semantics_concept (Concept c)
  | Context c -> validate_semantics_concept (Context c)
  | Variant(e,l) -> Xlist.fold l true (fun b (_,t) -> b && validate_semantics_contents t)
  | Tuple l -> Xlist.fold l true (fun b t -> b && validate_semantics_contents t)
  | t -> (*print_endline ("validate_semantics_contents: " ^ LCGstringOf.linear_term 0 t);*) false
  
(***************************************************************************************)

let rec find_multiple_variants v m = function
    Concept c -> 
      let v,m = find_multiple_variants v m c.c_quant in
      let v,m = find_multiple_variants v m c.c_relations in
      v,m
  | Context c -> 
      let v,m = find_multiple_variants v m c.cx_contents in
      let v,m = find_multiple_variants v m c.cx_relations in
      v,m
  | Relation(r,a,t) -> find_multiple_variants v m t
  | RevRelation(r,a,t) -> find_multiple_variants v m t
  | SingleRelation r  -> v,m
  | Tuple l -> 
      Xlist.fold l (v,m) (fun (v,m) t ->
        find_multiple_variants v m t)
  | Variant(e,l) -> 
      let m = if StringSet.mem v e then StringMap.add m e (Xlist.map l fst) else m in
      let v = StringSet.add v e in
      let vl,m = Xlist.fold l ([],m) (fun (vl,m) (i,t) -> 
        let v2,m = find_multiple_variants v m t in
        v2 :: vl,m) in
      Xlist.fold vl v StringSet.union, m
  | Dot -> v,m
  | Val s -> v,m
  | t -> failwith ("find_multiple_variants: " ^ LCGstringOf.linear_term 0 t)

type variant_structure = 
    C of variant_structure * variant_structure
  | E
  | T of variant_structure list
  | V of string * int * (string * int * variant_structure) list

let rec string_of_variant_structure = function
    C(s,t) -> sprintf "C(%s,%s)" (string_of_variant_structure s) (string_of_variant_structure t)
  | E -> "E"
  | T l -> sprintf "T[%s]" (String.concat ";" (Xlist.map l string_of_variant_structure))
  | V(e,n,l) -> 
      sprintf "V(%s,%d,[%s])" e n (String.concat ";" (Xlist.map l (fun (i,n,t) ->
        sprintf "%s,%d,%s" i n (string_of_variant_structure t))))
  
let rec create_variant_structure = function
    Concept c -> (*create_variant_structure c.c_relations*)
      let n,s = create_variant_structure c.c_quant in
      let m,t = create_variant_structure c.c_relations in
      m*n,C(s,t)
  | Context c -> 
      let n,s = create_variant_structure c.cx_contents in
      let m,t = create_variant_structure c.cx_relations in
      m*n,C(s,t)
  | Relation(r,a,t) -> create_variant_structure t
  | RevRelation(r,a,t) -> create_variant_structure t
  | SingleRelation r  -> 1,E
  | Tuple l -> 
      let n,l = Xlist.fold l (1,[]) (fun (n,l) t ->
        let m,v = create_variant_structure t in
        n*m,v :: l) in
      n,T(List.rev l)
  | Variant(e,l) -> 
      let n,l = Xlist.fold l (0,[]) (fun (n,l) (i,t) -> 
        let m,v = create_variant_structure t in
        n+m,(i,m,v) :: l) in
      n,V(e,n,List.rev l)
  | Dot -> 1,E
  | Val s -> 1,E
  | t -> failwith ("create_variant_structure: " ^ LCGstringOf.linear_term 0 t)

let rec get_all_variants = function  
    Concept c -> 
(*      let l = get_all_variants c.c_relations in 
      Xlist.map l (fun t -> Concept{c with c_relations=t})*)
      let lq = get_all_variants c.c_quant in
      let lr = get_all_variants c.c_relations in
      List.flatten (Xlist.map lq (fun q -> 
        Xlist.map lr (fun r -> 
          Concept{c with c_relations=r; c_quant=q})))
  | Context cx -> 
      let lc = get_all_variants cx.cx_contents in
      let lr = get_all_variants cx.cx_relations in
      List.flatten (Xlist.map lc (fun c -> 
        Xlist.map lr (fun r -> 
          Context{cx with cx_contents=c; cx_relations=r})))
  | Relation(r,a,t) -> 
      let l = get_all_variants t in 
      Xlist.map l (fun t -> Relation(r,a,t))
  | RevRelation(r,a,t) -> 
      let l = get_all_variants t in 
      Xlist.map l (fun t -> RevRelation(r,a,t))
  | SingleRelation r  -> [SingleRelation r]
  | Tuple l -> 
      let ll = Xlist.multiply_list (Xlist.map l get_all_variants) in
      Xlist.map ll (fun l -> Tuple l)
  | Variant(e,l) -> 
      List.rev (Xlist.fold l [] (fun l (_,t) -> get_all_variants t @ l))
  | Dot -> [Dot]
  | Val s -> [Val s]
  | t -> failwith ("get_all_variants: " ^ LCGstringOf.linear_term 0 t)
  
let _ = Random.self_init ()  

let rec draw_variant2 k = function
    (i2,m,v) :: lv, (i,t) :: l -> 
      if i2 <> i then failwith "draw_variant2" else
      if k < m then v,t else
      draw_variant2 (k - m) (lv,l)
  | _ -> failwith "draw_variant2"
  
let rec draw_variant = function
(*     s,Concept c -> Concept{c with c_relations=draw_variant (s,c.c_relations)} *)
    C(s,t),Concept c -> Concept{c with c_quant=draw_variant (s,c.c_quant); c_relations=draw_variant (t,c.c_relations)}
  | C(s,t),Context c -> Context{c with cx_contents=draw_variant (s,c.cx_contents); cx_relations=draw_variant (t,c.cx_relations)}
  | s,Relation(r,a,t) -> Relation(r,a,draw_variant (s,t))
  | s,RevRelation(r,a,t) -> RevRelation(r,a,draw_variant (s,t))
  | E,SingleRelation r  -> SingleRelation r
  | T lv,Tuple l -> Tuple(List.rev (Xlist.fold2 lv l [] (fun l s t -> (draw_variant (s,t)) :: l)))
  | V(e2,n,lv),Variant(e,l) -> 
      if e <> e2 then failwith "draw_variant" else
      let k = Random.int n in
      let s,t = draw_variant2 k (lv,l) in
      draw_variant (s,t)
  | E,Dot -> Dot
  | E,Val s -> Val s
  | s,t -> (*print_endline ("draw_variant: " ^ LCGstringOf.linear_term 0 t);*) failwith ("draw_variant: " ^ string_of_variant_structure s)
  
let rec get_some_variants chosen = function  
    Concept c -> (* FIXME: czy pozostałe atrybuty można pominąć? *)
      let q = get_some_variants chosen c.c_quant in
      let r = get_some_variants chosen c.c_relations in
      Concept{c with c_relations=r; c_quant=q}
  | Context cx -> 
      let c = get_some_variants chosen cx.cx_contents in
      let r = get_some_variants chosen cx.cx_relations in
      Context{cx with cx_contents=c; cx_relations=r}
  | Relation(r,a,t) -> Relation(r,a,get_some_variants chosen t)
  | RevRelation(r,a,t) -> RevRelation(r,a,get_some_variants chosen t)
  | SingleRelation r  -> SingleRelation r
  | Tuple l -> Tuple(Xlist.map l (get_some_variants chosen)) 
  | Variant(e,l) -> 
      if StringMap.mem chosen e then
        let t = try Xlist.assoc l (StringMap.find chosen e) with Not_found -> failwith "get_some_variants" in
        get_some_variants chosen t
      else Variant(e,Xlist.map l (fun (i,t) -> i,get_some_variants chosen t)) 
  | Dot -> Dot
  | Val s -> Val s
  | t -> failwith ("get_some_variants: " ^ LCGstringOf.linear_term 0 t)
  
let get_all_multiple_variants t mv =
  let ll = StringMap.fold mv [] (fun ll e l ->
    (Xlist.map l (fun i -> e,i)) :: ll) in
  if ll = [] then [t] else
  Xlist.fold (Xlist.multiply_list ll) [] (fun variants l ->
    let chosen = Xlist.fold l StringMap.empty (fun chosen (e,i) -> StringMap.add chosen e i) in
    get_some_variants chosen t :: variants)
  
(*let rec merge_multiple_variant l = function
    [] -> l
  | x :: rev -> merge_multiple_variant (x :: l) rev
  
let rec select_multiple_variant rev k = function
    [] -> failwith "select_multiple_variant"
  | x :: l -> if k=0 then x, merge_multiple_variant rev l else select_multiple_variant (x :: rev) (k-1) l*)
  
let rec select_multiple_variant k = function
    [] -> failwith "select_multiple_variant"
  | x :: l -> if k=0 then x else select_multiple_variant (k-1) l
  
let draw_multiple_variant k t mv = 
  let ll = StringMap.fold mv [] (fun ll e l ->
    (Xlist.map l (fun i -> e,i)) :: ll) in
  let mv = Int.fold 1 k [] (fun mv _ ->
    let variants = Xlist.fold ll [] (fun variants l -> 
      let k = Random.int (Xlist.size l) in
      select_multiple_variant k l :: variants) in
    variants :: mv) in
  Xlist.fold mv [] (fun variants l ->
    let chosen = Xlist.fold l StringMap.empty (fun chosen (e,i) -> StringMap.add chosen e i) in
    get_some_variants chosen t :: variants)   
  
let rec draw_multiple_variant2_rec k = function
    [] -> failwith "draw_multiple_variant2_rec"
  | (n,s,t) :: l -> if k < n then s,t else draw_multiple_variant2_rec (k-n) l
  
let draw_multiple_variant2 sum_n mv =
  let k = Random.int sum_n in
  draw_multiple_variant2_rec k mv
  
let draw_trees max_n t =
  let _,multiple_variants = find_multiple_variants StringSet.empty StringMap.empty t in
  let mo = StringMap.fold multiple_variants 1 (fun mo _ l -> mo * Xlist.size l) in
(*   printf "|multiple_variants|=%d |mo|=%d\n%!" (StringMap.size multiple_variants) mo; *)
  let multiple_variants =
    if mo <= 100 then get_all_multiple_variants t multiple_variants else
      draw_multiple_variant 100 t multiple_variants in
(*   printf "|multiple_variants|=%d |mo|=%d\n%!" (Xlist.size multiple_variants) mo; *)
  let multiple_variants = Xlist.map multiple_variants (fun t ->
    let n,s = create_variant_structure t in
    n,s,t) in
  let sum_n = Xlist.fold multiple_variants 0 (fun sum_n (n,_,_) -> sum_n + n) in
(*  print_endline (LCGstringOf.linear_term 0 t);
  print_endline (string_of_variant_structure s);*)
  if sum_n <= max_n then 
    List.flatten (Xlist.rev_map multiple_variants (fun (n,s,t) ->
      get_all_variants t)) else
  Int.fold 1 max_n [] (fun l _ -> 
    let s,t = draw_multiple_variant2 sum_n multiple_variants in
    (draw_variant (s,t)) :: l)
 
(* FIXME!: założenie o jednokrotnym występowaniu wagi nie jest prawdziwe np. dla zdania: "Łódź wyprzedza statek." *)