Wojciech Jaworski / ENIAM

open Xstd
open Types
open Printf

type tags =
    T of string * string
  | A of string

let parse_name s =
  if s = "" then failwith "parse_name: empty name" else
  if String.get s 0 = '@' then String.sub s 1 (String.length s - 1)
  else failwith ("parse_name: invalid name " ^ s)

let parse_tags s =
  Xlist.map (Xstring.split " " s) (fun t ->
    match Xstring.split "=" t with
      [k] -> A k
    | [k;v] -> T(k,v)
    | _ -> failwith "parse_tags")

let parse_star = function
    "" -> Productive
  | "*" -> Star
  | "ndm" -> Ndm
  | s -> failwith "parse_star"

let merge_stars = function
    Star,_ -> Star
  | _,Star -> Star
  | Ndm,_ -> failwith "merge_stars"
  | _,Ndm -> failwith "merge_stars"
  | _ -> Productive

let string_of_star = function
    Productive -> ""
  | Star -> "*"
  | Ndm -> "ndm"

let print_rule file rule =
  Printf.fprintf file "%s\t%d\t%s\t%s\t%s\t%s\t%s\n" rule.id rule.freq (string_of_star rule.star)
    rule.pref rule.find rule.set rule.interp

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

type alternation = {astar: star; aphone: string; afind: string; aset: string}

let load_alternations filename =
  let alternations,name,alts = File.fold_tab filename ([],"",[]) (fun (found,name,alts) -> function
      [alt_name] ->
        let alt_name = parse_name alt_name in
        if name = "" then found,alt_name,[] else (name,List.rev alts) :: found,alt_name,[]
    | [star;a;b;c] -> found,name,{astar=parse_star star; aphone=a; afind=b; aset=c} :: alts
    | _ ->  failwith "load_alternations") in
  (name,List.rev alts) :: alternations

let alternations () = load_alternations "../morphology/data/alternations.dic"

let revert_alternations l =
  Xlist.map l (fun a -> {a with afind=a.aset; aset=a.afind})

let alternation_map alternations = Xlist.fold alternations StringMap.empty (fun map (k,v) ->
  StringMap.add map k v)

let rev_alternation_map alternations = Xlist.fold alternations StringMap.empty (fun map (k,v) ->
  StringMap.add map k (revert_alternations v))

type suf_rule = {sstar: star; salt_name: string; ssufix: string; stags: tags list}
type pref_rule = {pstar: star; pprefix: string; ptags: tags list}

let load_suf_rules filename =
  let suf_rules,name,rules = File.fold_tab filename ([],"",[]) (fun (found,name,rules) -> function
      [rules_name] ->
        let rules_name = parse_name rules_name in
        if name = "" then found,rules_name,[] else (name,List.rev rules) :: found,rules_name,[]
    | [star;alt_name;sufix;tags] -> found,name,{sstar=parse_star star; salt_name=alt_name; ssufix=sufix; stags=parse_tags tags} :: rules
    | line -> failwith ("load_suf_rules: " ^ String.concat "\t" line)) in
  (name,List.rev rules) :: suf_rules

let load_pref_rules filename =
  let pref_rules,name,rules = File.fold_tab filename ([],"",[]) (fun (found,name,rules) -> function
      [rules_name] ->
        let rules_name = parse_name rules_name in
        if name = "" then found,rules_name,[] else (name,List.rev rules) :: found,rules_name,[]
    | [star;prefix;tags] -> found,name,{pstar=parse_star star; pprefix=prefix; ptags=parse_tags tags} :: rules
    | _ -> failwith "load_pref_rules") in
  (name,List.rev rules) :: pref_rules

let rules () = load_suf_rules "../morphology/data/rules.dic"
let rev_rules () = load_suf_rules "../morphology/data/rev_rules.dic"
let pref_rules () = load_pref_rules "../morphology/data/pref_rules.dic"

