{-# 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