{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

module Text.Greek.Script.Syllable where

import qualified Control.Lens as Lens
import qualified Data.Maybe as Maybe
import qualified Text.Greek.Phonology.Consonant as Consonant
import qualified Text.Greek.Script.Abstract as Abstract
import qualified Text.Greek.Script.Mark as Mark
import qualified Text.Greek.Script.Place as Place
import qualified Text.Greek.Script.Punctuation as Punctuation
import qualified Text.Greek.Script.Word as Word

data StartVocalic v
  = StartVocalicSingle v
  | StartVocalicDiaeresis v
  | StartVocalicIota v
  | StartVocalicDiphthong v v
  deriving (Eq, Ord, Show)

instance Functor StartVocalic where
  fmap f (StartVocalicSingle v) = StartVocalicSingle (f v)
  fmap f (StartVocalicDiaeresis v) = StartVocalicDiaeresis (f v)
  fmap f (StartVocalicIota v) = StartVocalicIota (f v)
  fmap f (StartVocalicDiphthong v1 v2) = StartVocalicDiphthong (f v1) (f v2)

type Start m = Either (StartVocalic (Abstract.Vowel, m)) (Abstract.Consonant, m)

makeStartVocalic :: [(Abstract.VowelConsonant, Mark.Group Maybe)] -> [Start (Mark.Group Maybe)]
makeStartVocalic = foldr go []
  where
    go (Right a, c) xs = Right (a, c) : xs
    go (Left a, c@(_, _, Just Mark.SyllabicIotaSubscript)) xs = Left (StartVocalicIota (a, c)) : xs
    go (Left a, c@(_, _, Just Mark.SyllabicDiaeresis)) xs = Left (StartVocalicDiaeresis (a, c)) : xs
    go (Left a, c@(_, _, Nothing)) [] = Left (StartVocalicSingle (a, c)) : []
    go (Left a, c@(_, _, Nothing)) (Left (StartVocalicSingle v@(vw, _)) : xs) | isCombiner vw = Left (StartVocalicDiphthong (a, c) v) : xs
    go (Left a, c) xs = Left (StartVocalicSingle (a, c)) : xs

    isCombiner Abstract.V_ι = True
    isCombiner Abstract.V_υ = True
    isCombiner _ = False

data Diphthong = D_αι | D_αυ | D_ει | D_ευ | D_ηυ | D_οι | D_ου | D_υι deriving (Eq, Ord, Show)
data ImproperDiphthong = I_α | I_η | I_ω deriving (Eq, Ord, Show)

data Vocalic m
  = VocalicSingle Abstract.Vowel m
  | VocalicIota ImproperDiphthong m
  | VocalicDiphthong Diphthong m
  deriving (Eq, Ord, Show)

getVocalicMark :: Vocalic m -> m
getVocalicMark (VocalicSingle _ m) = m
getVocalicMark (VocalicIota _ m) = m
getVocalicMark (VocalicDiphthong _ m) = m

type Vocalic' = Vocalic ()

instance Functor Vocalic where
  fmap f (VocalicSingle v m) = VocalicSingle v (f m)
  fmap f (VocalicIota v m) = VocalicIota v (f m)
  fmap f (VocalicDiphthong v m) = VocalicDiphthong v (f m)

vocalicMarkLens :: forall a b f. Functor f => (a -> f b) -> Vocalic a -> f (Vocalic b)
vocalicMarkLens f (VocalicSingle v m) = (\m' -> VocalicSingle v m') <$> f m
vocalicMarkLens f (VocalicIota v m) = (\m' -> VocalicIota v m') <$> f m
vocalicMarkLens f (VocalicDiphthong v m) = (\m' -> VocalicDiphthong v m') <$> f m

type VocalicEither mv c = Either (Vocalic mv) c
type VocalicConsonant mv mc = VocalicEither mv (Abstract.Consonant, mc)

clusterConsonants :: [VocalicEither mv c] -> [VocalicEither mv [c]]
clusterConsonants = foldr go []
  where
    go (Left v) xs = Left v : xs
    go (Right c) (Right cs : xs) = Right (c : cs) : xs
    go (Right c) xs = Right [c] : xs

newtype Count = Count Int deriving (Eq, Ord, Show, Num)
newtype VocalicSingleCount = VocalicSingleCount Int deriving (Eq, Ord, Show, Num)
newtype ImproperDiphthongCount = ImproperDiphthongCount Int deriving (Eq, Ord, Show, Num)
newtype DiphthongCount = DiphthongCount Int deriving (Eq, Ord, Show, Num)


tagConsonantPositions :: [Either v c] -> [Either v (c, Place.Place3)]
tagConsonantPositions [] = []
tagConsonantPositions [x] = pure . Lens.over Lens._Right (flip (,) Place.initialFinal) $ x
tagConsonantPositions (x : xs) = (Lens.over Lens._Right (flip (,) Place.initial) x) : (reverse . tagReverseMedialFinal . reverse $ xs)

tagReverseMedialFinal :: [Either v c] -> [Either v (c, Place.Place3)]
tagReverseMedialFinal [] = []
tagReverseMedialFinal (x : xs) = (Lens.over Lens._Right (flip (,) Place.final) x) : (Lens.over (traverse . Lens._Right) (flip (,) Place.medial) xs)

getSyllableCount :: VocalicConsonant a b -> Count
getSyllableCount (Left _) = 1
getSyllableCount (Right _) = 0

getVocalicSingleCount :: VocalicConsonant a b -> VocalicSingleCount
getVocalicSingleCount (Left (VocalicSingle _ _)) = 1
getVocalicSingleCount _ = 0

getImproperDiphthongCount :: VocalicConsonant a b -> ImproperDiphthongCount
getImproperDiphthongCount (Left (VocalicIota _ _)) = 1
getImproperDiphthongCount _ = 0

getDiphthongCount :: VocalicConsonant a b -> DiphthongCount
getDiphthongCount (Left (VocalicDiphthong _ _)) = 1
getDiphthongCount _ = 0

getSyllableMark :: Syllable m a -> m
getSyllableMark (Syllable _ v _) = getVocalicMark v

validateVocalicConsonant :: Start (Mark.Group Maybe) -> Maybe (VocalicConsonant (Mark.AccentBreathing Maybe) (Maybe Mark.Breathing))
validateVocalicConsonant x = Lens._Left validateStartVocalic x >>= Lens._Right validateConsonantBreathing

validateStartVocalic :: StartVocalic (Abstract.Vowel, Mark.Group Maybe) -> Maybe (Vocalic (Mark.AccentBreathing Maybe))
validateStartVocalic (StartVocalicSingle (v, (a, b, Nothing))) =
  Just $ VocalicSingle v (a, b)
validateStartVocalic (StartVocalicDiaeresis (v, (a, b, Just Mark.SyllabicDiaeresis))) =
  Just $ VocalicSingle v (a, b)
validateStartVocalic (StartVocalicIota (v, (a, b, Just Mark.SyllabicIotaSubscript))) =
  VocalicIota <$> vowelToImproperDiphthong v <*> pure (a, b)
validateStartVocalic (StartVocalicDiphthong (v1, (Nothing, Nothing, Nothing)) (v2, (a, b, Nothing))) =
  VocalicDiphthong <$> vowelPairToDiphthong v1 v2 <*> pure (a, b)
validateStartVocalic _ =
  Nothing

vowelToImproperDiphthong :: Abstract.Vowel -> Maybe ImproperDiphthong
vowelToImproperDiphthong Abstract.V_α = Just I_α
vowelToImproperDiphthong Abstract.V_η = Just I_η
vowelToImproperDiphthong Abstract.V_ω = Just I_ω
vowelToImproperDiphthong _ = Nothing

vowelPairToDiphthong :: Abstract.Vowel -> Abstract.Vowel -> Maybe Diphthong
vowelPairToDiphthong Abstract.V_α Abstract.V_ι = Just D_αι
vowelPairToDiphthong Abstract.V_α Abstract.V_υ = Just D_αυ
vowelPairToDiphthong Abstract.V_ε Abstract.V_ι = Just D_ει
vowelPairToDiphthong Abstract.V_ε Abstract.V_υ = Just D_ευ
vowelPairToDiphthong Abstract.V_η Abstract.V_υ = Just D_ηυ
vowelPairToDiphthong Abstract.V_ο Abstract.V_ι = Just D_οι
vowelPairToDiphthong Abstract.V_ο Abstract.V_υ = Just D_ου
vowelPairToDiphthong Abstract.V_υ Abstract.V_ι = Just D_υι
vowelPairToDiphthong _ _ = Nothing

validateConsonantBreathing :: (Abstract.Consonant, Mark.Group Maybe) -> Maybe (Abstract.Consonant, Maybe Mark.Breathing)
validateConsonantBreathing (x, (Nothing, b, Nothing)) = Just (x, b)
validateConsonantBreathing _ = Nothing

vocalicToSingle :: Vocalic m -> [Abstract.Vowel]
vocalicToSingle (VocalicSingle v _) = [v]
vocalicToSingle _ = []

vocalicToImproperDiphthong :: Vocalic m -> [ImproperDiphthong]
vocalicToImproperDiphthong (VocalicIota d _) = [d]
vocalicToImproperDiphthong _ = []

vocalicToDiphthong :: Vocalic m -> [Diphthong]
vocalicToDiphthong (VocalicDiphthong d _) = [d]
vocalicToDiphthong _ = []

data Syllable m c = Syllable
  { syllableInitialConsonants :: c
  , syllableVocalic :: Vocalic m
  , syllableFinalConsonants :: c
  } deriving (Eq, Ord, Show)

syllableMarkLens :: forall m m' c f. Functor f => (m -> f m') -> Syllable m c -> f (Syllable m' c)
syllableMarkLens f (Syllable cl v cr) = (\m' -> Syllable cl (fmap (const m') v) cr) <$> f (getVocalicMark v)