let load_freq_rules filename =
  File.fold_tab filename [] (fun rules -> function
    [id; freq; star; pref; find; set; interp] ->
       {id=id; freq=int_of_string freq; star=parse_star star; pref=pref; find=find; set=set;
        tags=[]; interp=interp} :: rules
  | _ -> failwith "load_freq_rules")

let expand_tags x l =
  Xlist.map l (function
      T(k,v) -> k,v
    | A k -> k,x)

let expand_tags_simple l =
  Xlist.map l (function
      T(k,v) -> k,v
    | A k -> failwith ("expand_tags_simple: " ^ k))

let prepare_rules alternation_map suf_rules =
  Xlist.fold suf_rules [] (fun rules s ->
    let alternation = try StringMap.find alternation_map s.salt_name with Not_found -> failwith ("prepare_rules: " ^ s.salt_name) in
    Xlist.fold alternation rules (fun rules a ->
        {star=merge_stars (s.sstar,a.astar); pref=""; find=a.afind ^ s.ssufix; set=a.aset;
         tags=expand_tags a.aphone s.stags; interp=""; id=""; freq=0} :: rules))

let prepare_rev_rules rev_alternation_map suf_rules =
  Xlist.fold suf_rules [] (fun rules s ->
    let alternation = try StringMap.find rev_alternation_map s.salt_name with Not_found -> failwith ("prepare_rev_rules: " ^ s.salt_name) in
    Xlist.fold alternation rules (fun rules a ->
        {star=merge_stars (s.sstar,a.astar); pref=""; find=a.afind; set=a.aset ^ s.ssufix;
         tags=expand_tags a.aphone s.stags; interp=""; id=""; freq=0} :: rules))

let prepare_pref_rules pref_rules =
  Xlist.fold pref_rules [] (fun rules p ->
    {star=p.pstar; pref=p.pprefix; find=""; set=""; tags=expand_tags "" p.ptags; interp=""; id=""; freq=0} :: rules)

let rule_map alternation_map rev_alternation_map rules rev_rules pref_rules =
  let map = Xlist.fold rules StringMap.empty (fun map (k,v) -> StringMap.add map k (prepare_rules alternation_map v)) in
  let map = Xlist.fold rev_rules map (fun map (k,v) -> StringMap.add map k (prepare_rev_rules rev_alternation_map v)) in
  Xlist.fold pref_rules map (fun map (k,v) -> StringMap.add map k (prepare_pref_rules v))

let schemata () = File.load_tab "../morphology/data/schemata.dic" (fun l -> l)

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

let rec extract_tag s rev = function
    [] -> "", List.rev rev
  | (k,v) :: l -> if s = k then v, List.rev rev @ l else extract_tag s ((k,v) :: rev) l

let create_compound_rules schemata rule_map =
  let found = Xlist.fold schemata [] (fun found schema ->
    let compounds = Xlist.fold schema [{star=Productive;pref="";find="";set="";tags=[];interp=""; id=""; freq=0}] (fun compounds rule_set_name ->
      let rules = try StringMap.find rule_map rule_set_name with Not_found -> failwith ("create_compound_rules: " ^ rule_set_name) in
      Xlist.fold compounds [] (fun compounds compound ->
        Xlist.fold rules compounds (fun compounds rule ->
          (* printf "compound.find=%s; compound.set=%s\n" compound.find compound.set;
          printf "rule.find=%s; rule.set=%s\n" rule.find rule.set;  *)
          if rule.find = "" && rule.set = "" then
            {compound with star=merge_stars (compound.star, rule.star);
                           pref=compound.pref ^ rule.pref; tags=rule.tags@compound.tags} :: compounds
          else if Xstring.check_sufix compound.set rule.find then
            {compound with star=merge_stars (compound.star, rule.star);
                           find=Xstring.cut_sufix compound.set rule.find ^ compound.find; set=rule.set; tags=rule.tags@compound.tags} :: compounds
          else if Xstring.check_sufix rule.find compound.set then
            {compound with star=merge_stars (compound.star, rule.star);
                           find=compound.find; set=Xstring.cut_sufix rule.find compound.set ^ rule.set; tags=rule.tags@compound.tags} :: compounds
          else compounds))) in
    compounds @ found) in
  let found = Xlist.rev_map found (fun rule ->
    let suf, tags = extract_tag "suf" [] rule.tags in
    {rule with set=rule.set ^ suf; tags=tags}) in
  found

