--# -path=.:../abstract:../common:../prelude

--1 Greek auxiliary operations.   -- NOT USED. Remember old version; sound law SL etc

resource AccentsGrc = {

flags 
  optimize = noexpand ;

oper

-- Accent shift and accent change: the following functions are applied to 
-- the stem in certain cases:

-- a) when the Pl Gen ending w~n is added, the accent in the stem 
--    must be removed using dropAccent:

  dropAccent : Str -> Str = \str -> case str of { 
      x + ("'" | "`" | "~") + z => x + z ;
      x + "="               + z => x + "-" + z ;
      _                         => str 
    } ;



{- Redesign: ------------------------------------------------------------------

   Try to extract the patterns of vowel lengths and accent position 
   and do the paradigms with less pattern matching.

   We need the general rule:
   1. the accent position is taken from SgNom, and only moved on demand.
   2. a shift is demanded if a an ending with a long vowel is added and 
      the accent position is on the 3rd last vowel.
   3. if an ending with accent is added, the accent in the stem has to be dropped.

-- Declension I,II: Word`stock'+NomSgEnding => wordkind includes ending. 
     Then from lists of endings *without accent* one takes the accent position 
     from the user-provided form(s), and given the vowel length of the ending,
     determines the accent position of other forms
-- Declension III:  
     Wordstem+Ending (wordstem+os=GenSg) => NomSg may have empty ending
     Then the accent position is taken from the NomSg.
-}

oper 
  Position : PType = Predef.Ints 3 ;

  WPat = { syl : Syllability ; 
            v : VPat * VPat * VPat ; 
            s : Str * Str * Str * Str;
           acnt : Accent 
         } ;
param
  Accent = Acute Position | Circum Position | NoAccent ;
  Syllability = Mono | Bi | Many ;

  Vowel  = A | E | I | O | U | AU | EU | OU | AI | EI | OI | UI | 
           -- vowel with spirtus asper/lenis:
           Aa | Ea | Ia | Oa | Ua | AUa | EUa | OUa | AIa | EIa | OIa | UIa | 
           Al | El | Il | Ol | Ul | AUl | EUl | OUl | AIl | EIl | OIl | UIl | 
           -- vowel with iota subscriptum and spiritus
           Ai | Ei | Oi | Aia | Eia | Oia | Ail | Eil | Oil 
         ;

  VPat   = NoVowel | Short Vowel | Long Vowel ;  -- 1+45+45 = 91 possibilities

  Spirit = Asper | Lenis | NoSpirit ;

oper
  removeLength : Str -> Str = \str -> case str of { 
     "a_" | "a." => "a" ; "i_" | "i." => "i" ;  "y_" | "y." => "y" ; x => x } ;

  toStr : VPat -> Str = \vpat -> case vpat of {
     Short A => "a" ;
     Short E => "e"  ;
     Short I => "i" ;  
     Short O => "o"  ;
     Short U => "y" ;
     Long A  => "a_" ; -- maybe better "a", since the unicode-table has not a_'
     Long E  => "h"  ;
     Long I  => "i_" ;
     Long O  => "w"  ;
     Long U  => "y_" ;
     Long AU => "ay" ;
     Long EU => "ey" ;
     Long OU => "oy" ;
     Long AI => "ai" ;
     Long EI => "ei" ;
     Long OI => "oi" ;
     Long UI => "yi" ;
     Short AI => "ai" ;
     Short OI => "oi" ;
     -- vowels and diphthongs with spriritus asper:
     Short Aa => "a(" ;
     Short Ea => "e(" ;       
     Short Ia => "i(" ;       
     Short Oa => "o(" ;       
     Short Ua => "y(" ;       
  -- Long Aa 
     Long Ea => "h(" ;    
  -- Long Ia
     Long Oa => "w(" ;       
  -- Long Ua
     Long AUa => "ay(" ;
     Long EUa => "ey(" ;
     Long OUa => "oy(" ;
     Long AIa => "ai(" ;
     Long EIa => "ei(" ;
     Long OIa => "oi(" ;
     Long UIa => "yi(" ;
     -- vowels and diphthongs with spriritus lenis:
     Short Al => "a)" ;       
     Short El => "e)" ;       
     Short Il => "i)" ;       
     Short Ol => "o)" ;       
     Short Ul => "y)" ;       
  -- Long Al
     Long El => "h)" ;       
  -- Long Il
     Long Ol => "w)" ;       
  -- Long Ul
     Long AUl => "ay)" ;
     Long EUl => "ey)" ;
     Long OUl => "oy)" ;
     Long AIl => "ai)" ;
     Long EIl => "ei)" ;
     Long OIl => "oi)" ;
     Long UIl => "yi)" ;
     -- vowels with iota subscriptum, and spirits
     Long Ai  => "a|" ;
     Long Ei  => "e|" ;
     Long Oi  => "o|" ;
     Long Aia => "a|(" ;
     Long Eia => "h|(" ;
     Long Oia => "w|(" ;
     Long Ail => "a|)" ;
     Long Eil => "h|)" ;
     Long Oil => "w|)" ;
     NoVowel => "" ;   -- TODO: trema etc. perhaps I2 = "i-" 
     _       => "*"    -- ca.30 possibilities
  } ;

  toVPat : Str -> VPat = \str -> case str of {
     ("a."|"a") => Short A ;
     ("i."|"i"|"i-"|"i=") => Short I ;
     ("y."|"y"|"y-"|"y=") => Short U ;
     "a_"       => Long A ;
     "i_"       => Long I ;
     "y_"       => Long U ;
     "a" => Short A ; 
     "e" => Short E ; 
     "i" => Short I ; 
     "o" => Short O ; 
     "y" => Short U ; 
     "a" => Long A  ; -- maybe better "a", since the unicode-table has not a_'
     "h" => Long E  ; 
     "i" => Long I  ; 
     "w" => Long O  ; 
     "y" => Long U  ; 
     "ay" => Long AU ; 
     "ey" => Long EU ; 
     "oy" => Long OU ; 
     "ai" => Long AI ; 
     "ei" => Long EI ; 
     "oi" => Long OI ; 
     "yi" => Long UI ; 
     -- vowels and diphthongs with spriritus asper:
     "a(" => Short Aa ; 
     "e(" => Short Ea ; 
     "i(" => Short Ia ; 
     "o(" => Short Oa ; 
     "y(" => Short Ua ; 
  -- Long Aa 
     "h(" => Long Ea ; 
  -- Long Ia
     "w(" => Long Oa ; 
  -- Long Ua
     "ay(" => Long AUa ; 
     "ey(" => Long EUa ; 
     "oy(" => Long OUa ; 
     "ai(" => Long AIa ; 
     "ei(" => Long EIa ; 
     "oi(" => Long OIa ; 
     "yi(" => Long UIa ; 
     -- vowels and diphthongs with spriritus lenis:
     "a)" => Short Al ; 
     "e)" => Short El ; 
     "i)" => Short Il ; 
     "o)" => Short Ol ; 
     "y)" => Short Ul ; 
  -- Long Al
     "h)" => Long El ; 
  -- Long Il
     "w)" => Long Ol ; 
  -- Long Ul
     "ay)" => Long AUl ; 
     "ey)" => Long EUl ; 
     "oy)" => Long OUl ; 
     "ai)" => Long AIl ; 
     "ei)" => Long EIl ; 
     "oi)" => Long OIl ; 
     "yi)" => Long UIl ; 
     -- vowels with iota subscriptum, and spirits
     "a|" => Long Ai  ; 
     "e|" => Long Ei  ; 
     "o|" => Long Oi  ; 
     "a|(" => Long Aia ; 
     "h|(" => Long Eia ; 
     "w|(" => Long Oia ; 
     "a|)" => Long Ail ; 
     "h|)" => Long Eil ; 
     "w|)" => Long Oil ; 
     _     => NoVowel  -- TODO: trema etc. perhaps I2 = "i-" 
  } ;

-- accent ~ can only be on long vowels, hence y~ must become <Long U, Circum> etc:

  toVPat2 : Str -> Str -> VPat = \o,z -> 
     case o of { (#shortV|#restV) => case z of {"~"+_ => toVPat (removeLength o + "_") ; 
                                                 _    => toVPat o} ;
                 _                => toVPat o } ;

  toAcntPos : Str -> Accent = \str -> 
     case str of { -- we don't check for double accent; the leftmost accent counts
     -- 3 syllables
     ("'"|"('"|")'") + _ + "$"       + _ + "$" + _  => Acute 1 ;
     ("~"|"(~"|")~") + _ + "$"       + _ + "$" + _  => Circum 1 ;
                       _ + "$" + "'" + _ + "$" + _  => Acute 2 ;
                       _ + "$" + "~" + _ + "$" + _  => Circum 2 ;
                       _ + "$" + _ + "$" + "'" + _  => Acute 3 ;
                       _ + "$" + _ + "$" + "~" + _  => Circum 3 ;
     -- 2 syllables
     ("'"|"('"|")'") + _ + "$" + _        => Acute 2 ;
     ("~"|"(~"|")~") + _ + "$" + _        => Circum 2 ;  
                       _ + "$" + "'" + _  => Acute 3 ;  
                       _ + "$" + "~" + _  => Circum 3 ;  
     -- 1 syllable
     ("'"|"('"|")'") + _          => Acute 3 ;
     ("~"|"(~"|")~") + _          => Circum 3 ;
     -(_ + ("'" | "~" | "`") + _) => NoAccent ;
     _  => Predef.error "Error: double accent" 
  } ;

