diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,3 +3,8 @@ ## 0.1.0.0 -- 2021-04-19 * First version. Released on an unsuspecting world. + +## 0.2.0.0 -- 2021-04-19 + +* Second version. Added some optimizations for the Data.Phonetic.Languages.Base module functions. Added new functions to +the module. diff --git a/Data/Phonetic/Languages/Base.hs b/Data/Phonetic/Languages/Base.hs --- a/Data/Phonetic/Languages/Base.hs +++ b/Data/Phonetic/Languages/Base.hs @@ -1,5 +1,9 @@ {-# OPTIONS_HADDOCK show-extensions #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + -- | -- Module : Data.Phonetic.Languages.Base -- Copyright : (c) OleksandrZhabenko 2021 @@ -35,16 +39,24 @@ , stringToXSG , stringToXG , stringToXS - --, stringToX , 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) import GHC.Int (Int8(..)) import Data.Maybe (isJust,fromJust) import Data.Either +import GHC.Arr +import GHC.Exts -- | The intended conversion to the syllables for a written word is: -- @ @@ -58,7 +70,7 @@ PREmpty { string :: String } deriving (Eq, Ord) --- | Extended variant of the 'PhoneticRepresentationPL' data type where the information for the 'Char' is encoded into the +-- | 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. data PhoneticsRepresentationPLX = PRC { stringX :: String, afterStringX :: String, beforeStringX :: String, char :: Char } | @@ -151,41 +163,134 @@ -} type IGWritingSystemPRPLX = [(PhoneticRepresentationXInter,Generations)] +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 +-- 'PhoneticRepresentationPLX' 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 +-- 'PhoneticRepresentationPLX' 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 + :: (# 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#) + +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 - xsG rs n (k1s:k2s:k3s:kss) -- xsG :: [PhoneticRepresentationPLX] -> [String] -> Generations -> IGWritingSystemPRPLX - | any (\rec -> afterStringX rec == k3s && beforeStringX rec == k1s) . filter ((== k2s) . stringX) $ r2s - = (Right k1s,n - 1):(Left . fromJust . find (\rec -> afterStringX rec == k3s && beforeStringX rec == k1s && - stringX rec == k2s) $ r2s,n):xsG rs n (k3s:kss) - | any (\rec -> afterStringX rec == k2s) . filter ((== k1s) . stringX) $ r3s - = (Left . fromJust . find (\rec -> afterStringX rec == k2s && - stringX rec == k1s) $ r3s,n):xsG rs n (k2s:k3s:kss) - | any (\rec -> beforeStringX rec == k1s) . filter ((== k2s) . stringX) $ r4s - = (Right k1s,n - 1):(Left . fromJust . find (\rec -> beforeStringX rec == k1s && - stringX rec == k2s) $ r4s,n):xsG rs n (k3s:kss) - | any ((== k1s) . stringX) r5s = (Left . fromJust . find (\rec -> stringX rec == k1s) $ r5s,n):xsG rs n (k2s:k3s:kss) - | otherwise = (Right k1s,n - 1):xsG rs n (k2s:k3s:kss) - where [!r2s,!r3s,!r4s,!r5s] = map (\f -> filter f rs) [isPRC, isPRAfterC, isPRBeforeC, isPREmptyC] - xsG rs n (k1s:k2s:kss) - | any (\rec -> afterStringX rec == k2s) . filter ((== k1s) . stringX) $ r3s - = (Left . fromJust . find (\rec -> afterStringX rec == k2s && - stringX rec == k1s) $ r3s,n):xsG rs n (k2s:kss) - | any (\rec -> beforeStringX rec == k1s) . filter ((== k2s) . stringX) $ r4s - = (Right k1s,n - 1):(Left . fromJust . find (\rec -> beforeStringX rec == k1s && - stringX rec == k2s) $ r4s,n):xsG rs n (kss) - | any ((== k1s) . stringX) r5s = (Left . fromJust . find (\rec -> stringX rec == k1s) $ r5s,n):xsG rs n (k2s:kss) - | otherwise = (Right k1s,n - 1):xsG rs n (k2s:kss) - where [r3s,!r4s,!r5s] = map (\f -> filter f rs) [isPRAfterC, isPRBeforeC, isPREmptyC] - xsG rs n [k1s] - | any ((== k1s) . stringX) r5s = [(Left . fromJust . find (\rec -> stringX rec == k1s) $ r5s,n)] + 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 !r5s = filter isPREmptyC rs - xsG rs n [] = [] + 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. @@ -196,44 +301,35 @@ | otherwise = ys where !ts = filter ((== n) . snd) xs -- ts :: GWritingSystemPRPLX !zs = concatMap fst ts -- zs :: PhoneticRepresentationX - xsGI rs n (k1s:k2s:k3s:kss) -- xsGI :: [PhoneticRepresentationPLX] -> Generations -> IGWritingSystemPRPLX -> IGWritingSystemPRPLX - | snd k2s == n && (any (\rec -> either (const False) (== afterStringX rec) (fst k3s) && - either (const False) (== beforeStringX rec) (fst k1s)) . - filter (\rec -> either (const False) (== stringX rec) (fst k2s)) $ r2s) - = (fst k1s,n - 1):(Left . fromJust . find (\rec -> either (const False) (== afterStringX rec) (fst k3s) && - either (const False) (== beforeStringX rec) (fst k1s) && either (const False) (== stringX rec) (fst k2s)) $ - r2s,n) : xsGI rs n (k3s:kss) - | snd k1s == n && (any (\rec -> either (const False) (== afterStringX rec) (fst k2s)) . - filter (\rec -> either (const False) (== stringX rec) (fst k1s)) $ r3s) - = (Left . fromJust . find (\rec -> either (const False) (== afterStringX rec) (fst k2s) && - either (const False) (== stringX rec) (fst k1s)) $ r3s,n):xsGI rs n (k2s:k3s:kss) - | snd k2s == n && (any (\rec -> either (const False) (== beforeStringX rec) (fst k1s)) . - filter (\rec -> either (const False) (== stringX rec) (fst k2s)) $ r4s) - = (fst k1s,n - 1):(Left . fromJust . find (\rec -> either (const False) (== beforeStringX rec) (fst k1s) && - either (const False) (== stringX rec) (fst k2s)) $ r4s,n):xsGI rs n (k3s:kss) - | snd k1s == n && (any (\rec -> either (const False) (== stringX rec) (fst k1s)) r5s) = (Left . fromJust . - find (\rec -> either (const False) (== stringX rec) (fst k1s)) $ r5s, n):xsGI rs n (k2s:k3s:kss) - | otherwise = (fst k1s,n - 1):xsGI rs n (k2s:k3s:kss) - where [!r2s,!r3s,!r4s,!r5s] = map (\f -> filter f rs) [isPRC, isPRAfterC, isPRBeforeC, isPREmptyC] - xsGI rs n (k1s:k2s:kss) - | snd k1s == n && (any (\rec -> either (const False) (== afterStringX rec) (fst k2s)) . - filter (\rec -> either (const False) (== stringX rec) (fst k1s)) $ r3s) - = (Left . fromJust . find (\rec -> either (const False) (== afterStringX rec) (fst k2s) && - either (const False) (== stringX rec) (fst k1s)) $ r3s,n):xsGI rs n (k2s:kss) - | snd k2s == n && (any (\rec -> either (const False) (== beforeStringX rec) (fst k1s)) . - filter (\rec -> either (const False) (== stringX rec) (fst k2s)) $ r4s) - = (fst k1s,n - 1):(Left . fromJust . find (\rec -> either (const False) (== beforeStringX rec) (fst k1s) && - either (const False) (== stringX rec) (fst k2s)) $ r4s,n):xsGI rs n (kss) - | snd k1s == n && (any (\rec -> either (const False) (== stringX rec) (fst k1s)) r5s) = (Left . fromJust . - find (\rec -> either (const False) (== stringX rec) (fst k1s)) $ r5s,n):xsGI rs n (k2s:kss) - | otherwise = (fst k1s,n - 1):xsGI rs n (k2s:kss) - where [r3s,!r4s,!r5s] = map (\f -> filter f rs) [isPRAfterC, isPRBeforeC, isPREmptyC] - xsGI rs n [k1s] - | snd k1s == n && (any (\rec -> either (const False) (== stringX rec) (fst k1s)) r5s) = [(Left . fromJust . - find (\rec -> either (const False) (== stringX rec) (fst k1s)) $ r5s,n)] + 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 !r5s = filter isPREmptyC rs - xsGI rs n [] = [] + 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. -} diff --git a/phonetic-languages-phonetics-basics.cabal b/phonetic-languages-phonetics-basics.cabal --- a/phonetic-languages-phonetics-basics.cabal +++ b/phonetic-languages-phonetics-basics.cabal @@ -3,7 +3,7 @@ -- http://haskell.org/cabal/users-guide/ name: phonetic-languages-phonetics-basics -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A library for working with generalized phonetic languages usage. description: There already exists a Ukrainian implementation for the phonetic languages approach published at: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array. It is optimized for the Ukrainian only and needs to be rewritten for every new language mostly from scratch using it as a template. To avoid this boilerplate, this one is provided. It can be used for different languages and even for music or other fields. homepage: https://hackage.haskell.org/package/phonetic-languages-phonetics-basics @@ -12,7 +12,7 @@ author: OleksandrZhabenko maintainer: olexandr543@yahoo.com copyright: Oleksandr Zhabenko -category: Language +category: Language, Math, Game build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 @@ -20,7 +20,8 @@ library exposed-modules: Data.Phonetic.Languages.Undefined, Data.Phonetic.Languages.Base -- other-modules: - other-extensions: BangPatterns + other-extensions: BangPatterns, UnboxedTuples, MagicHash + ghc-options: -funbox-strict-fields build-depends: base >=4.8 && <4.15 -- hs-source-dirs: default-language: Haskell2010