let make_compound_rules () =
  let schemata = schemata () in
  let alternations = alternations () in
  let alternation_map = alternation_map alternations in
  let rev_alternation_map = rev_alternation_map alternations in
  let rule_map = rule_map alternation_map rev_alternation_map (rules ()) (rev_rules ()) (pref_rules ()) in
  create_compound_rules schemata rule_map

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

let tag_value = function
    "cat" -> 1
  | "pref" -> 2
  | "con" -> 3
  | "grad" -> 4
  | "group" -> 5
  | "flex2" -> 6
  | "flex" -> 7
  | "lemma" -> 8
  | "patal" -> 9
  | "velar" -> 10
  | s -> failwith ("tag_value: " ^ s)

let tag_value2 = function
    "cat" -> 1
  | "flex" -> 2
  | "flex2" -> 3
  | "grad" -> 4
  | "pref" -> 5
  | "lemma" -> 6
  | "con" -> 7
  | "group" -> 8
  | "patal" -> 9
  | "velar" -> 10
  | s -> failwith ("tag_value2: " ^ s)

let compare_tag (a,_) (b,_) =
  compare (tag_value a) (tag_value b)

let compare_tag2 (a,_) (b,_) =
  compare (tag_value2 a) (tag_value2 b)

let load_interp_rules filename =
  File.load_tab filename (function
      star :: tags :: interp :: comment :: [] ->
        {star=parse_star star;
          pref=""; find=""; set="";
          tags=expand_tags_simple (parse_tags tags); interp=interp; (*comment=comment;*) id=""; freq=0}
    | line -> failwith ("load_tab: " ^ (String.concat "\t" line)))

module InterpTree = struct

  type t =
      N of string * t StringMap.t * rule list
    | L of rule list

  let empty = L []

  let rec create_rec rule = function
      [],N(key,map,rules) -> N(key,map,rule :: rules)
    | [],L rules -> L(rule :: rules)
    | (k,v) :: tags,N(key,map,rules) ->
        if k <> key then failwith ("create_rec: " ^ k ^ " " ^ key) else
        let tree = try StringMap.find map v with Not_found -> empty in
        let tree = create_rec rule (tags,tree) in
        N(key,StringMap.add map v tree,rules)
    | (k,v) :: tags,L rules ->
        let tree = create_rec rule (tags,empty) in
        N(k,StringMap.add StringMap.empty v tree,rules)

  let create interp_rules =
    Xlist.fold interp_rules empty (fun interp_tree rule ->
      let tags = Xlist.sort rule.tags compare_tag2 in
      create_rec rule (tags,interp_tree))

  let rec find_rec = function
      [],N(_,_,rules) -> rules
    | _,L rules -> rules
    | (k,v) :: tags,N(key,map,rules) ->
        if k <> key then find_rec (tags,N(key,map,rules)) else
        try rules @ (find_rec (tags,StringMap.find map v))
        with Not_found -> rules

  let find interp_tree tags =
    find_rec (Xlist.sort tags compare_tag2,interp_tree)

end

let interp_tree () = InterpTree.create (load_interp_rules "../morphology/data/interp_rules.dic")

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

let create_interp_compound_rules interp_tree compound_rules =
  Xlist.fold compound_rules [] (fun interp_compound_rules rule ->
    let interp_rules = InterpTree.find interp_tree rule.tags in
    Xlist.fold interp_rules interp_compound_rules (fun interp_compound_rules interp_rule ->
      {rule with interp=interp_rule.interp; star=merge_stars (rule.star, interp_rule.star)} :: interp_compound_rules))

let assign_ids rules =
  fst (Xlist.fold rules ([],1) (fun (rules,id) rule ->
    {rule with id=string_of_int id} :: rules, id+1))

