{-# LANGUAGE BangPatterns #-}
module Phonetic.Languages.Emphasis where
import Languages.Phonetic.Ukrainian.Syllable.ArrInt8
import Melodics.Ukrainian.ArrInt8
import Languages.Phonetic.Ukrainian.Syllable.Double.ArrInt8 (syllableDurationsGD)
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 CaseBi.Arr (getBFst',getBFstLSorted')
import Data.Lists.FLines (newLineEnding)
import Data.Traversable (traverse)
import Control.Applicative
import System.IO
data SyllWeights = Sy {
point :: !FlowSound
, order :: !Int8 -- Is intended to begin at -128 up to 0 (maximum 129 entries).
, weight :: !Double
}
instance Show SyllWeights where
show (Sy ps i w) = showFS ps `mappend` (' ':show i) `mappend` (' ':show w) `mappend` newLineEnding
weightSyllablesIO :: [FlowSound] -> IO [SyllWeights]
weightSyllablesIO = traverse (\(i,xs) -> (\d1 -> (Sy xs i d1)) <$> weightSyllAIO False xs) . zip ([-128..0]::[Int8])
weightStringIO :: String -> IO ([[FlowSound]],[SyllWeights],[[FlowSound]])
weightStringIO xs = weightSyllablesIO fss >>= \zs -> pure (tsss, zs, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss)
where tsss = createSyllablesUkrS xs
fss = [ ts | tss <- tsss , ts <- tss ]
weightStringNIO :: Int -> String -> IO ([[FlowSound]],[[SyllWeights]],[[FlowSound]])
weightStringNIO n xs = traverse (\_-> weightSyllablesIO fss) [1..n] >>= \zss -> pure (tsss, zss, helper1F . scanl' (+) (-128::Int8) . map (fromIntegral . length) $ tsss)
where tsss = createSyllablesUkrS xs
fss = [ ts | tss <- tsss , ts <- tss ]
weights2SyllableDurationsDArr :: [SyllWeights] -> Array Int (Sound8,Double)
weights2SyllableDurationsDArr xs = listArray (0,l-1) . map (\(Sy _ i w) -> (i,w)) $ xs
where l = length xs
weights2SyllableDurationsD :: [SyllWeights] -> [[[Sound8]]] -> [[Double]]
weights2SyllableDurationsD xs = syllableDurationsGD (getBFst' (4.0, weights2SyllableDurationsDArr xs))
{-# INLINE weights2SyllableDurationsD #-}
helper1F :: [Int8] -> [[FlowSound]]
helper1F (x:y:ys) = map (:[]) [x..y-1]:helper1F (y:ys)
helper1F _ = []
weightSyllAIO :: Bool -> FlowSound -> 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) . showFS $ 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 ReadyForConstructionUkr = Str String | FSL [[FlowSound]] deriving (Eq,Ord)
showR :: ReadyForConstructionUkr -> String
showR (Str xs) = xs
showR (FSL tsss) = show tsss
isStr :: ReadyForConstructionUkr -> Bool
isStr (Str _) = True
isStr _ = False
isFSL :: ReadyForConstructionUkr -> Bool
isFSL (FSL _) = True
isFSL _ = False
fromReadyFCUkrS :: ReadyForConstructionUkr -> Maybe String
fromReadyFCUkrS (Str xs) = Just xs
fromReadyFCUkrS _ = Nothing
fromReadyFCUkrF :: ReadyForConstructionUkr -> Maybe [[FlowSound]]
fromReadyFCUkrF (FSL xsss) = Just xsss
fromReadyFCUkrF _ = Nothing
helper2F :: [b] -> [a] -> [a] -> [[a]] -> [([b],[a],[a])]
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 :: String -> [[FlowSound]]
convF1 xs
| null xs = []
| otherwise = [ tss | tss <- createSyllablesUkrS xs ]
convF3 :: String -> [([String],[FlowSound],[FlowSound])]
convF3 xs
| null xs = [([],[],[])]
| otherwise = helper2F (concatMap (map showFS) tsss) (map (:[]) ([-128..0]::[Int8])) [ ts | tss <- qss, ts <- tss ] qss
where tsss = createSyllablesUkrS xs
qss = [ tss | tss <- tsss ]
convF3W :: String -> [(String,[FlowSound])]
convF3W xs
| null xs = [([],[])]
| otherwise = zipWith (\(_,ys,_) ts -> (ts,ys)) (convF3 xs) . words $ xs
convFI :: String -> String -> [[FlowSound]]
convFI ts = map f . words
where !f = getBFstL' [] (convF3W ts)
convFSL :: String -> ReadyForConstructionUkr -> String
convFSL ts r@(Str xs) = concat . concat . intersperse [" "] . map (\(ks,_,_)-> ks) . convF3 $ xs
where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 $ ts
convFSL ts r@(FSL tsss) = concat . concat . intersperse [" "] . map (map (getBFstLSorted' " " ks) ) $ tsss
where js = unzip . map (\(rs,ps,_) -> (ps,rs)) . convF3 $ ts
ks = zip (concat . fst $ js) (concat . snd $ js)
weightsString3IO :: Bool -> String -> IO ([[FlowSound]],[[[FlowSound]] -> [[Double]]],ReadyForConstructionUkr)
weightsString3IO bool bs
| bool = do
(syllDs1,sylws,fsls0) <- weightStringIO bs
let syllableDurationsD2s = [weights2SyllableDurationsD sylws]
return (syllDs1,syllableDurationsD2s,FSL fsls0)
| otherwise = return ([],[],FSL [])
weightsString3NIO :: Int -> Bool -> String -> IO ([[FlowSound]],[[[FlowSound]] -> [[Double]]],ReadyForConstructionUkr)
weightsString3NIO n bool bs
| bool = (\(syllDs1,sylws,fsls0) -> (syllDs1,map weights2SyllableDurationsD sylws,FSL fsls0)) <$> weightStringNIO n bs
| otherwise = pure ([],[],FSL [])