nazwy akapitów

Wojciech Jaworski
1 parent 9d5402d4
Showing 8 changed files with 226 additions and 12 deletions
exec/ENIAMexec.ml
exec/ENIAMexecTypes.ml
exec/ENIAMvisualization.ml
subsyntax/ENIAMsubsyntax.ml
subsyntax/ENIAMsubsyntaxStringOf.ml
subsyntax/ENIAMsubsyntaxTypes.ml
subsyntax/interface.ml
tokenizer/ENIAMtokens.ml
@@ -34,6 +34,7 @@ let translate_mode = function
   | ENIAMsubsyntaxTypes.Swigra -> Swigra
   | ENIAMsubsyntaxTypes.POLFIE -> POLFIE
   | ENIAMsubsyntaxTypes.Error -> Error
+  | ENIAMsubsyntaxTypes.Name -> Name
  
 let rec translate_sentence = function
     ENIAMsubsyntaxTypes.RawSentence s -> RawSentence s
@@ -139,10 +140,27 @@ let create_text_fragments tokens paths last =
     text_fragments.(i) <- map);
   text_fragments
  
+(*let create_beg_positions tokens paths last =
+  let beg_positions = Array.make last (-1) in
+  Xlist.iter paths (fun (id,lnode,rnode) ->
+    let t = ExtArray.get tokens id in
+    beg_positions.(lnode) <- t.ENIAMtokenizerTypes.beg);
+  beg_positions
+
+let create_end_positions tokens paths last =
+  let end_positions = Array.make last (-1) in
+  Xlist.iter paths (fun (id,lnode,rnode) ->
+    let t = ExtArray.get tokens id in
+    end_positions.(rnode) <- t.ENIAMtokenizerTypes.beg + t.ENIAMtokenizerTypes.len);
+  end_positions*)
+
 let eniam_parse_sentence timeout verbosity rules tokens lex_sems paths last =
   ENIAM_LCGreductions.reset_variant_label ();
   let result = {empty_eniam_parse_result with paths_size = Xlist.size paths} in
-  let result = if verbosity = 0 then result else {result with text_fragments=create_text_fragments tokens paths last} in
+  let result = if verbosity = 0 then result else {result with
+    text_fragments=create_text_fragments tokens paths last;
+    (*beg_positions=create_beg_positions tokens paths last;
+    end_positions=create_end_positions tokens paths last;*)} in
   let time1 = time_fun () in
   try
     (* print_endline "eniam_parse_sentence 1"; *)
@@ -78,7 +78,7 @@ type semantic_processing_result = {
   }
 *)
 type mode =
-    Raw | Struct | CONLL | ENIAM | Mate | Swigra | POLFIE | Error
+    Raw | Struct | CONLL | ENIAM | Mate | Swigra | POLFIE | Error | Name
  
 type sentence =
     RawSentence of string
@@ -309,6 +309,7 @@ let rec fold_text mode s f = function
         fold_text mode s f text)
  
 let rules_filename = ENIAM_LCGlexiconTypes.resource_path ^ "/LCGlexicon/lexicon-pl.dic"