let interp_compound_rules compound_rules = assign_ids (create_interp_compound_rules (interp_tree ()) compound_rules)

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

module CharTrees = struct

  type t = M of t CharMap.t * rule list

  let empty = M(CharMap.empty,[])

  let rec add_path_rules rule orth_suf i (M(map,rules)) =
    if i = -1 then M(map,rule :: rules) else
    let tree = try CharMap.find map (String.get orth_suf i) with Not_found -> empty in
    let tree = add_path_rules rule orth_suf (i-1) tree in
    M(CharMap.add map (String.get orth_suf i) tree,rules)

  let create_char_tree rules =
    let tree = Xlist.fold rules empty (fun tree rule ->
      add_path_rules rule rule.find (String.length rule.find - 1) tree) in
    tree

  let create rules =
    let prefix_map = Xlist.fold rules StringMap.empty (fun prefix_map rule ->
      StringMap.add_inc prefix_map rule.pref [rule] (fun l -> rule :: l)) in
    StringMap.fold prefix_map [] (fun trees prefix rules -> (prefix, create_char_tree rules) :: trees)

  let rec find_rec l i orth (M(map,rules)) =
    if i = 0 then Xlist.fold rules l (fun l rule -> ("", rule) :: l) else
    let l = try find_rec l (i-1) orth (CharMap.find map (String.get orth (i-1))) with Not_found -> l in
    Xlist.fold rules l (fun l rule -> (String.sub orth 0 i, rule) :: l)

  let find trees orth =
    Xlist.fold trees [] (fun found (pref,tree) ->
      (* print_endline pref; *)
      if Xstring.check_prefix pref orth then (
        let orth = Xstring.cut_prefix pref orth in
        (* printf "%s %d " orth (Xlist.size found); *)
        let found = find_rec found (String.length orth) orth tree in
        (* printf "%d\n%!" (Xlist.size found); *)
        (* Xlist.iter found (fun (stem,rule) -> printf "F %s\t%s\n" stem (string_of_rule rule)); *)
        found)
      else found)

  let add_char c rule =
    let s = String.make 1 c in
    {rule with find=s ^ rule.find; set=s ^ rule.set}

  let rec disjoint_rec super (M(map,rules)) =
    let rules = rules @ super in
    if CharMap.is_empty map then M(map,rules) else
    M(CharMap.mapi map (fun c tree ->
      disjoint_rec (Xlist.rev_map rules (add_char c)) tree),[])

  let disjoint trees =
    Xlist.rev_map trees (fun (pref,tree) ->
      pref, disjoint_rec [] tree)

  let rec print_rules_rec file (M(map,rules)) =
    Xlist.iter rules (print_rule file);
    CharMap.iter map (fun _ tree -> print_rules_rec file tree)

  let print_rules filename trees =
    File.file_out filename (fun file ->
      Xlist.iter trees (fun (_,tree) ->
        print_rules_rec file tree))

end

let compound_rule_trees compound_rules = CharTrees.create compound_rules
let interp_compound_rule_trees interp_compound_rules = CharTrees.create interp_compound_rules

let make_compound_rule_trees = compound_rule_trees

let make_interp_compound_rule_trees compound_rules =
  interp_compound_rule_trees (interp_compound_rules compound_rules)

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

module OrderedRule = struct

  type t = rule

  let compare = compare

end

module RuleQMap = Xmap.MakeQ(OrderedRule)

let string_of_star = function
    Productive -> ""
  | Star -> "*"
  | Ndm -> "ndm"

let string_of_freq_rule rule =
  sprintf "%s\t%d\t%s\t%s\t%s\t%s\t%s" rule.id rule.freq (string_of_star rule.star) rule.pref rule.find rule.set rule.interp

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

let latex_escape_char = function
    "′" -> "$'$"
  | "ʲ" -> "\\textipa{\\super{j}}"
  | "ʒ" -> "\\textipa{Z}"
  | "ǯ" -> "\\textipa{\\v{Z}}"
  | "ε" -> "$\\varepsilon$"
  | c -> c

