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 ExecTypes

let empty_result = {
  input_text=RawText "";
  pre_text=RawText "";
  status=Idle;
  msg="";
  pre_time1=0.;
  pre_time2=0.;
  parse_time=0.;
  parsed_text=RawText "";
  semantic_time=0.;
  selected_sent_text=RawText "";
  semantic_text=RawText "";
  selected_semantic_text=RawText "";
  }

let empty_eniam_parse_result = {
  file_prefix="";
  status=Idle;
  msg="";
  lex_time=0.;
  parse_time=0.;
  reduction_time=0.;
  sem_time=0.;
  paths_size=0;
  chart_size=0;
  dependency_tree_size=0;
  chart=[| |];
  dependency_tree=[| |];
  }

let empty_conll_parse_result = {
  file_prefix="";
  status=Idle;
  msg="";
  lex_time=0.;
  parse_time=0.;
  reduction_time=0.;
  sem_time=0.;
  paths_size=0;
  dependency_tree_size=0;
  paths=[| |];
  dep_chart=DepNode(-100,[],[],[]);
  parsed_dep_chart=[];
  not_parsed_dep_chart=(-100,[],[],[]);
  dependency_tree=[| |];
  }

let empty_semantic_processing_result = {
  file_prefix="";
  status=Idle;
  msg="";
  sem_time=0.;
  disamb=[| |];
  sem=[| |];
  sem2=[| |];
  sem3=LCGtypes.Dot;
  trees=[];
  mrls=[];
  }

let empty_sum_result = {
  no_queries=0;
  no_pre_error=0;
  no_lex_error=0;
  no_parse_error=0;
  no_timeout=0;
  no_reduction_error=0;
  no_sem_error=0;
  no_not_parsed=0;
  no_not_reduced=0;
  no_too_many_nodes=0;
  no_not_translated=0;
  no_parsed=0;
  sum_pre_time1=0.;
  sum_pre_time2=0.;
  sum_lex_time=0.;
  sum_parse_time=0.;
  sum_reduction_time=0.;
  sum_sem_time=0.;
  }

open Printf

let translate_mode = function
    PreTypes.Raw -> Raw
  | PreTypes.Struct -> Struct
  | PreTypes.CONLL -> CONLL
  | PreTypes.ENIAM -> ENIAM
  | PreTypes.Mate -> Mate
  | PreTypes.Swigra -> Swigra
  | PreTypes.POLFIE -> POLFIE

let rec translate_sentence = function
    PreTypes.RawSentence s -> RawSentence s
  | PreTypes.StructSentence(paths,last) -> StructSentence(paths,last)
  | PreTypes.DepSentence(paths) -> DepSentence(paths)
  | PreTypes.QuotedSentences sentences ->
      QuotedSentences(Xlist.map sentences (fun p ->
        {pid=p.PreTypes.pid; pbeg=p.PreTypes.pbeg; plen=p.PreTypes.plen; pnext=p.PreTypes.pnext; pfile_prefix=p.PreTypes.pfile_prefix;
         psentence=translate_sentence p.PreTypes.psentence}))
  | PreTypes.AltSentence l -> AltSentence(Xlist.map l (fun (mode,sentence) ->
      translate_mode mode, translate_sentence sentence))

let rec translate_paragraph = function
    PreTypes.RawParagraph s -> RawParagraph s
  | PreTypes.StructParagraph sentences ->
      StructParagraph(Xlist.map sentences (fun p ->
        {pid=p.PreTypes.pid; pbeg=p.PreTypes.pbeg; plen=p.PreTypes.plen; pnext=p.PreTypes.pnext; pfile_prefix=p.PreTypes.pfile_prefix;
         psentence=translate_sentence p.PreTypes.psentence}))
  | PreTypes.AltParagraph l -> AltParagraph(Xlist.map l (fun (mode,paragraph) ->
      translate_mode mode, translate_paragraph paragraph))

let rec translate_text = function
    PreTypes.RawText s -> RawText s
  | PreTypes.StructText(paragraphs,tokens) ->
      StructText(Xlist.map paragraphs translate_paragraph,tokens)
  | PreTypes.AltText l -> AltText(Xlist.map l (fun (mode,text) ->
      translate_mode mode, translate_text text))

let eniam_parse_sentence timeout test_only_flag paths last tokens =
  let result = empty_eniam_parse_result in
  let time2 = time_fun () in
  try
    let chart = LCGlexicon.create (paths,last) tokens in
    let chart,references = LCGchart.lazify chart in
    let result = if test_only_flag then result else {result with chart=chart} in
    let time3 = time_fun () in
    let result = {result with lex_time=time3 -. time2} in
    try
      (* print_endline "eniam_parse_sentence 1"; *)
      let chart = LCGchart.parse chart references timeout time_fun in (* uwaga: niejawna zmiana imperatywna w references *)
      (* print_endline "eniam_parse_sentence 2"; *)
      let time4 = time_fun () in
      let result = if test_only_flag then result else {result with chart=chart} in
      let result = {result with parse_time=time4 -. time3; chart_size=LCGchart.get_no_entries chart} in
      if LCGchart.is_parsed chart then
        try
          let term = LCGchart.get_parsed_term tokens chart in
          let dependency_tree = LCGreductions.reduce term references in
          let time5 = time_fun () in
          let result = if test_only_flag then result else {result with dependency_tree=dependency_tree} in
          let result = {result with reduction_time=time5 -. time4; dependency_tree_size=Array.length dependency_tree} in
          if LCGreductions.is_reduced_dependency_tree dependency_tree then
            try
              (* print_endline "eniam_parse_sentence 3"; *)
              LCGreductions.assign_labels dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
              (* print_endline "eniam_parse_sentence 4"; *)
              LCGreductions.remove_cuts dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
