diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -16,3 +16,8 @@ ## 0.2.2.0 -- 2021-04-20 * Second version revised B. Fixed issues with being not compiled because of no Ix instance specified for Array first argument. + +## 0.3.0.0 -- 2021-04-20 + +* Third version. Added a new module Data.Phonetic.Languages.Syllables for the general syllable segmentation. Added new +lightweight dependencies of mmsyn5 and mmsyn2-array. diff --git a/Data/Phonetic/Languages/Base.hs b/Data/Phonetic/Languages/Base.hs --- a/Data/Phonetic/Languages/Base.hs +++ b/Data/Phonetic/Languages/Base.hs @@ -176,7 +176,7 @@ {-# INLINE fHelp4 #-} -- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of --- 'PhoneticRepresentationPLX' values. +-- 'PhoneticsRepresentationPLX' values. (~=) :: PhoneticsRepresentationPL -> PhoneticsRepresentationPLX -> Bool (PR xs ys zs) ~= (PRC xs1 ys1 zs1 _) = xs == xs1 && ys == ys1 && zs == zs1 (PRAfter xs ys) ~= (PRAfterC xs1 ys1 _) = xs == xs1 && ys == ys1 @@ -185,7 +185,7 @@ _ ~= _ = False -- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of --- 'PhoneticRepresentationPLX' values. +-- 'PhoneticsRepresentationPLX' values. compareG :: PhoneticsRepresentationPL -> PhoneticsRepresentationPLX -> Ordering compareG (PR xs ys zs) (PRC xs1 ys1 zs1 _) | xs /= xs1 = compare xs xs1 @@ -239,7 +239,7 @@ !k = unsafeAt arr (I# i#) !m = unsafeAt arr (I# i#) -{-| The following is taken from the 'Data.Either' module from @base@ package. +{- The following CPP macros contents is taken from the 'Data.Either' module from @base@ package. -} #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__<802 @@ -253,6 +253,10 @@ #endif #endif +{-| Finds and element in the 'Array' that the corresponding 'PhoneticsRepresentationPLX' from the first argument is '~=' to the +it. The 'String' arguments inside the tuple pair are the 'beforeString' and the 'afterString' elements of it to be used in 'Right' +case. +-} findSAI :: PhoneticRepresentationXInter -> (String, String) diff --git a/Data/Phonetic/Languages/Syllables.hs b/Data/Phonetic/Languages/Syllables.hs new file mode 100644 --- /dev/null +++ b/Data/Phonetic/Languages/Syllables.hs @@ -0,0 +1,172 @@ +{-# OPTIONS_HADDOCK show-extensions #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Phonetic.Languages.Syllables +-- Copyright : (c) OleksandrZhabenko 2020-2021 +-- License : MIT +-- Stability : Experimental +-- Maintainer : olexandr543@yahoo.com +-- +-- This module works with syllable segmentation. The generalized version for the module +-- 'Languages.Phonetic.Ukrainian.Syllable.Arr' from @ukrainian-phonetics-basic-array@ package. +-- + +module Data.Phonetic.Languages.Syllables where + +import Prelude hiding (mappend) +import Data.Monoid +import Data.Typeable +import qualified Data.List as L (groupBy,find,findIndex) +import Data.Phonetic.Languages.Base +import CaseBi.Arr +import Data.List.InnToOut.Basic (mapI) +import Data.Maybe (mapMaybe,fromJust) +import GHC.Int + +-- 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 PRS = SylS { + charS :: !Char, -- ^ Phonetic languages phenomenon representation. Usually, a phoneme, but it can be otherwise something different. + phoneType :: !PhoneticType -- ^ Some encoded type. +} deriving ( Eq, Typeable ) + +instance Ord PRS where + compare (SylS x1 y1) (SylS x2 y2) = + case compare x1 x2 of + EQ -> compare y1 y2 + ~z -> z + +data PhoneticType = P !Int8 deriving (Eq, Ord) + +{-| The list must be sorted in the ascending order to be used in the module correctly. +-} +type CharPhoneticClassification = [PRS] + +{-| The 'String' of converted phonetic language representation 'Char' data is converted to this type to apply syllable +segmentation or other transformations. +-} +type StringRepresentation = [PRS] + +str2PRSs :: CharPhoneticClassification -> String -> StringRepresentation +str2PRSs zs = map (\c -> fromJust . L.find ((== c) . charS) $ zs) + +-- | Function-predicate 'isVowel1' checks whether its argument is a vowel representation in the 'PRS' format. +isVowel1 :: PRS -> Bool +isVowel1 = (== P 0) . 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 'PRS' format. +isSonorous1 :: PRS -> Bool +isSonorous1 = (`elem` [P 1,P 2]) . phoneType +{-# INLINE isSonorous1 #-} + +-- | Function-predicate 'isVoicedC1' checks whether its argument is a voiced consonant representation in the 'PRS' format. +isVoicedC1 :: PRS -> Bool +isVoicedC1 = (`elem` [P 3,P 4]) . phoneType +{-# INLINE isVoicedC1 #-} + +-- | Function-predicate 'isVoiceless1' checks whether its argument is a voiceless consonant representation in the 'PRS' format. +isVoicelessC1 :: PRS -> Bool +isVoicelessC1 = (`elem` [P 5,P 6]) . phoneType +{-# INLINE isVoicelessC1 #-} + +-- | Binary function-predicate 'isNotVowel2' checks whether its arguments are both consonant representations in the 'PRS' format. +isNotVowel2 :: PRS -> PRS -> Bool +isNotVowel2 x y + | phoneType x == P 0 || phoneType y == P 0 = 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 + :: [(Char,Char)] -- ^ The pairs of the 'Char' that corresponds to the similar phonetic languages consonant phenomenon (e. g. allophones). Must be sorted in the ascending order to be used correctly. + -> PRS + -> PRS + -> Bool +notEqC xs x y + | (== cy) . getBFstLSorted' cx xs $ cx = False + | otherwise = cx /= cy + where !cx = charS x + !cy = charS y + +-- | Function 'sndGroups' converts a word being a list of 'PRS' to the list of phonetically similar (consonants grouped with consonants and each vowel separately) +-- sounds representations in 'PRS' format. +sndGroups :: [PRS] -> [[PRS]] +sndGroups ys@(_:_) = L.groupBy isNotVowel2 ys +sndGroups _ = [] + +groupSnds :: [PRS] -> [[PRS]] +groupSnds = L.groupBy (\x y -> ((== P 0) . phoneType $ x) == ((== P 0) . phoneType $ y)) + +data SegmentationInfo1 = SI { + fieldN :: !Int8, -- ^ Number of fields in the pattern matching that are needed to apply the segmentation rules. Not less than 1. + predicateN :: Int8 -- ^ Number of predicates in the definition for the 'fieldN' that are needed to apply the segmentation rules. +} deriving (Eq) + +data SegmentationPredFunction = PF (SegmentationInfo1 -> [PRS] -> Bool) + +data SegmentationRules1 = SP1 { + infoS :: SegmentationInfo1, + pF :: [SegmentationPredFunction], -- ^ The list must be sorted in the appropriate order of the guards usage for the predicates. + -- The length of the list must be equal to the ('fromEnum' . 'predicateN' . 'infoS') value. + res :: [([PRS] -> [PRS],[PRS] -> [PRS])] -- ^ The corresponding list of rules for segmentation. +} + +{-| List of the 'SegmentationRules1' sorted in the descending order by the 'fieldN' 'SegmentationInfo1' data and where the +length of all the 'SegmentationPredFunction' lists of 'PRS' are equal to the 'fieldN' 'SegmentationInfo1' data by definition. +-} +type SegmentPredicates = [SegmentationRules1] + +-- | Function 'divCnsnts' is used to divide groups of 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 example phonetical information for the proper performance in Ukrainian can be found 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 +-- The example of the 'divCnsnts' can be found at: https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.1.2.0/docs/src/Languages.Phonetic.Ukrainian.Syllable.Arr.html#divCnsnts +divCnsnts :: [(Char,Char)] -> SegmentPredicates -> [PRS] -> ([PRS] -> [PRS],[PRS] -> [PRS]) +divCnsnts ks gs xs@(_:_) = res js !! ix + where !l = length xs + !js = fromJust . L.find ((== l) . fromEnum . fieldN . infoS) $ gs -- js :: SegmentationRules1 + !ix = fromJust . L.findIndex (\(PF f) -> f (infoS js) xs) . pF $ js +divCnsnts _ _ [] = (id,id) + +reSyllableCntnts :: [(Char,Char)] -> SegmentPredicates -> [[PRS]] -> [[PRS]] +reSyllableCntnts ks gs (xs:ys:zs:xss) + | (/= P 0) . phoneType . last $ ys = fst (divCnsnts ks gs ys) xs:reSyllableCntnts ks gs (snd (divCnsnts ks gs ys) zs:xss) + | otherwise = reSyllableCntnts ks gs ((xs `mappend` ys):zs:xss) +reSyllableCntnts _ _ (xs:ys:_) = [(xs `mappend` ys)] +reSyllableCntnts _ _ xss = xss + +divVwls :: [[PRS]] -> [[PRS]] +divVwls = mapI (\ws -> (length . filter ((== P 0) . phoneType) $ ws) > 1) h3 + where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> phoneType x == P 0 && phoneType y /= P 0) . drop 1 $ zs) + where (ys,zs) = span (\t -> phoneType t /= P 0) us + +createSyllablesPL + :: GWritingSystemPRPLX + -> [(Char,Char)] + -> CharPhoneticClassification + -> SegmentPredicates + -> String -- ^ Corresponds to the \'0\' symbol delimiter in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Corresponds to the \'1\' and \'-\' symbol delimiters in the @ukrainian-phonetics-basic-array@ package. + -> String -- ^ Actually the converted 'String'. + -> [[[PRS]]] +createSyllablesPL wrs ks cs gs us vs = map (divVwls . reSyllableCntnts ks gs . groupSnds . str2PRSs cs) . words1 . mapMaybe g . convertToProperPL . map (\x -> if x == '-' then ' ' else x) + where g x + | x `elem` us = Nothing + | x `notElem` vs = 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 #-} + convertToProperPL = map char . stringToXG wrs +{-# INLINE createSyllablesPL #-} diff --git a/Data/Phonetic/Languages/Undefined.hs b/Data/Phonetic/Languages/Undefined.hs --- a/Data/Phonetic/Languages/Undefined.hs +++ b/Data/Phonetic/Languages/Undefined.hs @@ -80,7 +80,7 @@ implementation has the same name and signature as here and the data type is used there. Please, use this function only as a type and semantics template and implement your own one where needed. After you have defined the 'rules' and 'showRepr' functions, you can implement the instance for 'Show' class -for the 'PhoneticRepresentationPL' as: +for the 'PhoneticsRepresentationPL' as: instance Show PhoneticsRepresentationPL where show = showRepr . rulesPR {-# INLINE show #-} diff --git a/phonetic-languages-phonetics-basics.cabal b/phonetic-languages-phonetics-basics.cabal --- a/phonetic-languages-phonetics-basics.cabal +++ b/phonetic-languages-phonetics-basics.cabal @@ -3,7 +3,7 @@ -- http://haskell.org/cabal/users-guide/ name: phonetic-languages-phonetics-basics -version: 0.2.2.0 +version: 0.3.0.0 synopsis: A library for working with generalized phonetic languages usage. description: There already exists a Ukrainian implementation for the phonetic languages approach published at: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array. It is optimized for the Ukrainian only and needs to be rewritten for every new language mostly from scratch using it as a template. To avoid this boilerplate, this one is provided. It can be used for different languages and even for music or other fields. homepage: https://hackage.haskell.org/package/phonetic-languages-phonetics-basics @@ -18,10 +18,10 @@ cabal-version: >=1.10 library - exposed-modules: Data.Phonetic.Languages.Undefined, Data.Phonetic.Languages.Base + exposed-modules: Data.Phonetic.Languages.Undefined, Data.Phonetic.Languages.Base, Data.Phonetic.Languages.Syllables -- other-modules: other-extensions: CPP, BangPatterns, UnboxedTuples, MagicHash ghc-options: -funbox-strict-fields - build-depends: base >=4.8 && <4.15 + build-depends: base >=4.8 && <4.15, mmsyn2-array >= 0.1.3 && <1, mmsyn5 >= 0.5 && <1 -- hs-source-dirs: default-language: Haskell2010