let latex_escape_string s =
  String.concat "" (Xlist.map (Xunicode.utf8_chars_of_utf8_string s) latex_escape_char)

let latex_of_alternation a =
  (if a.astar = Star then "$\\star$" else "") ^
  latex_escape_string a.afind ^ " $\\rightarrow$ " ^ latex_escape_string a.aset

let make_alternation_line phons alternation =
  let l,map = Xlist.fold phons ([],StringMap.empty) (fun (l,map) phon ->
    if not (StringMap.mem alternation phon) then "" :: l,map else
    let alts = StringMap.find alternation phon in
    latex_of_alternation (List.hd alts) :: l,
    if List.tl alts = [] then map else (StringMap.add map phon (List.tl alts))) in
  String.concat " & " (List.rev l), map

let rec print_alternation name phons map =
  if StringMap.is_empty map then print_endline "\\hline\\\\" else (
  let s,map = make_alternation_line phons map in
  print_endline (latex_escape_string name ^ " & " ^ s ^ "\\\\");
  print_alternation "" phons map)

let make_alternation_line2 alts =
  let l,alts = Xlist.fold alts ([],[]) (fun (l,alts) -> function
      [] -> "" :: l,[] :: alts
    | alt :: a -> latex_of_alternation alt :: l, a :: alts) in
  String.concat " & " (List.rev l), List.rev alts

let rec print_alternation2 name alts =
  if Xlist.fold alts true (fun b -> function [] -> b | _ -> false) then print_endline "\\hline" else (
  let s,alts = make_alternation_line2 alts in
  print_endline (latex_escape_string name ^ " & " ^ s ^ "\\\\");
  print_alternation2 "" alts)

let alt_names = [
  "funkcjonalnie_miekkie_iy","{\\bf y}";
  "funkcjonalnie_miekkie_ae","{\\bf a}";
  "funkcjonalnie_miekkie_wyglos","\\boldmath$\\varepsilon$";
  "funkcjonalnie_twarde_y","{\\bf y}";
  "funkcjonalnie_twarde_e","{\\bf e}";
  "funkcjonalnie_twarde_a","{\\bf a}";
  "funkcjonalnie_twarde_i","{\\bf i}";
  "funkcjonalnie_twarde_ie","{\\bf ie}";
  "funkcjonalnie_twarde_wyglos","\\boldmath$\\varepsilon$";
  "obce_ais","{\\bf }";
  "obce_apostrof","{\\bf }";
  "obce_funkcjonalnie_miekkie_ae","{\\bf }";
  "obce_funkcjonalnie_twarde_iy","{\\bf }";
  "obce_funkcjonalnie_twarde_ie","{\\bf }";
  "obce_funkcjonalnie_twarde_e","{\\bf }";
  "obce_funkcjonalnie_twarde_a","{\\bf }";
  "obce_funkcjonalnie_twarde_i","{\\bf }";
  "obce_funkcjonalnie_twarde_wyglos","{\\bf }";
  "obce_funkcjonalnie_miekkie_iy","{\\bf }";
  "obce_funkcjonalnie_miekkie_wyglos","{\\bf }";
  "obce_eu","{\\bf }";
  "obce_ech","{\\bf }";
  "dowolne","";
  "funkcjonalnie_twarde_ie1","{\\bf ie1}";
  "funkcjonalnie_twarde_ie2","{\\bf ie2}";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  "","{\\bf }";
  ]

let rec print_alternations names phons alternations =
  print_endline ("\\begin{center}\n\\begin{tabular}{r" ^ String.concat "" (Xlist.map phons (fun _ -> "r")) ^ "}");
  print_endline (" & " ^ String.concat " & " (Xlist.map phons latex_escape_string) ^ "\\\\");
  print_endline "\\hline\\\\";
  Xlist.iter names (fun name ->
    let name2 = Xlist.assoc alt_names name in
    let alternation = StringMap.find alternations name in
    let alternation = Xlist.fold alternation StringMap.empty (fun alternation a ->
      StringMap.add_inc alternation a.aphone [a] (fun l -> a :: l)) in
    let alternation = StringMap.map alternation List.rev in
    print_alternation name2 phons alternation);
  print_endline "\\end{tabular}\n\\end{center}\n"