(*               if Array.length dependency_tree < 10000 then print_xml_dependency_tree "results/trees/" id dependency_tree;  *)
              (* print_endline "eniam_parse_sentence 5"; *)
              let time6 = time_fun () in
              {result with status=Parsed; sem_time=time6 -. time5}
            with e ->
              let time6 = time_fun () in
              {result with status=SemError; msg=Printexc.to_string e; sem_time=time6 -. time5}
          else
            {result with status=NotReduced}
        with
        | SemTooBig ->
            let time5 = time_fun () in
            {result with status=TooManyNodes; reduction_time=time5 -. time4}
        | e ->
            let time5 = time_fun () in
            {result with status=ReductionError; msg=Printexc.to_string e; reduction_time=time5 -. time4}
      else {result with status=NotParsed}
    with
      Timeout t ->
        let time4 = time_fun () in
        {result with status=ParseTimeout; msg=Printf.sprintf "%f" t; parse_time=time4 -. time3}
    | e ->
        let time4 = time_fun () in
        {result with status=ParseError; msg=Printexc.to_string e; parse_time=time4 -. time3}
  with e ->
    let time3 = time_fun () in
    {result with status=LexiconError; msg=Printexc.to_string e; lex_time=time3 -. time2}

let conll_parse_sentence timeout test_only_flag paths tokens =
  let result = empty_conll_parse_result in
  let time2 = time_fun () in
  try
    let dep_chart = LCGlexicon.dep_create paths tokens in
    let dep_chart,references = LCGchart.dep_lazify dep_chart in
    let result = if test_only_flag then result else {result with dep_chart=dep_chart} in
    let time3 = time_fun () in
    let result = {result with lex_time=time3 -. time2} in
    try
      (* print_endline "conll_parse_sentence 1"; *)
      (* LCGlatexOf.print_references "results/" "references1" references; *)
      let parsed_dep_chart = LCGchart.dep_parse dep_chart references timeout time_fun in (* uwaga: niejawna zmiana imperatywna w references *)
      (* print_endline "conll_parse_sentence 2"; *)
      (* LCGlatexOf.print_references "results/" "references2" references; *)
      let time4 = time_fun () in
      let result = if test_only_flag then result else {result with parsed_dep_chart=parsed_dep_chart} in
      let result = {result with parse_time=time4 -. time3} in
      if LCGchart.is_dep_parsed parsed_dep_chart then
        try
          let term = LCGchart.get_dep_parsed_term tokens parsed_dep_chart in
          (* LCGlatexOf.print_dependency_tree "dep_dependency_tree1" dependency_tree; *)
          let dependency_tree = LCGreductions.reduce term references in
          let time5 = time_fun () in
          let result = if test_only_flag then result else {result with dependency_tree=dependency_tree} in
          let result = {result with reduction_time=time5 -. time4; dependency_tree_size=Array.length dependency_tree} in
          if LCGreductions.is_reduced_dependency_tree dependency_tree then
            try
              (* print_endline "conll_parse_sentence 3"; *)
              LCGreductions.assign_labels dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
              (* print_endline "conll_parse_sentence 4"; *)
              LCGreductions.remove_cuts dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
(*               if Array.length dependency_tree < 10000 then print_xml_dependency_tree "results/trees/" id dependency_tree;  *)
              (* print_endline "conll_parse_sentence 5"; *)
              let time6 = time_fun () in
              {result with status=Parsed; sem_time=time6 -. time5}
            with e ->
              let time6 = time_fun () in
              {result with status=SemError; msg=Printexc.to_string e; sem_time=time6 -. time5}
          else
            {result with status=NotReduced}
        with
        | SemTooBig ->
            let time5 = time_fun () in
            {result with status=TooManyNodes; reduction_time=time5 -. time4}
        | e ->
            let time5 = time_fun () in
            {result with status=ReductionError; msg=Printexc.to_string e; reduction_time=time5 -. time4}
      else {result with status=NotParsed}
    with
      Timeout t ->
        let time4 = time_fun () in
        {result with status=ParseTimeout; msg=Printf.sprintf "%f" t; parse_time=time4 -. time3}
    | NotDepParsed(id,left,l,right) ->
        let time4 = time_fun () in
        {result with status=NotParsed; not_parsed_dep_chart=(id,left,l,right); parse_time=time4 -. time3}
    | e ->
        let time4 = time_fun () in
        {result with status=ParseError; msg=Printexc.to_string e; parse_time=time4 -. time3}
  with e ->
    let time3 = time_fun () in
    {result with status=LexiconError; msg=Printexc.to_string e; lex_time=time3 -. time2}


