resource ResCze = ParamX ** open Prelude in {

-- AR March 2020
-- sources:
-- Wiki = https://en.wikipedia.org/wiki/Czech_declension, https://en.wikipedia.org/wiki/Czech_conjugation
-- CEG  = J. Naughton, Czech: an Essential Grammar, Routledge 2005.

-- parameters

param
  Animacy = Anim | Inanim ;
  Gender = Masc Animacy | Fem | Neutr ;

  Case = Nom | Gen | Dat | Acc | Voc | Loc | Ins ; -- traditional order

  Agr = Ag Gender Number Person | AgPol Gender | AgQuant Gender ; -- polite singular: plural verb, singular predicate

oper
  agrGender : Agr -> Gender = \a -> case a of {
    Ag g _ _ => g ; AgPol g => g ; AgQuant g => g
    } ;

  agrNumber : Agr -> Number = \a -> case a of {
    Ag _ n _ => n ; AgPol _ => Sg ; AgQuant _ => Pl
    } ;

  agrPerson : Agr -> Person = \a -> case a of {
    Ag _ _ p => p ; _ => P3
    } ;


-- phonology
  hardConsonant    : pattern Str = #("d"|"t"|"g"|"h"|"k"|"n"|"r") ;
  softConsonant    : pattern Str = #("ť"|"ď"|"j"|"ň"|"ř"|"š"|"c"|"č"|"ž") ;
  neutralConsonant : pattern Str = #("b"|"f"|"l"|"m"|"p"|"s"|"v") ;

-- neutral consonants take the hard endings by default (hrad, pán), and so do
-- the foreign "z" and "x"; this is the class to test when choosing a paradigm
  hardishConsonant : pattern Str =
    #("d"|"t"|"g"|"h"|"k"|"n"|"r" | "b"|"f"|"l"|"m"|"p"|"s"|"v" | "z"|"x") ;

  consonant : pattern Str =
    #(
      "d" | "t" | "g" | "h" | "k" | "n" | "r" |
      "ť" | "ď" | "j" | "ň" | "ř" | "š" | "c" | "č" | "ž" |
      "b" | "f" | "l" | "m" | "p" | "s" | "v"
      ) ;

  dropFleetingE : Str -> Str = \s -> case s of {
    x + "e" + c@("k"|"c"|"n") => x + c ;
    x + "e" + "ň" => x + "n" ;
    _ => s
    } ;

  shortenVowel : Str -> Str = \s -> case s of {
    x + "á" + y => x + "a" + y ;
    x + "é" + y => x + "e" + y ;
    x + "í" + y => x + "i" + y ;
    x + "ý" + y => x + "y" + y ;
    x + "ó" + y => x + "o" + y ;
    x + "ú" + y => x + "u" + y ;
    x + "ů" + y => x + "o" + y ;
    _ => s
    } ;

  addI : Str -> Str = \s -> case s of {
    klu + "k"  => klu + "ci" ;
    vra + "h"  => vra + "zi" ;
    ce  + "ch" => ce  + "ši" ;
    dokto + "r" => dokto + "ři" ;
    pan => pan + "i"
    } ;

  addAdjI : Str -> Str = \s -> case s of {
    angli + "ck"  => angli + "čtí" ;
    ce    + "sk"  => ce    + "ští" ;
    _ => init (addI s) + "í"
    } ;

  -- Before i/í/ě the vowel letter carries the dental's palatalization.
  dentalStem : Str -> Str = \s -> case s of {
    stem + "ň" => stem + "n" ; stem + "ť" => stem + "t" ;
    stem + "ď" => stem + "d" ; _ => s
    } ;

  -- The žena ending is spelled i after a soft consonant, otherwise y.
  addY : Str -> Str = \s -> case s of {
    _ + #softConsonant => dentalStem s + "i" ; _ => s + "y"
    } ;

  -- 3.4.10, in particular when also final 'a' is dropped
  addE : Str -> Str = \s -> case s of {
    re + "k"   => re + "ce" ;
    pra + ("g"|"h") => pra + "ze" ;
    stre + "ch" => stre  + "še" ;
    sest + "r" => sest + "ře" ;
    stem + "l" => stem + "le" ;
    stem + "z" => stem + "ze" ;
    stem + "s" => stem + "se" ;
    _ + ("ň"|"ť"|"ď") => dentalStem s + "ě" ;
    _ + #softConsonant => s + "e" ;
    pan => pan + "ě"
    } ;

  addEch : Str -> Str = \s -> case s of {
    klu + "k" => klu + "cich" ;
    vra + ("h"|"g") => vra + "zich" ;
    ce  + "ch" => ce + "šich" ;
    pan => pan + "ech"
    } ;

  shortFemPlGen : Str -> Str = \s -> case s of {
    ul  + "ice" => ul + "ic" ;
    koleg + "yně" => koleg + "yň" ;
    ruz + "e" => ruz + "í" ;
    _ => "" + s  -- Predef.error ("shortFemPlGen does not apply to" ++ s)
    } ;

---------------
-- Nouns
---------------

-- novel idea (for RGL): lexical items stored as records rather than tables
-- advantages:
-- - easier to make exceptions to paradigms (by ** {})
-- - easier to keep the number of forms minimal
-- - easier to see what is happening than with lots of anonymous arguments to mkN, mkA, mkV

-- so this is the lincat of N

  NounForms : Type = {snom,sgen,sdat,sacc,svoc,sloc,sins, pnom,pgen,pdat,pacc,ploc,pins : Str ; g,gPl : Gender} ;

-- But traditional tables make agreement easier to handle in syntax
-- so this is the lincat of CN

  Noun : Type = {s : Number => Case => Str ; g,gPl : Gender} ;

-- this is used in UseN

  nounFormsNoun : NounForms -> Noun
    = \forms -> {
      s = table {
        Sg => table {
	  Nom => forms.snom ;
	  Gen => forms.sgen ;
	  Dat => forms.sdat ;
	  Acc => forms.sacc ;
	  Voc => forms.svoc ;
	  Loc => forms.sloc ;
	  Ins => forms.sins
	  } ;
        Pl => table {
	  Nom | Voc => forms.pnom ;
	  Gen => forms.pgen ;
	  Dat => forms.pdat ;
	  Acc => forms.pacc ;
	  Loc => forms.ploc ;
	  Ins => forms.pins
	  }
	} ;
      g = forms.g ; gPl = forms.gPl
      } ;

-- terminology of CEG
  DeclensionType : Type = Str -> NounForms ;

  declensionNounForms : (nom,gen : Str) -> Gender -> NounForms
    = \nom,gen,g ->
