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 WalTypes

let rec token = function
    Text s -> s 
  | Paren l -> "(" ^ String.concat "" (Xlist.map l token) ^ ")"
  | Bracet l -> "{" ^ String.concat "" (Xlist.map l token) ^ "}"
  | SqBra l -> "[" ^ String.concat "" (Xlist.map l token) ^ "]"
  | LParen -> "("
  | RParen -> ")"
  | LBracet -> "{"
  | RBracet -> "}"
  | LSqBra -> "["
  | RSqBra -> "]"
  | Semic -> ";"
  | Plus -> "+"
  | Comma -> ","
  | Quot  -> "'"

let token_list l =
  String.concat "" (Xlist.map l token)
  
let opinion = function
    Pewny -> "pewny"
  | Potoczny -> "potoczny"
  | Watpliwy -> "wątpliwy"
  | Archaiczny -> "archaiczny"
  | Zly -> "zły"
  | Wulgarny -> "wulgarny"
  | Domyslny -> "domyślny"
    
let negation = function
    Negation -> "neg"
  | Aff -> "aff"
  | NegationUndef -> "_"
  | NegationNA -> ""
    
let pred = function
    PredNA -> "" 
  | Pred -> "pred"
    
let aspect = function
    Aspect s -> s
  | AspectUndef -> "_"
  | AspectNA -> ""
    
let case = function
    Case s -> s
  | Str -> "str"
  | Part -> "part"
  | CaseAgr -> "agr"
  | CaseUAgr -> "uagr"
  | NomAgr -> "nomagr"
  | GenAgr -> "genagr"
  | AllAgr -> "allagr"
  | AllUAgr -> "alluagr"
  | CaseUndef -> "_"

let rec comp = function  
    Comp s -> s
  | Zeby -> "żeby2"
  | Gdy -> "gdy"
  | CompUndef -> "_"

let rec comp_type = function
   Int -> "int"
 | Rel -> "rel"
 | Sub -> "sub"
 | Coord -> "coord"
 | CompTypeUndef -> "_"
 | CompTypeAgr -> "agr"
  
let number = function
    Number s -> s
  | NumberAgr -> "agr"
  | NumberUndef -> "_"
   
let gender = function
    Gender s -> s
  | GenderUndef -> "_"
  | GenderAgr -> "agr"
  | Genders l -> String.concat "." l
   
let grad = function
    Grad s -> s
  | GradUndef -> "_"
   
let refl = function
    ReflEmpty -> ""
  | ReflSie -> "się"
  
let acm = function
    Acm s -> s
  | AcmUndef -> "_"
  
let sem = function
    Sem -> "sem"
  | NoSem -> "nosem"
  
(*let req = function     
    Req -> ",req"
  | NReq -> ",nreq"
  | ReqUndef -> ""*)
  
let gf = function
    SUBJ -> "subj"
  | OBJ -> "obj"
  | ARG -> "arg"(*""*)
  | CORE -> "core"
  | NOSEM -> "nosem"
  | NOGF -> "nogf"
  | ADJUNCT -> "adjunct"
  | RAISED -> "raised"
  | CLAUSE -> "clause"
  | SENTENCE -> "sentence"
  
let pos = function
    SUBST(n,c) -> "SUBST(" ^ number n ^ "," ^ case c ^ ")"
  | PREP(c) -> "PREP(" ^ case c ^ ")"
  | NUM(c,g,a) -> "NUM(" ^ case c ^ "," ^ gender g ^ "," ^ acm a ^ ")"
  | ADJ(n,c,g,gr) -> "ADJ(" ^ number n ^ "," ^ case c ^ "," ^ gender g ^ "," ^ grad gr ^ ")"
  | ADV(gr) -> "ADV(" ^ grad gr ^ ")"
  | GER(n,c,g,a,neg,r) -> "GER(" ^ number n ^ "," ^ case c ^ "," ^ gender g ^ "," ^ aspect a ^ "," ^ negation neg ^ "," ^ refl r ^ ")"
  | PACT(n,c,g,a,neg,r) -> "PACT(" ^ number n ^ "," ^ case c ^ "," ^ gender g ^ "," ^ aspect a ^ "," ^ negation neg ^ "," ^ refl r ^ ")"
  | PPAS(n,c,g,a,neg) -> "PPAS(" ^ number n ^ "," ^ case c ^ "," ^ gender g ^ "," ^ aspect a ^ "," ^ negation neg ^ ")"
  | INF(a,n,r) -> "INF(" ^ aspect a ^ "," ^ negation n ^ "," ^ refl r ^ ")"
  | QUB -> "QUB"
  | COMPAR -> "COMPAR"
  | COMP(c) -> "COMP(" ^ comp_type c ^ ")"
  | PERS(n,r) -> "PERS(" ^ negation n ^ "," ^ refl r ^ ")"
   