type SyllableListOrConsonants m c = Either [Syllable m c] c
type SyllableOrConsonants m c = Either (Syllable m c) c

unifySyllableConsonant :: SyllableListOrConsonants m c -> [SyllableOrConsonants m c]
unifySyllableConsonant (Left ss) = fmap Left ss
unifySyllableConsonant (Right cs) = pure (Right cs)

mapSyllableMark :: (m -> m2) -> Syllable m c -> Syllable m2 c
mapSyllableMark f (Syllable c1 m c2) = Syllable c1 (fmap f m) c2

splitMedial :: ([c] -> ([c], [c])) -> [Syllable m [c]] -> Maybe [Syllable m [c]]
splitMedial split = foldr go (Just [])
  where
    go (Syllable _ _ (_:_)) (Just (Syllable [] _ _ : _)) = Nothing
    go (Syllable cl1 v1 []) (Just (Syllable cl2 v2 cr2 : xs)) | (l, r) <- split cl2 = Just (Syllable cl1 v1 l : Syllable r v2 cr2 : xs)
    go x (Just xs) = Just (x : xs)
    go _ Nothing = Nothing

makeSyllableMedialNext :: [VocalicEither m [c]] -> Maybe (SyllableListOrConsonants m [c])
makeSyllableMedialNext = tryFinish . foldr go (Just ([], []))
  where
    go (Left v) (Just (cs, ss)) = Just ([], Syllable [] v cs : ss)
    go (Right csl) (Just ([], Syllable [] v csr : ss)) = Just ([], Syllable csl v csr : ss)
    go (Right csr) (Just ([], [])) = Just (csr, [])
    go _ _ = Nothing

    tryFinish (Just ([], ss)) = Just . Left $ ss
    tryFinish (Just (cs@(_:_), [])) = Just . Right $ cs
    tryFinish _ = Nothing