-- the oblique stem, for the paradigms that cannot derive it from the nominative
    let stem : Str = Predef.tk 1 gen ;
        decl : DeclensionType = case <g, nom, gen> of {
      <Masc Anim,   _ + "tel"         , _ + "e"> => declMUZstem stem ;
      <Masc Anim,   _ + "ce"          , _ + "e"> => declSOUDCE ;
      <Masc Anim,   _ + ("us"|"os")   , _ + "a"> => declLATINUSA ;
      <Masc Anim,   _ + "a"           , _ + "a"> => declPREDSEDA ;
      <Masc Anim,   _ + (#softConsonant|#hardishConsonant), _ + ("e"|"ě")> => declMUZstem stem ;
      <Masc Anim,   _ + #hardishConsonant, _ + "a"> => declPAN ;
      <Masc Inanim, _ + ("us"|"os")   , _ + "u"> => declLATINUS ;
      <Masc Inanim, _ + "ý"           , _ + "ého"> => declADJM ;
      <Masc Inanim, _ + (#softConsonant|#hardishConsonant), _ + ("e"|"ě")> => declSTROJ ;
      <Masc Inanim, _ + #hardishConsonant, _ + "u"> => declHRADstem stem ;
      <Masc Inanim, _ + #hardishConsonant, _ + "a"> => declHRADAstem stem ;
      <Fem,         _ + "a"           , _ + "y"> => declZENA ;
      <Fem,         _ + "á"           , _ + "é"> => declADJF ;
      <Fem,         _ + ("e"|"ě")     , _ + ("e"|"ě")> => declRUZE ;
      <Fem,         _ + (#softConsonant|#hardishConsonant), _ + "i"> => declKOST ;  --- also many other "st" 3.6.3
      <Fem,         _ + (#softConsonant|#hardishConsonant), _ + ("e"|"ě")> => declPISEN ;
      <Neutr,       _ + "um"          , _ + "a"> => declLATINUM ;
      <Neutr,       _ + "ma"          , _ + ("matu"|"mata")> => declGREEKMA ;
      <Neutr,       _ + "o"           , _ + "a"> => declMESTO ;
      <Neutr,       _ + "e"           , _+"ete"> => declKURE ;
      <Neutr,       _ + "í"           , _ + "í"> => declSTAVENI ;
      <Neutr,       _ + ("e"|"ě")     , _ + ("e"|"ě")> => declMORE ;
      <Masc Inanim, _ + ("é"|"i"|"y"|"e"), _ + ("é"|"i"|"y"|"e")> => declINVAR (Masc Inanim) ;
      <Neutr,       _ + ("é"|"i"|"y")  , _ + ("é"|"i"|"y")> => declINVAR Neutr ;
      _ => (\s -> declSTROJ ("" + s)) -- Predef.error ("cannot infer declension type for" ++ nom ++ gen)
      }
    in decl nom ;

-- the "smartest" one-argument mkN

  guessNounForms : Str -> NounForms
    = \s -> case s of {
      _ + "ost"          => declKOST s ;
      _ + "tel"          => declMUZ s ;
      _ + "us"           => declLATINUS s ;
      _ + "um"           => declLATINUM s ;
      _ + #hardishConsonant => declHRAD s ;
      _ + #softConsonant => declSTROJ s ;
      _ + "a"            => declZENA s ;
      _ + "o"            => declMESTO s ;
      _ + "ce"           => declSOUDCE s ;
      _ + ("e"|"ě")      => declMORE s ;
      _ + "í"            => declSTAVENI s ;
      _ => declSTROJ ("" + s) -- Predef.error ("cannot guess declension type for" ++ s)
      } ;

-- the traditional declensions, in both CEG and Wiki
-- they are also exported in ParadigmsCze with names panN etc

  declPAN : DeclensionType = \pan ->  --- plural nom ové|i|é can be changed with ** {pnom = ...} CEG 3.5.1
    {
      snom      = pan ;
      sgen,sacc = pan + "a" ;
      sdat,sloc = pan + "ovi" ; --- pánu
      svoc      = shortenVowel pan + "e" ; --- "irregular shortening" 3.5.1
      sins      = pan + "em" ;

      pnom      = addI pan ;       -- pani, kluk-kluci --- panové, host-hosté
      pgen      = pan + "ů" ;
      pdat      = pan + "ům" ;
      pacc,pins = pan + "y" ;
      ploc      = addEch pan ;
      g,gPl = Masc Anim
      } ;

  declPREDSEDA : DeclensionType = \predseda -> --- 3.5.4: sgen y/i
    let predsed = init predseda
    in
    {
      snom      = predseda ;
      sgen      = predsed + "y" ; -- pacc,pins --- i
      sdat,sloc = predsed + "ovi" ;
      sacc      = predsed + "u" ;
      svoc      = predsed + "o" ;
      sins      = predsed + "ou" ;

      pnom      = case predseda of {
        tur + "ista" => tur + "isté" ;
        _ => predsed + "ové"
	} ;
      pgen      = predsed + "ů" ;
      pdat      = predsed + "ům" ;
      pacc,pins = predsed + "y" ;
      ploc      = addEch predsed ;
      g,gPl = Masc Anim
      } ;

-- the oblique stem is a separate argument, because it cannot always be
-- derived from the nominative: uzel-uzlu but člen-členu
  declHRADstem : Str -> DeclensionType = \hrd,hrad ->
    {
      snom,sacc = hrad ;
      sgen,sdat = hrd + "u" ; --- Berlín-a
      sloc      = hrd + "u" ; --- addE hrad ;  -- stůl-stole
      svoc      = hrd + "e" ;
      sins      = hrd + "em" ;

      pnom,pacc,pins = hrd + "y" ;
      pgen           = hrd + "ů" ;
      pdat           = hrd + "ům" ;
      ploc           = addEch hrd ;
      g,gPl = Masc Inanim
      } ;

  declHRAD : DeclensionType = \hrad -> --- 3.5.2: sloc u/ě/e  extra arg, sport-u, hrad-ě ; sgen u/a
    declHRADstem (dropFleetingE hrad) hrad ;

  declZENA : DeclensionType = \zena -> --- 3.6.1 sge y/i ; pgen sometimes shortening
    let zen = init zena
    in
    {
      snom      = zena ;
      sgen      = addY zen ;
      sdat,sloc = addE zen ;
      sacc      = zen + "u" ;
      svoc      = shortenVowel zen + "o" ; ---- shorten ?
      sins      = zen + "ou" ;

      pnom,pacc = addY zen ;
      pgen      = zen ; --- sometimes with vowel shortening
      pdat      = zen + "ám" ;
      ploc      = zen + "ách" ;
      pins      = zen + "ami" ;
      g,gPl = Fem
      } ;

  declMESTO : DeclensionType = \mesto -> --- 3.7.1 sloc u/e ; pgen vowel shortening sometimes ; ploc variations
    let mest = init mesto
    in
    {
      snom,sacc,svoc = mesto ;
      sgen      = mest + "a" ;
      sdat      = mest + "u" ;
      sloc      = mest + "u" ; --- "ě"
      sins      = mest + "em" ;

      pnom,pacc = mest + "a" ;
      pgen      = mest ;  --- léta - let
      pdat      = mest + "ům" ;
      ploc      = mest + "ech" ; --- with variations
      pins      = mest + "y" ;
      g,gPl = Neutr
      } ;

-- Latin masculines in -us: the ending is dropped outside the nominative
-- (algoritmus - algoritmu), otherwise they follow hrad
  declLATINUS : DeclensionType = \algoritmus ->
    let algoritm = Predef.tk 2 algoritmus
    in declHRAD algoritm ** {
      snom, sacc = algoritmus ;
      svoc       = algoritm + "e"
      } ;

  declLATINUSA : DeclensionType = \genius ->
    declLATINUS genius ** {g,gPl = Masc Anim} ;

-- Latin neuters in -um: the ending is dropped outside the nominative
-- (kontinuum - kontinua), otherwise they follow město
  declLATINUM : DeclensionType = \kompaktum ->
    let kompakt = Predef.tk 2 kompaktum
    in declMESTO (kompakt + "o") ** {
      snom, sacc, svoc = kompaktum
      } ;

-- Greek neuters in -ma, with the stem extended by -t- (schéma - schématu)
  declGREEKMA : DeclensionType = \schema ->
    let schemat = schema + "t"
    in {
      snom,sacc,svoc = schema ;
      sgen,sdat,sloc = schemat + "u" ;
      sins           = schemat + "em" ;

      pnom,pacc = schemat + "a" ;
      pgen      = schemat ;
      pdat      = schemat + "ům" ;
      ploc      = schemat + "ech" ;
      pins      = schemat + "y" ;
      g,gPl = Neutr
      } ;

-- the hrad type with genitive -a instead of -u (les - lesa, zákon - zákona)
  declHRADAstem : Str -> DeclensionType = \les_,les ->
    declHRADstem les_ les ** {sgen = les_ + "a"} ;

  declHRADA : DeclensionType = \les ->
    declHRADAstem (dropFleetingE les) les ;

-- nouns that are adjectives in form: proměnná - proměnné, nultý - nultého
  declADJF : DeclensionType = \promenna ->
    let a = mladyAdjForms (init promenna + "ý")
    in {
      snom,svoc = a.fsnom ;
      sgen      = a.fsgen ;
      sdat,sloc = a.fsdat ;
      sacc      = a.fsacc ;
      sins      = a.fsins ;
      pnom,pacc = a.fpnom ;
      pgen,ploc = a.pgen ;
      pdat      = a.msins ;
      pins      = a.pins ;
      g,gPl = Fem
      } ;

  declADJM : DeclensionType = \nulty ->
    let a = mladyAdjForms nulty
    in {
      snom,sacc,svoc = a.msnom ;
      sgen      = a.msgen ;
      sdat      = a.msdat ;
      sloc      = a.msloc ;
      sins      = a.msins ;
      pnom,pacc = a.fpnom ;
      pgen,ploc = a.pgen ;
      pdat      = a.msins ;
      pins      = a.pins ;
      g,gPl = Masc Inanim
      } ;

-- indeclinable loans: bombé, tamari, software
  declINVAR : Gender -> DeclensionType = \g,s -> {
    snom,sgen,sdat,sacc,svoc,sloc,sins = s ;
    pnom,pgen,pdat,pacc,ploc,pins      = s ;
    g,gPl = g
    } ;

  declMUZ : DeclensionType = \muz_ -> --- 3.5.3 : sdat,sloc ; pnom
    declMUZstem (dropFleetingE muz_) muz_ ;

  declMUZstem : Str -> DeclensionType = \muz,muz_ ->
    {
      snom      = muz_ ;
      sgen,sacc = muz + "e" ;   --- pacc
      sdat,sloc = muz + "i" ;   --- muzovi
      svoc      = case muz_ of {
        chlap + "ec" => chlap + "če" ;
        _ => muz + "i"
	} ;
      sins      = muz + "em" ;

      pnom = case muz_ of {
        uci + "tel" => uci + "telé" ;
        _ => muz + "i"  --- muzové
	} ;
      pgen = muz + "ů" ;
      pacc = muz + "e" ;
      pdat = muz + "ům" ;
      ploc = muz + "ích" ;
      pins = muz + "i" ;
      g,gPl = Masc Anim
      } ;

  declSOUDCE : DeclensionType = \soudce ->   --- 3.5.3: sdat/sloc i,ovi ; pnom i/ové
    let soudc = init soudce
    in
    {
      snom,sgen,sacc,svoc = soudce ;      ---- pacc
      sdat,sloc           = soudc + "i" ; --- soudcovi
      sins                = soudc + "em" ;

      pnom                = soudc + "i" ; --- soudcové
      pgen                = soudc + "ů" ;
      pdat                = soudc + "ům" ;
      pacc                = soudce ;
      ploc                = soudc + "ích" ;
      pins                = soudc + "i" ;
      g,gPl = Masc Anim
      } ;

  declSTROJ : DeclensionType = \stroj ->
    {
      snom,sacc      = stroj ;
      sgen           = stroj + "e" ; --- pnom,pacc
      sdat,svoc,sloc = stroj + "i" ; --- pins ---- svoc shorten?
      sins           = stroj + "em" ;

      pnom,pacc      = stroj + "e" ;
      pgen           = stroj + "ů" ;
      pdat           = stroj + "ům" ;
      ploc           = stroj + "ích" ;
      pins           = stroj + "i" ;
      g,gPl = Masc Inanim
      } ;

  declRUZE : DeclensionType = \ruze -> --- 3.6.2: pgen ulice-ulic, chvile-cvil
    let ruz = init ruze
    in
    {
      snom,sgen,svoc      = ruze ; --- pnom,pacc
      sdat,sacc,sloc = ruz + "i" ;
      sins = ruz + "í" ;

      pnom,pacc = ruze ;
      pgen      = shortFemPlGen ruze ;
      pdat      = ruz + "ím" ;
      ploc      = ruz + "ích" ;
      pins      = ruz + "emi" ;
      g,gPl = Fem
      } ;

  declPISEN : DeclensionType = \pisen ->
    let pisn = dentalStem (dropFleetingE pisen)
    in
    {
      snom,sacc      = pisen ;
      sgen           = pisn + "ě" ;
      sdat,svoc,sloc = pisn + "i" ; -- not shortened
      sins           = pisn + "í" ;

      pnom,pacc      = pisn + "ě" ;
      pgen           = pisn + "í" ;
      pdat           = pisn + "ím" ;
      ploc           = pisn + "ích" ;
      pins           = pisn + "ěmi" ;
      g,gPl = Fem
      } ;

  declKOST : DeclensionType = \kost ->
    let stem = dentalStem kost
    in
    {
      snom,sacc           = kost ;
      sgen,sdat,svoc,sloc = stem + "i" ; --- pnom,pacc
      sins                = stem + "í" ; --- pgen

      pnom,pacc      = stem + "i" ;
      pgen           = stem + "í" ;
      pdat           = stem + "em" ;
      ploc           = stem + "ech" ;
      pins           = kost + "mi" ;
      g,gPl = Fem
      } ;

  declKURE : DeclensionType = \kure ->
    let kur = init kure
    in
    {
      snom,sacc,svoc = kure ;
      sgen           = kur  + "ete" ;
      sdat,sloc      = kur  + "eti" ;
      sins           = kur  + "etem" ;

      pnom,pacc = kur + "ata" ;
      pgen      = kur + "at" ;
      pdat      = kur + "atům" ;
      ploc      = kur + "atech" ;
      pins      = kur + "aty" ;
      g,gPl = Neutr
      } ;

  declMORE : DeclensionType = \more -> --- 3.7.2 pgen zero sometimes
    let mor = init more
    in
    {
      snom,sgen,sacc,svoc = more ;      --- pnom
      sdat,sloc           = mor + "i" ; --- pins
      sins                = mor + "em" ;

      pnom,pacc = more ;
      pgen      = mor + "í" ;  ---
      pdat      = mor + "ím" ;
      ploc      = mor + "ích" ;
      pins      = mor + "i" ;
      g,gPl = Neutr
      } ;

  declSTAVENI : DeclensionType = \staveni ->
    {
      snom,sgen,sdat,sacc,svoc,sloc = staveni ;
      sins                          = staveni + "m" ;

      pnom,pgen,pacc = staveni ;
      pdat           = staveni + "m" ;
      ploc           = staveni + "ch" ;
      pins           = staveni + "mi" ;
      g,gPl = Neutr
      } ;

---------------------------
-- Adjectives

-- to be used for AP: 56 forms for each degree
  Adjective : Type = {s : Gender => Number => Case => Str} ;

  -- Long predicates agree with the counted noun; short predicates instead
  -- use neuter singular with a quantified subject.
  longPredicate : Adjective -> Agr => Str = \ap -> \\a => case a of {
    Ag g n _ => ap.s ! g ! n ! Nom ;
    AgPol g => ap.s ! g ! Sg ! Nom ;
    AgQuant g => ap.s ! g ! Pl ! Gen
    } ;
  shortPredicate : Adjective -> Agr => Str = \ap -> \\a => case a of {
    AgQuant _ => ap.s ! Neutr ! Sg ! Nom ;
    _ => longPredicate ap ! a
    } ;

-- to be used for A, in three degrees: 15 forms in each
  DegreeForms : Type = AdjForms ** {compar,superl : AdjForms} ;

  positiveAdj : AdjForms -> DegreeForms = \a -> a ** {
    compar,superl = invarAdjForms nonExist
    } ;

  AdjForms : Type = {
    msnom, fsnom, nsnom : Str ; -- svoc = snom
    msgen, fsgen : Str ;        -- nsgen = msgen, pacc = fsgen
    msdat, fsdat : Str ;        -- nsdat = msdat
    fsacc : Str ;               -- amsacc = msgen, imsacc = msnom, nsacc = nsnom
    msloc : Str ;               -- fsloc = fsdat, nsloc = msloc
    msins, fsins : Str ;        -- nsins = msins, pdat = msins

    mpnom,fpnom : Str ;         -- pvoc = pnom, impnom = fpnom, npnom = fsnom
    pgen : Str ;                -- ploc = pgen
    pins : Str ;
    } ;

invarAdjForms : Str -> AdjForms = \s -> {
    msnom, fsnom, nsnom, msgen, fsgen, msdat, fsdat, fsacc,
    msloc, msins, fsins, mpnom, fpnom, pgen, pins = s ;
    } ;

-- used in PositA but will also work in Compar and Superl by calling their record fields

adjFormsAdjective : AdjForms -> Adjective = \afs -> {
  s = \\g,n,c => case <n,c,g> of {

    <Sg, Nom|Voc, Masc _>
      | <Sg, Acc, Masc Inanim>   => afs.msnom ;
    <Sg, Nom|Voc, Fem>
      | <Pl, Nom|Acc|Voc, Neutr> => afs.fsnom ;
    <Sg, Nom|Acc|Voc, Neutr>     => afs.nsnom ;

    <Sg, Gen, Masc _ | Neutr>
      | <Sg,Acc,Masc Anim>     => afs.msgen ;
    <Sg, Gen, Fem>
      | <Pl,Acc,Masc _|Fem>    => afs.fsgen ;

    <Sg, Dat, Masc _|Neutr>    => afs.msdat ;
    <Sg, Dat|Loc, Fem>         => afs.fsdat ;

    <Sg, Acc, Fem>             => afs.fsacc ;

    <Sg, Loc, Masc _|Neutr>    => afs.msloc ;

    <Sg, Ins, Masc _|Neutr>
      | <Pl,Dat,_>             => afs.msins ;
    <Sg, Ins, Fem>             => afs.fsins ;

    <Pl, Nom|Voc, Masc Anim>       => afs.mpnom ;
    <Pl, Nom|Voc, Masc Inanim|Fem> => afs.fpnom ;

    <Pl, Gen|Loc,_> => afs.pgen ;
    <Pl, Ins,_>     => afs.pins
    }

    } ;

  -- Regular comparison plus common lexical exceptions. Spelling cannot
  -- determine semantic gradability or every stem alternation: callers can
  -- supply a comparative or nonExist explicitly.
  guessComparative : Str -> Str = \s -> case s of {
    "dobrý" => "lepší" ; "špatný" | "zlý" => "horší" ;
    "malý" => "menší" ; "velký" => "větší" ; "dlouhý" => "delší" ;
    "mladý" => "mladší" ; "starý" => "starší" ;
    "chudý" => "chudší" ; "tvrdý" => "tvrdší" ; "bledý" => "bledší" ;
    "bílý" => "bělejší" ; "hnědý" => "hnědší" ; "hezký" => "hezčí" ;
    stem + "cký" => stem + "čtější" ;
    stem + "ský" => stem + "štější" ;
    stem + ("ný" | "ní") => stem + "nější" ;
    stem + "lý" => stem + "lejší" ;
    stem + "rý" => stem + "řejší" ;
    stem + "vý" => stem + "vější" ;
    stem + "dý" => stem + "dější" ;
    stem + "tý" => stem + "tější" ;
    stem + "pý" => stem + "pější" ;
    stem + "bý" => stem + "bější" ;
    stem + "mý" => stem + "mější" ;
    stem + "zí" => stem + "zejší" ;
    stem + "ží" => stem + "žejší" ;
    _ => nonExist
    } ;

  degreeAdjForms : Str -> Str -> DegreeForms = \p,c ->
    (guessAdjForms p) ** {
      compar = guessAdjForms c ; superl = guessAdjForms ("nej" + c)
      } ;

  guessAdjForms : Str -> AdjForms = \s -> case s of {
        _ + "ý"  => mladyAdjForms s ;
        _ + "í"  => jarniAdjForms s ;
        _ + "ův" => otcuvAdjForms s ;
        _ + "in" => matcinAdjForms s ;
        _ => matcinAdjForms ("" + s) -- Predef.error ("no mkA for" ++ s)
        } ;

-- hard declension

  mladyAdjForms : Str -> AdjForms = \mlady ->
    let mlad = init mlady
    in {
      msnom                    = mlad + "ý" ;
      fsnom                    = mlad + "á" ;
      nsnom,fsgen,fsdat,fpnom  = mlad + "é" ;
      msgen                    = mlad + "ého" ;
      msdat                    = mlad + "ému" ;
      fsacc,fsins              = mlad + "ou" ;
      msloc                    = mlad + "ém" ;
      msins                    = mlad + "ým" ;
      mpnom                    = addAdjI mlad ;
      pgen                     = mlad + "ých" ;
      pins                     = mlad + "ými" ;
      } ;

-- soft declension

  jarniAdjForms : Str -> AdjForms = \jarni ->
    {
      msnom,fsnom,nsnom,
      fsgen,fsdat,fsacc,fsins,
      mpnom,fpnom              = jarni ;
      msgen                    = jarni + "ho" ;
      msdat                    = jarni + "mu" ;
      msloc,msins              = jarni + "m" ;
      pgen                     = jarni + "ch" ;
      pins                     = jarni + "mi" ;
      } ;

-- masculine possession: the same endings as in feminine

  otcuvAdjForms : Str -> AdjForms = \otcuv ->
    let otcov = Predef.tk 2 otcuv + "ov"
    in
    matcinAdjForms otcov ** {msnom = otcuv} ;

-- feminine possession

  matcinAdjForms : Str -> AdjForms = \matcin ->
     {
      msnom                    = matcin ;
      fsnom,msgen              = matcin + "a" ;
      nsnom                    = matcin + "o" ;
      fsgen,fpnom              = matcin + "y" ;
      msdat,fsacc              = matcin + "u" ;
      fsdat,msloc              = matcin + "ě" ;
      msins                    = matcin + "ým" ;
      fsins                    = matcin + "ou" ;
      mpnom                    = matcin + "i" ;
      pgen                     = matcin + "ých" ;
      pins                     = matcin + "ými" ;
      } ;

---------------------
-- Verbs

  -- Public input schema of ParadigmsCze.VerbPrincipalParts. Keep existing
  -- record literals valid: derived forms belong in VerbForms; additional
  -- principal parts need a new constructor or overload.
  PositiveVerbForms : Type = {
    inf,
    impsg2, imppl1, imppl2,
    pressg1, pressg2, pressg3,
    prespl1, prespl2, prespl3,
    pastpartsg, pastpartpl : Str
    } ;

  VerbForms : Type = PositiveVerbForms ** {
    negpressg1,negpressg2,negpressg3,negprespl1,negprespl2,negprespl3,
    negimpsg2,negimppl1,negimppl2,
    pastpartfsg,pastpartnsg,pastpartfpl,pastpartnpl,refl : Str ; isRefl : Bool
    } ;

  -- Prefix at lexical construction time, so ordinary spelling also parses.
  withNeg : PositiveVerbForms -> VerbForms = \v -> v ** {
    refl = [] ; isRefl = False ;
    negpressg1 = "ne" + v.pressg1 ; negpressg2 = "ne" + v.pressg2 ;
    negpressg3 = "ne" + v.pressg3 ;
    negprespl1 = "ne" + v.prespl1 ; negprespl2 = "ne" + v.prespl2 ;
    negprespl3 = "ne" + v.prespl3 ;
    negimpsg2 = "ne" + v.impsg2 ; negimppl1 = "ne" + v.imppl1 ; negimppl2 = "ne" + v.imppl2 ;
    pastpartfsg = Predef.tk 1 v.pastpartsg + "la" ;
    pastpartnsg = Predef.tk 1 v.pastpartsg + "lo" ;
    pastpartfpl = Predef.tk 1 v.pastpartpl + "y" ;
    pastpartnpl = Predef.tk 1 v.pastpartpl + "a"
    } ;

  -- Vocalization depends on the next realized token, not on the noun head.
  -- These environments choose a neutral standard form; other clusters can
  -- admit stylistic variants (https://prirucka.ujc.cas.cz/?id=770).
  vPreposition : Str =
    let continuation : Str -> Strs = \p -> strs {
          p+"a"; p+"á"; p+"b"; p+"c"; p+"č"; p+"d"; p+"ď"; p+"e"; p+"é"; p+"ě";
          p+"f"; p+"g"; p+"h"; p+"i"; p+"í"; p+"j"; p+"k"; p+"l"; p+"m"; p+"n";
          p+"ň"; p+"o"; p+"ó"; p+"p"; p+"q"; p+"r"; p+"ř"; p+"s"; p+"š"; p+"t";
          p+"ť"; p+"u"; p+"ú"; p+"ů"; p+"v"; p+"w"; p+"x"; p+"y"; p+"ý"; p+"z"; p+"ž"
          } ;
        longerMe : Strs = continuation "mě" ;
        longerMeCapital : Strs = continuation "Mě"
    in pre {
    -- pre matches prefixes: apply the měst- default to derived words too,
    -- then distinguish pronoun mě from longer words such as měna and měřítko.
    "měst" | "Měst" => "ve" ;
    longerMe => "v" ;
    longerMeCapital => "v" ;
    "mlýn" | "Mlýn" => "ve" ;
    "v" | "V" | "f" | "F" | "mě" | "mně" | "mne" | "mz" | "dv" | "čt" | "tř" | "hř" => "ve" ;
    "sb" | "sc" | "sd" | "sf" | "sh" | "sk" | "sl" | "sm" | "sn" | "sp" | "st" | "sv" |
    "zb" | "zd" | "zh" | "zk" | "zl" | "zm" | "zn" | "zv" |
    "šk" | "šp" | "št" | "šv" | "Šk" | "Šp" | "Št" | "Šv" | "žd" | "žl" | "žr" => "ve" ;
    "Mě" | "Mně" | "Mne" | "Mz" | "Dv" | "Čt" | "Tř" | "Hř" | "Sb" | "Sc" | "Sd" | "Sf" | "Sh" | "Sk" | "Sl" | "Sm" | "Sn" | "Sp" | "St" | "Sv" | "Zb" | "Zd" | "Zh" | "Zk" | "Zl" | "Zm" | "Zn" | "Zv" | "Žd" | "Žl" | "Žr" => "ve" ;
    _ => "v"
    } ;

  -- s/z share these common environments; v has a different profile.
  -- These defaults do not enumerate every lexical/style variant.
  szPreposition : Str -> Str -> Str = \bare,vocalized -> pre {
    "s" | "z" | "š" | "ž" | "mn" | "mz" | "vš" | "vs" | "vz" | "vč" | "dv" | "čt" | "tř" | "ps" |
    "S" | "Z" | "Š" | "Ž" | "Mn" | "Mz" | "Vš" | "Vs" | "Vz" | "Vč" | "Dv" | "Čt" | "Tř" | "Ps" => vocalized ;
    _ => bare
    } ;

  sPreposition : Str = szPreposition "s" "se" ;
  zPreposition : Str = szPreposition "z" "ze" ;

  ComplementCase : Type = {s : Str ; c : Case ; hasPrep : Bool} ;

  hasCliticComplement : ComplementCase -> Bool -> Bool = \p,hasClit ->
    case <hasClit,p.hasPrep,p.c> of {
      <True,False,Gen | Dat | Acc> => True ;
      _ => False
      } ;

  -- Dative precedes genitive/accusative; otherwise retain argument order.
  cliticBefore : Case -> Case -> Bool = \first,second -> case <first,second> of {
    <Gen | Acc,Dat> => False ;
    _ => True
    } ;

  -- Full complements: prepositions select n-forms, bare cases select j-forms.
  -- Clitic eligibility and placement are handled separately by the caller.
  fullComplement : ComplementCase -> (Case => Str) -> (Case => Str) -> Str =
    \p,bare,prep -> p.s ++ case p.hasPrep of {
      True => prep ! p.c ; False => bare ! p.c
      } ;

  verbAgr : VerbForms -> Agr -> Polarity -> Str
    = \vf,a,b -> case a of {
      Ag _ n p => case <n,p,b> of {
        <Sg,P1,Pos> => vf.pressg1 ; <Sg,P1,Neg> => vf.negpressg1 ;
        <Sg,P2,Pos> => vf.pressg2 ; <Sg,P2,Neg> => vf.negpressg2 ;
        <Sg,P3,Pos> => vf.pressg3 ; <Sg,P3,Neg> => vf.negpressg3 ;
        <Pl,P1,Pos> => vf.prespl1 ; <Pl,P1,Neg> => vf.negprespl1 ;
        <Pl,P2,Pos> => vf.prespl2 ; <Pl,P2,Neg> => vf.negprespl2 ;
        <Pl,P3,Pos> => vf.prespl3 ; <Pl,P3,Neg> => vf.negprespl3
        } ;
      AgPol _ => case b of {Pos => vf.prespl2 ; Neg => vf.negprespl2} ;
      AgQuant _ => case b of {Pos => vf.pressg3 ; Neg => vf.negpressg3}
      } ;

  imperativeAgr : VerbForms -> Agr -> Polarity -> Str = \v,a,pos -> case <a,pos> of {
    <Ag _ Sg _,Pos> => v.impsg2 ; <Ag _ Sg _,Neg> => v.negimpsg2 ;
    <Ag _ Pl P1,Pos> => v.imppl1 ; <Ag _ Pl P1,Neg> => v.negimppl1 ;
    <_,Pos> => v.imppl2 ; <_,Neg> => v.negimppl2
    } ;

  pastPartAgr : VerbForms -> Agr -> Polarity -> Str = \v,a,pos ->
    let form = case a of {
          Ag g n _ => case <g,n> of {
            <Masc _,Sg> => v.pastpartsg ; <Fem,Sg> => v.pastpartfsg ;
            <Neutr,Sg> => v.pastpartnsg ; <Masc Anim,Pl> => v.pastpartpl ;
            <Neutr,Pl> => v.pastpartnpl ; <_,Pl> => v.pastpartfpl
            } ;
          AgPol g => case g of {
            Masc _ => v.pastpartsg ; Fem => v.pastpartfsg ; Neutr => v.pastpartnsg
            } ;
          AgQuant _ => v.pastpartfpl
          }
    in case pos of {Pos => form ; Neg => "ne" ++ BIND ++ form} ;

  pastAux : Agr -> Str = \a -> case a of {
    Ag _ n p => case <n,p> of {
                  <Sg,P1> => "jsem" ;
                  <Sg,P2> => "jsi" ;
                  <Pl,P1> => "jsme" ;
                  <Pl,P2> => "jste" ;
                  _       => []
                } ;
    AgPol _ => "jste" ;
    AgQuant _ => []
    } ;

  conditionalAux : Agr -> Str = \a -> case a of {
    Ag _ n p => case <n,p> of {
      <Sg,P1> => "bych" ; <Sg,P2> => "bys" ; <Pl,P1> => "bychom" ;
      <Pl,P2> => "byste" ; _ => "by"
      } ; AgPol _ => "byste" ; AgQuant _ => "by"
    } ;

  futureAux : Agr -> Polarity -> Str = \a,pos ->
    let form = case a of {
      Ag _ n p => case <n,p> of {
        <Sg,P1> => "budu" ; <Sg,P2> => "budeš" ; <Sg,P3> => "bude" ;
        <Pl,P1> => "budeme" ; <Pl,P2> => "budete" ; <Pl,P3> => "budou"
        } ;
      AgQuant _ => "bude" ; AgPol _ => "budete"
      }
    in case pos of {Pos => form ; Neg => "ne" ++ BIND ++ form} ;

  tenseVerb : Tense -> VerbForms -> Agr -> Polarity -> Str = \t,v,a,pos -> case t of {
    Pres => verbAgr v a pos ;
    Past => pastPartAgr v a pos ;
    Fut => futureAux a pos ++ v.inf ;
    Cond => pastPartAgr v a pos
    } ;

  tenseClitic : Tense -> Agr -> Str = \t,a -> case t of {
    Past => pastAux a ; Cond => conditionalAux a ; _ => []
    } ;

  Clause : Type = {
    subj,clit,compl : Str ; verb : VerbForms ; a : Agr ;
    isDrop,clitPresent : Bool ;
    finite : Tense => Polarity => Str ; auxiliary : Tense => Str
    } ;

  mkClause : Str -> Str -> Str -> VerbForms -> Agr -> Bool -> Bool -> Clause =
    \subj,clit,compl,verb,a,isDrop,clitPresent -> {
      subj = subj ; clit = clit ; compl = compl ; verb = verb ; a = a ;
      isDrop = isDrop ; clitPresent = clitPresent ;
      finite = table {
        Pres => \\p => verbAgr verb a p ;
        Past => \\p => pastPartAgr verb a p ;
        Fut => \\p => tenseVerb Fut verb a p ;
        Cond => \\p => pastPartAgr verb a p
        } ;
      auxiliary = table {
        Pres => [] ; Past => pastAux a ; Fut => [] ; Cond => conditionalAux a
        }
      } ;

  -- s is the ordinary order; fronted places the clitics first, ready for
  -- an external host. clit/body retain the pieces needed by further fronting.
  -- Keep complete orders as well as pieces so markup can enclose a sentence
  -- in either order without leaking the moved clitics outside its scope.
  Sentence : Type = {s,fronted,clit,body : Str ; clitPresent : Bool} ;
  sentence : Bool -> Str -> Str -> Str -> Sentence = \present,first,clit,rest -> {
    s = first ++ clit ++ rest ; fronted = clit ++ first ++ rest ;
    clit = clit ; body = first ++ rest ; clitPresent = present
    } ;
  frontSentence : Str -> Sentence -> Sentence = \first,s -> s ** {
    s = first ++ s.fronted ; fronted = s.clit ++ first ++ s.body ;
    body = first ++ s.body
    } ;
  prefixSentence : Str -> Sentence -> Sentence = \first,s -> s ** {
    s = first ++ s.s ; fronted = s.clit ++ first ++ s.body ;
    body = first ++ s.body
    } ;
  -- Appended clauses retain their own domains; only s's clitics can move.
  appendSentence : Sentence -> Str -> Sentence = \s,last -> s ** {
    s = s.s ++ last ; fronted = s.fronted ++ last ; body = s.body ++ last
    } ;

  copulaVerbForms : VerbForms = (withNeg {
    inf = "být" ;
    impsg2 = "buď" ; imppl1 = "buďme" ; imppl2 = "buďte" ;
    pressg1 = "jsem" ;
    pressg2 = "jsi" ;
    pressg3 = "je" ;
    prespl1 = "jsme" ;
    prespl2 = "jste" ;
    prespl3 = "jsou" ;
    pastpartsg = "byl" ;
    pastpartpl = "byli" ;
    }) ** {negpressg3 = "není"} ;

  haveVerbForms : VerbForms = withNeg {
    inf = "mít" ;
    impsg2 = "měj" ; imppl1 = "mějme" ; imppl2 = "mějte" ;
    pressg1 = "mám" ;
    pressg2 = "máš" ;
    pressg3 = "má" ;
    prespl1 = "máme" ;
    prespl2 = "máte" ;
    prespl3 = "mají" ;
    pastpartsg = "měl" ;
    pastpartpl = "měli" ;
    } ;

-- just an example of a traditional paradigm
---- TODO other traditional paradigms

  iii_kupovatVerbForms : Str -> VerbForms = \kupovat ->
   let
     kupo = Predef.tk 3 kupovat ;
     kupu = Predef.tk 1 kupo + "u"
   in
   withNeg {
    inf = kupovat ;
    impsg2 = kupu + "j" ; imppl1 = kupu + "jme" ; imppl2 = kupu + "jte" ;
    pressg1 = kupu + "ji" ; --- kupuju
    pressg2 = kupu + "ješ" ;
    pressg3 = kupu + "je" ;
    prespl1 = kupu + "jeme" ;
    prespl2 = kupu + "jete" ;
    prespl3 = kupu + "jí" ; --- kupujou
    pastpartsg = kupo + "val" ;
    pastpartpl = kupo + "vali" ;
    } ;

  iii_krýtVerbForms : Str -> VerbForms = \krýt ->
   let
     kry = shortenVowel (Predef.tk 1 krýt) ;
   in
   withNeg {
    inf = krýt ;
    impsg2 = kry + "j" ; imppl1 = kry + "jme" ; imppl2 = kry + "jte" ;
    pressg1 = kry + "ji" ;
    pressg2 = kry + "ješ" ;
    pressg3 = kry + "je" ;
    prespl1 = kry + "jeme" ;
    prespl2 = kry + "jete" ;
    prespl3 = kry + "jí" ;
    pastpartsg = kry + "l" ;
    pastpartpl = kry + "li" ;
    } ;

  -- Productive defaults for lexicons that only provide an infinitive. Czech
  -- has many stem alternations, so irregular verbs should still use the full
  -- principal-parts constructor; these classes cover the regular majority.
  atVerbForms : Str -> VerbForms = \inf ->
    let stem = Predef.tk 2 inf in withNeg {
      inf = inf ;
      pressg1 = stem + "ám" ; pressg2 = stem + "áš" ; pressg3 = stem + "á" ;
      prespl1 = stem + "áme" ; prespl2 = stem + "áte" ; prespl3 = stem + "ají" ;
      pastpartsg = stem + "al" ; pastpartpl = stem + "ali" ;
      impsg2 = stem + "ej" ; imppl1 = stem + "ejme" ; imppl2 = stem + "ejte"
      } ;

  itVerbForms : Str -> VerbForms = \inf ->
    let stem = Predef.tk 2 inf in withNeg {
      inf = inf ;
      pressg1 = stem + "ím" ; pressg2 = stem + "íš" ; pressg3 = stem + "í" ;
      prespl1 = stem + "íme" ; prespl2 = stem + "íte" ; prespl3 = stem + "í" ;
      pastpartsg = stem + "il" ; pastpartpl = stem + "ili" ;
      impsg2 = stem ; imppl1 = stem + "me" ; imppl2 = stem + "te"
      } ;

  etVerbForms : Str -> Str -> VerbForms = \inf,pastVowel ->
    let stem = Predef.tk 2 inf in withNeg {
      inf = inf ;
      pressg1 = stem + "ím" ; pressg2 = stem + "íš" ; pressg3 = stem + "í" ;
      prespl1 = stem + "íme" ; prespl2 = stem + "íte" ; prespl3 = stem + "í" ;
      pastpartsg = stem + pastVowel + "l" ; pastpartpl = stem + pastVowel + "li" ;
      impsg2 = stem ; imppl1 = stem + "me" ; imppl2 = stem + "te"
      } ;

  noutVerbForms : Str -> VerbForms = \inf ->
    let stem = Predef.tk 4 inf in withNeg {
      inf = inf ;
      pressg1 = stem + "nu" ; pressg2 = stem + "neš" ; pressg3 = stem + "ne" ;
      prespl1 = stem + "neme" ; prespl2 = stem + "nete" ; prespl3 = stem + "nou" ;
      pastpartsg = stem + "nul" ; pastpartpl = stem + "nuli" ;
      impsg2 = stem + "ni" ; imppl1 = stem + "něme" ; imppl2 = stem + "něte"
      } ;

  nestVerbForms : Str -> VerbForms = \inf ->
    let prefix = Predef.tk 4 inf ; stem = prefix + "nes" in withNeg {
      inf = inf ;
      pressg1 = stem + "u" ; pressg2 = stem + "eš" ; pressg3 = stem + "e" ;
      prespl1 = stem + "eme" ; prespl2 = stem + "ete" ; prespl3 = stem + "ou" ;
      pastpartsg = stem + "l" ; pastpartpl = stem + "li" ;
      impsg2 = stem ; imppl1 = stem + "me" ; imppl2 = stem + "te"
      } ;

  jistVerbForms : VerbForms = withNeg {
    inf = "jíst" ;
    pressg1 = "jím" ; pressg2 = "jíš" ; pressg3 = "jí" ;
    prespl1 = "jíme" ; prespl2 = "jíte" ; prespl3 = "jedí" ;
    pastpartsg = "jedl" ; pastpartpl = "jedli" ;
    impsg2 = "jez" ; imppl1 = "jezme" ; imppl2 = "jezte"
    } ;

  guessVerbForms : Str -> VerbForms = \inf -> case inf of {
    "být" => copulaVerbForms ;
    "mít" => haveVerbForms ;
    "jíst" => jistVerbForms ;
    _ + "ovat" => iii_kupovatVerbForms inf ;
    _ + ("ýt" | "ít") => iii_krýtVerbForms inf ;
    _ + "nout" => noutVerbForms inf ;
    _ + "nést" => nestVerbForms inf ;
    _ + "at" => atVerbForms inf ;
    _ + "it" => itVerbForms inf ;
    _ + "ět" => etVerbForms inf "ě" ;
    _ + "et" => etVerbForms inf "e" ;
    _ => let stem = Predef.tk 1 inf in withNeg {
      inf = inf ;
      pressg1 = stem + "u" ; pressg2 = stem + "eš" ; pressg3 = stem + "e" ;
      prespl1 = stem + "eme" ; prespl2 = stem + "ete" ; prespl3 = stem + "ou" ;
      pastpartsg = stem + "l" ; pastpartpl = stem + "li" ;
      impsg2 = stem ; imppl1 = stem + "me" ; imppl2 = stem + "te"
      }
    } ;

---------------------------
-- Pronouns

  PronForms : Type = {
    nom, cnom,       -- cnom is the pro-drop subject
    gen, cgen,pgen,  -- bare, clitic, prepositional
    acc, cacc,pacc,
    dat, cdat,pdat,
    loc,
    ins,pins        : Str ;
    a : Agr ; isDrop : Bool
    } ;

  personalPron : Agr -> PronForms = \a ->
    {a = a ; cnom = [] ; isDrop = False} **
    case a of {
      AgQuant _ => {nom,gen,cgen,pgen,acc,cacc,pacc,dat,cdat,pdat,loc,ins,pins = nonExist} ;
      Ag _ Sg P1 => {
        nom = "já" ;
        gen,acc,pgen,pacc = "mne" ;
        cgen,cacc = "mě" ;
        dat,pdat,loc = "mně" ;
        cdat = "mi" ;
        ins,pins = "mnou"
        } ;
      Ag _ Sg P2 => {
        nom = "ty" ;
        gen,acc,pgen,pacc = "tebe" ;
        cgen,cacc = "tě" ;
        dat,pdat,loc = "tobě" ;
        cdat = "ti" ;
        ins,pins = "tebou"
        } ;
      Ag (Masc _) Sg P3 => {
        nom = "on" ;
        gen,acc = "jeho" ;
        cgen,cacc = "ho" ;
        pgen,pacc = "něho" ;
        dat = "jemu" ;
	cdat = "mu" ;
	pdat = "němu" ;
	loc = "něm" ;
	ins = "jím" ;
	pins = "ním" ;
        } ;
      Ag Fem Sg P3 => {
        nom = "ona" ;
        gen,dat,cgen,cdat,ins = "jí" ;
        acc,cacc = "ji" ;
        pacc = "ni" ;
        pgen,pdat,loc,pins = "ní" ;
        } ;
      Ag Neutr Sg P3 => {
        nom = "ono" ;
        gen = "jeho" ;
        cgen,cacc = "ho" ;
        pgen = "něho" ;
        dat = "jemu" ;
	acc = "je" ;
        pacc = "ně" ;
	cdat = "mu" ;
	pdat = "němu" ;
	loc = "něm" ;
	ins = "jím" ;
	pins = "ním" ;
        } ;
      Ag _ Pl P1 => {
        nom = "my" ;
        gen,acc,
          cgen,cacc,
          pgen,pacc,
	  loc  = "nás" ;
        dat,cdat,pdat = "nám" ;
	ins,pins = "námi" ;
        } ;
      Ag _ Pl P2 | AgPol _ => {
        nom = "vy" ;
        gen,acc,
          cgen,cacc,
          pgen,pacc,
	  loc  = "vás" ;
        dat,cdat,pdat = "vám" ;
	ins,pins = "vámi" ;
        } ;
      Ag g Pl P3 => {
        nom = case g of {
	  Masc Anim => "oni" ;
          Masc Inanim => "ony" ;
	  Fem => "ony" ;
	  Neutr => "ona"
	  } ;
	gen,cgen = "jich" ;
	pgen = "nich" ;
	dat,cdat = "jim" ;
	pdat = "nim" ;
	acc,cacc = "je" ;
	pacc = "ně" ;
	loc = "nich" ;
	ins = "jimi" ;
	pins = "nimi" ;
	}

      } ;

  possessivePron : Agr -> DemPronForms = \a -> case a of {
      Ag _ Sg P1 => mladyAdjForms "my" ** {msnom = "můj" ; pdat = "mým"} ;  --- alts: moje, moji,...
      Ag _ Sg P2 => mladyAdjForms "tvy" ** {msnom = "tvůj" ; pdat = "tvým"} ;
      
      Ag _ Pl P1 => nasPossessiveForms "náš" "naš" ;
      Ag _ Pl P2 | AgPol _ => nasPossessiveForms "váš" "vaš" ;
	
      Ag Fem Sg P3 => jarniAdjForms "její" ** {pdat = "jejím"} ;

      Ag (Masc _ | Neutr) Sg P3 => invarDemPronForms "jeho" ** {pdat = "jeho"} ;
      Ag _ Pl P3 | AgQuant _ => invarDemPronForms "jejich" ** {pdat = "jejich"}


    } ;

  -- Náš/váš distinguish feminine accusative naši from oblique naší,
  -- and singular instrumental naším from plural dative našim.
  nasPossessiveForms : Str -> Str -> DemPronForms = \nas,nasStem -> {
    msnom = nas ;
    fsnom,nsnom,fpnom = nasStem + "e" ;
    msgen = nasStem + "eho" ;
    fsgen,fsins = nasStem + "í" ;
    msdat = nasStem + "emu" ;
    fsacc,mpnom = nasStem + "i" ;
    msloc = nasStem + "em" ;
    msins = nasStem + "ím" ;
    pgen = nasStem + "ich" ;
    pdat = nasStem + "im" ;
    pins = nasStem + "imi"
    } ;

  reflPossessivePron : DemPronForms = mladyAdjForms "svy" ** {msnom = "svůj" ; pdat = "svým"} ;

  mkPron : Agr -> PronForms ** {poss : DemPronForms} = \a ->
    personalPron a ** {poss = possessivePron a} ;
  
--------------------------------
-- demonstrative pronouns, used for Quant and Det

oper
  DemPronForms : Type = {
    msnom, fsnom, nsnom,
    msgen, fsgen,
    msdat, -- fsdat = fsgen unlike AdjForms
    fsacc,
    msloc,
    msins, fsins,
    mpnom, fpnom, -- mpacc = fpacc = fpnom
    pgen,
    pdat,  -- NOT msins like AdjForms
    pins : Str
    } ;

  demPronFormsAdjective : DemPronForms -> Str -> Adjective =
    \dem,s ->
    let
      demAdj = dem ** {fsdat = dem.fsgen} ;
      adjAdj = adjFormsAdjective demAdj
    in {
      s = \\g,n,c => case <g,n,c> of {
        <_,Pl,Dat> => dem.pdat ;
	<Masc _ | Fem, Pl, Acc> => dem.fpnom ;
        _ => adjAdj.s ! g ! n ! c
        } + s
      } ;
      
  justDemPronFormsAdjective : DemPronForms -> Adjective =
    \dem ->
    let
      demAdj = dem ** {fsdat = dem.fsgen} ;
      adjAdj = adjFormsAdjective demAdj
    in {
      s = \\g,n,c => case <g,n,c> of {
        <_,Pl,Dat> => dem.pdat ;
	<Masc _ | Fem, Pl, Acc> => dem.fpnom ;
        _ => adjAdj.s ! g ! n ! c
        }
      } ;


  Determiner : Type = {
    s : Gender => Case => Str ;
    size : NumSize ;  -- number and case of the counted noun
    head : NumHead    -- agreement of a quantifier preceding the numeral
    } ;

  mkDemPronForms : Str -> DemPronForms = \t -> {
    msnom = t + "en" ;
    fsnom = t + "a" ;
    nsnom = t + "o" ;
    msgen = t + "oho" ;
    fsgen = t + "é" ;
    msdat = t + "omu" ;
    fsacc = t + "u" ;
    msloc = t + "om" ;
    msins = t + "ím" ;
    fsins = t + "ou" ;
    mpnom = t + "i" ;
    fpnom = t + "y" ;
    pgen  = t + "ěch" ;
    pdat  = t + "ěm" ;
    pins  = t + "ěmi" ;
    } ;

  invarDemPronForms : Str -> DemPronForms = \s -> {
    msnom, fsnom, nsnom, msgen, fsgen,
    msdat, fsacc, msloc, msins, fsins,
    mpnom, fpnom, pgen, pdat, pins = s ;
    } ;

-- interrogatives

 kdoForms : Case => Str = table {
   Nom => "kdo" ;
   Gen | Acc | Voc => "koho" ;
   Dat => "komu" ;
   Loc => "kom" ;
   Ins => "kým"
   } ;

 coForms : Case => Str = table {
   Nom|Acc|Voc => "co" ;
   Gen => "čeho" ;
   Dat => "čemu" ;
   Loc => "čem" ;
   Ins => "čím"
   } ;

-- Numerals

  -- singular forms of demonstratives
  NumeralForms : Type = {
    msnom, fsnom, nsnom,
    msgen, fsgen,
    msdat,
    fsacc,
    msloc,
    msins, fsins : Str
    } ;

  numeralFormsDeterminer : NumeralForms -> NumSize -> Determiner =
    \nume,size ->
    let
      dem = nume **
        {mpnom, fpnom, pgen, pdat, pins = nume.msnom} ; --- plural forms not used
      demAdj = dem ** {fsdat = dem.fsgen} ;
      adjAdj = adjFormsAdjective demAdj
    in {
      s = \\g,c => adjAdj.s ! g ! Sg ! c ;
      size = size ; head = CountedHead
      } ;

  -- example: number 1
  oneNumeral : Determiner = numeralFormsDeterminer ((mkDemPronForms "jedn") ** {msnom = "jeden"}) Num1 ;

  -- Unlike adjectives, 2--4 do not use the genitive for animate accusatives.
  twoNumeral : Determiner = {
    s = \\g,c => case c of {
      Nom|Acc|Voc => case g of {Masc _ => "dva" ; _ => "dvě"} ;
      Gen|Loc => "dvou" ; Dat|Ins => "dvěma"
      } ; size = Num2_4 ; head = CountedHead
    } ;
  threeNumeral : Determiner = {
    s = \\_,c => case c of {
      Nom|Acc|Voc => "tři" ; Gen => "tří" ; Dat => "třem" ; Loc => "třech" ; Ins => "třemi"
      } ; size = Num2_4 ; head = CountedHead
    } ;
  fourNumeral : Determiner = {
    s = \\_,c => case c of {
      Nom|Acc|Voc => "čtyři" ; Gen => "čtyř" ; Dat => "čtyřem" ; Loc => "čtyřech" ; Ins => "čtyřmi"
      } ; size = Num2_4 ; head = CountedHead
    } ;

  -- for the numbers 5 upwards
  regNumeral : Str -> Str -> Determiner = \pet,peti -> {
    s = \\_,c => case c of {Nom | Acc | Voc => pet ; _ => peti} ;
    size = Num5 ; head = CountedHead
    } ;

  invarDeterminer : Str -> NumSize -> Determiner = \sto,size ->
    (regNumeral sto sto) ** {size = size} ;

  invarNumeral : Str -> Determiner = \s -> invarDeterminer s Num5 ;

--------------------------------
-- combining nouns with numerals

param
  NumSize = Num1 | Num2_4 | Num5 | NumScale ; -- CEG 6.1
  -- A scale noun has its own agreement: tímto tisícem vs. těchto pěti tisíců.
  -- Nested scales retain the outer head: tato dvě stě tisíc korun.
  ScaleAgreement = QuantifiedScale | NominalScale ;
  NumHead = CountedHead | ScaleHead Gender NumSize ScaleAgreement ;

oper
  quantifierForm : Adjective -> Determiner -> Gender -> Case -> Str = \q,num,g,c ->
    case num.head of {
      CountedHead => q.s ! g ! numSizeNumber num.size ! countCase num.size c ;
      ScaleHead sg size _ => q.s ! sg ! numSizeNumber size ! countCase size c
      } ;

  quantifyNumeral : Adjective -> Determiner -> Determiner = \q,num -> num ** {
    s = \\g,c => quantifierForm q num g c ++ num.s ! g ! c
    } ;

  -- Predeterminers agree with the NP head, including a quantified head in
  -- the genitive. This differs from clause agreement for e.g. tisíc korun.
  numeralModAgr : Gender -> Determiner -> Agr = \g,num -> case num.head of {
    CountedHead => numSizeAgr g num.size P3 ;
    ScaleHead sg size _ => numSizeAgr sg size P3
    } ;

  predetForm : Adjective -> Agr -> Case -> Str = \pred,a,c -> case a of {
    Ag g n _ => pred.s ! g ! n  ! c ;
    AgPol g  => pred.s ! g ! Sg ! c ;
    AgQuant g => pred.s ! g ! Pl ! countCase Num5 c
    } ;

  -- Keep the boundary for my všichni doma, also after AdvNP. Complete forms
  -- retain a single markup wrapper; insertion can use separately marked pieces.
  NPForms : Type = {
    s,prep,before,prepBefore : Case => Str ;
    after : Str
    } ;

  npForms : (Case => Str) -> (Case => Str) -> NPForms = \s,prep -> {
    s,before = s ; prep,prepBefore = prep ; after = []
    } ;

  appendNPForms : NPForms -> Str -> NPForms = \np,adv -> np ** {
    s = \\c => np.s ! c ++ adv ; prep = \\c => np.prep ! c ++ adv ;
    after = np.after ++ adv
    } ;

  predetNPForms : Bool -> (Case => Str) -> NPForms -> NPForms = \post,pred,np ->
    case post of {
      True => np ** {
        s = \\c => np.before ! c ++ pred ! c ++ np.after ;
        prep = \\c => np.prepBefore ! c ++ pred ! c ++ np.after ;
        before = \\c => np.before ! c ++ pred ! c ;
        prepBefore = \\c => np.prepBefore ! c ++ pred ! c
        } ;
      False => np ** {
        s = \\c => pred ! c ++ np.s ! c ;
        prep = \\c => pred ! c ++ np.prep ! c ;
        before = \\c => pred ! c ++ np.before ! c ;
        prepBefore = \\c => pred ! c ++ np.prepBefore ! c
        }
      } ;

  nounGender : Noun -> Number -> Gender = \cn,n -> case n of {
    Sg => cn.g ; Pl => cn.gPl
    } ;

  countCase : NumSize -> Case -> Case = \n,c -> case <n,c> of {
    <NumScale,_> | <Num5, Nom | Acc | Voc> => Gen ; _ => c
    } ;

  numSizeForm : (Number => Case => Str) -> NumSize -> Case -> Str
    = \cns,n,c -> case n of {
        Num1   => cns ! Sg ! c ;
        NumScale => cns ! Pl ! Gen ;
	Num2_4 => cns ! Pl ! c ;
	Num5   => case c of {
	  Nom | Acc | Voc => cns ! Pl ! Gen ;
	  _ => cns ! Pl ! c
	  }
	} ;

  -- Clause agreement is independent of the counted noun's genitive case.
  -- Millions/billions normally agree with their scale head; hundreds and
  -- thousands use quantified agreement by default. Five million still has
  -- a quantified head, while two million has a plural nominal head.
  numeralAgr : Gender -> Determiner -> Person -> Agr = \g,num,p ->
    case num.head of {
      ScaleHead sg size NominalScale => numSizeAgr sg size p ;
      _ => numSizeAgr g num.size p
    } ;

  numSizeAgr : Gender -> NumSize -> Person -> Agr
    = \g,ns,p -> case ns of {
        Num5 | NumScale => AgQuant g ; -- essential grammar 6.1.4
	Num2_4 => Ag g Pl p ;
	Num1   => Ag g Sg p
	} ;

  numSizeNumber : NumSize -> Number = \ns -> case ns of {
    Num1 => Sg ;
    _ => Pl      ---- TO CHECK
    } ;
}