let phrase = function
    NP c -> "np(" ^ case c ^ ")"
  | PrepNP(s,prep,c) -> "prepnp(" ^ sem s ^ "," ^ prep ^ "," ^ case c ^ ")"
  | AdjP c -> "adjp(" ^ case c ^ ")"
  | PrepAdjP(s,prep,c) -> "prepadjp(" ^ sem s ^ "," ^ prep ^ "," ^ case c ^ ")"
  | NumP(c) -> "nump(" ^ case c ^ ")"
  | PrepNumP(s,prep,c) -> "prepnump(" ^ sem s ^ "," ^ prep ^ "," ^ case c ^ ")"
  | ComprepNP(s,prep) -> "comprepnp(" ^ sem s ^ "," ^ prep ^ ")"
  | ComparNP(s,prep,c) -> "comparnp(" ^ sem s ^ "," ^ prep ^ "," ^ case c ^ ")"
  | ComparPP(s,prep) -> "comparpp(" ^ sem s ^ "," ^ prep ^ ")"
  | IP -> "ip"
  | CP(ct,co) -> "cp(" ^ comp_type ct ^ "," ^ comp co ^ ")"
  | NCP(c,ct,co) -> "ncp(" ^ case c ^ "," ^ comp_type ct ^ "," ^ comp co ^ ")"
  | PrepNCP(s,prep,c,ct,co) -> "prepncp(" ^ sem s ^ "," ^ prep ^ "," ^ case c ^ "," ^ comp_type ct ^ "," ^ comp co ^ ")"
  | InfP(a(*,r*)) -> "infp(" ^ aspect a (*^ req r*) ^ ")"
  | PadvP -> "padvp"
  | AdvP -> "advp"
  | FixedP s -> "fixed(" ^ s ^ ")" 
  | PrepP -> "prepp"
  | Prep(prep,c) -> "prep(" ^ prep ^ "," ^ case c ^ ")"
  | Num(c,a) -> "num(" ^ case c ^ "," ^ acm a ^ ")"
  | Measure(c) -> "measure(" ^ case c ^ ")"
  | Or -> "or"
(*   | Refl -> "refl" *)
(*   | Recip -> "recip" *)
  | Qub -> "qub"
  | Inclusion -> "inclusion"
  | Adja -> "adja"
  | AuxPast -> "aux-past"
  | AuxFut -> "aux-fut"
  | AuxImp -> "aux-imp"
  | Aglt -> "aglt"
  | Pro -> "pro"
  | ProNG -> "prong"
  | Null -> "null"
  | X -> "x"
  | Lex s -> "lex(" ^ s ^ ")"
  
let phrase_abbr = function
    Xp(m) -> "xp(" ^ m ^ ")"
  | Advp(m) -> "advp(" ^ m ^ ")"
  | ComparP prep -> "compar(" ^ prep ^ ")"
  | Nonch -> "nonch"
  | Distrp -> "distrp"
  | Possp -> "possp"
  
let phrase_comp = function
    Cp -> "cp"
  | Ncp(c) -> "ncp(" ^ case c ^ ")"
  | Prepncp(prep,c) -> "prepncp(" ^ prep ^ "," ^ case c ^ ")"
  
let rec lex = function
    Lexeme s -> "'" ^ s ^ "'"
  | ORconcat l -> "OR(" ^ String.concat "," (Xlist.map l lex) ^ ")"
  | ORcoord l -> "OR(" ^ String.concat ";" (Xlist.map l lex) ^ ")"
  | XOR l -> "XOR(" ^ String.concat "," (Xlist.map l lex) ^ ")"
  | Elexeme g -> "'E(" ^ gender g ^ ")"
  