-- The order of the patterns in the pattern alternatives is important since 
-- diphthongs match against vowel+vowel, and short vowels.
-- (Here "ai", "oi" count as long; for end syllables, this is adjusted in addAccent.)

  wpat : Str -> WPat = \str ->      
     let T = "$" ;             
         da = dropAccent 
     in 
     case str of { 
     -- monosyllabic words:
          y@(("r(" | "") + #nonvowels)
        + o@((#diphthong | #longV | #shortV | #restV) + (#spirit | "")) 
        + z@#nonvowels 
     => { syl = Mono ;  
          v = <NoVowel, NoVowel, toVPat2 o z> ; 
          acnt = toAcntPos z ; 
          s = <[] , [] , y , da z>
        } ;
     -- bisyllabic words:
         x@(("r(" | "") + #nonvowels)
       + e@((#diphthong | #longV | #shortV | #restV) + (#spirit | ""))
       + y@#nonvowels 
       + o@(#diphthong | #longV | #shortV | #restV) 
       + z@#nonvowels
     => { syl = Bi ;  
          v = <NoVowel , toVPat2 e y, toVPat2 o z> ; 
          acnt = toAcntPos (y + T + z) ; 
          s = <[] , x , da y , da z>
        } ;
     -- manysyllabic words:
         r@_ 
       + a@((#diphthong | #longV | #shortV | #restV) + (#spirit | ""))
       + x@#nonvowels 
       + e@(#diphthong | #longV | #shortV | #restV) 
       + y@#nonvowels 
       + o@(#diphthong | #longV | #shortV | #restV) 
       + z@#nonvowels  
     => { syl = Many ;  
          v = <toVPat2 a x, toVPat2 e y, toVPat2 o z> ;
          acnt = toAcntPos (x + T + y + T + z) ;
          s = <r , da x , da y , da z>
        } ;
     _ => -- Predef.error "vowel/accent pattern not recognized" 
          { syl = Mono ;
            v   = <NoVowel,NoVowel,NoVowel> ;
            acnt= NoAccent ;
            s   = <"BUGGY","VOWEL","ACCENT","PATTERN"> 
          }
     } ;
           
-- Add an accent to an unaccentuated string; includes necessary accent changes and shifts
-- (We don't check that the given string has enough vowels.)

  merge : (Str * Str * Str * Str) -> (Str * Str * Str) -> Str = 
           \cs,vs -> cs.p1 + vs.p1 + cs.p2 + vs.p2 + cs.p3 + vs.p3 + cs.p4 ;

  glue : (Str * Str * Str * Str )-> (VPat * VPat * VPat) -> Str = 
         \cs,vs -> cs.p1 + (toStr vs.p1) + cs.p2 + (toStr vs.p2) + cs.p3 + (toStr vs.p3) + cs.p4 ;

  addAccent0 : Accent -> Str -> Str = \accent,str -> str ;  -- for testing

  -- addAccent inserts the given accent = (accnt pos) to the vowel at the position,
  -- and for pos=1=3rd last and last vowel is short, puts the accent to 2nd last:
  addAccent : Accent -> Str -> Str = \accent,str -> 
    let 
         w = wpat str ;
        v1 = toStr w.v.p1 ;  -- third last vowel
        v2 = toStr w.v.p2 ;  -- second last vowel
        v3 = toStr w.v.p3 ;  -- last vowel
        v2s = removeLength v2 ;
        v3s = removeLength v3 ;
    in
       case accent of {
         Acute 3  => merge w.s <v1, v2, v3 + "'"> ;
         Circum 3 => merge w.s <v1, v2, v3s + "~"> ;
         Acute 2  => case <w.v.p2, w.v.p3> of {                   -- BR 9 4
                        <Long u2, Short u3> => merge w.s <v1, v2s + "~", v3> ; 
                                          _ => merge w.s <v1, v2 + "'", v3> 
                     } ;
         Circum 2 => merge w.s <v1, v2s + "~", v3> ; -- change to ' for v2 short?
         Acute 1  => case <w.v.p3, w.s.p4> of { 
                       <Short _, _> => merge w.s <v1 + "'", v2, v3> ;  -- BR 9 1.b
                       <Long AI,""> => merge w.s <v1 + "'", v2, v3> ;  -- BR 29.7 declension ; conjug?
                       <Long OI,""> => merge w.s <v1 + "'", v2, v3> ;  -- BR 29.7 declension ; conjug?
                       _            => merge w.s <v1, v2 + "'", v3>    -- sometimes changes to "~" needed?
                     } ;
         _ => -- Predef.error ("Illegal accentuation for " ++ str)
              str
    } ;

  -- from accent position in stem to accent position in (stem+long ending): ?
  --   stempos1,stempos2,stempos3 => (stem+end)pos1,(stem+end)pos2,(stem+end)pos3

  addAccent' : Accent -> Str -> Str = \accent,str ->
     let 
        accent'  = case accent of {Acute 2  => Acute 1 ;
                                   Circum 2 => Acute 1 ;
                                   Acute 3  => Acute 2 ;
                                   Circum 3 => Circum 2 ;
                                          _ => accent} 
     in addAccent accent' str ;
-}
-- --------------------------------------------------------------------------------

{- Sound laws on structured string (Example)

  -- Problem: 
  -- In addNEnding, an accent on the ending overwrites accents on the stem.
  -- But if vowel contraction <e',ei> => <[],ei~> deletes the final vowel of
  -- the stem, one would need to shift stem parts to the right:  
  -- c1+v1+c2+v2+c3+v3+[]++[]+v+c2 => c1+v1+c2+v2+c3+[]+[]++[]+(v3+v)+c2 
  -- to avoid the adjacent []+[]. But c1 may contain vowels, and the number of 
  -- syllables is not exactly known!
  -- If we use c1+v1+c2+v2+c3+v3+[]++[]+v+c2 => c1+v1+c2+v2+c3+(v3+v)+[]++[]+[]+c2,
  -- as with <e',ei> => <ei~,[]>, we have to adjust the accent in the stem. (ToDo)
  -- (could also turn the ending to c2+[]+[], but need not). 

  --  cV2 : soundlaw = \s2 -> <"", contractVowels s2.p1 s2.p2> ; -- deprec.

  -- Test
  SL : Soundlaw = \we -> let S = we.p1 ; 
                             E = we.p2 ; 
                             sv3 : Str = S.v.p3 + case S.a of { Acute 3  => "'" ;
                                                                Circum 3 => "~" ; 
                                                                       _ => "" } ;
                             sc4 = S.c.p4 ;
                             ec1 = E.c.p1 ;
                             ev  = E.v ;
                          in case <sv3,sc4,ec1,ev> of {
                                  <_,"","",_> => let vs = cV2 <sv3,ev> ;  -- contractVowels
                                                     S2 = substV3 S vs.p1 ;
                                                     E2 = toNEnding (vs.p2 + E.c.p2)
                                                 in <S2, E2> ; 
                                  <_,?+_,_+("m"|"s"|"t"|"v"),_> => 
                                                 let cs = mC2 <sc4,ec1> ;
                                                     S2 = substC4 S cs.p1 ;
                                                     E2 = substC E <cs.p2,E.c.p2> 
                                                 in <S2, E2> ; 
                                  _ => we } ;

  substV3 : Word -> Str -> Word =   -- assume that w.v.p3 and u are not "" !!
     \w,u -> { a = case u of { _+"~" => Circum 3 ; _+"'" => Acute 3 ; _ => w.a } ; 
               s = w.s ; 
               v = <w.v.p1, w.v.p2, dropAccent u>  ; -- We need u=/=[], else w.v.p1 prevents shifting
               l = <w.l.p1, w.l.p2, vowelLength (dropAccent u)> ; -- TODO: short "ai" etc
               c = w.c } ; 
  substC : NEnding -> (Str*Str) -> NEnding = 
     \w,cs -> { a = w.a ; v = w.v ; l = w.l ; c = cs } ; 

  -- expl: cc SL <toWord "nanoga'", toNEnding "wn">

   toStrN3 : Word -> Str -> Str =
      \w,e -> let we = SL (adjustAccent <w, toNEnding e>) 
               in toStrT (concat we) ;               

--    toStrN3 : Word -> Str -> Str = \w,e -> let we = (SL <w, toNEnding e>)
--                                            in toStr (addNEnding we.p1 we.p2) ; 

   -- cc let we = (SL <toWord "gene'", toNEnding "i">) in toStr (addNEnding we.p1 we.p2) 
   -- cc toStr (addNEnding (SL <toWord "gene'", toNEnding "i">).p1 (SL <toWord "gene'", toNEnding "i">).p2)
-}

}