Conjugator.hs

module Quenya.Conjugator
    ( conjugate
    , Verb(..)
    , Stem(..)
    , Tense(..)
    , Person(..)
    ) where

import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.List
import Data.String.Utils (replace, startswith, endswith)
import Control.Conditional (cond)
    
-- | All the information required to conjugate a verb
data Verb = Verb { stem :: Stem
                 , tense :: Tense
                 , subject :: Subject
                 , object :: Object
                 } deriving Show

-- | The stem of a Quenya verb (ignoring any weird, one-off stems)
data Stem = AStem String
          | UStem String
          | PrimitiveStem String
          deriving (Show)

-- | Tense of a verb (but not imperative)
data Tense = Present
           | Aorist
           | Past
           | Perfect
           | Future
           deriving (Show)

-- | Either the object or the subject
data Person = FstSg
            | SndFamiliarSg
            | SndFormalSg
            | ThdAnimateSg
            | ThdInanimateSg
            | FstInclusivePl
            | FstExclusivePl
            | SndFamiliarPl
            | SndFormalPl
            | ThdAnimatePl
            | ThdInanimatePl
            | FstInclusiveDl
            | FstExclusiveDl
            | SndFamiliarDl
            | SndFormalDl
            | ThdDl
            | NoOne
            deriving (Show, Eq, Ord)

-- | The doer
type Subject = Person

-- | The victim
type Object = Person

-- | Maps the 'Person' to the corresponding subject ending
subjectPronouns :: M.Map Subject String
subjectPronouns = M.fromList [ (FstSg, "nyë")
                             , (SndFamiliarSg, "tyë")
                             , (SndFormalSg, "lyë")
                             , (ThdAnimateSg, "stë")
                             , (ThdInanimateSg, "ssa")
                             , (FstInclusivePl, "lvë")
                             , (FstExclusivePl, "lmë")
                             , (SndFamiliarPl, "ncë")
                             , (SndFormalPl, "ldë")
                             , (ThdAnimatePl, "ntë")
                             , (ThdInanimatePl, "nta")
                             , (FstInclusiveDl, "ngwë")
                             , (FstExclusiveDl, "mmë")
                             , (SndFamiliarDl, "xë")
                             , (SndFormalDl, "llë")
                             , (ThdDl, "stë")
                             , (NoOne, "")
                             ]

-- | Takes a tense and stem and outputs the conjugated regular verb without
-- | any pronominal endings
addTense :: Tense -> Stem -> String
addTense Present (AStem s) = init s ++ "ëa"
addTense Present (UStem s) = s ++ "a"
addTense Present (PrimitiveStem s) = s ++ "a"

addTense Aorist (AStem s) = s
addTense Aorist (UStem s) = s ++ "ë" -- Sometimes produces things that don't look right
addTense Aorist (PrimitiveStem s) = s ++ "ë"

addTense Past (AStem s) = s ++ "në"
addTense Past (UStem s) = s ++ "në"

-- Some of these might be caught by fixClusters, but best to have all in one place
addTense Past (PrimitiveStem s) = case (last s) of
                                    't' -> init s ++ "ntë"
                                    'c' -> init s ++ "ncë"
                                    'p' -> init s ++ "mpë"
                                    'r' -> init s ++ "ndë"
                                    'l' -> s ++ "lë"
                                    _ -> s ++ "në"

-- There are still dozens more irregularities that need to be accounted for
addTense Perfect (AStem s) = cond [ (startswith "s" s, regular $ "r" ++ tail s)
                                  , (and [isVowel $ head s, endswith "hya" s], s ++ "nië")
                                  , (and [isVowel $ head s, endswith "aya" s], dropLastN 2 (lengthenCentralVowel s) ++ "nië")
                                  , (and [isVowel $ head s, endswith "ya" s], dropLastN 2 (lengthenCentralVowel s) ++ "ië")
                                  , (isVowel $ head s, init (lengthenCentralVowel s) ++ "ië")
                                  , (endswith "hya" s, regular s)
                                  , (endswith "aya" s, regular (dropLastN 2 s ++ "na"))
                                  , (endswith "ya" s, firstVowel s ++ (dropLastN 2 (lengthenCentralVowel s)) ++ "ië")
                                  , (otherwise, regular s)]
    where regular s = firstVowel s ++ init (lengthenCentralVowel s) ++ "ië"