let mate_in, mate_out = (*Unix.open_process "java -jar ../dependencyParser/basic/mate-tools/dist/anna-3.5.jar -model ../dependencyParser/basic/mate-tools/examples/160622_Polish_MateParser.mdl -test"*)
  if Paths.config.Paths.mate_parser_enabled then
    Unix.open_process ("java -jar " ^ Paths.config.Paths.mate_parser_path ^ "dist/anna-3.5.jar -model " ^
      Paths.config.Paths.mate_parser_path ^ "examples/160622_Polish_MateParser.mdl -test")
  else stdin, stdout

let swigra_in, swigra_out = (*Unix.open_process "../swigra/parser/run.sh"*)
  if Paths.config.Paths.swigra_enabled then
    Unix.open_process (Paths.config.Paths.swigra_path ^ "run.sh")
  else stdin, stdout

let file_prefix_of_mode = function
    Raw -> "R"
  | Struct -> "St"
  | CONLL -> "C"
  | ENIAM -> "E"
  | Mate -> "M"
  | Swigra -> "S"
  | POLFIE -> "P"

let get_paths old_paths = function
    {PreTypes.psentence=PreTypes.DepSentence(paths)},_ ->
       Int.iter 0 (Array.length paths - 1) (fun i ->
         let id,_,_ = old_paths.(i) in
         let _,super,label = paths.(i) in
         paths.(i) <- id,super,label);
       paths
  | _ -> failwith "get_paths"

let rec parse_sentence timeout test_only_flag mode file_prefix tokens = function
    RawSentence s ->
      (match mode with
        Swigra ->
          if not Paths.config.Paths.swigra_enabled then RawSentence s else (
          Printf.fprintf swigra_out "%s\n%!" s;
          print_endline ("swigra: " ^ input_line swigra_in);
          RawSentence s)
      | _ -> RawSentence s)
  | StructSentence(paths,last) ->
      (match mode with
        ENIAM ->
          let result = eniam_parse_sentence timeout test_only_flag paths last tokens in
          let result = {result with file_prefix = file_prefix_of_mode mode ^ file_prefix} in
          ENIAMSentence result
      | _ -> failwith "parse_sentence")
  | DepSentence(paths) ->
      (match mode with
        CONLL ->
          let result = conll_parse_sentence timeout test_only_flag paths tokens in
          let result = {result with
            file_prefix = file_prefix_of_mode mode ^ file_prefix;
            paths = paths} in
          CONLLSentence result
          (* let xml = DepTree.conll_to_xml paths in
          let graph = XmlPrinter.graph_of_xml xml in (* FIXME: do poprawy *)
          Visualization.print_graph "results/" "term_conll" graph;
          let result = {empty_eniam_parse_result with status=Parsed; term=graph} in
          ENIAMSentence result, next_id *)
      | Mate ->
          if not Paths.config.Paths.mate_parser_enabled then DepSentence paths else (
          print_endline "parse_sentence 1";
          (* print_endline (Visualization.html_of_dep_sentence tokens paths); *)
          let conll = CONLL.string_of_paths PreTypes.Mate tokens paths in
          print_endline "parse_sentence 2";
          (* printf "|%s|\n" conll; *)
          Printf.fprintf mate_out "%s%!" conll;
          print_endline "parse_sentence 3";
          let new_paths = get_paths paths (CONLL.load_sentence mate_in) in
          print_endline "parse_sentence 4";
          (* print_endline (Visualization.html_of_dep_sentence tokens new_paths); *)
          let result = conll_parse_sentence timeout test_only_flag new_paths tokens in
          let result = {result with
            file_prefix = file_prefix_of_mode mode ^ file_prefix;
            paths=new_paths} in
          CONLLSentence result)
      | _ -> failwith "parse_sentence")
  | QuotedSentences sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence = parse_sentence timeout test_only_flag mode p.pfile_prefix tokens p.psentence in
        {p with psentence=sentence}) in
      QuotedSentences(List.rev sentences)
  | AltSentence l ->
      let l = Xlist.rev_map l (fun (mode,sentence) ->
        mode, parse_sentence timeout test_only_flag mode file_prefix tokens sentence) in
      AltSentence(List.rev l)
 | _ -> failwith "parse_sentence"

let rec parse_paragraph timeout test_only_flag mode tokens = function
    RawParagraph s -> RawParagraph s
  | StructParagraph sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence = parse_sentence timeout test_only_flag mode p.pfile_prefix tokens p.psentence in
        {p with psentence=sentence}) in
      StructParagraph(List.rev sentences)
  | AltParagraph l ->
      let l = Xlist.rev_map l (fun (mode,paragraph) ->
        mode, parse_paragraph timeout test_only_flag mode tokens paragraph) in
      AltParagraph(List.rev l)