let rec print_alternations2 names phons alternations =
  print_endline ("\\begin{longtable}{r|" ^ String.concat "" (Xlist.map names (fun _ -> "r")) ^ "}");
  print_endline (" & " ^ String.concat " & " (Xlist.map names (fun name ->
    try Xlist.assoc alt_names name with Not_found -> failwith ("print_alternations2: " ^ name))) ^ "\\\\");
  print_endline "\\hline";
  (* print_endline "\\endhead\n\\hline\\\\"; *)
  let alternations = Xlist.map names (fun name ->
    try StringMap.find alternations name with Not_found -> failwith ("print_alternations2: " ^ name)) in
  let alternations = Xlist.map alternations (fun alternation ->
    Xlist.fold alternation StringMap.empty (fun alternation a ->
      StringMap.add_inc alternation a.aphone [a] (fun l -> a :: l))) in
  Xlist.iter phons (fun phon ->
    print_alternation2 phon (Xlist.map alternations (fun a -> try List.rev (StringMap.find a phon) with Not_found -> [])));
  print_endline "\\end{longtable}\n"

let patal_alts = [
  "funkcjonalnie_miekkie_iy";
  "funkcjonalnie_miekkie_ae";
  "funkcjonalnie_miekkie_wyglos";]

let npatal_alts = [
  "funkcjonalnie_twarde_y";
  "funkcjonalnie_twarde_e";
  "funkcjonalnie_twarde_a";
  "funkcjonalnie_twarde_i";
  "funkcjonalnie_twarde_ie";
  "funkcjonalnie_twarde_wyglos";]

let patal_phons = ["b′";"d′";"f′";"m′";"n′";"p′";"s′";"t′";"v′";"z′";"l";"c";"č";"ʒ";"ǯ";"ř";"š";"ž";"ʲ";"j";"g′";"k′";"a";"e"]

let patal_phons1 = ["b′";"d′";"f′";"m′";"n′"]
let patal_phons2 = ["p′";"s′";"t′";"v′";"z′";"l"]
let patal_phons3 = ["c";"č";"ʒ";"ǯ";"ř";"š";"ž"]
let patal_phons4 = ["ʲ";"j";"g′";"k′";"a";"e"]

let npatal_phons = ["b";"x";"d";"f";"h";"ł";"m";"n";"p";"r";"s";"t";"v";"z";"g";"k";"o";"u"]

let npatal_phons1 = ["b";"x";"d";"f";"h";"ł"]
let npatal_phons2 = ["m";"n";"p";"r";"s"]
let npatal_phons3 = ["t";"v";"z";"g";"k";"o";"u"]

let merge_ie alternations =
  let ie1 = StringMap.find alternations "funkcjonalnie_twarde_ie1" in
  let ie2 = StringMap.find alternations "funkcjonalnie_twarde_ie2" in
  let ie = ie1 @ ie2 in
  StringMap.add alternations "funkcjonalnie_twarde_ie" ie

let latex_of_alternations filename =
  let alternations = alternation_map (load_alternations filename) in
  let alternations = merge_ie alternations in
  (* print_alternations patal_alts patal_phons1 alternations;
  print_alternations patal_alts patal_phons2 alternations;
  print_alternations patal_alts patal_phons3 alternations;
  print_alternations patal_alts patal_phons4 alternations;
  print_alternations npatal_alts npatal_phons1 alternations;
  print_alternations npatal_alts npatal_phons2 alternations;
  print_alternations npatal_alts npatal_phons3 alternations; *)
  print_alternations2 patal_alts patal_phons alternations;
  print_alternations2 npatal_alts npatal_phons alternations;
  ()

let latex_math_text s =
  if s = "" then "\\varepsilon" else
  "\\text{" ^ latex_escape_string s ^ "}"

