Wojciech Jaworski / ENIAM

(*
 *  ENIAMexec implements ENIAM processing stream
 *  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 ENIAMsemTypes
open Xstd
open Printf

(*let pro_id_counter = ref 100000 (* FIXME: to trzeba usunąć !!! *)

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

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 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 get_attr pat = function
    (s,Val t) :: l -> if s = pat then t else get_attr pat l
  | (s,t) :: l -> if s = pat then failwith ("get_attr 1: " ^ s) else get_attr pat l
  | [] -> failwith ("get_attr 2: " ^ pat) *)

let make_relation t c =
  match t.gf with
    "subj" | "obj" | "arg" ->
      Relation(t.role,t.role_attr,c)
  | "adjunct" ->
      if t.arev then RevRelation(t.role,t.role_attr,c) else
      Relation(t.role,t.role_attr,c)
  | s -> failwith ("make_relation: " (*^ s*))

let create_normal_concept (*roles role_attrs*) tokens lex_sems t sem_args =
(*  let sem_args = if t.pos = "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 = ENIAMwalTypes.NOSEM then t.args else*)
  let c = {empty_concept with
    c_sense = if t.lemma = "<root>" then Dot else Val t.meaning;
    c_relations=t.args;
    c_quant=(*make_sem_args sem_args*)Dot;(* FIXME *)
    c_variable=string_of_int t.id,"";
    c_pos=(*if t.id >= Array.length tokens then -1 else*) (ExtArray.get tokens t.id).ENIAMtokenizerTypes.beg;
    c_local_quant=true} in
  if t.pos = "subst" || t.pos = "depr" || t.pos = "ger" || t.pos = "unk" || StringSet.mem symbols t.pos 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
        "NSYN",Val "common" -> c,measure,cx_flag
      | "NSYN",Val "proper" -> {c with c_name=Val t.lemma; (*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 *)
      | "NSYN",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("impt")]},measure,true
      | "ASPECT",_ -> c,measure,cx_flag
      | "NEGATION",Val "aff" -> c,measure,cx_flag
      | "NEGATION",Val "neg" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]},measure,cx_flag
      | "controller",_ -> c,measure,cx_flag
      (* | "INCLUSION",_ -> c,measure ,cx_flag
      | "QUOT",Val "+" -> {c with c_relations=Tuple[c.c_relations;SingleRelation("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.pos = "depr" then {c with c_relations=Tuple[c.c_relations;SingleRelation "depr"]} else c in *)
    if cx_flag then
      let id = ExtArray.add tokens ENIAMtokenizerTypes.empty_token_env in
      let _ = ExtArray.add lex_sems ENIAMlexSemanticsTypes.empty_lex_sem in
      make_relation t (Context{empty_context with cx_contents=Concept c; cx_variable=string_of_int id,""; cx_pos=c.c_pos})
    else
      make_relation t (Concept c) else
  if t.pos = "fin" || t.pos = "bedzie" || t.pos = "praet" || t.pos = "winien" || t.pos = "impt" || t.pos = "imps" || t.pos = "pred" || t.lemma = "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",Val t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]} (* FIXME to jest powód dla którego nazwy relacji były termami *)
      | "MOOD",Val "indicative" -> c
      | "MOOD",Val "conditional" -> {c with c_relations=Tuple[c.c_relations;SingleRelation("cond")]} (* FIXME *)
      | "MOOD",Val "imperative" -> {c with c_relations=Tuple[c.c_relations;SingleRelation("impt")]} (* FIXME *)
      | "NEGATION",Val "aff" -> c
      | "NEGATION",Val "neg" -> {c with c_quant=Tuple[c.c_quant;Val "nie"]}
      | e,t -> failwith ("create_normal_concept verb: " ^ e)) in
    let c = if t.lemma = "pro-komunikować" then {c with c_relations=Relation("Theme","",c.c_relations)} else c in (* FIXME: to by trzeba przesunąć na wcześniej *)
    let id = ExtArray.add tokens ENIAMtokenizerTypes.empty_token_env in
    let _ = ExtArray.add lex_sems ENIAMlexSemanticsTypes.empty_lex_sem in
    let cx = {empty_context with cx_contents=Concept c; cx_variable=string_of_int id,""; cx_pos=c.c_pos} in
    (* if t.role <> "" || t.role_attr <> "" then failwith "create_normal_concept: verb" else *)
    make_relation t (Context cx) else
  if t.pos = "inf" then
    let c = {c with c_local_quant=false} in
    let c = Xlist.fold t.attrs c (fun c -> function
      | "ASPECT",_ -> c
      | "TENSE",Val 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 id = ExtArray.add tokens ENIAMtokenizerTypes.empty_token_env in
    let _ = ExtArray.add lex_sems  in
    let cx = {empty_context with cx_contents=Concept c; cx_variable=string_of_int id,""; cx_pos=c.c_pos} in
    Relation(t.role,t.role_attr,Context cx) else
  if t.pos = "adj" || t.pos = "adjc" || t.pos = "adjp" || t.pos = "adja" || t.pos = "pact" || t.pos = "ppas" || t.pos = "ordnum" || t.pos = "roman-adj" then
    let c = if t.pos = "pact" || t.pos = "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.pos = "roman-adj" then c else failwith "create_normal_concept adj: SYN=proper"
      | "NSEM",Val "count" -> if t.pos = "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.pos = "pact" || t.pos = "ppas" then
      RevRelation(t.role,t.role_attr,Concept c)
    else Relation(t.role,t.role_attr,Concept c) else
  if t.pos = "adv" || t.pos = "pcon" || t.pos = "pant" then
    let c = if t.pos = "pcon" || t.pos = "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(t.role,t.role_attr,Concept c) else
  if t.pos = "pro" || t.pos = "ppron12" || t.pos = "ppron3" || t.pos = "siebie" then (* FIXME: indexicalność *)
    let c = {c with c_local_quant=false} in
    let c = Xlist.fold t.attrs c (fun c -> function
        "NUM",Val t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "GEND",Val t -> {c with c_relations=Tuple[c.c_relations;SingleRelation t]}
      | "PERS",Val t2 -> if t.pos = "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(t.role,t.role_attr,Concept c) else
  if t.pos = "prep" then
    if t.arole = "NOSEM" then Relation(t.role,t.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(t.role,t.role_attr,Concept c) else
  if t.pos = "num" || t.pos = "intnum" || t.pos = "realnum" || t.pos = "intnum-interval" || t.pos = "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(t.role,t.role_attr,(*Quantifier*)(Concept c)) else
  if t.pos = "qub" && t.lemma="się" then
    let c = {c with c_quant=Tuple[c.c_quant;Val "coreferential"]} in
    Relation(t.role,t.role_attr,(*Quantifier*)(Concept c)) else
  if t.pos = "qub" && (t.lemma="czy" || t.lemma="gdyby") then
    Relation(t.role,t.role_attr,SetContextName(t.meaning,t.args)) else
  if t.pos = "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(t.role,t.role_attr,Concept c) else
  if t.pos = "comp" then
    Relation(t.role,t.role_attr,SetContextName(t.meaning,t.args)) else
  if t.pos = "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(t.role,t.role_attr,Context c) else
  if t.pos = "interj" then Node t else
  if t.pos = "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.pos = "interp" && t.lemma = "</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.pos = "interp" && t.lemma = "<sentence>" then t.args else
  if t.pos = "interp" && t.lemma = "”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(t.arole,t.arole_attr,x) else (* FIXME: czy na pewno tu i w następnych arole a nie position.role? *)
  if t.pos = "interp" && t.lemma = "<or>" then
    Relation(t.arole,t.arole_attr,t.args) else
  if t.pos = "interp" && t.lemma = "<speaker>" then
    Relation(t.arole,t.arole_attr,RemoveRelation t.args) else
  if t.pos = "interp" && t.lemma = "</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.gf = "obj" then Relation(t.arole,t.arole_attr,x) else x else
  if t.pos = "interp" && t.lemma = "<query1>" then t.args else
  if t.pos = "interp" && t.lemma = "<query2>" then t.args else
  if t.pos = "interp" && t.lemma = "<query4>" then t.args else
  if t.pos = "interp" && t.lemma = "<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.pos = "interp" && t.lemma = "<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.pos = "interp" && t.lemma = "?" then SingleRelation("int") else
  if t.pos = "interp" && t.lemma = "„" then
    Relation(t.role,t.role_attr,RemoveRelation t.args) else
  if t.pos = "interp" || t.lemma = "</or-sentence>" then Relation(t.role,t.role_attr,t.args) else (
  if t.pos = "interp" then Node t else
  if t.pos = "" then Relation(t.role,t.role_attr,t.args) else
  (* print_endline t.lemma; *)
  Node t)

let rec translate_node tokens lex_sems t =
  let attrs = Xlist.map t.ENIAM_LCGtypes.attrs (fun (k,t) -> k, create_concepts tokens lex_sems t) in
  let t = {
    orth=t.ENIAM_LCGtypes.orth; lemma=t.ENIAM_LCGtypes.lemma; pos=t.ENIAM_LCGtypes.pos; weight=t.ENIAM_LCGtypes.weight;
    id=t.ENIAM_LCGtypes.id; symbol=create_concepts tokens lex_sems t.ENIAM_LCGtypes.symbol; arg_symbol=create_concepts tokens lex_sems t.ENIAM_LCGtypes.arg_symbol;
    arg_dir=t.ENIAM_LCGtypes.arg_dir;
    attrs=[];
    args=create_concepts tokens lex_sems t.ENIAM_LCGtypes.args;
    gf=""; role=""; role_attr=""; selprefs=Dot; meaning=""; arole=""; arole_attr=""; arev=false; sem_args=Dot} in
  let t,attrs = Xlist.fold attrs (t,[]) (fun (t,attrs) -> function
      "gf",Val s -> {t with gf=s},attrs
    | "role",Val s -> {t with role=s},attrs
    | "role-attr",Val s -> {t with role_attr=s},attrs
    | "selprefs",s -> {t with selprefs=s},attrs
    | "meaning",Val s -> {t with meaning=s},attrs
    | "hipero",_ -> t,attrs
    | "arole",Val s -> {t with arole=s},attrs
    | "arole-attr",Val s -> {t with arole_attr=s},attrs
    | "arev",Val "-" -> {t with arev=false},attrs
    | "arev",Val "+" -> {t with arev=true},attrs
    | "sem-args",s -> {t with sem_args=s},attrs
    | "fopinion",_ -> t,attrs
    | "sopinion",_ -> t,attrs
(*    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs
    | "",s -> t,("",s) :: attrs*)
    | "ACM",s -> t,("ACM",s) :: attrs
    | "ASPECT",s -> t,("ASPECT",s) :: attrs
    | "NEGATION",s -> t,("NEGATION",s) :: attrs
    | "MOOD",s -> t,("MOOD",s) :: attrs
    | "TENSE",s -> t,("TENSE",s) :: attrs
    | "controller",s -> t,("controller",s) :: attrs
    | "CAT",_ -> t,attrs
    | "NUM",s -> t,("NUM",s) :: attrs
    | "CASE",s -> t,("CASE",s) :: attrs
    | "GEND",s -> t,("GEND",s) :: attrs
    | "PERS",s -> t,("PERS",s) :: attrs
    | "NSYN",s -> t,("NSYN",s) :: attrs
    | "NSEM",s -> t,("NSEM",s) :: attrs
(*    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs
    | "",Val s -> {t with =s},attrs*)
    | k,v -> printf "translate_node: %s %s\n%!" k (ENIAMsemStringOf.linear_term 0 v); t, (k,v) :: attrs) in
  {t with attrs=attrs}

and create_concepts tokens lex_sems = function
    ENIAM_LCGtypes.Node t ->
      let t = translate_node tokens lex_sems t in
      create_normal_concept tokens lex_sems t []
  | ENIAM_LCGtypes.Tuple l -> Tuple(Xlist.map l (create_concepts tokens lex_sems))
  | ENIAM_LCGtypes.Variant(e,l) -> Variant(e,Xlist.map l (fun (i,t) -> i, create_concepts tokens lex_sems t))
  | ENIAM_LCGtypes.Dot -> Dot
  | ENIAM_LCGtypes.Val s -> Val s
  | ENIAM_LCGtypes.Ref i -> Ref i
  (* | Choice choices -> Choice(StringMap.map choices (create_concepts tokens lex_sems)) *)
  | t -> failwith ("create_concepts: " ^ ENIAM_LCGstringOf.linear_term 0 t)


let translate tokens lex_sems term =
  let sem = Array.make (Array.length term) Dot in
  Int.iter 0 (Array.length sem - 1) (fun i ->
    sem.(i) <- create_concepts tokens lex_sems term.(i));
  sem

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

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

let make_tree references =
  RemoveRelation(make_tree_rec 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." *)
*)