let rec parse_text timeout test_only_flag mode = function
    RawText s -> RawText s
  | StructText(paragraphs,tokens) ->
      let paragraphs = Xlist.rev_map paragraphs (fun paragraph ->
        parse_paragraph timeout test_only_flag mode tokens paragraph) in
      StructText(List.rev paragraphs, tokens)
  | AltText l -> AltText(Xlist.map l (fun (mode,text) ->
       mode, parse_text timeout test_only_flag mode text))

let select_mode = function
    (Raw,_),_ -> failwith "select_mode"
  | _,(Raw,_) -> failwith "select_mode"
  | (Struct,_),_ -> failwith "select_mode"
  | _,(Struct,_) -> failwith "select_mode"
  | (CONLL,s),_ -> CONLL,s
  | _,(CONLL,s) -> CONLL,s
  | (ENIAM,s),_ -> ENIAM,s
  | _,(ENIAM,s) -> ENIAM,s
  | (Swigra,s),_ -> Swigra,s
  | _,(Swigra,s) -> Swigra,s
  | (Mate,s),_ -> Mate,s
  | _,(Mate,s) -> Mate,s
  | _ -> failwith "select_mode: ni"

let rec select_sentences_sentence = function
    RawSentence s -> failwith "select_sentences_sentence"
  | StructSentence(paths,last) -> failwith "select_sentences_sentence"
  | DepSentence paths  -> failwith "select_sentences_sentence"
  | QuotedSentences sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence,_ = select_sentences_sentence p.psentence in
        {p with psentence=sentence}) in
      QuotedSentences(List.rev sentences), Parsed
  | AltSentence l ->
      let raw,selected = Xlist.fold l ([],[]) (fun (raw,selected) (mode,sentence) ->
        if mode = Raw then (mode,sentence) :: raw, selected else
        let sentence,status = select_sentences_sentence sentence in
        if status <> Parsed && status <> NotTranslated then raw,selected else
        match selected with
          [] -> raw,[mode,sentence]
        | [mode2,sentence2] -> raw,[select_mode ((mode,sentence),(mode2,sentence2))]
        | _ -> failwith "select_sentences_sentence") in
      AltSentence(raw @ selected), Parsed
  | ENIAMSentence result -> ENIAMSentence result, result.status
  | CONLLSentence result -> CONLLSentence result, result.status
  | SemSentence result -> SemSentence result, result.status

let rec select_sentences_paragraph = function
    RawParagraph s -> RawParagraph s
  | StructParagraph sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence,_ = select_sentences_sentence p.psentence in
        {p with psentence=sentence}) in
      StructParagraph(List.rev sentences)
  | AltParagraph l ->
      let l = Xlist.rev_map l (fun (mode,paragraph) ->
        mode, select_sentences_paragraph paragraph) in
      AltParagraph(List.rev l)

let rec select_sentences_text = function
    RawText s -> RawText s
  | StructText(paragraphs,tokens) ->
      let paragraphs = Xlist.rev_map paragraphs (fun paragraph ->
        select_sentences_paragraph paragraph) in
      StructText(List.rev paragraphs, tokens)
  | AltText l -> AltText(Xlist.map l (fun (mode,text) ->
       mode, select_sentences_text text))