let restr = function  
    Natr -> "natr"
  | Atr -> "atr"
  | Ratr -> "ratr"
  | Ratrs -> "ratrs"
  | Atr1 -> "atr1"
  | Ratr1 -> "ratr1"
(*  | Ratr1,s -> "ratr1(" ^ schema s ^ ")"
  | Atr1,s -> "atr1(" ^ schema s ^ ")"
  | Ratr,s -> "ratr(" ^ schema s ^ ")"
  | Atr,s -> "atr(" ^ schema s ^ ")"
  | Ratrs,s -> "ratrs(" ^ schema s ^ ")"
 *) | NoRestr -> ""
(*   | NoRestr,s -> schema s *)
    
let controllers l =
  Xlist.map l (function
      "1" -> "controller"
    | n -> "controller" ^ n)
    
let controllees l =
  Xlist.map l (function
      "1" -> "controllee"
    | n -> "controllee" ^ n)

(*let lex_specs = function     
    NSpecs num -> number num
  | AdvSpecs gr -> grad gr
  | AdjSpecs(num,g,gr) -> number num ^ "," ^ gender g ^ "," ^ grad gr
  | PpasSpecs(num,g,neg) -> number num ^ "," ^ gender g ^ "," ^ negation neg
  | PactSpecs(num,g,neg,r) -> number num ^ "," ^ gender g ^ "," ^ negation neg ^ "," ^ refl r
  | GerSpecs(num,neg,r) -> number num ^ "," ^ negation neg ^ "," ^ refl r
  | CSpecs(neg,r) -> negation neg ^ "," ^ refl r
  | NumSpecs g -> gender g
  | EmptySpecs -> ""*)
       
let mood = function
    (*Mood*) s -> s
  (*| MoodUndef -> "_"*)
  
let tense t = t

let aux = function
    NoAux -> "-"
  | PastAux -> "aux-past"
  | FutAux -> "aux-fut"
  | ImpAux -> "aux-imp"
  
let nsem = function
    Common s -> s
  | Time -> "time"
      
let direction = function
    Forward -> "/"
  | Backward  -> "\\"
  | Both -> "|"

let rec schema schema = 
  String.concat "+" (Xlist.map schema (fun s -> 
    String.concat "," (
      (if s.gf = ARG then [] else [gf s.gf])@
      (if s.role = "" then [] else [s.role])@
      (if s.role_attr = "" then [] else [s.role_attr])@
      s.sel_prefs@(controllers s.cr)@(controllees s.ce)) ^ direction s.dir ^ "{" ^  String.concat ";" (Xlist.map s.morfs morf) ^ "}"))   

(*and schema_role schema = 
  String.concat "+" (Xlist.map schema (fun (r,role,cr,ce,morfs) -> 
    String.concat "," ((if r = "" then [] else [r])@(if role = "" then [] else [role])@(controllers cr)@(controllees ce)) ^ "{" ^  String.concat ";" (Xlist.map morfs morf) ^ "}"))   *)

and morf = function 
    Phrase p -> phrase p
  | E p -> "E(" ^ phrase p ^ ")"
  | LexPhrase(pos_lex,(r,s)) -> "lex([" ^ String.concat ";" (Xlist.map pos_lex (fun (p,le) -> pos p ^ "," ^ lex le)) ^ "]," ^ restr r ^ "[" ^ schema s ^ "])"
  | LexPhraseMode(m,pos_lex,(r,s)) -> "lex([" ^ m ^ "," ^ String.concat ";" (Xlist.map pos_lex (fun (p,le) -> pos p ^ "," ^ lex le)) ^ "]," ^ restr r ^ "[" ^ schema s ^ "])"
  | PhraseAbbr(p,ml) -> phrase_abbr p ^ "[" ^ String.concat ";" (Xlist.map ml morf) ^ "]"
  | PhraseComp(p,(ct,l)) -> phrase_comp p ^ "," ^ comp_type ct ^ "[" ^ String.concat ";" (Xlist.map l comp) ^ "]"
  | LexPhraseId(id,p,le) -> "lex(" ^ id ^ "," ^ pos p ^ "," ^ lex le ^ ")"
  | LexArg(id,p,le) -> "lex(" ^ id ^ "," ^ pos p ^ "," ^ le ^ ")"