let latex_prepare_tags tags =
  String.concat ", " (List.rev (Xlist.fold tags [] (fun l -> function
    T("cat",v) -> (latex_math_text v) :: l
  | T("patal","t") -> "\\uparrow" :: l
  | T("patal","n") -> "\\downarrow" :: l
  | T("patal","ę") -> l
  | T("patal","anin") -> l
  | T("patal","mię") -> l
  | T("patal","o") -> l
  | T("patal","stwo") -> l
  | T("patal","ni") -> l
  | T("velar","t") -> "\\rightarrow" :: l
  | T("velar","n") -> "\\leftarrow" :: l
  | T(k,v) -> (latex_math_text k ^ ":=" ^ latex_math_text v) :: l
  | A _ -> l)))

let latex_prepare_tags2 tags =
  String.concat ", " (List.rev (Xlist.fold tags [] (fun l -> function
    ("cat",v) -> (latex_escape_string v) :: l
  | ("patal","t") -> "$\\uparrow$" :: l
  | ("patal","n") -> "$\\downarrow$" :: l
  | ("patal","ę") -> l
  | ("patal","anin") -> l
  | ("patal","mię") -> l
  | ("patal","o") -> l
  | ("patal","stwo") -> l
  | ("patal","ni") -> l
  | ("velar","t") -> "$\\rightarrow$" :: l
  | ("velar","n") -> "$\\leftarrow$" :: l
  | (k,v) -> (k ^ ":=" ^ latex_escape_string v) :: l)))

let latex_prepare_rule r =
  (if r.sstar = Star then "\\star" else "") ^
  (latex_math_text (try Xlist.assoc alt_names r.salt_name with Not_found -> print_endline r.salt_name; "???")) ^
  "\\; +" ^ latex_math_text r.ssufix ^ " & " ^ (latex_prepare_tags r.stags)

let latex_prepare_rev_rule r =
  (if r.sstar = Star then "\\star" else "") ^
  (latex_math_text (try Xlist.assoc alt_names r.salt_name with Not_found -> print_endline r.salt_name; "???")) ^
  "\\; -" ^ latex_math_text r.ssufix ^ " & " ^ (latex_prepare_tags r.stags)

let latex_prepare_pref_rule r =
  (if r.pstar = Star then "\\star" else "") ^
  latex_math_text r.pprefix ^ "+ & " ^ (latex_prepare_tags r.ptags)

let latex_prepare_rules prepare_fun rule_map (name,rules) =
  let rules = Xlist.map rules prepare_fun in
  let rules = "\\left[\\begin{array}{ll}\n" ^ String.concat "\\\\\n" rules ^ "\n\\end{array}\\right]" in
  StringMap.add rule_map name rules

let latex_of_schemata () =
  let rule_map = Xlist.fold (rules ()) StringMap.empty (latex_prepare_rules latex_prepare_rule) in
  let rule_map = Xlist.fold (rev_rules ()) rule_map (latex_prepare_rules latex_prepare_rev_rule) in
  let rule_map = Xlist.fold (pref_rules ()) rule_map (latex_prepare_rules latex_prepare_pref_rule) in
  Xlist.iter (schemata ()) (fun schema ->
    print_endline "\\begin{scriptsize}\\[";
    let schema = Xlist.map schema (fun rule_set_name ->
      try StringMap.find rule_map rule_set_name with Not_found -> failwith ("create_compound_rules: " ^ rule_set_name)) in
    print_endline (String.concat " \\otimes " schema);
    print_endline "\\]\\end{scriptsize}\n")

let make_rule_key r =
  let cat = try Xlist.assoc r.tags "cat" with Not_found -> "" in
  let lemma = try Xlist.assoc r.tags "lemma" with Not_found -> "" in
  let group = try Xlist.assoc r.tags "group" with Not_found -> "" in
  let gender =
      match Xstring.split ":" (List.hd (Xstring.split "|" r.interp)) with
        "subst" :: n :: c :: g -> (String.concat ":" g)
      | "depr" :: _ -> "m1"
      | _ -> "" in
  cat ^ " " ^ lemma ^ " " ^ group ^ " " ^ gender, cat