let semantic_processing timeout test_only_flag file_prefix tokens max_n dependency_tree =
  let time5 = time_fun () in
  let result = {empty_semantic_processing_result with file_prefix=file_prefix} in
  try
    let (*dependency_tree2*)(*sem*)disamb = LCGvalence.assign_frames_and_senses tokens dependency_tree in
    let disamb(*sem*) = DisambSelPref.fit_sel_prefs DisambSelPref.fit_node1 (*dependency_tree2*)disamb in
    let (*sem*)disamb = DisambLemma.disambiguate_nodes (*dependency_tree*)(*sem*)disamb in
    let (*sem*)disamb = DisambLemma.remove_unused(*disambiguate_nodes*) (*dependency_tree*)(*sem*)disamb in
    let (*sem*)disamb = DisambLemma.remove_unused_choices(*disambiguate_nodes*) (*dependency_tree*)(*sem*)disamb in
    let (*disamb*)sem = DisambSelPref.fit_sel_prefs DisambSelPref.fit_node2 (*dependency_tree2*)disamb in
    let result = if test_only_flag then result else {result with disamb=disamb} in
    let sem = DisambLemma.disambiguate_meanings (*dependency_tree*)sem in
    let sem(*disamb*) = DisambLemma.remove_unused_choices(*disambiguate_nodes*) (*dependency_tree*)sem(*disamb*) in
    let result = if test_only_flag then result else {result with sem=sem} in
    let sem2 = SemGraph.translate tokens (*disamb*)sem in
    let result = if test_only_flag then result else {result with sem2=sem2} in
    let sem3(*disamb*) = SemGraph.make_tree(*disambiguate_nodes*) (*dependency_tree*)sem2(*disamb*) in
    let sem3(*disamb*) = SemGraph.simplify_tree(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in
(*     let sem3(*disamb*) = SemGraph.manage_quantification(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in  *)
    let sem3(*disamb*) = SemGraph.simplify_gender(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in
(*     if Array.length disamb < 10000 then print_xml_dependency_tree "results/trees/" (id ^ "dis") disamb; *)
    let result = if test_only_flag then result else {result with sem3=sem3} in
    let time6 = time_fun () in
    if SemGraph.validate_semantics sem3 then
      let trees = SemGraph.draw_trees max_n sem3 in
      let trees2 = Xlist.map trees SemMrl.variable_alpha_convertion in
      let mrls = Xlist.map trees2 SemMrl.make_mrl in
      let mrls = Xlist.map mrls SemMrl.move_requirements in
      let mrss = Xlist.map mrls SemMrl.make_mrs_of_mrl in
      let mrss = Xlist.map mrss SemMrl.mrs_handle_alpha_convertion in
      let fols = Xlist.map mrss (fun mrs ->
        let l = SemMrl.foll_of_mrs_greedy mrs in
        if l = [] then failwith "empty fol" else
        List.hd l) in
      let result = if test_only_flag then result else {result with trees=trees; mrls=fols(*mrls*)} in
      {result with status=Parsed; sem_time=time6 -. time5}
    else {result with status=NotTranslated; sem_time=time6 -. time5}
  with e ->
    let time6 = time_fun () in
    {result with status=SemError; msg=Printexc.to_string e; sem_time=time6 -. time5}


let rec semantic_processing_sentence timeout test_only_flag tokens max_n = function
    RawSentence s -> RawSentence s
  | ENIAMSentence result -> SemSentence (semantic_processing timeout test_only_flag result.file_prefix tokens max_n result.dependency_tree)
  | CONLLSentence result -> SemSentence (semantic_processing timeout test_only_flag result.file_prefix tokens max_n result.dependency_tree)
  | QuotedSentences sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence = semantic_processing_sentence timeout test_only_flag tokens max_n p.psentence in
        {p with psentence=sentence}) in
      QuotedSentences(List.rev sentences)
  | AltSentence l ->
      let l = Xlist.rev_map l (fun (mode,sentence) ->
        mode, semantic_processing_sentence timeout test_only_flag tokens max_n sentence) in
      AltSentence(List.rev l)
 | _ -> failwith "semantic_processing_sentence"

let rec semantic_processing_paragraph timeout test_only_flag tokens max_n = function
    RawParagraph s -> RawParagraph s
  | StructParagraph sentences ->
      let sentences = Xlist.rev_map sentences (fun p ->
        let sentence = semantic_processing_sentence timeout test_only_flag tokens max_n p.psentence in
        {p with psentence=sentence}) in
      StructParagraph(List.rev sentences)
  | AltParagraph l ->
      let l = Xlist.rev_map l (fun (mode,paragraph) ->
        mode, semantic_processing_paragraph timeout test_only_flag tokens max_n paragraph) in
      AltParagraph(List.rev l)

let rec semantic_processing_text timeout test_only_flag max_n = function
    RawText s -> RawText s
  | StructText(paragraphs,tokens) ->
      let paragraphs = Xlist.rev_map paragraphs (fun paragraph ->
        semantic_processing_paragraph timeout test_only_flag tokens max_n paragraph) in
      StructText(List.rev paragraphs, tokens)
  | AltText l -> AltText(Xlist.map l (fun (mode,text) ->
       mode, semantic_processing_text timeout test_only_flag max_n text))

let rec extract_query_text = function
    RawText s -> s
  | AltText l -> (try extract_query_text (Xlist.assoc l Raw) with Not_found -> failwith "extract_query_text")
  | _ -> failwith "extract_query_text"

let process_query pre_in pre_out timeout test_only_flag id full_query max_n =
  (* print_endline "process_query 0"; *)
  let result = {empty_result with input_text=translate_text full_query} in
  let time1 = time_fun () in
  (* print_endline "process_query 1"; *)
  Marshal.to_channel pre_out full_query [];
  flush pre_out;
  (* print_endline "process_query 2"; *)
  let pre_text,msg,pre_time1 = (Marshal.from_channel pre_in : PreTypes.text * string * float) in
  let time2 = time_fun () in
  let result = if test_only_flag then result else {result with pre_text=translate_text pre_text} in
  let result = {result with pre_time1=pre_time1; pre_time2=time2 -. time1} in
  if msg <> "" then {result with status=PreprocessingError; msg=msg} else (
  (* print_endline "process_query 3"; *)
  let parsed_text = parse_text timeout test_only_flag Struct (translate_text pre_text) in
  (* print_endline "process_query 4"; *)
  let time3 = time_fun () in
  let result = if test_only_flag then result else {result with status=Parsed; parsed_text=parsed_text} in
  let result = {result with parse_time=time3 -. time2} in
  (* print_endline "process_query 5"; *)
  let selected_sent_text =
     if not Paths.config.Paths.sentence_selection_enabled then parsed_text
     else select_sentences_text parsed_text in
  (* print_endline "process_query 6"; *)
  let result = if test_only_flag then result else {result with status=Parsed; selected_sent_text=selected_sent_text} in
  let semantic_text = semantic_processing_text timeout test_only_flag max_n selected_sent_text in
  (* print_endline "process_query 7"; *)
  let selected_semantic_text =
     if not Paths.config.Paths.sentence_selection_enabled then semantic_text
     else select_sentences_text semantic_text in
  (* print_endline "process_query 8"; *)
  let time4 = time_fun () in
  let result =
    if test_only_flag then result
    else {result with status=Parsed;
      semantic_text=semantic_text;
      selected_semantic_text=selected_semantic_text} in
  let result = {result with semantic_time=time4 -. time3} in
  result)
(**  (* let text,msg,pre_time1 = PreProcessing.mail_loop2 query in *)
  (* let text = PreTypes.RawText "" in
  let msg = "" in
  let pre_time1 = 0. in *)
  print_endline "process_query 3";
  let text = process_text Struct text in
  (* let paths = match paths with
      PreTypes.RawText "" -> [],0,0
    | PreTypes.StructText [PreTypes.StructParagraph [{PreTypes.pcontents=PreTypes.StructSentence(paths,last,next_id)}]] -> paths,last,next_id
    | _ -> failwith "process_query: pre format" in *)
  let paths_array = make_paths_array paths in
  let result = if test_only_flag then result else {result with paths=paths_array} in
(*   if not test_only_flag then print_endline (paths_to_string_indexed paths);  *)
  let time2 = time_fun () in
  let result = {result with pre_time1=pre_time1; pre_time2=time2 -. time1;
    paths_size=let _,_,next_id = paths in next_id-1} in
  (*if msg <> "" then*) {result with status=PreprocessingError; msg=msg} (*else*)
  (*try
    let graph = LCGlexicon.create query paths in
    let graph,references,next_reference = LCGchart.lazify graph in
    let time3 = time_fun () in
    let result = {result with lex_time=time3 -. time2} in
    try
      let graph,references,next_reference = LCGchart.parse timeout graph references next_reference time_fun in
      let time4 = time_fun () in
      let result = if test_only_flag then result else {result with graph=graph} in
      let result = {result with parse_time=time4 -. time3; graph_size=LCGchart.get_no_entries graph} in
      if LCGchart.is_parsed graph then
        try
          let term = LCGchart.get_parsed_term graph in
          let dependency_tree = LCGreductions.reduce term references next_reference in
          let time5 = time_fun () in
          let result = if test_only_flag then result else {result with dependency_tree=dependency_tree} in
          let result = {result with reduction_time=time5 -. time4; dependency_tree_size=Array.length dependency_tree} in
          if LCGreductions.is_reduced_dependency_tree dependency_tree then
            try
              LCGreductions.assign_labels dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
              LCGreductions.remove_cuts dependency_tree; (* uwaga: niejawna zmiana imperatywna w result *)
(*               if Array.length dependency_tree < 10000 then print_xml_dependency_tree "results/trees/" id dependency_tree;  *)
              let paths_array = extend_paths_array paths_array dependency_tree in
              let result = if test_only_flag then result else {result with paths=paths_array} in
              let (*dependency_tree2*)(*sem*)disamb = LCGvalence.assign_frames_and_senses paths_array dependency_tree(*disamb*) in (* FIXME: wstawić jako nowy etap i na nową zmienną *)
              let disamb(*sem*) = DisambSelPref.fit_sel_prefs DisambSelPref.fit_node1 (*dependency_tree2*)disamb in
              let (*sem*)disamb = DisambLemma.disambiguate_nodes (*dependency_tree*)(*sem*)disamb in
              let (*sem*)disamb = DisambLemma.remove_unused(*disambiguate_nodes*) (*dependency_tree*)(*sem*)disamb in
              let (*sem*)disamb = DisambLemma.remove_unused_choices(*disambiguate_nodes*) (*dependency_tree*)(*sem*)disamb in
              let (*disamb*)sem = DisambSelPref.fit_sel_prefs DisambSelPref.fit_node2 (*dependency_tree2*)disamb in
              let result = if test_only_flag then result else {result with disamb=disamb} in
              let sem = DisambLemma.disambiguate_meanings (*dependency_tree*)sem in
              let sem(*disamb*) = DisambLemma.remove_unused_choices(*disambiguate_nodes*) (*dependency_tree*)sem(*disamb*) in
              let result = if test_only_flag then result else {result with sem=sem} in
              let sem2 = SemGraph.translate paths_array (*disamb*)sem in
              let result = if test_only_flag then result else {result with sem2=sem2} in
              let sem3(*disamb*) = SemGraph.make_tree(*disambiguate_nodes*) (*dependency_tree*)sem2(*disamb*) in
              let sem3(*disamb*) = SemGraph.simplify_tree(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in
(*               let sem3(*disamb*) = SemGraph.manage_quantification(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in  *)
              let sem3(*disamb*) = SemGraph.simplify_gender(*disambiguate_nodes*) (*dependency_tree*)sem3(*disamb*) in
(*               if Array.length disamb < 10000 then print_xml_dependency_tree "results/trees/" (id ^ "dis") disamb; *)
              let result = if test_only_flag then result else {result with sem3=sem3} in
              let time6 = time_fun () in
              if SemGraph.validate_semantics sem3 then
                let trees = SemGraph.draw_trees max_n sem3 in
                let trees2 = Xlist.map trees SemMrl.variable_alpha_convertion in
                let mrls = Xlist.map trees2 SemMrl.make_mrl in
                let mrls = Xlist.map mrls SemMrl.move_requirements in
                let mrss = Xlist.map mrls SemMrl.make_mrs_of_mrl in
                let mrss = Xlist.map mrss SemMrl.mrs_handle_alpha_convertion in
                let fols = Xlist.map mrss (fun mrs ->
                  let l = SemMrl.foll_of_mrs_greedy mrs in
                  if l = [] then failwith "empty fol" else
                  List.hd l) in
                let result = if test_only_flag then result else {result with trees=trees; mrls=fols(*mrls*)} in
                {result with status=Parsed; sem_time=time6 -. time5}
              else {result with status=NotTranslated; sem_time=time6 -. time5}
            with e ->
              let time6 = time_fun () in
              {result with status=SemError; msg=Printexc.to_string e; sem_time=time6 -. time5}
          else
            {result with status=NotReduced}
        with
        | SemTooBig ->
          let time5 = time_fun () in
          {result with status=TooManyNodes; reduction_time=time5 -. time4}
        | e ->
          let time5 = time_fun () in
          {result with status=ReductionError; msg=Printexc.to_string e; reduction_time=time5 -. time4}
      else {result with status=NotParsed}
    with
      Timeout t ->
        let time4 = time_fun () in
        {result with status=ParseTimeout; msg=Printf.sprintf "%f" t; parse_time=time4 -. time3}
    | e ->
        let time4 = time_fun () in
        {result with status=ParseError; msg=Printexc.to_string e; parse_time=time4 -. time3}
  with e ->
    let time3 = time_fun () in
    {result with status=LexiconError; msg=Printexc.to_string e; lex_time=time3 -. time2}*)**)

let print_result file result =
  Printf.fprintf file "query: %s\n" (extract_query_text result.input_text);
  (match result.status with
    Idle -> Printf.fprintf file "idle\n"
  | PreprocessingError -> Printf.fprintf file "error_pre: %s\n" result.msg
  (* | LexiconError -> Printf.fprintf file "error_lex: %s\n" result.msg
  | ParseError -> Printf.fprintf file "error_parse: %s\n" result.msg
  | ParseTimeout -> Printf.fprintf file "timeout: %s\n" result.msg
  | NotParsed -> Printf.fprintf file "not_parsed: paths_size=%d chart_size=%d\n" result.paths_size result.chart_size
  | ReductionError -> Printf.fprintf file "error_reduction: %s\n" result.msg
  | TooManyNodes -> Printf.fprintf file "to_many_nodes: paths_size=%d chart_size=%d\n" result.paths_size result.chart_size
  | NotReduced -> Printf.fprintf file "not_reduced: paths_size=%d chart_size=%d\n" result.paths_size result.chart_size
  | SemError -> Printf.fprintf file "error_sem: %s\n" result.msg
  | NotTranslated -> Printf.fprintf file "not_translated: \n" *)
  (* | Parsed -> Printf.fprintf file "parsed: paths_size=%d chart_size=%d dependency_tree_size=%d\n" result.paths_size result.chart_size result.dependency_tree_size *)
  | Parsed -> Printf.fprintf file "parsed\n"
  | _ -> failwith "print_result");
  (* Printf.fprintf file "times: pre_time1=%f pre_time2=%f lex_time=%f parse_time=%f reduction_time=%f sem_time=%f\n%!"
    result.pre_time1 result.pre_time2 result.lex_time result.parse_time result.reduction_time result.sem_time *)
  Printf.fprintf file "times: pre_time1=%f pre_time2=%f parse_time=%f\n%!"
    result.pre_time1 result.pre_time2 result.parse_time

let add_result sum_result result =
  let sum_result = {sum_result with no_queries=sum_result.no_queries+1} in
  let sum_result = match result.status with
    Idle -> failwith "sum_result"
  | PreprocessingError -> {sum_result with no_pre_error=sum_result.no_pre_error+1}
  (* | LexiconError -> {sum_result with no_lex_error=sum_result.no_lex_error+1}
  | ParseError -> {sum_result with no_parse_error=sum_result.no_parse_error+1}
  | ParseTimeout -> {sum_result with no_timeout=sum_result.no_timeout+1}
  | NotParsed -> {sum_result with no_not_parsed=sum_result.no_not_parsed+1}
  | ReductionError -> {sum_result with no_reduction_error=sum_result.no_reduction_error+1}
  | TooManyNodes -> {sum_result with no_too_many_nodes=sum_result.no_too_many_nodes+1}
  | NotReduced -> {sum_result with no_not_reduced=sum_result.no_not_reduced+1}
  | SemError -> {sum_result with no_sem_error=sum_result.no_sem_error+1}
  | NotTranslated -> {sum_result with no_not_translated=sum_result.no_not_translated+1} *)
  | Parsed -> {sum_result with no_parsed=sum_result.no_parsed+1}
  | _ -> failwith "add_result" in
  {sum_result with
     sum_pre_time1=sum_result.sum_pre_time1 +. result.pre_time1;
     sum_pre_time2=sum_result.sum_pre_time2 +. result.pre_time2;
     (* sum_lex_time=sum_result.sum_lex_time +. result.lex_time; *)
     sum_parse_time=sum_result.sum_parse_time +. result.parse_time;
     (* sum_reduction_time=sum_result.sum_reduction_time +. result.reduction_time;
     sum_sem_time=sum_result.sum_sem_time +. result.sem_time*)}

let print_sum_result file r = failwith "print_sum_result: ni"
  (* Printf.fprintf file "avg_times: pre_time1=%f pre_time2=%f lex_time=%f parse_time=%f reduction_time=%f sem_time=%f\n"
    (r.sum_pre_time1 /. float r.no_queries)
    (r.sum_pre_time2 /. float r.no_queries)
    (r.sum_lex_time /. float r.no_queries)
    (r.sum_parse_time /. float r.no_queries)
    (r.sum_reduction_time /. float r.no_queries)
    (r.sum_sem_time /. float r.no_queries);
  Printf.fprintf file "sum_results: pre_error=%d (%f%%) lex_error=%d (%f%%) parse_error=%d (%f%%) timeout=%d (%f%%) not_parsed=%d (%f%%) reduction_error=%d (%f%%) too_many_nodes=%d (%f%%) not_reduced=%d (%f%%) sem_error=%d (%f%%) not_translated=%d (%f%%) parsed=%d (%f%%)\n%!"
    r.no_pre_error (float r.no_pre_error /. float r.no_queries *. 100.)
    r.no_lex_error (float r.no_lex_error /. float r.no_queries *. 100.)
    r.no_parse_error (float r.no_parse_error /. float r.no_queries *. 100.)
    r.no_timeout (float r.no_timeout /. float r.no_queries *. 100.)
    r.no_not_parsed (float r.no_not_parsed /. float r.no_queries *. 100.)
    r.no_reduction_error (float r.no_reduction_error /. float r.no_queries *. 100.)
    r.no_too_many_nodes (float r.no_too_many_nodes /. float r.no_queries *. 100.)
    r.no_not_reduced (float r.no_not_reduced /. float r.no_queries *. 100.)
    r.no_sem_error (float r.no_sem_error /. float r.no_queries *. 100.)
    r.no_not_translated (float r.no_not_translated /. float r.no_queries *. 100.)
    r.no_parsed (float r.no_parsed /. float r.no_queries *. 100.) *)

let get_sock_addr host_name port =
  let he = Unix.gethostbyname host_name in
  let addr = he.Unix.h_addr_list in
  Unix.ADDR_INET(addr.(0),port)

let generate_queries filename timeout =
  let queries = File.load_lines filename in
  List.rev (fst (Xlist.fold queries ([],1) (fun (l,id) query ->
    let query = try List.hd (Str.split (Str.regexp "\t") query) with _ -> "" in
    (string_of_int id,(query,timeout)) :: l, id+1)))

let generate_queries_id filename timeout =
  let queries = File.load_lines filename in
  List.rev (Xlist.rev_map queries (fun line ->
    match Str.split (Str.regexp "\t") line with
      [id;query] -> id,(query,timeout)
    | _ -> failwith ("generate_queries_id: " ^ line)))

(*let test_process_file filename output_filename timeout =
  let queries = generate_queries filename timeout in
  let ic,oc = Unix.open_connection (get_sock_addr Paths.pre_host Paths.pre_port) in
  File.file_out output_filename (fun file ->
    let _ = Xlist.fold queries empty_sum_result (fun sum_result (id,(query,timeout)) ->
      let result = process_query ic oc timeout true id query 10 in
      print_result file result;
      let sum_result = add_result sum_result result in
      print_sum_result file sum_result;
      sum_result) in
    ());
  Printf.fprintf oc "\n%!";
  let _ = Unix.shutdown_connection ic in
  ()

let process_file_id filename output_filename timeout =
  let queries = generate_queries_id filename timeout in
  let ic,oc = Unix.open_connection (get_sock_addr Paths.pre_host Paths.pre_port) in
  File.file_out output_filename (fun file ->
    let _ = Xlist.fold queries empty_sum_result (fun sum_result (id,(query,timeout)) ->
      let result = process_query ic oc timeout true id query 10 in
      print_result file result;
      let sum_result = add_result sum_result result in
      print_sum_result file sum_result;
      sum_result) in
    ());
  Printf.fprintf oc "\n%!";
  let _ = Unix.shutdown_connection ic in
  ()*)