-- | -- Module : Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations -- Copyright : (c) OleksandrZhabenko 2020 -- License : MIT -- Stability : Experimental -- Maintainer : olexandr543@yahoo.com -- -- Can be used to calculate the durations of the approximations of the Ukrainian phonemes -- using some prepared text with its correct (at least mostly) pronunciation. -- The prepared text is located in the same directory and contains lines --- the -- Ukrainian word and its duration in seconds separated with whitespace. -- The library is intended to use the functionality of the : -- -- 1) R programming language https://www.r-project.org/ -- -- 2) Rglpk library https://cran.r-project.org/web/packages/Rglpk/index.html -- -- 3) GNU GLPK library https://www.gnu.org/software/glpk/glpk.html -- -- For more information, please, see the documentation for them. -- {-# LANGUAGE CPP #-} module Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations where #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__>=710 /* code that applies only to GHC 7.10.* and higher versions */ import GHC.Base (mconcat) #endif #endif import Data.Monoid import Text.Read import Data.Maybe import CaseBi (getBFst') import qualified Data.Vector as VB import Numeric import Data.List (intercalate) #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__==708 /* code that applies only to GHC 7.8.* */ mconcat = concat #endif #endif createCoeffsObj :: Int -> [String] -> [Double] createCoeffsObj l xss | length xss < l = f (xss `mappend` replicate (l - length xss) "1.0") | otherwise = f (take l xss) where f tss = map (\ts -> fromMaybe 1.0 (readMaybe ts::Maybe Double)) tss countCharInWords :: [String] -> Char -> [Int] countCharInWords xss x | null xss = [] | otherwise = map (length . filter (== x)) xss matrix1Column :: [String] -> String -> Char -> [Int] matrix1Column xss js x = pairwiseComparings x (countCharInWords xss x `mappend` rs `mappend` rs) where l = length js iX = fromMaybe (-l - 1) (VB.findIndex (== x) . VB.fromList $ js) rs = if iX < 0 then [] else replicate iX 0 `mappend` [1] `mappend` replicate (l - 1 - iX) 0 pairwiseComparings :: Char -> [Int] -> [Int] pairwiseComparings x ys | x == 'f' = ys `mappend` [10,10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'v' = ys `mappend` [-5,-20,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'x' = ys `mappend` [0,0,10,10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'h' = ys `mappend` [0,0,-7,-13,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'g' = ys `mappend` [0,0,0,0,10,10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'k' = ys `mappend` [0,0,0,0,-7,-13,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] | x == 'j' = ys `mappend` [0,0,0,0,0,0,10,10,0,0,10,10,0,0,0,0,0,0,0,0,10,10,0,0] | x == 'B' = ys `mappend` [0,0,0,0,0,0,-10,-15,0,0,0,0,0,0,0,0,0,0,10,10,0,0,0,0] | x == 'A' = ys `mappend` [0,0,0,0,0,0,0,0,10,10,0,0,0,0,0,0,0,0,0,0,0,0,10,10] | x == 'z' = ys `mappend` [0,0,0,0,0,0,0,0,-10,-15,0,0,0,0,0,0,10,10,0,0,0,0,0,0] | x == 'd' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,-7,-13,0,0,10,10,0,0,0,0,0,0,0,0] | x == 'b' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,10,10,0,0,0,0,0,0,0,0,0,0] | x == 'p' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,-7,-13,0,0,0,0,0,0,0,0,0,0] | x == 't' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,-7,-13,0,0,0,0,0,0,0,0] | x == 's' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-7,-13,0,0,0,0,0,0] | x == 'F' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-7,-13,0,0,0,0] | x == 'E' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-8,-14,0,0] | x == 'c' = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-8,-14] | otherwise = ys `mappend` [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] -- | Actually @n@ is a 'length' bss. matrixLine :: [String] -> String -> Int -> String matrixLine bss js n | null bss || n <=0 = [] | otherwise = "mat1 <- matrix(c(" `mappend` (intercalate ", " . map show $ (concatMap (matrix1Column (bss `mappend` bss) js) js)) `mappend` "), nrow = " `mappend` show (2 * n + 2 * length js + 24) `mappend` ")\n" objLine :: VB.Vector Double -> String objLine v | VB.length v >= 32 = "obj1 <- c(" `mappend` (intercalate ", " . map (\t -> showFFloat Nothing t "") $ objCoeffs v) `mappend` ")\n" | otherwise = error "Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations.objLine: Not defined for the short argument. " objCoeffs :: VB.Vector Double -> [Double] objCoeffs v = let tuple = (1.0,VB.fromList [(0, VB.unsafeIndex v 14), (1, VB.unsafeIndex v 16), (2, VB.unsafeIndex v 9), (3, VB.unsafeIndex v 17), (4, VB.unsafeIndex v 18), (5, VB.unsafeIndex v 1), (6, VB.unsafeIndex v 2), (7, VB.unsafeIndex v 3), (8, VB.unsafeIndex v 19), (9, VB.unsafeIndex v 20), (10, VB.unsafeIndex v 21), (11, VB.unsafeIndex v 4), (12, VB.unsafeIndex v 22), (13, VB.unsafeIndex v 23), (14, VB.unsafeIndex v 24), (15, VB.unsafeIndex v 5), (16, VB.unsafeIndex v 25), (17, VB.unsafeIndex v 26), (18, VB.unsafeIndex v 10), (19, VB.unsafeIndex v 11), (20, VB.unsafeIndex v 12), (21, VB.unsafeIndex v 6), (22, VB.unsafeIndex v 27), (23, VB.unsafeIndex v 0), (24, VB.unsafeIndex v 13), (25, VB.unsafeIndex v 28), (26, VB.unsafeIndex v 29), (27, VB.unsafeIndex v 7), (28, VB.unsafeIndex v 14), (29, VB.unsafeIndex v 30), (30, VB.unsafeIndex v 8), (31, VB.unsafeIndex v 31)]) in VB.toList . VB.take 32 . VB.map (getBFst' tuple) . VB.enumFromTo 0 $ 31 maxLine :: String maxLine = "max1 <- TRUE\n" dirLine :: [String] -> String -> String dirLine bss js = "dir1 <- c(\"<" `mappend` g "<" bss `mappend` "\", \">" `mappend` g ">" (bss `mappend` map (:[]) js) `mappend` "\"" `mappend` h0 32 `mappend` h 12 `mappend` ")\n" where g xs ys = (intercalate ("\", \"" `mappend` xs) . replicate (length ys) $ "=") h n = concat . replicate n $ ", \">=\", \"<=\"" h0 n = concat . replicate n $ ", \"<=\"" rhsLineG :: [Double] -> [Double] -> [Double] -> String rhsLineG zs xs ys = "rhs1 <- c(" `mappend` f (xs `mappend` ys `mappend` zs) `mappend` ")\n" where f ts = (intercalate ", " . map (\t -> showFFloat Nothing t "") $ ts) rhsLine :: [Double] -> [Double] -> String rhsLine = rhsLineG (minDurations `mappend` maxDurations `mappend` constraintsR1 12) constraintsR1 :: Int -> [Double] constraintsR1 n = replicate (2 * n) 0.0 minDurations ::[Double] minDurations = VB.toList v where v = VB.generate 32 (\i -> h i) h i | i == 23 = 0.02 | otherwise = getBFst' (0.06,VB.fromList . zip [7,11,15,21,27,30] $ replicate 6 0.2) i maxDurations :: [Double] maxDurations = replicate 32 0.3 answer :: VB.Vector Double -> [String] -> [Double] -> [Double] -> String -> String answer lsts bss xs ys js = mconcat ["library(\"Rglpk\")\n",objLine lsts,matrixLine bss js (length bss),dirLine bss js,rhsLine xs ys,maxLine, "\nk <- Rglpk_solve_LP(obj = obj1, mat = mat1, dir = dir1, rhs = rhs1, max = max1)\ny <- runif(32, min = -0.012, max = 0.012)\nif (k$status == 0){k$solution / mean(k$solution)} else {c()}", "\nif (k$status == 0){z<- k$solution * 0.02 / k$solution[24] + y; z[24] <- 0.02 + runif(1, min = -0.003, max = 0.003); z} else {c()}\n"] charReplace :: [Char] -> [Char] charReplace = concatMap g where g x | x == '-' = "X" | x == '0' = "Y" | x == 'w' = "cq" | x == 'D' = "sq" | otherwise = [x]