diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. + diff --git a/Data/Phonetic/Languages/Base.hs b/Data/Phonetic/Languages/Base.hs deleted file mode 100644 --- a/Data/Phonetic/Languages/Base.hs +++ /dev/null @@ -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 diff --git a/Data/Phonetic/Languages/PrepareText.hs b/Data/Phonetic/Languages/PrepareText.hs deleted file mode 100644 --- a/Data/Phonetic/Languages/PrepareText.hs +++ /dev/null @@ -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 #-} diff --git a/Data/Phonetic/Languages/SpecificationsRead.hs b/Data/Phonetic/Languages/SpecificationsRead.hs deleted file mode 100644 --- a/Data/Phonetic/Languages/SpecificationsRead.hs +++ /dev/null @@ -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 - diff --git a/Data/Phonetic/Languages/Syllables.hs b/Data/Phonetic/Languages/Syllables.hs deleted file mode 100644 --- a/Data/Phonetic/Languages/Syllables.hs +++ /dev/null @@ -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 #-} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Numeric/Wrapper/R/GLPK/Phonetic/Languages/Durations.hs b/Numeric/Wrapper/R/GLPK/Phonetic/Languages/Durations.hs deleted file mode 100644 --- a/Numeric/Wrapper/R/GLPK/Phonetic/Languages/Durations.hs +++ /dev/null @@ -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 - - diff --git a/Phladiprelio/General/Base.hs b/Phladiprelio/General/Base.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/Base.hs @@ -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 diff --git a/Phladiprelio/General/PrepareText.hs b/Phladiprelio/General/PrepareText.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/PrepareText.hs @@ -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 #-} diff --git a/Phladiprelio/General/SpecificationsRead.hs b/Phladiprelio/General/SpecificationsRead.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/SpecificationsRead.hs @@ -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 + diff --git a/Phladiprelio/General/Syllables.hs b/Phladiprelio/General/Syllables.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/General/Syllables.hs @@ -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 #-} diff --git a/Phladiprelio/RGLPK/General.hs b/Phladiprelio/RGLPK/General.hs new file mode 100644 --- /dev/null +++ b/Phladiprelio/RGLPK/General.hs @@ -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 + + diff --git a/phonetic-languages-phonetics-basics.cabal b/phonetic-languages-phonetics-basics.cabal --- a/phonetic-languages-phonetics-basics.cabal +++ b/phonetic-languages-phonetics-basics.cabal @@ -3,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