addTense Perfect (UStem s) = cond [ (startswith "s" s, regular $ "r" ++ tail s)
                                  , (isVowel $ head s, init (lengthenCentralVowel s) ++ "ië")
                                  , (otherwise, regular s)
                                  ]
    where regular s = firstVowel s ++ init (lengthenCentralVowel s) ++ "ië"
addTense Perfect (PrimitiveStem s) = cond [ (startswith "s" s, regular $ "r" ++ tail s)
                                          , (otherwise, regular s)
                                          ]
    where regular s = firstVowel s ++ lengthenCentralVowel s ++ "ië"

addTense Future (AStem s) = init s ++ "uva"
addTense Future (UStem s) = init s ++ "úva"
addTense Future (PrimitiveStem s) = s ++ "uva"

-- | Gets last n elements of list
lastN :: Int -> [a] -> [a]
lastN n xs = drop (length xs - n) xs

-- | Drops last n elements of list
dropLastN :: Int -> [a] -> [a]
dropLastN n xs = take (length xs - n) xs

isVowel c = c `elem` "aeiouáéíóú"
isConsonant c = not $ isShortVowel c
isShortVowel c = c `elem` "aeiou"

-- | Tells you what the first vowel is (shortened)
firstVowel :: String -> String
firstVowel s = [head $ map shortenVowel $ filter isVowel s]
    where shortenVowel v = case v of
                             'á' -> 'a'
                             'é' -> 'e'
                             'í' -> 'i'
                             'ó' -> 'o'
                             'ú' -> 'u'
                             _ -> v

-- | Finds the central vowel (if it exists) and lengthens it
lengthenCentralVowel :: String -> String
lengthenCentralVowel s = if endsWithCluster
                         then s
                         else applyToFirst lengthen isShortVowel s
    where endsWithCluster = and $ map isConsonant $ lastN 2 s
          lengthen v = case v of
                         'a' -> 'á'
                         'e' -> 'é'
                         'i' -> 'í'
                         'o' -> 'ó'
                         'u' -> 'ú'
                         _ -> v

-- | Applies given function to first element that matches condition
applyToFirst :: (a -> a) -> (a -> Bool) -> [a] -> [a]
applyToFirst f cond (x:xs) =  if cond x
                              then (f x):xs
                              else case xs of
                                     [] -> [x]
                                     _ -> x:(applyToFirst f cond xs)

-- | Adds pronominal endings to a verb already conjugated in a tense
-- | I guess subject pronouns can be converted to object by taking the first letter...
addPronounEnding :: Verb -> String -> String
addPronounEnding v c = if addEnding then concat [endingStem, sEnding, oEnding] else c
    where addEnding = not $ and [(subject v == NoOne), (object v) == NoOne]
          endingStem = case (tense v) of
                         Aorist -> case (stem v) of
                                     AStem s -> c
                                     _ -> init c ++ "i"
                         _ -> c
          sEnding = get $ subject v
          oEnding = case get $ object v of
                      "" -> ""
                      _ -> [head (get $ object v)]
          get p = fromJust $ M.lookup p subjectPronouns

-- | The heavy-lifting function, called by users of this module
conjugate :: Verb -> String
conjugate v = fixClusters $ addPronounEnding v $ addTense (tense v) (stem v) 

-- | Replaces illegal clusters
fixClusters :: String -> String
fixClusters = foldl (.) id $ map (\(substr, replacement) -> replace substr replacement) [ ("tn", "nt")
                                                                                          , ("cn", "nc")
                                                                                          , ("pn", "mp")]