phonetic-languages-phonetics-basics 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+174/−72 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Data/Phonetic/Languages/Base.hs +165/−69
• phonetic-languages-phonetics-basics.cabal +4/−3

@@ -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.

@@ -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. -}

@@ -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