getCrasis :: SyllableListOrConsonants (Mark.AccentBreathing Maybe) [c] -> Word.Crasis
getCrasis (Left ((Syllable (_:_) v _) : _))
  | (_, Just Mark.BreathingSmooth) <- getVocalicMark v = Word.HasCrasis
getCrasis _ = Word.NoCrasis

processBreathing :: SyllableListOrConsonants (Mark.AccentBreathing Maybe) [Consonant.PlusRoughRho]
  -> Maybe (SyllableListOrConsonants (Maybe Mark.Accent) [Consonant.PlusRoughRhoRoughBreathing])
processBreathing (Right r) = Just . Right . fmap Consonant.promotePlusRoughRho $ r
processBreathing (Left ss) = go ss >>= (pure . Left)
  where
    go ((Syllable [] v cr) : ss')
      | (_, Just Mark.BreathingRough) <- getVocalicMark v
      = (:) <$> pure (Syllable [Consonant.RB_Rough] (dropBreathing v) (promote cr)) <*> validateAllNoBreathing ss'
    go ((Syllable cl v cr) : ss')
      | smoothOrNone v
      = (:) <$> promoteC (Syllable cl (dropBreathing v) cr) <*> validateAllNoBreathing ss'
    go _ = Nothing

    promote = fmap Consonant.promotePlusRoughRho
    promoteC :: Syllable a [Consonant.PlusRoughRho]
      -> Maybe (Syllable a [Consonant.PlusRoughRhoRoughBreathing])
    promoteC (Syllable cl v cr) = Just (Syllable (promote cl) v (promote cr))

    dropBreathing = fmap fst

    smoothOrNone v | (_, Just Mark.BreathingSmooth) <- getVocalicMark v = True
    smoothOrNone v | (_, Nothing) <- getVocalicMark v = True
    smoothOrNone _ = False

    validateAllNoBreathing :: [Syllable (Mark.AccentBreathing Maybe) [Consonant.PlusRoughRho]]
      -> Maybe ([Syllable (Maybe Mark.Accent) [Consonant.PlusRoughRhoRoughBreathing]])
    validateAllNoBreathing = traverse validateNoBreathing

    validateNoBreathing :: Syllable (Mark.AccentBreathing Maybe) [Consonant.PlusRoughRho]
      -> Maybe (Syllable (Maybe Mark.Accent) [Consonant.PlusRoughRhoRoughBreathing])
    validateNoBreathing (Syllable cl v cr) | (_, Nothing) <- getVocalicMark v = promoteC $ (Syllable cl (dropBreathing v) cr)
    validateNoBreathing _ = Nothing

processGrave :: Punctuation.EndOfSentence -> Mark.Accent -> Maybe Mark.AcuteCircumflex
processGrave Punctuation.IsEndOfSentence = Mark.accentNotGrave
processGrave _ = Just . Mark.convertGraveToAcute

newtype ReverseIndex = ReverseIndex { getReverseIndex :: Int } deriving (Eq, Show, Ord)

applyReverseIndex :: [a] -> [(Int, a)]
applyReverseIndex = reverse . zip [0..] . reverse

getAccents :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c -> [Mark.AcuteCircumflex]
getAccents = Lens.toListOf (Lens._Left . traverse . syllableMarkLens . Lens._Just)

getAccentCount :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c -> Int
getAccentCount = length . getAccents

isDoubleAccentWithFinalAcute :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c -> Bool
isDoubleAccentWithFinalAcute s = length accents == 2 && (checkLast . reverse $ accents)
  where
    accents = getAccents s
    checkLast (Mark.Acute : _) = True
    checkLast _ = False

getTopLevelSyllableCount :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c -> Int
getTopLevelSyllableCount = length . Lens.toListOf (Lens._Left . traverse)

dropFinalAcute :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c
  -> SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c
dropFinalAcute = Lens.over Lens._Left dropLastAcute
  where
    dropLastAcute :: [Syllable (Maybe Mark.AcuteCircumflex) c] -> [Syllable (Maybe Mark.AcuteCircumflex) c]
    dropLastAcute = reverse . dropFirstAcute . reverse

    dropFirstAcute :: [Syllable (Maybe Mark.AcuteCircumflex) c] -> [Syllable (Maybe Mark.AcuteCircumflex) c]
    dropFirstAcute (x : xs) = Lens.over syllableMarkLens acuteToNothing x : xs
    dropFirstAcute [] = []

    acuteToNothing :: Maybe Mark.AcuteCircumflex -> Maybe Mark.AcuteCircumflex
    acuteToNothing (Just Mark.Acute) = Nothing
    acuteToNothing x = x

trackEncliticAccent :: [Word.Word Word.WithEnclitic (SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c)]
  -> [Word.Word Word.WithEnclitic (SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c)]
trackEncliticAccent (w : ws)
  | Word.NoAccentUncertainEnclitic <- Lens.view (Word.info . Word.encliticLens) w
  = Lens.set (Word.info . Word.encliticLens) Word.UnaccentedAfterDoubleIsEnclitic w : ws
trackEncliticAccent (w : ws)
  | Word.AccentedUnlikelyEnclitic <- Lens.view (Word.info . Word.encliticLens) w
  = Lens.set (Word.info . Word.encliticLens) Word.SandwichDoubleEncliticIsEnclitic w : trackEncliticAccent ws
trackEncliticAccent ws = ws

markInitialEnclitic :: [Word.Word Word.Sentence (SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c)]
  -> [Word.Word Word.WithEnclitic (SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c)]
markInitialEnclitic = foldr go []
  where
    go w ys
      | s <- Word.getSurface w
      , isDoubleAccentWithFinalAcute s
      = Word.Word (Word.addInitialEnclitic Word.DoubleAccentNotEnclitic (Word.getInfo w)) (dropFinalAcute s)
        : trackEncliticAccent ys
    go w ys
      | getTopLevelSyllableCount (Word.getSurface w) == 0
      = Lens.over Word.info (Word.addInitialEnclitic Word.NoSyllableNotEnclitic) w : ys
    go w ys
      | getTopLevelSyllableCount (Word.getSurface w) > 2 || getAccents (Word.getSurface w) == [Mark.Circumflex]
      = Lens.over Word.info (Word.addInitialEnclitic Word.AccentedNotEnclitic) w : ys
    go w ys
      | getTopLevelSyllableCount (Word.getSurface w) <= 2 && getAccents (Word.getSurface w) == [Mark.Acute]
      = Lens.over Word.info (Word.addInitialEnclitic Word.AccentedUnlikelyEnclitic) w : ys
    go w ys
      | getWordAccent (Word.getSurface w) == Just Word.AccentNone
      = Lens.over Word.info (Word.addInitialEnclitic Word.NoAccentUncertainEnclitic) w : ys
    go w ys
      = Lens.over Word.info (Word.addInitialEnclitic Word.OtherUncertainEnclitic) w : ys

getWordAccent :: SyllableListOrConsonants (Maybe Mark.AcuteCircumflex) c
   -> Maybe Word.Accent
getWordAccent (Right _) = Just Word.AccentNone
getWordAccent (Left ss) = go . reverse . fmap getSyllableMark $ ss
  where
    go :: [Maybe Mark.AcuteCircumflex] -> Maybe Word.Accent
    go (Just Mark.Acute : xs) | allEmptyAccents xs = Just Word.AccentAcuteUltima
    go (Just Mark.Circumflex : xs) | allEmptyAccents xs = Just Word.AccentCircumflexUltima
    go (Nothing : Just Mark.Acute : xs) | allEmptyAccents xs = Just Word.AccentAcutePenult
    go (Nothing : Just Mark.Circumflex : xs) | allEmptyAccents xs = Just Word.AccentCircumflexPenult
    go (Nothing : Nothing : Just Mark.Acute : xs) | allEmptyAccents xs = Just Word.AccentAcuteAntepenult
    go xs | allEmptyAccents xs = Just Word.AccentNone
    go _ = Nothing

allEmptyAccents :: [Maybe Mark.AcuteCircumflex] -> Bool
allEmptyAccents = all Maybe.isNothing
