diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,3 +22,8 @@ ## 0.3.0.0 -- 2021-10-31 * Third version. Switched back to the CaseBi.Arr.getBFstLSorted' functionality. + +## 0.4.0.0 -- 2021-11-03 + +* Fourth version. Added Int8-based optimized functionality.The modules that do not use Int8 after ugrading the +phonetic-languages-simplified-examples-array to the Int8-based functionality are planned to be moved to a new package. diff --git a/Languages/Phonetic/Ukrainian/Syllable/ArrInt8.hs b/Languages/Phonetic/Ukrainian/Syllable/ArrInt8.hs new file mode 100644 --- /dev/null +++ b/Languages/Phonetic/Ukrainian/Syllable/ArrInt8.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} + +-- | +-- Module : Languages.Phonetic.Ukrainian.Syllable.ArrInt8 +-- Copyright : (c) OleksandrZhabenko 2021 +-- License : MIT +-- Stability : Experimental +-- Maintainer : olexandr543@yahoo.com +-- +-- This module works with syllable segmentation in Ukrainian. It is rewritten +-- module MMSyn7.Syllable from the @mmsyn7s@ package : https://hackage.haskell.org/package/mmsyn7s +-- + +module Languages.Phonetic.Ukrainian.Syllable.ArrInt8 where + +import Prelude hiding (mappend) +import Data.Monoid +import Data.Typeable +import qualified Data.List as L (groupBy) +import Melodics.ByteString.Ukrainian.ArrInt8 +import CaseBi.Arr +import GHC.Int +import Data.List.InnToOut.Basic (mapI) +import Data.Maybe (mapMaybe) + +-- Inspired by: https://github.com/OleksandrZhabenko/mm1/releases/tag/0.2.0.0 + +-- | Function-predicate 'isVowel1' checks whether its argument is a vowel representation in the 'Sound8' format. +isVowel1 :: Sound8 -> Bool +isVowel1 x = x > 0 && x < 7 +{-# INLINE isVowel1 #-} + +-- | Function-predicate 'isSonorous1' checks whether its argument is a sonorous consonant representation in the 'Sound8' format. +isSonorous1 :: Sound8 -> Bool +isSonorous1 x = x > 26 && x < 38 +{-# INLINE isSonorous1 #-} + +-- | Function-predicate 'isVoicedC1' checks whether its argument is a voiced consonant representation in the 'Sound8' format. +isVoicedC1 :: Sound8 -> Bool +isVoicedC1 x = x > 7 && x < 27 +{-# INLINE isVoicedC1 #-} + +-- | Function-predicate 'isVoiceless1' checks whether its argument is a voiceless consonant representation in the 'Sound8' format. +isVoicelessC1 :: Sound8 -> Bool +isVoicelessC1 x = x > 37 && x < 54 +{-# INLINE isVoicelessC1 #-} + +-- | Binary function-predicate 'isNotVowel2' checks whether its arguments are both consonant representations in the 'Sound8' format. +isNotVowel2 :: Sound8 -> Sound8 -> Bool +isNotVowel2 x y = x > 6 && y > 6 +{-# INLINE isNotVowel2 #-} + +-- | Function 'sndGroups' converts a Ukrainian word being a list of 'Sound8' to the list of phonetically similar (consonants grouped with consonants and each vowel separately) +-- sounds representations in 'Sound8' format. +sndGroups :: FlowSound -> [FlowSound] +sndGroups ys@(_:_) = L.groupBy isNotVowel2 ys +sndGroups _ = [] + +groupSnds :: FlowSound -> [FlowSound] +groupSnds = L.groupBy (\x y -> isVowel1 x == isVowel1 y) + +-- | Function 'divCnsnts' is used to divide groups of Ukrainian consonants into two-elements lists that later are made belonging to +-- different neighbour syllables if the group is between two vowels in a word. The group must be not empty, but this is not checked. +-- The phonetical information for the proper performance is taken from the: +-- https://msn.khnu.km.ua/pluginfile.php/302375/mod_resource/content/1/%D0%9B.3.%D0%86%D0%86.%20%D0%A1%D0%BA%D0%BB%D0%B0%D0%B4.%D0%9D%D0%B0%D0%B3%D0%BE%D0%BB%D0%BE%D1%81.pdf +divCnsnts :: FlowSound -> (FlowSound -> FlowSound,FlowSound -> FlowSound) +divCnsnts xs@(x:ys@(_:_:_:_)) + | isSonorous1 x || isVoicedC1 x = ((`mappend` [x]),mappend ys) + | otherwise = (id,mappend xs) +divCnsnts xs@(x:ys@(y:zs@(_:_))) + | isSonorous1 x = ((`mappend` [x]),mappend ys) + | isSonorous1 y = ((`mappend` [x,y]),mappend zs) + | otherwise = (id,mappend xs) +divCnsnts xs@(x:ys@(y:_)) + | (isSonorous1 x && (x `notEqC` y)) || (isVoicedC1 x && isVoicelessC1 y) = ((`mappend` [x]),mappend ys) + | otherwise = (id,mappend xs) +divCnsnts xs = (id,mappend xs) + +reSyllableCntnts :: [FlowSound] -> [FlowSound] +reSyllableCntnts (xs:ys:zs:xss) + | (> 6) . last $ ys = fst (divCnsnts ys) xs:reSyllableCntnts (snd (divCnsnts ys) zs:xss) + | otherwise = reSyllableCntnts ((xs `mappend` ys):zs:xss) +reSyllableCntnts (xs:ys:_) = [xs `mappend` ys] +reSyllableCntnts xss = xss + +divVwls :: [FlowSound] -> [FlowSound] +divVwls = mapI (\ws -> (length . filter isVowel1 $ ws) > 1) h3 + where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> isVowel1 x && y > 6) . drop 1 $ zs) + where (ys,zs) = span (>6) us + +createSyllablesUkrS :: String -> [[FlowSound]] +createSyllablesUkrS = map (divVwls . reSyllableCntnts . groupSnds) . words1 . convertToProperUkrainianI8 . + map (\x -> if x == '-' then ' ' else x) + where words1 xs = if null ts then [] else w : words1 s'' -- Practically this is an optimized version for this case 'words' function from Prelude. + where ts = dropWhile (< 1) xs + (w, s'') = span (> 0) ts + {-# NOINLINE words1 #-} +{-# INLINE createSyllablesUkrS #-} + +----------------------------------------------------- + +-- | Binary function-predicate 'notEqC' checks whether its arguments are not the same consonant sound representations (not taking palatalization into account). +notEqC :: Sound8 -> Sound8 -> Bool +notEqC x y + | x == 49 || x == 54 = + case y of + 49 -> False + 54 -> False + _ -> True + | x == 66 || x == 38 = + case y of + 38 -> False + 66 -> False + _ -> True + | x == y = False + | abs (x - y) == 1 = + getBFstLSorted' True ([(8,False),(10,False),(15,False),(17,False),(19,False),(21,False),(23,False),(25,False), + (28,False),(30,False),(32,False),(34,False),(36,False),(39,False),(41,False),(43,False),(45,False),(47,False), + (50,False),(52,False)]) . min x $ y + | otherwise = True + +-- | Function 'representProlonged' converts duplicated consequent in the syllable consonants +-- so that they are represented by just one 'Sound8'. After applying the function to the list of 'Sound8' being a syllable all groups of duplicated consequent consonants +-- in every syllable are represented with only one 'Sound8' respectively. +representProlonged :: FlowSound -> FlowSound +representProlonged (x:y:xs) + | isVowel1 x = x:representProlonged (y:xs) + | not . notEqC x $ y = y:representProlonged xs + | otherwise = x:representProlonged (y:xs) +representProlonged xs = xs diff --git a/Languages/Phonetic/Ukrainian/Syllable/Double/ArrInt8.hs b/Languages/Phonetic/Ukrainian/Syllable/Double/ArrInt8.hs new file mode 100644 --- /dev/null +++ b/Languages/Phonetic/Ukrainian/Syllable/Double/ArrInt8.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} +-- | +-- Module : Languages.Phonetic.Ukrainian.Syllable.Double.ArrInt8 +-- Copyright : (c) OleksandrZhabenko 2021-2021 +-- License : MIT +-- Stability : Experimental +-- Maintainer : olexandr543@yahoo.com +-- +-- This module works with syllable segmentation in Ukrainian. Uses 'Double' whenever possible. +-- Is inspired by the DobutokO.Sound.DIS5G6G module from @dobutokO2@ package. +-- See: 'https://hackage.haskell.org/package/dobutokO2-0.43.0.0/docs/DobutokO-Sound-DIS5G6G.html'. +-- The initial 'Double' data are gotten from there. + +module Languages.Phonetic.Ukrainian.Syllable.Double.ArrInt8 where + +import CaseBi.Arr +import Melodics.ByteString.Ukrainian.ArrInt8 (Sound8) +import GHC.Int + +s0DuratD1 :: Sound8 -> Double +s0DuratD1 = getBFstLSorted' 0.051020 [(1,0.138231),(2,9.3605e-2),(3,0.116463),(4,0.10907),(5,9.9955e-2),(6,9.415e-2),(7,2.0227e-2),(8,5.5601e-2),(9,5.5601e-2),(10,7.0658e-2),(11,7.0658e-2),(15,5.7143e-2),(16,5.7143e-2),(17,7.2063e-2),(18,7.2063e-2),(19,6.2948e-2),(20,6.2948e-2),(21,7.6825e-2),(22,7.6825e-2),(23,4.8934e-2),(24,4.8934e-2),(25,5.6054e-2),(26,5.6054e-2),(27,5.7143e-2),(28,6.4036e-2),(29,6.4036e-2),(30,7.737e-2),(31,7.737e-2),(32,7.424e-2),(33,7.424e-2),(34,4.9206e-2),(35,4.9206e-2),(36,8.2268e-2),(37,8.2268e-2),(38,5.3061e-2),(39,5.7596e-2),(40,5.7596e-2),(41,6.6077e-2),(42,6.6077e-2),(43,6.2268e-2),(44,6.2268e-2),(45,4.5351e-2),(46,4.5351e-2),(47,0.13483),(48,0.13483),(49,7.4603e-2),(50,0.110658),(51,0.110658),(52,7.7188e-2),(53,7.7188e-2),(54,7.4558e-2),(66,8.9342e-2)] +{-# INLINE s0DuratD1 #-} + +-- | +s0DuratD2 :: Sound8 -> Double +s0DuratD2 = getBFstLSorted' 0.06408817 [(1,0.27161466),(2,0.27192511),(3,0.28539351),(4,0.25250039),(5,0.2050935),(6,0.20026538),(7,2.218624e-2),(8,7.729654e-2),(9,7.729654e-2),(10,8.048113e-2),(11,8.048113e-2),(15,0.10977617),(16,0.10977617),(17,6.58655e-2),(18,6.58655e-2),(19,7.751571e-2),(20,7.751571e-2),(21,5.392745e-2),(22,5.392745e-2),(23,8.900757e-2),(24,8.900757e-2),(25,6.099951e-2),(26,6.099951e-2),(27,8.226452e-2),(28,0.11159399),(29,0.11159399),(30,0.14303837),(31,0.14303837),(32,5.639178e-2),(33,5.639178e-2),(34,6.354637e-2),(35,6.354637e-2),(36,8.404524e-2),(37,8.404524e-2),(38,5.616409e-2),(39,0.12541547),(40,0.12541547),(41,0.12838476),(42,0.12838476),(43,0.15776219),(44,0.15776219),(45,4.91782e-2),(46,4.91782e-2),(47,9.603085e-2),(48,9.603085e-2),(49,5.294375e-2),(50,5.047358e-2),(51,5.047358e-2),(52,7.905155e-2),(53,7.905155e-2),(54,7.512999e-2),(66,7.835033e-2)] +{-# INLINE s0DuratD2 #-} + +s0DuratD3 :: Sound8 -> Double +s0DuratD3 = getBFstLSorted' 0.05779993 [(1,0.25872483),(2,0.22876537),(3,0.25423777),(4,0.20243791),(5,0.19849003),(6,0.19777405),(7,1.943042e-2),(8,8.453724e-2),(9,8.453724e-2),(10,9.996042e-2),(11,9.996042e-2),(15,0.13787716),(16,0.13787716),(17,7.437409e-2),(18,7.437409e-2),(19,7.985903e-2),(20,7.985903e-2),(21,0.10289067),(22,0.10289067),(23,0.10039843),(24,0.10039843),(25,6.643842e-2),(26,6.643842e-2),(27,0.10975353),(28,0.1090645),(29,0.1090645),(30,0.14576594),(31,0.14576594),(32,6.084464e-2),(33,6.084464e-2),(34,5.937718e-2),(35,5.937718e-2),(36,7.798724e-2),(37,7.798724e-2),(38,5.901357e-2),(39,0.11906522),(40,0.11906522),(41,0.13985258),(42,0.13985258),(43,0.15880087),(44,0.15880087),(45,5.893304e-2),(46,5.893304e-2),(47,0.10765654),(48,0.10765654),(49,6.247632e-2),(50,6.03912e-2),(51,6.03912e-2),(52,0.13526622),(53,0.13526622),(54,8.190674e-2),(66,7.8444e-2)] +{-# INLINE s0DuratD3 #-} + +s0DuratD4 :: Sound8 -> Double +s0DuratD4 = getBFstLSorted' 0.14160713 [(1,0.25872483),(2,0.22876537),(3,0.25423777),(4,0.20243791),(5,0.19849003),(6,0.19777405),(7,1.943042e-2),(8,8.453724e-2),(9,8.453724e-2),(10,9.996042e-2),(11,9.996042e-2),(15,0.13787716),(16,0.13787716),(17,7.437409e-2),(18,7.437409e-2),(19,7.985903e-2),(20,7.985903e-2),(21,0.10289067),(22,0.10289067),(23,0.10039843),(24,0.10039843),(25,6.643842e-2),(26,6.643842e-2),(27,0.10975353),(28,0.1090645),(29,0.1090645),(30,0.14576594),(31,0.14576594),(32,6.084464e-2),(33,6.084464e-2),(34,5.937718e-2),(35,5.937718e-2),(36,7.798724e-2),(37,7.798724e-2),(38,5.901357e-2),(39,0.11906522),(40,0.11906522),(41,0.13985258),(42,0.13985258),(43,0.15880087),(44,0.15880087),(45,5.893304e-2),(46,5.893304e-2),(47,0.10765654),(48,0.10765654),(49,6.247632e-2),(50,6.03912e-2),(51,6.03912e-2),(52,0.13526622),(53,0.13526622),(54,8.190674e-2),(66,7.8444e-2)] +{-# INLINE s0DuratD4 #-} + + +class (Eq a) => SyllableDurations4 a where + sDuratsD :: a -> Double + sDuratsD2 :: a -> Double + sDuratsD3 :: a -> Double + sDuratsD4 :: a -> Double + syllableDurationsGDc :: (a -> Double) -> [[[a]]] -> [[Double]] + syllableDurationsGDc g = fmap (fmap (sum . fmap g)) + {-# INLINABLE syllableDurationsGDc #-} + +instance SyllableDurations4 Sound8 where + sDuratsD = s0DuratD1 + sDuratsD2 = s0DuratD2 + sDuratsD3 = s0DuratD3 + sDuratsD4 = s0DuratD4 + +-- | General variant of the 'syllableDurationsD' function. +syllableDurationsGD :: (Sound8 -> Double) -> [[[Sound8]]] -> [[Double]] +syllableDurationsGD g = syllableDurationsGDc g +{-# INLINABLE syllableDurationsGD #-} + +syllableDurationsD :: [[[Sound8]]] -> [[Double]] +syllableDurationsD = syllableDurationsGDc s0DuratD1 +{-# INLINE syllableDurationsD #-} + +syllableDurationsD2 :: [[[Sound8]]] -> [[Double]] +syllableDurationsD2 = syllableDurationsGDc s0DuratD2 +{-# INLINE syllableDurationsD2 #-} + +syllableDurationsD3 :: [[[Sound8]]] -> [[Double]] +syllableDurationsD3 = syllableDurationsGDc s0DuratD3 +{-# INLINE syllableDurationsD3 #-} + +syllableDurationsD4 :: [[[Sound8]]] -> [[Double]] +syllableDurationsD4 = syllableDurationsGDc s0DuratD4 +{-# INLINE syllableDurationsD4 #-} diff --git a/Melodics/ByteString/Ukrainian/Arr.hs b/Melodics/ByteString/Ukrainian/Arr.hs --- a/Melodics/ByteString/Ukrainian/Arr.hs +++ b/Melodics/ByteString/Ukrainian/Arr.hs @@ -14,6 +14,9 @@ -- -- Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of -- the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf +-- The code here is less optimized in time then in the new corresponding module Melodics.ByteString.Ukrainian.ArrInt8. +-- It will be moved to the new package after the upgrading the phonetic-languages-simplified-examples-array to the +-- new optimized modules. module Melodics.ByteString.Ukrainian.Arr ( -- * Basic functions @@ -30,31 +33,18 @@ import GHC.Arr import CaseBi.Arr import qualified Data.ByteString.Char8 as B - -{- --- Inspired by: https://mail.haskell.org/pipermail/beginners/2011-October/008649.html --} - -data Triple = Z | O | T - deriving (Eq,Ord,Show) +import Melodics.ByteString.Ukrainian.Common convertToProperUkrainianS :: String -> String convertToProperUkrainianS = correctB . correctA . applyChanges . bsToCharUkr . createTuplesByAnalysis . secondConv . filterUkr . changeIotated . filter (\x -> isUkrainianL x || isSpace x || isControl x || isPunctuation x) . map toLower -isUkrainianL :: Char -> Bool -isUkrainianL y | (y >= '\1070' && y <= '\1097') = True - | otherwise = getBFstLSorted' False (map (\x -> (x, True)) "'-\700\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217") y - changeIotated :: String -> String changeIotated (x:y:zs) | (y `elem` ("\1102\1103\1108\1110"::String)) && isConsNotJ x = x:'\1100':(case y of { '\1102' -> '\1091' ; '\1103' -> '\1072' ; '\1108' -> '\1077' ; ~r -> '\1110' }):changeIotated zs | otherwise = x:changeIotated (y:zs) changeIotated xs = xs -isConsNotJ :: Char -> Bool -isConsNotJ = getBFstLSorted' False (zip "\1073\1074\1075\1076\1078\1079\1082\1083\1084\1085\1087\1088\1089\1090\1092\1093\1094\1095\1096\1097\1169" (repeat True)) - filterUkr :: String -> B.ByteString filterUkr = B.pack . map toBSUkr @@ -290,7 +280,7 @@ correctSomeW zs = zs divideToParts :: (Char, Triple) -> [Char] -divideToParts (x, z) = getBFstLSorted' [x] (zip "NOPQRST" ["nt", "st", "tq", "Aq", "zq", "nq", "dq"]) . fst $ (x, z) +divideToParts (x, _) = getBFstLSorted' [x] (zip "NOPQRST" ["nt", "st", "tq", "Aq", "zq", "nq", "dq"]) x correctB :: [Char] -> [Char] correctB ys@(x:xs) diff --git a/Melodics/ByteString/Ukrainian/ArrInt8.hs b/Melodics/ByteString/Ukrainian/ArrInt8.hs new file mode 100644 --- /dev/null +++ b/Melodics/ByteString/Ukrainian/ArrInt8.hs @@ -0,0 +1,333 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Melodics.ByteString.Ukrainian.ArrInt8 +-- Copyright : (c) OleksandrZhabenko 2021 +-- License : MIT +-- Maintainer : olexandr543@yahoo.com +-- +-- Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis +-- especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr +-- for optimization purposes. +-- Phonetic material is taken from the : +-- +-- Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of +-- the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf + +module Melodics.ByteString.Ukrainian.ArrInt8 ( + -- * Basic functions + Sound8 + , FlowSound + , convertToProperUkrainianI8 + , isUkrainianL + , linkFileNameI8 +) where + +import qualified Data.String as S +import Data.Maybe (fromJust) +import Data.Char +import GHC.Arr +import CaseBi.Arr +import Data.List (uncons) +import GHC.Int +import Melodics.ByteString.Ukrainian.Common + +type Sound8 = Int8 + +type FlowSound = [Sound8] + +convertToProperUkrainianI8 :: String -> FlowSound +convertToProperUkrainianI8 = correctB . correctA . applyChanges . bsToCharUkr . createTuplesByAnalysis . secondConv . + filterUkr . changeIotated . filter (\x -> isUkrainianL x || isSpace x || isControl x || isPunctuation x) . map toLower +{-# INLINE convertToProperUkrainianI8 #-} + +changeIotated :: String -> String +changeIotated (x:y:zs) + | (y `elem` ("\1102\1103\1108\1110"::String)) && isConsNotJ x = x:'\1100':(case y of { '\1102' -> '\1091' ; '\1103' -> '\1072' ; '\1108' -> '\1077' ; ~r -> '\1110' }):changeIotated zs + | otherwise = x:changeIotated (y:zs) +changeIotated xs = xs + +filterUkr :: String -> FlowSound +filterUkr = map toBSUkr +{-# INLINE filterUkr #-} + +toBSUkr :: Char -> Sound8 +toBSUkr = getBFstLSorted' 0 (zip "'-\700\1072\1073\1074\1075\1076\1077\1078\1079\1080\1081\1082\1083\1084\1085\1086\1087\1088\1089\1090\1091\1092\1093\1094\1095\1096\1097\1100\1102\1103\1108\1110\1111\1169\8217" [-2,-1,60,1,15,36,21,17,2,10,25,5,27,45,28,30,32,3,47,34,49,50,4,43,52,38,39,41,55,7,56,57,58,6,59,19,61]) +{-# INLINE toBSUkr #-} + +secondConv :: FlowSound -> FlowSound +secondConv = + concatMap (\y -> getBFstLSorted' [y] (zip [-2,-1,55,56,57,58,59,60,61] [[-1],[-1],[41,39],[27,4],[27,1],[27,2],[27,6],[-1],[-1]]) y) +{-# INLINE secondConv #-} + +createTuplesByAnalysis :: FlowSound -> [FlowSound] +createTuplesByAnalysis x + | null x = [] + | getBFstLSorted' False (zip [10,17,21,25,32,38,39,41,43,45,47,49,50,52] (repeat True)) . head $ x = initialA x + | not (null . tail $ x) && (x !! 1 == 27 && isConsNotJ8 (head x)) = take 1 x:[7]:createTuplesByAnalysis (drop 2 x) + | otherwise = take 1 x:createTuplesByAnalysis (tail x) + +isConsNotJ8 :: Int8 -> Bool +isConsNotJ8 = getBFstLSorted' False (zip [10,15,17,19,21,25,28,30,32,34,36,38,39,41,43,45,47,49,50,52] (repeat True)) +{-# INLINE isConsNotJ8 #-} + +initialA :: FlowSound -> [FlowSound] +initialA t1@(t:ts) + | t < 1 = [0]:initialA ts + | getBFstLSorted' True (zip [10,17,21,25,32,38,39,41,43,45,47,49,50,52] (repeat False)) t = [t]:initialA ts + | getBFstLSorted' False (zip [17,32,38,49,50,52] (repeat True)) t = + let (us,vs) = splitAt 2 t1 in + if getBFstLSorted' False (zip [[17,10],[17,25],[32,50],[38,7],[49,7],[49,50],[50,7],[50,49],[52,21]] (repeat True)) us + then us:initialA vs + else [t]:initialA ts + | otherwise = [t]:initialA ts +initialA _ = [] + +bsToCharUkr :: [FlowSound] -> FlowSound +bsToCharUkr zs + | null zs = [] + | otherwise = map g zs + where g ts + | null ts = -1 + | otherwise = getBFstLSorted' (head ts) [([17,10],23),([17,25],8),([32,50],62),([38,7],66),([49,7],54), + ([49,50],63),([50,7],64),([50,49],38),([52,21],21)] ts +{-# INLINE bsToCharUkr #-} + +applyChanges :: FlowSound -> FlowSound +applyChanges [] = [] +applyChanges ys = foldr f v ys + where v = [] + f x xs + | null xs = [x] + | otherwise = getBFstLSorted' x (zip [8,10,17,21,25,38,39,41,43,45,47,49,50,52,54,62,63,64,66] [дзT xs, + жT xs, дT xs, гT xs, зT xs, цT xs, чT xs, шT xs, фT xs, кT xs, пT xs, сT xs, тT xs, хT xs, + сьT xs, нтT xs, стT xs, тьT xs, цьT xs]) x:xs +{-# INLINE applyChanges #-} + +isVoicedObstruent :: FlowSound -> Bool +isVoicedObstruent xs + | null xs = False + | otherwise = (\u -> u > 7 && u < 27) . head $ xs +{-# INLINE isVoicedObstruent #-} + +isVoicedObstruentH :: FlowSound -> Bool +isVoicedObstruentH xs + | null xs = False + | otherwise = getBFstLSorted' False [(8,True),(10,True),(15,True),(17,True),(19,True),(21,True),(23,True),(25, True)] . head $ xs +{-# INLINE isVoicedObstruentH #-} + +isVoicedObstruentS :: FlowSound -> Bool +isVoicedObstruentS xs + | null xs = False + | otherwise = (\u -> u > 11 && u < 15) . head $ xs +{-# INLINE isVoicedObstruentS #-} + +isSoftDOrL :: FlowSound -> Bool +isSoftDOrL xs = getBFstLSorted' False (zip [[15,7],[17,7],[28,7],[30,7],[32,7],[36,7],[38,7],[43,7],[47,7],[49,7],[50,7]] + (repeat True)) (takeFromFT_ 2 xs) || getBFstLSorted' False (zip [[12],[13],[14],[64],[65]] . repeat $ True) + (takeFromFT_ 1 xs) +{-# INLINE isSoftDOrL #-} + +isSoftDen :: FlowSound -> Bool +isSoftDen xs = getBFstLSorted' False (zip [[8,7],[17,7],[25,7],[28,7],[32,7],[38,7],[49,7],[50,7]] . repeat $ True) + (takeFromFT_ 2 xs) || getBFstLSorted' False (zip [[12],[13],[14],[64],[65]] . repeat $ True) + (takeFromFT_ 1 xs) +{-# INLINE isSoftDen #-} + +гT :: FlowSound -> Sound8 +гT (t:_) | t == 45 || t == 50 = 52 + | otherwise = 21 +гT _ = 21 +{-# INLINE гT #-} + +дT :: FlowSound -> Sound8 +дT t1@(_:_) | takeFromFT_ 1 t1 `elem` [[10],[39],[41]] = 23 -- д дж + | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] = 12 -- д дзь + | takeFromFT_ 1 t1 `elem` [[54],[66]] = 12 -- д дзь + | takeFromFT_ 1 t1 `elem` [[25],[49],[38]] = 8 -- д дз + | otherwise = 17 +дT _ = 17 +{-# INLINE дT #-} + +дзT :: FlowSound -> Sound8 +дзT t1@(_:_) | isSoftDOrL t1 = 12 + | otherwise = 8 +дзT _ = 8 +{-# INLINE дзT #-} + +жT :: FlowSound -> Sound8 +жT t1@(_:_) | takeFromFT 2 t1 `elem` [[49,7],[38,7]] = 13 + | takeFromFT 1 t1 `elem` [[54],[66]] = 13 + | otherwise = 10 +жT _ = 10 +{-# INLINE жT #-} + +зT :: FlowSound -> Sound8 +зT t1@(_:_) | takeFromFT_ 1 t1 `elem` [[10],[39],[41]] || takeFromFT_ 2 t1 == [17,10] || takeFromFT_ 1 t1 == [23] = 10 + | isSoftDOrL t1 = 13 + | takeFromFT 1 t1 `elem` [[39],[41]] = 41 -- з ш + | takeFromFT 1 t1 `elem` [[49],[38]] || takeFromFT_ 1 t1 `elem` [[45],[47],[50],[43],[52]] = 49 -- з с + | otherwise = 25 +зT _ = 25 +{-# INLINE зT #-} + +кT :: FlowSound -> Sound8 +кT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 19 + | otherwise = 45 +кT _ = 45 +{-# INLINE кT #-} + +нтT :: FlowSound -> Sound8 +нтT t1@(_:_) | takeFromFT 2 t1 == [49,50] || takeFromFT 1 t1 == [63] = 32 + | takeFromFT 3 t1 == [49,7,45] || takeFromFT 2 t1 == [54,45] = 65 + | otherwise = 62 +нтT _ = 62 +{-# INLINE нтT #-} + +пT :: FlowSound -> Sound8 +пT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 15 + | otherwise = 47 +пT _ = 47 +{-# INLINE пT #-} + +сT :: FlowSound -> Sound8 +сT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) || + isVoicedObstruentS (takeFromFT_ 1 t1) = 13 + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = 25 + | isSoftDOrL t1 = 54 + | takeFromFT_ 1 t1 == [41] = 41 + | otherwise = 49 +сT _ = 49 +{-# INLINE сT #-} + +стT :: FlowSound -> Sound8 +стT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 25 + | takeFromFT_ 3 t1 == [49,7,45] || (takeFromFT_ 2 t1 `elem` [[54,45],[38,7]]) || + takeFromFT_ 1 t1 == [66] = 54 + | takeFromFT_ 1 t1 `elem` [[49],[32]] = 49 + | takeFromFT_ 1 t1 == [39] = 41 + | otherwise = 63 +стT _ = 63 +{-# INLINE стT #-} + +сьT :: FlowSound -> Sound8 +сьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 13 + | otherwise = 54 +сьT _ = 54 +{-# INLINE сьT #-} + +тT :: FlowSound -> Sound8 +тT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) || + isVoicedObstruentS (takeFromFT_ 1 t1) = 14 + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = 17 + | takeFromFT_ 2 t1 == [38,7] || takeFromFT_ 1 t1 == [66] = 66 + | takeFromFT_ 1 t1 == [38] = 38 + | isSoftDen t1 = 64 + | takeFromFT_ 1 t1 `elem` [[39],[41]] = 39 + | otherwise = 50 +тT _ = 50 +{-# INLINE тT #-} + +тьT :: FlowSound -> Sound8 +тьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 14 + | takeFromFT_ 3 t1 == [49,7,1] || takeFromFT_ 2 t1 == [54,1] = 66 + | otherwise = 64 +тьT _ = 64 +{-# INLINE тьT #-} + +фT :: FlowSound -> Sound8 +фT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 36 + | otherwise = 43 +фT _ = 43 +{-# INLINE фT #-} + +хT :: FlowSound -> Sound8 +хT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 21 + | otherwise = 52 +хT _ = 52 +{-# INLINE хT #-} + +цT :: FlowSound -> Sound8 +цT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) || + isVoicedObstruentS (takeFromFT_ 1 t1) = 12 + | isSoftDOrL t1 = 66 + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = 8 + | otherwise = 38 +цT _ = 38 +{-# INLINE цT #-} + +цьT :: FlowSound -> Sound8 +цьT t1@(_:_) | (isVoicedObstruent . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7] = 12 + | otherwise = 66 +цьT _ = 66 +{-# INLINE цьT #-} + +чT :: FlowSound -> Sound8 +чT t1@(_:_) | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] || takeFromFT_ 1 t1 `elem` [[54],[66]] = 66 + | isVoicedObstruent . takeFromFT_ 1 $ t1 = 23 + | otherwise = 39 +чT _ = 39 +{-# INLINE чT #-} + +шT :: FlowSound -> Sound8 +шT t1@(_:_) | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] || takeFromFT_ 1 t1 `elem` [[54],[66]] = 54 + | isVoicedObstruent . takeFromFT_ 1 $ t1 = 10 + | otherwise = 41 +шT _ = 41 +{-# INLINE шT #-} + +takeFromFT :: Int -> FlowSound -> FlowSound +takeFromFT n ts | if n < 1 then True else null ts = [] + | n < 2 = [k] + | otherwise = k : takeFromFT (n - 1) (take (n - 1) ts) + where k = head ts + +takeFromFT2 :: Int -> FlowSound -> FlowSound +takeFromFT2 n ts | if n < 1 then True else null ts = [] + | n < 2 = [ks] + | otherwise = ks:takeFromFT2 (n - 1) (tail ts) + where ks = head ts + +dropFromFT2 :: Int -> FlowSound -> FlowSound +dropFromFT2 n ts | if n < 1 then True else null ts = [] + | n < 2 = tail ts + | otherwise = dropFromFT2 (n - 1) (tail ts) + +takeFromFT_ :: Int -> FlowSound -> FlowSound +takeFromFT_ n = takeFromFT n . filter (>0) +{-# INLINE takeFromFT_ #-} + +correctA :: FlowSound -> FlowSound +correctA = correctSomeW . separateSoftS +{-# INLINE correctA #-} + +separateSoftS :: FlowSound -> FlowSound +separateSoftS = concatMap divideToParts +{-# INLINE separateSoftS #-} + +correctSomeW :: FlowSound -> FlowSound +correctSomeW (x:y:z:xs@(t:ys)) + | x == 50 && y == 7 && z == 54 && t == 1 = 66:66:1:correctSomeW ys + | (x < 1) && y == 27 && z == 1 = + if take 2 xs == [39,32] + then x:y:z:41:correctSomeW ys + else x:correctSomeW (y:z:xs) + | otherwise = x:correctSomeW (y:z:xs) +correctSomeW zs = zs + +divideToParts :: Sound8 -> FlowSound +divideToParts x = + getBFstLSorted' [x] [(12,[8,7]),(13,[25,7]),(14,[17,7]),(62,[32,50]),(63,[49,50]),(64,[50,7]), (65,[32,7])] x +{-# INLINE divideToParts #-} + +correctB :: FlowSound -> FlowSound +correctB ys@(x:xs) + | (length . filter (== 0) . takeFromFT2 6 $ ys) > 1 = map (\t -> if t <= 0 then -1 else t) (takeFromFT2 6 ys) ++ correctB (dropFromFT2 6 ys) + | otherwise = (if x < 0 then -1 else x):correctB xs +correctB _ = [] + +linkFileNameI8 :: Sound8 -> Char +linkFileNameI8 x = getBFstLSorted' '0' ([(1,'A'),(2,'H'),(3,'Q'),(4,'W'),(5,'K'),(6,'e'),(7,'d'),(8,'G'),(10,'I'),(15,'B'), + (17,'E'),(19,'f'),(21,'D'),(23,'F'),(25,'J'),(27,'L'),(28,'N'),(30,'O'),(32,'P'),(34,'S'),(36,'C'),(38,'Z'),(39,'b'), + (41,'c'),(43,'X'),(45,'M'),(47,'R'),(49,'T'),(50,'V'),(52,'Y'),(54,'U'),(60,'0'),(61,'0'),(66,'a')]) x +{-# INLINE linkFileNameI8 #-} diff --git a/Melodics/ByteString/Ukrainian/Common.hs b/Melodics/ByteString/Ukrainian/Common.hs new file mode 100644 --- /dev/null +++ b/Melodics/ByteString/Ukrainian/Common.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Melodics.ByteString.Ukrainian.Common +-- Copyright : (c) OleksandrZhabenko 2021 +-- License : MIT +-- Maintainer : olexandr543@yahoo.com +-- +-- Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis +-- especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr +-- for optimization purposes. Contains the common for two modules definitions. +-- Phonetic material is taken from the : +-- +-- Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of +-- the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf + +module Melodics.ByteString.Ukrainian.Common where + +import CaseBi.Arr + +{- +-- Inspired by: https://mail.haskell.org/pipermail/beginners/2011-October/008649.html +-} + +data Triple = Z | O | T + deriving (Eq,Ord,Show) + +isUkrainianL :: Char -> Bool +isUkrainianL y | (y >= '\1070' && y <= '\1097') = True + | otherwise = getBFstLSorted' False (map (\x -> (x, True)) "'-\700\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217") y + +isConsNotJ :: Char -> Bool +isConsNotJ = getBFstLSorted' False (zip "\1073\1074\1075\1076\1078\1079\1082\1083\1084\1085\1087\1088\1089\1090\1092\1093\1094\1095\1096\1097\1169" (repeat True)) diff --git a/ukrainian-phonetics-basic-array.cabal b/ukrainian-phonetics-basic-array.cabal --- a/ukrainian-phonetics-basic-array.cabal +++ b/ukrainian-phonetics-basic-array.cabal @@ -2,9 +2,9 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: ukrainian-phonetics-basic-array -version: 0.3.0.0 +version: 0.4.0.0 synopsis: A library to work with the basic Ukrainian phonetics and syllable segmentation. -description: A library to work with the basic Ukrainian phonetics and syllable segmentation. Rewritten from the mmsyn6ukr and mmsyn7s packages. Comparing to the ukrainian-phonetics-basic package, all the vector-related functionality removed, it also removed from the dependencies and the mmsyn2 is changed to mmsyn2-array. +description: A library to work with the basic Ukrainian phonetics and syllable segmentation. Rewritten from the mmsyn6ukr and mmsyn7s packages. Comparing to the ukrainian-phonetics-basic package, all the vector-related functionality removed, it also removed from the dependencies and the mmsyn2 is changed to mmsyn2-array. Since 0.4.0.0 version switched to the more optimized Int8-based functionality. The modules that do not use Int8 after ugrading the phonetic-languages-simplified-examples-array to the Int8-based functionality are planned to be moved to the new package. homepage: https://hackage.haskell.org/package/ukrainian-phonetics-basic-array license: MIT license-file: LICENSE @@ -17,9 +17,9 @@ cabal-version: >=1.10 library - exposed-modules: Languages.Phonetic.Ukrainian.Syllable.Arr, Melodics.ByteString.Ukrainian.Arr, Languages.Phonetic.Ukrainian.Syllable.Double.Arr + exposed-modules: Languages.Phonetic.Ukrainian.Syllable.Arr, Melodics.ByteString.Ukrainian.Arr, Melodics.ByteString.Ukrainian.Common, Languages.Phonetic.Ukrainian.Syllable.Double.Arr, Languages.Phonetic.Ukrainian.Syllable.ArrInt8, Melodics.ByteString.Ukrainian.ArrInt8, Languages.Phonetic.Ukrainian.Syllable.Double.ArrInt8 -- other-modules: - other-extensions: DeriveDataTypeable, FlexibleInstances, OverloadedStrings + other-extensions: DeriveDataTypeable, FlexibleInstances, OverloadedStrings, TypeSynonymInstances build-depends: base >=4.8 && <4.15, mmsyn2-array >=0.3 && <1, bytestring >=0.10 && <0.13, mmsyn5 >=0.5 && <1 -- hs-source-dirs: default-language: Haskell2010