-- | -- Module : Melodics.Ukrainian -- Copyright : (c) OleksandrZhabenko 2019 -- License : MIT -- -- Maintainer : olexandr543@yahoo.com -- -- A program that can be used as a musical instrument synthesizer or for Ukrainian speech synthesis -- especially for poets, translators and writers. -- module Melodics.Ukrainian ( appendS16LEFile, convertToProperUkrainian, nSymbols ) where import Data.Char import Data.List (groupBy) import qualified Data.Vector as V import qualified Data.ByteString.Lazy as B import System.IO import CaseBi import Data.List.InnToOut.Basic import Paths_mmsyn6ukr {- -- Inspired by: https://mail.haskell.org/pipermail/beginners/2011-October/008649.html -} data Triple = Z | O | T deriving (Eq,Ord,Show,Read) takeData :: FilePath -> IO B.ByteString takeData file = do data1 <- B.readFile file let dataN = B.drop 44 data1 in return dataN -- | The function that actually produces a .raw file. appendS16LEFile :: V.Vector String -> Handle -> IO () appendS16LEFile xs hdl | not (V.null xs) = do dataFileList <- mapM getDataFileName ["0.wav", "1.wav", "A.wav", "B.wav", "C.wav", "D.wav", "E.wav", "F.wav", "G.wav", "H.wav", "I.wav", "J.wav", "K.wav", "L.wav", "M.wav", "N.wav", "O.wav", "P.wav", "Q.wav", "R.wav", "S.wav", "T.wav", "U.wav", "V.wav", "W.wav", "X.wav", "Y.wav", "Z.wav", "a.wav", "b.wav", "c.wav", "d.wav", "e.wav", "f.wav"] dataList <- V.mapM takeData . V.fromList $! dataFileList V.mapM_ (\u -> if V.all (\z -> B.length z > 0) dataList then let rs = "new." ++ (tail . dropWhile (/= ' ') . takeWhile (/= '}') . show $ hdl) in do B.appendFile rs $ dataList V.! (getBFst' (0, V.fromList [("0", 0), ("1", 1), ("а", 2), ("б", 3), ("в", 4), ("г", 5), ("д", 6), ("дж", 7), ("дз", 8), ("е", 9), ("ж", 10), ("з", 11), ("и", 12), ("й", 13), ("к", 14), ("л", 15), ("м", 16), ("н", 17), ("о", 18), ("п", 19), ("р", 20), ("с", 21), ("сь", 22), ("т", 23), ("у", 24), ("ф", 25), ("х", 26), ("ц", 27), ("ць", 28), ("ч", 29), ("ш", 30), ("ь", 31), ("і", 32), ("ґ", 33)]) u) else error "Data sound file is not read!") xs hClose hdl | otherwise = return () -- | The function that converts a written Ukrainian text into the sounding in the program phonetical respesentation. -- It is not exact phonetically but you can make for yourself a general imression of the Ukrainian sounding. convertToProperUkrainian :: String -> V.Vector String convertToProperUkrainian ys = toVector . correctA . createTuplesByAnalysis . filterUkr $ ys filterUkr :: String -> String filterUkr xs = concatMap (\x -> if isUkrainian x then [toLower x] else if isSpace x || isControl x then [x] else []) xs createTuplesByAnalysis :: String -> [(String, Triple)] createTuplesByAnalysis x@(y:ys) | canChange [y] == O = ("1", Z):createTuplesByAnalysis ys | canChange [y] == T = applyChanges . initialA . groupBy isSimilar . changeJotted . wasFstConverted $ x | otherwise = ([y], Z):createTuplesByAnalysis ys createTuplesByAnalysis _ = [] canChange :: String -> Triple canChange ~(x:_) | isSpace x || isControl x = O | getBFst' (False, V.fromList $ zip ['\1075','\1076','\1079','\1078','\1082','\1087','\1089','\1090','\1092','\1093','\1094','\1095','\1096'] (repeat True)) x = T | otherwise = Z isVoicedObstruent :: String -> Bool isVoicedObstruent xs | not (null xs) = getBFst' (False, V.fromList $ zip ["\1073","\1075","\1076","\1076\1078","\1076\1079","\1078","\1079","\1169"] (repeat True)) xs | otherwise = False initialA :: [String] -> [(String, Triple)] initialA (t:ts) | null t = initialA ts | tu == O = ("_", Z):initialA (tail t:ts) | (tu == T) = if getBFst' (False, V.fromList $ zip ["\1076","\1085","\1089","\1090","\1093","\1094"] (repeat True)) ht then let (us,vs) = splitAt 2 t in if getBFst' (False, V.fromList $ zip ["\1076\1078","\1076\1079","\1085\1090","\1089\1090","\1089\1100","\1090\1089","\1090\1100","\1093\1075","\1094\1100"] (repeat True)) us then (us, T):initialA (vs:ts) else (ht, T):initialA (tail t:ts) else case (getBFst' (False, V.fromList $ zip ["\1075","\1078","\1079","\1082","\1092","\1095","\1096"] (repeat True)) ht) of ~True -> (ht, T):initialA (tail t:ts) | otherwise = (ht, Z):initialA (tail t:ts) where ht = [head t] tu = canChange ht initialA _ = [] wasFstConverted :: String -> String wasFstConverted = mapI mustBeConverted convertionFst mustBeConverted :: Char -> Bool mustBeConverted c = getBFst' (False, V.fromList $ zip "'\700\1097\1102\1103\1108\1111\8217" (repeat True)) c convertionFst :: Char -> String convertionFst u = getBFst' ([u], V.fromList $ zip "'\700\1097\1102\1103\1108\1111\8217" ["0","0","\1096\1095","\1081\1091","\1081\1072","\1081\1077","\1081\1110","0"]) u isConsonant :: Char -> Bool isConsonant = getBFst' (False, V.fromList $ zip "\1073\1074\1075\1076\1078\1079\1081\1082\1083\1084\1085\1087\1088\1089\1090\1092\1093\1094\1095\1096\1169" (repeat True)) changeJotted :: String -> String changeJotted (x:y:z:zs) | (not (isNotVowel z)) && (y == '\1081') && (isConsonant x) = x:'\1100':z:changeJotted zs | isConsonant x && y == '\1110' = x:'\1100':y:changeJotted (z:zs) | otherwise = x:changeJotted (y:z:zs) changeJotted xs = xs isNotVowel :: Char -> Bool isNotVowel = getBFst' (True, V.fromList $ zip "\1072\1077\1080\1086\1091\1102\1103\1108\1110\1111" (repeat False)) isSimilar :: Char -> Char -> Bool isSimilar x y = isNotVowel x && isNotVowel y applyChanges :: [(String, Triple)] -> [(String, Triple)] applyChanges (z:t:zs) | snd z == T = getBFst' ((fst z, Z), V.fromList . zip ["\1075","\1076","\1076\1079","\1078","\1079","\1082","\1085\1090", "\1087","\1089","\1089\1090","\1089\1100","\1090","\1090\1089","\1090\1100","\1092","\1093","\1093\1075","\1094","\1094\1100","\1095","\1096"] $ [гT zs, дT zs, дзT zs, жT zs, зT zs, кT zs, нтT zs, пT zs, сT zs, стT zs, сьT zs, тT zs, тсT zs, тьT zs, фT zs, хT zs, хгT zs, цT zs, цьT zs, чT zs, шT zs]) (fst z):applyChanges (t:zs) | otherwise = z:applyChanges (t:zs) applyChanges [(xs, _)] = [(xs, Z)] applyChanges _ = [] (===) :: Eq a => a -> [a] -> Bool (===) x ys = or . map (\y -> x == y) $ ys -- in the further ??T functions the last (, T) means that it must be afterwards be separated with the soft sign into two tuples (1 additional function in the composition) -- need further processing means that there should be additional checks and may be transformations. May be they can be omitted isSoftDOrL :: [(String, Triple)] -> Bool isSoftDOrL xs = getBFst' (False, V.fromList . zip ["\1073\1100","\1074\1100","\1076\1100","\1079\1100","\1083\1100", "\1084\1100","\1085\1100","\1087\1100","\1089\1100","\1090\1100","\1092\1100","\1094\1100"] $ (repeat True)) (takeFromFT_ 2 xs) isSoftDen :: [(String, Triple)] -> Bool isSoftDen xs = getBFst' (False, V.fromList . zip ["\1076\1100","\1079\1100","\1083\1100","\1085\1100","\1089\1100", "\1090\1100","\1094\1100"] $ (repeat True)) (takeFromFT_ 2 xs) || takeFromFT_ 3 xs == "\1076\1079\1100" гT :: [(String, Triple)] -> (String, Triple) гT (t:_) | head (fst t) == '\1082' || head (fst t) == '\1090' = ("\1093", Z) | otherwise = ("\1075", Z) гT _ = ("г", Z) дT :: [(String, Triple)] -> (String, Triple) дT t1@(_:_) | takeFromFT_ 1 t1 === ["\1078","\1095","\1096"] = ("\1076\1078", Z) -- need further processing д дж | takeFromFT_ 2 t1 === ["\1089\1100","\1094\1100"] = ("\1076\1079\1100", T) -- need further processing д дзь | takeFromFT_ 1 t1 === ["\1079","\1089","\1094"] = ("\1076\1079", Z) -- need further processing д дз | otherwise = ("\1076", Z) дT _ = ("д", Z) дзT :: [(String, Triple)] -> (String, Triple) дзT t1@(_:_) | isSoftDOrL t1 = ("\1076\1079\1100", T) | otherwise = ("\1076\1079", Z) дзT _ = ("дз", Z) жT :: [(String, Triple)] -> (String, Triple) жT t1@(_:_) | takeFromFT 2 t1 === ["\1089\1100","\1094\1100"] = ("\1079\1100", T) | otherwise = ("\1078", Z) жT _ = ("ж", Z) зT :: [(String, Triple)] -> (String, Triple) зT t1@(_:_) | takeFromFT_ 1 t1 === ["\1078","\1095","\1096"] || takeFromFT_ 2 t1 == "\1076\1078" = ("\1078", Z) | isSoftDOrL t1 = ("\1079\1100", T) | takeFromFT 1 t1 === ["\1095","\1096"] = ("\1096", Z) -- need further processing з ш | takeFromFT 1 t1 === ["\1089","\1094"] || takeFromFT_ 1 t1 === ["\1082","\1087","\1090","\1092","\1093"] = ("\1089", Z) -- need further processing з с | otherwise = ("\1079", Z) зT _ = ("з", Z) кT :: [(String, Triple)] -> (String, Triple) кT t1@(_:_) | isVoicedObstruent (takeFromFT_ 1 t1) || isVoicedObstruent (takeFromFT_ 2 t1) = ("\1169", Z) | otherwise = ("\1082", Z) кT _ = ("к", Z) нтT :: [(String, Triple)] -> (String, Triple) нтT t1@(_:_) | takeFromFT 2 t1 == "\1089\1090" = ("\1085", Z) | takeFromFT 3 t1 == "\1089\1100\1082" = ("\1085\1100", T) | otherwise = ("\1085\1090", Z) нтT _ = ("нт", T) пT :: [(String, Triple)] -> (String, Triple) пT t1@(_:_) | isVoicedObstruent (takeFromFT_ 1 t1) || isVoicedObstruent (takeFromFT_ 2 t1) = ("\1073", Z) | otherwise = ("\1087", Z) пT _ = ("п", Z) сT :: [(String, Triple)] -> (String, Triple) сT t1@(_:_) | (isVoicedObstruent (takeFromFT_ 1 t1) && drop 1 (takeFromFT_ 2 t1) == "\1100") || (isVoicedObstruent (takeFromFT_ 2 t1) && drop 2 (takeFromFT_ 3 t1) == "\1100") = ("\1079\1100", T) | isVoicedObstruent (takeFromFT_ 1 t1) || isVoicedObstruent (takeFromFT_ 2 t1) = ("\1073", Z) | isSoftDOrL t1 = ("\1089\1100", Z) | takeFromFT_ 1 t1 == "\1096" = ("\1096", Z) | otherwise = ("\1089", Z) сT _ = ("с", Z) стT :: [(String, Triple)] -> (String, Triple) стT t1@(_:_) | isVoicedObstruent (takeFromFT_ 1 t1) || isVoicedObstruent (takeFromFT_ 2 t1) = ("\1079", Z) | takeFromFT_ 3 t1 == "\1089\1100\1082" || takeFromFT_ 2 t1 == "\1094\1100" = ("\1089\1100", Z) | takeFromFT_ 1 t1 === ["\1089","\1085"] = ("\1089", Z) | takeFromFT_ 1 t1 == "\1095" = ("\1096", Z) | otherwise = ("\1089\1090", T) стT _ = ("ст", T) сьT :: [(String, Triple)] -> (String, Triple) сьT t1@(_:_) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1079\1100", T) | otherwise = ("\1089\1100", Z) сьT _ = ("сь", Z) тT :: [(String, Triple)] -> (String, Triple) тT t1@(_:_) | (isVoicedObstruent (takeFromFT_ 1 t1) && drop 1 (takeFromFT_ 2 t1) == "\1100") || (isVoicedObstruent (takeFromFT_ 2 t1) && drop 2 (takeFromFT_ 3 t1) == "\1100") = ("\1076\1100", T) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1076", Z) | takeFromFT_ 2 t1 == "\1094\1100" = ("\1094\1100", Z) | takeFromFT_ 1 t1 == "\1094" = ("\1094", Z) | isSoftDen t1 = ("\1090\1100", T) | takeFromFT_ 1 t1 === ["\1095","\1096"] = ("\1095", Z) | otherwise = ("\1090", Z) тT _ = ("т", Z) тсT :: [(String, Triple)] -> (String, Triple) тсT _ = ("\1094", Z) тьT :: [(String, Triple)] -> (String, Triple) тьT t1@(_:_) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1076\1100", T) | takeFromFT_ 3 t1 == "\1089\1100\1072" = ("\1094\1100", Z) | otherwise = ("\1090\1100", T) тьT _ = ("ть", T) фT :: [(String, Triple)] -> (String, Triple) фT t1@(_:_) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1074", Z) | otherwise = ("\1092", Z) фT _ = ("ф", Z) хT :: [(String, Triple)] -> (String, Triple) хT t1@(_:_) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1075", Z) | otherwise = ("\1093", Z) хT _ = ("х", Z) хгT :: [(String, Triple)] -> (String, Triple) хгT _ = ("\1075", Z) цT :: [(String, Triple)] -> (String, Triple) цT t1@(_:_) | (isVoicedObstruent (takeFromFT_ 1 t1) && drop 1 (takeFromFT_ 2 t1) == "\1100") || (isVoicedObstruent (takeFromFT_ 2 t1) && drop 2 (takeFromFT_ 3 t1) == "\1100") = ("\1076\1079\1100", T) | isSoftDOrL t1 = ("\1094\1100", Z) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1076\1079", Z) | otherwise = ("\1094", Z) цT _ = ("ц", Z) цьT :: [(String, Triple)] -> (String, Triple) цьT t1@(_:_) | (isVoicedObstruent (takeFromFT_ 1 t1) && drop 1 (takeFromFT_ 2 t1) == "\1100") || (isVoicedObstruent (takeFromFT_ 2 t1) && drop 2 (takeFromFT_ 3 t1) == "\1100") = ("\1076\1079\1100", T) | otherwise = ("\1094\1100", Z) цьT _ = ("ць", Z) чT :: [(String, Triple)] -> (String, Triple) чT t1@(_:_) | takeFromFT_ 2 t1 === ["\1089\1100","\1094\110"] = ("\1094\1100", Z) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1076\1078", Z) | otherwise = ("\1095", Z) чT _ = ("ч", Z) шT :: [(String, Triple)] -> (String, Triple) шT t1@(_:_) | takeFromFT_ 2 t1 === ["\1089\1100","\1094\110"] = ("\1089\1100", Z) | isVoicedObstruent (takeFromFT_ 2 t1) || isVoicedObstruent (takeFromFT_ 1 t1) = ("\1078", Z) | otherwise = ("\1096", Z) шT _ = ("ш", Z) correctA :: [(String, Triple)] -> [(String, Triple)] correctA = correctSomeW . separateSoftS separateSoftS :: [(String, Triple)] -> [(String, Triple)] separateSoftS xs = mapI (\x -> snd x == T) divideToParts xs divideToParts :: (String, Triple) -> [(String, Triple)] divideToParts (xs, _) = [(init xs, Z),([last xs], Z)] correctSomeW :: [(String, Triple)] -> [(String, Triple)] correctSomeW (x:y:z:xs) | fst x == "\1094\1100" && fst y == "\1089\1100" && fst z == "\1072" = x:("\1094\1100", Z):z:correctSomeW xs | fst x == "1" && fst y == "\1081" && fst z == "\1072" = if takeFromFT 2 xs == "\1095\1085" then x:y:z:("\1096", Z):correctSomeW (tail xs) else x:correctSomeW (y:z:xs) correctSomeW zs = zs takeFromFT :: Int -> [(String, Triple)] -> String takeFromFT n ts | compare n 0 == GT = if null ts then [] else if compare k n /= LT then take n ks else ks ++ takeFromFT (n - length ks) (tail ts) | otherwise = [] where ks = fst (head ts) k = length ks takeFromFT_ :: Int -> [(String, Triple)] -> String takeFromFT_ n ts = takeFromFT n (map (\(xs, y) -> (filter (/='_') xs, y)) ts) toVector :: [(String, Triple)] -> V.Vector String toVector ts = V.fromList . map fst $ ts isUkrainian :: Char -> Bool isUkrainian y | (y >= '\1040' && y <= '\1065') || (y >= '\1070' && y <= '\1097') = True | otherwise = getBFst' (False, V.fromList . map (\x -> (x, True)) $ "'\700\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217") y nSymbols :: String -> Int nSymbols xs | null xs = 31416::Int | otherwise = getBFst' (31416::Int, V.generate 10 (\n -> (n, (10^n + 1)::Int))) (let temp = read xs::Int in if temp <= 9 && temp >= 1 then temp else error "Please, specify a digit as a command line argument for the program!")