+let colours_filename = ENIAMwalTypes.data_path ^ "/colours.tab"
  
 let lcg_rules = ref ([] : (int * (ENIAM_LCGtypes.linear_term ExtArray.t ->
           (ENIAM_LCGtypes.SymbolMap.key * ENIAM_LCGtypes.linear_term) list ->
@@ -23,6 +23,10 @@ open Printf
 open ENIAMtokenizerTypes
 open ENIAMexecTypes
  
+type marked =
+    Chart of (string * string * string list) list
+  | Message of string
+
 let string_of_status = function
       Idle -> "Idle"
     | PreprocessingError -> "PreprocessingError"
@@ -668,6 +672,7 @@ let string_of_mode = function
   | Swigra -> "Swigra"
   | POLFIE -> "POLFIE"
   | Error -> "Error"
+  | Name -> "Name"
 (*
 (*let rec string_of_sentence = function
     RawSentence s -> sprintf "RawSentence(%s)" s
@@ -811,7 +816,7 @@ let rec extract_pos_cat vars = function
  
 let get_text_fragment text_fragments node1 node2 =
   try IntMap.find text_fragments.(node1) node2
-  with Not_found -> "???"(*failwith (Printf.sprintf "chart: text_fragment not found %d-%d" node1 node2)*)
+  with (*Not_found*)_ -> "???"(*failwith (Printf.sprintf "chart: text_fragment not found %d-%d" node1 node2)*)
  
 let omited = StringSet.of_list ["<subst>";"<depr>";"<ppron12>";"<ppron3>";"<siebie>";"<prep>";
   "<num>";"<intnum>";"<realnum>";"<intnum-interval>";"<realnum-interval>";"<symbol>";"<ordnum>";
@@ -861,6 +866,86 @@ let cat_tokens_sequence text_fragments g =
       | b :: l -> if a = b then b :: l else a :: b :: l) in*)
   String.concat " " (Xlist.map l (fun (n,texts) -> texts))
  
+let excluded_cats = StringSet.union omited (StringSet.of_list ["0";"Prep";"s";"BracketSet";"<root>";"by";"nie";"się";"jak";"int";
+  "wieś";"ulica";"osada leśna";"część miejscowości";"astr.";"przysiółek";"nazwisko";"część miasta";
+  "imię";"geograficzna";"pseudonim";"gmina wiejska";"osada";"firma";"język programowania";"kolonia";
+  "instytucja";"gmina miejska";"miasto";"pora roku";"miesiąc";"krój pisma";"gmina miejsko-wiejska";
+  "obszar wiejski";"powiat";"organizacja";"dzielnica";"własna";"marka";"przydomek";"hour-minute";"inicjał"; ])
+
+let load_colours_of_cats filename =
+  File.fold_tab filename StringMap.empty (fun map -> function
+    [cat; colour] -> StringMap.add map cat colour
+  | line -> failwith ("load_colours_of_cats: " ^ String.concat "\t" line))
+
+let colours_of_cats = ref StringMap.empty
+
+let initialize () =
+  colours_of_cats := load_colours_of_cats colours_filename
+
+(* let colours_of_cats = Xlist.fold [
+  "ChemCompound","#00ffff";
+  "ChemFunGroup","#ff00cc";
+  "Measure","#ffff00";
+  "Contain","#00ff00";
+  "Number","#0000ff";
+  "Dose","#ff0000";
+  (* "","#";
+  "","#"; *)
+  ] StringMap.empty (fun map (cat,colour) -> StringMap.add map cat colour) *)
+
+let rec merge_cat_chart rev = function
+    (i,j,s,x) :: (m,n,t,y) :: l ->
+      (* printf "i=%d j=%d s=%s m=%d n=%d t=%s\n%!" i j s m n t; *)
+      if j=m && s=t then merge_cat_chart rev ((i,n,t,y) :: l)
+      else merge_cat_chart ((i,j,s,x) :: rev) ((m,n,t,y) :: l)
+  | l -> List.rev (l @ rev)
+
+let cat_chart text_fragments g =
+  (* print_endline "cat_chart 1"; *)
+  let l,last = ENIAM_LCGchart.fold g ([],0) (fun (l,last) (symbol,node1,node2,sem,layer) ->
+    (* printf "node1=%d node2=%d symbol=%s\n" node1 node2 (ENIAM_LCGstringOf.grammar_symbol 0 symbol); *)
+    (node1,node2,extract_pos_cat [] symbol) :: l, max node2 last) in
+  let a = Array.make (Array.length g) StringSet.empty in
+  Xlist.iter l (fun (node1,node2,cat) ->
+    if StringSet.mem excluded_cats cat then () else
+    Int.iter node1 (node2 - 1) (fun i ->
+      a.(i) <- StringSet.add a.(i) cat));
+  let l = List.rev (Int.fold 0 (Array.length g - 1) [] (fun l i ->
+    if i >= last then l else
+    let cats = List.sort compare (StringSet.to_list a.(i)) in
+    (i,i+1,String.concat "|" cats, cats ) :: l)) in
+  let l = merge_cat_chart [] l in
+  (* print_endline "cat_chart 2"; *)
+  List.rev (Xlist.fold l [] (fun l (node1,node2,key,cats) ->
+    let t = get_text_fragment text_fragments node1 node2 in
+    (* if t = "???" then printf "node1=%d node2=%d key=%s cats=[%s]\n%!" node1 node2 key (String.concat ";" cats); *)
+    if node1 = node2 then l else
+    (t,key,cats) :: l))
+
+let create_styles ll =
+  fst (Xlist.fold ll (StringMap.empty,1) (fun (map,n) -> function
+  | (_,_,Message l) -> map,n
+  | (_,_,Chart l) ->
+    Xlist.fold l (map,n) (fun (map,n) (_,key,cats) ->
+      if StringMap.mem map key || key = "" then map,n else
+      let colours = List.rev (Xlist.rev_map cats (fun cat ->
+        try StringMap.find !colours_of_cats cat with Not_found -> print_endline ("create_styles: unknown cat " ^ cat); "#ffffff")) in
+      let colours,_ = Xlist.fold colours ([],0) (fun (colours,i) colour ->
+        (Printf.sprintf "%s %dpx,%s %dpx" colour (i*7) colour ((i+1)*7)) :: colours, i+1) in
+      StringMap.add map key ("B" ^ string_of_int n,List.rev colours),n+1)))
+
+let render_styles styles =
+  "<style type=\"text/css\">\n  " ^
+  String.concat "\n  " (List.rev (StringMap.fold styles [] (fun l _ (name,colours) ->
+    (Printf.sprintf ".%s { background-image:repeating-linear-gradient(-45deg,%s); }" name
+      (String.concat "," colours)) :: l))) ^
+  "</style>"
+
+let assign_style styles (t,key,_) =
+  if key = "" then t else
+  let id,_ = try StringMap.find styles key with Not_found -> failwith ("assign_style: " ^ key) in
+  Printf.sprintf "<span class=\"%s\">%s</span>" id t
+
 (* verbosity:
   0 -> jedynie informacja o statusie zdania
   1 -> zawartość struktur danych istotnych dla uzyskanego statusu
@@ -1271,6 +1356,7 @@ let file_prefix_of_mode = function
   | Swigra -> "S"
   | POLFIE -> "P"
   | Error -> "Er"
+  | Name -> "N"
  
 let rec html_of_sentence path file_prefix mode img verbosity tokens = function
     RawSentence s -> escape_html s
@@ -1488,3 +1574,99 @@ let rec to_string_text verbosity tokens = function
     RawText s -> []
   | StructText paragraphs -> List.flatten (Xlist.map paragraphs (to_string_paragraph verbosity tokens))
   | AltText l -> List.flatten (Xlist.map l (fun (mode,text) -> to_string_text verbosity tokens text))
+
+let rec to_string2_paragraph verbosity tokens = function
+    RawParagraph s -> []
+  | StructParagraph sentences ->
+       let l = List.flatten (Xlist.map sentences (fun p -> to_string_sentence verbosity tokens p.sentence)) in
+       List.rev (Xlist.rev_map l (fun t -> "","",Message t))
+  | AltParagraph((Name,RawParagraph name) :: l) ->
+       let l = List.flatten (Xlist.map l (fun (mode,paragraph) -> to_string2_paragraph verbosity tokens paragraph)) in
+       List.rev (Xlist.rev_map l (fun (_,s,t) -> name,s,t))
+  | AltParagraph l -> List.flatten (Xlist.map l (fun (mode,paragraph) -> to_string2_paragraph verbosity tokens paragraph))
+  | ErrorParagraph s -> ["","",Message "SubsyntaxError"]
+
+let rec to_string2_text verbosity tokens = function
+    RawText s -> []
+  | StructText paragraphs -> List.flatten (Xlist.map paragraphs (to_string2_paragraph verbosity tokens))
+  | AltText l -> List.flatten (Xlist.map l (fun (mode,text) -> to_string2_text verbosity tokens text))
+
+let rec skip_tag = function
+    ">" :: l -> l
+  | s :: l -> skip_tag l
+  | [] -> []
+
+let rec check_name_length_rec n rev = function
+    "<" :: l -> check_name_length_rec n rev (skip_tag l)
+  | [s] -> String.concat "" (List.rev (s :: rev))
+  | [] -> String.concat "" (List.rev rev)
+  | s :: l ->
+      if n > 1 then check_name_length_rec (n-1) (s :: rev) l
+      else String.concat "" (List.rev ("…" :: rev))
+
+let check_name_length n s =
+  let l = Xunicode.utf8_chars_of_utf8_string s in
+  check_name_length_rec n [] l
+  (* if String.length s > n then
+    String.sub s 0 (n-1) ^ "…"
+  else s *)
+
+let to_string2_simplify name_length= function
+    name,_,Message s ->
+      if name_length <= 0 then s
+      else (check_name_length name_length name) ^ "\t" ^ s
+  | _ -> failwith "to_string2_simplify"
+
+
+let marked_string_of_eniam_sentence verbosity tokens (result : eniam_parse_result) =
+  let status_string = string_of_status result.status in
+  if result.status = NotParsed then
+    [status_string, Chart(cat_chart result.text_fragments result.chart1)]
+  else [status_string,Message result.msg]
+
+let rec marked_string_of_sentence verbosity tokens = function
+    RawSentence s -> []
+  | StructSentence(paths,last) -> []
+  | DepSentence paths -> []
+  | ENIAMSentence result -> marked_string_of_eniam_sentence verbosity tokens result
+  | QuotedSentences sentences -> List.flatten (Xlist.map sentences (fun p -> marked_string_of_sentence verbosity tokens p.sentence))
+  | AltSentence l -> List.flatten (Xlist.map l (fun (mode,sentence) -> marked_string_of_sentence verbosity tokens sentence))
+
+let rec marked_string_of_paragraph verbosity tokens = function
+    RawParagraph s -> []
+  | StructParagraph sentences ->
+       let l = List.flatten (Xlist.map sentences (fun p -> marked_string_of_sentence verbosity tokens p.sentence)) in
+       List.rev (Xlist.rev_map l (fun (s,t) -> "",s,t))
+  | AltParagraph((Name,RawParagraph name) :: l) ->
+       let l = List.flatten (Xlist.map l (fun (mode,paragraph) -> marked_string_of_paragraph verbosity tokens paragraph)) in
+       List.rev (Xlist.rev_map l (fun (_,s,t) -> name,s,t))
+  | AltParagraph l -> List.flatten (Xlist.map l (fun (mode,paragraph) -> marked_string_of_paragraph verbosity tokens paragraph))
+  | ErrorParagraph s -> ["","SubsyntaxError",Message s]
+
+let rec marked_string_of_text verbosity tokens = function
+    RawText s -> []
+  | StructText paragraphs -> List.flatten (Xlist.map paragraphs (marked_string_of_paragraph verbosity tokens))
+  | AltText l -> List.flatten (Xlist.map l (fun (mode,text) -> marked_string_of_text verbosity tokens text))
+
+let print_html_marked_simple_text path name name_length l =
+  File.file_out (path ^ name ^ ".html") (fun file ->
+    fprintf file "%s\n" html_header;
+    (* print_endline "print_html_marked_text 1"; *)
+    (* print_endline "print_html_marked_text 2"; *)
+    let styles = create_styles l in
+    (* print_endline "print_html_marked_text 3"; *)
+    fprintf file "%s\n" (render_styles styles);
+    if name_length <= 0 then
+      Xlist.iter l (function
+          name, "NotParsed", Chart t -> fprintf file "%s<BR>\n" (String.concat "" (List.rev (Xlist.rev_map t (assign_style styles))));
+        | name, status, Chart t -> fprintf file "%s: %s<BR>\n" status (String.concat "" (List.rev (Xlist.rev_map t (assign_style styles))));
+        | name, status, Message t -> fprintf file "%s: %s<BR>\n" status (escape_html t))
+    else (
+      fprintf file "<TABLE border=1>\n";
+      Xlist.iter l (function
+          name, "NotParsed", Chart t -> fprintf file "<TR><TD>%s</TD><TD>%s</TD><TR>\n" (check_name_length name_length name) (String.concat "" (List.rev (Xlist.rev_map t (assign_style styles))));
+        | name, status, Chart t -> fprintf file "<TR><TD>%s</TD><TD>%s: %s</TD><TR>\n" (check_name_length name_length name) status (String.concat "" (List.rev (Xlist.rev_map t (assign_style styles))));
+        | name, status, Message t -> fprintf file "<TR><TD>%s</TD><TD>%s: %s</TD><TR>\n" (check_name_length name_length name) status (escape_html t));
+      fprintf file "</TABLE>\n");
+    (* print_endline "print_html_marked_text 4"; *)
+    fprintf file "%s\n" html_trailer)
@@ -344,13 +344,19 @@ let parse query =
   (* print_endline "XXXXXXXXXXXXXXXXXXXXXXXXX a19"; *)
   paths(*, next_id*)
  
-let parse_text_tokens sentence_split_flag tokens query =
+let parse_text_tokens sentence_split_flag par_names_flag tokens query =
   (* print_endline ("parse_text_tokens: " ^ query); *)
   let paragraphs = Xstring.split "\n\\|\r" query in
   let paragraphs = List.rev (Xlist.fold paragraphs [] (fun l -> function "" -> l | s -> s :: l)) in
   let n = if Xlist.size paragraphs = 1 then 0 else 1 in
   let paragraphs,_ = Xlist.fold paragraphs ([],n) (fun (paragraphs,n) paragraph ->
     try
+      let name, paragraph =
+        if par_names_flag then
+          match Xstring.split "\t" paragraph with
+            [name; paragraph] -> name, paragraph
+          | _ -> failwith ("parse_text_tokens: " ^ paragraph)
+        else "", paragraph in
       (* print_endline paragraph; *)
       let paths = parse paragraph in
       (* print_endline "parse_text 1"; *)
@@ -358,25 +364,26 @@ let parse_text_tokens sentence_split_flag tokens query =
       let sentences =
         if sentence_split_flag then ENIAMsentences.split_into_sentences pid paragraph tokens paths
         else ENIAMsentences.no_split_into_sentences pid paragraph tokens paths in
-      (AltParagraph[Raw,RawParagraph paragraph; Struct,StructParagraph sentences]) :: paragraphs, n+1
+      (AltParagraph ((if par_names_flag then [Name,RawParagraph name] else []) @
+        [Raw,RawParagraph paragraph; Struct,StructParagraph sentences])) :: paragraphs, n+1
     with e ->
       (AltParagraph[Raw,RawParagraph paragraph; Error,ErrorParagraph (Printexc.to_string e)]) :: paragraphs, n+1) in
   AltText[Raw,RawText query; Struct,StructText(List.rev paragraphs)], tokens
  
-let parse_text sentence_split_flag query =
+let parse_text sentence_split_flag par_names_flag query =
   (* print_endline ("parse_text: " ^ query); *)
   let tokens = ExtArray.make 100 empty_token_env in
   let _ = ExtArray.add tokens empty_token_env in (* id=0 jest zarezerwowane dla pro; FIXME: czy to jest jeszcze aktualne? *)
-  parse_text_tokens sentence_split_flag tokens query
+  parse_text_tokens sentence_split_flag par_names_flag tokens query
  
 let catch_parse text =
   try
     let tokens = parse text in tokens,""
   with e -> [], Printexc.to_string e
  
-let catch_parse_text sentence_split_flag text =
+let catch_parse_text sentence_split_flag par_names_flag text =
   try
-    let text,tokens = parse_text sentence_split_flag text in text,tokens,""
+    let text,tokens = parse_text sentence_split_flag par_names_flag text in text,tokens,""
   with e ->
     RawText text,
     ExtArray.make 0 empty_token_env,
@@ -29,6 +29,7 @@ let mode = function
   | Swigra -> "Swigra"
   | POLFIE -> "POLFIE"
   | Error -> "Error"
+  | Name -> "Name"
  
 let token_extarray t =
   String.concat "\n" (List.rev (Int.fold 0 (ExtArray.size t - 1) [] (fun l id ->
@@ -20,7 +20,7 @@
 open ENIAMtokenizerTypes
  
 type mode =
-    Raw | Struct | CONLL | ENIAM | Mate | Swigra | POLFIE | Error
+    Raw | Struct | CONLL | ENIAM | Mate | Swigra | POLFIE | Error | Name
  
 type sentence =
     RawSentence of string
@@ -83,6 +83,7 @@ let int_of_mode = function
   | Swigra -> 5
   | POLFIE -> 6
   | Error -> 7
+  | Name -> 8
  
 let compare_mode x y =
   compare (int_of_mode x) (int_of_mode y)
@@ -24,6 +24,7 @@ let output = ref Text
 let comm_stdio = ref true
 let sentence_split = ref Full
 let port = ref 5439
+let par_names = ref false
  
 let spec_list = [
   "-s", Arg.Unit (fun () -> sentence_split:=Full), "Split input into sentences (default)";
@@ -40,6 +41,8 @@ let spec_list = [
   "--no-strong-disamb", Arg.Unit (fun () -> ENIAMsubsyntaxTypes.strong_disambiguate_flag:=false), "Do not perform strong disambiguation (default)";
   "--internet-mode", Arg.Unit (fun () -> ENIAMtokenizerTypes.internet_mode:=true), "Relaxed attitude towards interpunction";
   "--no-internet-mode", Arg.Unit (fun () -> ENIAMtokenizerTypes.internet_mode:=false), "Strict attitude towards interpunction (default)";
+  "--par-names", Arg.Unit (fun () -> par_names:=true), "Identifiers of paragraphs provided";
+  "--no-par-names", Arg.Unit (fun () -> par_names:=false), "No identifiers of paragraphs provided (default)";
   ]
  
 let usage_msg =
@@ -68,8 +71,8 @@ let rec main_loop in_chan out_chan =
     print_endline "input text end"; *)
     (if !sentence_split = Full || !sentence_split = Partial then
        let text,tokens,msg =
-         if !sentence_split = Full then ENIAMsubsyntax.catch_parse_text true text
-         else ENIAMsubsyntax.catch_parse_text false text in
+         if !sentence_split = Full then ENIAMsubsyntax.catch_parse_text true !par_names text
+         else ENIAMsubsyntax.catch_parse_text false !par_names text in
        (match !output with
           Text ->
              if msg = "" then output_string out_chan (ENIAMsubsyntaxStringOf.text "" tokens text ^ "\n" ^
@@ -1059,6 +1059,7 @@ let rec recognize_sign_group poss_s_beg i = function
   | (Sign "®") :: l -> create_sign_token poss_s_beg i [Sign "®"] l (Symbol "®")
   | (Sign "µ") :: l -> create_sign_token poss_s_beg i [Sign "µ"] l (Symbol "µ")
   | (Sign "μ") :: l -> create_sign_token poss_s_beg i [Sign "µ"] l (Symbol "µ")
+  | (Sign "†") :: l -> create_sign_token poss_s_beg i [Sign "†"] l (Interp "†")
   | (Sign s) :: l -> print_endline ("recognize_sign_group: " ^ s); create_sign_token poss_s_beg i [Sign s] l (Symbol s)
   | l ->  failwith "recognize_sign_group"