(*  | LexRealization(mrf,le) -> "lex(" ^ morf mrf ^ "," ^ le ^ ")"*)
  | Raised(mrf1,dir,mrf2) -> "raised([" ^ String.concat ";" mrf1 ^ "]," ^ direction dir ^ "[" ^ String.concat ";" mrf2 ^ "])"
  | Multi l -> "multi(" ^ String.concat ";" (Xlist.map l phrase) ^ ")"
 
(*and mode = function
    Mode(s,[]) -> s
  | Mode(s,l) -> s ^ "[" ^ "..."(*String.concat ";" (Xlist.map l morf)*) ^ "]"
(*   | Mod l -> "mod[...]"  *)
  | Pron [] -> "pron"
  | Pron l -> "pron" ^ "[" ^ "..."(*String.concat ";" (Xlist.map l morf)*) ^ "]"
  | Misc -> "misc"*)

let frame_atrs = function
    DefaultAtrs(m,r,o,neg,p,a) -> Printf.sprintf "%s: %s: %s: %s: %s: %s" (String.concat "; " m) (refl r) (opinion o) (negation neg) (pred p) (aspect a)
  | EmptyAtrs m -> Printf.sprintf "%s" (String.concat "; " m)
  | NounAtrs(m,nsyn,s(*,typ*)) -> Printf.sprintf "%s: %s: %s" (String.concat "; " m) nsyn (nsem s) (*(String.concat ";" typ)*)
  | AdjAtrs(m,c,adjsyn(*,adjsem,typ*)) -> Printf.sprintf "%s: %s: %s" (String.concat "; " m) (case c) adjsyn (*adjsem (String.concat ";" typ)*)
  | PersAtrs(m,le,neg,mo,t,au,a) -> Printf.sprintf "%s: %s: %s: %s: %s: %s: %s" (String.concat "; " m) le (negation neg) (mood mo) (tense t) (aux au) (aspect a)
  | GerAtrs(m,le,neg,a) -> Printf.sprintf "%s: %s: %s: %s" (String.concat "; " m) le (negation neg) (aspect a)
  | NonPersAtrs(m,le,role,role_attr,neg,a) -> Printf.sprintf "%s: %s: %s,%s: %s: %s" (String.concat "; " m) le role role_attr (negation neg) (aspect a)
  | _ -> failwith "WalStringOf.frame_atrs"
  
let frame lexeme = function
    Frame(atrs,s) -> 
      Printf.sprintf "%s: %s: %s" lexeme (frame_atrs atrs) (schema s)
  | LexFrame(id,p,r,s) -> 
      Printf.sprintf "%s: %s: %s: %s: %s" lexeme id (pos p) (restr r) (schema s)
  | ComprepFrame(le,p,r,s) -> 
      Printf.sprintf "%s: %s: %s: %s: %s" lexeme le (pos p) (restr r) (schema s)
(*  | FrameR(atrs,s) -> 
      Printf.sprintf "%s: %s: %s" lexeme (frame_atrs atrs) (schema_role s)
  | LexFrameR(id,p,r,s) -> 
      Printf.sprintf "%s: %s: %s: %s: %s" lexeme id (pos p) (restr r) (schema_role s)
  | ComprepFrameR(le,p,r,s) -> 
      Printf.sprintf "%s: %s: %s: %s: %s" lexeme le (pos p) (restr r) (schema_role s)*)
(*   | _ -> failwith "WalStringOf.frame" *)

let fnum_frame lexeme = function
    fnum,Frame(atrs,s) -> 
      Printf.sprintf "%d: %s: %s: %s" fnum lexeme (frame_atrs atrs) (schema s)
  | fnum,LexFrame(id,p,r,s) -> 
      Printf.sprintf "%d: %s: %s: %s: %s: %s" fnum lexeme id (pos p) (restr r) (schema s)
  | fnum,ComprepFrame(le,p,r,s) -> 
      Printf.sprintf "%d: %s: %s: %s: %s: %s" fnum lexeme le (pos p) (restr r) (schema s)
      
let unparsed_frame lexeme (r,o,neg,p,a,s) = lexeme ^ " " ^ String.concat ": " [r;o;neg;p;a;s]