{-# LANGUAGE BangPatterns #-}
module Phonetic.Languages.EmphasisG where
import Data.Phonetic.Languages.Base
import Data.Phonetic.Languages.Syllables
import GHC.Int
import Data.Maybe (fromMaybe)
import Text.Read (readMaybe)
import Data.Char (toUpper)
import GHC.Arr
import Data.List (scanl',intersperse)
import CaseBi.Arr
import Data.Foldable (foldl')
import CaseBi.Arr (getBFst',getBFstLSorted')
import Data.Lists.FLines (newLineEnding)
import Data.Traversable (traverse)
import Control.Applicative
import System.IO
data SyllWeightsG = SyG {
point :: ![PRS]
, order :: !Int8 -- Is intended to begin at -128 up to 127 (maximum 256 entries).
, weight :: !Double
}
showFSG :: FlowSoundG -> String
showFSG = map charS
{-# INLINE showFSG #-}
type FlowSoundG = [PRS]
instance Show SyllWeightsG where
show (SyG ps i w) = showFSG ps `mappend` (' ':show i) `mappend` (' ':show w) `mappend` newLineEnding
weightSyllablesIO :: [FlowSoundG] -> IO [SyllWeightsG]
weightSyllablesIO = traverse (\(i,xs) -> (\d1 -> (SyG xs i d1)) <$> weightSyllAIO False xs) . zip ([-128..127]::[Int8])
weightStringIO
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> IO ([[FlowSoundG]],[SyllWeightsG],[[[Int8]]])
weightStringIO wrs ks arr hs us vs xs = weightSyllablesIO fss >>= \zs -> pure (tsss, zs, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss)
where tsss = createSyllablesPL wrs ks arr hs us vs xs
fss = [ ts | tss <- tsss , ts <- tss ]
weightStringNIO
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> Int
-> String
-> IO ([[FlowSoundG]],[[SyllWeightsG]],[[[Int8]]])
weightStringNIO wrs ks arr hs us vs n xs = traverse (\_-> weightSyllablesIO fss) [1..n] >>= \zss -> pure (tsss, zss, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss)
where tsss = createSyllablesPL wrs ks arr hs us vs xs
fss = [ ts | tss <- tsss , ts <- tss ]
weights2SyllableDurationsDArr :: [SyllWeightsG] -> Array Int (Int8,Double)
weights2SyllableDurationsDArr xs = listArray (0,l-1) . map (\(SyG _ i w) -> (i,w)) $ xs
where l = length xs
weights2SyllableDurationsD :: [SyllWeightsG] -> [[[Int8]]] -> [[Double]]
weights2SyllableDurationsD xs = map (map (k (getBFst' (4.0, weights2SyllableDurationsDArr xs))))
where k f = foldl' (\y x -> f x + y) 0
{-# INLINE weights2SyllableDurationsD #-}
helper1F :: [Int8] -> [[[Int8]]]
helper1F (x:y:ys) = map (:[]) [x..y-1]:helper1F (y:ys)
helper1F _ = []
weightSyllAIO :: Bool -> FlowSoundG -> IO Double
weightSyllAIO upper xs
| null xs = pure 4.0
| otherwise =
(\d -> fromMaybe 4.0 (readMaybe d::Maybe Double)) <$> (hPutStr stderr ("? " `mappend` ((if upper then map toUpper else id) . showFSG $ xs) `mappend` " ") *> getLine) -- Well, definitely it should not be 'stderr' here, but 'stdout' gives some strange behaviour, probably related to optimizations or some strange 'Handle' behaviour. (?)
data ReadyForConstructionPL = StrG String | FSLG [[[Int8]]] deriving (Eq,Ord)
showR :: ReadyForConstructionPL -> String
showR (StrG xs) = xs
showR (FSLG tsss) = show tsss
isStr :: ReadyForConstructionPL -> Bool
isStr (StrG _) = True
isStr _ = False
isFSL :: ReadyForConstructionPL -> Bool
isFSL (FSLG _) = True
isFSL _ = False
fromReadyFCPLS :: ReadyForConstructionPL -> Maybe String
fromReadyFCPLS (StrG xs) = Just xs
fromReadyFCPLS _ = Nothing
fromReadyFCPLF :: ReadyForConstructionPL -> Maybe [[[Int8]]]
fromReadyFCPLF (FSLG xsss) = Just xsss
fromReadyFCPLF _ = Nothing
helper2F :: [b] -> [a] -> [c] -> [[d]] -> [([b],[a],[c])]
helper2F vs xs ys tss = let (us,ks,rs) = unzip3 . zip3 vs xs $ ys in
helper2F' us ks rs tss
where helper2F' us@(_:_) ks@(_:_) rs@(_:_) tss@(ts:wss) =
let l = length ts
(wws,vvs) = splitAt l us
(qs,ps) = splitAt l ks
(ns,ms) = splitAt l rs
in (wws,qs,ns):helper2F' vvs ps ms wss
helper2F' _ _ _ _ = []
convF1
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> [[FlowSoundG]]
convF1 wrs ks arr hs us vs xs
| null xs = []
| otherwise = [ tss | tss <- createSyllablesPL wrs ks arr hs us vs xs ]
convF3
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> [([String],[[Int8]],[FlowSoundG])]
convF3 wrs ks arr hs us vs xs
| null xs = [([],[],[])]
| otherwise = helper2F (concatMap (map showFSG) tsss) (map (:[]) ([-128..127]::[Int8])) [ ts | tss <- qss, ts <- tss ] qss
where tsss = createSyllablesPL wrs ks arr hs us vs xs
qss = [ tss | tss <- tsss ]
convF3W
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> [(String,[[Int8]])]
convF3W wrs ks arr hs us vs xs
| null xs = [([],[])]
| otherwise = zipWith (\(_,ys,_) ts -> (ts,ys)) (convF3 wrs ks arr hs us vs xs) . words $ xs
convFI
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> String
-> [[[Int8]]]
convFI wrs ks arr hs us vs ts = map f . words
where !f = getBFstL' [] (convF3W wrs ks arr hs us vs ts)
convFSL
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String
-> ReadyForConstructionPL
-> String
convFSL wrs ps arr hs us vs ts r@(StrG xs) = concat . concat . intersperse [" "] . map (\(ks,_,_)-> ks) . convF3 wrs ps arr hs us vs $ xs
where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts
convFSL wrs ps arr hs us vs ts r@(FSLG tsss) = concat . concat . intersperse [" "] . map (map (getBFstLSorted' " " ks) ) $ tsss
where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 wrs ps arr hs us vs $ ts
ks = zip (concat . fst $ js) (concat . snd $ js)
weightsString3IO
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> Bool
-> String
-> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL)
weightsString3IO wrs ps arr hs us vs bool bs
| bool = do
(syllDs1,sylws,fsls0) <- weightStringIO wrs ps arr hs us vs bs
let syllableDurationsD2s = [weights2SyllableDurationsD sylws]
return (syllDs1,syllableDurationsD2s,FSLG fsls0)
| otherwise = return ([],[],FSLG [])
weightsString3NIO
:: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.
-> [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon
-- (e. g. allophones). Must be sorted in the ascending order to be used correctly.
-> CharPhoneticClassification -- ^ The 'Array' 'Int' 'PRS' must be sorted in the ascending order to be used in the module correctly.
-> SegmentRulesG
-> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.
-> Int
-> Bool
-> String
-> IO ([[FlowSoundG]],[[[[Int8]]] -> [[Double]]],ReadyForConstructionPL)
weightsString3NIO wrs ps arr hs us vs n bool bs
| bool = (\(syllDs1,sylws,fsls0) -> (syllDs1,map weights2SyllableDurationsD sylws,FSLG fsls0)) <$> weightStringNIO wrs ps arr hs us vs n bs
| otherwise = pure ([],[],FSLG [])