let case_number c =
  match List.hd (Xstring.split "\\." c) with
    "nom" -> 1
  | "gen" -> 2
  | "dat" -> 3
  | "acc" -> 4
  | "inst" -> 5
  | "loc" -> 6
  | "voc" -> 7
  | _ -> failwith "case_number"

let key_of_noun_nc s =
  match Xstring.split ":" s with
    ["sg";c] -> case_number c
  | ["pl";c] -> 7 + case_number c
  | ["depr"] -> 15
  | _ -> failwith "key_of_noun_nc"

let rec get_gender = function
    s :: l ->
      let ll = Xstring.split "|" s in
      (match Xstring.split ":" (List.hd ll) with
        "subst" :: _ :: _ :: g -> String.concat ":" g
      | _ -> get_gender (List.tl ll @ l))
  | [] -> failwith "get_gender"

let latex_of_noun_interp_rules l =
  let cat = Xlist.assoc (List.hd l).tags "cat" in
  let lemma = Xlist.assoc (List.hd l).tags "lemma" in
  let gender = get_gender (Xlist.map l (fun r -> r.interp)) in
  let l = Xlist.map l (fun r -> {r with tags = snd (extract_tag "cat" [] r.tags)}) in
  let l = Xlist.map l (fun r -> {r with tags = snd (extract_tag "lemma" [] r.tags)}) in
  print_endline ("cat=" ^ cat ^ " lemma=" ^ latex_escape_string lemma ^ " gender:=" ^ gender ^ "\\\\");
  let map = Xlist.fold l StringMap.empty (fun map r ->
    StringMap.add_inc map r.interp [r] (fun l -> r :: l)) in
  let l = List.sort compare (StringMap.fold map [] (fun l interp rules ->
    let interp = String.concat "|" (Xlist.map (Xstring.split "|" interp) (fun interp ->
      match Xstring.split ":" interp with
        "subst" :: n :: c :: _ -> n ^ ":" ^ c
      | "depr" :: _ -> "depr"
      | _ -> failwith "latex_of_noun_interp_rules: interp")) in
    let key = key_of_noun_nc (List.hd (Xstring.split "|" interp)) in
    (key, interp, Xlist.map rules (fun r ->
      let flex,tags = extract_tag "flex" [] r.tags in
      let patal,tags = extract_tag "patal" [] tags in
      let velar,tags = extract_tag "velar" [] tags in
      let patal_velar =
        (match patal with
          "t" -> "\\uparrow"
        | "n" -> "\\downarrow"
        | "" -> ""
        | _ -> failwith "latex_of_noun_interp_rules: patal") ^
        (match velar with
          "t" -> "\\rightarrow"
        | "n" -> "\\leftarrow"
        | "" -> ""
        | _ -> failwith "latex_of_noun_interp_rules: velar") in
      if tags <> [] then failwith "latex_of_noun_interp_rules: tags" else
      (if r.star = Star then "$\\star$" else "") ^
      latex_escape_char flex ^
      (if patal_velar = "" then "" else "$" ^ patal_velar ^ "$"))) :: l)) in
  print_endline "\\begin{tabular}{l|l}";
  Xlist.iter l (fun (_,interp,l) ->
    print_endline (interp ^ " & " ^ (String.concat " " l) ^ "\\\\"));
  print_endline "\\end{tabular}\\\\"


let latex_of_interp_rules () =
  let map = Xlist.fold (load_interp_rules "../morphology/data/interp_rules.dic") StringMap.empty (fun map r ->
    let key, cat = make_rule_key r in
    StringMap.add_inc map key (cat,[r]) (fun (_,l) -> cat, r :: l)) in
  StringMap.iter map (fun _ (cat,l) ->
    if cat = "noun" then latex_of_noun_interp_rules l else
    Xlist.iter l (fun r ->
      print_endline ((if r.star = Star then "$\\star$" else "") ^ r.interp ^ " $\\leftarrow$ " ^ (latex_prepare_tags2 r.tags) ^ "\\\\")))