packages feed

phonetic-languages-phonetics-basics 0.9.1.0 → 0.10.0.0

raw patch · 14 files changed

+1310/−1301 lines, 14 filesdep ~basedep ~foldable-ixdep ~lists-flines

Dependency ranges changed: base, foldable-ix, lists-flines, mmsyn2-array, mmsyn3, mmsyn5

Files

ChangeLog.md view
@@ -124,3 +124,7 @@  * Ninth version revised A. Updated the dependencies boundaries. Some minor documentation improvements. +## 0.10.0.0 -- 2023-02-03++* Tenth version. Switched to NoImplicitPrelude extension. Updated the metadata and dependencies boundaries.+
− Data/Phonetic/Languages/Base.hs 
@@ -1,412 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-}-{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE MagicHash #-}---- |--- Module      :  Data.Phonetic.Languages.Base--- Copyright   :  (c) OleksandrZhabenko 2021--- License     :  MIT--- Stability   :  Experimental--- Maintainer  :  olexandr543@yahoo.com------ This is a computational scheme for generalized usage of the phonetic languages approach. --- It is intended to be exported qualified, so that the functions in every language--- implementation have the same names and signatures as these ones and the data type used here.--- It is may be not the most efficient implementation.--- --module Data.Phonetic.Languages.Base (-  -- * Phonetics representation data type for the phonetic languages approach.-  PhoneticElement(..)-  , PhoneticsRepresentationPL(..)-  , PhoneticsRepresentationPLX(..)-  , Generations-  , InterGenerationsString-  , WritingSystemPRPLX-  , GWritingSystemPRPLX-  , PhoneticRepresentationXInter-  , IGWritingSystemPRPLX-  , fromX2PRPL-  , fromPhoneticRX-  -- * Functions to work with the one.-  -- ** Predicates-  , isPRC-  , isPRAfterC-  , isPRBeforeC-  , isPREmptyC-  -- ** Convert to the 'PhoneticsRepresentationPLX'.-  , stringToXSG-  , stringToXG-  , stringToXS-  , string2X-  -- ** Apply conversion from 'PhoneticsRepresentationPLX'.-  , rulesX-  -- * Auxiliary functions-  , fHelp4-  , findSA-  , findSAI-  -- * Some class extensions for 'Eq' and 'Ord' type classes-  , (~=)-  , compareG-) where--import Data.List (sortBy,groupBy,nub,(\\),find,partition,intercalate)-import GHC.Int (Int8(..))-import Data.Maybe (isJust,fromJust)-import Data.Either-import Data.Char (isLetter)-import GHC.Arr-import GHC.Exts---- | The syllable after this is encoded with the representation with every 'Char' being some phonetic language phenomenon.--- To see its usual written representation, use the defined 'showRepr' function (please, implement your own one).-data PhoneticsRepresentationPL = PR { string :: String, afterString :: String, beforeString :: String } |-  PRAfter { string :: String, afterString :: String } |-  PRBefore { string :: String, beforeString :: String } |-  PREmpty { string :: String }-    deriving (Eq, Ord)--instance Show PhoneticsRepresentationPL where-  show (PR xs ys zs) = intercalate " " ["R", show zs, show xs, show ys]-  show (PRAfter xs ys) = intercalate " " ["A", show xs, show ys]-  show (PRBefore xs zs) = intercalate " " ["B", show zs, show xs]-  show (PREmpty xs) = "E " `mappend` show xs--class PhoneticElement a where-  readPEMaybe :: String -> Maybe a--instance PhoneticElement PhoneticsRepresentationPL where-  readPEMaybe rs-    | not . any isLetter $ rs = Nothing-    | otherwise = case ys of-        "R" -> case yss of-           [zs,xs,ts] -> Just (PR xs ts zs)-           _ -> Nothing-        "A" -> case yss of-           [xs,ts] -> Just (PRAfter xs ts)-           _ -> Nothing-        "B" -> case yss of-           [zs,xs] -> Just (PRBefore xs zs)-           _ -> Nothing-        "E" -> case yss of-           [xs] -> Just (PREmpty xs)-           _ -> Nothing-        _ -> Nothing-       where (ys:yss) = words rs  ---- | Extended variant of the 'PhoneticsRepresentationPL' data type where the information for the 'Char' is encoded into the--- data itself. Is easier to implement the rules in the separate file by just specifying the proper and complete list of--- 'PhoneticsRepresentationPLX' values. While the 'char' function can be used to group 'PhoneticRepresentationPLX'--- that represents some phenomenae, for the phonetic languages approach the 'string1' is used in the most cases.-data PhoneticsRepresentationPLX = PRC { stringX :: String, afterStringX :: String, beforeStringX :: String, char :: Char, string1 :: String } |-  PRAfterC { stringX :: String, afterStringX :: String, char :: Char, string1 :: String } |-  PRBeforeC { stringX :: String, beforeStringX :: String, char :: Char, string1 :: String } |-  PREmptyC { stringX :: String, char :: Char, string1 :: String }-    deriving (Eq, Ord)--instance Show PhoneticsRepresentationPLX where-  show (PRC xs ys zs c us) = intercalate " " ["RC", show zs, show xs, show ys, '\'':c:"\'", us]-  show (PRAfterC xs ys c us) = intercalate " " ["AC", show xs, show ys, '\'':c:"\'", us]-  show (PRBeforeC xs zs c us) = intercalate " " ["BC", show zs, show xs, '\'':c:"\'", us]-  show (PREmptyC xs c us) = "EC " `mappend` show xs `mappend` (' ':'\'':c:"\'") `mappend` us--instance PhoneticElement PhoneticsRepresentationPLX where-  readPEMaybe rs-    | not . any isLetter $ rs = Nothing-    | otherwise = case ys of-        "RC" -> case yss of-           [zs,xs,ts,cs,us] -> case cs of-               '\'':c:"\'" -> Just (PRC xs ts zs c us)-               _ -> Nothing-           _ -> Nothing-        "AC" -> case yss of-           [xs,ts,cs,us] -> case cs of-               '\'':c:"\'" -> Just (PRAfterC xs ts c us)-               _ -> Nothing-           _ -> Nothing-        "BC" -> case yss of-           [zs,xs,cs,us] -> case cs of-               '\'':c:"\'" -> Just (PRBeforeC xs zs c us)-               _ -> Nothing-           _ -> Nothing-        "EC" -> case yss of-           [xs,cs,us] -> case cs of-               '\'':c:"\'" -> Just (PREmptyC xs c us)-               _ -> Nothing-           _ -> Nothing-        _ -> Nothing-       where (ys:yss) = words rs    --isPRC :: PhoneticsRepresentationPLX -> Bool-isPRC (PRC _ _ _ _ _) = True-isPRC _ = False--isPRAfterC :: PhoneticsRepresentationPLX -> Bool-isPRAfterC (PRAfterC _ _ _ _) = True-isPRAfterC _ = False--isPRBeforeC :: PhoneticsRepresentationPLX -> Bool-isPRBeforeC (PRBeforeC _ _ _ _) = True-isPRBeforeC _ = False--isPREmptyC :: PhoneticsRepresentationPLX -> Bool-isPREmptyC (PREmptyC _ _ _) = True-isPREmptyC _ = False--fromX2PRPL :: PhoneticsRepresentationPLX -> PhoneticsRepresentationPL-fromX2PRPL (PREmptyC xs _ _) = PREmpty xs-fromX2PRPL (PRAfterC xs ys _ _) = PRAfter xs ys-fromX2PRPL (PRBeforeC xs zs _ _) = PRBefore xs zs-fromX2PRPL (PRC xs ys zs _ _) = PR xs ys zs-{-# INLINE fromX2PRPL #-}---- | An analogue of the 'rulesPR' function for 'PhoneticsRepresentationPLX'. -rulesX :: PhoneticsRepresentationPLX -> Char-rulesX = char-{-# INLINE rulesX #-}--stringToXS :: WritingSystemPRPLX -> String -> [String]-stringToXS xs ys = ks : stringToX' zss l ts-  where !zss = nub . map stringX $ xs-        !l = maximum . map length $ zss-        f ys l zss = splitAt ((\xs -> if null xs then 1 else head xs) . filter (\n -> elem (take n ys) zss) $ [l,l-1..1]) ys-        {-# INLINE f #-}-        (!ks,!ts) = f ys l zss-        stringToX' rss m vs = bs : stringToX' rss m us-           where (!bs,!us) = f vs m rss---- | Uses the simplest variant of the 'GWritingSystemPRPLX' with just two generations where all the 'PREmptyC' elements in the--- 'WritingSystemPRPLX' are used in the last order. Can be suitable for simple languages (e. g. Esperanto).-string2X :: WritingSystemPRPLX -> String -> [PhoneticsRepresentationPLX]-string2X xs = stringToXG [(zs,1),(ys,0)]-  where (ys,zs) = partition isPREmptyC xs-{-# INLINE string2X #-}---- | Each generation represents a subset of rules for representation transformation. The 'PhoneticsRepresentationPLX'--- are groupped by the generations so that in every group with the same generation number ('Int8' value, typically starting--- from 1) the rules represented have no conflicts with each other (this guarantees that they can be applied simultaneously--- without the danger of incorrect interference). Usage of 'Generations' is a design decision and is inspired by the--- GHC RULES pragma and the GHC compilation multistage process. -type Generations = Int8---- | Each value represents temporary intermediate resulting 'String' data to be transformed further into the representation.-type InterGenerationsString = String---- | If the list here is proper and complete, then it usually represents the whole writing system of the language. For proper usage,--- the list must be sorted in the ascending order.-type WritingSystemPRPLX = [PhoneticsRepresentationPLX]---- | The \'dynamic\' representation of the general writing system that specifies what transformations are made simultaneously--- during the conversion to the phonetic languages phonetics representation. During transformations those elements that have--- greater 'Generations' are used earlier than others. The last ones are used those elements with the 'Generations' element--- equal to 0 that must correspond to the 'PREmptyC' constructor-built records. For proper usage, the lists on the first--- place of the tuples must be sorted in the ascending order.-type GWritingSystemPRPLX = [([PhoneticsRepresentationPLX],Generations)]--{-| The intermediate representation of the phonetic languages data. Is used during conversions.--}-type PhoneticRepresentationXInter = Either PhoneticsRepresentationPLX InterGenerationsString--fromPhoneticRX :: [PhoneticsRepresentationPLX] -> [PhoneticRepresentationXInter] -> [PhoneticsRepresentationPLX]-fromPhoneticRX ts = concatMap (fromInter2X ts)-  where fromInter2X :: [PhoneticsRepresentationPLX] -> PhoneticRepresentationXInter -> [PhoneticsRepresentationPLX]-        fromInter2X _ (Left x) = [x]-        fromInter2X ys (Right z) = filter ((== z) . stringX) ys---- | The \'dynamic\' representation of the process of transformation for the general writing system during the conversion.--- Is not intended to be produced by hand, but automatically by programs.-type IGWritingSystemPRPLX = [(PhoneticRepresentationXInter,Generations)]---- | Splits the given list using 4 predicates into tuple of 4 lists of elements satisfying the predicates in the order--- being preserved.-fHelp4 :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a],[a],[a],[a])-fHelp4 p1 p2 p3 p4 = foldr g v-  where v = ([],[],[],[])-        g x (xs1,xs2,xs3,xs4)-          | p1 x = (x:xs1,xs2,xs3,xs4)-          | p2 x = (xs1,x:xs2,xs3,xs4)-          | p3 x = (xs1,xs2,x:xs3,xs4)-          | p4 x = (xs1,xs2,xs3,x:xs4)-          | otherwise = (xs1,xs2,xs3,xs4)-{-# INLINE fHelp4 #-}---- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of--- '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-(PRBefore ys zs) ~= (PRBeforeC ys1 zs1 _ _) = ys == ys1 && zs == zs1-(PREmpty xs) ~= (PREmptyC xs1 _ _) = xs1 == xs1-_ ~= _ = False---- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of--- 'PhoneticsRepresentationPLX' values. -compareG :: PhoneticsRepresentationPL -> PhoneticsRepresentationPLX -> Ordering-compareG (PR xs ys zs) (PRC xs1 ys1 zs1 _ _)- | xs /= xs1 = compare xs xs1- | ys /= ys1 = compare ys ys1- | zs /= zs1 = compare zs zs1- | otherwise = EQ-compareG (PR _ _ _) _ = LT-compareG (PREmpty xs) (PREmptyC xs1 _ _)- | xs /= xs1 = compare xs xs1- | otherwise = EQ-compareG (PREmpty _) _ = GT-compareG (PRAfter xs ys) (PRAfterC xs1 ys1 _ _)- | xs /= xs1 = compare xs xs1- | ys /= ys1 = compare ys ys1- | otherwise = EQ-compareG (PRAfter _ _) (PRC _ _ _ _ _) = GT-compareG (PRAfter _ _) _ = LT-compareG (PRBefore ys zs) (PRBeforeC ys1 zs1 _ _)- | ys /= ys1 = compare ys ys1- | zs /= zs1 = compare zs zs1- | otherwise = EQ-compareG (PRBefore _ _) (PREmptyC _ _ _) = LT-compareG (PRBefore _ _) _ = GT---- | Is somewhat rewritten from the 'CaseBi.Arr.gBF3' function (not exported) from the @mmsyn2-array@ package.-gBF3-  :: (Ix i) => (# Int#, PhoneticsRepresentationPLX #)-  -> (# Int#, PhoneticsRepresentationPLX #)-  -> PhoneticsRepresentationPL-  -> Array i PhoneticsRepresentationPLX-  -> Maybe PhoneticsRepresentationPLX-gBF3 (# !i#, k #) (# !j#, m #) repr arr- | isTrue# ((j# -# i#) ># 1# ) = -    case compareG repr p of-     GT -> gBF3 (# n#, p #) (# j#, m #) repr arr-     LT  -> gBF3 (# i#, k #) (# n#, p #) repr arr-     _ -> Just p- | repr ~= m = Just m- | repr ~= k = Just k- | otherwise = Nothing-     where !n# = (i# +# j#) `quotInt#` 2#-           !p = unsafeAt arr (I# n#)-{-# INLINABLE gBF3 #-}--findSA-  :: PhoneticsRepresentationPL-  -> Array Int PhoneticsRepresentationPLX-  -> Maybe PhoneticsRepresentationPLX-findSA repr arr = gBF3 (# i#, k #) (# j#, m #) repr arr -     where !(I# i#,I# j#) = bounds arr-           !k = unsafeAt arr (I# i#)-           !m = unsafeAt arr (I# i#)--{- The following CPP macros contents is taken from the 'Data.Either' module from @base@ package.--}-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__<802-fromLeft :: a -> Either a b -> a-fromLeft _ (Left x) = x-fromLeft def _ = def--fromRight :: b -> Either a b -> b-fromRight _ (Right x) = x-fromRight def _ = def-#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)-  -> Array Int PhoneticsRepresentationPLX-  -> Maybe PhoneticsRepresentationPLX-findSAI repr (xs,ys) arr- | isLeft repr = gBF3 (# i#, k #) (# j#, m #) (fromX2PRPL . fromLeft (PREmptyC " " ' ' " ") $ repr) arr- | otherwise = gBF3 (# i#, k #) (# j#, m #) (str2PRPL (fromRight [] repr) (xs,ys)) arr-     where !(I# i#,I# j#) = bounds arr-           !k = unsafeAt arr (I# i#)-           !m = unsafeAt arr (I# i#)-           str2PRPL :: String -> (String,String) -> PhoneticsRepresentationPL-           str2PRPL ts ([],[]) = PREmpty ts-           str2PRPL ts (ys,[]) = PRBefore ts ys-           str2PRPL ts ([],zs) = PRAfter ts zs-           str2PRPL ts (ys,zs) = PR ts zs ys--stringToXSG :: GWritingSystemPRPLX -> Generations -> String -> IGWritingSystemPRPLX-stringToXSG xs n ys- | any ((== n) . snd) xs && n > 0 = stringToXSGI (xs \\ ts) (n - 1) . xsG zs n $ pss- | otherwise = error "Data.Phonetic.Languages.Base.stringToXSG: Not defined for these first two arguments. "-    where !pss = stringToXS (concatMap fst xs) ys -- ps :: [String]-          !ts = filter ((== n) . snd) $ xs -- ts :: GWritingSystemPRPLX-          !zs = if null ts then [] else fst . head $ ts -- zs :: PhoneticRepresentationX-          xsG1 rs n (k1s:k2s:k3s:kss) (!r2s,!r3s,!r4s,!r5s) -- xsG1 :: [PhoneticRepresentationPLX] -> [String] -> Generations -> IGWritingSystemPRPLX-            | isJust x1 = (Right k1s,n - 1):(Left . fromJust $ x1,n):xsG1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)-            | isJust x2 = (Left . fromJust $ x2,n):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-            | isJust x3 = (Right k1s,n - 1):(Left . fromJust $ x3,n):xsG1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)-            | isJust x4 = (Left . fromJust $ x4,n):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-            | otherwise = (Right k1s,n - 1):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-                where !x1 = findSA (PR k2s k3s k1s) r2s-                      !x2 = findSA (PRAfter k1s k2s) r3s-                      !x3 = findSA (PRBefore k2s k1s) r4s-                      !x4 = findSA (PREmpty k1s) r5s-          xsG1 rs n (k1s:k2s:kss) (!r2s,!r3s,!r4s,!r5s)-            | isJust x2 = (Left . fromJust $ x2,n):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-            | isJust x3 = (Right k1s,n - 1):(Left . fromJust $ x3,n):xsG1 rs n kss (r2s,r3s,r4s,r5s)-            | isJust x4 = (Left . fromJust $ x4,n):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-            | otherwise = (Right k1s,n - 1):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-                where !x2 = findSA (PRAfter k1s k2s) r3s-                      !x3 = findSA (PRBefore k2s k1s) r4s-                      !x4 = findSA (PREmpty k1s) r5s-          xsG1 rs n [k1s] (_,_,_,r5s)-            | isJust x4 = [(Left . fromJust $ x4,n)]-            | otherwise = [(Right k1s,n - 1)]-                where !x4 = findSA (PREmpty k1s) r5s-          xsG1 rs n [] (_,_,_,_) = []-          xsG rs n jss = xsG1 rs n jss (r2s,r3s,r4s,r5s)-            where (!r2ls,!r3ls,!r4ls,!r5ls) = fHelp4 isPRC isPRAfterC isPRBeforeC isPREmptyC rs-                  !r2s = listArray (0,length r2ls - 1) r2ls-                  !r3s = listArray (0,length r3ls - 1) r3ls-                  !r4s = listArray (0,length r4ls - 1) r4ls-                  !r5s = listArray (0,length r5ls - 1) r5ls---- | Is used internally in the 'stringToXSG' and 'stringToXG' functions respectively. -stringToXSGI :: GWritingSystemPRPLX -> Generations -> IGWritingSystemPRPLX -> IGWritingSystemPRPLX-stringToXSGI xs n ys- | n > 0 = stringToXSGI (xs \\ ts) (n - 1) . xsGI zs n $ ys- | otherwise = ys-     where !ts = filter ((== n) . snd) xs -- ts :: GWritingSystemPRPLX-           !zs = concatMap fst ts -- zs :: PhoneticRepresentationX-           xsGI1 rs n (k1s:k2s:k3s:kss) (r2s,r3s,r4s,r5s) -- xsGI1 :: [PhoneticRepresentationPLX] -> Generations -> IGWritingSystemPRPLX -> IGWritingSystemPRPLX-            | snd k2s == n && isJust x1 = (fst k1s,n - 1):(Left . fromJust $ x1,n) : xsGI1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)-            | snd k1s == n && isJust x2 = (Left . fromJust $ x2,n):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-            | snd k2s == n && isJust x3 = (fst k1s,n - 1):(Left . fromJust $ x3 ,n):xsGI1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)-            | snd k1s == n && isJust x4 = (Left . fromJust $ x4, n):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-            | otherwise = (fst k1s,n - 1):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)-                where !x1 = findSAI (fst k2s) (either stringX id . fst $ k1s,either stringX id . fst $ k3s) r2s-                      !x2 = findSAI (fst k1s) ([],either stringX id . fst $ k2s) r3s-                      !x3 = findSAI (fst k2s) (either stringX id . fst $ k1s,[]) r4s-                      !x4 = findSAI (fst k1s) ([],[]) r5s-           xsGI1 rs n (k1s:k2s:kss) (r2s,r3s,r4s,r5s)-            | snd k1s == n && isJust x2 = (Left . fromJust $ x2,n):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-            | snd k2s == n && isJust x3 = (fst k1s,n - 1):(Left . fromJust $ x3,n):xsGI1 rs n kss (r2s,r3s,r4s,r5s)-            | snd k1s == n && isJust x4 = (Left . fromJust $ x4,n):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-            | otherwise = (fst k1s,n - 1):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)-                where !x2 = findSAI (fst k1s) ([],either stringX id . fst $ k2s) r3s-                      !x3 = findSAI (fst k2s) (either stringX id . fst $ k1s,[]) r4s-                      !x4 = findSAI (fst k1s) ([],[]) r5s-           xsGI1 rs n [k1s] (_,_,_,r5s)-            | snd k1s == n && isJust x4 = [(Left . fromJust $ x4,n)]-            | otherwise = [(fst k1s,n - 1)]-                where !x4 = findSAI (fst k1s) ([],[]) r5s-           xsGI1 rs n [] (_,_,_,_) = []-           xsGI rs n jss = xsGI1 rs n jss (r2s,r3s,r4s,r5s)-             where (!r2ls,!r3ls,!r4ls,!r5ls) = fHelp4 isPRC isPRAfterC isPRBeforeC isPREmptyC rs-                   !r2s = listArray (0,length r2ls - 1) r2ls-                   !r3s = listArray (0,length r3ls - 1) r3ls-                   !r4s = listArray (0,length r4ls - 1) r4ls-                   !r5s = listArray (0,length r5ls - 1) r5ls-        --- | The full conversion function. Applies conversion into representation using the 'GWritingSystemPRPLX' provided.-stringToXG :: GWritingSystemPRPLX -> String -> [PhoneticsRepresentationPLX]-stringToXG xs ys = fromPhoneticRX ts . map fst . stringToXSG xs n $ ys- where n = maximum . map snd $ xs-       !ts = concatMap fst . filter ((== 0) . snd) $ xs
− Data/Phonetic/Languages/PrepareText.hs 
@@ -1,224 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-}--{-# LANGUAGE MultiWayIf #-}---- |--- Module      :  Data.Phonetic.Languages.PrepareText--- Copyright   :  (c) OleksandrZhabenko 2020-2022--- License     :  MIT--- Stability   :  Experimental--- Maintainer  :  olexandr543@yahoo.com------ Helps to order the 7 or less phonetic language words (or their concatenations)--- to obtain (to some extent) suitable for poetry or music text.--- Earlier it has been a module DobutokO.Poetry.Ukrainian.PrepareText--- from the @dobutokO-poetry@ package.--- In particular, this module can be used to prepare the phonetic language text--- by applying the most needed grammar to avoid misunderstanding--- for the produced text. The attention is paid to the prepositions, pronouns, conjunctions--- and particles that are most commonly connected (or not) in a significant way--- with the next text.--- Uses the information from:--- https://uk.wikipedia.org/wiki/%D0%A1%D0%BF%D0%BE%D0%BB%D1%83%D1%87%D0%BD%D0%B8%D0%BA--- and--- https://uk.wikipedia.org/wiki/%D0%A7%D0%B0%D1%81%D1%82%D0%BA%D0%B0_(%D0%BC%D0%BE%D0%B2%D0%BE%D0%B7%D0%BD%D0%B0%D0%B2%D1%81%D1%82%D0%B2%D0%BE)------ Uses arrays instead of vectors.--- A list of basic (but, probably not complete and needed to be extended as needed) English words (the articles, pronouns,--- particles, conjunctions etc.) the corresponding phonetic language translations of which are intended to be used as a--- 'Concatenations' here is written to the file EnglishConcatenated.txt in the source tarball.--module Data.Phonetic.Languages.PrepareText (-  Concatenations-  -- * Basic functions-  , concatWordsFromLeftToRight-  , splitLines-  , splitLinesN-  , isSpC-  , sort2Concat-  -- * The end-user functions-  , prepareText-  , prepareTextN-  , growLinesN-  , prepareGrowTextMN-  , tuneLinesN-  , prepareTuneTextMN-  -- * Used to transform after convertToProperphonetic language from mmsyn6ukr package-  , isPLL-) where--import CaseBi.Arr (getBFstL',getBFst')-import Data.List.InnToOut.Basic (mapI)-import Data.Char (isAlpha,toLower)-import GHC.Arr-import Data.List (sort,sortOn)---- | The lists in the list are sorted in the descending order by the word counts in the inner 'String's. All the 'String's--- in each inner list have the same number of words, and if there is no 'String' with some intermediate number of words (e. g. there--- are 'String's for 4 and 2 words, but there is no one for 3 words 'String's) then such corresponding list is absent (since--- the 0.9.0.0 version). Probably the maximum number of words can be not more than 4, and the minimum number is--- not less than 1, but it depends. The 'String's in the inner lists must be (unlike the inner--- lists themselves) sorted in the ascending order for the data type to work correctly in the functions of the module.-type Concatenations = [[String]]--type ConcatenationsArr = [Array Int (String,Bool)]--defaultConversion :: Concatenations -> ConcatenationsArr-defaultConversion ysss = map (f . filter (not . null)) . filter (not . null) $ ysss-  where f :: [String] -> Array Int (String,Bool)-        f yss = let l = length yss in listArray (0,l-1) . zip yss . cycle $ [True]---- | Is used to convert a phonetic language text into list of 'String' each of which is ready to be--- used by the functions from the other modules in the package.--- It applies minimal grammar links and connections between the most commonly used phonetic language--- words that \"should\" be paired and not dealt with separately--- to avoid the misinterpretation and preserve maximum of the semantics for the--- \"phonetic\" language on the phonetic language basis.-prepareText-  :: [[String]] -- ^ Is intended to become a valid 'Concatenations'.-  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.-  -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.-  -> String-  -> [String]-prepareText = prepareTextN 7-{-# INLINE prepareText #-}--sort2Concat- :: [[String]]- -> Concatenations  -- ^ Data used to concatenate the basic grammar preserving words and word sequences to the next word or- -- to the previous word to- -- leave the most of the meaning (semantics) of the text available to easy understanding while reading and listening to.-sort2Concat xsss- | null xsss = []- | otherwise = map sort . reverse . sortOn (map (length . words)) $ xsss---------------------------------------------------------complexWords2 :: ConcatenationsArr -> String -> (String -> String,String)-complexWords2 ysss@(yss:zsss) zs@(r:rs)- | getBFst' (False, yss) . unwords $ tss = ((uwxs `mappend`), unwords uss)- | otherwise = complexWords2 zsss zs-      where y = length . words . fst . unsafeAt yss $ 0-            (tss,uss) = splitAt y . words $ zs-            uwxs = concat tss-complexWords2 _ zs = (id,zs)--pairCompl :: (String -> String,String) -> (String,String)-pairCompl (f,xs) = (f [],xs)--splitWords :: ConcatenationsArr -> [String] -> String -> (String,String)-splitWords ysss tss zs = let (ws,us) = pairCompl . complexWords2 ysss $ zs in if-  | null . words $ zs -> (mconcat tss,[])-  | null ws -> (\(xss,uss) -> (mconcat (tss `mappend` xss), unwords uss)) . splitAt 1 . words $ zs-  | otherwise -> splitWords ysss (tss `mappend` [ws]) us--concatWordsFromLeftToRight :: ConcatenationsArr -> String -> [String]-concatWordsFromLeftToRight ysss zs = let (ws,us) = splitWords ysss [] zs in-  if null us then [ws] else ws : concatWordsFromLeftToRight ysss us---------------------------------------------------------append2prependConv :: Concatenations -> Concatenations-append2prependConv = map (map (unwords . reverse . words))-{-# INLINE append2prependConv #-}--left2right :: [String] -> String-left2right = unwords . reverse . map reverse-{-# INLINE left2right #-}----------------------------------------------------------- | A generalized variant of the 'prepareText' with the arbitrary maximum number of the words in the lines given as the first argument.-prepareTextN- :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.- -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.- -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.- -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.- -> String- -> [String]-prepareTextN n ysss zsss xs = filter (any (isPLL xs)) . splitLinesN n . map (left2right .-  concatWordsFromLeftToRight (defaultConversion . sort2Concat . append2prependConv $ zsss) . left2right .-  concatWordsFromLeftToRight (defaultConversion . sort2Concat $ ysss)) . filter (not . null) . lines---- | A predicate to check whether the given character is one of the \"\' \\x2019\\x02BC-\".-isSpC :: Char -> Bool-isSpC x = x == '\'' || x == ' ' || x == '\x2019' || x == '\x02BC' || x == '-'-{-# INLINE isSpC #-}-{-# DEPRECATED #-}---- | The first argument must be a 'String' of sorted 'Char's in the ascending order of all possible symbols that can be--- used for the text in the phonetic language selected. Can be prepared beforehand, or read from the file.-isPLL :: String -> Char -> Bool-isPLL xs y = getBFstL' False (zip xs . replicate 10000 $ True) y---- | The function is recursive and is applied so that all returned elements ('String') are no longer than 7 words in them.-splitLines :: [String] -> [String]-splitLines = splitLinesN 7-{-# INLINE splitLines #-}---- | A generalized variant of the 'splitLines' with the arbitrary maximum number of the words in the lines given as the first argument.-splitLinesN :: Int -> [String] -> [String]-splitLinesN n xss- | null xss || n <= 0 = []- | otherwise = mapI (\xs -> compare (length . words $ xs) n == GT) (\xs -> let yss = words xs in-     splitLinesN n . map unwords . (\(q,r) -> [q,r]) . splitAt (length yss `quot` 2) $ yss) $ xss----------------------------------------------------{-| @ since 0.8.0.0-Given a positive number and a list tries to rearrange the list's 'String's by concatenation of the several elements of the list-so that the number of words in every new 'String' in the resulting list is not greater than the 'Int' argument. If some of the-'String's have more than that number quantity of the words then these 'String's are preserved.--}-growLinesN :: Int -> [String] -> [String]-growLinesN n xss- | null xss || n < 0 = []- | otherwise = unwords yss : growLinesN n zss-     where l = length . takeWhile (<= n) . scanl1 (+) . map (length . words) $ xss -- the maximum number of lines to be taken-           (yss,zss) = splitAt (max l 1) xss--{-| @ since 0.8.0.0-The function combines the 'prepareTextN' and 'growLinesN' function. Applies needed phonetic language preparations-to the text and tries to \'grow\' the resulting 'String's in the list so that the number of the words in every-of them is no greater than the given first 'Int' number.--}-prepareGrowTextMN- :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.- -> Int -- ^ A number of words in every 'String' that the function firstly forms. To have some sense of usage, must be less than the first argument.- -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.- -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.- -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.- -> String- -> [String]-prepareGrowTextMN m n ysss zsss xs = growLinesN m . prepareTextN n ysss zsss xs-{-# INLINE prepareGrowTextMN #-}-----------------------------------------{-| @ since 0.6.0.0-Recursively splits the concatenated list of lines of words so that in every resulting 'String' in the list-except the last one there is just 'Int' -- the first argument -- words.--}-tuneLinesN :: Int -> [String] -> [String]-tuneLinesN n xss- | null xss || n < 0 = []- | otherwise =-    let wss = words . unwords $ xss-        (yss,zss) = splitAt n wss-          in unwords yss : tuneLinesN n zss--{-| @ since 0.6.0.0-The function combines the 'prepareTextN' and 'tuneLinesN' functions. Applies needed phonetic language preparations-to the phonetic language text and splits the list of 'String's so that the number of the words in each of them (except the last one)-is equal the given first 'Int' number.--}-prepareTuneTextMN-  :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.-  -> Int -- ^ A number of words in every 'String' that the function firstly forms. To have some sense of usage, must be less than the first argument.-  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.-  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.-  -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.-  -> String-  -> [String]-prepareTuneTextMN m n ysss zsss xs = tuneLinesN m . prepareTextN n ysss zsss xs-{-# INLINE prepareTuneTextMN #-}
− Data/Phonetic/Languages/SpecificationsRead.hs 
@@ -1,41 +0,0 @@--- |--- Module      :  Data.Phonetic.Languages.SpecificationsRead--- Copyright   :  (c) OleksandrZhabenko 2021--- License     :  MIT--- Stability   :  Experimental--- Maintainer  :  olexandr543@yahoo.com------  Provides functions to read data specifications for other modules from textual files.--module Data.Phonetic.Languages.SpecificationsRead where--import Data.Char (isAlpha)-import Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations-import System.Environment (getArgs)-import GHC.Arr-import Text.Read-import Data.List-import Data.Maybe (fromMaybe,fromJust)-import GHC.Int-import Data.Phonetic.Languages.Base--charLine :: Char -> String -> Bool-charLine c = (== [c]) . take 1--groupBetweenChars- :: Char  -- ^ A delimiter (can be used probably multiple times) used between different parts of the data.- -> [String] -- ^ A list of 'String' that is partitioned using the 'String' starting with the delimiter.- -> [[String]]-groupBetweenChars c [] = []-groupBetweenChars c xs = css : groupBetweenChars c (dropWhile (charLine c) dss)-  where (css,dss) = span (charLine c) xs--{-| An example of the needed data structure to be read correctly is in the file gwrsysExample.txt in the source tarball. --}-getGWritingSystem-  :: Char -- ^ A delimiter (cab be used probably multiple times) between different parts of the data file. Usually, a tilda sign \'~\'.-  -> String -- ^ Actually the 'String' that is read into the result. -  -> GWritingSystemPRPLX -- ^ The data is used to obtain the phonetic language representation of the text.-getGWritingSystem c xs = map ((\(t1,t2) -> (sort . map (\kt -> fromJust (readPEMaybe kt::Maybe PhoneticsRepresentationPLX)) $ t2,-         read (concat t1)::Int8)) . splitAt 1) . groupBetweenChars c . lines $ xs-
− Data/Phonetic/Languages/Syllables.hs 
@@ -1,322 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-}-{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE FlexibleInstances #-}---- |--- Module      :  Data.Phonetic.Languages.Syllables--- Copyright   :  (c) OleksandrZhabenko 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 (-  -- * Data types and type synonyms-  PRS(..)-  , PhoneticType(..)-  , CharPhoneticClassification-  , StringRepresentation-  , SegmentationInfo1(..)-  , SegmentationPredFunction(..)-  , SegmentationPredFData(..)-  , SegmentationFDP-  , Eval2Bool(..)-  , DListFunctionResult-  , SegmentationLineFunction(..)-  , SegmentationRules1(..)-  , SegmentRulesG-  , DListRepresentation(..)-  -- * Basic functions-  , str2PRSs-  , sndGroups-  , groupSnds-  , divCnsnts-  , reSyllableCntnts-  , divSylls-  , createSyllablesPL-  -- * Auxiliary functions-  , gBF4-  , findC-  , createsSyllable-  , isSonorous1-  , isVoicedC1-  , isVoicelessC1-  , notCreatesSyllable2-  , notEqC-  , fromPhoneticType-) where--import Prelude hiding (mappend)-import Data.Monoid-import qualified Data.List as L (groupBy,find,intercalate)-import Data.Phonetic.Languages.Base-import CaseBi.Arr-import GHC.Arr-import GHC.Exts-import Data.List.InnToOut.Basic (mapI)-import Data.Maybe (mapMaybe,fromJust)-import GHC.Int-import Text.Read (readMaybe)-import Data.Char (isLetter)---- 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. For the vowels it has reserved value of 'P' 0, for the sonorous consonants - 'P' 1 and 'P' 2,-  -- for the voiced consonants - 'P' 3 and 'P' 4, for the voiceless consonants - 'P' 5 and 'P' 6. Nevertheless, it is possible to redefine the data by rewriting the-  -- respective parts of the code here.-} deriving ( Eq, Read )--instance Ord PRS where-  compare (SylS x1 y1) (SylS x2 y2) =-    case compare x1 x2 of-      EQ -> compare y1 y2-      ~z -> z--instance Show PRS where-  show (SylS c (P x)) = "SylS \'" `mappend` (c:'\'':' ':show x)--data PhoneticType = P !Int8 deriving (Eq, Ord, Read)--instance Show PhoneticType where-  show (P x) = "P " `mappend` show x--fromPhoneticType :: PhoneticType -> Int-fromPhoneticType (P x) = fromEnum x---- | The 'Array' 'Int' must be sorted in the ascending order to be used in the module correctly.-type CharPhoneticClassification = Array Int 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]---- | Is somewhat rewritten from the 'CaseBi.Arr.gBF3' function (not exported) from the @mmsyn2-array@ package.-gBF4-  :: (Ix i) => (# Int#, PRS #)-  -> (# Int#, PRS #)-  -> Char-  -> Array i PRS-  -> Maybe PRS-gBF4 (# !i#, k #) (# !j#, m #) c arr- | isTrue# ((j# -# i#) ># 1# ) = -    case compare c (charS p) of-     GT -> gBF4 (# n#, p #) (# j#, m #) c arr-     LT  -> gBF4 (# i#, k #) (# n#, p #) c arr-     _ -> Just p- | c == charS m = Just m- | c == charS k = Just k- | otherwise = Nothing-     where !n# = (i# +# j#) `quotInt#` 2#-           !p = unsafeAt arr (I# n#)-{-# INLINABLE gBF4 #-}--findC-  :: Char-  -> Array Int PRS-  -> Maybe PRS-findC c arr = gBF4 (# i#, k #) (# j#, m #) c arr -     where !(I# i#,I# j#) = bounds arr-           !k = unsafeAt arr (I# i#)-           !m = unsafeAt arr (I# i#)--str2PRSs :: CharPhoneticClassification -> String -> StringRepresentation-str2PRSs arr = map (\c -> fromJust . findC c $ arr)-  --- | Function-predicate 'createsSyllable' checks whether its argument is a phoneme representation that--- every time being presented in the text leads to the creation of the new syllable (in the 'PRS' format).--- Usually it is a vowel, but in some languages there can be syllabic phonemes that are not considered to be--- vowels.-createsSyllable :: PRS -> Bool-createsSyllable = (== P 0) . phoneType-{-# INLINE createsSyllable #-}---- | 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 'notCreatesSyllable2' checks whether its arguments are both consonant representations in the 'PRS' format.-notCreatesSyllable2 :: PRS -> PRS -> Bool-notCreatesSyllable2 x y-  | phoneType x == P 0 || phoneType y == P 0 = False-  | otherwise = True-{-# INLINE notCreatesSyllable2 #-}---- | 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 notCreatesSyllable2 ys-sndGroups _ = []--groupSnds :: [PRS] -> [[PRS]]-groupSnds = L.groupBy (\x y -> createsSyllable x == createsSyllable 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, Read, Show)--instance PhoneticElement SegmentationInfo1 where-  readPEMaybe rs-    | not . any isLetter $ rs = Nothing-    | otherwise = let (ys:yss) = words rs in case ys of-        "SI" -> case yss of-           [xs,ts] -> case (readMaybe xs::Maybe Int8) of-               Just m -> case (readMaybe ts::Maybe Int8) of-                 Just n -> Just (SI m n)-                 _ -> Nothing-               _ -> Nothing-           _ -> Nothing-        _ -> Nothing---- | We can think of 'SegmentationPredFunction' in terms of @f ('SI' fN pN) ks [x_{1},x_{2},...,x_{i},...,x_{fN}]@. Comparing with--- 'divCnsnts' from the @ukrainian-phonetics-basics-array@ we can postulate that it consists of the following logical terms in--- the symbolic form:--- --- 1) 'phoneType' x_{i} \`'elem'\` (X{...} = 'map' 'P' ['Int8'])--- --- 2) 'notEqC' ks x_{i} x_{j} (j /= i)--- --- combined with the standard logic Boolean operations of '(&&)', '(||)' and 'not'. Further, the 'not' can be transformed into the--- positive (affirmative) form using the notion of the universal set for the task. This transformation needs that the similar--- phonetic phenomenae (e. g. the double sounds -- the prolonged ones) belong to the one syllable and not to the different ones--- (so they are not related to different syllables, but just to the one and the same). Since such assumption has been used,--- we can further represent the function by the following data type and operations with it, see 'SegmentationPredFData'.-data SegmentationPredFunction = PF (SegmentationInfo1 -> [(Char, Char)] -> [PRS] -> Bool)--data SegmentationPredFData a b = L Int [Int] (Array Int a) | NEC Int Int (Array Int a) [b] | C (SegmentationPredFData a b) (SegmentationPredFData a b) |-  D (SegmentationPredFData a b) (SegmentationPredFData a b) deriving (Eq, Read, Show)--class Eval2Bool a where-  eval2Bool :: a -> Bool--type SegmentationFDP = SegmentationPredFData PRS (Char, Char)--instance Eval2Bool (SegmentationPredFData PRS (Char, Char)) where-  eval2Bool (L i js arr)-    | all (<= n) js && i <= n && i >= 1 && all (>=1) js = fromPhoneticType (phoneType (unsafeAt arr $ i - 1)) `elem` js-    | otherwise = error "Data.Phonetic.Languages.Syllables.eval2Bool: 'L' element is not properly defined. "-        where n = numElements arr-  eval2Bool (NEC i j arr ks)-    | i >= 1 && j >= 1 && i /= j && i <= n && j <= n = notEqC ks (unsafeAt arr $ i - 1) (unsafeAt arr $ j - 1)-    | otherwise = error "Data.Phonetic.Languages.Syllables.eval2Bool: 'NEC' element is not properly defined. "-        where n = numElements arr-  eval2Bool (C x y) = eval2Bool x && eval2Bool y-  eval2Bool (D x y) = eval2Bool x || eval2Bool y--type DListFunctionResult = ([PRS] -> [PRS],[PRS] -> [PRS])--class DListRepresentation a b where-  toDLR :: b -> [a] -> ([a] -> [a], [a] -> [a])--instance DListRepresentation PRS Int8 where-  toDLR left xs-    | null xs = (id,id)-    | null ts =  (id,(zs `mappend`))-    | null zs = ((`mappend` ts), id)-    | otherwise = ((`mappend` ts), (zs `mappend`))-        where (ts,zs) = splitAt (fromEnum left) xs-           -data SegmentationLineFunction = LFS {-  infoSP :: SegmentationInfo1,-  predF :: SegmentationFDP,  -- ^ The predicate to check the needed rule for segmentation.-  resF :: Int8 -- ^ The result argument to be appended to the left of the group of consonants if the 'predF' returns 'True' for its arguments. Is an argument to the 'toDLR'.-} deriving (Read, Show)--data SegmentationRules1 = SR1 {-  infoS :: SegmentationInfo1, -  lineFs :: [SegmentationLineFunction] -- ^ 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.-} deriving (Read, Show) ---- | 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 SegmentRulesG = [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)] -- ^ 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. - -> SegmentRulesG- -> [PRS]- -> DListFunctionResult-divCnsnts ks gs xs@(_:_) = toDLR left xs-  where !js = fromJust . L.find ((== length xs) . fromEnum . fieldN . infoS) $ gs -- js :: SegmentationRules1-        !left = resF . fromJust . L.find (eval2Bool . predF). lineFs $ js-divCnsnts _ _ [] = (id,id)--reSyllableCntnts- :: [(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. - -> SegmentRulesG- -> [[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--divSylls :: [[PRS]] -> [[PRS]]-divSylls = mapI (\ws -> (length . filter createsSyllable $ ws) > 1) h3-  where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> createsSyllable x && phoneType y /= P 0) . drop 1 $ zs)-                  where (ys,zs) = break createsSyllable us--{-| The function actually creates syllables using the provided data. Each resulting inner-most list is a phonetic language representation-of the syllable according to the rules provided.--}-createSyllablesPL-  :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.-  -> [(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. -  -> CharPhoneticClassification-  -> SegmentRulesG-  -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.-  -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.-  -> String -- ^ Actually the converted 'String'.-  -> [[[PRS]]]-createSyllablesPL wrs ks arr gs us vs = map (divSylls . reSyllableCntnts ks gs . groupSnds . str2PRSs arr) . 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'') = break (== ' ') ts-        {-# NOINLINE words1 #-}-        convertToProperPL = concatMap string1 . stringToXG wrs-{-# INLINE createSyllablesPL #-}
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2021-2022 Oleksandr Zhabenko+Copyright (c) 2021-2023 Oleksandr Zhabenko  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
Main.hs view
@@ -1,9 +1,9 @@ -- | -- Module      :  Main--- Copyright   :  (c) OleksandrZhabenko 2020-2021+-- Copyright   :  (c) Oleksandr Zhabenko 2020-2023 -- License     :  MIT -- Stability   :  Experimental--- Maintainer  :  olexandr543@yahoo.com+-- Maintainer  :  oleksandr.zhabenko@yahoo.com -- -- Can be used to calculate the durations of the approximations of the phonemes -- using some prepared text with its correct (at least mostly) pronunciation.@@ -24,21 +24,28 @@ -- The length of the 'String' js is refered to as 'lng'::'Int'. The number of 'pairs'' function elements in the lists is refered to -- as 'nn'::'Int'. The number of constraints is refered here as 'nc'::'Int'. @nc == nn `quot` 2@. -- --- Is generalized from the Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations module from+-- Is generalized from the Phladiprelio.RGLPK.Ukrainian module from -- the @r-glpk-phonetic-languages-ukrainian-durations@ package. +{-# LANGUAGE NoImplicitPrelude #-}+ module Main where +import GHC.Base+import GHC.Real ((/))+import GHC.Float (sqrt)+import GHC.Num ((*),(-),abs) import Data.Char (isAlpha)-import Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations+import Phladiprelio.RGLPK.General import System.Environment (getArgs) import GHC.Arr import Text.Read import Data.List import GHC.Int  import Data.Maybe (fromMaybe,fromJust)-import Data.Phonetic.Languages.Base-import Data.Phonetic.Languages.SpecificationsRead+import Phladiprelio.General.Base+import Phladiprelio.General.SpecificationsRead+import System.IO  main :: IO () main = do
− Numeric/Wrapper/R/GLPK/Phonetic/Languages/Durations.hs 
@@ -1,288 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK show-extensions #-}---- |--- Module      :  Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations--- Copyright   :  (c) OleksandrZhabenko 2020-2021--- License     :  MIT--- Stability   :  Experimental--- Maintainer  :  olexandr543@yahoo.com------ Can be used to calculate the durations of the approximations of the 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--- phonetic language 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.--- --- For the model correctness the js here refers to sorted list of the 'Char' representations of the phonetic language phenomenae.--- --- The length of the 'String' js is refered to as 'lng'::'Int'. The number of 'pairs'' function elements in the lists is refered to--- as 'nn'::'Int'. The number of constraints is refered here as 'nc'::'Int'. @nc == nn `quot` 2@.--- --- Is generalized from the Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations module from--- the @r-glpk-phonetic-languages-ukrainian-durations@ package.--module Numeric.Wrapper.R.GLPK.Phonetic.Languages.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 hiding (mconcat)-import Text.Read-import Data.Maybe-import CaseBi.Arr (getBFstL')-import Data.Foldable (foldl')-import GHC.Arr-import Numeric-import Data.List (intercalate,find,(\\))-import Data.Lists.FLines (newLineEnding)-import Data.Foldable.Ix (findIdx1)-#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 = map (\ts -> fromMaybe 1.0 (readMaybe ts::Maybe Double))--countCharInWords :: [String] -> Char -> [Int]-countCharInWords xss x-  | null xss = []-  | otherwise = map (length . filter (== x)) xss--matrix1Column :: PairwiseC -> [String] -> String -> Char -> [Int]-matrix1Column pw xss js x = pairwiseComparings x pw (mconcat [countCharInWords xss x, rs, rs])-  where l =  length js-        iX = fromMaybe (-l - 1) . findIdx1 x $ js-        rs = if iX < 0 then [] else mconcat [replicate iX 0,  [1],  replicate (l - 1 - iX) 0]--pairwiseComparings :: Char -> PairwiseC -> [Int] -> [Int]-pairwiseComparings x y zs = zs `mappend` pairs' y x---- | A way to encode the pairs of the phonetic language representations that give some additional associations, connections--- between elements, usually being caused by some similarity or commonality of the pronunciation act for the phenomenae--- corresponding to these elements. --- All ['Int'] must be equal in 'length' throughout the same namespace and this length is given as 'Int' argument in--- the 'PairwisePL'. This 'Int' parameter is @nn@.-data PairwisePL = PW Char Int [Int] deriving (Eq, Read, Show)--lengthPW :: PairwisePL -> Int-lengthPW (PW _ l _) = l--charPW :: PairwisePL -> Char-charPW (PW c _ _) = c--listPW :: PairwisePL -> [Int]-listPW (PW _ _ xs) = xs--data PairwiseC = LL [PairwisePL] Int deriving (Eq, Read, Show)--isCorrectPWC :: PairwiseC -> Bool-isCorrectPWC (LL xs n) = n == minimum (map lengthPW xs)--pwsC :: PairwiseC -> [PairwisePL]-pwsC (LL xs n) = map (\(PW c m ys) -> PW c n . take n $ ys) xs--pairs' :: PairwiseC -> Char -> [Int]-pairs' y@(LL xs n) x- | isCorrectPWC y = let z = find ((== x) . charPW) . pwsC $ y in-     if isJust z then listPW . fromJust $ z-     else replicate n 0- | otherwise = error "Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations.pairs': Not defined for the arguments. "---- | Actually @n@ is a 'length' bss.-matrixLine-  :: Int -- ^ The number of 'pairs'' function elements in the lists.-  -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.-  -> [String]-  -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.-  -> String-matrixLine nn pw bss js-  | null bss || n <=0 = []-  | otherwise = mconcat ["mat1 <- matrix(c(", intercalate ", " . map show . concatMap -      (matrix1Column pw (bss  `mappend`  bss) js) $ js, "), nrow = ", show (2 * n + 2 * length js + nn), ")", newLineEnding]-         where n = length bss--objLine- :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.- -> [(Int,Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation-  -- (which coefficients relates to which representation elements).- -> Array Int Double -- ^ An array of coefficients.- -> String-objLine lng xs arr- | numElements arr >= lng = mconcat ["obj1 <- c(", intercalate ", " . map (\t -> showFFloat Nothing t "") . objCoeffsNew lng xs $ arr,-      ")", newLineEnding]- | otherwise = error "Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations.objLine: Not defined for the short argument. "---- | A way to reorder the coefficients of the input and the elements representations related to each other.-objCoeffsNew-  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that-  -- appears in the file with test words and their spoken durations.-  -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation-  -- (which coefficients relates to which representation elements).-  -> Array Int Double -- ^ An array of coefficients.-  -> [Double]-objCoeffsNew lng xs arr = let lst = map (\(x,y) -> (x,unsafeAt arr y)) xs in map (getBFstL' 1.0 lst) [0..lng - 1]--maxLine :: String-maxLine = "max1 <- TRUE\n"--dirLine- :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.- -> Int -- ^ The number of 'pairs'' function elements in the lists.- -> [String] -- ^ An argument of the 'matrixLine' function.- -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.- -> String-dirLine lng nn bss js = mconcat ["dir1 <- c(\"<",  g "<" bss,  "\", \">",  g ">" (bss,  map (:[]) js),  "\"",  h0 lng,- h (nn `quot` 2), ")", newLineEnding]-  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 = mconcat ["rhs1 <- c(" ,  f (mconcat [xs ,  ys ,  zs]) ,  ")", newLineEnding]-  where f ts = (intercalate ", " . map (\t -> showFFloat Nothing t "") $ ts)--rhsLine- :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.- -> Int -- ^ The number of 'pairs'' function elements in the lists.- -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.- -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.- -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.- -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of-  -- phonemes) to set a general (common) behaviour for the set of resulting values.- -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the some group of representations (e. g. vowels). - -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the special group of representations (e. g. soft sign).  - -> [Double]- -> [Double]- -> String-rhsLine lng nn mx mn1 mnSpecial mnG xs1 sps1 = rhsLineG . mconcat $ [minDurations lng mn1 mnSpecial mnG xs1 sps1,  maxDurations lng mx,  constraintsR1 (nn `quot` 2)]--constraintsR1 :: Int -> [Double]-constraintsR1 n = replicate (2 * n) 0.0--minDurations-  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.-  -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.-  -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.-  -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of-  -- phonemes) to set a general (common) behaviour for the set of resulting values.-  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the some group of representations (e. g. vowels). -  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the special group of representations (e. g. soft sign). -  -> [Double]-minDurations lng mn1 mnSpecial mnG xs1 sps1 = map h [0..lng - 1]-  where xs2-         | maximum xs1 <= lng - 1 = filter (>= 0) xs1-         | otherwise = error "Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations.objLine: Not defined for these arguments. "-        sps2-         | maximum sps1 <= lng - 1 = filter (>= 0) sps1 \\ xs2-         | otherwise = error "Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations.objLine: Not defined for these arguments. "-        h i-         | i `elem` xs2 = mn1-         | i `elem` sps2 = mnSpecial-         | otherwise = mnG--maxDurations- :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.- -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.- -> [Double]-maxDurations lng mx = replicate lng mx---- | A variant of the more general 'answer2' where the predefined randomization parameters are used to produce every time being run--- a new result (e. g. this allows to model accents).-answer- :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that- -- appears in the file with test words and their spoken durations.- -> Int -- ^ The number of 'pairs'' function elements in the lists.- -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.- -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.- -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation-  -- (which coefficients relates to which representation elements).- -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.- -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.- -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of-  -- phonemes) to set a general (common) behaviour for the set of resulting values.- -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the some group of representations (e. g. vowels). - -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the special group of representations (e. g. soft sign). - -> Array Int Double -- ^ An array of coefficients.- -> [String] -- ^ An argument of the 'matrixLine' function.- -> [Double]- -> [Double]- -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.- -> String-answer lng nn pw mx ts = answer2 lng nn pw mx ts (-0.003) 0.003 (-0.0012) 0.0012--answer2-  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that-  -- appears in the file with test words and their spoken durations.-  -> Int -- ^ The number of 'pairs'' function elements in the lists.-  -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.-  -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.-  -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation-  -- (which coefficients relates to which representation elements).-  -> Double -- ^ A maximum in absolute value (being, usually, a negative one) possible random deviation from the computed value to be additionally applied to emulate-  -- 'more natural' behaviour and to get every time while running new sets of values. -  -> Double -- ^ A maximum in absolute value (being, usually, a positive one) possible random deviation from the computed value to be additionally applied to emulate-  -- 'more natural' behaviour and to get every time while running new sets of values. -  -> Double -- ^ A minimum in absolute value (being, usually, a negative one) possible random deviation from the computed value to be-  -- additionally applied to emulate 'more natural' behaviour and to get every time while running new sets of values. -  -> Double -- ^ A minimum in absolute value (being, usually, a positive one) possible random deviation from the computed value to be-  -- additionally applied to emulate 'more natural' behaviour and to get every time while running new sets of values. -  -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.-  -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of-  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.-  -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of-  -- phonemes) to set a general (common) behaviour for the set of resulting values.-  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the some group of representations (e. g. vowels). -  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that-  -- corresponds to the elements from the special group of representations (e. g. soft sign). -  -> Array Int Double -- ^ An array of coefficients.-  -> [String] -- ^ An argument of the 'matrixLine' function.-  -> [Double]-  -> [Double]-  -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.-  -> String-answer2 lng nn pw mx ts min1 max1 min2 max2 mn1 mnSpecial mnG xs1 sps1 lsts bss xs ys js = mconcat ["library(\"Rglpk\")",newLineEnding,objLine lng ts lsts,- matrixLine nn pw bss js,dirLine lng nn bss js, rhsLine lng nn mx mn1 mnSpecial mnG xs1 sps1 xs ys,maxLine,newLineEnding,-  "k <- Rglpk_solve_LP(obj = obj1, mat = mat1, dir = dir1, rhs = rhs1, max = max1)",newLineEnding, "y <- runif(",show lng,-   ", min = ", showFFloat Nothing (-(abs min1)) ", max = ", showFFloat Nothing (abs max1) ")", newLineEnding,-   "if (k$status == 0){k$solution / mean(k$solution)} else {c()}", newLineEnding, "\")}"]---- read ("SylS {charS=\'k\', phoneType=P 6")::PRS--
+ Phladiprelio/General/Base.hs view
@@ -0,0 +1,403 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}++-- |+-- Module      :  Phladiprelio.General.Base+-- Copyright   :  (c) Oleksandr Zhabenko 2021-2023+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  oleksandr.zhabenko@yahoo.com+--+-- This is a computational scheme for generalized usage of the phonetic languages approach. +-- It is intended to be exported qualified, so that the functions in every language+-- implementation have the same names and signatures as these ones and the data type used here.+-- It is may be not the most efficient implementation.+-- ++module Phladiprelio.General.Base (+  -- * Phonetics representation data type for the phonetic languages approach.+  PhoneticElement(..)+  , PhoneticsRepresentationPL(..)+  , PhoneticsRepresentationPLX(..)+  , Generations+  , InterGenerationsString+  , WritingSystemPRPLX+  , GWritingSystemPRPLX+  , PhoneticRepresentationXInter+  , IGWritingSystemPRPLX+  , fromX2PRPL+  , fromPhoneticRX+  -- * Functions to work with the one.+  -- ** Predicates+  , isPRC+  , isPRAfterC+  , isPRBeforeC+  , isPREmptyC+  -- ** Convert to the 'PhoneticsRepresentationPLX'.+  , stringToXSG+  , stringToXG+  , stringToXS+  , string2X+  -- ** Apply conversion from 'PhoneticsRepresentationPLX'.+  , rulesX+  -- * Auxiliary functions+  , fHelp4+  , findSA+  , findSAI+  -- * Some class extensions for 'Eq' and 'Ord' type classes+  , (~=)+  , compareG+) where++import GHC.Base+import GHC.List+import Data.List (sortBy,groupBy,nub,(\\),find,partition,intercalate,words)+import GHC.Int (Int8(..))+import Data.Maybe (isJust,fromJust)+import Data.Either+import Data.Char (isLetter)+import GHC.Arr+import GHC.Exts+import GHC.Num ((-))+import Data.Tuple (fst,snd)+import Text.Show (Show(..))++-- | The syllable after this is encoded with the representation with every 'Char' being some phonetic language phenomenon.+-- To see its usual written representation, use the defined 'showRepr' function (please, implement your own one).+data PhoneticsRepresentationPL = PR { string :: String, afterString :: String, beforeString :: String } |+  PRAfter { string :: String, afterString :: String } |+  PRBefore { string :: String, beforeString :: String } |+  PREmpty { string :: String }+    deriving (Eq, Ord)++instance Show PhoneticsRepresentationPL where+  show (PR xs ys zs) = intercalate " " ["R", show zs, show xs, show ys]+  show (PRAfter xs ys) = intercalate " " ["A", show xs, show ys]+  show (PRBefore xs zs) = intercalate " " ["B", show zs, show xs]+  show (PREmpty xs) = "E " `mappend` show xs++class PhoneticElement a where+  readPEMaybe :: String -> Maybe a++instance PhoneticElement PhoneticsRepresentationPL where+  readPEMaybe rs+    | not . any isLetter $ rs = Nothing+    | otherwise = case ys of+        "R" -> case yss of+           [zs,xs,ts] -> Just (PR xs ts zs)+           _ -> Nothing+        "A" -> case yss of+           [xs,ts] -> Just (PRAfter xs ts)+           _ -> Nothing+        "B" -> case yss of+           [zs,xs] -> Just (PRBefore xs zs)+           _ -> Nothing+        "E" -> case yss of+           [xs] -> Just (PREmpty xs)+           _ -> Nothing+        _ -> Nothing+       where (ys:yss) = words rs  ++-- | Extended variant of the 'PhoneticsRepresentationPL' data type where the information for the 'Char' is encoded into the+-- data itself. Is easier to implement the rules in the separate file by just specifying the proper and complete list of+-- 'PhoneticsRepresentationPLX' values. While the 'char' function can be used to group 'PhoneticRepresentationPLX'+-- that represents some phenomenae, for the phonetic languages approach the 'string1' is used in the most cases.+data PhoneticsRepresentationPLX = PRC { stringX :: String, afterStringX :: String, beforeStringX :: String, char :: Char, string1 :: String } |+  PRAfterC { stringX :: String, afterStringX :: String, char :: Char, string1 :: String } |+  PRBeforeC { stringX :: String, beforeStringX :: String, char :: Char, string1 :: String } |+  PREmptyC { stringX :: String, char :: Char, string1 :: String }+    deriving (Eq, Ord)++instance Show PhoneticsRepresentationPLX where+  show (PRC xs ys zs c us) = intercalate " " ["RC", show zs, show xs, show ys, '\'':c:"\'", us]+  show (PRAfterC xs ys c us) = intercalate " " ["AC", show xs, show ys, '\'':c:"\'", us]+  show (PRBeforeC xs zs c us) = intercalate " " ["BC", show zs, show xs, '\'':c:"\'", us]+  show (PREmptyC xs c us) = "EC " `mappend` show xs `mappend` (' ':'\'':c:"\'") `mappend` us++instance PhoneticElement PhoneticsRepresentationPLX where+  readPEMaybe rs+    | not . any isLetter $ rs = Nothing+    | otherwise = case ys of+        "RC" -> case yss of+           [zs,xs,ts,cs,us] -> case cs of+               '\'':c:"\'" -> Just (PRC xs ts zs c us)+               _ -> Nothing+           _ -> Nothing+        "AC" -> case yss of+           [xs,ts,cs,us] -> case cs of+               '\'':c:"\'" -> Just (PRAfterC xs ts c us)+               _ -> Nothing+           _ -> Nothing+        "BC" -> case yss of+           [zs,xs,cs,us] -> case cs of+               '\'':c:"\'" -> Just (PRBeforeC xs zs c us)+               _ -> Nothing+           _ -> Nothing+        "EC" -> case yss of+           [xs,cs,us] -> case cs of+               '\'':c:"\'" -> Just (PREmptyC xs c us)+               _ -> Nothing+           _ -> Nothing+        _ -> Nothing+       where (ys:yss) = words rs    ++isPRC :: PhoneticsRepresentationPLX -> Bool+isPRC (PRC _ _ _ _ _) = True+isPRC _ = False++isPRAfterC :: PhoneticsRepresentationPLX -> Bool+isPRAfterC (PRAfterC _ _ _ _) = True+isPRAfterC _ = False++isPRBeforeC :: PhoneticsRepresentationPLX -> Bool+isPRBeforeC (PRBeforeC _ _ _ _) = True+isPRBeforeC _ = False++isPREmptyC :: PhoneticsRepresentationPLX -> Bool+isPREmptyC (PREmptyC _ _ _) = True+isPREmptyC _ = False++fromX2PRPL :: PhoneticsRepresentationPLX -> PhoneticsRepresentationPL+fromX2PRPL (PREmptyC xs _ _) = PREmpty xs+fromX2PRPL (PRAfterC xs ys _ _) = PRAfter xs ys+fromX2PRPL (PRBeforeC xs zs _ _) = PRBefore xs zs+fromX2PRPL (PRC xs ys zs _ _) = PR xs ys zs+{-# INLINE fromX2PRPL #-}++-- | An analogue of the 'rulesPR' function for 'PhoneticsRepresentationPLX'. +rulesX :: PhoneticsRepresentationPLX -> Char+rulesX = char+{-# INLINE rulesX #-}++stringToXS :: WritingSystemPRPLX -> String -> [String]+stringToXS xs ys = ks : stringToX' zss l ts+  where !zss = nub . map stringX $ xs+        !l = maximum . map length $ zss+        f ys l zss = splitAt ((\xs -> if null xs then 1 else head xs) . filter (\n -> elem (take n ys) zss) $ [l,l-1..1]) ys+        {-# INLINE f #-}+        (!ks,!ts) = f ys l zss+        stringToX' rss m vs = bs : stringToX' rss m us+           where (!bs,!us) = f vs m rss++-- | Uses the simplest variant of the 'GWritingSystemPRPLX' with just two generations where all the 'PREmptyC' elements in the+-- 'WritingSystemPRPLX' are used in the last order. Can be suitable for simple languages (e. g. Esperanto).+string2X :: WritingSystemPRPLX -> String -> [PhoneticsRepresentationPLX]+string2X xs = stringToXG [(zs,1),(ys,0)]+  where (ys,zs) = partition isPREmptyC xs+{-# INLINE string2X #-}++-- | Each generation represents a subset of rules for representation transformation. The 'PhoneticsRepresentationPLX'+-- are groupped by the generations so that in every group with the same generation number ('Int8' value, typically starting+-- from 1) the rules represented have no conflicts with each other (this guarantees that they can be applied simultaneously+-- without the danger of incorrect interference). Usage of 'Generations' is a design decision and is inspired by the+-- GHC RULES pragma and the GHC compilation multistage process. +type Generations = Int8++-- | Each value represents temporary intermediate resulting 'String' data to be transformed further into the representation.+type InterGenerationsString = String++-- | If the list here is proper and complete, then it usually represents the whole writing system of the language. For proper usage,+-- the list must be sorted in the ascending order.+type WritingSystemPRPLX = [PhoneticsRepresentationPLX]++-- | The \'dynamic\' representation of the general writing system that specifies what transformations are made simultaneously+-- during the conversion to the phonetic languages phonetics representation. During transformations those elements that have+-- greater 'Generations' are used earlier than others. The last ones are used those elements with the 'Generations' element+-- equal to 0 that must correspond to the 'PREmptyC' constructor-built records. For proper usage, the lists on the first+-- place of the tuples must be sorted in the ascending order.+type GWritingSystemPRPLX = [([PhoneticsRepresentationPLX],Generations)]++{-| The intermediate representation of the phonetic languages data. Is used during conversions.+-}+type PhoneticRepresentationXInter = Either PhoneticsRepresentationPLX InterGenerationsString++fromPhoneticRX :: [PhoneticsRepresentationPLX] -> [PhoneticRepresentationXInter] -> [PhoneticsRepresentationPLX]+fromPhoneticRX ts = concatMap (fromInter2X ts)+  where fromInter2X :: [PhoneticsRepresentationPLX] -> PhoneticRepresentationXInter -> [PhoneticsRepresentationPLX]+        fromInter2X _ (Left x) = [x]+        fromInter2X ys (Right z) = filter ((== z) . stringX) ys++-- | The \'dynamic\' representation of the process of transformation for the general writing system during the conversion.+-- Is not intended to be produced by hand, but automatically by programs.+type IGWritingSystemPRPLX = [(PhoneticRepresentationXInter,Generations)]++-- | Splits the given list using 4 predicates into tuple of 4 lists of elements satisfying the predicates in the order+-- being preserved.+fHelp4 :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a],[a],[a],[a])+fHelp4 p1 p2 p3 p4 = foldr g v+  where v = ([],[],[],[])+        g x (xs1,xs2,xs3,xs4)+          | p1 x = (x:xs1,xs2,xs3,xs4)+          | p2 x = (xs1,x:xs2,xs3,xs4)+          | p3 x = (xs1,xs2,x:xs3,xs4)+          | p4 x = (xs1,xs2,xs3,x:xs4)+          | otherwise = (xs1,xs2,xs3,xs4)+{-# INLINE fHelp4 #-}++-- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of+-- '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+(PRBefore ys zs) ~= (PRBeforeC ys1 zs1 _ _) = ys == ys1 && zs == zs1+(PREmpty xs) ~= (PREmptyC xs1 _ _) = xs1 == xs1+_ ~= _ = False++-- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of+-- 'PhoneticsRepresentationPLX' values. +compareG :: PhoneticsRepresentationPL -> PhoneticsRepresentationPLX -> Ordering+compareG (PR xs ys zs) (PRC xs1 ys1 zs1 _ _)+ | xs /= xs1 = compare xs xs1+ | ys /= ys1 = compare ys ys1+ | zs /= zs1 = compare zs zs1+ | otherwise = EQ+compareG (PR _ _ _) _ = LT+compareG (PREmpty xs) (PREmptyC xs1 _ _)+ | xs /= xs1 = compare xs xs1+ | otherwise = EQ+compareG (PREmpty _) _ = GT+compareG (PRAfter xs ys) (PRAfterC xs1 ys1 _ _)+ | xs /= xs1 = compare xs xs1+ | ys /= ys1 = compare ys ys1+ | otherwise = EQ+compareG (PRAfter _ _) (PRC _ _ _ _ _) = GT+compareG (PRAfter _ _) _ = LT+compareG (PRBefore ys zs) (PRBeforeC ys1 zs1 _ _)+ | ys /= ys1 = compare ys ys1+ | zs /= zs1 = compare zs zs1+ | otherwise = EQ+compareG (PRBefore _ _) (PREmptyC _ _ _) = LT+compareG (PRBefore _ _) _ = GT++-- | Is somewhat rewritten from the 'CaseBi.Arr.gBF3' function (not exported) from the @mmsyn2-array@ package.+gBF3+  :: (Ix i) => (# Int#, PhoneticsRepresentationPLX #)+  -> (# Int#, PhoneticsRepresentationPLX #)+  -> PhoneticsRepresentationPL+  -> Array i PhoneticsRepresentationPLX+  -> Maybe PhoneticsRepresentationPLX+gBF3 (# !i#, k #) (# !j#, m #) repr arr+ | isTrue# ((j# -# i#) ># 1# ) = +    case compareG repr p of+     GT -> gBF3 (# n#, p #) (# j#, m #) repr arr+     LT  -> gBF3 (# i#, k #) (# n#, p #) repr arr+     _ -> Just p+ | repr ~= m = Just m+ | repr ~= k = Just k+ | otherwise = Nothing+     where !n# = (i# +# j#) `quotInt#` 2#+           !p = unsafeAt arr (I# n#)+{-# INLINABLE gBF3 #-}++findSA+  :: PhoneticsRepresentationPL+  -> Array Int PhoneticsRepresentationPLX+  -> Maybe PhoneticsRepresentationPLX+findSA repr arr = gBF3 (# i#, k #) (# j#, m #) repr arr +     where !(I# i#,I# j#) = bounds arr+           !k = unsafeAt arr (I# i#)+           !m = unsafeAt arr (I# i#)++-- | 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)+  -> Array Int PhoneticsRepresentationPLX+  -> Maybe PhoneticsRepresentationPLX+findSAI repr (xs,ys) arr+ | isLeft repr = gBF3 (# i#, k #) (# j#, m #) (fromX2PRPL . fromLeft (PREmptyC " " ' ' " ") $ repr) arr+ | otherwise = gBF3 (# i#, k #) (# j#, m #) (str2PRPL (fromRight [] repr) (xs,ys)) arr+     where !(I# i#,I# j#) = bounds arr+           !k = unsafeAt arr (I# i#)+           !m = unsafeAt arr (I# i#)+           str2PRPL :: String -> (String,String) -> PhoneticsRepresentationPL+           str2PRPL ts ([],[]) = PREmpty ts+           str2PRPL ts (ys,[]) = PRBefore ts ys+           str2PRPL ts ([],zs) = PRAfter ts zs+           str2PRPL ts (ys,zs) = PR ts zs ys++stringToXSG :: GWritingSystemPRPLX -> Generations -> String -> IGWritingSystemPRPLX+stringToXSG xs n ys+ | any ((== n) . snd) xs && n > 0 = stringToXSGI (xs \\ ts) (n - 1) . xsG zs n $ pss+ | otherwise = error "Data.Phonetic.Languages.Base.stringToXSG: Not defined for these first two arguments. "+    where !pss = stringToXS (concatMap fst xs) ys -- ps :: [String]+          !ts = filter ((== n) . snd) $ xs -- ts :: GWritingSystemPRPLX+          !zs = if null ts then [] else fst . head $ ts -- zs :: PhoneticRepresentationX+          xsG1 rs n (k1s:k2s:k3s:kss) (!r2s,!r3s,!r4s,!r5s) -- xsG1 :: [PhoneticRepresentationPLX] -> [String] -> Generations -> IGWritingSystemPRPLX+            | isJust x1 = (Right k1s,n - 1):(Left . fromJust $ x1,n):xsG1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)+            | isJust x2 = (Left . fromJust $ x2,n):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+            | isJust x3 = (Right k1s,n - 1):(Left . fromJust $ x3,n):xsG1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)+            | isJust x4 = (Left . fromJust $ x4,n):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+            | otherwise = (Right k1s,n - 1):xsG1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+                where !x1 = findSA (PR k2s k3s k1s) r2s+                      !x2 = findSA (PRAfter k1s k2s) r3s+                      !x3 = findSA (PRBefore k2s k1s) r4s+                      !x4 = findSA (PREmpty k1s) r5s+          xsG1 rs n (k1s:k2s:kss) (!r2s,!r3s,!r4s,!r5s)+            | isJust x2 = (Left . fromJust $ x2,n):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+            | isJust x3 = (Right k1s,n - 1):(Left . fromJust $ x3,n):xsG1 rs n kss (r2s,r3s,r4s,r5s)+            | isJust x4 = (Left . fromJust $ x4,n):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+            | otherwise = (Right k1s,n - 1):xsG1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+                where !x2 = findSA (PRAfter k1s k2s) r3s+                      !x3 = findSA (PRBefore k2s k1s) r4s+                      !x4 = findSA (PREmpty k1s) r5s+          xsG1 rs n [k1s] (_,_,_,r5s)+            | isJust x4 = [(Left . fromJust $ x4,n)]+            | otherwise = [(Right k1s,n - 1)]+                where !x4 = findSA (PREmpty k1s) r5s+          xsG1 rs n [] (_,_,_,_) = []+          xsG rs n jss = xsG1 rs n jss (r2s,r3s,r4s,r5s)+            where (!r2ls,!r3ls,!r4ls,!r5ls) = fHelp4 isPRC isPRAfterC isPRBeforeC isPREmptyC rs+                  !r2s = listArray (0,length r2ls - 1) r2ls+                  !r3s = listArray (0,length r3ls - 1) r3ls+                  !r4s = listArray (0,length r4ls - 1) r4ls+                  !r5s = listArray (0,length r5ls - 1) r5ls++-- | Is used internally in the 'stringToXSG' and 'stringToXG' functions respectively. +stringToXSGI :: GWritingSystemPRPLX -> Generations -> IGWritingSystemPRPLX -> IGWritingSystemPRPLX+stringToXSGI xs n ys+ | n > 0 = stringToXSGI (xs \\ ts) (n - 1) . xsGI zs n $ ys+ | otherwise = ys+     where !ts = filter ((== n) . snd) xs -- ts :: GWritingSystemPRPLX+           !zs = concatMap fst ts -- zs :: PhoneticRepresentationX+           xsGI1 rs n (k1s:k2s:k3s:kss) (r2s,r3s,r4s,r5s) -- xsGI1 :: [PhoneticRepresentationPLX] -> Generations -> IGWritingSystemPRPLX -> IGWritingSystemPRPLX+            | snd k2s == n && isJust x1 = (fst k1s,n - 1):(Left . fromJust $ x1,n) : xsGI1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)+            | snd k1s == n && isJust x2 = (Left . fromJust $ x2,n):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+            | snd k2s == n && isJust x3 = (fst k1s,n - 1):(Left . fromJust $ x3 ,n):xsGI1 rs n (k3s:kss) (r2s,r3s,r4s,r5s)+            | snd k1s == n && isJust x4 = (Left . fromJust $ x4, n):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+            | otherwise = (fst k1s,n - 1):xsGI1 rs n (k2s:k3s:kss) (r2s,r3s,r4s,r5s)+                where !x1 = findSAI (fst k2s) (either stringX id . fst $ k1s,either stringX id . fst $ k3s) r2s+                      !x2 = findSAI (fst k1s) ([],either stringX id . fst $ k2s) r3s+                      !x3 = findSAI (fst k2s) (either stringX id . fst $ k1s,[]) r4s+                      !x4 = findSAI (fst k1s) ([],[]) r5s+           xsGI1 rs n (k1s:k2s:kss) (r2s,r3s,r4s,r5s)+            | snd k1s == n && isJust x2 = (Left . fromJust $ x2,n):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+            | snd k2s == n && isJust x3 = (fst k1s,n - 1):(Left . fromJust $ x3,n):xsGI1 rs n kss (r2s,r3s,r4s,r5s)+            | snd k1s == n && isJust x4 = (Left . fromJust $ x4,n):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+            | otherwise = (fst k1s,n - 1):xsGI1 rs n (k2s:kss) (r2s,r3s,r4s,r5s)+                where !x2 = findSAI (fst k1s) ([],either stringX id . fst $ k2s) r3s+                      !x3 = findSAI (fst k2s) (either stringX id . fst $ k1s,[]) r4s+                      !x4 = findSAI (fst k1s) ([],[]) r5s+           xsGI1 rs n [k1s] (_,_,_,r5s)+            | snd k1s == n && isJust x4 = [(Left . fromJust $ x4,n)]+            | otherwise = [(fst k1s,n - 1)]+                where !x4 = findSAI (fst k1s) ([],[]) r5s+           xsGI1 rs n [] (_,_,_,_) = []+           xsGI rs n jss = xsGI1 rs n jss (r2s,r3s,r4s,r5s)+             where (!r2ls,!r3ls,!r4ls,!r5ls) = fHelp4 isPRC isPRAfterC isPRBeforeC isPREmptyC rs+                   !r2s = listArray (0,length r2ls - 1) r2ls+                   !r3s = listArray (0,length r3ls - 1) r3ls+                   !r4s = listArray (0,length r4ls - 1) r4ls+                   !r5s = listArray (0,length r5ls - 1) r5ls+        +-- | The full conversion function. Applies conversion into representation using the 'GWritingSystemPRPLX' provided.+stringToXG :: GWritingSystemPRPLX -> String -> [PhoneticsRepresentationPLX]+stringToXG xs ys = fromPhoneticRX ts . map fst . stringToXSG xs n $ ys+ where n = maximum . map snd $ xs+       !ts = concatMap fst . filter ((== 0) . snd) $ xs
+ Phladiprelio/General/PrepareText.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE MultiWayIf, NoImplicitPrelude #-}++-- |+-- Module      :  Phladiprelio.General.PrepareText+-- Copyright   :  (c) Oleksandr Zhabenko 2020-2023+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  oleksandr.zhabenko@yahoo.com+--+-- Helps to order the 7 or less phonetic language words (or their concatenations)+-- to obtain (to some extent) suitable for poetry or music text.+-- Earlier it has been a module DobutokO.Poetry.Ukrainian.PrepareText+-- from the @dobutokO-poetry@ package.+-- In particular, this module can be used to prepare the phonetic language text+-- by applying the most needed grammar to avoid misunderstanding+-- for the produced text. The attention is paid to the prepositions, pronouns, conjunctions+-- and particles that are most commonly connected (or not) in a significant way+-- with the next text.+-- Uses the information from:+-- https://uk.wikipedia.org/wiki/%D0%A1%D0%BF%D0%BE%D0%BB%D1%83%D1%87%D0%BD%D0%B8%D0%BA+-- and+-- https://uk.wikipedia.org/wiki/%D0%A7%D0%B0%D1%81%D1%82%D0%BA%D0%B0_(%D0%BC%D0%BE%D0%B2%D0%BE%D0%B7%D0%BD%D0%B0%D0%B2%D1%81%D1%82%D0%B2%D0%BE)+--+-- Uses arrays instead of vectors.+-- A list of basic (but, probably not complete and needed to be extended as needed) English words (the articles, pronouns,+-- particles, conjunctions etc.) the corresponding phonetic language translations of which are intended to be used as a+-- 'Concatenations' here is written to the file EnglishConcatenated.txt in the source tarball.++module Phladiprelio.General.PrepareText (+  Concatenations+  -- * Basic functions+  , concatWordsFromLeftToRight+  , splitLines+  , splitLinesN+  , isSpC+  , sort2Concat+  -- * The end-user functions+  , prepareText+  , prepareTextN+  , growLinesN+  , prepareGrowTextMN+  , tuneLinesN+  , prepareTuneTextMN+  -- * Used to transform after convertToProperphonetic language from mmsyn6ukr package+  , isPLL+) where++import GHC.Base+import Data.List+import Data.Bits (shiftR)+import GHC.Num ((+),(-),abs)+import CaseBi.Arr (getBFstL',getBFst')+import Data.List.InnToOut.Basic (mapI)+import Data.Char (isAlpha,toLower)+import GHC.Arr+import Data.Tuple (fst)++-- | The lists in the list are sorted in the descending order by the word counts in the inner 'String's. All the 'String's+-- in each inner list have the same number of words, and if there is no 'String' with some intermediate number of words (e. g. there+-- are 'String's for 4 and 2 words, but there is no one for 3 words 'String's) then such corresponding list is absent (since+-- the 0.9.0.0 version). Probably the maximum number of words can be not more than 4, and the minimum number is+-- not less than 1, but it depends. The 'String's in the inner lists must be (unlike the inner+-- lists themselves) sorted in the ascending order for the data type to work correctly in the functions of the module.+type Concatenations = [[String]]++type ConcatenationsArr = [Array Int (String,Bool)]++defaultConversion :: Concatenations -> ConcatenationsArr+defaultConversion ysss = map (f . filter (not . null)) . filter (not . null) $ ysss+  where f :: [String] -> Array Int (String,Bool)+        f yss = let l = length yss in listArray (0,l-1) . zip yss . cycle $ [True]++-- | Is used to convert a phonetic language text into list of 'String' each of which is ready to be+-- used by the functions from the other modules in the package.+-- It applies minimal grammar links and connections between the most commonly used phonetic language+-- words that \"should\" be paired and not dealt with separately+-- to avoid the misinterpretation and preserve maximum of the semantics for the+-- \"phonetic\" language on the phonetic language basis.+prepareText+  :: [[String]] -- ^ Is intended to become a valid 'Concatenations'.+  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+  -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.+  -> String+  -> [String]+prepareText = prepareTextN 7+{-# INLINE prepareText #-}++sort2Concat+ :: [[String]]+ -> Concatenations  -- ^ Data used to concatenate the basic grammar preserving words and word sequences to the next word or+ -- to the previous word to+ -- leave the most of the meaning (semantics) of the text available to easy understanding while reading and listening to.+sort2Concat xsss+ | null xsss = []+ | otherwise = map sort . reverse . sortOn (map (length . words)) $ xsss++-----------------------------------------------------++complexWords2 :: ConcatenationsArr -> String -> (String -> String,String)+complexWords2 ysss@(yss:zsss) zs@(r:rs)+ | getBFst' (False, yss) . unwords $ tss = ((uwxs `mappend`), unwords uss)+ | otherwise = complexWords2 zsss zs+      where y = length . words . fst . unsafeAt yss $ 0+            (tss,uss) = splitAt y . words $ zs+            uwxs = concat tss+complexWords2 _ zs = (id,zs)++pairCompl :: (String -> String,String) -> (String,String)+pairCompl (f,xs) = (f [],xs)++splitWords :: ConcatenationsArr -> [String] -> String -> (String,String)+splitWords ysss tss zs = let (ws,us) = pairCompl . complexWords2 ysss $ zs in if+  | null . words $ zs -> (mconcat tss,[])+  | null ws -> (\(xss,uss) -> (mconcat (tss `mappend` xss), unwords uss)) . splitAt 1 . words $ zs+  | otherwise -> splitWords ysss (tss `mappend` [ws]) us++concatWordsFromLeftToRight :: ConcatenationsArr -> String -> [String]+concatWordsFromLeftToRight ysss zs = let (ws,us) = splitWords ysss [] zs in+  if null us then [ws] else ws : concatWordsFromLeftToRight ysss us++-----------------------------------------------------++append2prependConv :: Concatenations -> Concatenations+append2prependConv = map (map (unwords . reverse . words))+{-# INLINE append2prependConv #-}++left2right :: [String] -> String+left2right = unwords . reverse . map reverse+{-# INLINE left2right #-}++-----------------------------------------------------++-- | A generalized variant of the 'prepareText' with the arbitrary maximum number of the words in the lines given as the first argument.+prepareTextN+ :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.+ -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+ -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+ -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.+ -> String+ -> [String]+prepareTextN n ysss zsss xs = filter (any (isPLL xs)) . splitLinesN n . map (left2right .+  concatWordsFromLeftToRight (defaultConversion . sort2Concat . append2prependConv $ zsss) . left2right .+  concatWordsFromLeftToRight (defaultConversion . sort2Concat $ ysss)) . filter (not . null) . lines++-- | A predicate to check whether the given character is one of the \"\' \\x2019\\x02BC-\".+isSpC :: Char -> Bool+isSpC x = x == '\'' || x == ' ' || x == '\x2019' || x == '\x02BC' || x == '-'+{-# INLINE isSpC #-}+{-# DEPRECATED #-}++-- | The first argument must be a 'String' of sorted 'Char's in the ascending order of all possible symbols that can be+-- used for the text in the phonetic language selected. Can be prepared beforehand, or read from the file.+isPLL :: String -> Char -> Bool+isPLL xs y = getBFstL' False (zip xs . replicate 10000 $ True) y++-- | The function is recursive and is applied so that all returned elements ('String') are no longer than 7 words in them.+splitLines :: [String] -> [String]+splitLines = splitLinesN 7+{-# INLINE splitLines #-}++-- | A generalized variant of the 'splitLines' with the arbitrary maximum number of the words in the lines given as the first argument.+splitLinesN :: Int -> [String] -> [String]+splitLinesN n xss+ | null xss || n <= 0 = []+ | otherwise = mapI (\xs -> compare (length . words $ xs) n == GT) (\xs -> let yss = words xs in+     splitLinesN n . map unwords . (\(q,r) -> [q,r]) . splitAt (shiftR (length yss) 1) $ yss) $ xss++------------------------------------------------++{-| @ since 0.8.0.0+Given a positive number and a list tries to rearrange the list's 'String's by concatenation of the several elements of the list+so that the number of words in every new 'String' in the resulting list is not greater than the 'Int' argument. If some of the+'String's have more than that number quantity of the words then these 'String's are preserved.+-}+growLinesN :: Int -> [String] -> [String]+growLinesN n xss+ | null xss || n < 0 = []+ | otherwise = unwords yss : growLinesN n zss+     where l = length . takeWhile (<= n) . scanl1 (+) . map (length . words) $ xss -- the maximum number of lines to be taken+           (yss,zss) = splitAt (max l 1) xss++{-| @ since 0.8.0.0+The function combines the 'prepareTextN' and 'growLinesN' function. Applies needed phonetic language preparations+to the text and tries to \'grow\' the resulting 'String's in the list so that the number of the words in every+of them is no greater than the given first 'Int' number.+-}+prepareGrowTextMN+ :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.+ -> Int -- ^ A number of words in every 'String' that the function firstly forms. To have some sense of usage, must be less than the first argument.+ -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+ -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+ -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.+ -> String+ -> [String]+prepareGrowTextMN m n ysss zsss xs = growLinesN m . prepareTextN n ysss zsss xs+{-# INLINE prepareGrowTextMN #-}++-------------------------------------++{-| @ since 0.6.0.0+Recursively splits the concatenated list of lines of words so that in every resulting 'String' in the list+except the last one there is just 'Int' -- the first argument -- words.+-}+tuneLinesN :: Int -> [String] -> [String]+tuneLinesN n xss+ | null xss || n < 0 = []+ | otherwise =+    let wss = words . unwords $ xss+        (yss,zss) = splitAt n wss+          in unwords yss : tuneLinesN n zss++{-| @ since 0.6.0.0+The function combines the 'prepareTextN' and 'tuneLinesN' functions. Applies needed phonetic language preparations+to the phonetic language text and splits the list of 'String's so that the number of the words in each of them (except the last one)+is equal the given first 'Int' number.+-}+prepareTuneTextMN+  :: Int -- ^ A maximum number of the words or their concatenations in the resulting list of 'String's.+  -> Int -- ^ A number of words in every 'String' that the function firstly forms. To have some sense of usage, must be less than the first argument.+  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+  -> [[String]] -- ^ Is intended to become a valid 'Concatenations'.+  -> String -- ^ A sorted 'String' of possible characters in the phonetic language representation.+  -> String+  -> [String]+prepareTuneTextMN m n ysss zsss xs = tuneLinesN m . prepareTextN n ysss zsss xs+{-# INLINE prepareTuneTextMN #-}
+ Phladiprelio/General/SpecificationsRead.hs view
@@ -0,0 +1,47 @@+-- |+-- Module      :  Phladiprelio.General.SpecificationsRead+-- Copyright   :  (c) Oleksandr Zhabenko 2021-2023+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  oleksandr.zhabenko@yahoo.com+--+--  Provides functions to read data specifications for other modules from textual files.+++{-# LANGUAGE NoImplicitPrelude #-}+++module Phladiprelio.General.SpecificationsRead where++import GHC.Base+import GHC.List+import Data.List (sort,lines)+import Data.Char (isAlpha)+import Phladiprelio.RGLPK.General+import System.Environment (getArgs)+import GHC.Arr+import Text.Read+import Data.Maybe (fromMaybe,fromJust)+import GHC.Int+import Phladiprelio.General.Base++charLine :: Char -> String -> Bool+charLine c = (== [c]) . take 1++groupBetweenChars+ :: Char  -- ^ A delimiter (can be used probably multiple times) used between different parts of the data.+ -> [String] -- ^ A list of 'String' that is partitioned using the 'String' starting with the delimiter.+ -> [[String]]+groupBetweenChars c [] = []+groupBetweenChars c xs = css : groupBetweenChars c (dropWhile (charLine c) dss)+  where (css,dss) = span (charLine c) xs++{-| An example of the needed data structure to be read correctly is in the file gwrsysExample.txt in the source tarball. +-}+getGWritingSystem+  :: Char -- ^ A delimiter (cab be used probably multiple times) between different parts of the data file. Usually, a tilda sign \'~\'.+  -> String -- ^ Actually the 'String' that is read into the result. +  -> GWritingSystemPRPLX -- ^ The data is used to obtain the phonetic language representation of the text.+getGWritingSystem c xs = map ((\(t1,t2) -> (sort . map (\kt -> fromJust (readPEMaybe kt::Maybe PhoneticsRepresentationPLX)) $ t2,+         read (concat t1)::Int8)) . splitAt 1) . groupBetweenChars c . lines $ xs+
+ Phladiprelio/General/Syllables.hs view
@@ -0,0 +1,328 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+++-- |+-- Module      :  Phladiprelio.General.Syllables+-- Copyright   :  (c) Oleksandr Zhabenko 2021-2023+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  oleksandr.zhabenko@yahoo.com+--+-- This module works with syllable segmentation. The generalized version for the module+-- 'Phladiprelio.Ukrainian.Syllable' from @ukrainian-phonetics-basic-array@ package.+-- ++module Phladiprelio.General.Syllables (+  -- * Data types and type synonyms+  PRS(..)+  , PhoneticType(..)+  , CharPhoneticClassification+  , StringRepresentation+  , SegmentationInfo1(..)+  , SegmentationPredFunction(..)+  , SegmentationPredFData(..)+  , SegmentationFDP+  , Eval2Bool(..)+  , DListFunctionResult+  , SegmentationLineFunction(..)+  , SegmentationRules1(..)+  , SegmentRulesG+  , DListRepresentation(..)+  -- * Basic functions+  , str2PRSs+  , sndGroups+  , groupSnds+  , divCnsnts+  , reSyllableCntnts+  , divSylls+  , createSyllablesPL+  -- * Auxiliary functions+  , gBF4+  , findC+  , createsSyllable+  , isSonorous1+  , isVoicedC1+  , isVoicelessC1+  , notCreatesSyllable2+  , notEqC+  , fromPhoneticType+) where++import GHC.Base+import GHC.List+import Data.Monoid+import qualified Data.List as L (groupBy,find,intercalate,words)+import Phladiprelio.General.Base+import CaseBi.Arr+import GHC.Arr+import GHC.Exts+import Data.List.InnToOut.Basic (mapI)+import Data.Maybe (mapMaybe,fromJust)+import GHC.Int+import Text.Read (Read(..),readMaybe)+import Text.Show (Show(..))+import Data.Char (isLetter)+import GHC.Num ((-))+import Data.Tuple (fst, snd)++-- 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. For the vowels it has reserved value of 'P' 0, for the sonorous consonants - 'P' 1 and 'P' 2,+  -- for the voiced consonants - 'P' 3 and 'P' 4, for the voiceless consonants - 'P' 5 and 'P' 6. Nevertheless, it is possible to redefine the data by rewriting the+  -- respective parts of the code here.+} deriving ( Eq, Read )++instance Ord PRS where+  compare (SylS x1 y1) (SylS x2 y2) =+    case compare x1 x2 of+      EQ -> compare y1 y2+      ~z -> z++instance Show PRS where+  show (SylS c (P x)) = "SylS \'" `mappend` (c:'\'':' ':show x)++data PhoneticType = P !Int8 deriving (Eq, Ord, Read)++instance Show PhoneticType where+  show (P x) = "P " `mappend` show x++fromPhoneticType :: PhoneticType -> Int+fromPhoneticType (P (I8# x)) =  I# x++-- | The 'Array' 'Int' must be sorted in the ascending order to be used in the module correctly.+type CharPhoneticClassification = Array Int 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]++-- | Is somewhat rewritten from the 'CaseBi.Arr.gBF3' function (not exported) from the @mmsyn2-array@ package.+gBF4+  :: (Ix i) => (# Int#, PRS #)+  -> (# Int#, PRS #)+  -> Char+  -> Array i PRS+  -> Maybe PRS+gBF4 (# !i#, k #) (# !j#, m #) c arr+ | isTrue# ((j# -# i#) ># 1# ) = +    case compare c (charS p) of+     GT -> gBF4 (# n#, p #) (# j#, m #) c arr+     LT  -> gBF4 (# i#, k #) (# n#, p #) c arr+     _ -> Just p+ | c == charS m = Just m+ | c == charS k = Just k+ | otherwise = Nothing+     where !n# = (i# +# j#) `quotInt#` 2#+           !p = unsafeAt arr (I# n#)+{-# INLINABLE gBF4 #-}++findC+  :: Char+  -> Array Int PRS+  -> Maybe PRS+findC c arr = gBF4 (# i#, k #) (# j#, m #) c arr +     where !(I# i#,I# j#) = bounds arr+           !k = unsafeAt arr (I# i#)+           !m = unsafeAt arr (I# i#)++str2PRSs :: CharPhoneticClassification -> String -> StringRepresentation+str2PRSs arr = map (\c -> fromJust . findC c $ arr)+  +-- | Function-predicate 'createsSyllable' checks whether its argument is a phoneme representation that+-- every time being presented in the text leads to the creation of the new syllable (in the 'PRS' format).+-- Usually it is a vowel, but in some languages there can be syllabic phonemes that are not considered to be+-- vowels.+createsSyllable :: PRS -> Bool+createsSyllable = (== P 0) . phoneType+{-# INLINE createsSyllable #-}++-- | 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 'notCreatesSyllable2' checks whether its arguments are both consonant representations in the 'PRS' format.+notCreatesSyllable2 :: PRS -> PRS -> Bool+notCreatesSyllable2 x y+  | phoneType x == P 0 || phoneType y == P 0 = False+  | otherwise = True+{-# INLINE notCreatesSyllable2 #-}++-- | 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 notCreatesSyllable2 ys+sndGroups _ = []++groupSnds :: [PRS] -> [[PRS]]+groupSnds = L.groupBy (\x y -> createsSyllable x == createsSyllable 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, Read, Show)++instance PhoneticElement SegmentationInfo1 where+  readPEMaybe rs+    | not . any isLetter $ rs = Nothing+    | otherwise = let (ys:yss) = L.words rs in case ys of+        "SI" -> case yss of+           [xs,ts] -> case (readMaybe xs::Maybe Int8) of+               Just m -> case (readMaybe ts::Maybe Int8) of+                 Just n -> Just (SI m n)+                 _ -> Nothing+               _ -> Nothing+           _ -> Nothing+        _ -> Nothing++-- | We can think of 'SegmentationPredFunction' in terms of @f ('SI' fN pN) ks [x_{1},x_{2},...,x_{i},...,x_{fN}]@. Comparing with+-- 'divCnsnts' from the @ukrainian-phonetics-basics-array@ we can postulate that it consists of the following logical terms in+-- the symbolic form:+-- +-- 1) 'phoneType' x_{i} \`'elem'\` (X{...} = 'map' 'P' ['Int8'])+-- +-- 2) 'notEqC' ks x_{i} x_{j} (j /= i)+-- +-- combined with the standard logic Boolean operations of '(&&)', '(||)' and 'not'. Further, the 'not' can be transformed into the+-- positive (affirmative) form using the notion of the universal set for the task. This transformation needs that the similar+-- phonetic phenomenae (e. g. the double sounds -- the prolonged ones) belong to the one syllable and not to the different ones+-- (so they are not related to different syllables, but just to the one and the same). Since such assumption has been used,+-- we can further represent the function by the following data type and operations with it, see 'SegmentationPredFData'.+data SegmentationPredFunction = PF (SegmentationInfo1 -> [(Char, Char)] -> [PRS] -> Bool)++data SegmentationPredFData a b = L Int [Int] (Array Int a) | NEC Int Int (Array Int a) [b] | C (SegmentationPredFData a b) (SegmentationPredFData a b) |+  D (SegmentationPredFData a b) (SegmentationPredFData a b) deriving (Eq, Read, Show)++class Eval2Bool a where+  eval2Bool :: a -> Bool++type SegmentationFDP = SegmentationPredFData PRS (Char, Char)++instance Eval2Bool (SegmentationPredFData PRS (Char, Char)) where+  eval2Bool (L i js arr)+    | all (<= n) js && i <= n && i >= 1 && all (>=1) js = fromPhoneticType (phoneType (unsafeAt arr $ i - 1)) `elem` js+    | otherwise = error "Data.Phonetic.Languages.Syllables.eval2Bool: 'L' element is not properly defined. "+        where n = numElements arr+  eval2Bool (NEC i j arr ks)+    | i >= 1 && j >= 1 && i /= j && i <= n && j <= n = notEqC ks (unsafeAt arr $ i - 1) (unsafeAt arr $ j - 1)+    | otherwise = error "Data.Phonetic.Languages.Syllables.eval2Bool: 'NEC' element is not properly defined. "+        where n = numElements arr+  eval2Bool (C x y) = eval2Bool x && eval2Bool y+  eval2Bool (D x y) = eval2Bool x || eval2Bool y++type DListFunctionResult = ([PRS] -> [PRS],[PRS] -> [PRS])++class DListRepresentation a b where+  toDLR :: b -> [a] -> ([a] -> [a], [a] -> [a])++instance DListRepresentation PRS Int8 where+  toDLR (I8# left) xs+    | null xs = (id,id)+    | null ts =  (id,(zs `mappend`))+    | null zs = ((`mappend` ts), id)+    | otherwise = ((`mappend` ts), (zs `mappend`))+        where (ts,zs) = splitAt (I# left) xs+           +data SegmentationLineFunction = LFS {+  infoSP :: SegmentationInfo1,+  predF :: SegmentationFDP,  -- ^ The predicate to check the needed rule for segmentation.+  resF :: Int8 -- ^ The result argument to be appended to the left of the group of consonants if the 'predF' returns 'True' for its arguments. Is an argument to the 'toDLR'.+} deriving (Read, Show)++data SegmentationRules1 = SR1 {+  infoS :: SegmentationInfo1, +  lineFs :: [SegmentationLineFunction] -- ^ 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.+} deriving (Read, Show) ++-- | 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 SegmentRulesG = [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)] -- ^ 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. + -> SegmentRulesG+ -> [PRS]+ -> DListFunctionResult+divCnsnts ks gs xs@(_:_) = toDLR left xs+  where !js = fromJust . L.find ((== length xs) . (\(I8# t) -> I# t) . fieldN . infoS) $ gs -- js :: SegmentationRules1+        !left = resF . fromJust . L.find (eval2Bool . predF). lineFs $ js+divCnsnts _ _ [] = (id,id)++reSyllableCntnts+ :: [(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. + -> SegmentRulesG+ -> [[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++divSylls :: [[PRS]] -> [[PRS]]+divSylls = mapI (\ws -> (length . filter createsSyllable $ ws) > 1) h3+  where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> createsSyllable x && phoneType y /= P 0) . drop 1 $ zs)+                  where (ys,zs) = break createsSyllable us++{-| The function actually creates syllables using the provided data. Each resulting inner-most list is a phonetic language representation+of the syllable according to the rules provided.+-}+createSyllablesPL+  :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.+  -> [(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. +  -> CharPhoneticClassification+  -> SegmentRulesG+  -> String -- ^ Corresponds to the 100 delimiter in the @ukrainian-phonetics-basic-array@ package.+  -> String -- ^ Corresponds to the 101 delimiter in the @ukrainian-phonetics-basic-array@ package.+  -> String -- ^ Actually the converted 'String'.+  -> [[[PRS]]]+createSyllablesPL wrs ks arr gs us vs = map (divSylls . reSyllableCntnts ks gs . groupSnds . str2PRSs arr) . 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'') = break (== ' ') ts+        {-# NOINLINE words1 #-}+        convertToProperPL = concatMap string1 . stringToXG wrs+{-# INLINE createSyllablesPL #-}
+ Phladiprelio/RGLPK/General.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Phladiprelio.RGLPK.General+-- Copyright   :  (c) Oleksandr Zhabenko 2020-2023+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  oleksandr.zhabenko@yahoo.com+--+-- Can be used to calculate the durations of the approximations of the 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+-- phonetic language 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.+-- +-- For the model correctness the js here refers to sorted list of the 'Char' representations of the phonetic language phenomenae.+-- +-- The length of the 'String' js is refered to as 'lng'::'Int'. The number of 'pairs'' function elements in the lists is refered to+-- as 'nn'::'Int'. The number of constraints is refered here as 'nc'::'Int'. @nc == nn `quot` 2@.+-- +-- Is generalized from the Numeric.Wrapper.R.GLPK.Phonetics.Ukrainian.Durations module from+-- the @r-glpk-phonetic-languages-ukrainian-durations@ package.++module Phladiprelio.RGLPK.General where++import GHC.Base+import Text.Read+import Data.Maybe+import CaseBi.Arr (getBFstL')+import Data.Foldable (foldl')+import GHC.Arr+import Numeric+import Data.List+import GHC.Num ((+),(-),(*),abs)+import Data.Bits (shiftR)+import Data.Lists.FLines (newLineEnding)+import Data.Foldable.Ix (findIdx1)+import Text.Show (Show(..))++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 = map (\ts -> fromMaybe 1.0 (readMaybe ts::Maybe Double))++countCharInWords :: [String] -> Char -> [Int]+countCharInWords xss x+  | null xss = []+  | otherwise = map (length . filter (== x)) xss++matrix1Column :: PairwiseC -> [String] -> String -> Char -> [Int]+matrix1Column pw xss js x = pairwiseComparings x pw (mconcat [countCharInWords xss x, rs, rs])+  where l =  length js+        iX = fromMaybe (-l - 1) . findIdx1 x $ js+        rs = if iX < 0 then [] else mconcat [replicate iX 0,  [1],  replicate (l - 1 - iX) 0]++pairwiseComparings :: Char -> PairwiseC -> [Int] -> [Int]+pairwiseComparings x y zs = zs `mappend` pairs' y x++-- | A way to encode the pairs of the phonetic language representations that give some additional associations, connections+-- between elements, usually being caused by some similarity or commonality of the pronunciation act for the phenomenae+-- corresponding to these elements. +-- All ['Int'] must be equal in 'length' throughout the same namespace and this length is given as 'Int' argument in+-- the 'PairwisePL'. This 'Int' parameter is @nn@.+data PairwisePL = PW Char Int [Int] deriving (Eq, Read, Show)++lengthPW :: PairwisePL -> Int+lengthPW (PW _ l _) = l++charPW :: PairwisePL -> Char+charPW (PW c _ _) = c++listPW :: PairwisePL -> [Int]+listPW (PW _ _ xs) = xs++data PairwiseC = LL [PairwisePL] Int deriving (Eq, Read, Show)++isCorrectPWC :: PairwiseC -> Bool+isCorrectPWC (LL xs n) = n == minimum (map lengthPW xs)++pwsC :: PairwiseC -> [PairwisePL]+pwsC (LL xs n) = map (\(PW c m ys) -> PW c n . take n $ ys) xs++pairs' :: PairwiseC -> Char -> [Int]+pairs' y@(LL xs n) x+ | isCorrectPWC y = let z = find ((== x) . charPW) . pwsC $ y in+     if isJust z then listPW . fromJust $ z+     else replicate n 0+ | otherwise = error "Phladiprelio.RGLPK.General.pairs': Not defined for the arguments. "++-- | Actually @n@ is a 'length' bss.+matrixLine+  :: Int -- ^ The number of 'pairs'' function elements in the lists.+  -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.+  -> [String]+  -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.+  -> String+matrixLine nn pw bss js+  | null bss || n <=0 = []+  | otherwise = mconcat ["mat1 <- matrix(c(", intercalate ", " . map show . concatMap +      (matrix1Column pw (bss  `mappend`  bss) js) $ js, "), nrow = ", show (2 * n + 2 * length js + nn), ")", newLineEnding]+         where n = length bss++objLine+ :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+ -> [(Int,Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation+  -- (which coefficients relates to which representation elements).+ -> Array Int Double -- ^ An array of coefficients.+ -> String+objLine lng xs arr+ | numElements arr >= lng = mconcat ["obj1 <- c(", intercalate ", " . map (\t -> showFFloat Nothing t "") . objCoeffsNew lng xs $ arr,+      ")", newLineEnding]+ | otherwise = error "Phladiprelio.RGLPK.General.objLine: Not defined for the short argument. "++-- | A way to reorder the coefficients of the input and the elements representations related to each other.+objCoeffsNew+  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+  -- appears in the file with test words and their spoken durations.+  -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation+  -- (which coefficients relates to which representation elements).+  -> Array Int Double -- ^ An array of coefficients.+  -> [Double]+objCoeffsNew lng xs arr = let lst = map (\(x,y) -> (x,unsafeAt arr y)) xs in map (getBFstL' 1.0 lst) [0..lng - 1]++maxLine :: String+maxLine = "max1 <- TRUE\n"++dirLine+ :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+ -> Int -- ^ The number of 'pairs'' function elements in the lists.+ -> [String] -- ^ An argument of the 'matrixLine' function.+ -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.+ -> String+dirLine lng nn bss js = mconcat ["dir1 <- c(\"<",  g "<" bss,  "\", \">",  g ">" (bss,  map (:[]) js),  "\"",  h0 lng,+ h (shiftR nn 1), ")", newLineEnding]+  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 = mconcat ["rhs1 <- c(" ,  f (mconcat [xs ,  ys ,  zs]) ,  ")", newLineEnding]+  where f ts = (intercalate ", " . map (\t -> showFFloat Nothing t "") $ ts)++rhsLine+ :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+ -> Int -- ^ The number of 'pairs'' function elements in the lists.+ -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.+ -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.+ -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.+ -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of+  -- phonemes) to set a general (common) behaviour for the set of resulting values.+ -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the some group of representations (e. g. vowels). + -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the special group of representations (e. g. soft sign).  + -> [Double]+ -> [Double]+ -> String+rhsLine lng nn mx mn1 mnSpecial mnG xs1 sps1 = rhsLineG . mconcat $ [minDurations lng mn1 mnSpecial mnG xs1 sps1,  maxDurations lng mx,  constraintsR1 (shiftR nn 1)]++constraintsR1 :: Int -> [Double]+constraintsR1 n = replicate (2 * n) 0.0++minDurations+  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+  -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.+  -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.+  -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of+  -- phonemes) to set a general (common) behaviour for the set of resulting values.+  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the some group of representations (e. g. vowels). +  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the special group of representations (e. g. soft sign). +  -> [Double]+minDurations lng mn1 mnSpecial mnG xs1 sps1 = map h [0..lng - 1]+  where xs2+         | maximum xs1 <= lng - 1 = filter (>= 0) xs1+         | otherwise = error "Phladiprelio.RGLPK.General.objLine: Not defined for these arguments. "+        sps2+         | maximum sps1 <= lng - 1 = filter (>= 0) sps1 \\ xs2+         | otherwise = error "Phladiprelio.RGLPK.General.objLine: Not defined for these arguments. "+        h i+         | i `elem` xs2 = mn1+         | i `elem` sps2 = mnSpecial+         | otherwise = mnG++maxDurations+ :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+ -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.+ -> [Double]+maxDurations lng mx = replicate lng mx++-- | A variant of the more general 'answer2' where the predefined randomization parameters are used to produce every time being run+-- a new result (e. g. this allows to model accents).+answer+ :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+ -- appears in the file with test words and their spoken durations.+ -> Int -- ^ The number of 'pairs'' function elements in the lists.+ -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.+ -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.+ -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation+  -- (which coefficients relates to which representation elements).+ -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.+ -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.+ -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of+  -- phonemes) to set a general (common) behaviour for the set of resulting values.+ -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the some group of representations (e. g. vowels). + -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the special group of representations (e. g. soft sign). + -> Array Int Double -- ^ An array of coefficients.+ -> [String] -- ^ An argument of the 'matrixLine' function.+ -> [Double]+ -> [Double]+ -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.+ -> String+answer lng nn pw mx ts = answer2 lng nn pw mx ts (-0.003) 0.003 (-0.0012) 0.0012++answer2+  :: Int -- ^ The length of the 'String' js that is a sorted list of the phonetic language representations as 'Char's that+  -- appears in the file with test words and their spoken durations.+  -> Int -- ^ The number of 'pairs'' function elements in the lists.+  -> PairwiseC -- ^ Actually the data type value that sets the behaviour of the 'pairs'' function.+  -> Double -- ^ Maximum duration of the phonetic language element representation in seconds.+  -> [(Int, Int)] -- ^ List of pairs of indices that shows how the input data is related to the representation+  -- (which coefficients relates to which representation elements).+  -> Double -- ^ A maximum in absolute value (being, usually, a negative one) possible random deviation from the computed value to be additionally applied to emulate+  -- 'more natural' behaviour and to get every time while running new sets of values. +  -> Double -- ^ A maximum in absolute value (being, usually, a positive one) possible random deviation from the computed value to be additionally applied to emulate+  -- 'more natural' behaviour and to get every time while running new sets of values. +  -> Double -- ^ A minimum in absolute value (being, usually, a negative one) possible random deviation from the computed value to be+  -- additionally applied to emulate 'more natural' behaviour and to get every time while running new sets of values. +  -> Double -- ^ A minimum in absolute value (being, usually, a positive one) possible random deviation from the computed value to be+  -- additionally applied to emulate 'more natural' behaviour and to get every time while running new sets of values. +  -> Double -- ^ A minimum positive duration value for some group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. vowels) to set some peculiar behaviour for the set of resulting values.+  -> Double -- ^ A minimum positive duration value for some *special* group of phonetic language representation (usually, some sorts of+  -- phonemes, e. g. soft sign representation) to set some peculiar behaviour for the set of resulting values.+  -> Double -- ^ A minimum positive duration value for all other phonetic language representations (usually, some sorts of+  -- phonemes) to set a general (common) behaviour for the set of resulting values.+  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the some group of representations (e. g. vowels). +  -> [Int] -- ^ A list of indices of the phonetic languages representations in their sorted in ascending order sequence that+  -- corresponds to the elements from the special group of representations (e. g. soft sign). +  -> Array Int Double -- ^ An array of coefficients.+  -> [String] -- ^ An argument of the 'matrixLine' function.+  -> [Double]+  -> [Double]+  -> String -- ^ A sorted list of the 'Char' representations of the phonetic language phenomenae.+  -> String+answer2 lng nn pw mx ts min1 max1 min2 max2 mn1 mnSpecial mnG xs1 sps1 lsts bss xs ys js = mconcat ["library(\"Rglpk\")",newLineEnding,objLine lng ts lsts,+ matrixLine nn pw bss js,dirLine lng nn bss js, rhsLine lng nn mx mn1 mnSpecial mnG xs1 sps1 xs ys,maxLine,newLineEnding,+  "k <- Rglpk_solve_LP(obj = obj1, mat = mat1, dir = dir1, rhs = rhs1, max = max1)",newLineEnding, "y <- runif(",show lng,+   ", min = ", showFFloat Nothing (-(abs min1)) ", max = ", showFFloat Nothing (abs max1) ")", newLineEnding,+   "if (k$status == 0){k$solution / mean(k$solution)} else {c()}", newLineEnding, "\")}"]++-- read ("SylS {charS=\'k\', phoneType=P 6")::PRS++
phonetic-languages-phonetics-basics.cabal view
@@ -3,14 +3,14 @@ -- http://haskell.org/cabal/users-guide/  name:                phonetic-languages-phonetics-basics-version:             0.9.1.0+version:             0.10.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. Now it combines the functionality of the @r-glpk-phonetic-languages-ukrainian-durations@ and @phonetic-languages-ukrainian-array@ and some dependencies of the mentioned one. homepage:            https://hackage.haskell.org/package/phonetic-languages-phonetics-basics license:             MIT license-file:        LICENSE author:              OleksandrZhabenko-maintainer:          olexandr543@yahoo.com+maintainer:          oleksandr.zhabenko@yahoo.com copyright:           Oleksandr Zhabenko category:            Language, Math, Game build-type:          Simple@@ -18,18 +18,18 @@ cabal-version:       >=1.10  library-  exposed-modules:     Data.Phonetic.Languages.Base, Data.Phonetic.Languages.Syllables, Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations, Data.Phonetic.Languages.SpecificationsRead, Data.Phonetic.Languages.PrepareText+  exposed-modules:     Phladiprelio.General.Base, Phladiprelio.General.Syllables, Phladiprelio.RGLPK.General, Phladiprelio.General.SpecificationsRead, Phladiprelio.General.PrepareText   other-modules:       Main-  other-extensions:    CPP, BangPatterns, UnboxedTuples, MagicHash, MultiParamTypeClasses, FlexibleInstances, MultiWayIf+  other-extensions:    BangPatterns, UnboxedTuples, MagicHash, MultiParamTypeClasses, FlexibleInstances, MultiWayIf, NoImplicitPrelude   ghc-options:         -funbox-strict-fields -fobject-code-  build-depends:       base >=4.8 && <5, mmsyn2-array ==0.3.0.0, mmsyn3 == 0.1.6.0, mmsyn5 == 0.5.1.0, lists-flines == 0.1.2.0, foldable-ix ==0.2.1.0+  build-depends:       base >=4.13 && <5, mmsyn2-array ==0.3.1.1, mmsyn3 == 0.2.0.0, mmsyn5 == 0.6.0.0, lists-flines == 0.1.3.0, foldable-ix ==0.3.0.0   -- hs-source-dirs:   default-language:    Haskell2010  executable pldPL   main-is:             Main.hs-  other-modules:       Data.Phonetic.Languages.Base, Data.Phonetic.Languages.Syllables, Numeric.Wrapper.R.GLPK.Phonetic.Languages.Durations, Data.Phonetic.Languages.SpecificationsRead, Data.Phonetic.Languages.PrepareText+  other-modules:       Phladiprelio.General.Base, Phladiprelio.General.Syllables, Phladiprelio.RGLPK.General, Phladiprelio.General.SpecificationsRead, Phladiprelio.General.PrepareText   -- other-extensions:-  build-depends:       base >=4.8 && <5, mmsyn2-array == 0.3.0.0, mmsyn3 == 0.1.6.0, mmsyn5 == 0.5.1.0, lists-flines == 0.1.2.0, foldable-ix ==0.2.1.0+  build-depends:       base >=4.13 && <5, mmsyn2-array == 0.3.1.1, mmsyn3 == 0.2.0.0, mmsyn5 == 0.6.0.0, lists-flines == 0.1.3.0, foldable-ix ==0.3.0.0   -- hs-source-dirs:   default-language:    Haskell2010