diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for ukrainian-phonetics-basic-array + +## 0.1.0.0 -- 2020-12-14 + +* First version. Released on an unsuspecting world. A fork of the ukrainian-phonetics-basic package that transformed into +an independent one. All the vector-related functionality has been removed. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2020 Oleksandr Zhabenko + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Languages/Phonetic/Ukrainian/Syllable/Arr.hs b/Languages/Phonetic/Ukrainian/Syllable/Arr.hs new file mode 100644 --- /dev/null +++ b/Languages/Phonetic/Ukrainian/Syllable/Arr.hs @@ -0,0 +1,247 @@ +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} + +-- | +-- Module : Languages.Phonetic.Ukrainian.Syllable.Arr +-- Copyright : (c) OleksandrZhabenko 2020 +-- 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.Arr where + +import Prelude hiding (mappend) +import Data.Monoid +import Data.Typeable +import qualified Data.List as L (groupBy) +import Melodics.ByteString.Ukrainian.Arr +import CaseBi.Arr +import Data.List.InnToOut.Basic (mapI) +import Data.Maybe (mapMaybe) + +-- Inspired by: https://github.com/OleksandrZhabenko/mm1/releases/tag/0.2.0.0 + +-- CAUTION: Please, do not mix with the show7s functions, they are not interoperable. + +data UZPP a b = UZ a b deriving ( Eq, Typeable ) + +instance (Ord a, Ord b) => Ord (UZPP a b) where + compare (UZ x1 y1) (UZ x2 y2) = + case compare x1 x2 of + EQ -> compare y1 y2 + ~z -> z + +data PhoneticType = W | S | O | D | K | L | M | N | E deriving ( Eq, Ord, Typeable ) + +type UZPP2 = UZPP Char PhoneticType + +instance Show (UZPP Char PhoneticType) where + show (UZ x y) + | y `notElem` [O,K,M] = + getBFstLSorted' "" [('-'," "),('0'," "),('1'," "),('A',"дз"),('B',"ж"),('C',"й"),('D',"сь"),('E',"ч"),('F',"ш"),('G',"щ"),('L',"\700"),('M',"\8217"), + ('a',"а"),('b',"б"),('c',"ц"),('d',"д"),('e',"е"),('f',"ф"),('g',"ґ"),('h',"г"),('i',"і"),('j',"дж"),('k',"к"),('l',"л"),('m',"м"),('n',"н"),('o',"о"),('p',"п"),('q',"ь"), + ('r',"р"),('s',"с"),('t',"т"),('u',"у"),('v',"в"),('w',"ць"),('x',"х"),('y',"и"),('z',"з")] x + | otherwise = + getBFstLSorted' "" [('-'," "),('0'," "),('1'," "),('A',"дзь"),('B',"жь"),('E',"чь"),('F',"шь"),('G',"щь"),('b',"бь"),('d',"дь"),('f',"фь"),('g',"ґь"), + ('h',"гь"),('j',"джь"),('k',"кь"),('l',"ль"),('m',"мь"),('n',"нь"),('p',"пь"),('q',"ь"),('r',"рь"),('t',"ть"),('v',"вь"),('x',"хь"),('z',"зь")] x + +phoneType :: UZPP2 -> PhoneticType +phoneType (UZ _ y) = y +{-# INLINE phoneType #-} + +charUkr :: UZPP2 -> Char +charUkr (UZ x _) = x +{-# INLINE charUkr #-} + +str2UZPP2s :: String -> [UZPP2] +str2UZPP2s (y:ys) + | getBFstLSorted' False [('a',True),('e',True),('i',True),('o',True),('u',True),('y',True)] y = UZ y W:str2UZPP2s ys + | y == 'D' || y == 'w' = UZ y N:str2UZPP2s ys + | (null ys || head ys /= 'q') && getBFstLSorted' False [('C',True),('l',True),('m',True),('n',True),('r',True),('v',True)] y = UZ y S:str2UZPP2s ys + | (null ys || head ys /= 'q') && + getBFstLSorted' False [('A',True),('B',True),('b',True),('d',True),('g',True),('h',True),('j',True),('z',True)] y = UZ y D:str2UZPP2s ys + | (null ys || head ys /= 'q') = UZ y L:str2UZPP2s ys + | getBFstLSorted' False [('l',True),('m',True),('n',True),('r',True),('v',True)] y = UZ y O:str2UZPP2s (drop 1 ys) + | getBFstLSorted' False [('A',True),('B',True),('b',True),('d',True),('g',True),('h',True),('j',True),('z',True)] y = + UZ y K:str2UZPP2s (drop 1 ys) + | otherwise = UZ y M:str2UZPP2s (drop 1 ys) +str2UZPP2s _ = [] + +-- | Function-predicate 'isVowel1' checks whether its argument is a vowel representation in the 'UZPP2' format. +isVowel1 :: UZPP2 -> Bool +isVowel1 = (== W) . phoneType +{-# INLINE isVowel1 #-} + +-- | Function-predicate 'isVwl' checks whether its argument is a vowel representation in the 'Char' format. +isVwl :: Char -> Bool +isVwl = getBFstLSorted' False [('a',True),('e',True),('i',True),('o',True),('u',True),('y',True)] +{-# INLINE isVwl #-} + +-- | Function-predicate 'isSonorous1' checks whether its argument is a sonorous consonant representation in the 'UZPP2' format. +isSonorous1 :: UZPP2 -> Bool +isSonorous1 = (`elem` [S,O]) . phoneType +{-# INLINE isSonorous1 #-} + +-- | Function-predicate 'isVoicedC1' checks whether its argument is a voiced consonant representation in the 'UZPP2' format. +isVoicedC1 :: UZPP2 -> Bool +isVoicedC1 = (`elem` [D,K]) . phoneType +{-# INLINE isVoicedC1 #-} + +-- | Function-predicate 'isVoiceless1' checks whether its argument is a voiceless consonant representation in the 'UZPP2' format. +isVoicelessC1 :: UZPP2 -> Bool +isVoicelessC1 = (`elem` [L,M]) . phoneType +{-# INLINE isVoicelessC1 #-} + +-- | Binary function-predicate 'isNotVowel2' checks whether its arguments are both consonant representations in the 'UZPP2' format. +isNotVowel2 :: UZPP2 -> UZPP2 -> Bool +isNotVowel2 x y + | phoneType x == W || phoneType y == W = False + | otherwise = True +{-# INLINE isNotVowel2 #-} + +-- | Binary function-predicate 'notEqC' checks whether its arguments are not the same consonant sound representations (not taking palatalization into account). +notEqC :: UZPP2 -> UZPP2 -> Bool +notEqC x y + | charUkr x == 's' || charUkr x == 'D' = + case charUkr y of + 's' -> False + 'D' -> False + _ -> True + | charUkr x == 'w' || charUkr x == 'c' = + case charUkr y of + 'w' -> False + 'c' -> False + _ -> True + | otherwise = charUkr x /= charUkr y + +-- | Function 'sndGroups' converts a Ukrainian word being a list of 'UZPP2' to the list of phonetically similar (consonants grouped with consonants and each vowel separately) +-- sounds representations in 'UZPP2' format. +sndGroups :: [UZPP2] -> [[UZPP2]] +sndGroups ys@(_:_) = L.groupBy isNotVowel2 ys +sndGroups _ = [] + +groupSnds :: [UZPP2] -> [[UZPP2]] +groupSnds = L.groupBy (\x y -> ((== W) . phoneType $ x) == ((== W) . phoneType $ 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 :: [UZPP2] -> ([UZPP2] -> [UZPP2],[UZPP2] -> [UZPP2]) +divCnsnts xs@(x:ys@(_:_:_:_)) + | (isSonorous1 x) || (isVoicedC1 x) = ((`mappend` [x]),(ys `mappend`)) + | otherwise = ((id),(xs `mappend`)) +divCnsnts xs@(x:ys@(y:zs@(_:_))) + | isSonorous1 x = ((`mappend` [x]),(ys `mappend`)) + | isSonorous1 y = ((`mappend` [x,y]),(zs `mappend`)) + | otherwise = ((id),(xs `mappend`)) +divCnsnts xs@(x:ys@(y:_)) + | ((isSonorous1 x) && (x `notEqC` y)) || ((isVoicedC1 x) && (isVoicelessC1 y)) = ((`mappend` [x]),(ys `mappend`)) + | otherwise = ((id),(xs `mappend`)) +divCnsnts xs = ((id),(xs `mappend`)) + +reSyllableCntnts :: [[UZPP2]] -> [[UZPP2]] +reSyllableCntnts (xs:ys:zs:xss) + | (/= W) . phoneType . 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 :: [[UZPP2]] -> [[UZPP2]] +divVwls = mapI (\ws -> (length . filter ((== W) . phoneType) $ ws) > 1) h3 + where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> phoneType x == W && phoneType y /= W) . drop 1 $ zs) + where (ys,zs) = span (\t -> phoneType t /= W) us + +createSyllablesUkrS :: String -> [[[UZPP2]]] +createSyllablesUkrS = map (divVwls . reSyllableCntnts . groupSnds . str2UZPP2s) . words1 . mapMaybe g . convertToProperUkrainianS . map (\x -> if x == '-' then ' ' else x) + where g x + | x == '0' = Nothing + | x /= '1' && x /= '-' = Just x + | otherwise = Just ' ' + 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 (== ' ') xs + (w, s'') = span (/= ' ') ts + {-# NOINLINE words1 #-} +{-# INLINE createSyllablesUkrS #-} + +-- | Function 'representProlonged' converts duplicated consequent in the syllable consonants +-- so that they are represented by just one 'UZPP2'. After applying the function to the list of 'UZPP2' being a syllable all groups of duplicated consequent consonants +-- in every syllable are represented with only one 'UZPP2' respectively. +representProlonged :: [UZPP2] -> [UZPP2] +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 + +-- | 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 'Float' data are gotten from there. +str2Durat1 :: String -> Float +str2Durat1 = getBFstLSorted' 0.153016 [("-", (0.101995)), ("0", (0.051020)), ("1", (0.153016)), ("а", 0.138231), ("б", 0.057143), + ("в", 0.082268), ("г", 0.076825), ("д", 0.072063), ("дж", 0.048934), ("дз", 0.055601), ("е", 0.093605), ("ж", 0.070658), ("з", 0.056054), + ("и", 0.099955), ("й", 0.057143), ("к", 0.045351), ("л", 0.064036), ("м", 0.077370), ("н", 0.074240), ("о", 0.116463), ("п", 0.134830), + ("р", 0.049206), ("с", 0.074603), ("сь", 0.074558), ("т", 0.110658), ("у", 0.109070), ("ф", 0.062268), ("х", 0.077188), ("ц", 0.053061), + ("ць", 0.089342), ("ч", 0.057596), ("ш", 0.066077), ("ь", 0.020227), ("і", 0.094150), ("ґ", 0.062948)] + +-- | Just another possible duration approximation obtained by usage of the @r-glpk-phonetic-languages-ukrainian-durations@ package +-- https://hackage.haskell.org/package/r-glpk-phonetic-languages-ukrainian-durations. +-- It is generated for the set of the words-durations pairs that the words contents ('Char') converts to the elements of the +-- \"ABCEFXYabcdefghijklmnopqrstuvxyz\" (for more information, pleas, refer to the +-- https://hackage.haskell.org/package/r-glpk-phonetic-languages-ukrainian-durations). +uzpp2Durat2 :: UZPP2 -> Float +uzpp2Durat2 = getBFstLSorted' 0.06408817 [(UZ 'A' D, 0.07729654), (UZ 'A' K, 0.07729654), (UZ 'B' D, 0.08048113), (UZ 'B' K, 0.08048113), + (UZ 'C' S, 0.08226452), (UZ 'D' N, 0.07512999), (UZ 'E' L, 0.12541547), (UZ 'E' M, 0.12541547), (UZ 'F' L, 0.12838476), (UZ 'F' M, 0.12838476), + (UZ 'a' W, 0.27161466), (UZ 'b' D, 0.10977617), (UZ 'b' K, 0.10977617), (UZ 'c' D, 0.05616409), (UZ 'd' D, 0.06586550), (UZ 'd' K, 0.06586550), + (UZ 'e' W, 0.27192511), (UZ 'f' L, 0.15776219), (UZ 'f' M, 0.15776219), (UZ 'g' D, 0.07751571), (UZ 'g' K, 0.07751571), (UZ 'h' D, 0.05392745), + (UZ 'h' K, 0.05392745), (UZ 'i' W, 0.20026538), (UZ 'j' D, 0.08900757), (UZ 'j' K, 0.08900757), (UZ 'k' L, 0.04917820), (UZ 'k' M, 0.04917820), + (UZ 'l' S, 0.11159399), (UZ 'l' O, 0.11159399), (UZ 'm' S, 0.14303837), (UZ 'm' O, 0.14303837), (UZ 'n' S, 0.05639178), + (UZ 'n' O, 0.05639178), (UZ 'o' W, 0.28539351), (UZ 'p' L, 0.09603085), (UZ 'p' M, 0.09603085), (UZ 'q' E, 0.02218624), (UZ 'r' S, 0.06354637), + (UZ 'r' O, 0.06354637), (UZ 's' L, 0.05294375), (UZ 't' L, 0.05047358), (UZ 't' M, 0.05047358), (UZ 'u' W, 0.25250039), + (UZ 'v' S, 0.08404524), (UZ 'v' O, 0.08404524), (UZ 'w' N, 0.07835033), (UZ 'x' L, 0.07905155), (UZ 'x' M, 0.07905155), + (UZ 'y' W, 0.20509350), (UZ 'z' D, 0.06099951), (UZ 'z' K, 0.06099951)] + +uzpp2Durat1 :: UZPP2 -> Float +uzpp2Durat1 = getBFstLSorted' 0.051020 [(UZ 'A' D, 0.055601), (UZ 'A' K, 0.055601), (UZ 'B' D, 0.070658), (UZ 'B' K, 0.070658), (UZ 'C' S, 0.057143), (UZ 'D' N, 0.074558), + (UZ 'E' L, 0.057596), (UZ 'E' M, 0.057596), (UZ 'F' L, 0.066077), (UZ 'F' M, 0.066077), (UZ 'a' W, 0.138231), (UZ 'b' D, 0.057143), (UZ 'b' K, 0.057143), (UZ 'c' D, 0.053061), + (UZ 'd' D, 0.072063), (UZ 'd' K, 0.072063), (UZ 'e' W, 0.093605), (UZ 'f' L, 0.062268), (UZ 'f' M, 0.062268), (UZ 'g' D, 0.062948), (UZ 'g' K, 0.062948), (UZ 'h' D, 0.076825), + (UZ 'h' K, 0.076825), (UZ 'i' W, 0.094150), (UZ 'j' D, 0.048934), (UZ 'j' K, 0.048934), (UZ 'k' L, 0.045351), (UZ 'k' M, 0.045351), (UZ 'l' S, 0.064036), (UZ 'l' O, 0.064036), + (UZ 'm' S, 0.077370), (UZ 'm' O, 0.077370), (UZ 'n' S, 0.074240), (UZ 'n' O, 0.074240), (UZ 'o' W, 0.116463), (UZ 'p' L, 0.134830), (UZ 'p' M, 0.134830), + (UZ 'q' E, 0.020227), (UZ 'r' S, 0.049206), (UZ 'r' O, 0.049206), (UZ 's' L, 0.074603), (UZ 't' L, 0.110658), (UZ 't' M, 0.110658), (UZ 'u' W, 0.109070), (UZ 'v' S, 0.082268), + (UZ 'v' O, 0.082268), (UZ 'w' N, 0.089342), (UZ 'x' L, 0.077188), (UZ 'x' M, 0.077188), (UZ 'y' W, 0.099955), (UZ 'z' D, 0.056054), (UZ 'z' K, 0.056054)] + +uzpp2Durat3 :: UZPP2 -> Float +uzpp2Durat3 = getBFstLSorted' 0.05779993 [(UZ 'A' D, 0.08453724), (UZ 'A' K, 0.08453724), + (UZ 'B' D, 0.09996042), (UZ 'B' K, 0.09996042), (UZ 'C' S, 0.10975353), (UZ 'D' N, 0.08190674), + (UZ 'E' L, 0.11906522), (UZ 'E' M, 0.11906522), (UZ 'F' L, 0.13985258), (UZ 'F' M, 0.13985258), + (UZ 'a' W, 0.25872483), (UZ 'b' D, 0.13787716), (UZ 'b' K, 0.13787716), (UZ 'c' D, 0.05901357), + (UZ 'd' D, 0.07437409), (UZ 'd' K, 0.07437409), (UZ 'e' W, 0.22876537), (UZ 'f' L, 0.15880087), + (UZ 'f' M, 0.15880087), (UZ 'g' D, 0.07985903), (UZ 'g' K, 0.07985903), (UZ 'h' D, 0.10289067), + (UZ 'h' K, 0.10289067), (UZ 'i' W, 0.19777405), (UZ 'j' D, 0.10039843), (UZ 'j' K, 0.10039843), + (UZ 'k' L, 0.05893304), (UZ 'k' M, 0.05893304), (UZ 'l' S, 0.10906450), (UZ 'l' O, 0.10906450), + (UZ 'm' S, 0.14576594), (UZ 'm' O, 0.14576594), (UZ 'n' S, 0.06084464), (UZ 'n' O, 0.06084464), + (UZ 'o' W, 0.25423777), (UZ 'p' L, 0.10765654), (UZ 'p' M, 0.10765654), (UZ 'q' E, 0.01943042), + (UZ 'r' S, 0.05937718), (UZ 'r' O, 0.05937718), (UZ 's' L, 0.06247632), (UZ 't' L, 0.06039120), + (UZ 't' M, 0.06039120), (UZ 'u' W, 0.20243791), (UZ 'v' S, 0.07798724), (UZ 'v' O, 0.07798724), + (UZ 'w' N, 0.07844400), (UZ 'x' L, 0.13526622), (UZ 'x' M, 0.13526622), (UZ 'y' W, 0.19849003), + (UZ 'z' D, 0.06643842), (UZ 'z' K, 0.06643842)] + +-- | General variant of the 'syllableDurations' function with the arbitrary 'uzpp2Durat1'-like function. +syllableDurationsG :: (UZPP2 -> Float) -> [[[UZPP2]]] -> [[Float]] +syllableDurationsG g = fmap (fmap (sum . fmap g)) +{-# INLINABLE syllableDurationsG #-} + +-- | Returns list of lists, every inner one of which contains approximate durations of the Ukrainian syllables. +syllableDurations :: [[[UZPP2]]] -> [[Float]] +syllableDurations = syllableDurationsG uzpp2Durat1 + +-- | Likewise 'syllableDurations', but uses 'uzpp2Durat2' instead of 'uzpp2Durat1'. +syllableDurations2 :: [[[UZPP2]]] -> [[Float]] +syllableDurations2 = syllableDurationsG uzpp2Durat2 + +-- | Likewise 'syllableDurations', but uses 'uzpp2Durat3' instead of 'uzpp2Durat1'. +syllableDurations3 :: [[[UZPP2]]] -> [[Float]] +syllableDurations3 = syllableDurationsG uzpp2Durat3 diff --git a/Languages/Phonetic/Ukrainian/Syllable/Double/Arr.hs b/Languages/Phonetic/Ukrainian/Syllable/Double/Arr.hs new file mode 100644 --- /dev/null +++ b/Languages/Phonetic/Ukrainian/Syllable/Double/Arr.hs @@ -0,0 +1,82 @@ +-- | +-- Module : Languages.Phonetic.Ukrainian.Syllable.Double.Arr +-- Copyright : (c) OleksandrZhabenko 2020 +-- License : MIT +-- Stability : Experimental +-- Maintainer : olexandr543@yahoo.com +-- +-- This module works with syllable segmentation in Ukrainian. Uses 'Double' whenever possible. +-- + +module Languages.Phonetic.Ukrainian.Syllable.Double.Arr where + +import CaseBi.Arr +import Languages.Phonetic.Ukrainian.Syllable.Arr (UZPP(..),UZPP2,PhoneticType(..)) + +-- | 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 'Double' data are gotten from there. +str2DuratD1 :: String -> Double +str2DuratD1 = getBFstLSorted' 0.153016 [("-", (0.101995)), ("0", (0.051020)), ("1", (0.153016)), ("а", 0.138231), ("б", 0.057143), + ("в", 0.082268), ("г", 0.076825), ("д", 0.072063), ("дж", 0.048934), ("дз", 0.055601), ("е", 0.093605), ("ж", 0.070658), ("з", 0.056054), + ("и", 0.099955), ("й", 0.057143), ("к", 0.045351), ("л", 0.064036), ("м", 0.077370), ("н", 0.074240), ("о", 0.116463), ("п", 0.134830), + ("р", 0.049206), ("с", 0.074603), ("сь", 0.074558), ("т", 0.110658), ("у", 0.109070), ("ф", 0.062268), ("х", 0.077188), ("ц", 0.053061), + ("ць", 0.089342), ("ч", 0.057596), ("ш", 0.066077), ("ь", 0.020227), ("і", 0.094150), ("ґ", 0.062948)] + +-- | Just another possible duration approximation obtained by usage of the @r-glpk-phonetic-languages-ukrainian-durations@ package +-- https://hackage.haskell.org/package/r-glpk-phonetic-languages-ukrainian-durations. +-- It is generated for the set of the words-durations pairs that the words contents ('Char') converts to the elements of the +-- \"ABCEFXYabcdefghijklmnopqrstuvxyz\" (for more information, pleas, refer to the +-- https://hackage.haskell.org/package/r-glpk-phonetic-languages-ukrainian-durations). +uzpp2DuratD2 :: UZPP2 -> Double +uzpp2DuratD2 = getBFstLSorted' 0.06408817 [(UZ 'A' D, 0.07729654), (UZ 'A' K, 0.07729654), (UZ 'B' D, 0.08048113), (UZ 'B' K, 0.08048113), + (UZ 'C' S, 0.08226452), (UZ 'D' N, 0.07512999), (UZ 'E' L, 0.12541547), (UZ 'E' M, 0.12541547), (UZ 'F' L, 0.12838476), (UZ 'F' M, 0.12838476), + (UZ 'a' W, 0.27161466), (UZ 'b' D, 0.10977617), (UZ 'b' K, 0.10977617), (UZ 'c' D, 0.05616409), (UZ 'd' D, 0.06586550), (UZ 'd' K, 0.06586550), + (UZ 'e' W, 0.27192511), (UZ 'f' L, 0.15776219), (UZ 'f' M, 0.15776219), (UZ 'g' D, 0.07751571), (UZ 'g' K, 0.07751571), (UZ 'h' D, 0.05392745), + (UZ 'h' K, 0.05392745), (UZ 'i' W, 0.20026538), (UZ 'j' D, 0.08900757), (UZ 'j' K, 0.08900757), (UZ 'k' L, 0.04917820), (UZ 'k' M, 0.04917820), + (UZ 'l' S, 0.11159399), (UZ 'l' O, 0.11159399), (UZ 'm' S, 0.14303837), (UZ 'm' O, 0.14303837), (UZ 'n' S, 0.05639178), + (UZ 'n' O, 0.05639178), (UZ 'o' W, 0.28539351), (UZ 'p' L, 0.09603085), (UZ 'p' M, 0.09603085), (UZ 'q' E, 0.02218624), (UZ 'r' S, 0.06354637), + (UZ 'r' O, 0.06354637), (UZ 's' L, 0.05294375), (UZ 't' L, 0.05047358), (UZ 't' M, 0.05047358), (UZ 'u' W, 0.25250039), + (UZ 'v' S, 0.08404524), (UZ 'v' O, 0.08404524), (UZ 'w' N, 0.07835033), (UZ 'x' L, 0.07905155), (UZ 'x' M, 0.07905155), + (UZ 'y' W, 0.20509350), (UZ 'z' D, 0.06099951), (UZ 'z' K, 0.06099951)] + +uzpp2DuratD1 :: UZPP2 -> Double +uzpp2DuratD1 = getBFstLSorted' 0.051020 [(UZ 'A' D, 0.055601), (UZ 'A' K, 0.055601), (UZ 'B' D, 0.070658), (UZ 'B' K, 0.070658), (UZ 'C' S, 0.057143), (UZ 'D' N, 0.074558), + (UZ 'E' L, 0.057596), (UZ 'E' M, 0.057596), (UZ 'F' L, 0.066077), (UZ 'F' M, 0.066077), (UZ 'a' W, 0.138231), (UZ 'b' D, 0.057143), (UZ 'b' K, 0.057143), (UZ 'c' D, 0.053061), + (UZ 'd' D, 0.072063), (UZ 'd' K, 0.072063), (UZ 'e' W, 0.093605), (UZ 'f' L, 0.062268), (UZ 'f' M, 0.062268), (UZ 'g' D, 0.062948), (UZ 'g' K, 0.062948), (UZ 'h' D, 0.076825), + (UZ 'h' K, 0.076825), (UZ 'i' W, 0.094150), (UZ 'j' D, 0.048934), (UZ 'j' K, 0.048934), (UZ 'k' L, 0.045351), (UZ 'k' M, 0.045351), (UZ 'l' S, 0.064036), (UZ 'l' O, 0.064036), + (UZ 'm' S, 0.077370), (UZ 'm' O, 0.077370), (UZ 'n' S, 0.074240), (UZ 'n' O, 0.074240), (UZ 'o' W, 0.116463), (UZ 'p' L, 0.134830), (UZ 'p' M, 0.134830), + (UZ 'q' E, 0.020227), (UZ 'r' S, 0.049206), (UZ 'r' O, 0.049206), (UZ 's' L, 0.074603), (UZ 't' L, 0.110658), (UZ 't' M, 0.110658), (UZ 'u' W, 0.109070), (UZ 'v' S, 0.082268), + (UZ 'v' O, 0.082268), (UZ 'w' N, 0.089342), (UZ 'x' L, 0.077188), (UZ 'x' M, 0.077188), (UZ 'y' W, 0.099955), (UZ 'z' D, 0.056054), (UZ 'z' K, 0.056054)] + +uzpp2DuratD3 :: UZPP2 -> Double +uzpp2DuratD3 = getBFstLSorted' 0.05779993 [(UZ 'A' D, 0.08453724), (UZ 'A' K, 0.08453724), + (UZ 'B' D, 0.09996042), (UZ 'B' K, 0.09996042), (UZ 'C' S, 0.10975353), (UZ 'D' N, 0.08190674), + (UZ 'E' L, 0.11906522), (UZ 'E' M, 0.11906522), (UZ 'F' L, 0.13985258), (UZ 'F' M, 0.13985258), + (UZ 'a' W, 0.25872483), (UZ 'b' D, 0.13787716), (UZ 'b' K, 0.13787716), (UZ 'c' D, 0.05901357), + (UZ 'd' D, 0.07437409), (UZ 'd' K, 0.07437409), (UZ 'e' W, 0.22876537), (UZ 'f' L, 0.15880087), + (UZ 'f' M, 0.15880087), (UZ 'g' D, 0.07985903), (UZ 'g' K, 0.07985903), (UZ 'h' D, 0.10289067), + (UZ 'h' K, 0.10289067), (UZ 'i' W, 0.19777405), (UZ 'j' D, 0.10039843), (UZ 'j' K, 0.10039843), + (UZ 'k' L, 0.05893304), (UZ 'k' M, 0.05893304), (UZ 'l' S, 0.10906450), (UZ 'l' O, 0.10906450), + (UZ 'm' S, 0.14576594), (UZ 'm' O, 0.14576594), (UZ 'n' S, 0.06084464), (UZ 'n' O, 0.06084464), + (UZ 'o' W, 0.25423777), (UZ 'p' L, 0.10765654), (UZ 'p' M, 0.10765654), (UZ 'q' E, 0.01943042), + (UZ 'r' S, 0.05937718), (UZ 'r' O, 0.05937718), (UZ 's' L, 0.06247632), (UZ 't' L, 0.06039120), + (UZ 't' M, 0.06039120), (UZ 'u' W, 0.20243791), (UZ 'v' S, 0.07798724), (UZ 'v' O, 0.07798724), + (UZ 'w' N, 0.07844400), (UZ 'x' L, 0.13526622), (UZ 'x' M, 0.13526622), (UZ 'y' W, 0.19849003), + (UZ 'z' D, 0.06643842), (UZ 'z' K, 0.06643842)] + +-- | General variant of the 'syllableDurationsD' function with the arbitrary 'uzpp2DuratD1'-like function. +syllableDurationsGD :: (UZPP2 -> Double) -> [[[UZPP2]]] -> [[Double]] +syllableDurationsGD g = fmap (fmap (sum . fmap g)) +{-# INLINABLE syllableDurationsGD #-} + +-- | Returns list of lists, every inner one of which contains approximate durations of the Ukrainian syllables. +syllableDurationsD :: [[[UZPP2]]] -> [[Double]] +syllableDurationsD = syllableDurationsGD uzpp2DuratD1 + +-- | Likewise 'syllableDurations', but uses 'uzpp2DuratD2' instead of 'uzpp2DuratD1'. +syllableDurationsD2 :: [[[UZPP2]]] -> [[Double]] +syllableDurationsD2 = syllableDurationsGD uzpp2DuratD2 + +-- | Likewise 'syllableDurations', but uses 'uzpp2DuratD3' instead of 'uzpp2DuratD1'. +syllableDurationsD3 :: [[[UZPP2]]] -> [[Double]] +syllableDurationsD3 = syllableDurationsGD uzpp2DuratD3 diff --git a/Melodics/ByteString/Ukrainian/Arr.hs b/Melodics/ByteString/Ukrainian/Arr.hs new file mode 100644 --- /dev/null +++ b/Melodics/ByteString/Ukrainian/Arr.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Melodics.ByteString.Ukrainian.Arr +-- Copyright : (c) OleksandrZhabenko 2019-2020 +-- 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.Ukrainian from the +-- @mmsyn6ukr@ package : 'https://hackage.haskell.org/package/mmsyn6ukr' +-- 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.Arr ( + -- * Basic functions + convertToProperUkrainianS + , convertToProperUkrainianB + , isUkrainianL + , linkFileName + , showInteresting +) where + +import qualified Data.String as S +import Data.Maybe (fromJust) +import Data.Char +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) + +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 + +toBSUkr :: Char -> Char +toBSUkr x = getBFstLSorted' x (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" "LabvhdeBzyCklmnoprstufxcEFGqHIJiKgM") x + +secondConv :: B.ByteString -> B.ByteString +secondConv = B.concatMap f + where f y + | isSpace y || isControl y = B.singleton '1' + | otherwise = getBFstLSorted' (B.singleton y) (zip "'-GHIJKLM" [B.singleton '0',B.singleton '0',"FE","Cu","Ca","Ce","Ci",B.singleton '0',B.singleton '0']) y + +createTuplesByAnalysis :: B.ByteString -> [(B.ByteString, Triple)] +createTuplesByAnalysis x + | B.null x = [] + | getBFstLSorted' False (zip "BEFcdfhknpstxz" (repeat True)) . B.head $ x = initialA x + | not (B.null . B.tail $ x) && (B.index x 1 == 'C' && isConsNotJ (B.head x)) = (B.copy . B.singleton . B.head $ x, T):(B.singleton 'q', Z):createTuplesByAnalysis (B.drop 2 x) + | otherwise = (B.copy . B.singleton . B.head $ x, Z):createTuplesByAnalysis (B.tail x) + + +initialA :: B.ByteString -> [(B.ByteString, Triple)] +initialA t1 + | B.null t1 = [] + | canChange t == O = (B.singleton '1', Z):initialA ts + | canChange t == Z = (B.singleton t, Z):initialA ts + | getBFstLSorted' False (zip "cdnstx" (repeat True)) t = + let (us,vs) = B.splitAt 2 t1 in + if getBFstLSorted' False (zip ["cq","dB","dz","nt","sq","st","tq","ts","xh"] (repeat True)) us + then (B.copy us, T):initialA vs + else (B.singleton t, T):initialA ts + | otherwise = (B.singleton t, T):initialA ts + where (t,ts) = fromJust . B.uncons $ t1 + +canChange :: Char -> Triple +canChange x + | isSpace x || isControl x || x == '-' = O + | getBFstLSorted' False (zip "BEFcdfhknpstxz" (repeat True)) x = T + | otherwise = Z + +bsToCharUkr :: [(B.ByteString,Triple)] -> [(Char,Triple)] +bsToCharUkr zs + | null zs = [] + | otherwise = map g zs + where g (ts,k) + | B.null ts = ('0',Z) + | otherwise = (getBFstLSorted' (B.head ts) (zip ["cq","dB","dz","nt","sq","st","tq","ts","xh"] "wjANDOPch") ts,k) + +applyChanges :: [(Char, Triple)] -> [(Char, Triple)] +applyChanges [] = [] +applyChanges ys = foldr f v ys + where v = [] + f x xs + | null xs = (:[]) . (\(y,_) -> (y, Z)) $ x + | snd x == T = + getBFstLSorted' (fst x, Z) (zip "ABDEFNOPcdfhkpstwxz" [дз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]) (fst x):xs + | otherwise = x:xs + +isVoicedObstruent :: B.ByteString -> Bool +isVoicedObstruent = getBFstLSorted' False [("A",True),("B",True),("Q",True),("R",True),("T",True),("b",True),("d",True),("g",True),("h",True), + ("j",True),("z", True)] . B.take 1 + +isVoicedObstruentH :: B.ByteString -> Bool +isVoicedObstruentH = getBFstLSorted' False [("A",True),("B",True),("b",True),("d",True),("g",True),("h",True),("j",True),("z", True)] . B.take 1 + +isVoicedObstruentS :: B.ByteString -> Bool +isVoicedObstruentS = (\u -> any (== u) ["Q","R","T"]) . B.take 1 + +isSoftDOrL :: [(Char, Triple)] -> Bool +isSoftDOrL xs = getBFstLSorted' False (zip ["bq","cq","dq","fq","lq","mq","nq","pq","sq","tq","vq"] (repeat True)) (takeFromFT_ 2 xs) || + getBFstLSorted' False (zip ["P","Q","R","S","T"] . repeat $ True) (takeFromFT_ 1 xs) + +isSoftDen :: [(Char, Triple)] -> Bool +isSoftDen xs = getBFstLSorted' False (zip ["Aq","cq","dq","lq","nq","sq","tq","zq"] . repeat $ True) (takeFromFT_ 2 xs) || + getBFstLSorted' False (zip ["P","Q","R","S","T"] . repeat $ True) (takeFromFT_ 1 xs) + +-- 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 + +гT :: [(Char, Triple)] -> (Char, Triple) +гT (t:_) | fst t == 'k' || fst t == 't' = ('x', Z) + | otherwise = ('h', Z) +гT _ = ('h', Z) + +дT :: [(Char, Triple)] -> (Char, Triple) +дT t1@(_:_) | takeFromFT_ 1 t1 `elem` ["B","E","F"] = ('j', Z) -- need further processing д дж + | takeFromFT_ 2 t1 `elem` ["sq","cq"] = ('Q', T) -- need further processing д дзь + | takeFromFT_ 1 t1 `elem` ["D","w"] = ('Q', T) -- need further processing д дзь + | takeFromFT_ 1 t1 `elem` ["z","s","c"] = ('A', Z) -- need further processing д дз + | otherwise = ('d', Z) +дT _ = ('d', Z) + +дзT :: [(Char, Triple)] -> (Char, Triple) +дзT t1@(_:_) | isSoftDOrL t1 = ('Q', T) + | otherwise = ('A', Z) +дзT _ = ('A', Z) + +жT :: [(Char, Triple)] -> (Char, Triple) +жT t1@(_:_) | takeFromFT 2 t1 `elem` ["sq","cq"] = ('R', T) + | takeFromFT 1 t1 `elem` ["D","w"] = ('R', T) + | otherwise = ('B', Z) +жT _ = ('B', Z) + +зT :: [(Char, Triple)] -> (Char, Triple) +зT t1@(_:_) | takeFromFT_ 1 t1 `elem` ["B","E","F"] || takeFromFT_ 2 t1 == "dB" || takeFromFT_ 1 t1 == "j" = ('B', Z) + | isSoftDOrL t1 = ('R', T) + | takeFromFT 1 t1 `elem` ["E","F"] = ('F', Z) -- need further processing з ш + | takeFromFT 1 t1 `elem` ["s","c"] || takeFromFT_ 1 t1 `elem` ["k","p","t","f","x"] = ('s', Z) -- need further processing з с + | otherwise = ('z', Z) +зT _ = ('z', Z) + +кT :: [(Char, Triple)] -> (Char, Triple) +кT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('g', Z) + | otherwise = ('k', Z) +кT _ = ('k', Z) + +нтT :: [(Char, Triple)] -> (Char, Triple) +нтT t1@(_:_) | takeFromFT 2 t1 == "st" || takeFromFT 1 t1 == "O" = ('n', Z) + | takeFromFT 3 t1 == "sqk" || takeFromFT 2 t1 == "Dk" = ('S', T) + | otherwise = ('N', T) +нтT _ = ('N', T) + +пT :: [(Char, Triple)] -> (Char, Triple) +пT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('b', Z) + | otherwise = ('p', Z) +пT _ = ('p', Z) + +сT :: [(Char, Triple)] -> (Char, Triple) +сT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && B.drop 1 (takeFromFT_ 2 t1) == "q") || isVoicedObstruentS (takeFromFT_ 1 t1) = ('R', T) + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = ('z', Z) + | isSoftDOrL t1 = ('D', Z) + | takeFromFT_ 1 t1 == "F" = ('F', Z) + | otherwise = ('s', Z) +сT _ = ('s', Z) + +стT :: [(Char, Triple)] -> (Char, Triple) +стT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('z', Z) + | takeFromFT_ 3 t1 == "sqk" || (takeFromFT_ 2 t1 `elem` ["Dk","cq"]) || takeFromFT_ 1 t1 == "w" = ('D', Z) + | takeFromFT_ 1 t1 `elem` ["s","n"] = ('s', Z) + | takeFromFT_ 1 t1 == "E" = ('F', Z) + | otherwise = ('O', T) +стT _ = ('O', T) + +сьT :: [(Char, Triple)] -> (Char, Triple) +сьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('R', T) + | otherwise = ('D', Z) +сьT _ = ('D', Z) + +тT :: [(Char, Triple)] -> (Char, Triple) +тT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && B.drop 1 (takeFromFT_ 2 t1) == "q") || isVoicedObstruentS (takeFromFT_ 1 t1) = ('T', T) + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = ('d', Z) + | takeFromFT_ 2 t1 == "cq" || takeFromFT_ 1 t1 == "w" = ('w', Z) + | takeFromFT_ 1 t1 == "c" = ('c', Z) + | isSoftDen t1 = ('P', T) + | takeFromFT_ 1 t1 `elem` ["E","F"] = ('E', Z) + | otherwise = ('t', Z) +тT _ = ('t', Z) + +тьT :: [(Char, Triple)] -> (Char, Triple) +тьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('T', T) + | takeFromFT_ 3 t1 == "sqa" || takeFromFT_ 2 t1 == "Da" = ('w', Z) + | otherwise = ('P', T) +тьT _ = ('P', T) + +фT :: [(Char, Triple)] -> (Char, Triple) +фT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('v', Z) + | otherwise = ('f', Z) +фT _ = ('f', Z) + +хT :: [(Char, Triple)] -> (Char, Triple) +хT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('h', Z) + | otherwise = ('x', Z) +хT _ = ('х', Z) + +цT :: [(Char, Triple)] -> (Char, Triple) +цT t1@(_:_) | ((isVoicedObstruentH . takeFromFT_ 1 $ t1) && B.drop 1 (takeFromFT_ 2 t1) == "q") || isVoicedObstruentS (takeFromFT_ 1 t1) = ('Q', T) + | isSoftDOrL t1 = ('w', Z) + | isVoicedObstruentH . takeFromFT_ 1 $ t1 = ('A', Z) + | otherwise = ('c', Z) +цT _ = ('c', Z) + +цьT :: [(Char, Triple)] -> (Char, Triple) +цьT t1@(_:_) | (isVoicedObstruent . takeFromFT_ 1 $ t1) && B.drop 1 (takeFromFT_ 2 t1) == "q" = ('Q', T) + | otherwise = ('w', Z) +цьT _ = ('w', Z) + +чT :: [(Char, Triple)] -> (Char, Triple) +чT t1@(_:_) | takeFromFT_ 2 t1 `elem` ["sq","cq"] || takeFromFT_ 1 t1 `elem` ["D","w"] = ('w', Z) + | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('j', Z) + | otherwise = ('E', Z) +чT _ = ('E', Z) + +шT :: [(Char, Triple)] -> (Char, Triple) +шT t1@(_:_) | takeFromFT_ 2 t1 `elem` ["sq","cq"] || takeFromFT_ 1 t1 `elem` ["D","w"] = ('D', Z) + | isVoicedObstruent . takeFromFT_ 1 $ t1 = ('B', Z) + | otherwise = ('F', Z) +шT _ = ('F', Z) + +takeFromFT :: Int -> [(Char, Triple)] -> B.ByteString +takeFromFT n ts | if compare 0 n /= LT then True else null ts = B.empty + | compare 1 n /= LT = B.singleton k + | otherwise = k `B.cons` takeFromFT (n - 1) (take (n - 1) ts) + where k = fst (head ts) + +takeFromFT2 :: Int -> [Char] -> [Char] +takeFromFT2 n ts | if compare 0 n /= LT then True else null ts = [] + | compare 1 n /= LT = [ks] + | otherwise = ks:takeFromFT2 (n - 1) (tail ts) + where ks = head ts + +dropFromFT2 :: Int -> [Char] -> [Char] +dropFromFT2 n ts | if compare 0 n /= LT then True else null ts = [] + | compare 1 n /= LT = tail ts + | otherwise = dropFromFT2 (n - 1) (tail ts) + +takeFromFT_ :: Int -> [(Char, Triple)] -> B.ByteString +takeFromFT_ n = takeFromFT n . filter (\(x, _) -> x /= '1' && x /= '0') + +correctA :: [(Char, Triple)] -> [Char] +correctA = correctSomeW . separateSoftS + +separateSoftS :: [(Char, Triple)] -> [Char] +separateSoftS = concatMap divideToParts + +correctSomeW :: [Char] -> [Char] +correctSomeW (x:y:z:xs@(t:ys)) + | x == 't' && y == 'q' && z == 'D' && t == 'a' = 'w':'w':'a':correctSomeW ys + | (x == '1' || x == '0') && y == 'C' && z == 'a' = + if take 2 xs == "En" + then x:y:z:'F':correctSomeW ys + else x:correctSomeW (y:z:xs) + | otherwise = x:correctSomeW (y:z:xs) +correctSomeW zs = zs + +divideToParts :: (Char, Triple) -> [Char] +divideToParts (x, z) = getBFstLSorted' [x] (zip "NOPQRST" ["nt", "st", "tq", "Aq", "zq", "nq", "dq"]) . fst $ (x, z) + +correctB :: [Char] -> [Char] +correctB ys@(x:xs) + | compare (length . filter (== '1') . takeFromFT2 6 $ ys) 1 == GT = map (\t -> if t == '1' || isPunctuation t then '-' else t) (takeFromFT2 6 ys) ++ correctB (dropFromFT2 6 ys) + | otherwise = (if isPunctuation x then '-' else x):correctB xs +correctB _ = [] + +-- | A variant of the 'convertToProperUkrainian' with the 'B.ByteString' result. +convertToProperUkrainianB :: String -> B.ByteString +convertToProperUkrainianB = B.pack . convertToProperUkrainianS + +linkFileName :: Char -> Char +linkFileName x = getBFstLSorted' x (zip "ABCDEFLMabcdefghijklmnopqrstuvwxyz" "GILUbc00ABZEHXfDeFMNOPQRdSTVWCaYKJ") x + +showInteresting :: String -> B.ByteString +showInteresting = S.fromString . convertToProperUkrainianS diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ukrainian-phonetics-basic-array.cabal b/ukrainian-phonetics-basic-array.cabal new file mode 100644 --- /dev/null +++ b/ukrainian-phonetics-basic-array.cabal @@ -0,0 +1,25 @@ +-- Initial ukrainian-phonetics-basic-array.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: ukrainian-phonetics-basic-array +version: 0.1.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. +homepage: https://hackage.haskell.org/package/ukrainian-phonetics-basic-array +license: MIT +license-file: LICENSE +author: OleksandrZhabenko +maintainer: olexandr543@yahoo.com +copyright: Oleksandr Zhabenko +category: Language +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: Languages.Phonetic.Ukrainian.Syllable.Arr, Melodics.ByteString.Ukrainian.Arr, Languages.Phonetic.Ukrainian.Syllable.Double.Arr + -- other-modules: + other-extensions: DeriveDataTypeable, FlexibleInstances, OverloadedStrings + build-depends: base >=4.7 && <4.15, mmsyn2-array >=0.1 && <1, bytestring >=0.10 && <0.13, mmsyn5 >=0.5 && <1 + -- hs-source-dirs: + default-language: Haskell2010