aftovolio 0.4.0.0 → 0.5.0.0
raw patch · 34 files changed
+7143/−3899 lines, 34 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Aftovolio.Constraints: filterGrouppedTogether :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> t (Array Int Int) -> t (Array Int Int)
+ Aftovolio.Constraints: isGrouppedTogether :: Int -> Int -> Array Int Int -> Bool
+ Aftovolio.Constraints: notGrouppedTogether :: Int -> Int -> Array Int Int -> Bool
+ Aftovolio.ConstraintsEncoded: G :: a -> a -> a -> EncodedContraints a b d
+ Aftovolio.ConstraintsEncoded: isG :: EncodedCnstrs -> Bool
- Aftovolio.General.Simple: generalF :: Int -> Int -> Compards -> Bool -> Bool -> FilePath -> String -> (String -> String) -> (String, String) -> Int -> GWritingSystemPRPLX -> [(Char, Char)] -> CharPhoneticClassification -> SegmentRulesG -> String -> String -> ([[[PRS]]] -> [[Word8]]) -> Int -> HashCorrections -> (Int8, [Int8]) -> Bool -> Int -> Bool -> Int8 -> (FilePath, Int) -> Bool -> String -> [String] -> IO [String]
+ Aftovolio.General.Simple: generalF :: Int -> Int -> Compards -> Bool -> Bool -> FilePath -> String -> (String -> String) -> (String, String) -> Int -> GWritingSystemPRPLX -> [(Char, Char)] -> CharPhoneticClassification -> SegmentRulesG -> String -> String -> ([[[PRS]]] -> [[Word8]]) -> Int -> HashCorrections -> (Int8, [Int8]) -> Int -> Bool -> Int8 -> (FilePath, Int) -> Bool -> String -> [String] -> IO [String]
- Aftovolio.General.Simple: processingF :: (String -> String) -> GWritingSystemPRPLX -> [(Char, Char)] -> CharPhoneticClassification -> SegmentRulesG -> String -> String -> ([[[PRS]]] -> [[Word8]]) -> Int -> HashCorrections -> (Int8, [Int8]) -> [[String]] -> [[String]] -> Bool -> Int -> String -> IO ()
+ Aftovolio.General.Simple: processingF :: (String -> String) -> GWritingSystemPRPLX -> [(Char, Char)] -> CharPhoneticClassification -> SegmentRulesG -> String -> String -> ([[[PRS]]] -> [[Word8]]) -> Int -> HashCorrections -> (Int8, [Int8]) -> [[String]] -> [[String]] -> Int -> String -> IO ()
- Aftovolio.Partir: class Foldable t => ConstraintsG t a
+ Aftovolio.Partir: class (Foldable t) => ConstraintsG t a
- Aftovolio.Ukrainian.IO: generalF :: Int -> Int -> Compards -> Bool -> Bool -> FilePath -> String -> (String, String) -> Int -> FilePath -> Int -> HashCorrections -> (Int8, [Int8]) -> Int -> Bool -> Int -> Bool -> Int8 -> (FilePath, Int) -> Bool -> String -> [String] -> IO [String]
+ Aftovolio.Ukrainian.IO: generalF :: Int -> Int -> Compards -> Bool -> Bool -> FilePath -> String -> (String, String) -> Int -> FilePath -> Int -> HashCorrections -> (Int8, [Int8]) -> Int -> Int -> Bool -> Int8 -> (FilePath, Int) -> Bool -> String -> [String] -> IO [String]
Files
- Aftovolio/Basis.hs +32/−31
- Aftovolio/Coeffs.hs +26/−22
- Aftovolio/Constraints.hs +355/−192
- Aftovolio/ConstraintsEncoded.hs +438/−284
- Aftovolio/DataG.hs +383/−201
- Aftovolio/General/Base.hs +395/−299
- Aftovolio/General/Datatype3.hs +166/−127
- Aftovolio/General/Distance.hs +108/−84
- Aftovolio/General/Parsing.hs +168/−96
- Aftovolio/General/Simple.hs +654/−337
- Aftovolio/General/SpecificationsRead.hs +44/−31
- Aftovolio/General/Syllables.hs +291/−231
- Aftovolio/Halfsplit.hs +128/−97
- Aftovolio/Partir.hs +85/−67
- Aftovolio/PermutationsArr.hs +62/−42
- Aftovolio/PermutationsArrMini.hs +44/−37
- Aftovolio/PermutationsArrMini1.hs +63/−52
- Aftovolio/PermutationsRepresent.hs +16/−15
- Aftovolio/RGLPK/General.hs +333/−210
- Aftovolio/StrictVG.hs +75/−42
- Aftovolio/Tests.hs +80/−80
- Aftovolio/Ukrainian/Common2.hs +42/−26
- Aftovolio/Ukrainian/IO.hs +487/−191
- Aftovolio/Ukrainian/Melodics.hs +633/−253
- Aftovolio/Ukrainian/PrepareText.hs +638/−298
- Aftovolio/Ukrainian/ReadDurations.hs +99/−46
- Aftovolio/Ukrainian/ReverseConcatenations.hs +602/−195
- Aftovolio/Ukrainian/Syllable.hs +301/−188
- Aftovolio/Ukrainian/SyllableWord8.hs +257/−34
- Aftovolio/UniquenessPeriodsG.hs +95/−58
- CHANGELOG.md +5/−0
- README.md +23/−16
- aftovolio.cabal +1/−1
- src/Main.hs +14/−16
Aftovolio/Basis.hs view
@@ -1,48 +1,49 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE NoImplicitPrelude, StrictData #-} --- |--- Module : Aftovolio.Basis--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Simplified version of the @phonetic-languages-common@ and @phonetic-languages-general@ packages.--- Uses less dependencies.--{-# LANGUAGE BangPatterns, FlexibleContexts #-}+{- |+Module : Aftovolio.Basis+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Simplified version of the @phonetic-languages-common@ and @phonetic-languages-general@ packages.+Uses less dependencies.+-} module Aftovolio.Basis where import GHC.Base -data Result t a b c = R {line :: !(t a), propertiesF :: !b, transPropertiesF :: !c} deriving Eq+data Result t a b c = R {line :: !(t a), propertiesF :: !b, transPropertiesF :: !c}+ deriving (Eq) instance (Ord (t a), Ord b, Ord c) => Ord (Result t a b c) where- compare x y- = case compare (transPropertiesF x) (transPropertiesF y) of- !EQ -> case compare (propertiesF x) (propertiesF y) of- !EQ -> compare (line x) (line y)- !z -> z- !z0 -> z0- {-# INLINE compare #-}+ compare x y =+ case compare (transPropertiesF x) (transPropertiesF y) of+ !EQ -> case compare (propertiesF x) (propertiesF y) of+ !EQ -> compare (line x) (line y)+ !z -> z+ !z0 -> z0+ {-# INLINE compare #-} -data FuncRep2 a b c = D { getAB :: (a -> b), getBC :: (b -> c) }+data FuncRep2 a b c = D {getAB :: (a -> b), getBC :: (b -> c)} getAC :: FuncRep2 a b c -> (a -> c) getAC (D f g) = g . f {-# INLINE getAC #-} -data Result2 a b c = R2 {line2 :: !a, propertiesF2 :: !b, transPropertiesF2 :: !c} deriving Eq+data Result2 a b c = R2 {line2 :: !a, propertiesF2 :: !b, transPropertiesF2 :: !c}+ deriving (Eq) instance (Ord a, Ord b, Ord c) => Ord (Result2 a b c) where- compare x y- = case compare (transPropertiesF2 x) (transPropertiesF2 y) of- !EQ -> case compare (propertiesF2 x) (propertiesF2 y) of- !EQ -> compare (line2 x) (line2 y)- !z -> z- !z0 -> z0- {-# INLINE compare #-}--+ compare x y =+ case compare (transPropertiesF2 x) (transPropertiesF2 y) of+ !EQ -> case compare (propertiesF2 x) (propertiesF2 y) of+ !EQ -> compare (line2 x) (line2 y)+ !z -> z+ !z0 -> z0+ {-# INLINE compare #-}
Aftovolio/Coeffs.hs view
@@ -1,31 +1,31 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE NoImplicitPrelude, StrictData #-} --- |--- Module : Aftovolio.Coeffs--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ The coefficients functionality common for both phonetic-languages-simplified-examples-array and phonetic-languages-simplified-generalized-examples-array lines of AFTOVolio.--{-# LANGUAGE BangPatterns #-}+{- |+Module : Aftovolio.Coeffs+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +The coefficients functionality common for both phonetic-languages-simplified-examples-array and phonetic-languages-simplified-generalized-examples-array lines of AFTOVolio.+-} module Aftovolio.Coeffs ( -- * Newtype to work with- CoeffTwo(..)- , Coeffs2- , isEmpty- , isPair- , fstCF- , sndCF- , readCF+ CoeffTwo (..),+ Coeffs2,+ isEmpty,+ isPair,+ fstCF,+ sndCF,+ readCF, ) where +import Data.Maybe (fromJust, fromMaybe, isNothing) import GHC.Base import GHC.List-import Data.Maybe (isNothing,fromMaybe,fromJust) import Text.Read (readMaybe) data CoeffTwo a = CF0 | CF2 (Maybe a) (Maybe a) deriving (Eq)@@ -48,9 +48,13 @@ readCF :: String -> Coeffs2 readCF xs- | any (== '_') xs = let (!ys,!zs) = (\(ks,ts) -> (readMaybe ks::Maybe Double,readMaybe (drop 1 ts)::Maybe Double)) . break (== '_') $ xs in- if (isNothing ys && isNothing zs) then CF0 else CF2 ys zs- | otherwise = CF0+ | any (== '_') xs =+ let (!ys, !zs) =+ (\(ks, ts) -> (readMaybe ks :: Maybe Double, readMaybe (drop 1 ts) :: Maybe Double))+ . break (== '_') $+ xs+ in if (isNothing ys && isNothing zs) then CF0 else CF2 ys zs+ | otherwise = CF0 -- | A data type that is used to represent the coefficients of the rhythmicity functions as a one argument value. type Coeffs2 = CoeffTwo Double
Aftovolio/Constraints.hs view
@@ -1,129 +1,143 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.Constraints--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Provides several the most important variants of constraints for the--- permutations. All the 'Array'--- here must consists of unique 'Int' starting from 0 to n-1 and the 'Int'--- arguments must be in the range [0..n-1] though these inner constraints are--- not checked. It is up to user to check them.--- Uses arrays instead of vectors.--- The word \"unsafe\" in the names means that there is no checking whether the arguments are --- within the elements of the arrays, this checking is intended to be done elsewhere before applying --- the functions here. Without such a checking the result are meaningless.--{-# LANGUAGE BangPatterns, FlexibleContexts, NoImplicitPrelude #-}+{- |+Module : Aftovolio.Constraints+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Provides several most important variants of constraints for the+permutations. All the 'Array'+here must consists of unique 'Int' starting from 0 to n-1 and the 'Int'+arguments must be in the range [0..n-1] though these inner constraints are+not checked. It is up to user to check them.+Uses arrays instead of vectors.+The word \"unsafe\" in the names means that there is no checking whether the arguments are+within the elements of the arrays, this checking is intended to be done elsewhere before applying+the functions here. Without such a checking the result are meaningless.+-} module Aftovolio.Constraints (- -- * Predicates- unsafeOrderIJ- , unsafeSignDistanceIJ- , unsafeUnsignDistanceIJ- , isSignDistIJK3- , isUnsignDistIJK3- , isMixedDistIJK3- , isTripleOrdered- , isQuadrupleOrdered- , isQuintupleOrdered- , isSeveralAOrdered- , isSeveralBOrdered- , isFixedPointTup- , isFixedPoint- , notSignDistIJK3 - , notUnsignDistIJK3- , notMixedDistIJK3 - , notTripleOrdered - , notQuadrupleOrdered- , notQuintupleOrdered- , notSeveralAOrdered - , notSeveralBOrdered - , notFixedPointTup - , notFixedPoint - -- * Functions to work with permutations with basic constraints ('Array'-based)- , filterOrderIJ- , unsafeTriples- , unsafeQuadruples- , unsafeQuintuples- -- ** With multiple elements specified- , unsafeSeveralA- , unsafeSeveralB- -- ** With fixed points- , fixedPointsG- , fixedPointsS- -- * Distances between elements- , filterSignDistanceIJ- , filterUnsignDistanceIJ- , filterSignDistanceIJK3- , filterUnsignDistanceIJK3- , filterMixedDistanceIJK3+ -- * Predicates+ unsafeOrderIJ,+ unsafeSignDistanceIJ,+ unsafeUnsignDistanceIJ,+ isSignDistIJK3,+ isUnsignDistIJK3,+ isMixedDistIJK3,+ isTripleOrdered,+ isQuadrupleOrdered,+ isQuintupleOrdered,+ isSeveralAOrdered,+ isSeveralBOrdered,+ isFixedPointTup,+ isFixedPoint,+ notSignDistIJK3,+ notUnsignDistIJK3,+ notMixedDistIJK3,+ notTripleOrdered,+ notQuadrupleOrdered,+ notQuintupleOrdered,+ notSeveralAOrdered,+ notSeveralBOrdered,+ notFixedPointTup,+ notFixedPoint,+ isGrouppedTogether,+ notGrouppedTogether,++ -- * Functions to work with permutations with basic constraints ('Array'-based)+ filterOrderIJ,+ unsafeTriples,+ unsafeQuadruples,+ unsafeQuintuples,+ filterGrouppedTogether,++ -- ** With multiple elements specified+ unsafeSeveralA,+ unsafeSeveralB,++ -- ** With fixed points+ fixedPointsG,+ fixedPointsS,++ -- * Distances between elements+ filterSignDistanceIJ,+ filterUnsignDistanceIJ,+ filterSignDistanceIJK3,+ filterUnsignDistanceIJK3,+ filterMixedDistanceIJK3, ) where -import GHC.Base hiding (foldr)-import GHC.Num (Num, (-),(+))-import Data.InsertLeft (InsertLeft(..),filterG)+import Data.Bits (clearBit, setBit, shiftR, testBit, (.&.))+import Data.Foldable (Foldable, all, any, foldr)+import Data.InsertLeft (InsertLeft (..), filterG) import GHC.Arr-import GHC.Int (Int8(..))-import Data.Bits ((.&.),testBit, shiftR, setBit, clearBit)-import Data.Foldable (Foldable, all, foldr, any)+import GHC.Base hiding (foldr)+import GHC.Int (Int8 (..))+import GHC.Num (Num, (+), (-))+import Data.Tuple (snd) f2 :: (Foldable t, Eq p) => p -> p -> t p -> Int8-f2 i j = foldr g (0::Int8) -- (== 3)- where g x y- | y == 3 = 3- | x == j = bitChange (shiftR y 1 == 0) y 0- | x == i = bitChange (testBit y 0) y 1- | otherwise = y+f2 i j = foldr g (0 :: Int8) -- (== 3)+ where+ g x y+ | y == 3 = 3+ | x == j = bitChange (shiftR y 1 == 0) y 0+ | x == i = bitChange (testBit y 0) y 1+ | otherwise = y {-# INLINE f2 #-} {-# SPECIALIZE f2 :: Int -> Int -> Array Int Int -> Int8 #-} f3 :: (Foldable t, Eq p) => p -> p -> p -> t p -> Int8-f3 i j k = foldr g (0::Int8) -- (== 7)- where g x y- | y == 7 = 7- | x == k = bitChange (shiftR y 1 == 0) y 0 -- u, not (t && u))- | x == j = bitChange (not (testBit y 2) && testBit y 0) y 1 -- (t, w && not t, w)- | x == i = bitChange (clearBit y 2 == 3) y 2 -- (u && w, u, w)- | otherwise = y+f3 i j k = foldr g (0 :: Int8) -- (== 7)+ where+ g x y+ | y == 7 = 7+ | x == k = bitChange (shiftR y 1 == 0) y 0 -- u, not (t && u))+ | x == j = bitChange (not (testBit y 2) && testBit y 0) y 1 -- (t, w && not t, w)+ | x == i = bitChange (clearBit y 2 == 3) y 2 -- (u && w, u, w)+ | otherwise = y {-# INLINE f3 #-} {-# SPECIALIZE f3 :: Int -> Int -> Int -> Array Int Int -> Int8 #-} f4 :: (Foldable t, Eq p) => p -> p -> p -> p -> t p -> Int8-f4 i j k l = foldr g (0::Int8) -- (== 15)- where g x y- | y == 15 = 15- | x == l = bitChange (shiftR y 1 == 0) y 0 - | x == k = bitChange (shiftR y 2 == 0 && testBit y 0) y 1 - | x == j = bitChange (not (testBit y 3) && y .&. 3 == 3) y 2 - | x == i = bitChange (clearBit y 3 == 7) y 3 - | otherwise = y+f4 i j k l = foldr g (0 :: Int8) -- (== 15)+ where+ g x y+ | y == 15 = 15+ | x == l = bitChange (shiftR y 1 == 0) y 0+ | x == k = bitChange (shiftR y 2 == 0 && testBit y 0) y 1+ | x == j = bitChange (not (testBit y 3) && y .&. 3 == 3) y 2+ | x == i = bitChange (clearBit y 3 == 7) y 3+ | otherwise = y {-# INLINE f4 #-} {-# SPECIALIZE f4 :: Int -> Int -> Int -> Int -> Array Int Int -> Int8 #-} f5 :: (Foldable t, Eq p) => p -> p -> p -> p -> p -> t p -> Int8-f5 i j k l m = foldr g (0::Int8) -- (== 31)- where g x y- | y == 31 = 31- | x == m = bitChange (shiftR y 1 == 0) y 0 - | x == l = bitChange (testBit y 0 && shiftR y 2 == 0) y 1- | x == k = bitChange (shiftR y 3 == 0 && y .&. 3 == 3) y 2 - | x == j = bitChange (not (testBit y 4) && y .&. 7 == 7) y 3 - | x == i = bitChange (clearBit y 4 == 15) y 4 - | otherwise = y+f5 i j k l m = foldr g (0 :: Int8) -- (== 31)+ where+ g x y+ | y == 31 = 31+ | x == m = bitChange (shiftR y 1 == 0) y 0+ | x == l = bitChange (testBit y 0 && shiftR y 2 == 0) y 1+ | x == k = bitChange (shiftR y 3 == 0 && y .&. 3 == 3) y 2+ | x == j = bitChange (not (testBit y 4) && y .&. 7 == 7) y 3+ | x == i = bitChange (clearBit y 4 == 15) y 4+ | otherwise = y {-# INLINE f5 #-}-{-# SPECIALIZE f5 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Int8 #-}-+{-# SPECIALIZE f5 ::+ Int -> Int -> Int -> Int -> Int -> Array Int Int -> Int8+ #-} -- | @n@ must be in the range [0..7] though it is not checked here.-bitChange - :: Bool - -> Int8 - -> Int - -> Int8+bitChange ::+ Bool ->+ Int8 ->+ Int ->+ Int8 bitChange bool = (if bool then setBit else clearBit) {-# INLINE bitChange #-} @@ -132,153 +146,284 @@ unsafeOrderIJ i j = (== 3) . f2 i j {-# INLINE unsafeOrderIJ #-} --- | Being given the data satisfying the constraints in the module header checks whether in the--- 'Array' the distance between positions of the first two arguments values is equal to the signed--- third argument.-unsafeSignDistanceIJ- :: Int- -> Int- -> Int -- ^ Can be of both signs, but not equal to 0. The positive value gives 'True' for the first argument being find earlier in the 'Array' than the second and the distance between their positions are equal to 'abs' @d@ (this argument). The negative value gives 'True' for the second argument being earlier in the 'Array' than the first one and the distance between their positions are equal to 'abs' @d@ (this argument).- -> Array Int Int- -> Bool-unsafeSignDistanceIJ i j d = (\(_,_,r) -> if r > 100 then (100 - r) == d else r == d) . foldr helpG2 (j, i, -1)+{- | Being given the data satisfying the constraints in the module header checks whether in the+'Array' the distance between positions of the first two arguments values is equal to the signed+third argument.+-}+unsafeSignDistanceIJ ::+ Int ->+ Int ->+ -- | Can be of both signs, but not equal to 0. The positive value gives 'True' for the first argument being find earlier in the 'Array' than the second and the distance between their positions are equal to 'abs' @d@ (this argument). The negative value gives 'True' for the second argument being earlier in the 'Array' than the first one and the distance between their positions are equal to 'abs' @d@ (this argument).+ Int ->+ Array Int Int ->+ Bool+unsafeSignDistanceIJ i j d =+ (\(_, _, r) -> if r > 100 then (100 - r) == d else r == d)+ . foldr helpG2 (j, i, -1) {-# INLINE unsafeSignDistanceIJ #-} - helpG2 :: (Ord a1, Ord a2, Num a1, Num a2) => a2 -> (a2, a2, a1) -> (a2, a2, a1) helpG2 z (t, u, n)- | n < 0 = if (z /= t && z /= u) then (t, u, n) else (t, u, if z == t then 1 else 101)- | z /= u && z /= t && t >= 0 = (t, u, n + 1)- | otherwise = (-1, u, n)+ | n < 0 =+ if (z /= t && z /= u) then (t, u, n) else (t, u, if z == t then 1 else 101)+ | z /= u && z /= t && t >= 0 = (t, u, n + 1)+ | otherwise = (-1, u, n) {-# INLINE helpG2 #-}-{-# SPECIALIZE helpG2 :: Int -> (Int, Int, Int) -> (Int, Int, Int) #-}+{-# SPECIALIZE helpG2 :: Int -> (Int, Int, Int) -> (Int, Int, Int) #-} --- | Being given the data satisfying the constraints in the module header checks whether in the--- 'Array' the distance between positions of the first two arguments values is equal to the unsigned --- third argument. The following is true: if 'unsafeSignDistanceIJ' @i@ @j@ @d@ @array@ == 'True' then--- 'unsafeUnsignDistanceIJ' @i@ @j@ @d@ @array@ == 'True', but not necessarily vice versa. -unsafeUnsignDistanceIJ - :: Int - -> Int - -> Int -- ^ Only for positive values can give 'True', if the distance between the positions of the elements equal to the first two arguments are equal to this argument. Otherwise, 'False'.- -> Array Int Int - -> Bool-unsafeUnsignDistanceIJ i j d = (\(_,_,r) -> r == d) . foldr helpG3 (j, i, -1)+{- | Being given the data satisfying the constraints in the module header checks whether in the+'Array' the distance between positions of the first two arguments values is equal to the unsigned+third argument. The following is true: if 'unsafeSignDistanceIJ' @i@ @j@ @d@ @array@ == 'True' then+'unsafeUnsignDistanceIJ' @i@ @j@ @d@ @array@ == 'True', but not necessarily vice versa.+-}+unsafeUnsignDistanceIJ ::+ Int ->+ Int ->+ -- | Only for positive values can give 'True', if the distance between the positions of the elements equal to the first two arguments are equal to this argument. Otherwise, 'False'.+ Int ->+ Array Int Int ->+ Bool+unsafeUnsignDistanceIJ i j d = (\(_, _, r) -> r == d) . foldr helpG3 (j, i, -1) {-# INLINE unsafeUnsignDistanceIJ #-} helpG3 :: (Ord a1, Ord a2, Num a1, Num a2) => a2 -> (a2, a2, a1) -> (a2, a2, a1) helpG3 z (t, u, n)- | n < 0 = if (z /= t && z /= u) then (t, u, n) else (t, u, 1)- | z /= u && z /= t && t >= 0 = (t, u, n + 1)- | otherwise = (-1, u, n)+ | n < 0 = if (z /= t && z /= u) then (t, u, n) else (t, u, 1)+ | z /= u && z /= t && t >= 0 = (t, u, n + 1)+ | otherwise = (-1, u, n) {-# INLINE helpG3 #-} {-# SPECIALIZE helpG3 :: Int -> (Int, Int, Int) -> (Int, Int, Int) #-} -- | Being given the data satisfying the constraints in the module header returns the elements that satisfy 'unsafeOrderIJ' as a predicate.-filterOrderIJ :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterOrderIJ ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterOrderIJ i j = filterG (unsafeOrderIJ i j) {-# INLINE filterOrderIJ #-}-{-# SPECIALIZE filterOrderIJ :: Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterOrderIJ ::+ Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} -- | Being given the data satisfying the constraints in the module header returns the elements that satisfy 'unsafeSignDistanceIJ' as a predicate.-filterSignDistanceIJ :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterSignDistanceIJ ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterSignDistanceIJ i j d = filterG (unsafeSignDistanceIJ i j d) {-# INLINE filterSignDistanceIJ #-}-{-# SPECIALIZE filterSignDistanceIJ :: Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterSignDistanceIJ ::+ Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} -- | Being given the data satisfying the constraints in the module header returns the elements that satisfy 'unsafeUnsignDistanceIJ' as a predicate.-filterUnsignDistanceIJ :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterUnsignDistanceIJ ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterUnsignDistanceIJ i j d = filterG (unsafeUnsignDistanceIJ i j d) {-# INLINE filterUnsignDistanceIJ #-}-{-# SPECIALIZE filterUnsignDistanceIJ :: Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterUnsignDistanceIJ ::+ Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} -- | Being given the data satisfying the constraints in the module header returns the elements that pairwisely (1 and 2, 2 and 3) satisfy 'unsafeSignDistanceIJ' as a predicate.-filterSignDistanceIJK3 :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterSignDistanceIJK3 ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterSignDistanceIJK3 i j k d1 d2 = filterG (isSignDistIJK3 i j k d1 d2) {-# INLINE filterSignDistanceIJK3 #-}-{-# SPECIALIZE filterSignDistanceIJK3 :: Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterSignDistanceIJK3 ::+ Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} -- | Being given the data satisfying the constraints in the module header returns the elements that pairwisely (1 and 2, 2 and 3) satisfy 'unsafeUnsignDistanceIJ' as a predicate.-filterUnsignDistanceIJK3 :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterUnsignDistanceIJK3 ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterUnsignDistanceIJK3 i j k d1 d2 = filterG (isUnsignDistIJK3 i j k d1 d2) {-# INLINE filterUnsignDistanceIJK3 #-}-{-# SPECIALIZE filterUnsignDistanceIJK3 :: Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterUnsignDistanceIJK3 ::+ Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} -- | Being given the data satisfying the constraints in the module header returns the elements that satisfy both 'unsafeSignDistanceIJ' with the 1st, 2nd and 4th arguments and 'unsafeUnsignDistanceIJ' with the 2nd, 3rd and 5th arguments as predicates.-filterMixedDistanceIJK3 :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+filterMixedDistanceIJK3 ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) filterMixedDistanceIJK3 i j k d1 d2 = filterG (isMixedDistIJK3 i j k d1 d2) {-# INLINE filterMixedDistanceIJK3 #-}-{-# SPECIALIZE filterMixedDistanceIJK3 :: Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE filterMixedDistanceIJK3 ::+ Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} --- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of--- the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the--- arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.--- The first three arguments--- can be the indices of the the triple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).-unsafeTriples :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+{- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of+the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the+arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.+The first three arguments+can be the indices of the the triple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).+-}+unsafeTriples ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) unsafeTriples i j k = filterG (isTripleOrdered i j k) {-# INLINE unsafeTriples #-}-{-# SPECIALIZE unsafeTriples :: Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE unsafeTriples ::+ Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} --- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of--- the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the--- arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.--- The first four arguments--- can the indices of the the quadruple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).-unsafeQuadruples :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+{- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of+the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the+arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.+The first four arguments+can the indices of the the quadruple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).+-}+unsafeQuadruples ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) unsafeQuadruples i j k l = filterG (isQuadrupleOrdered i j k l) {-# INLINE unsafeQuadruples #-}-{-# SPECIALIZE unsafeQuadruples :: Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE unsafeQuadruples ::+ Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} --- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of--- the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the--- arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.--- The first five arguments--- can be the indices of the the quintuple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).-unsafeQuintuples :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Int -> Int -> Int -> Int -> t (Array Int Int) -> t (Array Int Int)+{- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of+the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication if the+arguments are the indices of the duplicated words or their concatenated combinations in the corresponding line.+The first five arguments+can be the indices of the the quintuple duplicated elements (words or their concatenated combinations in the @phonetic-languages@ series of packages).+-}+unsafeQuintuples ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Int ->+ Int ->+ Int ->+ Int ->+ t (Array Int Int) ->+ t (Array Int Int) unsafeQuintuples i j k l m = filterG (isQuintupleOrdered i j k l m) {-# INLINE unsafeQuintuples #-}-{-# SPECIALIZE unsafeQuintuples :: Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE unsafeQuintuples ::+ Int -> Int -> Int -> Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-} --- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of--- the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication.--- The first argument--- is the index of the the element (a word or their concatenated combination in the @phonetic-languages@ series of packages), the second argument--- is 'Array' 'Int' of indices that are in the range [0..n-1]. Filters (and reduces further complex computations) the permutations so that only the--- variants with the indices in the second argument all stand AFTER the element with the index equal to the first argument.-unsafeSeveralA :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Array Int Int -> t (Array Int Int) -> t (Array Int Int)+{- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of+the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication.+The first argument+is the index of the the element (a word or their concatenated combination in the @phonetic-languages@ series of packages), the second argument+is 'Array' 'Int' of indices that are in the range [0..n-1]. Filters (and reduces further complex computations) the permutations so that only the+variants with the indices in the second argument all stand AFTER the element with the index equal to the first argument.+-}+unsafeSeveralA ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Array Int Int ->+ t (Array Int Int) ->+ t (Array Int Int) unsafeSeveralA !i0 arr = filterG (isSeveralAOrdered i0 arr) {-# INLINE unsafeSeveralA #-}-{-# SPECIALIZE unsafeSeveralA :: Int -> Array Int Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE unsafeSeveralA ::+ Int -> Array Int Int -> [Array Int Int] -> [Array Int Int]+ #-} --- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of--- the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication.--- The first argument--- is the index of the the element (a word or their concatenated combination in the @phonetic-languages@ series of packages), the second argument--- is 'Array' of indices that are in the range [0..n-1]. Filters (and reduces further complex computations) the permutations so that only the--- variants with the indices in the second argument all stand BEFORE the element with the index equal to the first argument.-unsafeSeveralB :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Int -> Array Int Int -> t (Array Int Int) -> t (Array Int Int)+{- | Being given the data satisfying the constraints in the module header reduces the number of further computations in the foldable structure of+the permutations each one being represented as 'Array' 'Int' 'Int' where the elements are all the numbers in the range [0..n-1] without duplication.+The first argument+is the index of the the element (a word or their concatenated combination in the @phonetic-languages@ series of packages), the second argument+is 'Array' of indices that are in the range [0..n-1]. Filters (and reduces further complex computations) the permutations so that only the+variants with the indices in the second argument all stand BEFORE the element with the index equal to the first argument.+-}+unsafeSeveralB ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int ->+ Array Int Int ->+ t (Array Int Int) ->+ t (Array Int Int) unsafeSeveralB !i0 arr = filterG (isSeveralBOrdered i0 arr) {-# INLINE unsafeSeveralB #-}-{-# SPECIALIZE unsafeSeveralB :: Int -> Array Int Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE unsafeSeveralB ::+ Int -> Array Int Int -> [Array Int Int] -> [Array Int Int]+ #-} -------------------------------------------------------------------------------- --- | Reduces the number of permutations using filtering leaving just those ones permutations where elements on the--- first elements in the tuples in the first argument 'Array' places are moved to the places indexed with the second--- elements in the tuples respectively.-fixedPointsG :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Array Int (Int,Int) -> t (Array Int Int) -> t (Array Int Int)+{- | Reduces the number of permutations using filtering leaving just those ones permutations where elements on the+first elements in the tuples in the first argument 'Array' places are moved to the places indexed with the second+elements in the tuples respectively.+-}+fixedPointsG ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Array Int (Int, Int) ->+ t (Array Int Int) ->+ t (Array Int Int) fixedPointsG arr = filterG (isFixedPointTup arr) {-# INLINE fixedPointsG #-}-{-# SPECIALIZE fixedPointsG :: Array Int (Int,Int) -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE fixedPointsG ::+ Array Int (Int, Int) -> [Array Int Int] -> [Array Int Int]+ #-} --- | A simplified variant of the 'fixedPointsG' function where the specified elements stay on their place and that is--- why are 'fixed points' in the permutation specified.-fixedPointsS :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => Array Int Int -> t (Array Int Int) -> t (Array Int Int)+{- | A simplified variant of the 'fixedPointsG' function where the specified elements stay on their place and that is+why are 'fixed points' in the permutation specified.+-}+fixedPointsS ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Array Int Int ->+ t (Array Int Int) ->+ t (Array Int Int) fixedPointsS arr = filterG (isFixedPoint arr) {-# INLINE fixedPointsS #-}-{-# SPECIALIZE fixedPointsS :: Array Int Int -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE fixedPointsS ::+ Array Int Int -> [Array Int Int] -> [Array Int Int]+ #-} +filterGrouppedTogether :: + (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ Int -> + Int -> + t (Array Int Int) -> + t (Array Int Int)+filterGrouppedTogether i j = filterG (isGrouppedTogether i j) +{-# INLINE filterGrouppedTogether #-}+{-# SPECIALIZE filterGrouppedTogether ::+ Int -> Int -> [Array Int Int] -> [Array Int Int]+ #-}+ ------------------------------------------ isSignDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool@@ -314,13 +459,28 @@ {-# INLINE isSeveralBOrdered #-} isFixedPointTup :: Array Int (Int, Int) -> Array Int Int -> Bool-isFixedPointTup arr1 arr2 = all (\(k,j) -> unsafeAt arr2 k == j) arr1+isFixedPointTup arr1 arr2 = all (\(k, j) -> unsafeAt arr2 k == j) arr1 {-# INLINE isFixedPointTup #-} isFixedPoint :: Array Int Int -> Array Int Int -> Bool isFixedPoint arr1 arr2 = all (\k -> unsafeAt arr2 k == k) arr1 {-# INLINE isFixedPoint #-} +isGrouppedTogether :: Int -> Int -> Array Int Int -> Bool+isGrouppedTogether i j = (> -1) . snd . foldr f6 v+ where v = (0,0)+ f6 x (k,l)+ | x < i || x > j = + case k of + 0 -> (0, l) + b -> if b < j - i + 1 then (b, -1) else (b, l)+ | otherwise = + case l of+ -1 -> (0, -1)+ c -> (k + 1, c + 1)+{-# INLINE isGrouppedTogether #-}++ notSignDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool notSignDistIJK3 i j k d1 d2 arr = unsafeSignDistanceIJ j i d1 arr || unsafeSignDistanceIJ k j d2 arr {-# INLINE notSignDistIJK3 #-}@@ -341,7 +501,7 @@ notQuadrupleOrdered i j k l = (/= 15) . f4 i j k l {-# INLINE notQuadrupleOrdered #-} -notQuintupleOrdered :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+notQuintupleOrdered :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool notQuintupleOrdered i j k l m = (/= 31) . f5 i j k l m {-# INLINE notQuintupleOrdered #-} @@ -354,10 +514,13 @@ {-# INLINE notSeveralBOrdered #-} notFixedPointTup :: Array Int (Int, Int) -> Array Int Int -> Bool-notFixedPointTup arr1 arr2 = any (\(k,j) -> unsafeAt arr2 k /= j) arr1+notFixedPointTup arr1 arr2 = any (\(k, j) -> unsafeAt arr2 k /= j) arr1 {-# INLINE notFixedPointTup #-} notFixedPoint :: Array Int Int -> Array Int Int -> Bool notFixedPoint arr1 arr2 = any (\k -> unsafeAt arr2 k /= k) arr1 {-# INLINE notFixedPoint #-} +notGrouppedTogether :: Int -> Int -> Array Int Int -> Bool+notGrouppedTogether i j = not . isGrouppedTogether i j+{-# INLINE notGrouppedTogether #-}
Aftovolio/ConstraintsEncoded.hs view
@@ -1,184 +1,233 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.ConstraintsEncoded--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Provides a way to encode the needed constraint with possibly less symbols.--- Uses arrays instead of vectors.--{-# LANGUAGE FlexibleInstances, FlexibleContexts, NoImplicitPrelude, BangPatterns, StrictData #-}+{- |+Module : Aftovolio.ConstraintsEncoded+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Provides a way to encode the needed constraint with possibly less symbols.+Uses arrays instead of vectors.+-} module Aftovolio.ConstraintsEncoded (- -- * Data types- EncodedContraints(..)- , EncodedCnstrs- -- * Functions to work with them- -- ** Read functions- , readMaybeECG- -- ** Process-encoding functions- , decodeConstraint1- , decodeLConstraints- , isConstraint1- -- ** Modifiers and getters- , getIEl- , setIEl- -- ** Predicates- , isE- , isP- , isF- , isQ- , isT- , isSA- , isSB- , isV- , isW- , isH- , isR- , isM- , isN- , isD- , isI- , isU- -- * Algebraic general conversion- , validOrdStr- , generalConversion- , filterGeneralConv+ -- * Data types+ EncodedContraints (..),+ EncodedCnstrs,++ -- * Functions to work with them++ -- ** Read functions+ readMaybeECG,++ -- ** Process-encoding functions+ decodeConstraint1,+ decodeLConstraints,+ isConstraint1,++ -- ** Modifiers and getters+ getIEl,+ setIEl,++ -- ** Predicates+ isE,+ isP,+ isF,+ isQ,+ isT,+ isSA,+ isSB,+ isV,+ isW,+ isH,+ isR,+ isM,+ isN,+ isD,+ isI,+ isU,+ isG,++ -- * Algebraic general conversion+ validOrdStr,+ generalConversion,+ filterGeneralConv, ) where +import Aftovolio.Constraints+import Data.Char (isDigit, isLetter)+import Data.InsertLeft (InsertLeft (..), splitAtEndG)+import Data.List (groupBy, nub, words)+import Data.Maybe+import Data.Tuple (fst)+import GHC.Arr import GHC.Base import GHC.List-import GHC.Num ((+),(-),abs)-import Text.Show (show, Show(..))+import GHC.Num (abs, (+), (-)) import Text.Read (readMaybe)-import Data.Maybe-import Data.List (nub, words, groupBy)-import GHC.Arr-import Data.Char (isDigit, isLetter)-import Aftovolio.Constraints-import Data.InsertLeft (InsertLeft(..), splitAtEndG)-import Data.Tuple (fst)+import Text.Show (Show (..), show) -data EncodedContraints a b d - = E -- ^ Represents no additional constraint, corresponds to the whole set of theoretically possible permutations.- | P a b -- ^ Represents the set of permutations with the fixed positions of some elements.- | Q a a a a a -- ^ Represents the set of permutations with the preserved pairwise order between first and second, second and third, third and fourth elements.- | T a a a a -- ^ Represents the set of permutations with the preserved pairwise order between first and second, second and third elements.- | SA a a b -- ^ Represents the set of permutations with the preserved position of the elements AFTER the another selected one.- | SB a a b -- ^ Represents the set of permutations with the preserved position of the elements BEFORE the another selected one.- | F a a a -- ^ Represents the set of permutations with the preserved order between first and second elements.- | V a a a -- ^ Represents the set of permutations with the preserved both distance between and order of the two elements.- | W a a a -- ^ Represents the set of permutations with the preserved distance between the two elements.- | H a a a a -- ^ Represents the set of permutations with the preserved both distances between and order of the three elements.- | R a a a a -- ^ Represents the set of permutations with the preserved pairwise distances between the first and second, second and third elements.- | M a a a a -- ^ Represents the set of permutations with the preserved pairwise distances between the first and second, second and third elements, and additionally the order of the first and second elements.- | N a d -- ^ Represents the set of permutations with the moved fixed positions of some elements (at least one).- | D a a a a -- ^ Pepresents the set of permutations with the specified order and distance between the two elements.- | I a a a a -- ^ Pepresents the set of permutations with the specified distance between the two elements.- | U a a a a a a -- ^ Represents the set of permutations with the preserved order of the 5 elements- deriving (Eq, Ord, Show)+data EncodedContraints a b d+ = -- | Represents no additional constraint, corresponds to the whole set of theoretically possible permutations.+ E+ | -- | Represents the set of permutations with the fixed positions of some elements.+ P a b+ | -- | Represents the set of permutations with the preserved pairwise order between first and second, second and third, third and fourth elements.+ Q a a a a a+ | -- | Represents the set of permutations with the preserved pairwise order between first and second, second and third elements.+ T a a a a+ | -- | Represents the set of permutations with the preserved position of the elements AFTER the another selected one.+ SA a a b+ | -- | Represents the set of permutations with the preserved position of the elements BEFORE the another selected one.+ SB a a b+ | -- | Represents the set of permutations with the preserved order between first and second elements.+ F a a a+ | -- | Represents the set of permutations with the preserved both distance between and order of the two elements.+ V a a a+ | -- | Represents the set of permutations with the preserved distance between the two elements.+ W a a a+ | -- | Represents the set of permutations with the preserved both distances between and order of the three elements.+ H a a a a+ | -- | Represents the set of permutations with the preserved pairwise distances between the first and second, second and third elements.+ R a a a a+ | -- | Represents the set of permutations with the preserved pairwise distances between the first and second, second and third elements, and additionally the order of the first and second elements.+ M a a a a+ | -- | Represents the set of permutations with the moved fixed positions of some elements (at least one).+ N a d+ | -- | Pepresents the set of permutations with the specified order and distance between the two elements.+ D a a a a+ | -- | Pepresents the set of permutations with the specified distance between the two elements.+ I a a a a+ | -- | Represents the set of permutations with the preserved order of the 5 elements+ U a a a a a a+ | -- | Represents the set of permutations with the groupped more than two elements together+ G a a a+ deriving (Eq, Ord, Show) -validOrdStr0 - :: String - -> Int -- ^ Number of seen so far \'(\' parentheses- -> Int -- ^ Number of seen so far \')\' parentheses- -> Bool-validOrdStr0 ('E':ys) n m = validOrdStr0 ys n m-validOrdStr0 (' ':y:t:ys) n m- | y `elem` "ABDFHIMNPQRTUVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m- | y `elem` "-(E" = validOrdStr0 (y:t:ys) n m- | otherwise = False -validOrdStr0 ('(':y:t:ys) n m- | y `elem` "ABDFHIMNPQRTUVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) (n + 1) m- | y `elem` "-(E" = validOrdStr0 (y:t:ys) (n + 1) m- | otherwise = False -validOrdStr0 (')':y:t:ys) n m- | y `elem` "ABDFHIMNPQRTUVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n (m + 1)- | y `elem` "-()E" = validOrdStr0 (y:t:ys) n (m + 1)- | otherwise = False -validOrdStr0 ('-':y:t:ys) n m- | y `elem` "ABDFHIMNPQRTUVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m - | y `elem` "-)" || isDigit y = False- | otherwise = validOrdStr0 (y:t:ys) n m -validOrdStr0 (x:y:t:ys) n m - | x `elem` "ABDFHIMNPQRTUVW" && isDigit y = validOrdStr0 (dropWhile isDigit (t:ys)) n m - | x `elem` "ABDFHIMNPQRTUVW" = False- | otherwise = validOrdStr0 (y:t:ys) n (m + 1) -validOrdStr0 (x:')':ys) n m - | isDigit x = validOrdStr0 ys n (m + 1)- | x == ')' = validOrdStr0 ys n (m + 2) - | otherwise = False-validOrdStr0 (x:y:_) n m - | x `elem` "(ABDFHIMNQRTUVW" = False- | y `elem` " -(ABDFHIMNPQRTUVW" = False- | x == 'P' && not (isDigit y) = False- | x == ')' && y /= 'E' = False- | x == 'P' && n == m = True- | x == ')' && y == 'E' = n == (m + 1)- | (x `elem` "E -") && y == 'E' = n == m - | otherwise = False-validOrdStr0 (x:_) n m - | isDigit x || (x `elem` ")E") = if x == ')' then n == (m + 1) else n == m - | otherwise = False-validOrdStr0 _ n m = n == m+validOrdStr0 ::+ String ->+ -- | Number of seen so far \'(\' parentheses+ Int ->+ -- | Number of seen so far \')\' parentheses+ Int ->+ Bool+validOrdStr0 ('E' : ys) n m = validOrdStr0 ys n m+validOrdStr0 (' ' : y : t : ys) n m+ | y `elem` "ABDFGHIMNPQRTUVW" && isDigit t =+ validOrdStr0 (dropWhile isDigit ys) n m+ | y `elem` "-(E" = validOrdStr0 (y : t : ys) n m+ | otherwise = False+validOrdStr0 ('(' : y : t : ys) n m+ | y `elem` "ABDFGHIMNPQRTUVW" && isDigit t =+ validOrdStr0 (dropWhile isDigit ys) (n + 1) m+ | y `elem` "-(E" = validOrdStr0 (y : t : ys) (n + 1) m+ | otherwise = False+validOrdStr0 (')' : y : t : ys) n m+ | y `elem` "ABDFGHIMNPQRTUVW" && isDigit t =+ validOrdStr0 (dropWhile isDigit ys) n (m + 1)+ | y `elem` "-()E" = validOrdStr0 (y : t : ys) n (m + 1)+ | otherwise = False+validOrdStr0 ('-' : y : t : ys) n m+ | y `elem` "ABDFGHIMNPQRTUVW" && isDigit t =+ validOrdStr0 (dropWhile isDigit ys) n m+ | y `elem` "-)" || isDigit y = False+ | otherwise = validOrdStr0 (y : t : ys) n m+validOrdStr0 (x : y : t : ys) n m+ | x `elem` "ABDFGHIMNPQRTUVW" && isDigit y =+ validOrdStr0 (dropWhile isDigit (t : ys)) n m+ | x `elem` "ABDFGHIMNPQRTUVW" = False+ | otherwise = validOrdStr0 (y : t : ys) n (m + 1)+validOrdStr0 (x : ')' : ys) n m+ | isDigit x = validOrdStr0 ys n (m + 1)+ | x == ')' = validOrdStr0 ys n (m + 2)+ | otherwise = False+validOrdStr0 (x : y : _) n m+ | x `elem` "(ABDFGHIMNQRTUVW" = False+ | y `elem` " -(ABDFGHIMNPQRTUVW" = False+ | x == 'P' && not (isDigit y) = False+ | x == ')' && y /= 'E' = False+ | x == 'P' && n == m = True+ | x == ')' && y == 'E' = n == (m + 1)+ | (x `elem` "E -") && y == 'E' = n == m+ | otherwise = False+validOrdStr0 (x : _) n m+ | isDigit x || (x `elem` ")E") = if x == ')' then n == (m + 1) else n == m+ | otherwise = False+validOrdStr0 _ n m = n == m --- | An extended predicate to check whether the 'String' is a probably correct representation of the--- constraints algebraic expression for 'generalConversion' evaluation.+{- | An extended predicate to check whether the 'String' is a probably correct representation of the+constraints algebraic expression for 'generalConversion' evaluation.+-} validOrdStr :: String -> Bool-validOrdStr xs = validOrdStr0 xs 0 0 +validOrdStr xs = validOrdStr0 xs 0 0 {-# INLINE validOrdStr #-} stage1Parsing :: String -> [String]-stage1Parsing = groupBy (\x y -> x == '(' && y == '(' || isLetter x && isDigit y || x == ')' && y == ')')+stage1Parsing =+ groupBy+ ( \x y -> x == '(' && y == '(' || isLetter x && isDigit y || x == ')' && y == ')'+ ) {-# INLINE stage1Parsing #-} -- | At the moment is used only for the list of 'String' without any parentheses in each of them.-convertToBools - :: Int - -> Array Int Int - -> [String] - -> String -- ^ The result is a 'String' that Haskell can evaluate to 'Bool' (some logical expression).-convertToBools n arr ("-":yss) = "not " `mappend` (convertToBools n arr yss)-convertToBools n arr (" ":yss) = " || " `mappend` (convertToBools n arr yss)-convertToBools n arr (xs:yss@(ys:_))- | xs `elem` ["True","False"] = xs `mappend` (case ys of - " " -> " "- _ -> " && ") `mappend` convertToBools n arr yss - | otherwise = let cnstrs = fromMaybe E . readMaybeECG n $ xs in - show (isConstraint1 True arr cnstrs) - `mappend` (case ys of - " " -> " "- _ -> " && ") `mappend` convertToBools n arr yss -convertToBools n arr (xs:_) - | xs `elem` ["True","False"] = xs- | otherwise = (show . isConstraint1 True arr . fromMaybe E . readMaybeECG n $ xs) +convertToBools ::+ Int ->+ Array Int Int ->+ [String] ->+ -- | The result is a 'String' that Haskell can evaluate to 'Bool' (some logical expression).+ String+convertToBools n arr ("-" : yss) = "not " `mappend` (convertToBools n arr yss)+convertToBools n arr (" " : yss) = " || " `mappend` (convertToBools n arr yss)+convertToBools n arr (xs : yss@(ys : _))+ | xs `elem` ["True", "False"] =+ xs+ `mappend` ( case ys of+ " " -> " "+ _ -> " && "+ )+ `mappend` convertToBools n arr yss+ | otherwise =+ let cnstrs = fromMaybe E . readMaybeECG n $ xs+ in show (isConstraint1 True arr cnstrs)+ `mappend` ( case ys of+ " " -> " "+ _ -> " && "+ )+ `mappend` convertToBools n arr yss+convertToBools n arr (xs : _)+ | xs `elem` ["True", "False"] = xs+ | otherwise =+ (show . isConstraint1 True arr . fromMaybe E . readMaybeECG n $ xs) convertToBools _ _ _ = [] splitNoParenAtDisjunction :: [String] -> [[String]]-splitNoParenAtDisjunction xss@(_:_) - | null tss = []- | otherwise = tss : splitNoParenAtDisjunction wss - where (tss,uss) = break (== "||") xss- wss = drop 1 uss +splitNoParenAtDisjunction xss@(_ : _)+ | null tss = []+ | otherwise = tss : splitNoParenAtDisjunction wss+ where+ (tss, uss) = break (== "||") xss+ wss = drop 1 uss splitNoParenAtDisjunction _ = [] -noParenString0 :: [String] -> Bool -noParenString0 (xs:ys:ts:yss) - | xs == "not" = - case ys of - "True" -> False - _ -> noParenString0 yss - | otherwise = - case xs of- "True" -> noParenString0 (ts:yss)- _ -> False -noParenString0 ("not":ys:_) = if ys == "True" then False else True -noParenString0 (xs:_) - | xs == "True" = True - | otherwise = False +noParenString0 :: [String] -> Bool+noParenString0 (xs : ys : ts : yss)+ | xs == "not" =+ case ys of+ "True" -> False+ _ -> noParenString0 yss+ | otherwise =+ case xs of+ "True" -> noParenString0 (ts : yss)+ _ -> False+noParenString0 ("not" : ys : _) = if ys == "True" then False else True+noParenString0 (xs : _)+ | xs == "True" = True+ | otherwise = False noParenString0 _ = True noParenString :: [String] -> Bool@@ -190,97 +239,186 @@ {-# INLINE oneStep #-} oneChange :: Int -> Array Int Int -> [String] -> [String]-oneChange m arr xss - | null wss = [show . oneStep m arr $ xss]- | otherwise = ((\(jss, _, qss) -> jss `mappend` [show . oneStep m arr $ qss]) . - foldr (\xs (tss, n, rss) -> if xs == "(" && n == 0 - then (tss, 1, rss) - else if any (== '(') xs && n == 0- then (drop 1 xs:tss, 1, rss)- else case n of - 0 -> (tss, 0, xs:rss)- _ -> (xs:tss, 1, rss)) ([], 0, []) $ yss) `mappend` kss- where (yss,wss) = break (any (== ')')) xss- kss = case wss of- ")":vss -> vss - ws:vss -> drop 1 ws : vss- _ -> []+oneChange m arr xss+ | null wss = [show . oneStep m arr $ xss]+ | otherwise =+ ( (\(jss, _, qss) -> jss `mappend` [show . oneStep m arr $ qss])+ . foldr+ ( \xs (tss, n, rss) ->+ if xs == "(" && n == 0+ then (tss, 1, rss)+ else+ if any (== '(') xs && n == 0+ then (drop 1 xs : tss, 1, rss)+ else case n of+ 0 -> (tss, 0, xs : rss)+ _ -> (xs : tss, 1, rss)+ )+ ([], 0, [])+ $ yss+ )+ `mappend` kss+ where+ (yss, wss) = break (any (== ')')) xss+ kss = case wss of+ ")" : vss -> vss+ ws : vss -> drop 1 ws : vss+ _ -> [] generalConversion :: Int -> String -> Array Int Int -> Bool generalConversion m xs arr- | validOrdStr xs = (\ks -> if ks == "True" || ks == "E" then True else False) . - head . head . dropWhile ((/= 1) . length) . drop 1 . iterate (oneChange m arr) . stage1Parsing $ xs - | otherwise = False+ | validOrdStr xs =+ (\ks -> if ks == "True" || ks == "E" then True else False)+ . head+ . head+ . dropWhile ((/= 1) . length)+ . drop 1+ . iterate (oneChange m arr)+ . stage1Parsing+ $ xs+ | otherwise = False {-# INLINE generalConversion #-} -- | Can be thought of as 'filter' ('generalConversion' ... ) @<arrays>@ but is somewhat more efficient. filterGeneralConv :: Int -> String -> [Array Int Int] -> [Array Int Int]-filterGeneralConv m cnstrns xs - | validOrdStr cnstrns = let !xss = stage1Parsing cnstrns in - filter (\arr -> (\ks -> if ks == "True" || ks == "E" then True else False) . head . head . dropWhile ((/= 1) . length) . drop 1 . iterate (oneChange m arr) $ xss) xs- | otherwise = []+filterGeneralConv m cnstrns xs+ | validOrdStr cnstrns =+ let !xss = stage1Parsing cnstrns+ in filter+ ( \arr ->+ (\ks -> if ks == "True" || ks == "E" then True else False)+ . head+ . head+ . dropWhile ((/= 1) . length)+ . drop 1+ . iterate (oneChange m arr) $+ xss+ )+ xs+ | otherwise = [] {-# INLINE filterGeneralConv #-} --- | Inspired by the: https://hackage.haskell.org/package/base-4.14.0.0/docs/Data-Maybe.html--- Is provided here as a more general way to read the 'String' into a 'EncodedCnstrs'. --- It is up to user to check whether the parameters are in the correct form, the function does--- not do the full checking.+{- | Inspired by the: https://hackage.haskell.org/package/base-4.14.0.0/docs/Data-Maybe.html+Is provided here as a more general way to read the 'String' into a 'EncodedCnstrs'.+It is up to user to check whether the parameters are in the correct form, the function does+not do the full checking.+-} readMaybeECG :: Int -> String -> Maybe EncodedCnstrs readMaybeECG n xs- | null xs = Nothing- | n >=0 && n <= 9 =- let h = head xs- ts = filter (\x -> x >= '0' && [x] <= show n) . tail $ xs in- case h of- 'E' -> Just E- _ -> f n h ts- | otherwise = Nothing- where f n c ts - | c `elem` "DFHIMQRQTUVW" = - let ys0 =catMaybes . map (\t -> readMaybe [t]::Maybe Int) $ ts- ys = nub ys0- (jjs, ps) = splitAtEndG 1 ys0- res - | length ys0 >= 3 && (c `elem` "DI") = let qs = take 2 . nub $ jjs- [y,z] = map (\rr -> if rr == 0 then 9 else rr - 1) qs in if length qs /= 2 || ps == [0] || ps > [n] then Nothing else Just ((if c == 'D' then D else I) n y z (head ps))- | length ys /= g c = Nothing- | c == 'Q' = let [y,z,u,w] = map (\rr -> if rr == 0 then 9 else rr - 1) ys in Just (Q n y z u w)- | c == 'U' = let [y,z,t,u,w] = map (\rr -> if rr == 0 then 9 else rr - 1) ys in Just (U n y z t u w)- | c `elem` "FVW" = let [y,z] = map (\rr -> if rr == 0 then 9 else rr - 1) ys in Just ((case c of {'F' -> F; 'V'-> V; _ -> W}) n y z)- | c `elem` "HMT" = let [y,z,u] = map (\rr -> if rr == 0 then 9 else rr - 1) ys in Just ((case c of {'T' -> T; 'H' -> H; 'M' -> M; _ -> R}) n y z u)- | otherwise = Nothing in res- | c `elem` "AB" = let y = readMaybe (take 1 ts)::Maybe Int in- if isJust y then- let y0 = fromJust y- zs = map (\rr -> if rr == 0 then 9 else rr - 1) . filter (/= y0) . nub . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in- case zs of- [] -> Nothing- ~x2 -> Just ((if c == 'A' then SA else SB) n (if y0 == 0 then 9 else y0 - 1) (listArray (0,length x2 - 1) x2))- else Nothing - | c == 'P' = if null ts then Just E else Just . P n . listArray (0,length ts - 1) . map (\r -> case (fromJust (readMaybe [r]::Maybe Int)) of {0 -> 9; q -> q-1}) $ ts- | c == 'N' = if tl == 0 then Just E else Just . N n . listArray (0, tl - 1) . map ((\[s,w] -> (w, s)) . map (\r -> case (fromJust (readMaybe [r]::Maybe Int)) of {0 -> 9; q -> q-1})) $ h3- | otherwise = Nothing- where h1 (b:d:ds) = [b,d]:h1 ds- h1 _ = [] - h2 = h1 ts- qqs = map head h2- pps = map last h2- h3 - | length (nub qqs) == length qqs && length (nub pps) == length pps = h2- | otherwise = []- tl = length h3- g c - | c `elem` "FVW" = 2- | c == 'Q' = 4- | c == 'U' = 5- | otherwise = 3-+ | null xs = Nothing+ | n >= 0 && n <= 9 =+ let h = head xs+ ts = filter (\x -> x >= '0' && [x] <= show n) . tail $ xs+ in case h of+ 'E' -> Just E+ _ -> f n h ts+ | otherwise = Nothing+ where+ f n c ts+ | c `elem` "DFGHIMQRQTUVW" =+ let ys0 = catMaybes . map (\t -> readMaybe [t] :: Maybe Int) $ ts+ ys = nub ys0+ (jjs, ps) = splitAtEndG 1 ys0+ res+ | length ys0 >= 3 && (c `elem` "DI") =+ let qs = take 2 . nub $ jjs+ [y, z] = map (\rr -> if rr == 0 then 9 else rr - 1) qs+ in if length qs /= 2 || ps == [0] || ps > [n]+ then Nothing+ else Just ((if c == 'D' then D else I) n y z (head ps))+ | length ys /= g c = Nothing+ | c `elem` "FVW" =+ let [y, z] = map (\rr -> if rr == 0 then 9 else rr - 1) ys+ in Just ((case c of 'F' -> F; 'V' -> V; _ -> W) n y z)+ | c `elem` "HMT" =+ let [y, z, u] = map (\rr -> if rr == 0 then 9 else rr - 1) ys+ in Just ((case c of 'T' -> T; 'H' -> H; 'M' -> M; _ -> R) n y z u)+ | c == 'G' =+ let [y0, z0] = map (\rr -> if rr == 0 then 9 else rr - 1) ys+ (y, z) + | y0 < z0 = (y0, z0)+ | otherwise = (z0, y0) + in Just (G n y z)+ | c == 'Q' =+ let [y, z, u, w] = map (\rr -> if rr == 0 then 9 else rr - 1) ys+ in Just (Q n y z u w)+ | c == 'U' =+ let [y, z, t, u, w] = map (\rr -> if rr == 0 then 9 else rr - 1) ys+ in Just (U n y z t u w)+ | otherwise = Nothing+ in res+ | c `elem` "AB" =+ let y = readMaybe (take 1 ts) :: Maybe Int+ in if isJust y+ then+ let y0 = fromJust y+ zs =+ map (\rr -> if rr == 0 then 9 else rr - 1)+ . filter (/= y0)+ . nub+ . catMaybes+ . map (\t -> readMaybe [t] :: Maybe Int)+ . drop 1 $+ ts+ in case zs of+ [] -> Nothing+ ~x2 ->+ Just+ ( (if c == 'A' then SA else SB)+ n+ (if y0 == 0 then 9 else y0 - 1)+ (listArray (0, length x2 - 1) x2)+ )+ else Nothing+ | c == 'P' =+ if null ts+ then Just E+ else+ Just+ . P n+ . listArray (0, length ts - 1)+ . map (\r -> case (fromJust (readMaybe [r] :: Maybe Int)) of 0 -> 9; q -> q - 1) $+ ts+ | c == 'N' =+ if tl == 0+ then Just E+ else+ Just+ . N n+ . listArray (0, tl - 1)+ . map+ ( (\[s, w] -> (w, s))+ . map (\r -> case (fromJust (readMaybe [r] :: Maybe Int)) of 0 -> 9; q -> q - 1)+ ) $+ h3+ | otherwise = Nothing+ where+ h1 (b : d : ds) = [b, d] : h1 ds+ h1 _ = []+ h2 = h1 ts+ qqs = map head h2+ pps = map last h2+ h3+ | length (nub qqs) == length qqs && length (nub pps) == length pps = h2+ | otherwise = []+ tl = length h3+ g c+ | c `elem` "FGVW" = 2+ | c == 'Q' = 4+ | c == 'U' = 5+ | otherwise = 3 -type EncodedCnstrs = EncodedContraints Int (Array Int Int) (Array Int (Int, Int))+type EncodedCnstrs =+ EncodedContraints Int (Array Int Int) (Array Int (Int, Int)) --- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the--- 'EncodedCnstrs' must be in the range [0..n-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. -decodeConstraint1 :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => EncodedCnstrs -> t (Array Int Int) -> t (Array Int Int)+{- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the+'EncodedCnstrs' must be in the range [0..n-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'.+-}+decodeConstraint1 ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ EncodedCnstrs ->+ t (Array Int Int) ->+ t (Array Int Int) decodeConstraint1 E = id decodeConstraint1 (P _ v) = fixedPointsS v decodeConstraint1 (Q _ i j k l) = unsafeQuadruples i j k l@@ -297,54 +435,67 @@ decodeConstraint1 (D _ i j d) = filterSignDistanceIJ i j (abs d) decodeConstraint1 (I _ i j d) = filterUnsignDistanceIJ i j (abs d) decodeConstraint1 (U _ i j k l m) = unsafeQuintuples i j k l m-{-# SPECIALIZE decodeConstraint1 :: EncodedCnstrs -> [Array Int Int] -> [Array Int Int] #-}+decodeConstraint1 (G _ i j) = filterGrouppedTogether i j+{-# SPECIALIZE decodeConstraint1 ::+ EncodedCnstrs -> [Array Int Int] -> [Array Int Int]+ #-} --- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the--- 'EncodedCnstrs' must be in the range [0..n-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'.-decodeLConstraints :: (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) => [EncodedCnstrs] -> t (Array Int Int) -> t (Array Int Int)-decodeLConstraints (x:xs) = decodeLConstraints' ys . decodeConstraint1 y- where y = minimum (x:xs)- ys = filter (/= y) . g $ (x:xs)- g (E:zs) = g zs- g (z:zs) = z : g zs- g _ = []- decodeLConstraints' (z:zs) = decodeLConstraints' zs . decodeConstraint1 z- decodeLConstraints' _ = id+{- | Must be applied to the correct array of permutation indeces. Otherwise, it gives runtime error (exception). All the integers inside the+'EncodedCnstrs' must be in the range [0..n-1] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'.+-}+decodeLConstraints ::+ (InsertLeft t (Array Int Int), Monoid (t (Array Int Int))) =>+ [EncodedCnstrs] ->+ t (Array Int Int) ->+ t (Array Int Int)+decodeLConstraints (x : xs) = decodeLConstraints' ys . decodeConstraint1 y+ where+ y = minimum (x : xs)+ ys = filter (/= y) . g $ (x : xs)+ g (E : zs) = g zs+ g (z : zs) = z : g zs+ g _ = []+ decodeLConstraints' (z : zs) = decodeLConstraints' zs . decodeConstraint1 z+ decodeLConstraints' _ = id decodeLConstraints _ = id-{-# SPECIALIZE decodeLConstraints :: [EncodedCnstrs] -> [Array Int Int] -> [Array Int Int] #-}+{-# SPECIALIZE decodeLConstraints ::+ [EncodedCnstrs] -> [Array Int Int] -> [Array Int Int]+ #-} isConstraint1 :: Bool -> Array Int Int -> EncodedCnstrs -> Bool isConstraint1 bool _ E = bool-isConstraint1 True arr (F _ i j) = unsafeOrderIJ i j arr -isConstraint1 True arr (T _ i j k) = isTripleOrdered i j k arr -isConstraint1 True arr (Q _ i j k l) = isQuadrupleOrdered i j k l arr -isConstraint1 True arr (SA _ i arr2) = isSeveralAOrdered i arr2 arr -isConstraint1 True arr (SB _ i arr2) = isSeveralBOrdered i arr2 arr -isConstraint1 True arr (P _ arr2) = isFixedPoint arr2 arr -isConstraint1 True arr (H _ i j k) = isSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 True arr (M _ i j k) = isMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 True arr (R _ i j k) = isUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 True arr (V _ i j) = unsafeSignDistanceIJ i j (abs $ j - i) arr -isConstraint1 True arr (W _ i j) = unsafeUnsignDistanceIJ i j (abs $ j - i) arr -isConstraint1 True arr (N _ arr2) = isFixedPointTup arr2 arr -isConstraint1 True arr (D _ i j d) = unsafeSignDistanceIJ i j (abs d) arr -isConstraint1 True arr (I _ i j d) = unsafeUnsignDistanceIJ i j (abs d) arr -isConstraint1 True arr (U _ i j k l m) = isQuintupleOrdered i j k l m arr -isConstraint1 False arr (F _ i j) = unsafeOrderIJ j i arr -isConstraint1 False arr (T _ i j k) = notTripleOrdered i j k arr -isConstraint1 False arr (Q _ i j k l) = notQuadrupleOrdered i j k l arr -isConstraint1 False arr (SA _ i arr2) = notSeveralAOrdered i arr2 arr -isConstraint1 False arr (SB _ i arr2) = notSeveralBOrdered i arr2 arr -isConstraint1 False arr (P _ arr2) = notFixedPoint arr2 arr -isConstraint1 False arr (H _ i j k) = notSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 False arr (M _ i j k) = notMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 False arr (R _ i j k) = notUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr -isConstraint1 False arr (V _ i j) = unsafeSignDistanceIJ j i (abs $ j - i) arr -isConstraint1 False arr (W _ i j) = not . unsafeUnsignDistanceIJ i j (abs $ j - i) $ arr -isConstraint1 False arr (N _ arr2) = notFixedPointTup arr2 arr -isConstraint1 False arr (D _ i j d) = unsafeSignDistanceIJ j i (abs d) arr -isConstraint1 False arr (I _ i j d) = not . unsafeUnsignDistanceIJ i j (abs d) $ arr -isConstraint1 False arr (U _ i j k l m) = notQuintupleOrdered i j k l m arr +isConstraint1 True arr (F _ i j) = unsafeOrderIJ i j arr+isConstraint1 True arr (T _ i j k) = isTripleOrdered i j k arr+isConstraint1 True arr (Q _ i j k l) = isQuadrupleOrdered i j k l arr+isConstraint1 True arr (SA _ i arr2) = isSeveralAOrdered i arr2 arr+isConstraint1 True arr (SB _ i arr2) = isSeveralBOrdered i arr2 arr+isConstraint1 True arr (P _ arr2) = isFixedPoint arr2 arr+isConstraint1 True arr (H _ i j k) = isSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 True arr (M _ i j k) = isMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 True arr (R _ i j k) = isUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 True arr (V _ i j) = unsafeSignDistanceIJ i j (abs $ j - i) arr+isConstraint1 True arr (W _ i j) = unsafeUnsignDistanceIJ i j (abs $ j - i) arr+isConstraint1 True arr (N _ arr2) = isFixedPointTup arr2 arr+isConstraint1 True arr (D _ i j d) = unsafeSignDistanceIJ i j (abs d) arr+isConstraint1 True arr (I _ i j d) = unsafeUnsignDistanceIJ i j (abs d) arr+isConstraint1 True arr (U _ i j k l m) = isQuintupleOrdered i j k l m arr+isConstraint1 True arr (G _ i j) = isGrouppedTogether i j arr+isConstraint1 False arr (F _ i j) = unsafeOrderIJ j i arr+isConstraint1 False arr (T _ i j k) = notTripleOrdered i j k arr+isConstraint1 False arr (Q _ i j k l) = notQuadrupleOrdered i j k l arr+isConstraint1 False arr (SA _ i arr2) = notSeveralAOrdered i arr2 arr+isConstraint1 False arr (SB _ i arr2) = notSeveralBOrdered i arr2 arr+isConstraint1 False arr (P _ arr2) = notFixedPoint arr2 arr+isConstraint1 False arr (H _ i j k) = notSignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 False arr (M _ i j k) = notMixedDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 False arr (R _ i j k) = notUnsignDistIJK3 i j k (abs $ j - i) (abs $ k - j) arr+isConstraint1 False arr (V _ i j) = unsafeSignDistanceIJ j i (abs $ j - i) arr+isConstraint1 False arr (W _ i j) = not . unsafeUnsignDistanceIJ i j (abs $ j - i) $ arr+isConstraint1 False arr (N _ arr2) = notFixedPointTup arr2 arr+isConstraint1 False arr (D _ i j d) = unsafeSignDistanceIJ j i (abs d) arr+isConstraint1 False arr (I _ i j d) = not . unsafeUnsignDistanceIJ i j (abs d) $ arr+isConstraint1 False arr (U _ i j k l m) = notQuintupleOrdered i j k l m arr+isConstraint1 False arr (G _ i j) = notGrouppedTogether i j arr isE :: EncodedCnstrs -> Bool isE E = True@@ -410,9 +561,11 @@ isU (U _ _ _ _ _ _) = True isU _ = False +isG :: EncodedCnstrs -> Bool+isG (G _ _ _) = True+isG _ = False -{-| Works only with the correctly defined argument though it is not checked. Use with this caution.--}+-- | Works only with the correctly defined argument though it is not checked. Use with this caution. getIEl :: EncodedCnstrs -> Int getIEl E = -1 getIEl (P _ arr) = unsafeAt arr 0@@ -426,16 +579,16 @@ getIEl (H _ i _ _) = i getIEl (R _ i _ _) = i getIEl (M _ i _ _) = i-getIEl (N _ arr) = fst . unsafeAt arr $ 0 +getIEl (N _ arr) = fst . unsafeAt arr $ 0 getIEl (D _ i _ _) = i getIEl (I _ i _ _) = i getIEl (U _ i _ _ _ _) = i+getIEl (G _ i _) = i -{-| Works only with the correctly defined arguments though it is not checked. Use with this caution.--}+-- | Works only with the correctly defined arguments though it is not checked. Use with this caution. setIEl :: Int -> EncodedCnstrs -> EncodedCnstrs setIEl _ E = E-setIEl i (P n arr) = P n (arr // [(0,i)])+setIEl i (P n arr) = P n (arr // [(0, i)]) setIEl i (Q n _ j k l) = Q n i j k l setIEl i (T n _ j k) = T n i j k setIEl i (SA n _ v) = SA n i v@@ -450,4 +603,5 @@ setIEl i (D n _ j k) = D n i j k setIEl i (I n _ j k) = I n i j k setIEl i (U n _ j k l m) = U n i j k l m+setIEl i (G n _ j) = G n i j
Aftovolio/DataG.hs view
@@ -1,301 +1,483 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.DataG--- Copyright : (c) Oleksandr Zhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Simplified version of the @phonetic-languages-common@ and @phonetic-languages-general@ packages.--- Uses less dependencies.--{-# LANGUAGE BangPatterns, FlexibleContexts, NoImplicitPrelude #-}+{- |+Module : Aftovolio.DataG+Copyright : (c) Oleksandr Zhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Simplified version of the @phonetic-languages-common@ and @phonetic-languages-general@ packages.+Uses less dependencies.+-} module Aftovolio.DataG where +import Aftovolio.Basis+import qualified Data.Foldable as F+import Data.InsertLeft (InsertLeft (..), mapG, partitionG)+import Data.Maybe (fromJust)+import Data.MinMax1 import GHC.Base import GHC.Num ((-)) import GHC.Real-import qualified Data.Foldable as F-import Data.InsertLeft (InsertLeft(..),mapG,partitionG) -import Data.MinMax1-import Data.Maybe (fromJust) -import Aftovolio.Basis -maximumEl- :: (F.Foldable t2, Ord c) => FuncRep2 (t a) b c- -> t2 (t a)- -> Result t a b c+maximumEl ::+ (F.Foldable t2, Ord c) =>+ FuncRep2 (t a) b c ->+ t2 (t a) ->+ Result t a b c maximumEl !frep2 data0 =- let !l = F.maximumBy (\x y -> compare (getAC frep2 x) (getAC frep2 y)) data0- !m = getAB frep2 l- !tm = getBC frep2 m in R {line = l, propertiesF = m, transPropertiesF = tm}+ let !l = F.maximumBy (\x y -> compare (getAC frep2 x) (getAC frep2 y)) data0+ !m = getAB frep2 l+ !tm = getBC frep2 m+ in R{line = l, propertiesF = m, transPropertiesF = tm} {-# INLINE maximumEl #-}-{-# SPECIALIZE maximumEl :: (Ord c) => FuncRep2 [a] Double c -> [[a]] -> Result [] a Double c #-}+{-# SPECIALIZE maximumEl ::+ (Ord c) => FuncRep2 [a] Double c -> [[a]] -> Result [] a Double c+ #-} -- | Is intended to be used for the structures with at least two elements, though it is not checked.-minMaximumEls- :: (InsertLeft t2 (t a), Monoid (t2 (t a)), Ord (t a), Ord c) => FuncRep2 (t a) b c- -> t2 (t a)- -> (Result t a b c,Result t a b c)+minMaximumEls ::+ (InsertLeft t2 (t a), Monoid (t2 (t a)), Ord (t a), Ord c) =>+ FuncRep2 (t a) b c ->+ t2 (t a) ->+ (Result t a b c, Result t a b c) minMaximumEls !frep2 data0 =- let (!ln,!lx) = fromJust . minMax11By (\x y -> compare (getAC frep2 x) (getAC frep2 y)) $ data0- !mn = getAB frep2 ln- !mx = getAB frep2 lx- !tmn = getBC frep2 mn- !tmx = getBC frep2 mx in (R {line = ln, propertiesF = mn, transPropertiesF = tmn}, R {line = lx, propertiesF = mx, transPropertiesF = tmx})+ let (!ln, !lx) =+ fromJust . minMax11By (\x y -> compare (getAC frep2 x) (getAC frep2 y)) $ data0+ !mn = getAB frep2 ln+ !mx = getAB frep2 lx+ !tmn = getBC frep2 mn+ !tmx = getBC frep2 mx+ in ( R{line = ln, propertiesF = mn, transPropertiesF = tmn}+ , R{line = lx, propertiesF = mx, transPropertiesF = tmx}+ ) {-# INLINE minMaximumEls #-}-{-# SPECIALIZE minMaximumEls :: (Ord a, Ord c) => FuncRep2 [a] Double c -> [[a]] -> (Result [] a Double c, Result [] a Double c) #-}+{-# SPECIALIZE minMaximumEls ::+ (Ord a, Ord c) =>+ FuncRep2 [a] Double c ->+ [[a]] ->+ (Result [] a Double c, Result [] a Double c)+ #-} -maximumElR- :: (F.Foldable t2, Ord c) => t2 (Result t a b c)- -> Result t a b c+maximumElR ::+ (F.Foldable t2, Ord c) =>+ t2 (Result t a b c) ->+ Result t a b c maximumElR = F.maximumBy (\x y -> compare (transPropertiesF x) (transPropertiesF y)) {-# INLINE maximumElR #-}-{-# SPECIALIZE maximumElR :: (Ord c) => [Result [] a Double c] -> Result [] a Double c #-}+{-# SPECIALIZE maximumElR ::+ (Ord c) => [Result [] a Double c] -> Result [] a Double c+ #-} -- | Is intended to be used for the structures with at least two elements, though it is not checked.-minMaximumElRs- :: (InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), Ord (t a), Ord b, Ord c) => t2 (Result t a b c)- -> (Result t a b c,Result t a b c)-minMaximumElRs = fromJust . minMax11By (\x y -> compare (transPropertiesF x) (transPropertiesF y))+minMaximumElRs ::+ ( InsertLeft t2 (Result t a b c)+ , Monoid (t2 (Result t a b c))+ , Ord (t a)+ , Ord b+ , Ord c+ ) =>+ t2 (Result t a b c) ->+ (Result t a b c, Result t a b c)+minMaximumElRs =+ fromJust+ . minMax11By (\x y -> compare (transPropertiesF x) (transPropertiesF y)) {-# INLINE minMaximumElRs #-}-{-# SPECIALIZE minMaximumElRs :: (Ord a, Ord c) => [Result [] a Double c] -> (Result [] a Double c, Result [] a Double c) #-}+{-# SPECIALIZE minMaximumElRs ::+ (Ord a, Ord c) =>+ [Result [] a Double c] ->+ (Result [] a Double c, Result [] a Double c)+ #-} ----------------------------------------------------------------------------------- -- | The second argument must be not empty for the function to work correctly.-innerPartitioning- :: (InsertLeft t2 (t a), Monoid (t2 (t a)), InsertLeft t2 c, Monoid (t2 c), Ord c) => FuncRep2 (t a) b c- -> t2 (t a)- -> (t2 (t a), t2 (t a))+innerPartitioning ::+ (InsertLeft t2 (t a), Monoid (t2 (t a)), InsertLeft t2 c, Monoid (t2 c), Ord c) =>+ FuncRep2 (t a) b c ->+ t2 (t a) ->+ (t2 (t a), t2 (t a)) innerPartitioning !frep2 data0 =- let !l = F.maximum . mapG (toTransPropertiesF' frep2) $ data0 in partitionG ((== l) . getAC frep2) data0+ let !l = F.maximum . mapG (toTransPropertiesF' frep2) $ data0+ in partitionG ((== l) . getAC frep2) data0 {-# INLINE innerPartitioning #-}-{-# SPECIALIZE innerPartitioning :: (Eq a, Ord c) => FuncRep2 [a] Double c -> [[a]] -> ([[a]], [[a]]) #-}+{-# SPECIALIZE innerPartitioning ::+ (Eq a, Ord c) => FuncRep2 [a] Double c -> [[a]] -> ([[a]], [[a]])+ #-} -- | The first argument must be not empty for the function to work correctly.-innerPartitioningR- :: (InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), InsertLeft t2 c, Monoid (t2 c), Ord c) => t2 (Result t a b c)- -> (t2 (Result t a b c), t2 (Result t a b c))+innerPartitioningR ::+ ( InsertLeft t2 (Result t a b c)+ , Monoid (t2 (Result t a b c))+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Ord c+ ) =>+ t2 (Result t a b c) ->+ (t2 (Result t a b c), t2 (Result t a b c)) innerPartitioningR dataR =- let !l = F.maximum . mapG transPropertiesF $ dataR in partitionG ((== l) . transPropertiesF) dataR+ let !l = F.maximum . mapG transPropertiesF $ dataR+ in partitionG ((== l) . transPropertiesF) dataR {-# INLINE innerPartitioningR #-}-{-# SPECIALIZE innerPartitioningR :: (Eq a, Ord c) => [Result [] a Double c] -> ([Result [] a Double c], [Result [] a Double c]) #-}+{-# SPECIALIZE innerPartitioningR ::+ (Eq a, Ord c) =>+ [Result [] a Double c] ->+ ([Result [] a Double c], [Result [] a Double c])+ #-} -maximumGroupsClassification- :: (InsertLeft t2 (t a), Monoid (t2 (t a)), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> FuncRep2 (t a) b c- -> (t2 (t a), t2 (t a))- -> (t2 (t a), t2 (t a))-maximumGroupsClassification !nGroups !frep2 (dataT,dataF)- | F.null dataF = (dataT,mempty)- | nGroups <= 0 = (dataT,dataF)- | otherwise = maximumGroupsClassification (nGroups - 1) frep2 (dataT `mappend` partT,partF)- where (!partT,!partF) = innerPartitioning frep2 dataF+maximumGroupsClassification ::+ ( InsertLeft t2 (t a)+ , Monoid (t2 (t a))+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ FuncRep2 (t a) b c ->+ (t2 (t a), t2 (t a)) ->+ (t2 (t a), t2 (t a))+maximumGroupsClassification !nGroups !frep2 (dataT, dataF)+ | F.null dataF = (dataT, mempty)+ | nGroups <= 0 = (dataT, dataF)+ | otherwise =+ maximumGroupsClassification (nGroups - 1) frep2 (dataT `mappend` partT, partF)+ where+ (!partT, !partF) = innerPartitioning frep2 dataF {-# NOINLINE maximumGroupsClassification #-} -maximumGroupsClassification1- :: (InsertLeft t2 (t a), Monoid (t2 (t a)), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> FuncRep2 (t a) b c- -> t2 (t a)- -> (t2 (t a), t2 (t a))+maximumGroupsClassification1 ::+ ( InsertLeft t2 (t a)+ , Monoid (t2 (t a))+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ FuncRep2 (t a) b c ->+ t2 (t a) ->+ (t2 (t a), t2 (t a)) maximumGroupsClassification1 !nGroups !frep2 data0- | F.null data0 = (mempty,mempty)- | nGroups <= 0 = innerPartitioning frep2 data0- | otherwise = maximumGroupsClassification (nGroups - 1) frep2 . innerPartitioning frep2 $ data0+ | F.null data0 = (mempty, mempty)+ | nGroups <= 0 = innerPartitioning frep2 data0+ | otherwise =+ maximumGroupsClassification (nGroups - 1) frep2 . innerPartitioning frep2 $+ data0 {-# NOINLINE maximumGroupsClassification1 #-} -maximumGroupsClassificationR2- :: (Eq a, Eq b, Eq (t a), InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> (t2 (Result t a b c), t2 (Result t a b c))- -> (t2 (Result t a b c), t2 (Result t a b c))-maximumGroupsClassificationR2 !nGroups (dataT,dataF)- | F.null dataF = (dataT,mempty)- | nGroups <= 0 = (dataT,dataF)- | otherwise = maximumGroupsClassificationR2 (nGroups - 1) (dataT `mappend` partT,partF)- where (!partT,!partF) = innerPartitioningR dataF+maximumGroupsClassificationR2 ::+ ( Eq a+ , Eq b+ , Eq (t a)+ , InsertLeft t2 (Result t a b c)+ , Monoid (t2 (Result t a b c))+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ (t2 (Result t a b c), t2 (Result t a b c)) ->+ (t2 (Result t a b c), t2 (Result t a b c))+maximumGroupsClassificationR2 !nGroups (dataT, dataF)+ | F.null dataF = (dataT, mempty)+ | nGroups <= 0 = (dataT, dataF)+ | otherwise =+ maximumGroupsClassificationR2 (nGroups - 1) (dataT `mappend` partT, partF)+ where+ (!partT, !partF) = innerPartitioningR dataF {-# NOINLINE maximumGroupsClassificationR2 #-} -maximumGroupsClassificationR- :: (Eq a, Eq b, Eq (t a), InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), InsertLeft t2 c, Monoid (t2 c), Ord c, Integral d) => d- -> t2 (Result t a b c)- -> (t2 (Result t a b c), t2 (Result t a b c))+maximumGroupsClassificationR ::+ ( Eq a+ , Eq b+ , Eq (t a)+ , InsertLeft t2 (Result t a b c)+ , Monoid (t2 (Result t a b c))+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Ord c+ , Integral d+ ) =>+ d ->+ t2 (Result t a b c) ->+ (t2 (Result t a b c), t2 (Result t a b c)) maximumGroupsClassificationR !nGroups dataR- | F.null dataR = (mempty,mempty)- | nGroups <= 0 = innerPartitioningR dataR- | otherwise = maximumGroupsClassificationR2 (nGroups - 1) . innerPartitioningR $ dataR+ | F.null dataR = (mempty, mempty)+ | nGroups <= 0 = innerPartitioningR dataR+ | otherwise =+ maximumGroupsClassificationR2 (nGroups - 1) . innerPartitioningR $ dataR {-# NOINLINE maximumGroupsClassificationR #-} -toResultR- :: FuncRep2 (t a) b c- -> t a- -> Result t a b c-toResultR !frep2 !ys = R { line = ys, propertiesF = m, transPropertiesF = tm}- where !m = getAB frep2 ys- !tm = getBC frep2 m+toResultR ::+ FuncRep2 (t a) b c ->+ t a ->+ Result t a b c+toResultR !frep2 !ys = R{line = ys, propertiesF = m, transPropertiesF = tm}+ where+ !m = getAB frep2 ys+ !tm = getBC frep2 m {-# INLINE toResultR #-} -toPropertiesF'- :: FuncRep2 (t a) b c- -> t a- -> b+toPropertiesF' ::+ FuncRep2 (t a) b c ->+ t a ->+ b toPropertiesF' !frep2 !ys = getAB frep2 ys {-# INLINE toPropertiesF' #-} -toTransPropertiesF'- :: FuncRep2 (t a) b c- -> t a- -> c+toTransPropertiesF' ::+ FuncRep2 (t a) b c ->+ t a ->+ c toTransPropertiesF' !frep2 !ys = getAC frep2 ys {-# INLINE toTransPropertiesF' #-} -- | The second argument must be not empty for the function to work correctly.-partiR- :: (InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), InsertLeft t2 c) => (c -> Bool)- -> t2 (Result t a b c)- -> (t2 (Result t a b c), t2 (Result t a b c))+partiR ::+ (InsertLeft t2 (Result t a b c), Monoid (t2 (Result t a b c)), InsertLeft t2 c) =>+ (c -> Bool) ->+ t2 (Result t a b c) ->+ (t2 (Result t a b c), t2 (Result t a b c)) partiR p dataR = partitionG (p . transPropertiesF) dataR {-# INLINE partiR #-}-{-# SPECIALIZE partiR :: (Eq a, Eq c) => (c -> Bool) -> [Result [] a Double c] -> ([Result [] a Double c], [Result [] a Double c]) #-}+{-# SPECIALIZE partiR ::+ (Eq a, Eq c) =>+ (c -> Bool) ->+ [Result [] a Double c] ->+ ([Result [] a Double c], [Result [] a Double c])+ #-} ----------------------------------------------------------- -maximumEl2- :: (F.Foldable t2, Ord c) => FuncRep2 a b c- -> t2 a- -> Result2 a b c+maximumEl2 ::+ (F.Foldable t2, Ord c) =>+ FuncRep2 a b c ->+ t2 a ->+ Result2 a b c maximumEl2 !frep2 data0 =- let !l = F.maximumBy (\x y -> compare (getAC frep2 x) (getAC frep2 y)) data0- !m = getAB frep2 l- !tm = getBC frep2 m in R2 {line2 = l, propertiesF2 = m, transPropertiesF2 = tm}+ let !l = F.maximumBy (\x y -> compare (getAC frep2 x) (getAC frep2 y)) data0+ !m = getAB frep2 l+ !tm = getBC frep2 m+ in R2{line2 = l, propertiesF2 = m, transPropertiesF2 = tm} {-# INLINE maximumEl2 #-}-{-# SPECIALIZE maximumEl2 :: (Ord c) => FuncRep2 a Double c -> [a] -> Result2 a Double c #-}+{-# SPECIALIZE maximumEl2 ::+ (Ord c) => FuncRep2 a Double c -> [a] -> Result2 a Double c+ #-} -- | Is intended to be used with the structures with at least two elements, though it is not checked.-minMaximumEls2- :: (InsertLeft t2 a, Monoid (t2 a), Ord a, Ord c) => FuncRep2 a b c- -> t2 a- -> (Result2 a b c,Result2 a b c)+minMaximumEls2 ::+ (InsertLeft t2 a, Monoid (t2 a), Ord a, Ord c) =>+ FuncRep2 a b c ->+ t2 a ->+ (Result2 a b c, Result2 a b c) minMaximumEls2 !frep2 data0 =- let (!ln,!lx) = fromJust . minMax11By (\x y -> compare (getAC frep2 x) (getAC frep2 y)) $ data0- !mn = getAB frep2 ln- !mx = getAB frep2 lx- !tmn = getBC frep2 mn- !tmx = getBC frep2 mx in (R2 {line2 = ln, propertiesF2 = mn, transPropertiesF2 = tmn}, R2 {line2 = lx, propertiesF2 = mx, transPropertiesF2 = tmx})+ let (!ln, !lx) =+ fromJust . minMax11By (\x y -> compare (getAC frep2 x) (getAC frep2 y)) $ data0+ !mn = getAB frep2 ln+ !mx = getAB frep2 lx+ !tmn = getBC frep2 mn+ !tmx = getBC frep2 mx+ in ( R2{line2 = ln, propertiesF2 = mn, transPropertiesF2 = tmn}+ , R2{line2 = lx, propertiesF2 = mx, transPropertiesF2 = tmx}+ ) {-# INLINE minMaximumEls2 #-}-{-# SPECIALIZE minMaximumEls2 :: (Ord a, Ord c) => FuncRep2 a Double c -> [a] -> (Result2 a Double c, Result2 a Double c) #-}+{-# SPECIALIZE minMaximumEls2 ::+ (Ord a, Ord c) =>+ FuncRep2 a Double c ->+ [a] ->+ (Result2 a Double c, Result2 a Double c)+ #-} -maximumElR2- :: (F.Foldable t2, Ord c) => t2 (Result2 a b c)- -> Result2 a b c+maximumElR2 ::+ (F.Foldable t2, Ord c) =>+ t2 (Result2 a b c) ->+ Result2 a b c maximumElR2 = F.maximumBy (\x y -> compare (transPropertiesF2 x) (transPropertiesF2 y)) {-# INLINE maximumElR2 #-}-{-# SPECIALIZE maximumElR2 :: (Ord c) => [Result2 a Double c] -> Result2 a Double c #-}+{-# SPECIALIZE maximumElR2 ::+ (Ord c) => [Result2 a Double c] -> Result2 a Double c+ #-} -- | Is intended to be used with the structures with at least two elements, though it is not checked.-minMaximumElRs2- :: (InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), Ord a, Ord b, Ord c) => t2 (Result2 a b c)- -> (Result2 a b c,Result2 a b c)-minMaximumElRs2 = fromJust . minMax11By (\x y -> compare (transPropertiesF2 x) (transPropertiesF2 y))+minMaximumElRs2 ::+ ( InsertLeft t2 (Result2 a b c)+ , Monoid (t2 (Result2 a b c))+ , Ord a+ , Ord b+ , Ord c+ ) =>+ t2 (Result2 a b c) ->+ (Result2 a b c, Result2 a b c)+minMaximumElRs2 =+ fromJust+ . minMax11By (\x y -> compare (transPropertiesF2 x) (transPropertiesF2 y)) {-# INLINE minMaximumElRs2 #-}-{-# SPECIALIZE minMaximumElRs2 :: (Ord a, Ord c) => [Result2 a Double c] -> (Result2 a Double c, Result2 a Double c) #-}+{-# SPECIALIZE minMaximumElRs2 ::+ (Ord a, Ord c) =>+ [Result2 a Double c] ->+ (Result2 a Double c, Result2 a Double c)+ #-} ----------------------------------------------------------------------------------- -- | The second argument must be not empty for the function to work correctly.-innerPartitioning2- :: (InsertLeft t2 a, Monoid (t2 a), InsertLeft t2 c, Monoid (t2 c), Ord c) => FuncRep2 a b c- -> t2 a- -> (t2 a, t2 a)+innerPartitioning2 ::+ (InsertLeft t2 a, Monoid (t2 a), InsertLeft t2 c, Monoid (t2 c), Ord c) =>+ FuncRep2 a b c ->+ t2 a ->+ (t2 a, t2 a) innerPartitioning2 !frep2 data0 =- let !l = F.maximum . mapG (toTransPropertiesF'2 frep2) $ data0 in partitionG ((== l) . getAC frep2) data0+ let !l = F.maximum . mapG (toTransPropertiesF'2 frep2) $ data0+ in partitionG ((== l) . getAC frep2) data0 {-# INLINE innerPartitioning2 #-}-{-# SPECIALIZE innerPartitioning2 :: (Eq a, Ord c) => FuncRep2 a Double c -> [a] -> ([a], [a]) #-}+{-# SPECIALIZE innerPartitioning2 ::+ (Eq a, Ord c) => FuncRep2 a Double c -> [a] -> ([a], [a])+ #-} -- | The first argument must be not empty for the function to work correctly.-innerPartitioningR2- :: (InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), InsertLeft t2 c, Monoid (t2 c), Ord c) => t2 (Result2 a b c)- -> (t2 (Result2 a b c), t2 (Result2 a b c))+innerPartitioningR2 ::+ ( InsertLeft t2 (Result2 a b c)+ , Monoid (t2 (Result2 a b c))+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Ord c+ ) =>+ t2 (Result2 a b c) ->+ (t2 (Result2 a b c), t2 (Result2 a b c)) innerPartitioningR2 dataR =- let !l = F.maximum . mapG transPropertiesF2 $ dataR in partitionG ((== l) . transPropertiesF2) dataR+ let !l = F.maximum . mapG transPropertiesF2 $ dataR+ in partitionG ((== l) . transPropertiesF2) dataR {-# INLINE innerPartitioningR2 #-}-{-# SPECIALIZE innerPartitioningR2 :: (Eq a, Ord c) => [Result2 a Double c] -> ([Result2 a Double c], [Result2 a Double c]) #-}+{-# SPECIALIZE innerPartitioningR2 ::+ (Eq a, Ord c) =>+ [Result2 a Double c] ->+ ([Result2 a Double c], [Result2 a Double c])+ #-} -maximumGroupsClassification2- :: (InsertLeft t2 a, Monoid (t2 a), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> FuncRep2 a b c- -> (t2 a, t2 a)- -> (t2 a, t2 a)-maximumGroupsClassification2 !nGroups !frep2 (dataT,dataF)- | F.null dataF = (dataT,mempty)- | nGroups <= 0 = (dataT,dataF)- | otherwise = maximumGroupsClassification2 (nGroups - 1) frep2 (dataT `mappend` partT,partF)- where (!partT,!partF) = innerPartitioning2 frep2 dataF+maximumGroupsClassification2 ::+ ( InsertLeft t2 a+ , Monoid (t2 a)+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ FuncRep2 a b c ->+ (t2 a, t2 a) ->+ (t2 a, t2 a)+maximumGroupsClassification2 !nGroups !frep2 (dataT, dataF)+ | F.null dataF = (dataT, mempty)+ | nGroups <= 0 = (dataT, dataF)+ | otherwise =+ maximumGroupsClassification2 (nGroups - 1) frep2 (dataT `mappend` partT, partF)+ where+ (!partT, !partF) = innerPartitioning2 frep2 dataF {-# NOINLINE maximumGroupsClassification2 #-} -maximumGroupsClassification12- :: (InsertLeft t2 a, Monoid (t2 a), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> FuncRep2 a b c- -> t2 a- -> (t2 a, t2 a)+maximumGroupsClassification12 ::+ ( InsertLeft t2 a+ , Monoid (t2 a)+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ FuncRep2 a b c ->+ t2 a ->+ (t2 a, t2 a) maximumGroupsClassification12 !nGroups !frep2 data0- | F.null data0 = (mempty,mempty)- | nGroups <= 0 = innerPartitioning2 frep2 data0- | otherwise = maximumGroupsClassification2 (nGroups - 1) frep2 . innerPartitioning2 frep2 $ data0+ | F.null data0 = (mempty, mempty)+ | nGroups <= 0 = innerPartitioning2 frep2 data0+ | otherwise =+ maximumGroupsClassification2 (nGroups - 1) frep2 . innerPartitioning2 frep2 $+ data0 {-# NOINLINE maximumGroupsClassification12 #-} -maximumGroupsClassificationR2_2- :: (Eq a, Eq b, InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), Ord c, InsertLeft t2 c, Monoid (t2 c), Integral d) => d- -> (t2 (Result2 a b c), t2 (Result2 a b c))- -> (t2 (Result2 a b c), t2 (Result2 a b c))-maximumGroupsClassificationR2_2 !nGroups (dataT,dataF)- | F.null dataF = (dataT,mempty)- | nGroups <= 0 = (dataT,dataF)- | otherwise = maximumGroupsClassificationR2_2 (nGroups - 1) (dataT `mappend` partT,partF)- where (!partT,!partF) = innerPartitioningR2 dataF+maximumGroupsClassificationR2_2 ::+ ( Eq a+ , Eq b+ , InsertLeft t2 (Result2 a b c)+ , Monoid (t2 (Result2 a b c))+ , Ord c+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Integral d+ ) =>+ d ->+ (t2 (Result2 a b c), t2 (Result2 a b c)) ->+ (t2 (Result2 a b c), t2 (Result2 a b c))+maximumGroupsClassificationR2_2 !nGroups (dataT, dataF)+ | F.null dataF = (dataT, mempty)+ | nGroups <= 0 = (dataT, dataF)+ | otherwise =+ maximumGroupsClassificationR2_2 (nGroups - 1) (dataT `mappend` partT, partF)+ where+ (!partT, !partF) = innerPartitioningR2 dataF {-# NOINLINE maximumGroupsClassificationR2_2 #-} -maximumGroupsClassificationR_2- :: (Eq a, Eq b, InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), InsertLeft t2 c, Monoid (t2 c), Ord c, Integral d) => d- -> t2 (Result2 a b c)- -> (t2 (Result2 a b c), t2 (Result2 a b c))+maximumGroupsClassificationR_2 ::+ ( Eq a+ , Eq b+ , InsertLeft t2 (Result2 a b c)+ , Monoid (t2 (Result2 a b c))+ , InsertLeft t2 c+ , Monoid (t2 c)+ , Ord c+ , Integral d+ ) =>+ d ->+ t2 (Result2 a b c) ->+ (t2 (Result2 a b c), t2 (Result2 a b c)) maximumGroupsClassificationR_2 !nGroups dataR- | F.null dataR = (mempty,mempty)- | nGroups <= 0 = innerPartitioningR2 dataR- | otherwise = maximumGroupsClassificationR2_2 (nGroups - 1) . innerPartitioningR2 $ dataR+ | F.null dataR = (mempty, mempty)+ | nGroups <= 0 = innerPartitioningR2 dataR+ | otherwise =+ maximumGroupsClassificationR2_2 (nGroups - 1) . innerPartitioningR2 $ dataR {-# NOINLINE maximumGroupsClassificationR_2 #-} -toResultR2- :: FuncRep2 a b c- -> a- -> Result2 a b c-toResultR2 !frep2 !y = R2 { line2 = y, propertiesF2 = m, transPropertiesF2 = tm}- where !m = getAB frep2 y- !tm = getBC frep2 m+toResultR2 ::+ FuncRep2 a b c ->+ a ->+ Result2 a b c+toResultR2 !frep2 !y = R2{line2 = y, propertiesF2 = m, transPropertiesF2 = tm}+ where+ !m = getAB frep2 y+ !tm = getBC frep2 m {-# INLINE toResultR2 #-} -toPropertiesF'2- :: FuncRep2 a b c- -> a- -> b+toPropertiesF'2 ::+ FuncRep2 a b c ->+ a ->+ b toPropertiesF'2 !frep2 !y = getAB frep2 y {-# INLINE toPropertiesF'2 #-} -toTransPropertiesF'2- :: FuncRep2 a b c- -> a- -> c+toTransPropertiesF'2 ::+ FuncRep2 a b c ->+ a ->+ c toTransPropertiesF'2 !frep2 !y = getAC frep2 y {-# INLINE toTransPropertiesF'2 #-} -- | The second argument must be not empty for the function to work correctly.-partiR2- :: (InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), InsertLeft t2 c) => (c -> Bool)- -> t2 (Result2 a b c)- -> (t2 (Result2 a b c), t2 (Result2 a b c))+partiR2 ::+ (InsertLeft t2 (Result2 a b c), Monoid (t2 (Result2 a b c)), InsertLeft t2 c) =>+ (c -> Bool) ->+ t2 (Result2 a b c) ->+ (t2 (Result2 a b c), t2 (Result2 a b c)) partiR2 p dataR = partitionG (p . transPropertiesF2) dataR {-# INLINE partiR2 #-}-{-# SPECIALIZE partiR2 :: (Eq a, Eq c) => (c -> Bool) -> [Result2 a Double c] -> ([Result2 a Double c], [Result2 a Double c]) #-}-+{-# SPECIALIZE partiR2 ::+ (Eq a, Eq c) =>+ (c -> Bool) ->+ [Result2 a Double c] ->+ ([Result2 a Double c], [Result2 a Double c])+ #-}
Aftovolio/General/Base.hs view
@@ -1,149 +1,169 @@-{-# OPTIONS_HADDOCK show-extensions #-}-{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UnboxedTuples, StrictData #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.General.Base--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ This is a computational scheme for generalized usage of the phonetic languages and AFTOVolio 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 : Aftovolio.General.Base+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +This is a computational scheme for generalized usage of the phonetic languages and AFTOVolio 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 Aftovolio.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+ -- * 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 Data.Either+import Data.List (find, groupBy, intercalate, nub, partition, sortBy, words, (\\))+import Data.Maybe (fromJust, isJust)+import Data.Tuple (fst, snd) import GHC.Arr+import GHC.Base import GHC.Exts+import GHC.Int (Int8 (..))+import GHC.List import GHC.Num ((-))-import Data.Tuple (fst,snd)-import Text.Show (Show(..))+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 }+{- | 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+ 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+ 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 + 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 }+{- | 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+ 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 + 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@@ -168,78 +188,107 @@ fromX2PRPL (PRC xs ys zs _ _) = PR xs ys zs {-# INLINE fromX2PRPL #-} --- | An analogue of the 'rulesPR' function for 'PhoneticsRepresentationPLX'. +-- | 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+ 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).+{- | 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+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. +{- | 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.+{- | 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.+{- | 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 PhoneticRepresentationXInter = Either PhoneticsRepresentationPLX InterGenerationsString+type GWritingSystemPRPLX = [([PhoneticsRepresentationPLX], Generations)] -fromPhoneticRX :: [PhoneticsRepresentationPLX] -> [PhoneticRepresentationXInter] -> [PhoneticsRepresentationPLX]+-- | 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+ 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)]+{- | 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])+{- | 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)+ 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. +{- | 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@@ -247,157 +296,204 @@ (PREmpty xs) ~= (PREmptyC xs1 _ _) = xs1 == xs1 _ ~= _ = False --- | Partial equivalence that is used to find the appropriate 'PhoneticsRepresentationPL' for the class of--- 'PhoneticsRepresentationPLX' values. +{- | 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+ | 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+ | 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+ | 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+ | 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 ::+ (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 #-}+ | 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#)+{-# INLINEABLE 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#)+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+{- | 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 ::+ 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 "Aftovolio.General.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+ | any ((== n) . snd) xs && n > 0 =+ stringToXSGI (xs \\ ts) (n - 1) . xsG zs n $ pss+ | otherwise =+ error+ "Aftovolio.General.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+-- | 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- + | 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+ where+ n = maximum . map snd $ xs+ !ts = concatMap fst . filter ((== 0) . snd) $ xs
Aftovolio/General/Datatype3.hs view
@@ -1,65 +1,84 @@--- |--- Module : Aftovolio.General.Datatype3 --- Copyright : (c) OleksandrZhabenko 2023-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com-+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -funbox-strict-fields #-}-{-# LANGUAGE NoImplicitPrelude, BangPatterns, StrictData #-} +{- |+Module : Aftovolio.General.Datatype3+Copyright : (c) OleksandrZhabenko 2023-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com+-} module Aftovolio.General.Datatype3 (- Read0- , isA- , isB- , isC - , readU2- , readSimple3- , basicSplit- , line2Strings- , read3- , readEq4G - , readEq4 - , zippedDouble2Word8 + Read0,+ isA,+ isB,+ isC,+ readU2,+ readSimple3,+ basicSplit,+ line2Strings,+ read3,+ readEq4G,+ readEq4,+ zippedDouble2Word8, ) where +import Data.Char (isDigit, isLetter, isSpace)+import qualified Data.Foldable as F (foldr)+import Data.List (find, groupBy, maximumBy, minimumBy)+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import qualified Data.Sequence as S+import Data.Tuple (fst, snd) import GHC.Base+import GHC.Float (int2Double) import GHC.List+import GHC.Num ((*), (+), (-))+import GHC.Real (floor, fromIntegral, (/)) import GHC.Word-import GHC.Real (floor,fromIntegral,(/)) -import GHC.Float (int2Double) -import Data.List (groupBy,find,maximumBy,minimumBy)-import Data.Char (isDigit, isSpace,isLetter)+import ListQuantizer (round2GL) import Text.Read (readMaybe)-import Text.Show (Show(..))-import GHC.Num ((*),(+),(-))-import Data.Maybe (fromMaybe)-import Data.Tuple (fst,snd)-import qualified Data.Foldable as F (foldr) -import qualified Data.Sequence as S-import Data.Ord (comparing) -import ListQuantizer (round2GL) +import Text.Show (Show (..)) -- | Is a way to read duration of the additional added time period into the line. readU2 :: String -> Double-readU2 (y:ys) = fromMaybe 1.0 (readMaybe (y:'.':(if null ys then "0" else ys))::Maybe Double)+readU2 (y : ys) = fromMaybe 1.0 (readMaybe (y : '.' : (if null ys then "0" else ys)) :: Maybe Double) readU2 _ = 1.0 {-# INLINE readU2 #-} -- | Splits a 'String' into list of 'String' so that they can be read by other functions here into respective datatypes. splitL0 :: String -> [String]-splitL0 = groupBy (\x y -> (isDigit x && isDigit y) || (x /= '_' && x /= '=' && not (isDigit x) && y /= '_' && y /= '=' && not (isDigit y)) || ((x == '=' || x == '_') && isDigit y))+splitL0 =+ groupBy+ ( \x y ->+ (isDigit x && isDigit y)+ || ( x+ /= '_'+ && x+ /= '='+ && not (isDigit x)+ && y+ /= '_'+ && y+ /= '='+ && not (isDigit y)+ )+ || ((x == '=' || x == '_') && isDigit y)+ ) {-# INLINE splitL0 #-} -data Read0 = A {-# UNPACK #-} !Double | B {-# UNPACK #-} !Double | C String deriving (Eq, Show)+data Read0 = A {-# UNPACK #-} !Double | B {-# UNPACK #-} !Double | C String+ deriving (Eq, Show) -- | Converts a specially formatted 'String' into a 'Read0' value. reRead3 :: String -> Read0-reRead3 xs = - case uncons xs of- Just ('=',ts) -> A (readU2 ts)- Just ('_',ts) -> B (readU2 ts)- _ -> C xs+reRead3 xs =+ case uncons xs of+ Just ('=', ts) -> A (readU2 ts)+ Just ('_', ts) -> B (readU2 ts)+ _ -> C xs isA :: Read0 -> Bool isA (A _) = True@@ -74,9 +93,9 @@ isC _ = False filterReads :: [Read0] -> S.Seq Read0-filterReads xs@(B y:A t:us) = B y S.<| filterReads (dropWhile isA us)-filterReads xs@(A y:A t:us) = A y S.<| filterReads (dropWhile isA us)-filterReads xs@(t:ts) = t S.<| filterReads ts+filterReads xs@(B y : A t : us) = B y S.<| filterReads (dropWhile isA us)+filterReads xs@(A y : A t : us) = A y S.<| filterReads (dropWhile isA us)+filterReads xs@(t : ts) = t S.<| filterReads ts filterReads _ = S.empty -- | A preparatory function for the further ones here.@@ -84,38 +103,44 @@ basicSplit = filterReads . map reRead3 . splitL0 {-# INLINE basicSplit #-} -readSimple3 - :: (String -> Bool) -- ^ A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.- -> Double- -> (String -> [Word8])- -> S.Seq Read0 -- ^ Is should be obtained using 'basicSplit' function here.- -> [Word8]+readSimple3 ::+ -- | A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.+ (String -> Bool) ->+ Double ->+ (String -> [Word8]) ->+ -- | Is should be obtained using 'basicSplit' function here.+ S.Seq Read0 ->+ [Word8] readSimple3 p temp fConvA rs@(C xs S.:<| A x S.:<| ts) -- This branch is fixed in the version 0.6.0.0 because earlier it has an issue.- | null qs = readSimple3 p temp fConvA ts- | null q1 = floor xl1 : readSimple3 p xl1 fConvA ts- | otherwise = q1 `mappend` (floor xl1 : readSimple3 p xl1 fConvA ts)- where qs - | p xs = fConvA xs- | otherwise = []- (q1,q2s) = splitAtEnd 1 qs- ql1 = head q2s- xl1=min (x*word8ToDouble ql1) 255.0-readSimple3 p temp fConvA rs@(C xs S.:<| ys@(B x S.:<| ts)) = qs `mappend` qqs `mappend` readSimple3 p ql fConvA ws - where (!ks, ws) = S.spanl isB ys- !qs - | p xs = fConvA xs- | otherwise = []- !ql- | null qs = 0.0- | otherwise = word8ToDouble . last $ qs- qqs = F.foldr (\(B k) js -> double2Word8 (k * ql):js) [] ks-readSimple3 p temp fConvA rs@(B x S.:<| ts) = qqs `mappend` readSimple3 p temp fConvA ws - where (ks, ws) = S.spanl isB rs- qqs = F.foldr (\(B k) js -> double2Word8 (k * temp) : js) [] ks+ | null qs = readSimple3 p temp fConvA ts+ | null q1 = floor xl1 : readSimple3 p xl1 fConvA ts+ | otherwise = q1 `mappend` (floor xl1 : readSimple3 p xl1 fConvA ts)+ where+ qs+ | p xs = fConvA xs+ | otherwise = []+ (q1, q2s) = splitAtEnd 1 qs+ ql1 = head q2s+ xl1 = min (x * word8ToDouble ql1) 255.0+readSimple3 p temp fConvA rs@(C xs S.:<| ys@(B x S.:<| ts)) = qs `mappend` qqs `mappend` readSimple3 p ql fConvA ws+ where+ (!ks, ws) = S.spanl isB ys+ !qs+ | p xs = fConvA xs+ | otherwise = []+ !ql+ | null qs = 0.0+ | otherwise = word8ToDouble . last $ qs+ qqs = F.foldr (\(B k) js -> double2Word8 (k * ql) : js) [] ks+readSimple3 p temp fConvA rs@(B x S.:<| ts) = qqs `mappend` readSimple3 p temp fConvA ws+ where+ (ks, ws) = S.spanl isB rs+ qqs = F.foldr (\(B k) js -> double2Word8 (k * temp) : js) [] ks readSimple3 p temp fConvA (C xs S.:<| _) = qs- where qs - | p xs = fConvA xs- | otherwise = []+ where+ qs+ | p xs = fConvA xs+ | otherwise = [] readSimple3 _ _ _ _ = [] -- | Is intended to 'floor' the values greater than 255.0 to 255::'Word8' and to be used for non-negative 'Double'.@@ -128,79 +153,93 @@ word8ToDouble = int2Double . fromIntegral {-# INLINE word8ToDouble #-} -read3 - :: (String -> Bool) -- ^ A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.- -> Double- -> (String -> [Word8])- -> String - -> [Word8]+read3 ::+ -- | A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.+ (String -> Bool) ->+ Double ->+ (String -> [Word8]) ->+ String ->+ [Word8] read3 p temp fConvA = filter (/= 0) . readSimple3 p temp fConvA . basicSplit {-# INLINE read3 #-} splitAtEnd :: Int -> [a] -> ([a], [a])-splitAtEnd n = (\(x,y,_) -> (y,x)) . foldr f v- where v = ([],[],0)- f x (zs,ts,k)- | k < n = (x : zs,[],k + 1)- | otherwise = (zs,x : ts,k + 1)+splitAtEnd n = (\(x, y, _) -> (y, x)) . foldr f v+ where+ v = ([], [], 0)+ f x (zs, ts, k)+ | k < n = (x : zs, [], k + 1)+ | otherwise = (zs, x : ts, k + 1) --- | Is a specialized version of 'Data.InsertLeft.dropFromEndG' function variant from the @subG@ package. Is taken from there to--- reduce the dependencies. Is not intended to be exported at all.+{- | Is a specialized version of 'Data.InsertLeft.dropFromEndG' function variant from the @subG@ package. Is taken from there to+reduce the dependencies. Is not intended to be exported at all.+-} dropFromEnd :: Int -> [a] -> [a]-dropFromEnd n = (\(xs,_) -> xs) . foldr f v- where v = ([],0)- f x (zs,k)- | k < n = ([],k + 1)- | otherwise = (x : zs,k)+dropFromEnd n = (\(xs, _) -> xs) . foldr f v+ where+ v = ([], 0)+ f x (zs, k)+ | k < n = ([], k + 1)+ | otherwise = (x : zs, k) -line2Strings - :: (String -> Bool) -- ^ A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.- -> (String -> [String])- -> S.Seq Read0 -- ^ Is should be obtained using 'basicSplit' function here.- -> [String]-line2Strings p gConvC xs@(C ts S.:<| tt@(A x) S.:<| ys) - | null qs = ks `mappend` line2Strings p gConvC ys- | otherwise = ks `mappend` ((ql `mappend` ('=':showRead0AsInsert tt)) : line2Strings p gConvC ys) - where (ks, qs) - | p ts = splitAtEnd 1 . gConvC $ ts - | otherwise = ([],[])- ql = head qs+line2Strings ::+ -- | A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.+ (String -> Bool) ->+ (String -> [String]) ->+ -- | Is should be obtained using 'basicSplit' function here.+ S.Seq Read0 ->+ [String]+line2Strings p gConvC xs@(C ts S.:<| tt@(A x) S.:<| ys)+ | null qs = ks `mappend` line2Strings p gConvC ys+ | otherwise =+ ks+ `mappend` ((ql `mappend` ('=' : showRead0AsInsert tt)) : line2Strings p gConvC ys)+ where+ (ks, qs)+ | p ts = splitAtEnd 1 . gConvC $ ts+ | otherwise = ([], [])+ ql = head qs line2Strings p gConvC xs@(C ys S.:<| ts) = gConvC ys `mappend` line2Strings p gConvC ts line2Strings p gConvC xs@(y@(B x) S.:<| ts) = showRead0AsInsert y : line2Strings p gConvC ts line2Strings _ _ _ = [] -- | Is intended to be used in the "music" mode for AFTOVolio.-readEq4G - :: (String -> Bool) -- ^ A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.- -> (String -> [Word8])- -> (String -> [String])- -> S.Seq Read0 -- ^ Is should be obtained using 'basicSplit' function here.- -> [(String, Word8)]+readEq4G ::+ -- | A special function to check whether the 'String' contains needed information. Must return 'True' for the 'String' that contains the needed for usual processment information, otherwise — 'False'.+ (String -> Bool) ->+ (String -> [Word8]) ->+ (String -> [String]) ->+ -- | Is should be obtained using 'basicSplit' function here.+ S.Seq Read0 ->+ [(String, Word8)] readEq4G p fConvA gConvC xs = zip ks rs- where ks = line2Strings p gConvC xs- rs = filter (/= 0) . readSimple3 p 1.0 fConvA $ xs+ where+ ks = line2Strings p gConvC xs+ rs = filter (/= 0) . readSimple3 p 1.0 fConvA $ xs {-# INLINE readEq4G #-} -readEq4- :: (String -> [Word8])- -> (String -> [String])- -> S.Seq Read0 -- ^ Is should be obtained using 'basicSplit' function here.- -> [(String, Word8)]+readEq4 ::+ (String -> [Word8]) ->+ (String -> [String]) ->+ -- | Is should be obtained using 'basicSplit' function here.+ S.Seq Read0 ->+ [(String, Word8)] readEq4 = readEq4G (not . null . filter (not . isSpace)) {-# INLINE readEq4 #-} showRead0AsInsert :: Read0 -> String-showRead0AsInsert d@(A t) = '=':(filter (/= '.') . show $ t)-showRead0AsInsert d@(B t) = '_':(filter (/= '.') . show $ t)+showRead0AsInsert d@(A t) = '=' : (filter (/= '.') . show $ t)+showRead0AsInsert d@(B t) = '_' : (filter (/= '.') . show $ t) showRead0AsInsert d@(C ts) = ts {-# INLINE showRead0AsInsert #-} --- | Is intended to be used to transform the earlier data for AFTOVolio representations durations from 'Double' to 'Word8' values. It was used during the transition from the ukrainian-phonetics-basic-array-0.7.1.1 to ukrainian-phonetics-basic-array-0.10.0.0. -zippedDouble2Word8 xs = map (\(t, u) -> (t,fromMaybe 15 . hh $ u)) xs - where !h = snd . minimumBy (comparing snd) $ xs- !lt = snd . maximumBy (comparing snd) $ xs- !del = (lt - h)/14.0- !ys = take 15 . iterate (+del) $ h- !zs = zip [1..15] ys- gg !u = fromMaybe lt . round2GL True (\_ _ -> EQ) ys $ u- hh !u = fmap fst . find ((== gg u) . snd) $ zs+-- | Is intended to be used to transform the earlier data for AFTOVolio representations durations from 'Double' to 'Word8' values. It was used during the transition from the ukrainian-phonetics-basic-array-0.7.1.1 to ukrainian-phonetics-basic-array-0.10.0.0.+zippedDouble2Word8 xs = map (\(t, u) -> (t, fromMaybe 15 . hh $ u)) xs+ where+ !h = snd . minimumBy (comparing snd) $ xs+ !lt = snd . maximumBy (comparing snd) $ xs+ !del = (lt - h) / 14.0+ !ys = take 15 . iterate (+ del) $ h+ !zs = zip [1 .. 15] ys+ gg !u = fromMaybe lt . round2GL True (\_ _ -> EQ) ys $ u+ hh !u = fmap fst . find ((== gg u) . snd) $ zs
Aftovolio/General/Distance.hs view
@@ -1,104 +1,130 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-} module Aftovolio.General.Distance where +import Data.List (replicate) import GHC.Base-import GHC.Real (Integral,Fractional(..),Real(..),gcd,quot,(/),fromIntegral,toInteger)-import GHC.Float (Floating(..),sqrt)+import GHC.Float (Floating (..), sqrt)+import GHC.Int import GHC.List-import Data.List (replicate)-import GHC.Num ((*),(-),subtract,abs,Integer)+import GHC.Num (Integer, abs, subtract, (*), (-))+import GHC.Real (+ Fractional (..),+ Integral,+ Real (..),+ fromIntegral,+ gcd,+ quot,+ toInteger,+ (/),+ ) import GHC.Word-import GHC.Int --- | 'toEqLength' changes two given lists into two lists of equal--- minimal lengths and also returs its new length and initial lengths of the lists given.-toEqLength :: [a] -> [a] -> ([a],[a],Int,Int,Int)-toEqLength xs ys - | null xs = ([],[],0,0,0)- | null ys = ([],[],0,0,0)- | otherwise = (ts, vs, lx * ly `quot` dc,lx,ly) - where lx = length xs- ly = length ys- dc = gcd lx ly- ts = concatMap (replicate (ly `quot` dc)) $ xs- vs = concatMap (replicate (lx `quot` dc)) $ ys+{- | 'toEqLength' changes two given lists into two lists of equal+minimal lengths and also returs its new length and initial lengths of the lists given.+-}+toEqLength :: [a] -> [a] -> ([a], [a], Int, Int, Int)+toEqLength xs ys+ | null xs = ([], [], 0, 0, 0)+ | null ys = ([], [], 0, 0, 0)+ | otherwise = (ts, vs, lx * ly `quot` dc, lx, ly)+ where+ lx = length xs+ ly = length ys+ dc = gcd lx ly+ ts = concatMap (replicate (ly `quot` dc)) $ xs+ vs = concatMap (replicate (lx `quot` dc)) $ ys --- | 'toEqLengthL' changes two given lists into two lists of equal--- minimal lengths and also returs its new length and initial lengths of the lists given. Is--- intended to be used when the length of the lists are known and given as the first and the second parameters--- here respectively.-toEqLengthL :: Int -> Int -> [a] -> [a] -> ([a],[a],Int,Int,Int)-toEqLengthL lx ly xs ys - | lx == 0 = ([],[],0,0,0)- | ly == 0 = ([],[],0,0,0)- | otherwise = (ts, vs, lx * ly `quot` dc,lx,ly) - where dc = gcd lx ly- ts = concatMap (replicate (ly `quot` dc)) $ xs- vs = concatMap (replicate (lx `quot` dc)) $ ys+{- | 'toEqLengthL' changes two given lists into two lists of equal+minimal lengths and also returs its new length and initial lengths of the lists given. Is+intended to be used when the length of the lists are known and given as the first and the second parameters+here respectively.+-}+toEqLengthL :: Int -> Int -> [a] -> [a] -> ([a], [a], Int, Int, Int)+toEqLengthL lx ly xs ys+ | lx == 0 = ([], [], 0, 0, 0)+ | ly == 0 = ([], [], 0, 0, 0)+ | otherwise = (ts, vs, lx * ly `quot` dc, lx, ly)+ where+ dc = gcd lx ly+ ts = concatMap (replicate (ly `quot` dc)) $ xs+ vs = concatMap (replicate (lx `quot` dc)) $ ys -- | Is also a simplified distance between the lists. Intended to be used with 'Word8'. sumAbsDistNorm :: (Integral a, Ord a) => [a] -> [a] -> Integer-sumAbsDistNorm xs ys - | lc == 0 = 0- | otherwise = sum . zipWith (\x y -> toInteger (if x > y then x-y else y-x)) ts $ vs- where (ts, vs, lc, lx, ly) = toEqLength xs ys +sumAbsDistNorm xs ys+ | lc == 0 = 0+ | otherwise =+ sum . zipWith (\x y -> toInteger (if x > y then x - y else y - x)) ts $ vs+ where+ (ts, vs, lc, lx, ly) = toEqLength xs ys -- | Intended to be used with 'Compards' of the same constructor in both arguments of the function. Otherwise returns -1. sumAbsDistNormComp :: Compards -> Compards -> Integer-sumAbsDistNormComp x1s@(C1 xs) y1s@(C1 ys) - | lc == 0 = 0- | otherwise = sum . zipWith (\x y -> toInteger (if x > y then x-y else y-x)) ts $ vs- where (ts, vs, lc, lx, ly) = toEqLength xs ys -sumAbsDistNormComp x1s@(C2 xs) y1s@(C2 ys) - | lc == 0 = 0- | otherwise = sum . zipWith (\x y -> toInteger (if x > y then x-y else y-x)) ts $ vs- where (ts, vs, lc, lx, ly) = toEqLength xs ys +sumAbsDistNormComp x1s@(C1 xs) y1s@(C1 ys)+ | lc == 0 = 0+ | otherwise =+ sum . zipWith (\x y -> toInteger (if x > y then x - y else y - x)) ts $ vs+ where+ (ts, vs, lc, lx, ly) = toEqLength xs ys+sumAbsDistNormComp x1s@(C2 xs) y1s@(C2 ys)+ | lc == 0 = 0+ | otherwise =+ sum . zipWith (\x y -> toInteger (if x > y then x - y else y - x)) ts $ vs+ where+ (ts, vs, lc, lx, ly) = toEqLength xs ys sumAbsDistNormComp _ _ = -1 sumSqrDistNorm :: (Real a, Fractional a) => [a] -> [a] -> a-sumSqrDistNorm xs ys - | lc == 0 = 0- | otherwise = sum (zipWith (\x y -> (x - y) * (x - y)) ts vs) / fromIntegral lc- where (ts, vs, lc, lx, ly) = toEqLength xs ys +sumSqrDistNorm xs ys+ | lc == 0 = 0+ | otherwise = sum (zipWith (\x y -> (x - y) * (x - y)) ts vs) / fromIntegral lc+ where+ (ts, vs, lc, lx, ly) = toEqLength xs ys --- | 'distanceSqr' is applied on two lists of non-negative 'Real' numbers (preferably, of type--- 'Double') and returns a special kind of distance that is similar to the statistical distance used--- in the regression analysis. Is intended to be used e. g. for the AFTOVolio approach. The less--- is the resulting number, the more \'similar\' are the two lists of non-negative numbers in their--- distributions. Here, in contrast to the more general 'distanceSqrG', the numbers must be normed--- to 1.0, so that the largest ones in both listn must be 1.0.+{- | 'distanceSqr' is applied on two lists of non-negative 'Real' numbers (preferably, of type+'Double') and returns a special kind of distance that is similar to the statistical distance used+in the regression analysis. Is intended to be used e. g. for the AFTOVolio approach. The less+is the resulting number, the more \'similar\' are the two lists of non-negative numbers in their+distributions. Here, in contrast to the more general 'distanceSqrG', the numbers must be normed+to 1.0, so that the largest ones in both listn must be 1.0.+-} distanceSqr :: (Real a, Floating a, Fractional a) => [a] -> [a] -> a distanceSqr xs ys = sqrt s- where s = sumSqrDistNorm xs ys + where+ s = sumSqrDistNorm xs ys {-# INLINE distanceSqr #-} --- | 'distanceSqrG' is applied on two lists of non-negative 'Real' numbers (preferably, of type--- 'Double') and returns a special kind of distance that is similar to the statistical distance used--- in the regression analysis. Is intended to be used e. g. for the AFTOVolio approach. The less--- is the resulting number, the more \'similar\' are the two lists of non-negative numbers in their--- distributions.+{- | 'distanceSqrG' is applied on two lists of non-negative 'Real' numbers (preferably, of type+'Double') and returns a special kind of distance that is similar to the statistical distance used+in the regression analysis. Is intended to be used e. g. for the AFTOVolio approach. The less+is the resulting number, the more \'similar\' are the two lists of non-negative numbers in their+distributions.+-} distanceSqrG :: (Real a, Floating a, Fractional a) => [a] -> [a] -> a distanceSqrG xs ys = distanceSqr qs rs- where mx = maximum xs- my = maximum ys- qs = map (/ mx) xs- rs = map (/ my) ys+ where+ mx = maximum xs+ my = maximum ys+ qs = map (/ mx) xs+ rs = map (/ my) ys {-# INLINE distanceSqrG #-} --- | 'distanceSqrG2' is an partially optimized variant of the 'distanceSqrG' if length of the least--- common multiplier of the two lists is known and provided as the first argument, besides if it is--- equal to the length of the second argument, and if maximum element of the second argument here is--- equal to 1.0.+{- | 'distanceSqrG2' is an partially optimized variant of the 'distanceSqrG' if length of the least+common multiplier of the two lists is known and provided as the first argument, besides if it is+equal to the length of the second argument, and if maximum element of the second argument here is+equal to 1.0.+-} distanceSqrG2 :: (Real a, Floating a, Fractional a) => Int -> [a] -> [a] -> a distanceSqrG2 lc xs ys = sqrt (sum (zipWith (\x y -> (x - y) * (x - y)) xs qs) / fromIntegral lc)- where my = maximum ys- rs = map (/ my) ys- lr = length rs- dc = lc `quot` lr- qs = concatMap (replicate dc) rs+ where+ my = maximum ys+ rs = map (/ my) ys+ lr = length rs+ dc = lc `quot` lr+ qs = concatMap (replicate dc) rs {-# INLINE distanceSqrG2 #-} data Compards = C1 [Word8] | C2 [Int8] deriving (Eq)@@ -111,29 +137,27 @@ isInt8Based (C2 _) = True isInt8Based _ = False -{-| The elements in the first argument must not be greater than 127 though it is not checked. -}+-- | The elements in the first argument must not be greater than 127 though it is not checked. fromSmallWord8toInt8Diff :: [Word8] -> [Int8]-fromSmallWord8toInt8Diff xs@(_:ys) = zipWith (\t u -> fromIntegral u - fromIntegral t) xs ys+fromSmallWord8toInt8Diff xs@(_ : ys) = zipWith (\t u -> fromIntegral u - fromIntegral t) xs ys fromSmallWord8toInt8Diff [] = [] {-# INLINE fromSmallWord8toInt8Diff #-} class DoubleFunc a b c d where- doubleFunc :: (a -> c) -> (b -> c) -> d -> c+ doubleFunc :: (a -> c) -> (b -> c) -> d -> c instance (DoubleFunc [Word8] [Int8] Int) Compards where- doubleFunc f g (C1 xs) = f xs- doubleFunc f g (C2 ys) = g ys+ doubleFunc f g (C1 xs) = f xs+ doubleFunc f g (C2 ys) = g ys instance (DoubleFunc [Word8] [Int8] Compards) Compards where- doubleFunc f g (C1 xs) = f xs- doubleFunc f g (C2 ys) = g ys+ doubleFunc f g (C1 xs) = f xs+ doubleFunc f g (C2 ys) = g ys instance (DoubleFunc [Word8] [Int8] Bool) Compards where- doubleFunc f g (C1 xs) = f xs- doubleFunc f g (C2 ys) = g ys+ doubleFunc f g (C1 xs) = f xs+ doubleFunc f g (C2 ys) = g ys instance (DoubleFunc [Word8] [Int8] Integer) Compards where- doubleFunc f g (C1 xs) = f xs- doubleFunc f g (C2 ys) = g ys--+ doubleFunc f g (C1 xs) = f xs+ doubleFunc f g (C2 ys) = g ys
Aftovolio/General/Parsing.hs view
@@ -1,59 +1,61 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -threaded -rtsopts #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} --- |--- Module : Aftovolio.General.Parsing--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ The additional parsing library functions for the AFTOVolio both old and new variants.--- Is taken from the Phonetic.Languages.Parsing module from the--- @phonetic-languages-simplified-examples-array@ package to reduce dependencies in general case.--- +{- |+Module : Aftovolio.General.Parsing+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +The additional parsing library functions for the AFTOVolio both old and new variants.+Is taken from the Phonetic.Languages.Parsing module from the+@phonetic-languages-simplified-examples-array@ package to reduce dependencies in general case.+-} module Aftovolio.General.Parsing (- -- * Predicates- isClosingCurlyBracket- , isSlash- , isOpeningCurlyBracket- , variations- -- * Transformations- , breakGroupOfStrings- , breakInSlashes- , combineVariants- , combineHeadsWithNexts- , transformToVariations- -- * Files processment for specifications- , readLangSpecs - , innerProcessmentSimple- , argsProcessment+ -- * Predicates+ isClosingCurlyBracket,+ isSlash,+ isOpeningCurlyBracket,+ variations,++ -- * Transformations+ breakGroupOfStrings,+ breakInSlashes,+ combineVariants,+ combineHeadsWithNexts,+ transformToVariations,++ -- * Files processment for specifications+ readLangSpecs,+ innerProcessmentSimple,+ argsProcessment, ) where +import Aftovolio.General.Base+import Aftovolio.General.PrepareText+import Aftovolio.General.SpecificationsRead+import Aftovolio.General.Syllables+import Data.List (lines, sort, unwords)+import Data.Maybe (fromMaybe)+import GHC.Arr import GHC.Base import GHC.List-import Aftovolio.General.PrepareText import System.Environment (getArgs) import System.IO (FilePath, readFile)-import Data.List (sort,lines,unwords)-import GHC.Arr-import Aftovolio.General.Base-import Aftovolio.General.Syllables-import Text.Read (readMaybe,read)-import Data.Maybe (fromMaybe)-import Aftovolio.General.SpecificationsRead+import Text.Read (read, readMaybe) isClosingCurlyBracket :: String -> Bool isClosingCurlyBracket = (== "}") {-# INLINE isClosingCurlyBracket #-} isSlash :: String -> Bool-isSlash (x:xs)- | x /= '/' = False- | null xs = True- | otherwise = False+isSlash (x : xs)+ | x /= '/' = False+ | null xs = True+ | otherwise = False isSlash _ = False {-# INLINE isSlash #-} @@ -61,83 +63,153 @@ isOpeningCurlyBracket = (== "{") {-# INLINE isOpeningCurlyBracket #-} -breakGroupOfStrings :: [String] -> (([String],[[String]]),[String])-breakGroupOfStrings !xss = ((tss,breakInSlashes uss []), drop 1 zss)- where (!yss,!zss) = break isClosingCurlyBracket xss- (!tss,!uss) = (\(t1,t2) -> (t1,drop 1 t2)) . break isOpeningCurlyBracket $ yss+breakGroupOfStrings :: [String] -> (([String], [[String]]), [String])+breakGroupOfStrings !xss = ((tss, breakInSlashes uss []), drop 1 zss)+ where+ (!yss, !zss) = break isClosingCurlyBracket xss+ (!tss, !uss) = (\(t1, t2) -> (t1, drop 1 t2)) . break isOpeningCurlyBracket $ yss {-# INLINE breakGroupOfStrings #-} breakInSlashes :: [String] -> [[String]] -> [[String]] breakInSlashes !wss !usss- | null lss = kss : usss- | otherwise = breakInSlashes (drop 1 lss) (kss : usss)- where (!kss,!lss) = break isSlash wss+ | null lss = kss : usss+ | otherwise = breakInSlashes (drop 1 lss) (kss : usss)+ where+ (!kss, !lss) = break isSlash wss -combineVariants :: ([String],[[String]]) -> [[String]]-combineVariants (!xss, (!yss:ysss)) = (xss `mappend` yss) : combineVariants (xss, ysss)+combineVariants :: ([String], [[String]]) -> [[String]]+combineVariants (!xss, (!yss : ysss)) = (xss `mappend` yss) : combineVariants (xss, ysss) combineVariants _ = [] combineHeadsWithNexts :: [[String]] -> [String] -> [[String]] combineHeadsWithNexts !xsss !yss- | null yss = xsss- | otherwise = combineHeadsWithNexts [xss `mappend` zss | xss <- xsss, zss <- zsss] uss- where (!t,!uss) = breakGroupOfStrings yss- !zsss = combineVariants t+ | null yss = xsss+ | otherwise =+ combineHeadsWithNexts [xss `mappend` zss | xss <- xsss, zss <- zsss] uss+ where+ (!t, !uss) = breakGroupOfStrings yss+ !zsss = combineVariants t transformToVariations :: [String] -> [[String]] transformToVariations !yss- | null yss = []- | otherwise = combineHeadsWithNexts xsss tss- where (!y,!tss) = breakGroupOfStrings yss- !xsss = combineVariants y+ | null yss = []+ | otherwise = combineHeadsWithNexts xsss tss+ where+ (!y, !tss) = breakGroupOfStrings yss+ !xsss = combineVariants y {-# INLINE transformToVariations #-} variations :: [String] -> Bool-variations xss = any isSlash xss && any isOpeningCurlyBracket xss && any isClosingCurlyBracket xss+variations xss =+ any isSlash xss+ && any isOpeningCurlyBracket xss+ && any isClosingCurlyBracket xss {-# INLINE variations #-} -innerProcessmentSimple- :: String -- ^ Must be a valid 'GWritingSystemPRPLX' specifications 'String' representation only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);- -> String -- ^ Must be a 'String' with the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;- -> String -- ^ Must be a 'String' with the 'SegmentRulesG' specifications only;- -> String -- ^ Must be a 'String' with the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.- -> String -- ^ Must be a 'String' with the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.- -> (GWritingSystemPRPLX, [(Char, Char)], CharPhoneticClassification, SegmentRulesG, String, String, Concatenations, Concatenations, String)+innerProcessmentSimple ::+ -- | Must be a valid 'GWritingSystemPRPLX' specifications 'String' representation only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);+ String ->+ -- | Must be a 'String' with the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;+ String ->+ -- | Must be a 'String' with the 'SegmentRulesG' specifications only;+ String ->+ -- | Must be a 'String' with the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.+ String ->+ -- | Must be a 'String' with the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.+ String ->+ ( GWritingSystemPRPLX+ , [(Char, Char)]+ , CharPhoneticClassification+ , SegmentRulesG+ , String+ , String+ , Concatenations+ , Concatenations+ , String+ ) innerProcessmentSimple gwrsCnts controlConts segmentData concatenationsFileP concatenationsFileA =- let [allophonesGs, charClfs, jss, vss, wss] = groupBetweenChars '~' . lines $ controlConts- wrs = getGWritingSystem '~' gwrsCnts- ks = sort . fromMaybe [] $ (readMaybe (unwords allophonesGs)::Maybe [(Char, Char)])- arr = read (unwords charClfs)::Array Int PRS -- The 'Array' must be previously sorted in the ascending order.- gs = read segmentData::SegmentRulesG- ysss = sort2Concat . fromMaybe [] $ (readMaybe concatenationsFileP::Maybe [[String]])- zzzsss = sort2Concat . fromMaybe [] $ (readMaybe concatenationsFileA::Maybe [[String]])- js = concat jss- vs = concat vss- ws = sort . concat $ wss- in (wrs, ks, arr, gs, js, vs, ysss, zzzsss, ws)+ let [allophonesGs, charClfs, jss, vss, wss] = groupBetweenChars '~' . lines $ controlConts+ wrs = getGWritingSystem '~' gwrsCnts+ ks =+ sort . fromMaybe [] $ (readMaybe (unwords allophonesGs) :: Maybe [(Char, Char)])+ arr = read (unwords charClfs) :: Array Int PRS -- The 'Array' must be previously sorted in the ascending order.+ gs = read segmentData :: SegmentRulesG+ ysss =+ sort2Concat . fromMaybe [] $ (readMaybe concatenationsFileP :: Maybe [[String]])+ zzzsss =+ sort2Concat . fromMaybe [] $ (readMaybe concatenationsFileA :: Maybe [[String]])+ js = concat jss+ vs = concat vss+ ws = sort . concat $ wss+ in (wrs, ks, arr, gs, js, vs, ysss, zzzsss, ws) {-# INLINE innerProcessmentSimple #-} -{-| -}-argsProcessment- :: FilePath -- ^ With the 'GWritingSystemPRPLX' specifications only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);- -> FilePath -- ^ With the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;- -> FilePath -- ^ With the 'SegmentRulesG' specifications only;- -> FilePath -- ^ With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.- -> FilePath -- ^ With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.- -> IO [String]-argsProcessment fileGWrSys controlFile segmentRulesFile concatenationsFileP concatenationsFileA = mapM readFile [controlFile, fileGWrSys, segmentRulesFile, concatenationsFileP, concatenationsFileA]+argsProcessment ::+ -- | With the 'GWritingSystemPRPLX' specifications only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);+ FilePath ->+ -- | With the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;+ FilePath ->+ -- | With the 'SegmentRulesG' specifications only;+ FilePath ->+ -- | With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.+ FilePath ->+ -- | With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.+ FilePath ->+ IO [String]+argsProcessment fileGWrSys controlFile segmentRulesFile concatenationsFileP concatenationsFileA =+ mapM+ readFile+ [ controlFile+ , fileGWrSys+ , segmentRulesFile+ , concatenationsFileP+ , concatenationsFileA+ ] {-# INLINE argsProcessment #-} --- | The function that is mostly intended to be used by the end user. Reads the specifications from--- the5 given files and returns the data that can be used further for generalized AFTOVolio.-readLangSpecs - :: FilePath -- ^ With the 'GWritingSystemPRPLX' specifications only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);- -> FilePath -- ^ With the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;- -> FilePath -- ^ With the 'SegmentRulesG' specifications only;- -> FilePath -- ^ With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.- -> FilePath -- ^ With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.- -> IO (GWritingSystemPRPLX, [(Char, Char)], CharPhoneticClassification, SegmentRulesG, String, String, Concatenations, Concatenations, String)-readLangSpecs fileGWrSys controlFile segmentRulesFile concatenationsFileP concatenationsFileA = - argsProcessment fileGWrSys controlFile segmentRulesFile concatenationsFileP concatenationsFileA >>= \xss -> let [controlConts, gwrsCnts, segmentData, concatenationsFileP1, concatenationsFileA1] = xss in return $ innerProcessmentSimple gwrsCnts controlConts segmentData concatenationsFileP1 concatenationsFileA1 +{- | The function that is mostly intended to be used by the end user. Reads the specifications from+the5 given files and returns the data that can be used further for generalized AFTOVolio.+-}+readLangSpecs ::+ -- | With the 'GWritingSystemPRPLX' specifications only (see the gwrsysExample.txt file in the @phonetic-languages-phonetics-basics@ package as a schema);+ FilePath ->+ -- | With the 5 meaningful lines that are delimited with the \'~\' line one from another with the specifications for the possible allophones (if any), 'CharPhoneticClassification', white spaces information (two 'String's) and the 'String' of all the possible 'PLL' 'Char's;+ FilePath ->+ -- | With the 'SegmentRulesG' specifications only;+ FilePath ->+ -- | With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be prepended to the next word.+ FilePath ->+ -- | With the 'Concatenations' specifications only (see the data in the EnglishConcatenated.txt file in the @phonetic-languages-phonetics-basics@ package as a list of English equivalents of the needed 'String's). These are to be appended to the previous word.+ FilePath ->+ IO+ ( GWritingSystemPRPLX+ , [(Char, Char)]+ , CharPhoneticClassification+ , SegmentRulesG+ , String+ , String+ , Concatenations+ , Concatenations+ , String+ )+readLangSpecs fileGWrSys controlFile segmentRulesFile concatenationsFileP concatenationsFileA =+ argsProcessment+ fileGWrSys+ controlFile+ segmentRulesFile+ concatenationsFileP+ concatenationsFileA >>= \xss ->+ let [ controlConts+ , gwrsCnts+ , segmentData+ , concatenationsFileP1+ , concatenationsFileA1+ ] = xss+ in return $+ innerProcessmentSimple+ gwrsCnts+ controlConts+ segmentData+ concatenationsFileP1+ concatenationsFileA1 {-# INLINE readLangSpecs #-}-
Aftovolio/General/Simple.hs view
@@ -1,378 +1,695 @@-{-# LANGUAGE NoImplicitPrelude, BangPatterns, DeriveGeneric, StrictData #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} module Aftovolio.General.Simple where -import GHC.Base-import GHC.Enum (fromEnum)-import GHC.Real (Integral,fromIntegral,(/),quot,rem,quotRem,round,gcd,(^))-import GHC.Word-import GHC.Generics-import Text.Show (Show(..))-import Aftovolio.General.PrepareText -import Aftovolio.General.Syllables +import Aftovolio.ConstraintsEncoded import Aftovolio.General.Base-import System.Environment (getArgs)-import GHC.Num (Num,(+),(-),(*),Integer)-import Text.Read (readMaybe)-import System.IO (putStrLn, FilePath,stdout,universalNewlineMode,hSetNewlineMode,getLine,appendFile,readFile,writeFile,putStr)-import Rhythmicity.MarkerSeqs hiding (id) -import Data.List hiding (foldr,null)-import qualified Data.List as L (null)-import Data.Ord (Down(..))-import Data.Maybe (fromMaybe, mapMaybe, catMaybes,isNothing,fromJust) -import Data.Tuple (fst)-import Data.Char (isDigit,isSpace)+import Aftovolio.General.Datatype3+import Aftovolio.General.Distance+import Aftovolio.General.PrepareText+import Aftovolio.General.Syllables+import Aftovolio.Halfsplit+import Aftovolio.PermutationsArr+import Aftovolio.StrictVG+import Aftovolio.Tests+import Aftovolio.UniquenessPeriodsG import CLI.Arguments import CLI.Arguments.Get import CLI.Arguments.Parsing-import Data.Ord (comparing)+import Control.Concurrent.Async (mapConcurrently)+import Control.DeepSeq+import Data.Char (isDigit, isSpace)+import Data.ChooseLine2+import Data.List hiding (foldr, null)+import qualified Data.List as L (null)+import Data.Maybe (catMaybes, fromJust, fromMaybe, isNothing, mapMaybe)+import Data.MinMax1 (minMax11By)+import Data.Ord (Down (..), comparing)+import Data.ReversedScientific+import Data.Tuple (fst)+import GHC.Base+import GHC.Enum (fromEnum)+import GHC.Generics import GHC.Int (Int8)+import GHC.Num (Integer, Num, (*), (+), (-))+import GHC.Real (Integral, fromIntegral, gcd, quot, quotRem, rem, round, (/), (^))+import GHC.Word import GHC.Word (Word8)-import Aftovolio.ConstraintsEncoded-import Aftovolio.PermutationsArr-import Aftovolio.StrictVG import Numeric (showFFloat)-import Aftovolio.Halfsplit-import System.Directory (doesFileExist,readable,writable,getPermissions,Permissions(..),doesFileExist,getCurrentDirectory)-import Data.ReversedScientific-import Control.Concurrent.Async (mapConcurrently)-import Data.MinMax1 (minMax11By) -import Aftovolio.Tests-import Aftovolio.General.Datatype3-import Aftovolio.General.Distance-import Aftovolio.UniquenessPeriodsG-import Data.ChooseLine2-import Control.DeepSeq+import Rhythmicity.MarkerSeqs hiding (id)+import System.Directory (+ Permissions (..),+ doesFileExist,+ getCurrentDirectory,+ getPermissions,+ readable,+ writable,+ )+import System.Environment (getArgs)+import System.IO (+ FilePath,+ appendFile,+ getLine,+ hSetNewlineMode,+ putStr,+ putStrLn,+ readFile,+ stdout,+ universalNewlineMode,+ writeFile,+ )+import Text.Read (readMaybe)+import Text.Show (Show (..)) -generalF - :: Int -- ^ A power of 10. The resulting distance using next ['Word8'] argument is quoted by 10 in this power. The default one is 0. The proper values are in the range [0..4].- -> Int -- ^ A 'length' of the next argument here.- -> Compards -- ^ A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.- -> Bool -- ^ If 'True' then adds \"<br>\" to line endings for double column output- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> FilePath -- ^ A path to the file to save double columns output to. If empty then just prints to 'stdout'.- -> String -- ^ If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'- -> (String -> String) -- ^ A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#selectSounds. Use just small 'Char' if they are letters, do not use \'.\' and spaces.- -> (String, String) -- ^ If the next element is not equal to -1, then the prepending and appending lines to be displayed. Used basically for working with the multiline textual input data.- -> Int -- ^ The number of the line in the file to be read the lines from. If equal to -1 then neither reading from the file is done nor the first argument influences the processment results.- -> 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.- -> ([[[PRS]]] -> [[Word8]]) -- ^ Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].- -> Int- -> HashCorrections - -> (Int8,[Int8])- -> Bool- -> Int -- ^ The hashing function step. The default value is 20. Is expected to be greater than 2, and better greater than 12. - -> Bool - -> Int8- -> (FilePath, Int)- -> Bool -- ^ In the testing mode, whether to execute computations in concurrent mode (for speed up) or in single thread. If specified needs the executable to be compiled with -rtsopts and -threaded options and run with the command line +RTS -N -RTS options.- -> String -- ^ An initial string to be analyzed.- -> [String] - -> IO [String] -generalF power10 ldc compards html filtering dcfile selStr selFun (prestr,poststr) lineNmb wrs ks arr gs us vs h numTest hc (grps,mxms) descending hashStep emptyline splitting (fs, code) concurrently initstr universalSet - | L.null universalSet = do- let strOutput = ["You have specified the data and constraints on it that lead to no further possible options.", "Please, specify another data and constraints."] - putStrLn . unlines $ strOutput- return strOutput- | length universalSet == 1 = do- putStrLn . unlines $ universalSet- return universalSet- | otherwise = do- let syllN = countSyll wrs arr us vs initstr- f ldc compards grps mxms - | L.null selStr = (if doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]->Bool) compards then (sum . countHashes2G hashStep hc grps mxms) else (`quot` 10^power10) . fromIntegral . sumAbsDistNormComp compards . (if isWord8Based compards then C1 else C2 . fromSmallWord8toInt8Diff)) . read3 (not . L.null . filter (not . isSpace)) 1.0 (mconcat . h . createSyllablesPL wrs ks arr gs us vs)- | otherwise = fromIntegral . diverse2GGL (selectSounds selFun selStr) (us `mappend` vs) . concatMap string1 . stringToXG wrs . filter (\c -> not (isDigit c) && c /= '_' && c /= '=')- hSetNewlineMode stdout universalNewlineMode- if numTest >= 0 && numTest <= 179 && numTest /= 1 && doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]->Bool) compards then testsOutput concurrently syllN filtering f ldc numTest universalSet - else let sRepresent = zipWith (\k (x, ys) -> S k x ys) [1..] . - (if descending then sortOn (\(u,w) -> (Down u,w)) else sortOn id) . map (\xss -> (f ldc compards grps mxms xss, xss)) $ universalSet- strOutput = force . (:[]) . halfsplit1G (\(S _ y _) -> y) filtering (if html then "<br>" else "") (jjj splitting) $ sRepresent- lns1 = unlines strOutput- in do- putStrLn lns1- if L.null dcfile then putStr "" - else do - doesFileExist dcfile >>= \exist -> if exist then do - getPermissions dcfile >>= \perms -> if writable perms then writeFile dcfile lns1 - else error $ "Aftovolio.General.IO.generalF: File " `mappend` dcfile `mappend` " is not writable!" - else do - getCurrentDirectory >>= \currdir -> do - getPermissions currdir >>= \perms -> if writable perms then writeFile dcfile lns1 - else error $ "Aftovolio.General.IO.generalF: Directory of the file " `mappend` dcfile `mappend` " is not writable!"- let l1 = length sRepresent- if code == -1 - then if lineNmb == -1 then return strOutput- else do - print23 filtering prestr poststr 1 [initstr]- return strOutput- else do - print23 filtering prestr poststr 1 [initstr]- parseLineNumber l1 >>= \num -> do- permiss <- getPermissions fs- let writ = writable permiss- readab = readable permiss- if writ && readab then outputWithFile h wrs ks arr gs us vs selStr compards sRepresent code grps fs num- else error "The specified file cannot be used for appending the text! Please, specify another file!"- return []- where jjj kk = let (q1,r1) = quotRem kk (if kk < 0 then -10 else 10) in jjj' q1 r1 emptyline- jjj' q1 r1 emptyline- | r1 == (-1) || r1 == (-3) = -10*q1 + (if emptyline then -5 else r1)- | r1 == 1 || r1 == 3 = 10*q1 + (if emptyline then 5 else r1)- | r1 < 0 = -10*q1 + (if emptyline then -4 else r1)- | otherwise = 10*q1 + (if emptyline then 4 else r1)+generalF ::+ -- | A power of 10. The resulting distance using next ['Word8'] argument is quoted by 10 in this power. The default one is 0. The proper values are in the range [0..4].+ Int ->+ -- | A 'length' of the next argument here.+ Int ->+ -- | A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.+ Compards ->+ -- | If 'True' then adds \"<br>\" to line endings for double column output+ Bool ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ -- | A path to the file to save double columns output to. If empty then just prints to 'stdout'.+ FilePath ->+ -- | If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'+ String ->+ -- | A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#selectSounds. Use just small 'Char' if they are letters, do not use \'.\' and spaces.+ (String -> String) ->+ -- | If the next element is not equal to -1, then the prepending and appending lines to be displayed. Used basically for working with the multiline textual input data.+ (String, String) ->+ -- | The number of the line in the file to be read the lines from. If equal to -1 then neither reading from the file is done nor the first argument influences the processment results.+ Int ->+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ -- | 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.+ [(Char, Char)] ->+ CharPhoneticClassification ->+ SegmentRulesG ->+ -- | 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 ->+ -- | Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].+ ([[[PRS]]] -> [[Word8]]) ->+ Int ->+ HashCorrections ->+ (Int8, [Int8]) ->+ -- | The hashing function step. The default value is 20. Is expected to be greater than 2, and better greater than 12.+ Int ->+ Bool ->+ Int8 ->+ (FilePath, Int) ->+ -- | In the testing mode, whether to execute computations in concurrent mode (for speed up) or in single thread. If specified needs the executable to be compiled with -rtsopts and -threaded options and run with the command line +RTS -N -RTS options.+ Bool ->+ -- | An initial string to be analyzed.+ String ->+ [String] ->+ IO [String]+generalF power10 ldc compards html filtering dcfile selStr selFun (prestr, poststr) lineNmb wrs ks arr gs us vs h numTest hc (grps, mxms) hashStep emptyline splitting (fs, code) concurrently initstr universalSet+ | L.null universalSet = do+ let strOutput =+ [ "You have specified the data and constraints on it that lead to no further possible options."+ , "Please, specify another data and constraints."+ ]+ putStrLn . unlines $ strOutput+ return strOutput+ | length universalSet == 1 = do+ putStrLn . unlines $ universalSet+ return universalSet+ | otherwise = do+ let syllN = countSyll wrs arr us vs initstr+ f ldc compards grps mxms+ | L.null selStr =+ ( if doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ then (sum . countHashes2G hashStep hc grps mxms)+ else+ (`quot` 10 ^ power10)+ . fromIntegral+ . sumAbsDistNormComp compards+ . (if isWord8Based compards then C1 else C2 . fromSmallWord8toInt8Diff)+ )+ . read3+ (not . L.null . filter (not . isSpace))+ 1.0+ (mconcat . h . createSyllablesPL wrs ks arr gs us vs)+ | otherwise =+ fromIntegral+ . diverse2GGL (selectSounds selFun selStr) (us `mappend` vs)+ . concatMap string1+ . stringToXG wrs+ . filter (\c -> not (isDigit c) && c /= '_' && c /= '=')+ hSetNewlineMode stdout universalNewlineMode+ if numTest+ >= 0+ && numTest+ <= 179+ && numTest+ /= 1+ && doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ then testsOutput concurrently syllN filtering f ldc numTest universalSet+ else+ let sRepresent =+ zipWith (\k (x, ys) -> S k x ys) [1 ..]+ . sortOn id+ . map (\xss -> (f ldc compards grps mxms xss, xss))+ $ universalSet+ strOutput =+ force+ . (: [])+ . halfsplit1G+ (\(S _ y _) -> y)+ filtering+ (if html then "<br>" else "")+ (jjj splitting) $+ sRepresent+ lns1 = unlines strOutput+ in do+ putStrLn lns1+ if L.null dcfile+ then putStr ""+ else do+ doesFileExist dcfile >>= \exist ->+ if exist+ then do+ getPermissions dcfile >>= \perms ->+ if writable perms+ then writeFile dcfile lns1+ else+ error $+ "Aftovolio.General.IO.generalF: File "+ `mappend` dcfile+ `mappend` " is not writable!"+ else do+ getCurrentDirectory >>= \currdir -> do+ getPermissions currdir >>= \perms ->+ if writable perms+ then writeFile dcfile lns1+ else+ error $+ "Aftovolio.General.IO.generalF: Directory of the file "+ `mappend` dcfile+ `mappend` " is not writable!"+ let l1 = length sRepresent+ if code == -1+ then+ if lineNmb == -1+ then return strOutput+ else do+ print23 filtering prestr poststr 1 [initstr]+ return strOutput+ else do+ print23 filtering prestr poststr 1 [initstr]+ parseLineNumber l1 >>= \num -> do+ permiss <- getPermissions fs+ let writ = writable permiss+ readab = readable permiss+ if writ && readab+ then outputWithFile h wrs ks arr gs us vs selStr compards sRepresent code grps fs num+ else+ error+ "The specified file cannot be used for appending the text! Please, specify another file!"+ return []+ where+ jjj kk = let (q1, r1) = quotRem kk (if kk < 0 then -10 else 10) in jjj' q1 r1 emptyline+ jjj' q1 r1 emptyline+ | r1 == (-1) || r1 == (-3) = -10 * q1 + (if emptyline then -5 else r1)+ | r1 == 1 || r1 == 3 = 10 * q1 + (if emptyline then 5 else r1)+ | r1 < 0 = -10 * q1 + (if emptyline then -4 else r1)+ | otherwise = 10 * q1 + (if emptyline then 4 else r1) data AftovolioGen = S Int Integer String deriving (Eq, Generic) instance Show AftovolioGen where- show (S i j xs) = showBignum 7 j `mappend` " " `mappend` xs `mappend` " " `mappend` showWithSpaces 4 i+ show (S i j xs) =+ showBignum 7 j+ `mappend` " "+ `mappend` xs+ `mappend` " "+ `mappend` showWithSpaces 4 i instance NFData AftovolioGen -countSyll - :: GWritingSystemPRPLX -- ^ Data used to obtain the phonetic language representation of the text.- -> CharPhoneticClassification - -> 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 - -> Int-countSyll wrs arr us vs xs = numUnderscoresSyll + (fromEnum . foldr (\x y -> if createsSyllable x then y + 1 else y) 0 . concatMap (str2PRSs arr) . words1 . mapMaybe g . concatMap string1 . stringToXG wrs $ xs)- where numUnderscoresSyll = length . filter (\xs -> let (ys,ts) = splitAt 1 xs in ys == "_" && all isDigit ts && not (L.null ts)) . groupBy (\x y -> x=='_' && isDigit y) $ xs- g :: Char -> Maybe Char- g x- | x `elem` us = Nothing- | x `notElem` vs = Just x- | otherwise = Just ' '- words1 xs = if L.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 #-}+countSyll ::+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ CharPhoneticClassification ->+ -- | 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 ->+ String ->+ Int+countSyll wrs arr us vs xs =+ numUnderscoresSyll+ + ( fromEnum+ . foldr (\x y -> if createsSyllable x then y + 1 else y) 0+ . concatMap (str2PRSs arr)+ . words1+ . mapMaybe g+ . concatMap string1+ . stringToXG wrs $+ xs+ )+ where+ numUnderscoresSyll =+ length+ . filter+ ( \xs -> let (ys, ts) = splitAt 1 xs in ys == "_" && all isDigit ts && not (L.null ts)+ )+ . groupBy (\x y -> x == '_' && isDigit y) $+ xs+ g :: Char -> Maybe Char+ g x+ | x `elem` us = Nothing+ | x `notElem` vs = Just x+ | otherwise = Just ' '+ words1 xs = if L.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 #-} -stat1 :: Int -> (Int8,[Int8]) -> Int+stat1 :: Int -> (Int8, [Int8]) -> Int stat1 n (k, ks) = fst (n `quotRemInt` fromEnum k) * length ks outputSel :: AftovolioGen -> Int -> String outputSel (S x1 y1 ts) code- | code < 0 = []- | code == 1 || code == 11 || code == 16 = intercalate " " [show x1, ts] `mappend` "\n"- | code == 2 || code == 12 || code == 17 = intercalate " " [show y1, ts] `mappend` "\n"- | code == 3 || code == 13 || code == 18 = intercalate " " [show x1, ts, show y1] `mappend` "\n"- | code == 4 || code == 14 || code == 19 = intercalate " " [show x1, show y1] `mappend` "\n"- | otherwise = ts `mappend` "\n"+ | code < 0 = []+ | code == 1 || code == 11 || code == 16 =+ intercalate " " [show x1, ts] `mappend` "\n"+ | code == 2 || code == 12 || code == 17 =+ intercalate " " [show y1, ts] `mappend` "\n"+ | code == 3 || code == 13 || code == 18 =+ intercalate " " [show x1, ts, show y1] `mappend` "\n"+ | code == 4 || code == 14 || code == 19 =+ intercalate " " [show x1, show y1] `mappend` "\n"+ | otherwise = ts `mappend` "\n" parseLineNumber :: Int -> IO Int-parseLineNumber l1 = do - putStrLn "Please, specify the number of the option to be written to the file specified: "- number <- getLine- let num = readMaybe (filter isDigit number)::Maybe Int- if isNothing num || num > Just l1 || num == Just 0 - then parseLineNumber l1 - else return . fromJust $ num+parseLineNumber l1 = do+ putStrLn+ "Please, specify the number of the option to be written to the file specified: "+ number <- getLine+ let num = readMaybe (filter isDigit number) :: Maybe Int+ if isNothing num || num > Just l1 || num == Just 0+ then parseLineNumber l1+ else return . fromJust $ num -{-| Uses 'getArgs' inside to get the needed data from the command line arguments. Use with this in- mind. +{- | Uses 'getArgs' inside to get the needed data from the command line arguments. Use with this in+ mind. -}-argsProcessing- :: 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.- -> ([[[PRS]]] -> [[Word8]]) -- ^ Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].- -> [[String]]- -> [[String]]- -> String - -> IO (Int, Int, Compards, Bool, Bool, FilePath, String, String, String, Int, Bool, Int8, FilePath, Int, Bool, String, [String]) -- ^ These ones are intended to be used inside 'generalF'.+argsProcessing ::+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ -- | 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.+ [(Char, Char)] ->+ CharPhoneticClassification ->+ SegmentRulesG ->+ -- | 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 ->+ -- | Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].+ ([[[PRS]]] -> [[Word8]]) ->+ [[String]] ->+ [[String]] ->+ String ->+ -- | These ones are intended to be used inside 'generalF'.+ IO+ ( Int+ , Int+ , Compards+ , Bool+ , Bool+ , FilePath+ , String+ , String+ , String+ , Int+ , Bool+ , Int8+ , FilePath+ , Int+ , Bool+ , String+ , [String]+ ) argsProcessing wrs ks arr gs us vs h ysss zsss xs = do- args0 <- getArgs- let (argsC, args) = takeCs1R ('+','-') cSpecs args0- (argsB, args11) = takeBsR bSpecs args- compareByLinesFinalFile = concat . getB "-cm" $ argsB- if not . L.null $ compareByLinesFinalFile then do- compareFilesToOneCommon 14 args11 compareByLinesFinalFile- return (0,0,(C1 []),False,False,[],[],[],[],0,False,0,[],0,False,[],[]) - else do- let prepare = any (== "-p") args11- emptyline = any (== "+l") args11 - splitting = fromMaybe 50 (readMaybe (concat . getB "+w" $ argsB)::Maybe Int8) - concurrently = any (== "-C") args11- filtering = any (== "-e") args11- dcspecs = getB "+dc" argsB- (html,dcfile) - | L.null dcspecs = (False, "")- | otherwise = (head dcspecs == "1",last dcspecs)- selStr = concat . getB "+ul" $ argsB- filedata = getB "+f" argsB- power10' = fromMaybe 0 (readMaybe (concat . getB "+q" $ argsB)::Maybe Int)- power10 - | power10' < 0 && power10' > 4 = 0- | otherwise = power10'- (multiline2, multiline2LineNum)- | oneB "+m3" argsB =- let r1ss = getB "+m3" argsB in- if length r1ss == 3- then let (kss,qss) = splitAt 2 r1ss in- (kss, max 1 (fromMaybe 1 (readMaybe (concat qss)::Maybe Int)))- else (r1ss, 1)- | oneB "+m2" argsB = (getB "+m" argsB, max 1 (fromMaybe 1 (readMaybe (concat . getB "+m2" $ argsB)::Maybe Int)))- | otherwise = (getB "+m" argsB, -1)- (fileread,lineNmb)- | L.null multiline2 = ("",-1)- | length multiline2 == 2 = (head multiline2, fromMaybe 1 (readMaybe (last multiline2)::Maybe Int))- | otherwise = (head multiline2, 1)- (arg3s,prestr,poststr,linecomp3) <- do- if lineNmb /= -1 then do- txtFromFile <- readFile fileread- let lns = lines txtFromFile- ll1 = length lns- ln0 = max 1 (min lineNmb (length lns))- lm3- | multiline2LineNum < 1 = -1- | otherwise = max 1 . min multiline2LineNum $ ll1- linecomp3- | lm3 == -1 = []- | otherwise = lns !! (lm3 - 1)- ln_1 - | ln0 == 1 = 0- | otherwise = ln0 - 1- ln1- | ln0 == length lns = 0- | otherwise = ln0 + 1- lineF = lns !! (ln0 - 1)- line_1F - | ln_1 == 0 = []- | otherwise = lns !! (ln_1 - 1)- line1F- | ln1 == 0 = []- | otherwise = lns !! (ln1 - 1)- return $ (words lineF, line_1F,line1F,linecomp3)- else return (args11, [], [],[])- let differentiate = any (== "+di") args11- line2comparewith- | oneC "+l2" argsC || L.null linecomp3 = unwords . getC "+l2" $ argsC- | otherwise = linecomp3- basecomp - | oneC "+ln" argsC = (if differentiate then C2 . fromSmallWord8toInt8Diff else C1) . catMaybes . map (\xs -> readMaybe xs::Maybe Word8) . getC "+ln" $ argsC -- to read positive Word8 values as a list of them.- | otherwise = (if differentiate then C2 . fromSmallWord8toInt8Diff else C1) . read3 (not . L.null . filter (not . isSpace)) 1.0 (mconcat . h . createSyllablesPL wrs ks arr gs us vs) $ line2comparewith- (filesave,codesave)- | L.null filedata = ("",-1)- | length filedata == 2 = (head filedata, fromMaybe 0 (readMaybe (last filedata)::Maybe Int))- | otherwise = (head filedata,0)- ll = let maxWordsNum = (if any (== "+x") arg3s then 9 else 7) in take maxWordsNum . (if prepare then id else words . mconcat . prepareTextN maxWordsNum ysss zsss xs . unwords) $ arg3s- l = length ll- argCs = catMaybes (fmap (readMaybeECG l) . getC "+a" $ argsC)- argCBs = unwords . getC "+b" $ argsC -- If you use the parenthese with +b ... -b then consider also using the quotation marks for the whole algebraic constraint. At the moment though it is still not working properly for parentheses functionality. The issue should be fixed in the further releases.- !perms - | not (L.null argCBs) = filterGeneralConv l argCBs . genPermutationsL $ l- | L.null argCs = genPermutationsL l- | otherwise = decodeLConstraints argCs . genPermutationsL $ l - basiclineoption = unwords arg3s- example = (if differentiate then C2 . fromSmallWord8toInt8Diff else C1) . read3 (not . L.null . filter (not . isSpace)) 1.0 (mconcat . h . createSyllablesPL wrs ks arr gs us vs) . unwords $ arg3s- le = doubleFunc (length::[Word8]->Int) (length::[Int8]->Int) example- lb = doubleFunc (length::[Word8]->Int) (length::[Int8]->Int) basecomp- gcd1 = gcd le lb- ldc = le * lb `quot` gcd1- mulp = ldc `quot` lb--- max2 = maximum basecomp- compards = let ff g1 g2 ks = if isWord8Based ks then C1 . g1 . (\(C1 us) -> us) $ ks else C2 . g2 . (\(C2 us) -> us)$ ks in ff (concatMap (replicate mulp)) (concatMap (replicate mulp)) basecomp- variants1 = force . uniquenessVariants2GNBL ' ' id id id perms $ ll- return (power10, ldc, compards, html, filtering, dcfile, selStr, prestr, poststr, lineNmb, emptyline, splitting, filesave, codesave, concurrently, basiclineoption, variants1)+ args0 <- getArgs+ let (argsC, args) = takeCs1R ('+', '-') cSpecs args0+ (argsB, args11) = takeBsR bSpecs args+ compareByLinesFinalFile = concat . getB "-cm" $ argsB+ if not . L.null $ compareByLinesFinalFile+ then do+ compareFilesToOneCommon 14 args11 compareByLinesFinalFile+ return (0, 0, (C1 []), False, False, [], [], [], [], 0, False, 0, [], 0, False, [], [])+ else do+ let prepare = any (== "-p") args11+ emptyline = any (== "+l") args11+ splitting = fromMaybe 54 (readMaybe (concat . getB "+w" $ argsB) :: Maybe Int8)+ concurrently = any (== "-C") args11+ filtering = any (== "-e") args11+ dcspecs = getB "+dc" argsB+ (html, dcfile)+ | L.null dcspecs = (False, "")+ | otherwise = (head dcspecs == "1", last dcspecs)+ selStr = concat . getB "+ul" $ argsB+ filedata = getB "+f" argsB+ power10' = fromMaybe 0 (readMaybe (concat . getB "+q" $ argsB) :: Maybe Int)+ power10+ | power10' < 0 && power10' > 4 = 0+ | otherwise = power10'+ (multiline2, multiline2LineNum)+ | oneB "+m3" argsB =+ let r1ss = getB "+m3" argsB+ in if length r1ss == 3+ then+ let (kss, qss) = splitAt 2 r1ss+ in (kss, max 1 (fromMaybe 1 (readMaybe (concat qss) :: Maybe Int)))+ else (r1ss, 1)+ | oneB "+m2" argsB =+ ( getB "+m" argsB+ , max 1 (fromMaybe 1 (readMaybe (concat . getB "+m2" $ argsB) :: Maybe Int))+ )+ | otherwise = (getB "+m" argsB, -1)+ (fileread, lineNmb)+ | L.null multiline2 = ("", -1)+ | length multiline2 == 2 =+ (head multiline2, fromMaybe 1 (readMaybe (last multiline2) :: Maybe Int))+ | otherwise = (head multiline2, 1)+ (arg3s, prestr, poststr, linecomp3) <- do+ if lineNmb /= -1+ then do+ txtFromFile <- readFile fileread+ let lns = lines txtFromFile+ ll1 = length lns+ ln0 = max 1 (min lineNmb (length lns))+ lm3+ | multiline2LineNum < 1 = -1+ | otherwise = max 1 . min multiline2LineNum $ ll1+ linecomp3+ | lm3 == -1 = []+ | otherwise = lns !! (lm3 - 1)+ ln_1+ | ln0 == 1 = 0+ | otherwise = ln0 - 1+ ln1+ | ln0 == length lns = 0+ | otherwise = ln0 + 1+ lineF = lns !! (ln0 - 1)+ line_1F+ | ln_1 == 0 = []+ | otherwise = lns !! (ln_1 - 1)+ line1F+ | ln1 == 0 = []+ | otherwise = lns !! (ln1 - 1)+ return $ (words lineF, line_1F, line1F, linecomp3)+ else return (args11, [], [], [])+ let differentiate = any (== "+di") args11+ line2comparewith+ | oneC "+l2" argsC || L.null linecomp3 = unwords . getC "+l2" $ argsC+ | otherwise = linecomp3+ basecomp+ | oneC "+ln" argsC =+ (if differentiate then C2 . fromSmallWord8toInt8Diff else C1)+ . catMaybes+ . map (\xs -> readMaybe xs :: Maybe Word8)+ . getC "+ln" $+ argsC -- to read positive Word8 values as a list of them.+ | otherwise =+ (if differentiate then C2 . fromSmallWord8toInt8Diff else C1)+ . read3+ (not . L.null . filter (not . isSpace))+ 1.0+ (mconcat . h . createSyllablesPL wrs ks arr gs us vs) $+ line2comparewith+ (filesave, codesave)+ | L.null filedata = ("", -1)+ | length filedata == 2 =+ (head filedata, fromMaybe 0 (readMaybe (last filedata) :: Maybe Int))+ | otherwise = (head filedata, 0)+ ll =+ let maxWordsNum = (if any (== "+x") arg3s then 9 else 7)+ in take maxWordsNum+ . ( if prepare+ then id+ else words . mconcat . prepareTextN maxWordsNum ysss zsss xs . unwords+ ) $+ arg3s+ l = length ll+ argCs = catMaybes (fmap (readMaybeECG l) . getC "+a" $ argsC)+ argCBs = unwords . getC "+b" $ argsC -- If you use the parenthese with +b ... -b then consider also using the quotation marks for the whole algebraic constraint. At the moment though it is still not working properly for parentheses functionality. The issue should be fixed in the further releases.+ !perms+ | not (L.null argCBs) = filterGeneralConv l argCBs . genPermutationsL $ l+ | L.null argCs = genPermutationsL l+ | otherwise = decodeLConstraints argCs . genPermutationsL $ l+ basiclineoption = unwords arg3s+ example =+ (if differentiate then C2 . fromSmallWord8toInt8Diff else C1)+ . read3+ (not . L.null . filter (not . isSpace))+ 1.0+ (mconcat . h . createSyllablesPL wrs ks arr gs us vs)+ . unwords $+ arg3s+ le = doubleFunc (length :: [Word8] -> Int) (length :: [Int8] -> Int) example+ lb = doubleFunc (length :: [Word8] -> Int) (length :: [Int8] -> Int) basecomp+ gcd1 = gcd le lb+ ldc = le * lb `quot` gcd1+ mulp = ldc `quot` lb+ -- max2 = maximum basecomp+ compards =+ let ff g1 g2 ks =+ if isWord8Based ks+ then C1 . g1 . (\(C1 us) -> us) $ ks+ else C2 . g2 . (\(C2 us) -> us) $ ks+ in ff (concatMap (replicate mulp)) (concatMap (replicate mulp)) basecomp+ variants1 = force . uniquenessVariants2GNBL ' ' id id id perms $ ll+ return+ ( power10+ , ldc+ , compards+ , html+ , filtering+ , dcfile+ , selStr+ , prestr+ , poststr+ , lineNmb+ , emptyline+ , splitting+ , filesave+ , codesave+ , concurrently+ , basiclineoption+ , variants1+ ) -processingF- :: (String -> String) -- ^ A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#parsey0Choice. Use just small 'Char' if they are letters, do not use \'.\' and spaces.- -> 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.- -> ([[[PRS]]] -> [[Word8]]) -- ^ Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].- -> Int- -> HashCorrections - -> (Int8,[Int8]) - -> [[String]] - -> [[String]] - -> Bool- -> Int -- ^ The hashing function step. The default value is 20. Is expected to be greater than 2, and better greater than 12. - -> String - -> IO ()-processingF selFun wrs ks arr gs us vs h numTest hc (grps,mxms) ysss zsss descending hashStep xs = argsProcessing wrs ks arr gs us vs h ysss zsss xs >>= \(power10, ldc, compards, html, filtering, dcfile, selStr, prestr, poststr, lineNmb, emptyline, splitting, filesave, codesave, concurrently, basiclineoption, variants1) -> generalF power10 ldc compards html filtering dcfile selStr selFun (prestr,poststr) lineNmb wrs ks arr gs us vs h numTest hc (grps,mxms) descending hashStep emptyline splitting (filesave, codesave) concurrently basiclineoption variants1 >> return ()+processingF ::+ -- | A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#parsey0Choice. Use just small 'Char' if they are letters, do not use \'.\' and spaces.+ (String -> String) ->+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ -- | 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.+ [(Char, Char)] ->+ CharPhoneticClassification ->+ SegmentRulesG ->+ -- | 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 ->+ -- | Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].+ ([[[PRS]]] -> [[Word8]]) ->+ Int ->+ HashCorrections ->+ (Int8, [Int8]) ->+ [[String]] ->+ [[String]] ->+ -- | The hashing function step. The default value is 20. Is expected to be greater than 2, and better greater than 12.+ Int ->+ String ->+ IO ()+processingF selFun wrs ks arr gs us vs h numTest hc (grps, mxms) ysss zsss hashStep xs =+ argsProcessing wrs ks arr gs us vs h ysss zsss xs >>= \( power10+ , ldc+ , compards+ , html+ , filtering+ , dcfile+ , selStr+ , prestr+ , poststr+ , lineNmb+ , emptyline+ , splitting+ , filesave+ , codesave+ , concurrently+ , basiclineoption+ , variants1+ ) ->+ generalF+ power10+ ldc+ compards+ html+ filtering+ dcfile+ selStr+ selFun+ (prestr, poststr)+ lineNmb+ wrs+ ks+ arr+ gs+ us+ vs+ h+ numTest+ hc+ (grps, mxms)+ hashStep+ emptyline+ splitting+ (filesave, codesave)+ concurrently+ basiclineoption+ variants1+ >> return () {-# INLINE processingF #-} --- | Specifies the group of the command line arguments for 'processingF', which specifies the--- PhLADiPreLiO constraints. For more information, see:--- https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#constraints +{- | Specifies the group of the command line arguments for 'processingF', which specifies the+PhLADiPreLiO constraints. For more information, see:+https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#constraints+-} cSpecs :: CLSpecifications-cSpecs = zip ["+a","+b","+l2","+ln"] . cycle $ [-1]+cSpecs = zip ["+a", "+b", "+l2", "+ln"] . cycle $ [-1] bSpecs :: CLSpecifications-bSpecs = [("+f",2),("+m",2),("+m2",2),("+m3",3),("+ul",1),("+w",1),("+dc",2),("+q",1),("-cm",1)]+bSpecs =+ [ ("+f", 2)+ , ("+m", 2)+ , ("+m2", 2)+ , ("+m3", 3)+ , ("+ul", 1)+ , ("+w", 1)+ , ("+dc", 2)+ , ("+q", 1)+ , ("-cm", 1)+ ] -{-| 'selectSounds' converts the argument after \"+ul\" command line argument into a list of sound representations that is used for evaluation of \'uniqueness periods\' properties of the line. Is a modified Phonetic.Languages.Simplified.Array.General.FuncRep2RelatedG2.parsey0Choice from the @phonetic-languages-simplified-generalized-examples-array-0.19.0.1@ package.- -}-selectSounds - :: (String -> String) -- ^ A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#selectSounds. Use just small 'Char' if they are letters, do not use \'.\' and spaces.- -> String - -> String-selectSounds g xs = f . sortOn id . concatMap g . words . map (\c -> if c == '.' then ' ' else c) $ us- where (_,us) = break (== '.') . filter (\c -> c /= 'H' && c /= 'G') $ xs- f (x:ts@(y:_)) - | x == y = f ts- | otherwise = x:f ts- f xs = xs+-- | 'selectSounds' converts the argument after \"+ul\" command line argument into a list of sound representations that is used for evaluation of \'uniqueness periods\' properties of the line. Is a modified Phonetic.Languages.Simplified.Array.General.FuncRep2RelatedG2.parsey0Choice from the @phonetic-languages-simplified-generalized-examples-array-0.19.0.1@ package.+selectSounds ::+ -- | A function that specifies what 'Char's in the list the first argument makes to be the function sensitive to. Analogue of the @g@ function in the definition: https://hackage.haskell.org/package/phonetic-languages-simplified-examples-array-0.21.0.0/docs/src/Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.html#selectSounds. Use just small 'Char' if they are letters, do not use \'.\' and spaces.+ (String -> String) ->+ String ->+ String+selectSounds g xs =+ f . sortOn id . concatMap g . words . map (\c -> if c == '.' then ' ' else c) $+ us+ where+ (_, us) = break (== '.') . filter (\c -> c /= 'H' && c /= 'G') $ xs+ f (x : ts@(y : _))+ | x == y = f ts+ | otherwise = x : f ts+ f xs = xs -- | Internal part of the 'generalF' for processment in case of using tests mode.-testsOutput- :: (Show a1, Integral a1) =>- Bool- -> Int- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> (Int -> Compards -> Int8 -> [Int8] -> String -> a1)- -> Int- -> Int- -> [String]- -> IO [String]+testsOutput ::+ (Show a1, Integral a1) =>+ Bool ->+ Int ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ (Int -> Compards -> Int8 -> [Int8] -> String -> a1) ->+ Int ->+ Int ->+ [String] ->+ IO [String] testsOutput concurrently syllN filtering f ldc numTest universalSet = do- putStrLn "Feet Val Stat Proxim" - (if concurrently then mapConcurrently else mapM) - (\(q,qs) -> let m = stat1 syllN (q,qs)- (min1,max1) = force . fromJust . minMax11By (comparing (f ldc (C1 []) q qs)) $ universalSet - mx = f ldc (C1 []) q qs max1- strTest = (show (fromEnum q) `mappend` " | " `mappend` show mx `mappend` " " `mappend` show m `mappend` " -> " `mappend` showFFloat (Just 3) (100 * fromIntegral mx / fromIntegral m) "%" `mappend` (if rem numTest 10 >= 4 - then -- let min1 = minimumBy (comparing (f ldc [] q qs)) universalSet in - ("\n" `mappend` (if filtering then removeChangesOfDurations else id) min1 `mappend` "\n" `mappend` (if filtering then removeChangesOfDurations else id) max1 `mappend` "\n") - else "")) in putStrLn strTest >> return strTest) . zip (sel2 numTest) $ (sel numTest)+ putStrLn "Feet Val Stat Proxim"+ (if concurrently then mapConcurrently else mapM)+ ( \(q, qs) ->+ let m = stat1 syllN (q, qs)+ (min1, max1) = force . fromJust . minMax11By (comparing (f ldc (C1 []) q qs)) $ universalSet+ mx = f ldc (C1 []) q qs max1+ strTest =+ ( show (fromEnum q)+ `mappend` " | "+ `mappend` show mx+ `mappend` " "+ `mappend` show m+ `mappend` " -> "+ `mappend` showFFloat (Just 3) (100 * fromIntegral mx / fromIntegral m) "%"+ `mappend` ( if rem numTest 10 >= 4+ then -- let min1 = minimumBy (comparing (f ldc [] q qs)) universalSet in + ( "\n"+ `mappend` (if filtering then removeChangesOfDurations else id) min1+ `mappend` "\n"+ `mappend` (if filtering then removeChangesOfDurations else id) max1+ `mappend` "\n"+ )+ else ""+ )+ )+ in putStrLn strTest >> return strTest+ )+ . zip (sel2 numTest)+ $ (sel numTest)+ -- | Internal part of the 'generalF' for processment with a file.-outputWithFile- :: ([[[PRS]]] -> [[Word8]]) -- ^ Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].- -> 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 -- ^ If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'- -> Compards -- ^ A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.- -> [AftovolioGen]- -> Int- -> Int8- -> FilePath -- ^ A file to be probably added output parts to.- -> Int- -> IO ()+outputWithFile ::+ -- | Since the version 0.20.0.0, here there are 'Word8' instead of 'Double'. If this function is @g@, then the module 'Aftovolio.General.Datatype3' has corresponding function 'Aftovolio.General.Datatype3.zippedDouble2Word8' to transform the previously used function into the new one. If you have the function used inside the @f::[[[PRS]]]->[[Double]]@ with main conversion semantically similar to the one by the link: 'https://hackage.haskell.org/package/ukrainian-phonetics-basic-array-0.7.1.1/docs/Phladiprelio-Ukrainian-SyllableDouble.html#v:syllableDurationsD', then you can use 'zippedDouble2Word8' to transform the main semantic kernel of [(PRS, Double)] into [(PRS, Word8)].+ ([[[PRS]]] -> [[Word8]]) ->+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ -- | 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.+ [(Char, Char)] ->+ CharPhoneticClassification ->+ SegmentRulesG ->+ -- | 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 ->+ -- | If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'+ String ->+ -- | A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.+ Compards ->+ [AftovolioGen] ->+ Int ->+ Int8 ->+ -- | A file to be probably added output parts to.+ FilePath ->+ Int ->+ IO () outputWithFile h wrs ks arr gs us vs selStr compards sRepresent code grps fs num- | mBool && code >= 10 && code <= 19 && grps == 2 = putStrLn (mconcat [textP, "\n", breaks, "\n", show rs]) >> appendF ((if code >= 15 then mconcat [show rs, "\n", breaks, "\n"] else "") `mappend` outputS)- | otherwise = appendF outputS- where mBool = L.null selStr && doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]->Bool) compards- appendF = appendFile fs- lineOption = head . filter (\(S k _ _) -> k == num) $ sRepresent- textP = (\(S _ _ ts) -> ts) lineOption- outputS = outputSel lineOption code- qqs = readEq4 (mconcat . h . createSyllablesPL wrs ks arr gs us vs) (map (map charS) . mconcat . createSyllablesPL wrs ks arr gs us vs) . basicSplit $ textP- (breaks,rs) = showZerosFor2PeriodMusic qqs-+ | mBool && code >= 10 && code <= 19 && grps == 2 =+ putStrLn (mconcat [textP, "\n", breaks, "\n", show rs])+ >> appendF+ ( (if code >= 15 then mconcat [show rs, "\n", breaks, "\n"] else "")+ `mappend` outputS+ )+ | otherwise = appendF outputS+ where+ mBool =+ L.null selStr+ && doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ appendF = appendFile fs+ lineOption = head . filter (\(S k _ _) -> k == num) $ sRepresent+ textP = (\(S _ _ ts) -> ts) lineOption+ outputS = outputSel lineOption code+ qqs =+ readEq4+ (mconcat . h . createSyllablesPL wrs ks arr gs us vs)+ (map (map charS) . mconcat . createSyllablesPL wrs ks arr gs us vs)+ . basicSplit $+ textP+ (breaks, rs) = showZerosFor2PeriodMusic qqs
Aftovolio/General/SpecificationsRead.hs view
@@ -1,48 +1,61 @@--- |--- Module : Aftovolio.General.SpecificationsRead--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Provides functions to read data specifications for other modules from textual files.-- {-# LANGUAGE NoImplicitPrelude #-} +{- |+Module : Aftovolio.General.SpecificationsRead+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com + Provides functions to read data specifications for other modules from textual files.+-} module Aftovolio.General.SpecificationsRead where +import Aftovolio.General.Base+import Aftovolio.RGLPK.General+import Data.Char (isAlpha)+import Data.List (lines, sort)+import Data.Maybe (fromJust, fromMaybe)+import GHC.Arr import GHC.Base+import GHC.Int import GHC.List-import Data.List (sort,lines)-import Data.Char (isAlpha)-import Aftovolio.RGLPK.General import System.Environment (getArgs)-import GHC.Arr import Text.Read-import Data.Maybe (fromMaybe,fromJust)-import GHC.Int-import Aftovolio.General.Base charLine :: Char -> String -> Bool charLine c = (== [c]) . take 1 {-# INLINE charLine #-} -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 ::+ -- | A delimiter (can be used probably multiple times) used between different parts of the data.+ Char ->+ -- | A list of 'String' that is partitioned using the 'String' starting with the delimiter.+ [String] ->+ [[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+ 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 ::+ -- | A delimiter (cab be used probably multiple times) between different parts of the data file. Usually, a tilda sign \'~\'.+ Char ->+ -- | Actually the 'String' that is read into the result.+ String ->+ -- | The data is used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX+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
Aftovolio/General/Syllables.hs view
@@ -1,192 +1,204 @@-{-# OPTIONS_HADDOCK show-extensions #-}-{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnboxedTuples, StrictData #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE NoImplicitPrelude #-}-+{-# OPTIONS_GHC -funbox-strict-fields -fobject-code #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.General.Syllables--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ This module works with syllable segmentation. The generalized version for the module--- 'Aftovolio.Ukrainian.Syllable' from @ukrainian-phonetics-basic-array@ package.--- +{- |+Module : Aftovolio.General.Syllables+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +This module works with syllable segmentation. The generalized version for the module+'Aftovolio.Ukrainian.Syllable' from @ukrainian-phonetics-basic-array@ package.+-} module Aftovolio.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+ -- * 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 qualified Data.List as L (groupBy,find,intercalate,words) import Aftovolio.General.Base import CaseBi.Arr+import Data.Char (isLetter)+import Data.IntermediateStructures1 (mapI)+import qualified Data.List as L (find, groupBy, intercalate, words)+import Data.Maybe (fromJust, mapMaybe)+import Data.Tuple (fst, snd) import GHC.Arr+import GHC.Base+import GHC.Enum (fromEnum) import GHC.Exts-import Data.IntermediateStructures1 (mapI)-import Data.Maybe (mapMaybe,fromJust) import GHC.Int-import Text.Read (Read(..),readMaybe)-import Text.Show (Show(..))-import Data.Char (isLetter)+import GHC.List import GHC.Num ((-))-import Data.Tuple (fst, snd)-import GHC.Enum (fromEnum)+import Text.Read (Read (..), readMaybe)+import Text.Show (Show (..)) -- 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 :: {-# UNPACK #-} !Char, -- ^ Phonetic languages phenomenon representation. Usually, a phoneme, but it can be otherwise something different.- phoneType :: {-# UNPACK #-} !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 )+data PRS = SylS+ { charS :: {-# UNPACK #-} !Char+ -- ^ Phonetic languages phenomenon representation. Usually, a phoneme, but it can be otherwise something different.+ , phoneType :: {-# UNPACK #-} !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+ 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)+ show (SylS c (P x)) = "SylS \'" `mappend` (c : '\'' : ' ' : show x) data PhoneticType = P {-# UNPACK #-} !Int8 deriving (Eq, Ord, Read) instance Show PhoneticType where- show (P x) = 'P':' ':show x+ show (P x) = 'P' : ' ' : show x fromPhoneticType :: PhoneticType -> Int-fromPhoneticType (P x) = fromEnum x+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.+{- | 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 ::+ (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#)+ | 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#) -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#)+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#) {-# INLINE findC #-} str2PRSs :: CharPhoneticClassification -> String -> StringRepresentation str2PRSs arr = map (\c -> fromJust . findC c $ arr) {-# INLINE str2PRSs #-}- --- | 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.++{- | 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` [1,2]) . fromPhoneticType . phoneType+isSonorous1 = (`elem` [1, 2]) . fromPhoneticType . phoneType {-# INLINE isSonorous1 #-} -- | Function-predicate 'isVoicedC1' checks whether its argument is a voiced consonant representation in the 'PRS' format.-isVoicedC1 :: PRS -> Bool-isVoicedC1 = (`elem` [3,4]) . fromPhoneticType . phoneType+isVoicedC1 :: PRS -> Bool+isVoicedC1 = (`elem` [3, 4]) . fromPhoneticType . phoneType {-# INLINE isVoicedC1 #-} -- | Function-predicate 'isVoiceless1' checks whether its argument is a voiceless consonant representation in the 'PRS' format.-isVoicelessC1 :: PRS -> Bool-isVoicelessC1 = (`elem` [5,6]) . fromPhoneticType . phoneType-{-# INLINE isVoicelessC1 #-} +isVoicelessC1 :: PRS -> Bool+isVoicelessC1 = (`elem` [5, 6]) . fromPhoneticType . 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+ | 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 ::+ -- | 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.+ [(Char, Char)] ->+ PRS ->+ PRS ->+ Bool notEqC xs x y- | (== cy) . getBFstLSorted' cx xs $ cx = False- | otherwise = cx /= cy- where !cx = charS x- !cy = charS y+ | (== cy) . getBFstLSorted' cx xs $ cx = False+ | otherwise = cx /= cy+ where+ !cx = charS x+ !cy = charS y {-# INLINE notEqC #-} --- | 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.+{- | 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 ys@(_ : _) = L.groupBy notCreatesSyllable2 ys sndGroups _ = [] {-# INLINE sndGroups #-} @@ -194,139 +206,187 @@ groupSnds = L.groupBy (\x y -> createsSyllable x == createsSyllable y) {-# INLINE groupSnds #-} -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)+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+ 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)+{- | 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: -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)+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+ 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 "Aftovolio.General.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 "Aftovolio.General.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+ 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+ "Aftovolio.General.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+ "Aftovolio.General.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])+type DListFunctionResult = ([PRS] -> [PRS], [PRS] -> [PRS]) class DListRepresentation a b where- toDLR :: b -> [a] -> ([a] -> [a], [a] -> [a])+ 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)+ 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 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) +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) --- | 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.+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)+{- | 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 ::+ -- | 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.+ [(Char, Char)] ->+ 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 ::+ -- | 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.+ [(Char, Char)] ->+ 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+ 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+{- | 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+createSyllablesPL ::+ -- | Data used to obtain the phonetic language representation of the text.+ GWritingSystemPRPLX ->+ -- | 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.+ [(Char, Char)] ->+ CharPhoneticClassification ->+ SegmentRulesG ->+ -- | 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'.+ 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 #-}
Aftovolio/Halfsplit.hs view
@@ -1,124 +1,155 @@--- |--- Module : Aftovolio.Halfsplit--- Copyright : (c) OleksandrZhabenko 2023--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com---- {-# LANGUAGE NoImplicitPrelude #-}- {-# OPTIONS_HADDOCK -show-extensions #-} +{- |+Module : Aftovolio.Halfsplit+Copyright : (c) OleksandrZhabenko 2023+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com+-} module Aftovolio.Halfsplit where +import Data.Char (isDigit)+import Data.List hiding (foldr)+import Data.Tuple (fst) import GHC.Base import GHC.Enum (fromEnum)-import GHC.Real (quot,quotRem)-import GHC.Num ((+),(-),abs)-import Data.List hiding (foldr) import GHC.Int (Int8)-import Text.Show (Show(..))-import System.IO (putStrLn,getLine,putStr)-import Data.Tuple (fst)-import Data.Char (isDigit)+import GHC.Num (abs, (+), (-))+import GHC.Real (quot, quotRem)+import System.IO (getLine, putStr, putStrLn)+import Text.Show (Show (..)) -- | Converts the data that is an instance of 'Show' typeclass to be printed in two-column way.-halfsplit - :: (Show a, Eq b) - => (a -> b)- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> Int8 - -> [a] - -> String-halfsplit g filtering = halfsplit1G g filtering "" +halfsplit ::+ (Show a, Eq b) =>+ (a -> b) ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ Int8 ->+ [a] ->+ String+halfsplit g filtering = halfsplit1G g filtering "" {-# INLINE halfsplit #-} --- | Converts the data that is an instance of 'Show' typeclass to be printed in two-column way with--- customizable ending of each line. Filters out all groups of \'={digits}\' from the lines.-halfsplit1G - :: (Show a, Eq b) - => (a -> b)- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> String -- ^ Additional 'String' added to every line before the \"\\n\" character.- -> Int8 - -> [a] - -> String-halfsplit1G g filtering appendstr m xs - | null xs = []- | otherwise = - let (n, rr2) = quotRem (fromEnum m) (if m < 0 then -10 else 10)- r = - case abs rr2 of- 1 -> let us = reverse ts in (if rrr == 0 then map show ys else replicate l0 ' ':map show ys, map show us)- 2 -> let us = (replicate (lt1 - ly1) [replicate l0 ' ']) `mappend` reverse (map reverse y1s) in (mconcat us, mconcat t1s)- 3 -> let us = (replicate (lt1 - ly1) [replicate l0 ' ']) `mappend` y1s- ks = reverse . map reverse $ t1s in (mconcat us, mconcat ks)- 4 -> let us = (replicate (lt2 - ly2) [replicate l0 ' ']) `mappend` reverse (map reverse y2s) in (mconcat us, mconcat t2s)- 5 -> let us = (replicate (lt2 - ly2) [replicate l0 ' ']) `mappend` y2s- ks = reverse . map reverse $ t2s in (mconcat us, mconcat ks)- _ -> let us = reverse ys in (if rrr == 0 then map show us else replicate l0 ' ':map show us, map show ts) in (if filtering then removeChangesOfDurations else id) $ ((\(rs, qs) -> mergePartsLine n (appendstr `mappend` "\n") rs qs) r) `mappend` appendstr- where (ys,ts) = splitAt l xs - (l,rrr) = length xs `quotRem` 2- l0 = length . show . head $ xs - rss = map (map show) . groupBy (\x y -> g x == g y) $ xs- r1ss = intersperse [replicate l0 ' '] rss- l2 = (sum . map length $ rss) `quot` 2- l3 = (sum . map length $ r1ss) `quot` 2- (y1s,t1s,_) = splitGroups l2 rss- ly1 = sum . map length $ y1s- lt1 = sum . map length $ t1s- (y2s,t2s,_) = splitGroups l3 r1ss- ly2 = sum . map length $ y2s- lt2 = sum . map length $ t2s-+{- | Converts the data that is an instance of 'Show' typeclass to be printed in two-column way with+customizable ending of each line. Filters out all groups of \'={digits}\' from the lines.+-}+halfsplit1G ::+ (Show a, Eq b) =>+ (a -> b) ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ -- | Additional 'String' added to every line before the \"\\n\" character.+ String ->+ Int8 ->+ [a] ->+ String+halfsplit1G g filtering appendstr m xs+ | null xs = []+ | otherwise =+ let (n, rr2) = quotRem (fromEnum m) (if m < 0 then -10 else 10)+ r =+ case abs rr2 of+ 1 ->+ let us = reverse ts+ in ((if rrr == 0 then id else (replicate l0 ' ' :)) $ map show ys, map show us)+ 2 -> (reverse y10s, t10s)+ 3 -> (y10s, reverse t10s)+ 4 -> (reverse y20s, t20s)+ 5 -> (y20s, reverse t20s)+ _ ->+ let us = reverse ys+ in ((if rrr == 0 then id else (replicate l0 ' ' :)) $ map show us, map show ts)+ in (if filtering then removeChangesOfDurations else id) $+ ((\(rs, qs) -> mergePartsLine n (appendstr `mappend` "\n") rs qs) r)+ `mappend` appendstr+ where+ (ys, ts) = splitAt l xs -- Is used for basic splitting+ (l, rrr) = length xs `quotRem` 2 -- For basic splitting+ l0 = length . show . head $ xs -- For all cases for a whitespace placeholder+ rss = map (map show) . groupBy (\x y -> g x == g y) $ xs -- For basic groupping+ (l2, r20) = (sum . map length $ rss) `quotRem` 2+ (y100s, t10s) = splitAt l2 . concat $ rss+ y10s + | r20 == 0 = y100s+ | otherwise = replicate l0 ' ' : y10s+ r1ss = intersperse [replicate l0 ' '] rss -- For groupping with empty lines+ (l3, r30) = (sum . map length $ r1ss) `quotRem` 2+ (y200s, t20s) = splitAt l3 . concat $ r1ss+ y20s+ | r30 == 0 = y200s+ | otherwise = replicate l0 ' ' : y20s+ -- | A generalized version of 'halfsplit3G' with the possibility to prepend and append strings to it. These 'String's are not filtered out for the groups of \'={digits}\' from the prepending and appending 'String's.-halfsplit2G - :: (Show a, Eq b) - => (a -> b)- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> String -- ^ Additional 'String' added to every line before the \"\\n\" character.- -> String -- ^ A 'String' that is prepended to the 'halfsplit1G' result.- -> String -- ^ A 'String' that is appended to the 'halfsplit1G' result.- -> Int8 - -> [a] - -> String+halfsplit2G ::+ (Show a, Eq b) =>+ (a -> b) ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ -- | Additional 'String' added to every line before the \"\\n\" character.+ String ->+ -- | A 'String' that is prepended to the 'halfsplit1G' result.+ String ->+ -- | A 'String' that is appended to the 'halfsplit1G' result.+ String ->+ Int8 ->+ [a] ->+ String halfsplit2G g filtering appendstr prestr poststr m xs = prestr `mappend` halfsplit1G g filtering appendstr m xs `mappend` poststr-{-# INLINABLE halfsplit2G #-}+{-# INLINEABLE halfsplit2G #-} -- | Filters out all groups of \'={digits}\' from the 'String' removeChangesOfDurations :: String -> String-removeChangesOfDurations ('=':xs) = removeChangesOfDurations (dropWhile isDigit xs) -removeChangesOfDurations (x:xs) = x:removeChangesOfDurations xs+removeChangesOfDurations ('=' : xs) = removeChangesOfDurations (dropWhile isDigit xs)+removeChangesOfDurations (x : xs) = x : removeChangesOfDurations xs removeChangesOfDurations _ = [] mergePartsLine :: Int -> String -> [String] -> [String] -> String-mergePartsLine n newlined xs ys = intercalate newlined . zipWith (\x y -> x `mappend` (replicate n (if n < 0 then '\t' else ' ')) `mappend` y) xs $ ys+mergePartsLine n newlined xs ys =+ intercalate newlined+ . zipWith+ (\x y -> x `mappend` (replicate n (if n < 0 then '\t' else ' ')) `mappend` y)+ xs $+ ys splitGroups :: Int -> [[a]] -> ([[a]], [[a]], Int)-splitGroups l tss = foldr h ([],[],0) tss- where h js (rss,mss,k)- | k <= l = (rss, js:mss, k + length js)- | otherwise = (js : rss, mss, k + length js)+splitGroups l tss = foldr h ([], [], 0) tss+ where+ h js (rss, mss, k)+ | k < l = (rss, js : mss, k + length js)+ | otherwise = (js : rss, mss, k + length js) showWithSpaces :: (Show a) => Int -> a -> String-showWithSpaces n x - | l < n = xs `mappend` replicate (n - l) ' '- | otherwise = xs- where xs = show x- l = length xs+showWithSpaces n x+ | l < n = xs `mappend` replicate (n - l) ' '+ | otherwise = xs+ where+ xs = show x+ l = length xs print23 :: Bool -> String -> String -> Int -> [String] -> IO () print23 filtering prestr poststr n xss = do- putStrLn prestr- let linez = zip xss [1..]- if n >= 2 && n <= l - 1- then do- let linez3 = (\(x:y:t:xs) -> x:(' ':y):(' ':' ':t):xs) . map fst . filter (\(ts,m) -> m `elem` [n - 1..n + 1]) $ linez- mapM putSLn linez3 >> putStrLn poststr- else (case n of- 1 -> putStr " " >> mapM putSLn (take 2 xss)- m -> if m == l then mapM putSLn ((\(x:y:xs) -> x:(' ':y):xs) . drop (l - 2) $ xss) else pure []) >> putStrLn poststr- where l = length xss- putSLn = putStrLn . (if filtering then removeChangesOfDurations else id)-+ putStrLn prestr+ let linez = zip xss [1 ..]+ if n >= 2 && n <= l - 1+ then do+ let linez3 =+ (\(x : y : t : xs) -> x : (' ' : y) : (' ' : ' ' : t) : xs)+ . map fst+ . filter (\(ts, m) -> m `elem` [n - 1 .. n + 1]) $+ linez+ mapM putSLn linez3 >> putStrLn poststr+ else+ ( case n of+ 1 -> putStr " " >> mapM putSLn (take 2 xss)+ m ->+ if m == l+ then mapM putSLn ((\(x : y : xs) -> x : (' ' : y) : xs) . drop (l - 2) $ xss)+ else pure []+ )+ >> putStrLn poststr+ where+ l = length xss+ putSLn = putStrLn . (if filtering then removeChangesOfDurations else id)
Aftovolio/Partir.hs view
@@ -1,83 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.Partir--- Copyright : (c) Oleksandr Zhabenko 2022-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ --{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses, NoImplicitPrelude #-}-+{- |+Module : Aftovolio.Partir+Copyright : (c) Oleksandr Zhabenko 2022-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com+-} module Aftovolio.Partir where -import GHC.Base-import GHC.Num-import GHC.Real-import GHC.Float-import qualified Data.Foldable as F-import Data.InsertLeft (InsertLeft(..)) -import Aftovolio.DataG import Aftovolio.Basis+import Aftovolio.DataG import Data.Char (isDigit)-import Data.List (uncons, filter, null)+import qualified Data.Foldable as F+import Data.InsertLeft (InsertLeft (..))+import Data.List (filter, null, uncons) import Data.Maybe (fromJust, fromMaybe)+import GHC.Base+import GHC.Float+import GHC.Num+import GHC.Real import Text.Read (readMaybe) -class F.Foldable t => ConstraintsG t a where- decodeCDouble :: t a -> Double -> Bool+class (F.Foldable t) => ConstraintsG t a where+ decodeCDouble :: t a -> Double -> Bool instance ConstraintsG [] Char where- decodeCDouble xs !y- | null xxs = True- | t < '2' = (if t == '0' then (>) else (<)) y (fromIntegral . fromMaybe 1 $ (readMaybe ts :: Maybe Integer))- | otherwise = getScale c cs t y- where xxs = filter isDigit xs- (t,ts) = fromJust . uncons $ xxs- (c,cs) = fromMaybe ('0',"1") . uncons $ ts- getScale c0 ws t0 y0 - | c0 == '1' = (ords t0) (logBase 10 y0) base- | c0 == '2' = (ords t0) (637.0 * atan y0) base -- atan Infinity * 637.0 \approx 1000.0- | c0 == '3' = (ords t0) (sin (k * y0)) (0.01 * base1)- | c0 == '4' = (ords t0) (cos (k * y0)) (0.01 * base1)- | c0 == '5' = (ords t0) (sin (k * y0)) (0.001 * base2)- | c0 == '6' = (ords t0) (cos (k * y0)) (0.001 * base2)- | c0 == '7' = (ords t0) (sin (k * y0)) (-0.01 * base1)- | c0 == '8' = (ords t0) (cos (k * y0)) (-0.01 * base1)- | otherwise = (ords t0) (y0 ** k) base1- where base = fromIntegral . fromMaybe 1 $ (readMaybe ws :: Maybe Integer)- ords t0- | t0 == '2' = (>)- | otherwise = (<)- (w,wws) = fromMaybe ('2',"") . uncons $ ws- base1 = fromIntegral . fromMaybe 50 $ (readMaybe wws :: Maybe Integer)- base2 = fromIntegral . fromMaybe 500 $ (readMaybe wws :: Maybe Integer)- k = fromIntegral . fromMaybe 2 $ (readMaybe [w] :: Maybe Integer)- -partitioningR- :: (InsertLeft t2 (Result [] Char b Double), Monoid (t2 (Result [] Char b Double)), InsertLeft t2 Double, Monoid (t2 Double)) => String- -> t2 (Result [] Char b Double)- -> (t2 (Result [] Char b Double), t2 (Result [] Char b Double))+ decodeCDouble xs !y+ | null xxs = True+ | t < '2' =+ (if t == '0' then (>) else (<))+ y+ (fromIntegral . fromMaybe 1 $ (readMaybe ts :: Maybe Integer))+ | otherwise = getScale c cs t y+ where+ xxs = filter isDigit xs+ (t, ts) = fromJust . uncons $ xxs+ (c, cs) = fromMaybe ('0', "1") . uncons $ ts+ getScale c0 ws t0 y0+ | c0 == '1' = (ords t0) (logBase 10 y0) base+ | c0 == '2' = (ords t0) (637.0 * atan y0) base -- atan Infinity * 637.0 \approx 1000.0+ | c0 == '3' = (ords t0) (sin (k * y0)) (0.01 * base1)+ | c0 == '4' = (ords t0) (cos (k * y0)) (0.01 * base1)+ | c0 == '5' = (ords t0) (sin (k * y0)) (0.001 * base2)+ | c0 == '6' = (ords t0) (cos (k * y0)) (0.001 * base2)+ | c0 == '7' = (ords t0) (sin (k * y0)) (-0.01 * base1)+ | c0 == '8' = (ords t0) (cos (k * y0)) (-0.01 * base1)+ | otherwise = (ords t0) (y0 ** k) base1+ where+ base = fromIntegral . fromMaybe 1 $ (readMaybe ws :: Maybe Integer)+ ords t0+ | t0 == '2' = (>)+ | otherwise = (<)+ (w, wws) = fromMaybe ('2', "") . uncons $ ws+ base1 = fromIntegral . fromMaybe 50 $ (readMaybe wws :: Maybe Integer)+ base2 = fromIntegral . fromMaybe 500 $ (readMaybe wws :: Maybe Integer)+ k = fromIntegral . fromMaybe 2 $ (readMaybe [w] :: Maybe Integer)++partitioningR ::+ ( InsertLeft t2 (Result [] Char b Double)+ , Monoid (t2 (Result [] Char b Double))+ , InsertLeft t2 Double+ , Monoid (t2 Double)+ ) =>+ String ->+ t2 (Result [] Char b Double) ->+ (t2 (Result [] Char b Double), t2 (Result [] Char b Double)) partitioningR !xs dataR- | F.null dataR = (mempty,mempty)- | otherwise = partiR (decodeCDouble xs) dataR+ | F.null dataR = (mempty, mempty)+ | otherwise = partiR (decodeCDouble xs) dataR {-# INLINE partitioningR #-}-{-# SPECIALIZE partitioningR - :: String- -> [Result [] Char Double Double]- -> ([Result [] Char Double Double], [Result [] Char Double Double])#-}+{-# SPECIALIZE partitioningR ::+ String ->+ [Result [] Char Double Double] ->+ ([Result [] Char Double Double], [Result [] Char Double Double])+ #-} -partitioningR2- :: (InsertLeft t2 (Result2 a b Double), Monoid (t2 (Result2 a b Double)), InsertLeft t2 Double, Monoid (t2 Double)) => String- -> t2 (Result2 a b Double)- -> (t2 (Result2 a b Double), t2 (Result2 a b Double))+partitioningR2 ::+ ( InsertLeft t2 (Result2 a b Double)+ , Monoid (t2 (Result2 a b Double))+ , InsertLeft t2 Double+ , Monoid (t2 Double)+ ) =>+ String ->+ t2 (Result2 a b Double) ->+ (t2 (Result2 a b Double), t2 (Result2 a b Double)) partitioningR2 !xs dataR- | F.null dataR = (mempty,mempty)- | otherwise = partiR2 (decodeCDouble xs) dataR+ | F.null dataR = (mempty, mempty)+ | otherwise = partiR2 (decodeCDouble xs) dataR {-# INLINE partitioningR2 #-}-{-# SPECIALIZE partitioningR2 :: (Eq a) => String- -> [Result2 a Double Double]- -> ([Result2 a Double Double], [Result2 a Double Double]) #-}-+{-# SPECIALIZE partitioningR2 ::+ (Eq a) =>+ String ->+ [Result2 a Double Double] ->+ ([Result2 a Double Double], [Result2 a Double Double])+ #-}
Aftovolio/PermutationsArr.hs view
@@ -1,64 +1,84 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Strict #-}+{-# LANGUAGE NoImplicitPrelude #-} --- |--- Module : Aftovolio.PermutationsArr--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Permutations and universal set functions for the phonetic-languages series and phladiprelio of packages--- (AFTOVolio-related). This module uses no vectors, but instead uses arrays.+{- |+Module : Aftovolio.PermutationsArr+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Permutations and universal set functions for the phonetic-languages series and phladiprelio of packages+(AFTOVolio-related). This module uses no vectors, but instead uses arrays.+-} module Aftovolio.PermutationsArr (- universalSetGL- , genPermutations- , genPermutationsArr- , genPermutationsL- , genPermutationsArrL+ universalSetGL,+ genPermutations,+ genPermutationsArr,+ genPermutationsL,+ genPermutationsArrL, ) where -import GHC.Enum-import GHC.List-import GHC.Num (Num,(*), (-))-import GHC.Base-import GHC.Arr-import qualified Data.List as L (permutations,product)+import qualified Data.Foldable as F (Foldable, concat, foldl', foldr') import Data.InsertLeft-import qualified Data.Foldable as F (Foldable,concat,foldr',foldl')+import qualified Data.List as L (permutations, product) import Data.Monoid+import GHC.Arr+import GHC.Base+import GHC.Enum+import GHC.List+import GHC.Num (Num, (*), (-)) -- | A key point of the evaluation -- the universal set of the task represented as a @[[a]]@. universalSetGL ::- (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) => t a- -> t (t a)- -> (t a -> [a]) -- ^ The function that is used internally to convert to the @[a]@ so that the function can process further the permutations- -> ((t (t a)) -> [[a]]) -- ^ The function that is used internally to convert to the needed representation so that the function can process further- -> [Array Int Int] -- ^ The list of permutations of 'Int' indices starting from 0 and up to n (n is probably less than 7).- -> Array Int [a]- -> [[a]]-universalSetGL ts uss f1 f2 permsL baseArr = map (F.concat . F.foldr' (:) [] . (f1 ts:) . (`mappend` f2 uss) . elems . amap (unsafeAt baseArr)) permsL+ (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) =>+ t a ->+ t (t a) ->+ -- | The function that is used internally to convert to the @[a]@ so that the function can process further the permutations+ (t a -> [a]) ->+ -- | The function that is used internally to convert to the needed representation so that the function can process further+ ((t (t a)) -> [[a]]) ->+ -- | The list of permutations of 'Int' indices starting from 0 and up to n (n is probably less than 7).+ [Array Int Int] ->+ Array Int [a] ->+ [[a]]+universalSetGL ts uss f1 f2 permsL baseArr =+ map+ ( F.concat+ . F.foldr' (:) []+ . (f1 ts :)+ . (`mappend` f2 uss)+ . elems+ . amap (unsafeAt baseArr)+ )+ permsL {-# INLINE universalSetGL #-}-{-# SPECIALIZE universalSetGL :: String -> [String] -> (String -> String) -> ([String] -> [String]) -> [Array Int Int] -> Array Int String -> [String] #-}+{-# SPECIALIZE universalSetGL ::+ String ->+ [String] ->+ (String -> String) ->+ ([String] -> [String]) ->+ [Array Int Int] ->+ Array Int String ->+ [String]+ #-} -genPermutations :: (Ord a, Enum a, Num a) => Int -> Array Int [a]-genPermutations n = listArray (0,L.product [1..(n - 1)]) . L.permutations . take n $ [0..]+genPermutations :: (Ord a, Enum a, Num a) => Int -> Array Int [a]+genPermutations n = listArray (0, L.product [1 .. (n - 1)]) . L.permutations . take n $ [0 ..] {-# INLINE genPermutations #-}-{-# SPECIALIZE genPermutations :: Int -> Array Int [Int] #-}+{-# SPECIALIZE genPermutations :: Int -> Array Int [Int] #-} -genPermutationsArr :: (Ord a, Enum a, Num a) => Array Int (Array Int [a])-genPermutationsArr = amap genPermutations . listArray (0,5) $ [2..7]+genPermutationsArr :: (Ord a, Enum a, Num a) => Array Int (Array Int [a])+genPermutationsArr = amap genPermutations . listArray (0, 5) $ [2 .. 7] {-# INLINE genPermutationsArr #-} {-# SPECIALIZE genPermutationsArr :: Array Int (Array Int [Int]) #-} -genPermutationsL :: (Ord a, Enum a, Num a) => Int -> [Array Int a]-genPermutationsL n = map (\xs -> listArray (0,n - 1) xs) . L.permutations . take n $ [0..]+genPermutationsL :: (Ord a, Enum a, Num a) => Int -> [Array Int a]+genPermutationsL n = map (\xs -> listArray (0, n - 1) xs) . L.permutations . take n $ [0 ..] {-# INLINE genPermutationsL #-}-{-# SPECIALIZE genPermutationsL :: Int -> [Array Int Int] #-}+{-# SPECIALIZE genPermutationsL :: Int -> [Array Int Int] #-} -genPermutationsArrL :: (Ord a, Enum a, Num a) => Array Int [Array Int a]-genPermutationsArrL = amap genPermutationsL . listArray (0,5) $ [2..7]+genPermutationsArrL :: (Ord a, Enum a, Num a) => Array Int [Array Int a]+genPermutationsArrL = amap genPermutationsL . listArray (0, 5) $ [2 .. 7] {-# INLINE genPermutationsArrL #-} {-# SPECIALIZE genPermutationsArrL :: Array Int [Array Int Int] #-}-
Aftovolio/PermutationsArrMini.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Strict #-}+{-# LANGUAGE NoImplicitPrelude #-} --- |--- Module : Aftovolio.PermutationsArrMini--- Copyright : (c) OleksandrZhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Special permutations functions for the phonetic-languages and phladiprelio series of packages. This--- module uses no vectors, but instead uses arrays.+{- |+Module : Aftovolio.PermutationsArrMini+Copyright : (c) OleksandrZhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Special permutations functions for the phonetic-languages and phladiprelio series of packages. This+module uses no vectors, but instead uses arrays.+-} module Aftovolio.PermutationsArrMini (- genPairwisePermutations- , pairsSwapP- , genPairwisePermutationsArrN- , genPairwisePermutationsArr- , genPairwisePermutationsLN- , genPairwisePermutationsL- , genPairwisePermutationsArrLN- , genPairwisePermutationsArrL+ genPairwisePermutations,+ pairsSwapP,+ genPairwisePermutationsArrN,+ genPairwisePermutationsArr,+ genPairwisePermutationsLN,+ genPairwisePermutationsL,+ genPairwisePermutationsArrLN,+ genPairwisePermutationsArrL, ) where -import GHC.Enum import Data.Bits (shiftR)+import GHC.Arr import GHC.Base-import GHC.Num+import GHC.Enum import GHC.List-import GHC.Arr+import GHC.Num genPairwisePermutations :: (Ord a, Enum a, Num a) => Int -> Array Int [a]-genPairwisePermutations n = listArray (0, shiftR (n*(n-1)) 1) . pairsSwapP . take n $ [0..]+genPairwisePermutations n = listArray (0, shiftR (n * (n - 1)) 1) . pairsSwapP . take n $ [0 ..] {-# INLINE genPairwisePermutations #-} {-# SPECIALIZE genPairwisePermutations :: Int -> Array Int [Int] #-} pairsSwapP :: (Ord a, Enum a, Num a) => [a] -> [[a]]-pairsSwapP xs = xs:[swap2Ls k m xs | k <- xs, m <- xs , k < m]+pairsSwapP xs = xs : [swap2Ls k m xs | k <- xs, m <- xs, k < m] {-# SPECIALIZE pairsSwapP :: [Int] -> [[Int]] #-} -- | The first two arguments are considered not equal, though it is not checked. swap2ns :: (Eq a) => a -> a -> a -> a swap2ns k m n- | n /= k = if n /= m then n else k- | otherwise = m+ | n /= k = if n /= m then n else k+ | otherwise = m {-# INLINE swap2ns #-} {-# SPECIALIZE swap2ns :: Int -> Int -> Int -> Int #-} @@ -51,33 +51,40 @@ {-# INLINE swap2Ls #-} {-# SPECIALIZE swap2Ls :: Int -> Int -> [Int] -> [Int] #-} -genPairwisePermutationsArrN :: (Ord a, Enum a, Num a) => Int -> Array Int (Array Int [a])-genPairwisePermutationsArrN n = amap genPairwisePermutations . listArray (0,n - 2) $ [2..n]+genPairwisePermutationsArrN ::+ (Ord a, Enum a, Num a) => Int -> Array Int (Array Int [a])+genPairwisePermutationsArrN n = amap genPairwisePermutations . listArray (0, n - 2) $ [2 .. n] {-# INLINE genPairwisePermutationsArrN #-}-{-# SPECIALIZE genPairwisePermutationsArrN :: Int -> Array Int (Array Int [Int]) #-}+{-# SPECIALIZE genPairwisePermutationsArrN ::+ Int -> Array Int (Array Int [Int])+ #-} -genPairwisePermutationsArr :: (Ord a, Enum a, Num a) => Array Int (Array Int [a])+genPairwisePermutationsArr ::+ (Ord a, Enum a, Num a) => Array Int (Array Int [a]) genPairwisePermutationsArr = genPairwisePermutationsArrN 10 {-# INLINE genPairwisePermutationsArr #-} {-# SPECIALIZE genPairwisePermutationsArr :: Array Int (Array Int [Int]) #-} -genPairwisePermutationsLN :: (Ord a, Enum a, Num a) => Int -> [Array Int a]-genPairwisePermutationsLN n = map (\xs -> listArray (0,n - 1) xs) . pairsSwapP . take n $ [0..]+genPairwisePermutationsLN :: (Ord a, Enum a, Num a) => Int -> [Array Int a]+genPairwisePermutationsLN n = map (\xs -> listArray (0, n - 1) xs) . pairsSwapP . take n $ [0 ..] {-# INLINE genPairwisePermutationsLN #-} {-# SPECIALIZE genPairwisePermutationsLN :: Int -> [Array Int Int] #-} -genPairwisePermutationsL :: (Ord a, Enum a, Num a) => [Array Int a]+genPairwisePermutationsL :: (Ord a, Enum a, Num a) => [Array Int a] genPairwisePermutationsL = genPairwisePermutationsLN 10 {-# INLINE genPairwisePermutationsL #-} {-# SPECIALIZE genPairwisePermutationsL :: [Array Int Int] #-} -genPairwisePermutationsArrLN :: (Ord a, Enum a, Num a) => Int -> Array Int [Array Int a]-genPairwisePermutationsArrLN n = amap genPairwisePermutationsLN . listArray (0,n - 2) $ [2..n]+genPairwisePermutationsArrLN ::+ (Ord a, Enum a, Num a) => Int -> Array Int [Array Int a]+genPairwisePermutationsArrLN n = amap genPairwisePermutationsLN . listArray (0, n - 2) $ [2 .. n] {-# INLINE genPairwisePermutationsArrLN #-}-{-# SPECIALIZE genPairwisePermutationsArrLN :: Int -> Array Int [Array Int Int] #-}+{-# SPECIALIZE genPairwisePermutationsArrLN ::+ Int -> Array Int [Array Int Int]+ #-} -genPairwisePermutationsArrL :: (Ord a, Enum a, Num a) => Array Int [Array Int a]+genPairwisePermutationsArrL ::+ (Ord a, Enum a, Num a) => Array Int [Array Int a] genPairwisePermutationsArrL = genPairwisePermutationsArrLN 10 {-# INLINE genPairwisePermutationsArrL #-} {-# SPECIALIZE genPairwisePermutationsArrL :: Array Int [Array Int Int] #-}-
Aftovolio/PermutationsArrMini1.hs view
@@ -1,95 +1,106 @@ {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Strict #-}+{-# LANGUAGE NoImplicitPrelude #-} --- |--- Module : Aftovolio.PermutationsArrMini1--- Copyright : (c) OleksandrZhabenko 2022-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Special permutations functions for the phonetic-languages and phladiprelio series of packages. This--- module uses no vectors, but instead uses arrays.+{- |+Module : Aftovolio.PermutationsArrMini1+Copyright : (c) OleksandrZhabenko 2022-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Special permutations functions for the phonetic-languages and phladiprelio series of packages. This+module uses no vectors, but instead uses arrays.+-} module Aftovolio.PermutationsArrMini1 (- genElementaryPermutations1- , pairsSwapP1- , genElementaryPermutationsArrN1- , genElementaryPermutationsArr1- , genElementaryPermutationsLN1- , genElementaryPermutationsL1- , genElementaryPermutationsArrLN1- , genElementaryPermutationsArrL1+ genElementaryPermutations1,+ pairsSwapP1,+ genElementaryPermutationsArrN1,+ genElementaryPermutationsArr1,+ genElementaryPermutationsLN1,+ genElementaryPermutationsL1,+ genElementaryPermutationsArrLN1,+ genElementaryPermutationsArrL1, ) where -import GHC.Base import GHC.Arr-import GHC.List-import GHC.Num (Num,(-), (+), abs)+import GHC.Base import GHC.Enum+import GHC.List+import GHC.Num (Num, abs, (+), (-)) genElementaryPermutations1 :: (Ord a, Enum a, Num a) => Int -> Array Int [a]-genElementaryPermutations1 n = listArray (0,l-1) xs- where xs = pairsSwapP1 . take n $ [0..]- l = length xs+genElementaryPermutations1 n = listArray (0, l - 1) xs+ where+ xs = pairsSwapP1 . take n $ [0 ..]+ l = length xs {-# INLINE genElementaryPermutations1 #-} {-# SPECIALIZE genElementaryPermutations1 :: Int -> Array Int [Int] #-} -pairsSwapP1 :: (Ord a, Num a) => [a] -> [[a]]-pairsSwapP1 xs = xs:[swap2Ls1 k m xs | k <- xs, m <- xs , abs (k - m) > 1] `mappend` [swap2Ls1 k (k - 1) xs | k <- drop 1 xs ]+pairsSwapP1 :: (Ord a, Num a) => [a] -> [[a]]+pairsSwapP1 xs =+ xs+ : [swap2Ls1 k m xs | k <- xs, m <- xs, abs (k - m) > 1]+ `mappend` [swap2Ls1 k (k - 1) xs | k <- drop 1 xs] {-# SPECIALIZE pairsSwapP1 :: [Int] -> [[Int]] #-} -- | The first two arguments are considered not equal and all three of the arguments are considered greater or equal to 0, though it is not checked.-swap2ns1 :: (Ord a, Num a) => a -> a -> a -> a+swap2ns1 :: (Ord a, Num a) => a -> a -> a -> a swap2ns1 k n m- | n > k =- if- | m < k -> m- | m > n -> m- | m < n -> m + 1- | otherwise -> k- | otherwise =- if- | m > k -> m- | m < n -> m- | m > n -> m - 1- | otherwise -> k+ | n > k =+ if+ | m < k -> m+ | m > n -> m+ | m < n -> m + 1+ | otherwise -> k+ | otherwise =+ if+ | m > k -> m+ | m < n -> m+ | m > n -> m - 1+ | otherwise -> k {-# INLINE swap2ns1 #-} {-# SPECIALIZE swap2ns1 :: Int -> Int -> Int -> Int #-} -swap2Ls1 :: (Ord a, Num a) => a -> a -> [a] -> [a]+swap2Ls1 :: (Ord a, Num a) => a -> a -> [a] -> [a] swap2Ls1 k m = map (swap2ns1 k m) {-# INLINE swap2Ls1 #-} {-# SPECIALIZE swap2Ls1 :: Int -> Int -> [Int] -> [Int] #-} -genElementaryPermutationsArrN1 :: (Ord a, Enum a, Num a) => Int -> Array Int (Array Int [a])-genElementaryPermutationsArrN1 n = amap genElementaryPermutations1 . listArray (0,n - 2) $ [2..n]+genElementaryPermutationsArrN1 ::+ (Ord a, Enum a, Num a) => Int -> Array Int (Array Int [a])+genElementaryPermutationsArrN1 n = amap genElementaryPermutations1 . listArray (0, n - 2) $ [2 .. n] {-# INLINE genElementaryPermutationsArrN1 #-}-{-# SPECIALIZE genElementaryPermutationsArrN1 :: Int -> Array Int (Array Int [Int]) #-}+{-# SPECIALIZE genElementaryPermutationsArrN1 ::+ Int -> Array Int (Array Int [Int])+ #-} -genElementaryPermutationsArr1 :: (Ord a, Enum a, Num a) => Array Int (Array Int [a])+genElementaryPermutationsArr1 ::+ (Ord a, Enum a, Num a) => Array Int (Array Int [a]) genElementaryPermutationsArr1 = genElementaryPermutationsArrN1 10 {-# INLINE genElementaryPermutationsArr1 #-} {-# SPECIALIZE genElementaryPermutationsArr1 :: Array Int (Array Int [Int]) #-} -genElementaryPermutationsLN1 :: (Ord a, Enum a, Num a) => Int -> [Array Int a]-genElementaryPermutationsLN1 n = map (\xs -> listArray (0,n - 1) xs) . pairsSwapP1 . take n $ [0..]+genElementaryPermutationsLN1 :: (Ord a, Enum a, Num a) => Int -> [Array Int a]+genElementaryPermutationsLN1 n = map (\xs -> listArray (0, n - 1) xs) . pairsSwapP1 . take n $ [0 ..] {-# INLINE genElementaryPermutationsLN1 #-} {-# SPECIALIZE genElementaryPermutationsLN1 :: Int -> [Array Int Int] #-} -genElementaryPermutationsL1 :: (Ord a, Enum a, Num a) => [Array Int a]+genElementaryPermutationsL1 :: (Ord a, Enum a, Num a) => [Array Int a] genElementaryPermutationsL1 = genElementaryPermutationsLN1 10 {-# INLINE genElementaryPermutationsL1 #-} {-# SPECIALIZE genElementaryPermutationsL1 :: [Array Int Int] #-} -genElementaryPermutationsArrLN1 :: (Ord a, Enum a, Num a) => Int -> Array Int [Array Int a]-genElementaryPermutationsArrLN1 n = amap genElementaryPermutationsLN1 . listArray (0,n - 2) $ [2..n]+genElementaryPermutationsArrLN1 ::+ (Ord a, Enum a, Num a) => Int -> Array Int [Array Int a]+genElementaryPermutationsArrLN1 n = amap genElementaryPermutationsLN1 . listArray (0, n - 2) $ [2 .. n] {-# INLINE genElementaryPermutationsArrLN1 #-}-{-# SPECIALIZE genElementaryPermutationsArrLN1 :: Int -> Array Int [Array Int Int] #-}+{-# SPECIALIZE genElementaryPermutationsArrLN1 ::+ Int -> Array Int [Array Int Int]+ #-} -genElementaryPermutationsArrL1 :: (Ord a, Enum a, Num a) => Array Int [Array Int a]+genElementaryPermutationsArrL1 ::+ (Ord a, Enum a, Num a) => Array Int [Array Int a] genElementaryPermutationsArrL1 = genElementaryPermutationsArrLN1 10 {-# INLINE genElementaryPermutationsArrL1 #-} {-# SPECIALIZE genElementaryPermutationsArrL1 :: Array Int [Array Int Int] #-}-
Aftovolio/PermutationsRepresent.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE NoImplicitPrelude, StrictData #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} --- |--- Module : Aftovolio.PermutationsRepresent--- Copyright : (c) OleksandrZhabenko 2022-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Permutations data type to mark the needed permutations type from the other modules.+{- |+Module : Aftovolio.PermutationsRepresent+Copyright : (c) OleksandrZhabenko 2022-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Permutations data type to mark the needed permutations type from the other modules.+-} module Aftovolio.PermutationsRepresent (- PermutationsType(..)- , bTransform2Perms+ PermutationsType (..),+ bTransform2Perms, ) where import GHC.Base@@ -20,10 +21,10 @@ data PermutationsType = P Int deriving (Eq, Ord) instance Show PermutationsType where- show (P x) = "+p " `mappend` show x+ show (P x) = "+p " `mappend` show x bTransform2Perms :: [String] -> PermutationsType bTransform2Perms ys- | ys == ["1"] = P 1- | ys == ["2"] = P 2- | otherwise = P 0+ | ys == ["1"] = P 1+ | ys == ["2"] = P 2+ | otherwise = P 0
Aftovolio/RGLPK/General.hs view
@@ -1,75 +1,79 @@-{-# LANGUAGE NoImplicitPrelude, StrictData #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.RGLPK.General--- Copyright : (c) Oleksandr Zhabenko 2020-2024--- 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 : Aftovolio.RGLPK.General+Copyright : (c) Oleksandr Zhabenko 2020-2024+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 Aftovolio.RGLPK.General where -import GHC.Base-import Text.Read-import Data.Maybe import CaseBi.Arr (getBFstL')+import Data.Bits (shiftR) 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 Text.Show (Show(..))+import Data.Maybe+import GHC.Arr+import GHC.Base+import GHC.Num (abs, (*), (+), (-))+import Numeric+import Text.Read+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))+ | 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+ | 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) . elemIndex x $ js- rs = if iX < 0 then [] else replicate iX 0 `mappend` (1:replicate (l - 1 - iX) 0)+ where+ l = length js+ iX = fromMaybe (-l - 1) . elemIndex x $ js+ rs = if iX < 0 then [] else replicate iX 0 `mappend` (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@.+{- | 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@@ -91,188 +95,307 @@ 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 "Aftovolio.RGLPK.General.pairs': Not defined for the arguments. "+ | isCorrectPWC y =+ let z = find ((== x) . charPW) . pwsC $ y+ in if isJust z+ then listPW . fromJust $ z+ else replicate n 0+ | otherwise =+ error "Aftovolio.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 ::+ -- | The number of 'pairs'' function elements in the lists.+ Int ->+ -- | Actually the data type value that sets the behaviour of the 'pairs'' function.+ PairwiseC ->+ [String] ->+ -- | A sorted list of the 'Char' representations of the phonetic language phenomenae.+ String ->+ 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+ | 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 ::+ -- | 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 ->+ -- | List of pairs of indices that shows how the input data is related to the representation+ -- (which coefficients relates to which representation elements).+ [(Int, Int)] ->+ -- | An array of coefficients.+ Array Int Double ->+ String objLine lng xs arr- | numElements arr >= lng = mconcat ["obj1 <- c(", intercalate ", " . map (\t -> showFFloat Nothing t "") . objCoeffsNew lng xs $ arr,- ")", newLineEnding]- | otherwise = error "Aftovolio.RGLPK.General.objLine: Not defined for the short argument. "+ | numElements arr >= lng =+ mconcat+ [ "obj1 <- c("+ , intercalate ", " . map (\t -> showFFloat Nothing t "") . objCoeffsNew lng xs $+ arr+ , ")"+ , newLineEnding+ ]+ | otherwise =+ error "Aftovolio.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]+objCoeffsNew ::+ -- | 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 ->+ -- | List of pairs of indices that shows how the input data is related to the representation+ -- (which coefficients relates to which representation elements).+ [(Int, Int)] ->+ -- | An array of coefficients.+ Array Int Double ->+ [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 $ ", \"<=\""+dirLine ::+ -- | 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.+ Int ->+ -- | An argument of the 'matrixLine' function.+ [String] ->+ -- | A sorted list of the 'Char' representations of the phonetic language phenomenae.+ String ->+ 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)+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)]+rhsLine ::+ -- | 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.+ Int ->+ -- | 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.+ Double ->+ -- | 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).+ [Int] ->+ [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 "Aftovolio.RGLPK.General.objLine: Not defined for these arguments. "- sps2- | maximum sps1 <= lng - 1 = filter (>= 0) sps1 \\ xs2- | otherwise = error "Aftovolio.RGLPK.General.objLine: Not defined for these arguments. "- h i- | i `elem` xs2 = mn1- | i `elem` sps2 = mnSpecial- | otherwise = mnG+minDurations ::+ -- | 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 ->+ -- | 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.+ Double ->+ -- | 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).+ [Int] ->+ [Double]+minDurations lng mn1 mnSpecial mnG xs1 sps1 = map h [0 .. lng - 1]+ where+ xs2+ | maximum xs1 <= lng - 1 = filter (>= 0) xs1+ | otherwise =+ error "Aftovolio.RGLPK.General.objLine: Not defined for these arguments. "+ sps2+ | maximum sps1 <= lng - 1 = filter (>= 0) sps1 \\ xs2+ | otherwise =+ error "Aftovolio.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 ::+ -- | 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 ->+ -- | Maximum duration of the phonetic language element representation in seconds.+ Double ->+ [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+{- | 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 ::+ -- | 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.+ Int ->+ -- | Actually the data type value that sets the behaviour of the 'pairs'' function.+ PairwiseC ->+ -- | Maximum duration of the phonetic language element representation in seconds.+ Double ->+ -- | List of pairs of indices that shows how the input data is related to the representation+ -- (which coefficients relates to which representation elements).+ [(Int, Int)] ->+ -- | 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.+ Double ->+ -- | 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).+ [Int] ->+ -- | An array of coefficients.+ Array Int Double ->+ -- | An argument of the 'matrixLine' function.+ [String] ->+ [Double] ->+ [Double] ->+ -- | A sorted list of the 'Char' representations of the phonetic language phenomenae.+ String ->+ 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, "\")}"]+answer2 ::+ -- | 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.+ Int ->+ -- | Actually the data type value that sets the behaviour of the 'pairs'' function.+ PairwiseC ->+ -- | Maximum duration of the phonetic language element representation in seconds.+ Double ->+ -- | List of pairs of indices that shows how the input data is related to the representation+ -- (which coefficients relates to which representation elements).+ [(Int, Int)] ->+ -- | 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.+ Double ->+ -- | 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).+ [Int] ->+ -- | An array of coefficients.+ Array Int Double ->+ -- | An argument of the 'matrixLine' function.+ [String] ->+ [Double] ->+ [Double] ->+ -- | A sorted list of the 'Char' representations of the phonetic language phenomenae.+ String ->+ 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--
Aftovolio/StrictVG.hs view
@@ -1,59 +1,92 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-} --- |--- Module : Aftovolio.StrictVG--- Copyright : (c) Oleksandr Zhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Simplified version of the @phonetic-languages-common@ package.--- Uses less dependencies.--{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}+{- |+Module : Aftovolio.StrictVG+Copyright : (c) Oleksandr Zhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Simplified version of the @phonetic-languages-common@ package.+Uses less dependencies.+-} module Aftovolio.StrictVG (- -- * Working with lists- uniquenessVariants2GNBL- , uniquenessVariants2GNPBL+ -- * Working with lists+ uniquenessVariants2GNBL,+ uniquenessVariants2GNPBL, ) where -import GHC.Base-import GHC.Num ((-)) import Aftovolio.PermutationsArr import qualified Data.Foldable as F-import Data.InsertLeft (InsertLeft(..)) +import Data.InsertLeft (InsertLeft (..)) import GHC.Arr+import GHC.Base+import GHC.Num ((-)) uniquenessVariants2GNBL ::- (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) => a -- ^ The first most common element in the \"whitespace symbols\" structure- -> (t a -> [a]) -- ^ The function that is used internally to convert to the @[a]@ so that the function can process further the permutations- -> ((t (t a)) -> [[a]]) -- ^ The function that is used internally to convert to the @[[a]]@ so that the function can process further- -> ([a] -> t a) -- ^ The function that is used internally to convert to the needed representation so that the function can process further- -> [Array Int Int] -- ^ The permutations of 'Int' indices starting from 0 and up to n (n is probably less than 8).- -> t (t a) -- ^ Must be obtained as 'subG' @whspss xs@ or in equivalent way- -> [t a]+ (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) =>+ -- | The first most common element in the \"whitespace symbols\" structure+ a ->+ -- | The function that is used internally to convert to the @[a]@ so that the function can process further the permutations+ (t a -> [a]) ->+ -- | The function that is used internally to convert to the @[[a]]@ so that the function can process further+ ((t (t a)) -> [[a]]) ->+ -- | The function that is used internally to convert to the needed representation so that the function can process further+ ([a] -> t a) ->+ -- | The permutations of 'Int' indices starting from 0 and up to n (n is probably less than 8).+ [Array Int Int] ->+ -- | Must be obtained as 'subG' @whspss xs@ or in equivalent way+ t (t a) ->+ [t a] uniquenessVariants2GNBL !hd f1 f2 f3 perms !subs = uniquenessVariants2GNPBL mempty mempty hd f1 f2 f3 perms subs {-# INLINE uniquenessVariants2GNBL #-}-{-# SPECIALIZE uniquenessVariants2GNBL :: Char -> (String -> String) -> ([String] -> [String]) -> (String -> String) -> [Array Int Int] -> [String] -> [String] #-}+{-# SPECIALIZE uniquenessVariants2GNBL ::+ Char ->+ (String -> String) ->+ ([String] -> [String]) ->+ (String -> String) ->+ [Array Int Int] ->+ [String] ->+ [String]+ #-} uniquenessVariants2GNPBL ::- (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) => t a- -> t a- -> a -- ^ The first most common element in the whitespace symbols structure- -> (t a -> [a]) -- ^ The function that is used internally to convert to the @[a]@ so that the function can process further the permutations- -> ((t (t a)) -> [[a]]) -- ^ The function that is used internally to convert to the @[[a]]@ so that the function can process further- -> ([a] -> t a) -- ^ The function that is used internally to convert to the needed representation that the function can process further- -> [Array Int Int] -- ^ The permutations of 'Int' indices starting from 0 and up to n (n is probably less than 8).- -> t (t a) -- ^ Must be obtained as @subG whspss xs@ or in equivalent way- -> [t a]+ (Eq a, F.Foldable t, InsertLeft t a, Monoid (t a), Monoid (t (t a))) =>+ t a ->+ t a ->+ -- | The first most common element in the whitespace symbols structure+ a ->+ -- | The function that is used internally to convert to the @[a]@ so that the function can process further the permutations+ (t a -> [a]) ->+ -- | The function that is used internally to convert to the @[[a]]@ so that the function can process further+ ((t (t a)) -> [[a]]) ->+ -- | The function that is used internally to convert to the needed representation that the function can process further+ ([a] -> t a) ->+ -- | The permutations of 'Int' indices starting from 0 and up to n (n is probably less than 8).+ [Array Int Int] ->+ -- | Must be obtained as @subG whspss xs@ or in equivalent way+ t (t a) ->+ [t a] uniquenessVariants2GNPBL !ts !us !hd f1 f2 f3 perms !subs- | F.null subs = mempty- | otherwise = map f3 ns- where !uss = (hd %@ us) %^ mempty- !base0 = map (hd %@) . f2 $ subs- !l = F.length base0- !baseArr = listArray (0,l - 1) base0- !ns = universalSetGL ts uss f1 f2 perms baseArr -- in map f3 ns+ | F.null subs = mempty+ | otherwise = map f3 ns+ where+ !uss = (hd %@ us) %^ mempty+ !base0 = map (hd %@) . f2 $ subs+ !l = F.length base0+ !baseArr = listArray (0, l - 1) base0+ !ns = universalSetGL ts uss f1 f2 perms baseArr -- in map f3 ns {-# INLINE uniquenessVariants2GNPBL #-}-{-# SPECIALIZE uniquenessVariants2GNPBL :: String -> String -> Char -> (String -> String) -> ([String] -> [String]) -> (String -> String) -> [Array Int Int] -> [String] -> [String] #-}+{-# SPECIALIZE uniquenessVariants2GNPBL ::+ String ->+ String ->+ Char ->+ (String -> String) ->+ ([String] -> [String]) ->+ (String -> String) ->+ [Array Int Int] ->+ [String] ->+ [String]+ #-}
Aftovolio/Tests.hs view
@@ -3,93 +3,93 @@ module Aftovolio.Tests where import GHC.Base-import GHC.Int (Int8) import GHC.Enum (toEnum)-import GHC.Real (quot,rem)-import GHC.Num ((+),(-),(*))+import GHC.Int (Int8) import GHC.List (elem)+import GHC.Num ((*), (+), (-))+import GHC.Real (quot, rem) sel :: Int -> [[Int8]]-sel x - | x == 1 || x < 0 || x > 179 = []- | x == 0 || x == 4 = [[1],[2,1],[3,2],[4,3,2],[5,4,3],[6,5,4,3,2]] -- all cases are present: 2, 3, 4, 5, 6, 7. Therefore, the slowest ones.- | x == 2 || x == 5 = [[1],[2],[3],[4,3],[5,4],[6,5,4]]- | x == 7 = [[0],[1,0],[1,0],[1,0],[1,0],[1,0]]- | x == 8 = [[0],[1,0],[1,0],[2,1,0],[2,1,0],[2,1,0]]- | x == 9 = [[0],[1,0],[1,0],[2,1,0],[3,2,1,0],[3,2,1,0]]-------------------------------------------------------------------- | x >= 20 && x <= 26 && x /= 21 = [[1]] -- at least 7 is omitted, but probably 6, or even 5, or even 4, or even 3. 2 is however present.- | x >= 27 && x <= 29 = [[0]]- | x == 30 || x == 34 = [[1],[2,1]]- | x == 32 || x == 35 = [[1],[2]]- | x >= 37 && x <= 39 = [[0],[1,0]]- | x == 40 || x == 44 = [[1],[2,1],[3,2]]- | x == 42 || x == 45 = [[1],[2],[3]]- | x >= 47 && x <= 49 = [[0],[1,0],[1,0]]- | x == 50 || x == 54 = [[1],[2,1],[3,2],[4,3,2]]- | x == 52 || x == 55 = [[1],[2],[3],[4,3]]- | x == 57 = [[0],[1,0],[1,0],[1,0]]- | x == 58 || x == 59 = [[0],[1,0],[1,0],[2,1,0]]- | x == 60 || x == 64 = [[1],[2,1],[3,2],[4,3,2],[5,4,3]]- | x == 62 || x == 65 = [[1],[2],[3],[4,3],[5,4]]- | x == 67 = [[0],[1,0],[1,0],[1,0],[1,0]]- | x == 68 = [[0],[1,0],[1,0],[2,1,0],[2,1,0]]- | x == 69 = [[0],[1,0],[1,0],[2,1,0],[3,2,1,0]]-------------------------------------------------------- | x == 70 || x == 74 = [[2,1],[3,2],[4,3,2],[5,4,3],[6,5,4,3,2]] -- at least 2 is omitted, but probably 3 and even 4. 5, 6 and 7 are present.- | x == 72 || x == 75 = [[2],[3],[4,3],[5,4],[6,5,4]]- | x == 77 = [[1,0],[1,0],[1,0],[1,0],[1,0]]- | x == 78 = [[1,0],[1,0],[2,1,0],[2,1,0],[2,1,0]]- | x == 79 = [[1,0],[1,0],[2,1,0],[3,2,1,0],[3,2,1,0]]- | x == 80 || x == 84 = [[3,2],[4,3,2],[5,4,3],[6,5,4,3,2]]- | x == 82 || x == 85 = [[3],[4,3],[5,4],[6,5,4]]- | x == 87 = [[1,0],[1,0],[1,0],[1,0]]- | x == 88 = [[1,0],[2,1,0],[2,1,0],[2,1,0]]- | x == 89 = [[1,0],[2,1,0],[3,2,1,0],[3,2,1,0]]- | x == 90 || x == 94 = [[4,3,2],[5,4,3],[6,5,4,3,2]]- | x == 92 || x == 95 = [[4,3],[5,4],[6,5,4]]- | x == 97 = [[1,0],[1,0],[1,0]]- | x == 98 = [[2,1,0],[2,1,0],[2,1,0]]- | x == 99 = [[2,1,0],[3,2,1,0],[3,2,1,0]]-------------------------------------------------------------------------- | x == 100 || x == 104 = [[1],[2,1],[4,3,2],[6,5,4,3,2]] -- 4 and 6 are omitted, just present the ones from: 2, 3, 5, 7.- | x == 102 || x == 105 = [[1],[2],[4,3],[6,5,4]]- | x == 107 = [[0],[1,0],[1,0],[1,0]]- | x == 108 = [[0],[1,0],[2,1,0],[2,1,0]]- | x == 109 = [[0],[1,0],[2,1,0],[3,2,1,0]]-------------------------------------------------------------------- | x == 150 || x == 154 = [[1],[2,1],[4,3,2]] -- 4, 6, 7 are omitted but 2, 3, 5 are present.- | x == 152 || x == 155 = [[1],[2],[4,3]]- | x == 157 = [[0],[1,0],[1,0]]- | x == 158 || x == 159 = [[0],[1,0],[2,1,0]]-------------------------------------------------------- | x == 170 || x == 174 = [[2,1],[4,3,2],[6,5,4,3,2]] -- just 3, 5 and 7 are present- | x == 172 || x == 175 = [[2],[4,3],[6,5,4]]- | x == 177 = [[1,0],[1,0],[1,0]]- | x == 178 = [[1,0],[2,1,0],[2,1,0]]- | x == 179 = [[1,0],[2,1,0],[3,2,1,0]]------------------------------------------------------------------------ - | otherwise = [[1],[1],[2,1],[3,2,1],[3,2],[4,3,2]]+sel x+ | x == 1 || x < 0 || x > 179 = []+ | x == 0 || x == 4 = [[1], [2, 1], [3, 2], [4, 3, 2], [5, 4, 3], [6, 5, 4, 3, 2]] -- all cases are present: 2, 3, 4, 5, 6, 7. Therefore, the slowest ones.+ | x == 2 || x == 5 = [[1], [2], [3], [4, 3], [5, 4], [6, 5, 4]]+ | x == 7 = [[0], [1, 0], [1, 0], [1, 0], [1, 0], [1, 0]]+ | x == 8 = [[0], [1, 0], [1, 0], [2, 1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 9 = [[0], [1, 0], [1, 0], [2, 1, 0], [3, 2, 1, 0], [3, 2, 1, 0]]+ ------------------------------------------------------------------+ | x >= 20 && x <= 26 && x /= 21 = [[1]] -- at least 7 is omitted, but probably 6, or even 5, or even 4, or even 3. 2 is however present.+ | x >= 27 && x <= 29 = [[0]]+ | x == 30 || x == 34 = [[1], [2, 1]]+ | x == 32 || x == 35 = [[1], [2]]+ | x >= 37 && x <= 39 = [[0], [1, 0]]+ | x == 40 || x == 44 = [[1], [2, 1], [3, 2]]+ | x == 42 || x == 45 = [[1], [2], [3]]+ | x >= 47 && x <= 49 = [[0], [1, 0], [1, 0]]+ | x == 50 || x == 54 = [[1], [2, 1], [3, 2], [4, 3, 2]]+ | x == 52 || x == 55 = [[1], [2], [3], [4, 3]]+ | x == 57 = [[0], [1, 0], [1, 0], [1, 0]]+ | x == 58 || x == 59 = [[0], [1, 0], [1, 0], [2, 1, 0]]+ | x == 60 || x == 64 = [[1], [2, 1], [3, 2], [4, 3, 2], [5, 4, 3]]+ | x == 62 || x == 65 = [[1], [2], [3], [4, 3], [5, 4]]+ | x == 67 = [[0], [1, 0], [1, 0], [1, 0], [1, 0]]+ | x == 68 = [[0], [1, 0], [1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 69 = [[0], [1, 0], [1, 0], [2, 1, 0], [3, 2, 1, 0]]+ ------------------------------------------------------+ | x == 70 || x == 74 = [[2, 1], [3, 2], [4, 3, 2], [5, 4, 3], [6, 5, 4, 3, 2]] -- at least 2 is omitted, but probably 3 and even 4. 5, 6 and 7 are present.+ | x == 72 || x == 75 = [[2], [3], [4, 3], [5, 4], [6, 5, 4]]+ | x == 77 = [[1, 0], [1, 0], [1, 0], [1, 0], [1, 0]]+ | x == 78 = [[1, 0], [1, 0], [2, 1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 79 = [[1, 0], [1, 0], [2, 1, 0], [3, 2, 1, 0], [3, 2, 1, 0]]+ | x == 80 || x == 84 = [[3, 2], [4, 3, 2], [5, 4, 3], [6, 5, 4, 3, 2]]+ | x == 82 || x == 85 = [[3], [4, 3], [5, 4], [6, 5, 4]]+ | x == 87 = [[1, 0], [1, 0], [1, 0], [1, 0]]+ | x == 88 = [[1, 0], [2, 1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 89 = [[1, 0], [2, 1, 0], [3, 2, 1, 0], [3, 2, 1, 0]]+ | x == 90 || x == 94 = [[4, 3, 2], [5, 4, 3], [6, 5, 4, 3, 2]]+ | x == 92 || x == 95 = [[4, 3], [5, 4], [6, 5, 4]]+ | x == 97 = [[1, 0], [1, 0], [1, 0]]+ | x == 98 = [[2, 1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 99 = [[2, 1, 0], [3, 2, 1, 0], [3, 2, 1, 0]]+ ------------------------------------------------------------------------+ | x == 100 || x == 104 = [[1], [2, 1], [4, 3, 2], [6, 5, 4, 3, 2]] -- 4 and 6 are omitted, just present the ones from: 2, 3, 5, 7.+ | x == 102 || x == 105 = [[1], [2], [4, 3], [6, 5, 4]]+ | x == 107 = [[0], [1, 0], [1, 0], [1, 0]]+ | x == 108 = [[0], [1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 109 = [[0], [1, 0], [2, 1, 0], [3, 2, 1, 0]]+ ------------------------------------------------------------------+ | x == 150 || x == 154 = [[1], [2, 1], [4, 3, 2]] -- 4, 6, 7 are omitted but 2, 3, 5 are present.+ | x == 152 || x == 155 = [[1], [2], [4, 3]]+ | x == 157 = [[0], [1, 0], [1, 0]]+ | x == 158 || x == 159 = [[0], [1, 0], [2, 1, 0]]+ ------------------------------------------------------+ | x == 170 || x == 174 = [[2, 1], [4, 3, 2], [6, 5, 4, 3, 2]] -- just 3, 5 and 7 are present+ | x == 172 || x == 175 = [[2], [4, 3], [6, 5, 4]]+ | x == 177 = [[1, 0], [1, 0], [1, 0]]+ | x == 178 = [[1, 0], [2, 1, 0], [2, 1, 0]]+ | x == 179 = [[1, 0], [2, 1, 0], [3, 2, 1, 0]]+ -----------------------------------------------------------------------+ | otherwise = [[1], [1], [2, 1], [3, 2, 1], [3, 2], [4, 3, 2]]+ -------------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------------- sel2 :: Int -> [Int8]-sel2 y - | y == 1 || y < 0 || y > 179 = []- | (rem y 10 `elem` [1,3,6]) || y >= 0 && y <= 9 = [2..7]- | y >= 20 && y <= 69 = [2..toEnum (y `quot` 10)]- | y >= 70 && y <= 99 = [toEnum (y `quot` 10) - 4..7]- | y >= 100 && y <= 109 = [2,3,5,7]- | y >= 150 && y <= 159 = [2,3,5]- | y >= 170 && y <= 179 = [3,5,7]- | otherwise = [2..7]+sel2 y+ | y == 1 || y < 0 || y > 179 = []+ | (rem y 10 `elem` [1, 3, 6]) || y >= 0 && y <= 9 = [2 .. 7]+ | y >= 20 && y <= 69 = [2 .. toEnum (y `quot` 10)]+ | y >= 70 && y <= 99 = [toEnum (y `quot` 10) - 4 .. 7]+ | y >= 100 && y <= 109 = [2, 3, 5, 7]+ | y >= 150 && y <= 159 = [2, 3, 5]+ | y >= 170 && y <= 179 = [3, 5, 7]+ | otherwise = [2 .. 7] -minMax11ByCList :: Ord a => (a -> a -> Ordering) -> [a] -> (a, a) -- Is rewritten from the 'Data.MinMax.Preconditions.minMax11ByC' from @subG@ package.-minMax11ByCList g xs@(x:y:ys) = foldr f (if x > y then (y, x) else (x, y)) ys- where f z (x,y)- | g z x == LT = (z,y)- | g z y == GT = (x,z)- | otherwise = (x,y)+minMax11ByCList :: (Ord a) => (a -> a -> Ordering) -> [a] -> (a, a) -- Is rewritten from the 'Data.MinMax.Preconditions.minMax11ByC' from @subG@ package.+minMax11ByCList g xs@(x : y : ys) = foldr f (if x > y then (y, x) else (x, y)) ys+ where+ f z (x, y)+ | g z x == LT = (z, y)+ | g z y == GT = (x, z)+ | otherwise = (x, y) minMax11ByCList _ _ = undefined -- Is not intended to be used for lists with less than two elements.--
Aftovolio/Ukrainian/Common2.hs view
@@ -1,46 +1,62 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude, StrictData #-} --- |--- Module : Aftovolio.Ukrainian.Common2--- Copyright : (c) Oleksandr Zhabenko 2021-2023--- License : MIT--- Maintainer : oleksandr.zhabenko@yahoo.com------ Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis--- especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr--- for optimization purposes. Contains the common for two modules definitions.--- Phonetic material is taken from the :------ Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of--- the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf---+{- |+Module : Aftovolio.Ukrainian.Common2+Copyright : (c) Oleksandr Zhabenko 2021-2023+License : MIT+Maintainer : oleksandr.zhabenko@yahoo.com++Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis+especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr+for optimization purposes. Contains the common for two modules definitions.+Phonetic material is taken from the :++Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of+the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf+-} module Aftovolio.Ukrainian.Common2 where -import GHC.Base-import GHC.List (zip, repeat) import CaseBi.Arr-import GHC.Arr (Array(..))-import Text.Show (Show(..))+import GHC.Arr (Array (..))+import GHC.Base+import GHC.List (repeat, zip)+import Text.Show (Show (..)) {- -- Inspired by: https://mail.haskell.org/pipermail/beginners/2011-October/008649.html -- -} data Triple = Z | O | T- deriving (Eq,Ord,Show)+ deriving (Eq, Ord, Show) isUkrainianL :: Char -> Bool-isUkrainianL y | (y >= '\1070' && y <= '\1097') = True- | otherwise = getBFstLSorted' False (map (\x -> (x, True)) "'-\700\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217") y+isUkrainianL y+ | (y >= '\1070' && y <= '\1097') = True+ | otherwise =+ getBFstLSorted'+ False+ ( map+ (\x -> (x, True))+ "'-\700\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217"+ )+ y isUkrainianLTup :: Array Int (Char, Bool) -> Char -> Bool isUkrainianLTup !tup15 y- | (y >= '\1070' && y <= '\1097') = True- | otherwise = getBFst' (False, tup15) y+ | (y >= '\1070' && y <= '\1097') = True+ | otherwise = getBFst' (False, tup15) y isConsNotJ :: Char -> Bool-isConsNotJ = getBFstLSorted' False (zip "\1073\1074\1075\1076\1078\1079\1082\1083\1084\1085\1087\1088\1089\1090\1092\1093\1094\1095\1096\1097\1169" (repeat True))+isConsNotJ =+ getBFstLSorted'+ False+ ( zip+ "\1073\1074\1075\1076\1078\1079\1082\1083\1084\1085\1087\1088\1089\1090\1092\1093\1094\1095\1096\1097\1169"+ (repeat True)+ ) -isConsNotJTup :: Array Int (Char,Bool) -> Char -> Bool+isConsNotJTup :: Array Int (Char, Bool) -> Char -> Bool isConsNotJTup !tup16 = getBFst' (False, tup16)
Aftovolio/Ukrainian/IO.hs view
@@ -1,221 +1,517 @@-{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, DeriveGeneric, StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE NoImplicitPrelude #-} module Aftovolio.Ukrainian.IO where -import GHC.Arr-import GHC.Base -import GHC.Word-import GHC.Num (Num(..),Integer,(+),(-),(*))-import GHC.Real (Integral(..),fromIntegral,(/),rem,quotRem,round,(^))-import GHC.Generics-import GHC.Enum (fromEnum)-import Text.Show (Show(..))-import Text.Read (readMaybe)-import Data.Ord (Down(..)) -import Data.Char (isDigit,toLower,isSpace)-import System.IO (putStrLn, FilePath,stdout,hSetNewlineMode,universalNewlineMode,getLine,appendFile,writeFile,putStr,readFile)-import qualified Rhythmicity.MarkerSeqs as R --hiding (id)-import Data.List hiding (foldr,null)-import qualified Data.List as L (null) -import Data.Foldable (mapM_)-import Data.Maybe (isNothing,fromJust,fromMaybe) -import Data.Tuple (fst,snd)-import Aftovolio.Ukrainian.Syllable -import Aftovolio.Ukrainian.SyllableWord8-import Aftovolio.Ukrainian.Melodics -import GHC.Int (Int8)-import CaseBi.Arr (getBFst')-import Aftovolio.Ukrainian.ReadDurations-import Data.Ord (comparing)-import Numeric (showFFloat)+-- hiding (id)++import Aftovolio.General.Datatype3+import Aftovolio.General.Distance import Aftovolio.Halfsplit-import System.Directory (readable,writable,getPermissions,Permissions(..),doesFileExist,getCurrentDirectory)-import Data.ReversedScientific-import Control.Concurrent.Async (mapConcurrently) import Aftovolio.Tests-import Data.MinMax1 -import Aftovolio.General.Datatype3 -import Aftovolio.General.Distance+import Aftovolio.Ukrainian.Melodics+import Aftovolio.Ukrainian.ReadDurations+import Aftovolio.Ukrainian.Syllable+import Aftovolio.Ukrainian.SyllableWord8 import Aftovolio.UniquenessPeriodsG+import CaseBi.Arr (getBFst')+import Control.Concurrent.Async (mapConcurrently)+import Control.DeepSeq import Control.Exception-import Control.DeepSeq +import Data.Char (isDigit, isSpace, toLower)+import Data.Foldable (mapM_)+import Data.List hiding (foldr, null)+import qualified Data.List as L (null)+import Data.Maybe (fromJust, fromMaybe, isNothing)+import Data.MinMax1+import Data.Ord (Down (..), comparing)+import Data.ReversedScientific+import Data.Tuple (fst, snd)+import GHC.Arr+import GHC.Base+import GHC.Enum (fromEnum)+import GHC.Generics+import GHC.Int (Int8)+import GHC.Num (Integer, Num (..), (*), (+), (-))+import GHC.Real (Integral (..), fromIntegral, quotRem, rem, round, (/), (^))+import GHC.Word+import Numeric (showFFloat)+import qualified Rhythmicity.MarkerSeqs as R+import System.Directory (+ Permissions (..),+ doesFileExist,+ getCurrentDirectory,+ getPermissions,+ readable,+ writable,+ )+import System.IO (+ FilePath,+ appendFile,+ getLine,+ hSetNewlineMode,+ putStr,+ putStrLn,+ readFile,+ stdout,+ universalNewlineMode,+ writeFile,+ )+import Text.Read (readMaybe)+import Text.Show (Show (..)) -generalF- :: Int -- ^ A power of 10. The distance value is quoted by 10 in this power if the next ['Word8'] argument is not empty. The default one is 0. The right values are in the range [0..4].- -> Int -- ^ A 'length' of the next argument here.- -> Compards -- ^ A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.- -> Bool -- ^ If 'True' then adds \"<br>\" to line endings for double column output- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> FilePath -- ^ A path to the file to save double columns output to. If empty then just prints to 'stdout'.- -> String -- ^ If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'- -> (String, String) -- ^ If the next element is not equal to -1, then the prepending and appending lines to be displayed. Used basically for working with the multiline textual input data.- -> Int -- ^ The number of the line in the file to be read the lines from. If equal to -1 then neither reading from the file is done nor the first argument influences the processment results.- -> FilePath -- ^ The file to read the sound representation durations from.- -> Int - -> R.HashCorrections - -> (Int8,[Int8]) - -> Int - -> Bool - -> Int - -> Bool - -> Int8 - -> (FilePath, Int) - -> Bool -- ^ Whether to run tests concurrently or not. 'True' corresponds to concurrent execution that can speed up the getting results but use more resources.- -> String -- ^ An initial string to be analysed.- -> [String] - -> IO [String]-generalF power10 ldc compards html filtering dcfile selStr (prestr, poststr) lineNmb file numTest hc (grps,mxms) k descending hashStep emptyline splitting (fs,code) concurrently initstr universalSet@(_:_:_) = do- syllableDurationsDs <- readSyllableDurations file- let syllN = countSyll initstr- f ldc compards syllableDurationsDs grps mxms -- Since the version 0.12.0.0, has a possibility to evaluate diversity property.- | L.null selStr = (if doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]-> Bool) compards then (sum . R.countHashes2G hashStep hc grps mxms) else (`quot` 10^power10) . fromIntegral . sumAbsDistNormComp compards . (if isWord8Based compards then C1 else C2 . fromSmallWord8toInt8Diff)) . read3 (not . L.null . filter (not . isSpace)) 1.0 (mconcat . (if L.null file then case k of { 1 -> syllableDurationsD; 2 -> syllableDurationsD2; 3 -> syllableDurationsD3; 4 -> syllableDurationsD4} - else if length syllableDurationsDs >= k then syllableDurationsDs !! (k - 1) else syllableDurationsD2) . createSyllablesUkrS) - | otherwise = fromIntegral . diverse2GGL (selectSounds selStr) [100,101] . convertToProperUkrainianI8 . filter (\c -> not (isDigit c) && c /= '_' && c/= '=')- hSetNewlineMode stdout universalNewlineMode- if numTest >= 0 && numTest <= 179 && numTest /= 1 && doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]-> Bool) compards then testsOutput concurrently syllN filtering f ldc syllableDurationsDs numTest universalSet- else let sRepresent = zipWith (\k (x, ys) -> S k x ys) [1..] . - (if descending then sortOn (\(u,w) -> (Down u, w)) else sortOn id) . map (\xss -> (f ldc compards syllableDurationsDs grps mxms xss, xss)) $ universalSet- strOutput = force . (:[]) . halfsplit1G (\(S _ y _) -> y) filtering (if html then "<br>" else "") (jjj splitting) $ sRepresent- in do- let lns1 = unlines strOutput- putStrLn lns1- if L.null dcfile then putStr "" - else do - exist <- doesFileExist dcfile - if exist then do - perms <- getPermissions dcfile - if writable perms then writeFile dcfile lns1 - else error $ "Aftovolio.Ukrainian.IO.generalF: File " `mappend` dcfile `mappend` " is not writable!"- else do - currdir <- getCurrentDirectory- perms <- getPermissions currdir- if writable perms then writeFile dcfile lns1 - else error $ "Aftovolio.Ukrainian.IO.generalF: Directory of the file " `mappend` dcfile `mappend` " is not writable!"- let l1 = length sRepresent- if code == -1 - then if lineNmb == -1 then return strOutput- else do - print23 filtering prestr poststr 1 [initstr]- return strOutput- else do - print23 filtering prestr poststr 1 [initstr]- parseLineNumber l1 >>= \num -> do- permiss <- getPermissions fs- let writ = writable permiss- readab = readable permiss- if writ && readab then outputWithFile selStr compards sRepresent file syllableDurationsDs code grps k fs num - else error "Aftovolio.Ukrainian.IO.generalF: The specified file cannot be used for appending the text! Please, specify another file!"- return []- where jjj kk = let (q1,r1) = quotRem kk (if kk < 0 then -10 else 10) in jjj' q1 r1 emptyline- jjj' q1 r1 emptyline- | r1 == (-1) || r1 == (-3) = -10*q1 + (if emptyline then -5 else r1)- | r1 == 1 || r1 == 3 = 10*q1 + (if emptyline then 5 else r1)- | r1 < 0 = -10*q1 + (if emptyline then -4 else r1)- | otherwise = 10*q1 + (if emptyline then 4 else r1)-generalF _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ [u1] = do- putStrLn u1- return [u1]-generalF _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = let strOutput = ["You have specified the data and constraints on it that lead to no further possible options.", "Please, specify another data and constraints."] in do - putStrLn . unlines $ strOutput- return strOutput+generalF ::+ -- | A power of 10. The distance value is quoted by 10 in this power if the next ['Word8'] argument is not empty. The default one is 0. The right values are in the range [0..4].+ Int ->+ -- | A 'length' of the next argument here.+ Int ->+ -- | A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.+ Compards ->+ -- | If 'True' then adds \"<br>\" to line endings for double column output+ Bool ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ -- | A path to the file to save double columns output to. If empty then just prints to 'stdout'.+ FilePath ->+ -- | If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'+ String ->+ -- | If the next element is not equal to -1, then the prepending and appending lines to be displayed. Used basically for working with the multiline textual input data.+ (String, String) ->+ -- | The number of the line in the file to be read the lines from. If equal to -1 then neither reading from the file is done nor the first argument influences the processment results.+ Int ->+ -- | The file to read the sound representation durations from.+ FilePath ->+ Int ->+ R.HashCorrections ->+ (Int8, [Int8]) ->+ Int ->+ Int ->+ Bool ->+ Int8 ->+ (FilePath, Int) ->+ -- | Whether to run tests concurrently or not. 'True' corresponds to concurrent execution that can speed up the getting results but use more resources.+ Bool ->+ -- | An initial string to be analysed.+ String ->+ [String] ->+ IO [String]+generalF power10 ldc compards html filtering dcfile selStr (prestr, poststr) lineNmb file numTest hc (grps, mxms) k hashStep emptyline splitting (fs, code) concurrently initstr universalSet@(_ : _ : _) = do+ syllableDurationsDs <- readSyllableDurations file+ let syllN = countSyll initstr+ f ldc compards syllableDurationsDs grps mxms -- Since the version 0.12.0.0, has a possibility to evaluate diversity property.+ | L.null selStr =+ ( if doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ then (sum . R.countHashes2G hashStep hc grps mxms)+ else+ (`quot` 10 ^ power10)+ . fromIntegral+ . sumAbsDistNormComp compards+ . (if isWord8Based compards then C1 else C2 . fromSmallWord8toInt8Diff)+ )+ . read3+ (not . L.null . filter (not . isSpace))+ 1.0+ ( mconcat+ . ( if L.null file+ then case k of+ 1 -> syllableDurationsD+ 2 -> syllableDurationsD2+ 3 -> syllableDurationsD3+ 4 -> syllableDurationsD4+ else+ if length syllableDurationsDs >= k+ then syllableDurationsDs !! (k - 1)+ else syllableDurationsD2+ )+ . createSyllablesUkrS+ )+ | otherwise =+ fromIntegral+ . diverse2GGL (selectSounds selStr) [100, 101]+ . convertToProperUkrainianI8+ . filter (\c -> not (isDigit c) && c /= '_' && c /= '=')+ hSetNewlineMode stdout universalNewlineMode+ if numTest+ >= 0+ && numTest+ <= 179+ && numTest+ /= 1+ && doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ then+ testsOutput+ concurrently+ syllN+ filtering+ f+ ldc+ syllableDurationsDs+ numTest+ universalSet+ else+ let sRepresent =+ zipWith (\k (x, ys) -> S k x ys) [1 ..]+ . sortOn id+ . map (\xss -> (f ldc compards syllableDurationsDs grps mxms xss, xss))+ $ universalSet+ strOutput =+ force+ . (: [])+ . halfsplit1G+ (\(S _ y _) -> y)+ filtering+ (if html then "<br>" else "")+ (jjj splitting) $+ sRepresent+ in do+ let lns1 = unlines strOutput+ putStrLn lns1+ if L.null dcfile+ then putStr ""+ else do+ exist <- doesFileExist dcfile+ if exist+ then do+ perms <- getPermissions dcfile+ if writable perms+ then writeFile dcfile lns1+ else+ error $+ "Aftovolio.Ukrainian.IO.generalF: File "+ `mappend` dcfile+ `mappend` " is not writable!"+ else do+ currdir <- getCurrentDirectory+ perms <- getPermissions currdir+ if writable perms+ then writeFile dcfile lns1+ else+ error $+ "Aftovolio.Ukrainian.IO.generalF: Directory of the file "+ `mappend` dcfile+ `mappend` " is not writable!"+ let l1 = length sRepresent+ if code == -1+ then+ if lineNmb == -1+ then return strOutput+ else do+ print23 filtering prestr poststr 1 [initstr]+ return strOutput+ else do+ print23 filtering prestr poststr 1 [initstr]+ parseLineNumber l1 >>= \num -> do+ permiss <- getPermissions fs+ let writ = writable permiss+ readab = readable permiss+ if writ && readab+ then+ outputWithFile+ selStr+ compards+ sRepresent+ file+ syllableDurationsDs+ code+ grps+ k+ fs+ num+ else+ error+ "Aftovolio.Ukrainian.IO.generalF: The specified file cannot be used for appending the text! Please, specify another file!"+ return []+ where+ jjj kk = let (q1, r1) = quotRem kk (if kk < 0 then -10 else 10) in jjj' q1 r1 emptyline+ jjj' q1 r1 emptyline+ | r1 == (-1) || r1 == (-3) = -10 * q1 + (if emptyline then -5 else r1)+ | r1 == 1 || r1 == 3 = 10 * q1 + (if emptyline then 5 else r1)+ | r1 < 0 = -10 * q1 + (if emptyline then -4 else r1)+ | otherwise = 10 * q1 + (if emptyline then 4 else r1)+generalF _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ [u1] = do+ putStrLn u1+ return [u1]+generalF _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ =+ let strOutput =+ [ "You have specified the data and constraints on it that lead to no further possible options."+ , "Please, specify another data and constraints."+ ]+ in do+ putStrLn . unlines $ strOutput+ return strOutput data AftovolioUkr = S Int Integer String deriving (Eq, Generic) instance NFData AftovolioUkr instance Show AftovolioUkr where- show (S i j xs) = showBignum 7 j `mappend` " " `mappend` xs `mappend` " " `mappend` showWithSpaces 4 i+ show (S i j xs) =+ showBignum 7 j+ `mappend` " "+ `mappend` xs+ `mappend` " "+ `mappend` showWithSpaces 4 i countSyll :: String -> Int-countSyll xs = numUnderscoresSyll + (fromEnum . foldr (\x y -> if isVowel1 x then y + 1 else y) 0 . convertToProperUkrainianI8 $ xs)- where numUnderscoresSyll = length . filter (\xs -> let (ys,ts) = splitAt 1 xs in ys == "_" && all isDigit ts && not (L.null ts)) . groupBy (\x y -> x=='_' && isDigit y) $ xs+countSyll xs =+ numUnderscoresSyll+ + ( fromEnum+ . foldr (\x y -> if isVowel1 x then y + 1 else y) 0+ . convertToProperUkrainianI8 $+ xs+ )+ where+ numUnderscoresSyll =+ length+ . filter+ ( \xs -> let (ys, ts) = splitAt 1 xs in ys == "_" && all isDigit ts && not (L.null ts)+ )+ . groupBy (\x y -> x == '_' && isDigit y) $+ xs -stat1 :: Int -> (Int8,[Int8]) -> Int+stat1 :: Int -> (Int8, [Int8]) -> Int stat1 n (k, ks) = fst (n `quotRemInt` fromEnum k) * length ks -parseHelp :: [String] -> (String,[String])-parseHelp xss - | L.null xss = ([],[])- | otherwise = (unwords rss, uss `mappend` qss)- where (yss,tss) = break (== "-b") xss- (uss,wss) = break (== "+b") yss- [qss,rss] = map (drop 1) [tss, wss]- +parseHelp :: [String] -> (String, [String])+parseHelp xss+ | L.null xss = ([], [])+ | otherwise = (unwords rss, uss `mappend` qss)+ where+ (yss, tss) = break (== "-b") xss+ (uss, wss) = break (== "+b") yss+ [qss, rss] = map (drop 1) [tss, wss]+ outputSel :: AftovolioUkr -> Int -> String outputSel (S x1 y1 ts) code- | code < 0 = []- | code == 1 || code == 11 || code == 16 = intercalate " " [show x1, ts] `mappend` "\n"- | code == 2 || code == 12 || code == 17 = intercalate " " [show y1, ts] `mappend` "\n"- | code == 3 || code == 13 || code == 18 = intercalate " " [show x1, ts, show y1] `mappend` "\n"- | code == 4 || code == 14 || code == 19 = intercalate " " [show x1, show y1] `mappend` "\n"- | otherwise = ts `mappend` "\n"+ | code < 0 = []+ | code == 1 || code == 11 || code == 16 =+ intercalate " " [show x1, ts] `mappend` "\n"+ | code == 2 || code == 12 || code == 17 =+ intercalate " " [show y1, ts] `mappend` "\n"+ | code == 3 || code == 13 || code == 18 =+ intercalate " " [show x1, ts, show y1] `mappend` "\n"+ | code == 4 || code == 14 || code == 19 =+ intercalate " " [show x1, show y1] `mappend` "\n"+ | otherwise = ts `mappend` "\n" parseLineNumber :: Int -> IO Int-parseLineNumber l1 = do - putStrLn "Please, specify the number of the option to be written to the file specified: "- number <- getLine- let num = readMaybe (filter isDigit number)::Maybe Int- if isNothing num || num > Just l1 || num == Just 0 - then parseLineNumber l1 - else return . fromJust $ num+parseLineNumber l1 = do+ putStrLn+ "Please, specify the number of the option to be written to the file specified: "+ number <- getLine+ let num = readMaybe (filter isDigit number) :: Maybe Int+ if isNothing num || num > Just l1 || num == Just 0+ then parseLineNumber l1+ else return . fromJust $ num -{-| 'selectSounds' converts the argument after \"+ul\" command line argument into a list of Ukrainian sound representations that is used for evaluation of \'uniqueness periods\' properties of the line. Is a modified Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.parsey0Choice from the @phonetic-languages-simplified-examples-array-0.21.0.0@ package. --}+-- | 'selectSounds' converts the argument after \"+ul\" command line argument into a list of Ukrainian sound representations that is used for evaluation of \'uniqueness periods\' properties of the line. Is a modified Phonetic.Languages.Simplified.Array.Ukrainian.FuncRep2RelatedG2.parsey0Choice from the @phonetic-languages-simplified-examples-array-0.21.0.0@ package. selectSounds :: String -> FlowSound-selectSounds = f . sortOn id . filter (/= 101) . concatMap g . words . map (\c -> if c == '.' then ' ' else toLower c)- where g = getBFst' ([101::Sound8], listArray (0,41) (("1",[1,2,3,4,5,6,7,8,10,15,17,19,21,23,25,27,28,30,32,34,36,38,39,41,43,45,47,49,50,52,54,66]):("sr",[27,28,30,32,34,36]):("vd",[8,10,15,17,19,21,23,25]) :("vs",[45,47,49,50,43,52,38,66,54,39,41]) :("vw",[1..6]) :map (\(k,t) -> (k,[t])) [("\1072",1),("\1073",15),("\1074",36),("\1075",21),("\1076",17),("\1076\1078",23),("\1076\1079",8),("\1077",2),("\1078",10),("\1079",25),("\1080",5),("\1081",27),("\1082",45),("\1083",28),("\1084",30),("\1085",32),("\1086",3),("\1087",47),("\1088",34),("\1089",49),("\1089\1100",54),("\1090",50),("\1091",4),("\1092",43),("\1093",52),("\1094",38),("\1094\1100",66),("\1095",39),("\1096",41),("\1097",55),("\1100",7),("\1102",56),("\1103",57),("\1108",58),("\1110",6),("\1111",59),("\1169",19),("\8217",61)]))- f (x:ts@(y:_)) - | x == y = f ts- | otherwise = x:f ts- f xs = xs+selectSounds =+ f+ . sortOn id+ . filter (/= 101)+ . concatMap g+ . words+ . map (\c -> if c == '.' then ' ' else toLower c)+ where+ g =+ getBFst'+ ( [101 :: Sound8]+ , listArray+ (0, 41)+ ( ( "1"+ ,+ [ 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 10+ , 15+ , 17+ , 19+ , 21+ , 23+ , 25+ , 27+ , 28+ , 30+ , 32+ , 34+ , 36+ , 38+ , 39+ , 41+ , 43+ , 45+ , 47+ , 49+ , 50+ , 52+ , 54+ , 66+ ]+ )+ : ("sr", [27, 28, 30, 32, 34, 36])+ : ("vd", [8, 10, 15, 17, 19, 21, 23, 25])+ : ("vs", [45, 47, 49, 50, 43, 52, 38, 66, 54, 39, 41])+ : ("vw", [1 .. 6])+ : map+ (\(k, t) -> (k, [t]))+ [ ("\1072", 1)+ , ("\1073", 15)+ , ("\1074", 36)+ , ("\1075", 21)+ , ("\1076", 17)+ , ("\1076\1078", 23)+ , ("\1076\1079", 8)+ , ("\1077", 2)+ , ("\1078", 10)+ , ("\1079", 25)+ , ("\1080", 5)+ , ("\1081", 27)+ , ("\1082", 45)+ , ("\1083", 28)+ , ("\1084", 30)+ , ("\1085", 32)+ , ("\1086", 3)+ , ("\1087", 47)+ , ("\1088", 34)+ , ("\1089", 49)+ , ("\1089\1100", 54)+ , ("\1090", 50)+ , ("\1091", 4)+ , ("\1092", 43)+ , ("\1093", 52)+ , ("\1094", 38)+ , ("\1094\1100", 66)+ , ("\1095", 39)+ , ("\1096", 41)+ , ("\1097", 55)+ , ("\1100", 7)+ , ("\1102", 56)+ , ("\1103", 57)+ , ("\1108", 58)+ , ("\1110", 6)+ , ("\1111", 59)+ , ("\1169", 19)+ , ("\8217", 61)+ ]+ )+ )+ f (x : ts@(y : _))+ | x == y = f ts+ | otherwise = x : f ts+ f xs = xs -- | Part of the 'generalF' for processment in case of using tests mode.-testsOutput- :: (Show a1, Integral a1) =>- Bool -- ^ Whether to run tests concurrently or not. 'True' corresponds to concurrent execution that can speed up the getting results but use more resources.- -> Int- -> Bool -- ^ Whether to filter out all groups of \'={digits}\' from the lines.- -> (Int -> Compards -> p2 -> Int8 -> [Int8] -> String -> a1)- -> Int- -> p2- -> Int- -> [String]- -> IO [String]+testsOutput ::+ (Show a1, Integral a1) =>+ -- | Whether to run tests concurrently or not. 'True' corresponds to concurrent execution that can speed up the getting results but use more resources.+ Bool ->+ Int ->+ -- | Whether to filter out all groups of \'={digits}\' from the lines.+ Bool ->+ (Int -> Compards -> p2 -> Int8 -> [Int8] -> String -> a1) ->+ Int ->+ p2 ->+ Int ->+ [String] ->+ IO [String] testsOutput concurrently syllN filtering f ldc syllableDurationsDs numTest universalSet = do- putStrLn "Feet Val Stat Proxim" - (if concurrently - then mapConcurrently- else mapM) (\(q,qs) -> - let m = stat1 syllN (q,qs)- (min1, max1) = force . fromJust . minMax11By (comparing (f ldc (C1 []) syllableDurationsDs q qs)) $ universalSet - mx = f ldc (C1 []) syllableDurationsDs q qs max1 - strTest = (show (fromEnum q) `mappend` " | " `mappend` show mx `mappend` " " `mappend` show m `mappend` " -> " `mappend` - showFFloat (Just 3) (100 * fromIntegral mx / fromIntegral m) "%" `mappend` (if rem numTest 10 >= 4 - then ("\n" `mappend` (if filtering then removeChangesOfDurations else id) min1 `mappend` "\n" `mappend` (if filtering then removeChangesOfDurations else id) max1 `mappend` "\n")- else "")) in putStrLn strTest >> return strTest) . zip (sel2 numTest) $ (sel numTest)+ putStrLn "Feet Val Stat Proxim"+ ( if concurrently+ then mapConcurrently+ else mapM+ )+ ( \(q, qs) ->+ let m = stat1 syllN (q, qs)+ (min1, max1) =+ force+ . fromJust+ . minMax11By (comparing (f ldc (C1 []) syllableDurationsDs q qs)) $+ universalSet+ mx = f ldc (C1 []) syllableDurationsDs q qs max1+ strTest =+ ( show (fromEnum q)+ `mappend` " | "+ `mappend` show mx+ `mappend` " "+ `mappend` show m+ `mappend` " -> "+ `mappend` showFFloat (Just 3) (100 * fromIntegral mx / fromIntegral m) "%"+ `mappend` ( if rem numTest 10 >= 4+ then+ ( "\n"+ `mappend` (if filtering then removeChangesOfDurations else id) min1+ `mappend` "\n"+ `mappend` (if filtering then removeChangesOfDurations else id) max1+ `mappend` "\n"+ )+ else ""+ )+ )+ in putStrLn strTest >> return strTest+ )+ . zip (sel2 numTest)+ $ (sel numTest) -- | Part of 'generalF' for processment with a file.-outputWithFile- :: String -- ^ If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'- -> Compards -- ^ A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.- -> [AftovolioUkr]- -> FilePath -- ^ The file to read the sound representation durations from.- -> [[[[Sound8]]] -> [[Word8]]]- -> Int- -> Int8 - -> Int- -> FilePath -- ^ A file to be probably added output parts to.- -> Int- -> IO ()-outputWithFile selStr compards sRepresent file syllableDurationsDs code grps k fs num - | mBool && code >= 10 && code <= 19 && grps == 2 = putStrLn (mconcat [textP, "\n", breaks, "\n", show rs]) >> appendF ((if code >= 15 then mconcat [show rs, "\n", breaks, "\n"] else "") `mappend` outputS)- | otherwise = appendF outputS- where mBool = L.null selStr && doubleFunc (L.null::[Word8]->Bool) (L.null::[Int8]-> Bool) compards - appendF = appendFile fs- lineOption = head . filter (\(S k _ _) -> k == num) $ sRepresent- textP = (\(S _ _ ts) -> ts) lineOption--- sylls = createSyllablesUkrS textP- outputS = outputSel lineOption code- qqs = readEq4 (mconcat . (if L.null file then case k of { 1 -> syllableDurationsD; 2 -> syllableDurationsD2; 3 -> syllableDurationsD3; 4 -> syllableDurationsD4} else if length syllableDurationsDs >= k then syllableDurationsDs !! (k - 1) else syllableDurationsD2) . createSyllablesUkrS) (map showFS . mconcat . createSyllablesUkrS) . basicSplit $ textP - (breaks, rs) = R.showZerosFor2PeriodMusic qqs-+outputWithFile ::+ -- | If not null than instead of rhythmicity evaluation using hashes and and feets, there is computed a diversity property for the specified 'String' here using the 'selectSounds' function. For more information, see: 'https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types'+ String ->+ -- | A value that the different options are compared with. If no command line argument \"+di\" was added, then this is a `C1` applied to the list of positive values normed by 255 (the greatest of which is 255) that the line options are compared with. If null, then the program works without comparison. The length of it must be a least common multiplier of the (number of syllables plus number of \'_digits\' groups) to work correctly. Is not used when the next 'FilePath' and 'String' arguments are not null. If \"+di\" command line argument was provided, then this corresponds to the case of differentiation.+ Compards ->+ [AftovolioUkr] ->+ -- | The file to read the sound representation durations from.+ FilePath ->+ [[[[Sound8]]] -> [[Word8]]] ->+ Int ->+ Int8 ->+ Int ->+ -- | A file to be probably added output parts to.+ FilePath ->+ Int ->+ IO ()+outputWithFile selStr compards sRepresent file syllableDurationsDs code grps k fs num+ | mBool && code >= 10 && code <= 19 && grps == 2 =+ putStrLn (mconcat [textP, "\n", breaks, "\n", show rs])+ >> appendF+ ( (if code >= 15 then mconcat [show rs, "\n", breaks, "\n"] else "")+ `mappend` outputS+ )+ | otherwise = appendF outputS+ where+ mBool =+ L.null selStr+ && doubleFunc (L.null :: [Word8] -> Bool) (L.null :: [Int8] -> Bool) compards+ appendF = appendFile fs+ lineOption = head . filter (\(S k _ _) -> k == num) $ sRepresent+ textP = (\(S _ _ ts) -> ts) lineOption+ -- sylls = createSyllablesUkrS textP+ outputS = outputSel lineOption code+ qqs =+ readEq4+ ( mconcat+ . ( if L.null file+ then case k of+ 1 -> syllableDurationsD+ 2 -> syllableDurationsD2+ 3 -> syllableDurationsD3+ 4 -> syllableDurationsD4+ else+ if length syllableDurationsDs >= k+ then syllableDurationsDs !! (k - 1)+ else syllableDurationsD2+ )+ . createSyllablesUkrS+ )+ (map showFS . mconcat . createSyllablesUkrS)+ . basicSplit $+ textP+ (breaks, rs) = R.showZerosFor2PeriodMusic qqs
Aftovolio/Ukrainian/Melodics.hs view
@@ -1,67 +1,69 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE NoImplicitPrelude, BangPatterns #-} --- |--- Module : Aftovolio.Ukrainian.Melodics--- Copyright : (c) OleksandrZhabenko 2021-2024--- License : MIT--- Maintainer : oleksandr.zhabenko@yahoo.com------ Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis--- especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr--- for optimization purposes.--- Phonetic material is taken from the :------ Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of--- the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf+{- |+Module : Aftovolio.Ukrainian.Melodics+Copyright : (c) OleksandrZhabenko 2021-2024+License : MIT+Maintainer : oleksandr.zhabenko@yahoo.com +Functions provide functionality of a musical instrument synthesizer or for Ukrainian speech synthesis+especially for poets, translators and writers. Is rewritten from the module Melodics.ByteString.Ukrainian.Arr+for optimization purposes.+Phonetic material is taken from the :++Solomija Buk, Ján Mačutek, Andrij Rovenchak. Some properties of+the Ukrainian writing system. [Electronic resource] https://arxiv.org/ftp/arxiv/papers/0802/0802.4198.pdf+-} module Aftovolio.Ukrainian.Melodics (- -- * Basic functions- Sound8- , FlowSound- , convertToProperUkrainianI8WithTuples- , convertToProperUkrainianI8- , isUkrainianL- , linkFileNameI8- -- * Transformation functions- , дзT- , жT- , дT- , гT- , зT- , цT- , чT- , шT- , фT- , кT- , пT- , сT- , тT- , хT- , сьT- , нтT- , стT- , тьT- , цьT+ -- * Basic functions+ Sound8,+ FlowSound,+ convertToProperUkrainianI8WithTuples,+ convertToProperUkrainianI8,+ isUkrainianL,+ linkFileNameI8,++ -- * Transformation functions+ дзT,+ жT,+ дT,+ гT,+ зT,+ цT,+ чT,+ шT,+ фT,+ кT,+ пT,+ сT,+ тT,+ хT,+ сьT,+ нтT,+ стT,+ тьT,+ цьT, ) where -import GHC.Base-import GHC.List-import GHC.Num ((-))-import Data.Maybe (fromJust)-import Data.Char-import GHC.Arr+import Aftovolio.Ukrainian.Common2 import CaseBi.Arr+import Data.Char import Data.List (uncons)+import Data.Maybe (fromJust)+import GHC.Arr+import GHC.Base import GHC.Int-import Aftovolio.Ukrainian.Common2+import GHC.List+import GHC.Num ((-)) -- | Is used to signify the optimization data type of 'Int8'. type Sound8 = Int8 type FlowSound = [Sound8] -{-| The function that uses the following correspondence between the previous data type UZPP2 and the 'Sound8'.+{- | The function that uses the following correspondence between the previous data type UZPP2 and the 'Sound8'. See for more implementation information: <https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#ability-to-use-your-own-durations-of-representations-of-sounds-or-phonetic-phenomena> @@ -73,343 +75,721 @@ -} convertToProperUkrainianI8 :: String -> FlowSound convertToProperUkrainianI8 =- let !tup1 = listArray (0,13) [(10,True),(17,True),(21,True),(25,True),(32,True),(38,True),(39,True),- (41,True),(43,True),(45,True),(47,True),(49,True),(50,True),(52,True)]- !tup2 = listArray (0,19) [(10,True),(15,True),(17,True),(19,True),(21,True),(25,True),(28,True),- (30,True),(32,True),(34,True),(36,True),(38,True),(39,True),(41,True),(43,True),(45,True),(47,True),- (49,True),(50,True),(52,True)]- !tup3 = listArray (0,13) [(10,False),(17,False),(21,False),(25,False),(32,False),(38,False),(39,False),- (41,False),(43,False),(45,False),(47,False),(49,False),(50,False),(52,False)]- !tup4 = listArray (0,5) [(17,True),(32,True),(38,True),(49,True),(50,True),(52,True)]- !tup5 = listArray (0,8) [([17,10],True),([17,25],True),([32,50],True),([38,7],True),([49,7],True),- ([49,50],True),([50,7],True),([50,49],True),([52,21],True)]- !tup6 = listArray (0,8) [([17,10],23),([17,25],8),([32,50],62),([38,7],66),([49,7],54), ([49,50],63),- ([50,7],64),([50,49],38),([52,21],21)]- !tup8 = listArray (0,7) [(8,True),(10,True),(15,True),(17,True),(19,True),(21,True),(23,True),(25, True)]- !tup9 = listArray (0,10) [([15,7],True),([17,7],True),([28,7],True),([30,7],True),([32,7],True),([36,7],True),- ([38,7],True),([43,7],True),([47,7],True),([49,7],True),([50,7],True)]- !tup10 = listArray (0,4) [([12],True),([13],True),([14],True),([64],True),([65],True)]- !tup11 = listArray (0,7) [([8,7],True),([17,7],True),([25,7],True),([28,7],True),([32,7],True),([38,7],True),- ([49,7],True),([50,7],True)]- tup7 = listArray (0,18) [(8, дзT tup9 tup10),(10, жT),(17, дT),(21, гT),(25, зT tup9 tup10),(38, цT tup8 tup9 tup10),- (39, чT),(41, шT),(43, фT), (45, кT),(47, пT),(49, сT tup8 tup9 tup10),(50, тT tup8 tup11 tup10),- (52, хT),(54, сьT),(62, нтT),(63, стT),(64, тьT),(66, цьT)]- !tup12 = listArray (0,6) [(12,[8,7]),(13,[25,7]),(14,[17,7]),(62,[32,50]),(63,[49,50]),(64,[50,7]), (65,[32,7])]- !tup13 = listArray (0,36) [('\'',102),('-',101),('\700',60),('\1072',1),('\1073',15),('\1074',36),('\1075',21),- ('\1076',17),('\1077',2),('\1078',10),('\1079',25),('\1080',5),('\1081',27),('\1082',45),('\1083',28),- ('\1084',30),('\1085',32),('\1086',3),('\1087',47),('\1088',34),('\1089',49),('\1090',50),('\1091',4),- ('\1092',43),('\1093',52),('\1094',38),('\1095',39),('\1096',41),('\1097',55),('\1100',7),('\1102',56),- ('\1103',57),('\1108',58),('\1110',6),('\1111',59),('\1169',19),('\8217',61)]- !tup14 = listArray (0,8) [(55,[41,39]),(56,[27,4]),(57,[27,1]),(58,[27,2]),(59,[27,6]),- (60,[101]),(61,[101]),(101,[101]),(102,[101])]- !tup15 = listArray (0,15) [('\'',True),('-',True),('\700',True),('\1028',True),('\1030',True),('\1031',True),- ('\1068',True),('\1100',True),('\1102',True),('\1103',True),('\1108',True),('\1110',True),('\1111',True),- ('\1168',True),('\1169',True),('\8217',True)]- !tup16 = listArray (0,20) [('\1073',True),('\1074',True),('\1075',True),('\1076',True),('\1078',True),- ('\1079',True),('\1082',True),('\1083',True),('\1084',True),('\1085',True),('\1087',True),('\1088',True),- ('\1089',True),('\1090',True),('\1092',True),('\1093',True),('\1094',True),('\1095',True),('\1096',True),- ('\1097',True),('\1169',True)] in- correctB . correctA tup12 . applyChanges tup7 . bsToCharUkr tup6 . createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 .- secondConv tup14 . filterUkr tup13 . changeIotated tup16 .- filter (\x -> isUkrainianLTup tup15 x || isSpace x || isControl x || isPunctuation x) . map toLower+ let !tup1 =+ listArray+ (0, 13)+ [ (10, True)+ , (17, True)+ , (21, True)+ , (25, True)+ , (32, True)+ , (38, True)+ , (39, True)+ , (41, True)+ , (43, True)+ , (45, True)+ , (47, True)+ , (49, True)+ , (50, True)+ , (52, True)+ ]+ !tup2 =+ listArray+ (0, 19)+ [ (10, True)+ , (15, True)+ , (17, True)+ , (19, True)+ , (21, True)+ , (25, True)+ , (28, True)+ , (30, True)+ , (32, True)+ , (34, True)+ , (36, True)+ , (38, True)+ , (39, True)+ , (41, True)+ , (43, True)+ , (45, True)+ , (47, True)+ , (49, True)+ , (50, True)+ , (52, True)+ ]+ !tup3 =+ listArray+ (0, 13)+ [ (10, False)+ , (17, False)+ , (21, False)+ , (25, False)+ , (32, False)+ , (38, False)+ , (39, False)+ , (41, False)+ , (43, False)+ , (45, False)+ , (47, False)+ , (49, False)+ , (50, False)+ , (52, False)+ ]+ !tup4 = listArray (0, 5) [(17, True), (32, True), (38, True), (49, True), (50, True), (52, True)]+ !tup5 =+ listArray+ (0, 8)+ [ ([17, 10], True)+ , ([17, 25], True)+ , ([32, 50], True)+ , ([38, 7], True)+ , ([49, 7], True)+ , ([49, 50], True)+ , ([50, 7], True)+ , ([50, 49], True)+ , ([52, 21], True)+ ]+ !tup6 =+ listArray+ (0, 8)+ [ ([17, 10], 23)+ , ([17, 25], 8)+ , ([32, 50], 62)+ , ([38, 7], 66)+ , ([49, 7], 54)+ , ([49, 50], 63)+ , ([50, 7], 64)+ , ([50, 49], 38)+ , ([52, 21], 21)+ ]+ !tup8 =+ listArray+ (0, 7)+ [ (8, True)+ , (10, True)+ , (15, True)+ , (17, True)+ , (19, True)+ , (21, True)+ , (23, True)+ , (25, True)+ ]+ !tup9 =+ listArray+ (0, 10)+ [ ([15, 7], True)+ , ([17, 7], True)+ , ([28, 7], True)+ , ([30, 7], True)+ , ([32, 7], True)+ , ([36, 7], True)+ , ([38, 7], True)+ , ([43, 7], True)+ , ([47, 7], True)+ , ([49, 7], True)+ , ([50, 7], True)+ ]+ !tup10 = listArray (0, 4) [([12], True), ([13], True), ([14], True), ([64], True), ([65], True)]+ !tup11 =+ listArray+ (0, 7)+ [ ([8, 7], True)+ , ([17, 7], True)+ , ([25, 7], True)+ , ([28, 7], True)+ , ([32, 7], True)+ , ([38, 7], True)+ , ([49, 7], True)+ , ([50, 7], True)+ ]+ tup7 =+ listArray+ (0, 18)+ [ (8, дзT tup9 tup10)+ , (10, жT)+ , (17, дT)+ , (21, гT)+ , (25, зT tup9 tup10)+ , (38, цT tup8 tup9 tup10)+ , (39, чT)+ , (41, шT)+ , (43, фT)+ , (45, кT)+ , (47, пT)+ , (49, сT tup8 tup9 tup10)+ , (50, тT tup8 tup11 tup10)+ , (52, хT)+ , (54, сьT)+ , (62, нтT)+ , (63, стT)+ , (64, тьT)+ , (66, цьT)+ ]+ !tup12 =+ listArray+ (0, 6)+ [ (12, [8, 7])+ , (13, [25, 7])+ , (14, [17, 7])+ , (62, [32, 50])+ , (63, [49, 50])+ , (64, [50, 7])+ , (65, [32, 7])+ ]+ !tup13 =+ listArray+ (0, 36)+ [ ('\'', 102)+ , ('-', 101)+ , ('\700', 60)+ , ('\1072', 1)+ , ('\1073', 15)+ , ('\1074', 36)+ , ('\1075', 21)+ , ('\1076', 17)+ , ('\1077', 2)+ , ('\1078', 10)+ , ('\1079', 25)+ , ('\1080', 5)+ , ('\1081', 27)+ , ('\1082', 45)+ , ('\1083', 28)+ , ('\1084', 30)+ , ('\1085', 32)+ , ('\1086', 3)+ , ('\1087', 47)+ , ('\1088', 34)+ , ('\1089', 49)+ , ('\1090', 50)+ , ('\1091', 4)+ , ('\1092', 43)+ , ('\1093', 52)+ , ('\1094', 38)+ , ('\1095', 39)+ , ('\1096', 41)+ , ('\1097', 55)+ , ('\1100', 7)+ , ('\1102', 56)+ , ('\1103', 57)+ , ('\1108', 58)+ , ('\1110', 6)+ , ('\1111', 59)+ , ('\1169', 19)+ , ('\8217', 61)+ ]+ !tup14 =+ listArray+ (0, 8)+ [ (55, [41, 39])+ , (56, [27, 4])+ , (57, [27, 1])+ , (58, [27, 2])+ , (59, [27, 6])+ , (60, [101])+ , (61, [101])+ , (101, [101])+ , (102, [101])+ ]+ !tup15 =+ listArray+ (0, 15)+ [ ('\'', True)+ , ('-', True)+ , ('\700', True)+ , ('\1028', True)+ , ('\1030', True)+ , ('\1031', True)+ , ('\1068', True)+ , ('\1100', True)+ , ('\1102', True)+ , ('\1103', True)+ , ('\1108', True)+ , ('\1110', True)+ , ('\1111', True)+ , ('\1168', True)+ , ('\1169', True)+ , ('\8217', True)+ ]+ !tup16 =+ listArray+ (0, 20)+ [ ('\1073', True)+ , ('\1074', True)+ , ('\1075', True)+ , ('\1076', True)+ , ('\1078', True)+ , ('\1079', True)+ , ('\1082', True)+ , ('\1083', True)+ , ('\1084', True)+ , ('\1085', True)+ , ('\1087', True)+ , ('\1088', True)+ , ('\1089', True)+ , ('\1090', True)+ , ('\1092', True)+ , ('\1093', True)+ , ('\1094', True)+ , ('\1095', True)+ , ('\1096', True)+ , ('\1097', True)+ , ('\1169', True)+ ]+ in correctB+ . correctA tup12+ . applyChanges tup7+ . bsToCharUkr tup6+ . createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5+ . secondConv tup14+ . filterUkr tup13+ . changeIotated tup16+ . filter+ (\x -> isUkrainianLTup tup15 x || isSpace x || isControl x || isPunctuation x)+ . map toLower {-# INLINE convertToProperUkrainianI8 #-} -{-| A full variant of the 'convertToProperUkrainianI8' function with all the elements for the 'getBFst'' function being+{- | A full variant of the 'convertToProperUkrainianI8' function with all the elements for the 'getBFst'' function being provided as 'Array' 'Int' (data tuple). Can be useful to reduce number of calculations in the complex usage scenarios. -}-convertToProperUkrainianI8WithTuples- :: Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Int8)- -> Array Int (Int8, FlowSound -> Sound8)- -> Array Int (Int8, Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Bool)- -> Array Int (Int8, [Int8])- -> Array Int (Char,Int8)- -> Array Int (Int8,[Int8])- -> Array Int (Char, Bool)- -> Array Int (Char, Bool)- -> [Char]- -> FlowSound+convertToProperUkrainianI8WithTuples ::+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Int8) ->+ Array Int (Int8, FlowSound -> Sound8) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int (Int8, [Int8]) ->+ Array Int (Char, Int8) ->+ Array Int (Int8, [Int8]) ->+ Array Int (Char, Bool) ->+ Array Int (Char, Bool) ->+ [Char] ->+ FlowSound convertToProperUkrainianI8WithTuples !tup1 !tup2 !tup3 !tup4 !tup5 !tup6 tup7 !tup8 !tup9 !tup10 !tup11 !tup12 !tup13 !tup14 !tup15 !tup16 =- correctB . correctA tup12 . applyChanges tup7 . bsToCharUkr tup6 . createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 .- secondConv tup14 . filterUkr tup13 . changeIotated tup16 .- filter (\x -> isUkrainianLTup tup15 x || isSpace x || isControl x || isPunctuation x) . map toLower+ correctB+ . correctA tup12+ . applyChanges tup7+ . bsToCharUkr tup6+ . createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5+ . secondConv tup14+ . filterUkr tup13+ . changeIotated tup16+ . filter+ (\x -> isUkrainianLTup tup15 x || isSpace x || isControl x || isPunctuation x)+ . map toLower {-# INLINE convertToProperUkrainianI8WithTuples #-} -changeIotated :: Array Int (Char,Bool) -> String -> String-changeIotated !tup16 (x:y:zs)- | (y `elem` ("\1102\1103\1108\1110"::String)) && isConsNotJTup tup16 x = x:'\1100':(case y of { '\1102' -> '\1091' ; '\1103' -> '\1072' ; '\1108' -> '\1077' ; ~r -> '\1110' }):changeIotated tup16 zs- | x == '\'' || x == '\x2019' || x == '\x02BC' || x == '-' = if (y `elem` ("\1102\1103\1108\1110"::String)) then '\1081':(case y of { '\1102' -> '\1091' ; '\1103' -> '\1072' ; '\1108' -> '\1077' ; ~r -> '\1110' }):changeIotated tup16 zs else changeIotated tup16 (y:zs)- | otherwise = x:changeIotated tup16 (y:zs)+changeIotated :: Array Int (Char, Bool) -> String -> String+changeIotated !tup16 (x : y : zs)+ | (y `elem` ("\1102\1103\1108\1110" :: String)) && isConsNotJTup tup16 x =+ x+ : '\1100'+ : ( case y of+ '\1102' -> '\1091'+ '\1103' -> '\1072'+ '\1108' -> '\1077'+ ~r -> '\1110'+ )+ : changeIotated tup16 zs+ | x == '\'' || x == '\x2019' || x == '\x02BC' || x == '-' =+ if (y `elem` ("\1102\1103\1108\1110" :: String))+ then+ '\1081'+ : ( case y of+ '\1102' -> '\1091'+ '\1103' -> '\1072'+ '\1108' -> '\1077'+ ~r -> '\1110'+ )+ : changeIotated tup16 zs+ else changeIotated tup16 (y : zs)+ | otherwise = x : changeIotated tup16 (y : zs) changeIotated _ xs = xs -filterUkr :: Array Int (Char,Int8) -> String -> FlowSound+filterUkr :: Array Int (Char, Int8) -> String -> FlowSound filterUkr tup13 = let !tup = (100, tup13) in map (getBFst' tup) {-# INLINE filterUkr #-} -secondConv :: Array Int (Int8,[Int8]) -> FlowSound -> FlowSound+secondConv :: Array Int (Int8, [Int8]) -> FlowSound -> FlowSound secondConv tup14 = concatMap (\y -> getBFst' ([y], tup14) y) {-# INLINE secondConv #-} -createTuplesByAnalysis :: Array Int (Int8,Bool) -> Array Int (Int8,Bool) -> Array Int (Int8,Bool) -> Array Int (Int8,Bool) -> Array Int ([Int8],Bool) -> FlowSound -> [FlowSound]-createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 x@(h:ta)- | getBFst' (False, tup1) h = initialA tup3 tup4 tup5 x- | not (null ta) && (head ta == 27 && getBFst' (False, tup2) h) = [h]:[7]:createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 (drop 1 ta)- | otherwise = [h]:createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 ta+createTuplesByAnalysis ::+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ FlowSound ->+ [FlowSound]+createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 x@(h : ta)+ | getBFst' (False, tup1) h = initialA tup3 tup4 tup5 x+ | not (null ta) && (head ta == 27 && getBFst' (False, tup2) h) =+ [h] : [7] : createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 (drop 1 ta)+ | otherwise = [h] : createTuplesByAnalysis tup1 tup2 tup3 tup4 tup5 ta createTuplesByAnalysis _ _ _ _ _ _ = [] -initialA :: Array Int (Int8,Bool) -> Array Int (Int8,Bool) -> Array Int ([Int8],Bool) -> FlowSound -> [FlowSound]-initialA tup3 tup4 tup5 t1@(t:ts)- | t < 1 || t > 99 = [100]:initialA tup3 tup4 tup5 ts- | getBFst' (True, tup3) t = [t]:initialA tup3 tup4 tup5 ts- | getBFst' (False, tup4) t =- let (us,vs) = splitAt 2 t1 in- if getBFst' (False, tup5) us- then us:initialA tup3 tup4 tup5 vs- else [t]:initialA tup3 tup4 tup5 ts- | otherwise = [t]:initialA tup3 tup4 tup5 ts+initialA ::+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ FlowSound ->+ [FlowSound]+initialA tup3 tup4 tup5 t1@(t : ts)+ | t < 1 || t > 99 = [100] : initialA tup3 tup4 tup5 ts+ | getBFst' (True, tup3) t = [t] : initialA tup3 tup4 tup5 ts+ | getBFst' (False, tup4) t =+ let (us, vs) = splitAt 2 t1+ in if getBFst' (False, tup5) us+ then us : initialA tup3 tup4 tup5 vs+ else [t] : initialA tup3 tup4 tup5 ts+ | otherwise = [t] : initialA tup3 tup4 tup5 ts initialA _ _ _ _ = [] -bsToCharUkr :: Array Int ([Int8],Int8) -> [FlowSound] -> FlowSound-bsToCharUkr tup6 zs@(_:_) = map (g tup6) zs- where g tup6 ts@(t:_) = getBFst' (t, tup6) ts- g _ _ = 101+bsToCharUkr :: Array Int ([Int8], Int8) -> [FlowSound] -> FlowSound+bsToCharUkr tup6 zs@(_ : _) = map (g tup6) zs+ where+ g tup6 ts@(t : _) = getBFst' (t, tup6) ts+ g _ _ = 101 bsToCharUkr _ _ = [] {-# INLINE bsToCharUkr #-} -applyChanges- :: Array Int (Int8,FlowSound -> Sound8)- -> FlowSound- -> FlowSound+applyChanges ::+ Array Int (Int8, FlowSound -> Sound8) ->+ FlowSound ->+ FlowSound applyChanges tup7 ys = foldr f v ys- where v = []- f x xs@(_:_) = getBFst' (\_ -> x, tup7) x xs:xs- f x _ = [x]+ where+ v = []+ f x xs@(_ : _) = getBFst' (\_ -> x, tup7) x xs : xs+ f x _ = [x] {-# INLINE applyChanges #-} isVoicedObstruent :: FlowSound -> Bool-isVoicedObstruent (x:_) = x > 7 && x < 27+isVoicedObstruent (x : _) = x > 7 && x < 27 isVoicedObstruent _ = False {-# INLINE isVoicedObstruent #-} -isVoicedObstruentH :: Array Int (Int8,Bool) -> FlowSound -> Bool-isVoicedObstruentH tup8 (x:_) = getBFst' (False, tup8) x+isVoicedObstruentH :: Array Int (Int8, Bool) -> FlowSound -> Bool+isVoicedObstruentH tup8 (x : _) = getBFst' (False, tup8) x isVoicedObstruentH _ _ = False {-# INLINE isVoicedObstruentH #-} isVoicedObstruentS :: FlowSound -> Bool-isVoicedObstruentS (x:_) = x > 11 && x < 15+isVoicedObstruentS (x : _) = x > 11 && x < 15 isVoicedObstruentS _ = False {-# INLINE isVoicedObstruentS #-} -isSoftDOrL :: Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Bool-isSoftDOrL tup9 tup10 xs = getBFst' (False, tup9) (takeFromFT_ 2 xs) || getBFst' (False, tup10) (takeFromFT_ 1 xs)+isSoftDOrL ::+ Array Int ([Int8], Bool) -> Array Int ([Int8], Bool) -> FlowSound -> Bool+isSoftDOrL tup9 tup10 xs =+ getBFst' (False, tup9) (takeFromFT_ 2 xs)+ || getBFst' (False, tup10) (takeFromFT_ 1 xs) {-# INLINE isSoftDOrL #-} -isSoftDen :: Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Bool-isSoftDen tup11 tup10 xs = getBFst' (False, tup11) (takeFromFT_ 2 xs) || getBFst' (False, tup10) (takeFromFT_ 1 xs)+isSoftDen ::+ Array Int ([Int8], Bool) -> Array Int ([Int8], Bool) -> FlowSound -> Bool+isSoftDen tup11 tup10 xs =+ getBFst' (False, tup11) (takeFromFT_ 2 xs)+ || getBFst' (False, tup10) (takeFromFT_ 1 xs) {-# INLINE isSoftDen #-} гT :: FlowSound -> Sound8-гT (t:_) | t == 45 || t == 50 = 52 -- г х- | otherwise = 21+гT (t : _)+ | t == 45 || t == 50 = 52 -- г х+ | otherwise = 21 гT _ = 21 {-# INLINE гT #-} дT :: FlowSound -> Sound8-дT t1@(_:_) | takeFromFT_ 1 t1 `elem` [[10],[39],[41]] = 23 -- д дж- | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] = 12 -- д дзь- | takeFromFT_ 1 t1 `elem` [[54],[66]] = 12 -- д дзь- | takeFromFT_ 1 t1 `elem` [[25],[49],[38]] = 8 -- д дз- | otherwise = 17+дT t1@(_ : _)+ | takeFromFT_ 1 t1 `elem` [[10], [39], [41]] = 23 -- д дж+ | takeFromFT_ 2 t1 `elem` [[49, 7], [38, 7]] = 12 -- д дзь+ | takeFromFT_ 1 t1 `elem` [[54], [66]] = 12 -- д дзь+ | takeFromFT_ 1 t1 `elem` [[25], [49], [38]] = 8 -- д дз+ | otherwise = 17 дT _ = 17 {-# INLINE дT #-} -дзT :: Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Sound8-дзT tup9 tup10 t1@(_:_) | isSoftDOrL tup9 tup10 t1 = 12 -- дз дзь- | otherwise = 8+дзT :: Array Int ([Int8], Bool) -> Array Int ([Int8], Bool) -> FlowSound -> Sound8+дзT tup9 tup10 t1@(_ : _)+ | isSoftDOrL tup9 tup10 t1 = 12 -- дз дзь+ | otherwise = 8 дзT _ _ _ = 8 {-# INLINE дзT #-} жT :: FlowSound -> Sound8-жT t1@(_:_) | takeFromFT 2 t1 `elem` [[49,7],[38,7]] = 13 -- ж зь- | takeFromFT 1 t1 `elem` [[54],[66]] = 13- | otherwise = 10+жT t1@(_ : _)+ | takeFromFT 2 t1 `elem` [[49, 7], [38, 7]] = 13 -- ж зь+ | takeFromFT 1 t1 `elem` [[54], [66]] = 13+ | otherwise = 10 жT _ = 10 {-# INLINE жT #-} -зT :: Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Sound8-зT tup9 tup10 t1@(_:_) | takeFromFT_ 1 t1 `elem` [[10],[39],[41]] || takeFromFT_ 2 t1 == [17,10] || takeFromFT_ 1 t1 == [23] = 10 -- з ж- | isSoftDOrL tup9 tup10 t1 = 13 -- з зь- | takeFromFT 1 t1 `elem` [[39],[41]] = 41 -- з ш- | takeFromFT 1 t1 `elem` [[49],[38]] || takeFromFT_ 1 t1 `elem` [[45],[47],[50],[43],[52]] = 49 -- з с- | otherwise = 25+зT :: Array Int ([Int8], Bool) -> Array Int ([Int8], Bool) -> FlowSound -> Sound8+зT tup9 tup10 t1@(_ : _)+ | takeFromFT_ 1 t1+ `elem` [[10], [39], [41]] || takeFromFT_ 2 t1 == [17, 10] || takeFromFT_ 1 t1 == [23] =+ 10 -- з ж+ | isSoftDOrL tup9 tup10 t1 = 13 -- з зь+ | takeFromFT 1 t1 `elem` [[39], [41]] = 41 -- з ш+ | takeFromFT 1 t1+ `elem` [[49], [38]] || takeFromFT_ 1 t1+ `elem` [[45], [47], [50], [43], [52]] =+ 49 -- з с+ | otherwise = 25 зT _ _ _ = 25 {-# INLINE зT #-} кT :: FlowSound -> Sound8-кT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 19- | otherwise = 45+кT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 19+ | otherwise = 45 кT _ = 45 {-# INLINE кT #-} нтT :: FlowSound -> Sound8-нтT t1@(_:_) | takeFromFT 2 t1 == [49,50] || takeFromFT 1 t1 == [63] = 32- | takeFromFT 3 t1 == [49,7,45] || takeFromFT 2 t1 == [54,45] = 65- | otherwise = 62+нтT t1@(_ : _)+ | takeFromFT 2 t1 == [49, 50] || takeFromFT 1 t1 == [63] = 32+ | takeFromFT 3 t1 == [49, 7, 45] || takeFromFT 2 t1 == [54, 45] = 65+ | otherwise = 62 нтT _ = 62 {-# INLINE нтT #-} пT :: FlowSound -> Sound8-пT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 15- | otherwise = 47+пT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 15+ | otherwise = 47 пT _ = 47 {-# INLINE пT #-} -сT :: Array Int (Int8,Bool) -> Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Sound8-сT tup8 tup9 tup10 t1@(_:_)- | ((isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) ||- isVoicedObstruentS (takeFromFT_ 1 t1) = 13- | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 25- | isSoftDOrL tup9 tup10 t1 = 54- | takeFromFT_ 1 t1 == [41] = 41- | otherwise = 49+сT ::+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ FlowSound ->+ Sound8+сT tup8 tup9 tup10 t1@(_ : _)+ | ( (isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1)+ && drop 1 (takeFromFT_ 2 t1)+ == [7]+ )+ || isVoicedObstruentS (takeFromFT_ 1 t1) =+ 13+ | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 25+ | isSoftDOrL tup9 tup10 t1 = 54+ | takeFromFT_ 1 t1 == [41] = 41+ | otherwise = 49 сT _ _ _ _ = 49 {-# INLINE сT #-} стT :: FlowSound -> Sound8-стT t1@(_:_)- | isVoicedObstruent . takeFromFT_ 1 $ t1 = 25- | takeFromFT_ 3 t1 == [49,7,45] || (takeFromFT_ 2 t1 `elem` [[54,45],[38,7]]) || takeFromFT_ 1 t1 == [66] = 54- | takeFromFT_ 1 t1 `elem` [[49],[32]] = 49- | takeFromFT_ 1 t1 == [39] = 41- | otherwise = 63+стT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 25+ | takeFromFT_ 3 t1+ == [49, 7, 45]+ || (takeFromFT_ 2 t1 `elem` [[54, 45], [38, 7]])+ || takeFromFT_ 1 t1+ == [66] =+ 54+ | takeFromFT_ 1 t1 `elem` [[49], [32]] = 49+ | takeFromFT_ 1 t1 == [39] = 41+ | otherwise = 63 стT _ = 63 {-# INLINE стT #-} сьT :: FlowSound -> Sound8-сьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 13- | otherwise = 54+сьT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 13+ | otherwise = 54 сьT _ = 54 {-# INLINE сьT #-} -тT :: Array Int (Int8,Bool) -> Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Sound8-тT tup8 tup11 tup10 t1@(_:_)- | ((isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) ||- isVoicedObstruentS (takeFromFT_ 1 t1) = 14- | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 17- | takeFromFT_ 2 t1 == [38,7] || takeFromFT_ 1 t1 == [66] = 66- | takeFromFT_ 1 t1 == [38] = 38- | isSoftDen tup11 tup10 t1 = 64- | takeFromFT_ 1 t1 `elem` [[39],[41]] = 39- | otherwise = 50+тT ::+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ FlowSound ->+ Sound8+тT tup8 tup11 tup10 t1@(_ : _)+ | ( (isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1)+ && drop 1 (takeFromFT_ 2 t1)+ == [7]+ )+ || isVoicedObstruentS (takeFromFT_ 1 t1) =+ 14+ | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 17+ | takeFromFT_ 2 t1 == [38, 7] || takeFromFT_ 1 t1 == [66] = 66+ | takeFromFT_ 1 t1 == [38] = 38+ | isSoftDen tup11 tup10 t1 = 64+ | takeFromFT_ 1 t1 `elem` [[39], [41]] = 39+ | otherwise = 50 тT _ _ _ _ = 50 {-# INLINE тT #-} тьT :: FlowSound -> Sound8-тьT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 14- | takeFromFT_ 3 t1 == [49,7,1] || takeFromFT_ 2 t1 == [54,1] = 66- | otherwise = 64+тьT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 14+ | takeFromFT_ 3 t1 == [49, 7, 1] || takeFromFT_ 2 t1 == [54, 1] = 66+ | otherwise = 64 тьT _ = 64 {-# INLINE тьT #-} фT :: FlowSound -> Sound8-фT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 36- | otherwise = 43+фT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 36+ | otherwise = 43 фT _ = 43 {-# INLINE фT #-} хT :: FlowSound -> Sound8-хT t1@(_:_) | isVoicedObstruent . takeFromFT_ 1 $ t1 = 21- | otherwise = 52+хT t1@(_ : _)+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 21+ | otherwise = 52 хT _ = 52 {-# INLINE хT #-} -цT :: Array Int (Int8,Bool) -> Array Int ([Int8],Bool) -> Array Int ([Int8],Bool) -> FlowSound -> Sound8-цT tup8 tup9 tup10 t1@(_:_)- | ((isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7]) ||- isVoicedObstruentS (takeFromFT_ 1 t1) = 12- | isSoftDOrL tup9 tup10 t1 = 66- | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 8- | otherwise = 38+цT ::+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ FlowSound ->+ Sound8+цT tup8 tup9 tup10 t1@(_ : _)+ | ( (isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1)+ && drop 1 (takeFromFT_ 2 t1)+ == [7]+ )+ || isVoicedObstruentS (takeFromFT_ 1 t1) =+ 12+ | isSoftDOrL tup9 tup10 t1 = 66+ | isVoicedObstruentH tup8 . takeFromFT_ 1 $ t1 = 8+ | otherwise = 38 цT _ _ _ _ = 38 {-# INLINE цT #-} цьT :: FlowSound -> Sound8-цьT t1@(_:_) | (isVoicedObstruent . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7] = 12- | otherwise = 66+цьT t1@(_ : _)+ | (isVoicedObstruent . takeFromFT_ 1 $ t1) && drop 1 (takeFromFT_ 2 t1) == [7] =+ 12+ | otherwise = 66 цьT _ = 66 {-# INLINE цьT #-} чT :: FlowSound -> Sound8-чT t1@(_:_) | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] || takeFromFT_ 1 t1 `elem` [[54],[66]] = 66- | isVoicedObstruent . takeFromFT_ 1 $ t1 = 23- | otherwise = 39+чT t1@(_ : _)+ | takeFromFT_ 2 t1 `elem` [[49, 7], [38, 7]] || takeFromFT_ 1 t1 `elem` [[54], [66]] =+ 66+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 23+ | otherwise = 39 чT _ = 39 {-# INLINE чT #-} шT :: FlowSound -> Sound8-шT t1@(_:_) | takeFromFT_ 2 t1 `elem` [[49,7],[38,7]] || takeFromFT_ 1 t1 `elem` [[54],[66]] = 54- | isVoicedObstruent . takeFromFT_ 1 $ t1 = 10- | otherwise = 41+шT t1@(_ : _)+ | takeFromFT_ 2 t1 `elem` [[49, 7], [38, 7]] || takeFromFT_ 1 t1 `elem` [[54], [66]] =+ 54+ | isVoicedObstruent . takeFromFT_ 1 $ t1 = 10+ | otherwise = 41 шT _ = 41 {-# INLINE шT #-} takeFromFT :: Int -> FlowSound -> FlowSound-takeFromFT n ts | if n < 1 then True else null ts = []- | n < 2 = [k]- | otherwise = k : takeFromFT (n - 1) (take (n - 1) ts)- where k = head ts+takeFromFT n ts+ | if n < 1 then True else null ts = []+ | n < 2 = [k]+ | otherwise = k : takeFromFT (n - 1) (take (n - 1) ts)+ where+ k = head ts takeFromFT2 :: Int -> FlowSound -> FlowSound-takeFromFT2 n ts | if n < 1 then True else null ts = []- | n < 2 = [ks]- | otherwise = ks:takeFromFT2 (n - 1) (tail ts)- where ks = head ts+takeFromFT2 n ts+ | if n < 1 then True else null ts = []+ | n < 2 = [ks]+ | otherwise = ks : takeFromFT2 (n - 1) (tail ts)+ where+ ks = head ts dropFromFT2 :: Int -> FlowSound -> FlowSound-dropFromFT2 n ts | if n < 1 then True else null ts = []- | n < 2 = tail ts- | otherwise = dropFromFT2 (n - 1) (tail ts)+dropFromFT2 n ts+ | if n < 1 then True else null ts = []+ | n < 2 = tail ts+ | otherwise = dropFromFT2 (n - 1) (tail ts) takeFromFT_ :: Int -> FlowSound -> FlowSound takeFromFT_ n = takeFromFT n . filter (\t -> t > 0 && t < 100) {-# INLINE takeFromFT_ #-} -correctA :: Array Int (Int8,[Int8]) -> FlowSound -> FlowSound+correctA :: Array Int (Int8, [Int8]) -> FlowSound -> FlowSound correctA tup12 = correctSomeW . separateSoftS tup12 {-# INLINE correctA #-} -separateSoftS :: Array Int (Int8,[Int8]) -> FlowSound -> FlowSound+separateSoftS :: Array Int (Int8, [Int8]) -> FlowSound -> FlowSound separateSoftS tup12 = concatMap (\x -> getBFst' ([x], tup12) x) {-# INLINE separateSoftS #-} correctSomeW :: FlowSound -> FlowSound-correctSomeW (x:y:z:xs@(t:ys))- | x == 50 && y == 7 && z == 54 && t == 1 = 66:66:1:correctSomeW ys- | (x > 99) && y == 27 && z == 1 =- if take 2 xs == [39,32]- then x:y:z:41:correctSomeW ys- else x:correctSomeW (y:z:xs)- | otherwise = x:correctSomeW (y:z:xs)+correctSomeW (x : y : z : xs@(t : ys))+ | x == 50 && y == 7 && z == 54 && t == 1 = 66 : 66 : 1 : correctSomeW ys+ | (x > 99) && y == 27 && z == 1 =+ if take 2 xs == [39, 32]+ then x : y : z : 41 : correctSomeW ys+ else x : correctSomeW (y : z : xs)+ | otherwise = x : correctSomeW (y : z : xs) correctSomeW zs = zs correctB :: FlowSound -> FlowSound-correctB ys@(x:xs)- | (length . filter (== 100) . takeFromFT2 6 $ ys) > 1 = map (\t -> if t >= 100 then 101 else t) (takeFromFT2 6 ys) `mappend` correctB (dropFromFT2 6 ys)- | otherwise = (if x > 100 then 101 else x):correctB xs+correctB ys@(x : xs)+ | (length . filter (== 100) . takeFromFT2 6 $ ys) > 1 =+ map (\t -> if t >= 100 then 101 else t) (takeFromFT2 6 ys)+ `mappend` correctB (dropFromFT2 6 ys)+ | otherwise = (if x > 100 then 101 else x) : correctB xs correctB _ = [] -- | Can be used to map the 'Sound8' representation and the mmsyn6ukr-array files with some recordings. linkFileNameI8 :: Sound8 -> Char-linkFileNameI8 = getBFstLSorted' '0' ([(1,'A'),(2,'H'),(3,'Q'),(4,'W'),(5,'K'),(6,'e'),(7,'d'),(8,'G'),(10,'I'),(15,'B'),- (17,'E'),(19,'f'),(21,'D'),(23,'F'),(25,'J'),(27,'L'),(28,'N'),(30,'O'),(32,'P'),(34,'S'),(36,'C'),(38,'Z'),(39,'b'),- (41,'c'),(43,'X'),(45,'M'),(47,'R'),(49,'T'),(50,'V'),(52,'Y'),(54,'U'),(60,'0'),(61,'0'),(66,'a')]) +linkFileNameI8 =+ getBFstLSorted'+ '0'+ ( [ (1, 'A')+ , (2, 'H')+ , (3, 'Q')+ , (4, 'W')+ , (5, 'K')+ , (6, 'e')+ , (7, 'd')+ , (8, 'G')+ , (10, 'I')+ , (15, 'B')+ , (17, 'E')+ , (19, 'f')+ , (21, 'D')+ , (23, 'F')+ , (25, 'J')+ , (27, 'L')+ , (28, 'N')+ , (30, 'O')+ , (32, 'P')+ , (34, 'S')+ , (36, 'C')+ , (38, 'Z')+ , (39, 'b')+ , (41, 'c')+ , (43, 'X')+ , (45, 'M')+ , (47, 'R')+ , (49, 'T')+ , (50, 'V')+ , (52, 'Y')+ , (54, 'U')+ , (60, '0')+ , (61, '0')+ , (66, 'a')+ ]+ ) {-# INLINE linkFileNameI8 #-}-
Aftovolio/Ukrainian/PrepareText.hs view
@@ -1,165 +1,305 @@--- |--- Module : Aftovolio.Ukrainian.PrepareText--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ 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 Ukrainian text--- by applying the most needed grammar for AFTOVolio 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.--{-# OPTIONS_HADDOCK -show-extensions #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK -show-extensions #-} +{- |+Module : Aftovolio.Ukrainian.PrepareText+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com++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 Ukrainian text+by applying the most needed grammar for AFTOVolio 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.+-} module Aftovolio.Ukrainian.PrepareText (- -- * Basic functions- complexWords- , participleConc- , splitLines- , splitLinesN- , auxiliary1- , isPreposition- , isParticipleAppended- , isPrepended- , isConcatenated- , isSpC- , isUkrainianL- , concatenated2- , jottedConv- , jottedCnv- -- * The end-user functions- , prepareText- , prepareTextN- , prepareTextN2- , prepareTextN3- , prepareTextNG- , growLinesN- , prepareGrowTextMN- , prepareGrowTextMNG- , tuneLinesN- , prepareTuneTextMN- , prepareTuneTextMNG- -- * Used to transform after convertToProperUkrainian from mmsyn6ukr package- , aux4+ -- * Basic functions+ complexWords,+ participleConc,+ splitLines,+ splitLinesN,+ auxiliary1,+ isPreposition,+ isParticipleAppended,+ isPrepended,+ isConcatenated,+ isSpC,+ isUkrainianL,+ concatenated2,+ jottedConv,+ jottedCnv,++ -- * The end-user functions+ prepareText,+ prepareTextN,+ prepareTextN2,+ prepareTextN3,+ prepareTextNG,+ growLinesN,+ prepareGrowTextMN,+ prepareGrowTextMNG,+ tuneLinesN,+ prepareTuneTextMN,+ prepareTuneTextMNG,++ -- * Used to transform after convertToProperUkrainian from mmsyn6ukr package+ aux4, ) where -import Data.Bits (shiftR)-import GHC.Base-import Data.List import CaseBi.Arr (getBFstLSorted')+import Data.Bits (shiftR)+import Data.Char (isAlpha, isDigit, toLower) import Data.IntermediateStructures1 (mapI)-import Data.Char (isAlpha,toLower,isDigit)+import Data.List import GHC.Arr+import GHC.Base import GHC.Num ((+)) --- | Is used to convert a Ukrainian text into list of 'String' each of which is ready to be--- used by the functions of the modules for the phonetic languages approach.--- It applies minimal grammar links and connections between the most commonly used Ukrainian--- 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 Ukrainian basis.+{- | Is used to convert a Ukrainian text into list of 'String' each of which is ready to be+used by the functions of the modules for the phonetic languages approach.+It applies minimal grammar links and connections between the most commonly used Ukrainian+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 Ukrainian basis.+-} prepareText :: String -> [String] prepareText = prepareTextN 7 {-# INLINE prepareText #-} --- | Concatenates complex words in Ukrainian so that they are not separated further by possible words order rearrangements (because they are treated--- as a single word). This is needed to preserve basic grammar in phonetic languages.+{- | Concatenates complex words in Ukrainian so that they are not separated further by possible words order rearrangements (because they are treated+as a single word). This is needed to preserve basic grammar in phonetic languages.+-} complexWords :: [String] -> [String]-complexWords wwss@(xs:ys:zs:ts:xss) =- getBFstLSorted' (xs:complexWords (ys:zs:ts:xss)) ([("\1074",- if ys == "\1084\1110\1088\1091" && zs == "\1090\1086\1075\1086" &&- ts == "\1103\1082" then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss else auxiliary4 wwss),- ("\1076\1072\1088\1084\1072", if ys == "\1097\1086"- then auxiliary3 wwss else auxiliary4 wwss), ("\1076\1083\1103",- if ys == "\1090\1086\1075\1086" && zs == "\1097\1086\1073"- then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss- else auxiliary4 wwss), ("\1079",- case ys of- "\1090\1080\1084" -> if zs == "\1097\1086\1073"- then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts:xss)- else auxiliary4 wwss- "\1090\1086\1075\1086" -> if zs == "\1095\1072\1089\1091" && ts == "\1103\1082"- then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` "\1081\1072\1082") xss- else auxiliary4 wwss- _ -> auxiliary4 wwss), ("\1079\1072\1083\1077\1078\1085\1086",- if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss),- ("\1079\1072\1084\1110\1089\1090\1100",- if ys == "\1090\1086\1075\1086" && zs == "\1097\1086\1073"- then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts:xss)- else auxiliary4 wwss), ("\1087\1086\1087\1088\1080",- if ys == "\1090\1077" && zs == "\1097\1086" then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts:xss)- else auxiliary4 wwss),("\1085\1077\1079\1072\1083\1077\1078\1085\1086",- if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss),- ("\1085\1077\1079\1074\1072\1078\1072\1102\1095\1080", if ys == "\1085\1072" then- if zs == "\1090\1077" && ts == "\1097\1086" then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss- else auxiliary3 wwss else auxiliary4 wwss),- ("\1087\1088\1080",- if ys == "\1094\1100\1086\1084\1091" then auxiliary3 wwss- else auxiliary4 wwss), ("\1087\1110\1089\1083\1103",- if ys == "\1090\1086\1075\1086" && zs == "\1103\1082" then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts:xss)- else auxiliary4 wwss), ("\1090\1072\1082", if (ys == "\1097\1086") || (ys == "\1103\1082")- then auxiliary3 wwss else auxiliary4 wwss),- ("\1090\1080\1084\1095\1072\1089\1086\1084", if ys == "\1103\1082"- then auxiliary3 wwss else auxiliary4 wwss),- ("\1090\1086\1084\1091", if ys == "\1103\1082" then auxiliary2Inner (xs `mappend` "\1081\1072\1082") (zs:ts:xss)- else auxiliary4 wwss), ("\1091",- if (ys == "\1079\1074'\1103\1079\1082\1091" || ys == "\1079\1074\x02BC\1103\1079\1082\1091") && zs == "\1079"- then auxiliary2Inner (xs `mappend` "\1079\1074\1081\1072\1079\1082\1091" `mappend` zs) (ts:xss)- else if ys == "\1084\1110\1088\1091" && zs == "\1090\1086\1075\1086" && ts == "\1103\1082"- then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss else auxiliary4 wwss),- ("\1093\1086\1095", if ys == "\1073\1080" then auxiliary3 wwss- else auxiliary4 wwss), ("\1093\1086\1095\1072", if ys == "\1073"- then auxiliary3 wwss else auxiliary4 wwss),- ("\1095\1077\1088\1077\1079", if ys == "\1090\1077" && zs == "\1097\1086"- then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts:xss) else auxiliary4 wwss)]) xs-complexWords wwss@(xs:ys:zs:xss) =- getBFstLSorted' (xs:complexWords [ys,zs]) ([("\1076\1072\1088\1084\1072", if ys == "\1097\1086"- then auxiliary3 wwss else auxiliary4 wwss), ("\1079\1072\1083\1077\1078\1085\1086",- if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss),- ("\1085\1077\1079\1072\1083\1077\1078\1085\1086",- if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss),- ("\1087\1088\1080",- if ys == "\1094\1100\1086\1084\1091" then auxiliary3 wwss- else auxiliary4 wwss), ("\1090\1072\1082", if ys == "\1097\1086" || ys == "\1103\1082"- then auxiliary3 wwss else auxiliary4 wwss),- ("\1090\1080\1084\1095\1072\1089\1086\1084", if ys == "\1103\1082"- then auxiliary3 wwss else auxiliary4 wwss),- ("\1090\1086\1084\1091", if ys == "\1103\1082" then auxiliary2Inner (xs `mappend` "\1081\1072\1082") (zs:xss)- else auxiliary4 wwss), ("\1093\1086\1095", if ys == "\1073\1080" then auxiliary3 wwss- else auxiliary4 wwss), ("\1093\1086\1095\1072", if ys == "\1073"- then auxiliary3 wwss else auxiliary4 wwss)]) xs-complexWords [xs,ys]- | ys `elem` ["\1073","\1073\1060","\1078\1077","\1078"] = [xs `mappend` ys]- | xs == "\1076\1072\1088\1084\1072" && ys == "\1097\1086" = [xs `mappend` ys]- | otherwise = [xs,ys]+complexWords wwss@(xs : ys : zs : ts : xss) =+ getBFstLSorted'+ (xs : complexWords (ys : zs : ts : xss))+ ( [+ ( "\1074"+ , if ys+ == "\1084\1110\1088\1091"+ && zs+ == "\1090\1086\1075\1086"+ && ts+ == "\1103\1082"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss+ else auxiliary4 wwss+ )+ ,+ ( "\1076\1072\1088\1084\1072"+ , if ys == "\1097\1086"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1076\1083\1103"+ , if ys == "\1090\1086\1075\1086" && zs == "\1097\1086\1073"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss+ else auxiliary4 wwss+ )+ ,+ ( "\1079"+ , case ys of+ "\1090\1080\1084" ->+ if zs == "\1097\1086\1073"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts : xss)+ else auxiliary4 wwss+ "\1090\1086\1075\1086" ->+ if zs == "\1095\1072\1089\1091" && ts == "\1103\1082"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` "\1081\1072\1082") xss+ else auxiliary4 wwss+ _ -> auxiliary4 wwss+ )+ ,+ ( "\1079\1072\1083\1077\1078\1085\1086"+ , if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss+ )+ ,+ ( "\1079\1072\1084\1110\1089\1090\1100"+ , if ys == "\1090\1086\1075\1086" && zs == "\1097\1086\1073"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts : xss)+ else auxiliary4 wwss+ )+ ,+ ( "\1087\1086\1087\1088\1080"+ , if ys == "\1090\1077" && zs == "\1097\1086"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts : xss)+ else auxiliary4 wwss+ )+ ,+ ( "\1085\1077\1079\1072\1083\1077\1078\1085\1086"+ , if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss+ )+ ,+ ( "\1085\1077\1079\1074\1072\1078\1072\1102\1095\1080"+ , if ys == "\1085\1072"+ then+ if zs == "\1090\1077" && ts == "\1097\1086"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss+ else auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1087\1088\1080"+ , if ys == "\1094\1100\1086\1084\1091"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1087\1110\1089\1083\1103"+ , if ys == "\1090\1086\1075\1086" && zs == "\1103\1082"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts : xss)+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1072\1082"+ , if (ys == "\1097\1086") || (ys == "\1103\1082")+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1080\1084\1095\1072\1089\1086\1084"+ , if ys == "\1103\1082"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1086\1084\1091"+ , if ys == "\1103\1082"+ then auxiliary2Inner (xs `mappend` "\1081\1072\1082") (zs : ts : xss)+ else auxiliary4 wwss+ )+ ,+ ( "\1091"+ , if ( ys+ == "\1079\1074'\1103\1079\1082\1091"+ || ys+ == "\1079\1074\x02BC\1103\1079\1082\1091"+ )+ && zs+ == "\1079"+ then+ auxiliary2Inner+ (xs `mappend` "\1079\1074\1081\1072\1079\1082\1091" `mappend` zs)+ (ts : xss)+ else+ if ys+ == "\1084\1110\1088\1091"+ && zs+ == "\1090\1086\1075\1086"+ && ts+ == "\1103\1082"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs `mappend` ts) xss+ else auxiliary4 wwss+ )+ ,+ ( "\1093\1086\1095"+ , if ys == "\1073\1080"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1093\1086\1095\1072"+ , if ys == "\1073"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1095\1077\1088\1077\1079"+ , if ys == "\1090\1077" && zs == "\1097\1086"+ then auxiliary2Inner (xs `mappend` ys `mappend` zs) (ts : xss)+ else auxiliary4 wwss+ )+ ]+ )+ xs+complexWords wwss@(xs : ys : zs : xss) =+ getBFstLSorted'+ (xs : complexWords [ys, zs])+ ( [+ ( "\1076\1072\1088\1084\1072"+ , if ys == "\1097\1086"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1079\1072\1083\1077\1078\1085\1086"+ , if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss+ )+ ,+ ( "\1085\1077\1079\1072\1083\1077\1078\1085\1086"+ , if ys == "\1074\1110\1076" then auxiliary3 wwss else auxiliary4 wwss+ )+ ,+ ( "\1087\1088\1080"+ , if ys == "\1094\1100\1086\1084\1091"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1072\1082"+ , if ys == "\1097\1086" || ys == "\1103\1082"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1080\1084\1095\1072\1089\1086\1084"+ , if ys == "\1103\1082"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1090\1086\1084\1091"+ , if ys == "\1103\1082"+ then auxiliary2Inner (xs `mappend` "\1081\1072\1082") (zs : xss)+ else auxiliary4 wwss+ )+ ,+ ( "\1093\1086\1095"+ , if ys == "\1073\1080"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ,+ ( "\1093\1086\1095\1072"+ , if ys == "\1073"+ then auxiliary3 wwss+ else auxiliary4 wwss+ )+ ]+ )+ xs+complexWords [xs, ys]+ | ys `elem` ["\1073", "\1073\1060", "\1078\1077", "\1078"] = [xs `mappend` ys]+ | xs == "\1076\1072\1088\1084\1072" && ys == "\1097\1086" = [xs `mappend` ys]+ | otherwise = [xs, ys] complexWords xss = xss auxiliary2Inner :: String -> [String] -> [String]-auxiliary2Inner ts (xs:ys:xss)- | (concatenated2 . auxiliary1 $ [xs,ys]) /= [xs,ys] = let (rs,ws) = splitAt 1 (concatenated2 . auxiliary1 $ [xs,ys]) in- (ts `mappend` head rs):complexWords (concat [ws,xss])- | otherwise = (ts `mappend` xs):complexWords (ys:xss)+auxiliary2Inner ts (xs : ys : xss)+ | (concatenated2 . auxiliary1 $ [xs, ys]) /= [xs, ys] =+ let (rs, ws) = splitAt 1 (concatenated2 . auxiliary1 $ [xs, ys])+ in (ts `mappend` head rs) : complexWords (concat [ws, xss])+ | otherwise = (ts `mappend` xs) : complexWords (ys : xss) auxiliary2Inner ts [xs] = [ts `mappend` xs] auxiliary2Inner ts _ = [ts] auxiliary3 :: [String] -> [String]-auxiliary3 (xs:ys:xss) = auxiliary2Inner (xs `mappend` ys) xss+auxiliary3 (xs : ys : xss) = auxiliary2Inner (xs `mappend` ys) xss auxiliary3 xss = xss {-# INLINE auxiliary3 #-} auxiliary4 :: [String] -> [String]-auxiliary4 (xs:xss) = auxiliary2Inner xs xss+auxiliary4 (xs : xss) = auxiliary2Inner xs xss auxiliary4 xss = xss {-# INLINE auxiliary4 #-} @@ -171,147 +311,323 @@ -- | 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- splitLines . map unwords . (\(q,r) -> [q,r]) . splitAt (shiftR (length yss) 1) $ yss) $ xss+ | null xss || n <= 0 = []+ | otherwise =+ mapI+ (\xs -> compare (length . words $ xs) n == GT)+ ( \xs ->+ let yss = words xs+ in splitLines . map unwords . (\(q, r) -> [q, r]) . splitAt (shiftR (length yss) 1) $+ yss+ )+ $ xss -- | A generalized variant of the 'prepareText' with the arbitrary maximum number of the words in the lines given as the first argument. prepareTextN :: Int -> String -> [String]-prepareTextN = prepareTextNG (\t -> isAlpha t || isSpC t) +prepareTextN = prepareTextNG (\t -> isAlpha t || isSpC t) {-# INLINE prepareTextN #-} -- | A generalized variant of the 'prepareText' with the arbitrary maximum number of the words in the lines given as the first argument. The \'_\' is not filtered out. prepareTextN2 :: Int -> String -> [String]-prepareTextN2 = prepareTextNG (\t -> isAlpha t || isSpC t || t == '_' || isDigit t) +prepareTextN2 = prepareTextNG (\t -> isAlpha t || isSpC t || t == '_' || isDigit t) {-# INLINE prepareTextN2 #-} -- | A generalized variant of the 'prepareText' with the arbitrary maximum number of the words in the lines given as the first argument. Both \'_\' and \'=\' are not filtered out. prepareTextN3 :: Int -> String -> [String]-prepareTextN3 = prepareTextNG (\t -> isAlpha t || isSpC t || t == '_' || t == '=' || isDigit t) +prepareTextN3 =+ prepareTextNG (\t -> isAlpha t || isSpC t || t == '_' || t == '=' || isDigit t) {-# INLINE prepareTextN3 #-} -- | An even more generalized variant of the 'prepareTextN' with the arbitrary maximum number of the words in the lines given as the second argument and the possibility to provide custom function for filtering.-prepareTextNG - :: (Char -> Bool) -- ^ A predicate to filter the symbols during preparation.- -> Int - -> String - -> [String]-prepareTextNG f n = filter (any isUkrainianL) . splitLinesN n .- map (unwords . concatenated2 . participleConc . auxiliary1 . complexWords . words . filter f) .- filter (not . null) . lines+prepareTextNG ::+ -- | A predicate to filter the symbols during preparation.+ (Char -> Bool) ->+ Int ->+ String ->+ [String]+prepareTextNG f n =+ filter (any isUkrainianL)+ . splitLinesN n+ . map+ ( unwords+ . concatenated2+ . participleConc+ . auxiliary1+ . complexWords+ . words+ . filter f+ )+ . filter (not . null)+ . lines {-# INLINE prepareTextNG #-} participleConc :: [String] -> [String]-participleConc (xs:ys:zs:yss)- | isParticipleAppended ys = if isParticipleAppended zs then (xs `mappend` ys `mappend` zs):participleConc yss- else participleConc (xs `mappend` ys:zs:yss)- | otherwise = xs:participleConc (ys:zs:yss)-participleConc (xs:ys:yss)- | isParticipleAppended ys = (xs `mappend` ys):participleConc yss- | otherwise = xs:participleConc (ys:yss)+participleConc (xs : ys : zs : yss)+ | isParticipleAppended ys =+ if isParticipleAppended zs+ then (xs `mappend` ys `mappend` zs) : participleConc yss+ else participleConc (xs `mappend` ys : zs : yss)+ | otherwise = xs : participleConc (ys : zs : yss)+participleConc (xs : ys : yss)+ | isParticipleAppended ys = (xs `mappend` ys) : participleConc yss+ | otherwise = xs : participleConc (ys : yss) participleConc yss = yss isParticipleAppended :: String -> Bool-isParticipleAppended xs = xs `elem` ["\1073","\1073\1080","\1078\1077","\1078"]+isParticipleAppended xs = xs `elem` ["\1073", "\1073\1080", "\1078\1077", "\1078"] isPrepended :: String -> Bool isPrepended xs- | isParticipleAppended xs = True- | isPreposition xs = True- | otherwise = isConcatenated xs+ | isParticipleAppended xs = True+ | isPreposition xs = True+ | otherwise = isConcatenated xs jottedCnv :: String -> String-jottedCnv xs = drop 1 . jottedConv $ ' ':xs+jottedCnv xs = drop 1 . jottedConv $ ' ' : xs auxiliary1 :: [String] -> [String]-auxiliary1 yss@(xs:zs:xss)- | isParticipleAppended xs = xs:auxiliary1 (zs:xss)- | isPreposition xs || isConcatenated xs = auxiliary1 (concatMap jottedCnv (tss `mappend` wss):vss)- | otherwise = xs:auxiliary1 (zs:xss)- where (tss,uss) = span isPrepended yss- (wss,vss) = splitAt 1 uss+auxiliary1 yss@(xs : zs : xss)+ | isParticipleAppended xs = xs : auxiliary1 (zs : xss)+ | isPreposition xs || isConcatenated xs =+ auxiliary1 (concatMap jottedCnv (tss `mappend` wss) : vss)+ | otherwise = xs : auxiliary1 (zs : xss)+ where+ (tss, uss) = span isPrepended yss+ (wss, vss) = splitAt 1 uss auxiliary1 xss = xss isPreposition :: String -> Bool isPreposition ts =- getBFstLSorted' False- (zip ["\1030\1079", "\1041\1077\1079", "\1041\1110\1083\1103", "\1042",- "\1042\1110\1076", "\1044\1083\1103", "\1044\1086", "\1047",- "\1047\1072", "\1047\1072\1088\1072\1076\1080", "\1047\1110",- "\1050", "\1050\1086\1083\1086", "\1050\1088\1110\1079\1100",- "\1050\1088\1110\1084", "\1052\1077\1078", "\1052\1077\1078\1080",- "\1052\1110\1078", "\1053\1072", "\1053\1072\1076", "\1054",- "\1054\1073", "\1054\1076", "\1054\1082\1088\1110\1084",- "\1055\1077\1088\1077\1076", "\1055\1086", "\1055\1088\1080",- "\1055\1088\1086", "\1055\1088\1086\1090\1080",- "\1055\1110\1076", "\1055\1110\1089\1083\1103",- "\1057\1077\1088\1077\1076", "\1057\1077\1088\1077\1076\1080",- "\1059", "\1063\1077\1088\1077\1079", "\1073\1077\1079",- "\1073\1110\1083\1103", "\1074", "\1074\1110\1076",- "\1076\1083\1103", "\1076\1086", "\1079", "\1079\1072",- "\1079\1072\1088\1072\1076\1080", "\1079\1110",- "\1082", "\1082\1086\1083\1086", "\1082\1088\1110\1079\1100",- "\1082\1088\1110\1084", "\1084\1077\1078", "\1084\1077\1078\1080",- "\1084\1110\1078", "\1085\1072", "\1085\1072\1076", "\1086",- "\1086\1073", "\1086\1076", "\1086\1082\1088\1110\1084",- "\1087\1077\1088\1077\1076", "\1087\1086", "\1087\1088\1080",- "\1087\1088\1086", "\1087\1088\1086\1090\1080", "\1087\1110\1076",- "\1087\1110\1089\1083\1103", "\1089\1077\1088\1077\1076",- "\1089\1077\1088\1077\1076\1080", "\1091",- "\1095\1077\1088\1077\1079", "\1110\1079"] $- replicate 200 True) ts+ getBFstLSorted'+ False+ ( zip+ [ "\1030\1079"+ , "\1041\1077\1079"+ , "\1041\1110\1083\1103"+ , "\1042"+ , "\1042\1110\1076"+ , "\1044\1083\1103"+ , "\1044\1086"+ , "\1047"+ , "\1047\1072"+ , "\1047\1072\1088\1072\1076\1080"+ , "\1047\1110"+ , "\1050"+ , "\1050\1086\1083\1086"+ , "\1050\1088\1110\1079\1100"+ , "\1050\1088\1110\1084"+ , "\1052\1077\1078"+ , "\1052\1077\1078\1080"+ , "\1052\1110\1078"+ , "\1053\1072"+ , "\1053\1072\1076"+ , "\1054"+ , "\1054\1073"+ , "\1054\1076"+ , "\1054\1082\1088\1110\1084"+ , "\1055\1077\1088\1077\1076"+ , "\1055\1086"+ , "\1055\1088\1080"+ , "\1055\1088\1086"+ , "\1055\1088\1086\1090\1080"+ , "\1055\1110\1076"+ , "\1055\1110\1089\1083\1103"+ , "\1057\1077\1088\1077\1076"+ , "\1057\1077\1088\1077\1076\1080"+ , "\1059"+ , "\1063\1077\1088\1077\1079"+ , "\1073\1077\1079"+ , "\1073\1110\1083\1103"+ , "\1074"+ , "\1074\1110\1076"+ , "\1076\1083\1103"+ , "\1076\1086"+ , "\1079"+ , "\1079\1072"+ , "\1079\1072\1088\1072\1076\1080"+ , "\1079\1110"+ , "\1082"+ , "\1082\1086\1083\1086"+ , "\1082\1088\1110\1079\1100"+ , "\1082\1088\1110\1084"+ , "\1084\1077\1078"+ , "\1084\1077\1078\1080"+ , "\1084\1110\1078"+ , "\1085\1072"+ , "\1085\1072\1076"+ , "\1086"+ , "\1086\1073"+ , "\1086\1076"+ , "\1086\1082\1088\1110\1084"+ , "\1087\1077\1088\1077\1076"+ , "\1087\1086"+ , "\1087\1088\1080"+ , "\1087\1088\1086"+ , "\1087\1088\1086\1090\1080"+ , "\1087\1110\1076"+ , "\1087\1110\1089\1083\1103"+ , "\1089\1077\1088\1077\1076"+ , "\1089\1077\1088\1077\1076\1080"+ , "\1091"+ , "\1095\1077\1088\1077\1079"+ , "\1110\1079"+ ]+ $ replicate 200 True+ )+ ts {-# INLINE isPreposition #-} --- | Since the dobutokO-poetry version 0.16.3.0 the (||) operator has been changed to the (&&).--- The idea is that these words are the ones that are pronouns and they \"should\" be treated--- (by the author's understanding) as independent words.+{- | Since the dobutokO-poetry version 0.16.3.0 the (||) operator has been changed to the (&&).+The idea is that these words are the ones that are pronouns and they \"should\" be treated+(by the author's understanding) as independent words.+-} isConcatenated :: String -> Bool isConcatenated ts- | null ts = False- | otherwise = compare (length ts) 2 /= GT &&- getBFstLSorted' True (zip ["\1028", "\1042\1080", "\1052\1080", "\1058\1080", "\1058\1110",- "\1062\1110", "\1071", "\1074\1080", "\1084\1080", "\1090\1080", "\1090\1110",- "\1094\1110", "\1103", "\1108"] $ replicate 14 False) ts && (head ts `notElem` "\1031\1111")+ | null ts = False+ | otherwise =+ compare (length ts) 2+ /= GT+ && getBFstLSorted'+ True+ ( zip+ [ "\1028"+ , "\1042\1080"+ , "\1052\1080"+ , "\1058\1080"+ , "\1058\1110"+ , "\1062\1110"+ , "\1071"+ , "\1074\1080"+ , "\1084\1080"+ , "\1090\1080"+ , "\1090\1110"+ , "\1094\1110"+ , "\1103"+ , "\1108"+ ]+ $ replicate 14 False+ )+ ts+ && (head ts `notElem` "\1031\1111") {-# INLINE isConcatenated #-} concatenated2 :: [String] -> [String]-concatenated2 (xs:ys:xss) =- getBFstLSorted' (xs:concatenated2 (ys:xss)) (zip ["\1040\1073\1086","\1040\1076\1078\1077",- "\1040\1083\1077","\1040\1085\1110\1078","\1041\1086\1076\1072\1081",- "\1041\1091\1094\1110\1084\1090\1086","\1042\1078\1077","\1042\1080\1082\1083\1102\1095\1085\1086",- "\1042\1083\1072\1089\1085\1077","\1042\1090\1110\1084","\1044\1072\1074\1072\1081",- "\1047\1072\1090\1077","\1050\1086\1083\1080","\1051\1077\1076\1074\1077","\1051\1080\1096\1077",- "\1052\1072\1081\1078\1077","\1052\1086\1074","\1052\1086\1074\1073\1080",- "\1052\1086\1074\1073\1080\1090\1086","\1053\1072\1074\1110\1090\1100",- "\1053\1072\1089\1082\1110\1083\1100\1082\1080","\1053\1072\1095\1077","\1053\1072\1095\1077\1073",- "\1053\1072\1095\1077\1073\1090\1086","\1053\1077\1074\1078\1077","\1053\1077\1084\1086\1074",- "\1053\1077\1084\1086\1074\1073\1080","\1053\1077\1084\1086\1074\1073\1080\1090\1086",- "\1053\1077\1085\1072\1095\1077","\1053\1077\1085\1072\1095\1077\1073\1090\1086",- "\1053\1077\1093\1072\1081","\1053\1090\1078\1077","\1053\1110\1073\1080",- "\1053\1110\1073\1080\1090\1086","\1053\1110\1078","\1054\1090\1086\1078",- "\1055\1088\1080\1090\1086\1084\1091","\1055\1088\1080\1090\1110\1084",- "\1055\1088\1080\1095\1086\1084\1091","\1055\1088\1080\1095\1110\1084",- "\1055\1088\1086\1090\1077","\1057\1072\1084\1077","\1057\1077\1073\1090\1086",- "\1058\1072\1082\1080","\1058\1086\1073\1090\1086","\1058\1110\1083\1100\1082\1080",- "\1061\1072\1081","\1061\1086\1095","\1061\1110\1073\1072","\1062\1077\1073\1090\1086",- "\1065\1086\1073","\1071\1082\1073\1080","\1071\1082\1088\1072\1079","\1071\1082\1097\1086",- "\1072\1073\1086","\1072\1076\1078\1077","\1072\1083\1077","\1072\1085\1110\1078",- "\1073\1086\1076\1072\1081","\1073\1091\1094\1110\1084\1090\1086","\1074\1078\1077",- "\1074\1080\1082\1083\1102\1095\1085\1086","\1074\1083\1072\1089\1085\1077",- "\1074\1090\1110\1084","\1076\1072\1074\1072\1081","\1079\1072\1090\1077","\1082\1086\1083\1080",- "\1083\1077\1076\1074\1077","\1083\1080\1096\1077","\1084\1072\1081\1078\1077","\1084\1086\1074",- "\1084\1086\1074\1073\1080","\1084\1086\1074\1073\1080\1090\1086","\1085\1072\1074\1110\1090\1100",- "\1085\1072\1089\1082\1110\1083\1100\1082\1080","\1085\1072\1095\1077","\1085\1072\1095\1077\1073",- "\1085\1072\1095\1077\1073\1090\1086","\1085\1077\1074\1078\1077","\1085\1077\1084\1086\1074",- "\1085\1077\1084\1086\1074\1073\1080","\1085\1077\1084\1086\1074\1073\1080\1090\1086",- "\1085\1077\1085\1072\1095\1077","\1085\1077\1085\1072\1095\1077\1073\1090\1086",- "\1085\1077\1093\1072\1081","\1085\1110\1073\1080","\1085\1110\1073\1080\1090\1086",- "\1085\1110\1078","\1086\1090\1078\1077","\1086\1090\1086\1078","\1087\1088\1080\1090\1086\1084\1091",- "\1087\1088\1080\1090\1110\1084","\1087\1088\1080\1095\1086\1084\1091","\1087\1088\1080\1095\1110\1084",- "\1087\1088\1086\1090\1077","\1089\1072\1084\1077","\1089\1077\1073\1090\1086","\1090\1072\1082\1080",- "\1090\1086\1073\1090\1086","\1090\1110\1083\1100\1082\1080","\1093\1072\1081","\1093\1086\1095",- "\1093\1110\1073\1072","\1094\1077\1073\1090\1086","\1097\1086\1073","\1103\1082\1073\1080",- "\1103\1082\1088\1072\1079","\1103\1082\1097\1086"] $ replicate 200 ((xs `mappend` jottedCnv ys):concatenated2 xss)) xs+concatenated2 (xs : ys : xss) =+ getBFstLSorted'+ (xs : concatenated2 (ys : xss))+ ( zip+ [ "\1040\1073\1086"+ , "\1040\1076\1078\1077"+ , "\1040\1083\1077"+ , "\1040\1085\1110\1078"+ , "\1041\1086\1076\1072\1081"+ , "\1041\1091\1094\1110\1084\1090\1086"+ , "\1042\1078\1077"+ , "\1042\1080\1082\1083\1102\1095\1085\1086"+ , "\1042\1083\1072\1089\1085\1077"+ , "\1042\1090\1110\1084"+ , "\1044\1072\1074\1072\1081"+ , "\1047\1072\1090\1077"+ , "\1050\1086\1083\1080"+ , "\1051\1077\1076\1074\1077"+ , "\1051\1080\1096\1077"+ , "\1052\1072\1081\1078\1077"+ , "\1052\1086\1074"+ , "\1052\1086\1074\1073\1080"+ , "\1052\1086\1074\1073\1080\1090\1086"+ , "\1053\1072\1074\1110\1090\1100"+ , "\1053\1072\1089\1082\1110\1083\1100\1082\1080"+ , "\1053\1072\1095\1077"+ , "\1053\1072\1095\1077\1073"+ , "\1053\1072\1095\1077\1073\1090\1086"+ , "\1053\1077\1074\1078\1077"+ , "\1053\1077\1084\1086\1074"+ , "\1053\1077\1084\1086\1074\1073\1080"+ , "\1053\1077\1084\1086\1074\1073\1080\1090\1086"+ , "\1053\1077\1085\1072\1095\1077"+ , "\1053\1077\1085\1072\1095\1077\1073\1090\1086"+ , "\1053\1077\1093\1072\1081"+ , "\1053\1090\1078\1077"+ , "\1053\1110\1073\1080"+ , "\1053\1110\1073\1080\1090\1086"+ , "\1053\1110\1078"+ , "\1054\1090\1086\1078"+ , "\1055\1088\1080\1090\1086\1084\1091"+ , "\1055\1088\1080\1090\1110\1084"+ , "\1055\1088\1080\1095\1086\1084\1091"+ , "\1055\1088\1080\1095\1110\1084"+ , "\1055\1088\1086\1090\1077"+ , "\1057\1072\1084\1077"+ , "\1057\1077\1073\1090\1086"+ , "\1058\1072\1082\1080"+ , "\1058\1086\1073\1090\1086"+ , "\1058\1110\1083\1100\1082\1080"+ , "\1061\1072\1081"+ , "\1061\1086\1095"+ , "\1061\1110\1073\1072"+ , "\1062\1077\1073\1090\1086"+ , "\1065\1086\1073"+ , "\1071\1082\1073\1080"+ , "\1071\1082\1088\1072\1079"+ , "\1071\1082\1097\1086"+ , "\1072\1073\1086"+ , "\1072\1076\1078\1077"+ , "\1072\1083\1077"+ , "\1072\1085\1110\1078"+ , "\1073\1086\1076\1072\1081"+ , "\1073\1091\1094\1110\1084\1090\1086"+ , "\1074\1078\1077"+ , "\1074\1080\1082\1083\1102\1095\1085\1086"+ , "\1074\1083\1072\1089\1085\1077"+ , "\1074\1090\1110\1084"+ , "\1076\1072\1074\1072\1081"+ , "\1079\1072\1090\1077"+ , "\1082\1086\1083\1080"+ , "\1083\1077\1076\1074\1077"+ , "\1083\1080\1096\1077"+ , "\1084\1072\1081\1078\1077"+ , "\1084\1086\1074"+ , "\1084\1086\1074\1073\1080"+ , "\1084\1086\1074\1073\1080\1090\1086"+ , "\1085\1072\1074\1110\1090\1100"+ , "\1085\1072\1089\1082\1110\1083\1100\1082\1080"+ , "\1085\1072\1095\1077"+ , "\1085\1072\1095\1077\1073"+ , "\1085\1072\1095\1077\1073\1090\1086"+ , "\1085\1077\1074\1078\1077"+ , "\1085\1077\1084\1086\1074"+ , "\1085\1077\1084\1086\1074\1073\1080"+ , "\1085\1077\1084\1086\1074\1073\1080\1090\1086"+ , "\1085\1077\1085\1072\1095\1077"+ , "\1085\1077\1085\1072\1095\1077\1073\1090\1086"+ , "\1085\1077\1093\1072\1081"+ , "\1085\1110\1073\1080"+ , "\1085\1110\1073\1080\1090\1086"+ , "\1085\1110\1078"+ , "\1086\1090\1078\1077"+ , "\1086\1090\1086\1078"+ , "\1087\1088\1080\1090\1086\1084\1091"+ , "\1087\1088\1080\1090\1110\1084"+ , "\1087\1088\1080\1095\1086\1084\1091"+ , "\1087\1088\1080\1095\1110\1084"+ , "\1087\1088\1086\1090\1077"+ , "\1089\1072\1084\1077"+ , "\1089\1077\1073\1090\1086"+ , "\1090\1072\1082\1080"+ , "\1090\1086\1073\1090\1086"+ , "\1090\1110\1083\1100\1082\1080"+ , "\1093\1072\1081"+ , "\1093\1086\1095"+ , "\1093\1110\1073\1072"+ , "\1094\1077\1073\1090\1086"+ , "\1097\1086\1073"+ , "\1103\1082\1073\1080"+ , "\1103\1082\1088\1072\1079"+ , "\1103\1082\1097\1086"+ ]+ $ replicate 200 ((xs `mappend` jottedCnv ys) : concatenated2 xss)+ )+ xs concatenated2 xss = xss isSpC :: Char -> Bool@@ -319,110 +635,134 @@ {-# INLINE isSpC #-} jottedConv :: String -> String-jottedConv (x:y:xs)- | isSpC x = x:(getBFstLSorted' (jottedConv (y:xs))- [('\1028', '\1049':'\1077':jottedConv xs),- ('\1031', '\1049':'\1110':jottedConv xs),- ('\1070', '\1049':'\1091':jottedConv xs),- ('\1071', '\1049':'\1072':jottedConv xs),- ('\1102', '\1081':'\1091':jottedConv xs),- ('\1103', '\1081':'\1072':jottedConv xs),- ('\1108', '\1081':'\1077':jottedConv xs),- ('\1111', '\1081':'\1110':jottedConv xs)] y)- | otherwise = x:jottedConv (y:xs)+jottedConv (x : y : xs)+ | isSpC x =+ x+ : ( getBFstLSorted'+ (jottedConv (y : xs))+ [ ('\1028', '\1049' : '\1077' : jottedConv xs)+ , ('\1031', '\1049' : '\1110' : jottedConv xs)+ , ('\1070', '\1049' : '\1091' : jottedConv xs)+ , ('\1071', '\1049' : '\1072' : jottedConv xs)+ , ('\1102', '\1081' : '\1091' : jottedConv xs)+ , ('\1103', '\1081' : '\1072' : jottedConv xs)+ , ('\1108', '\1081' : '\1077' : jottedConv xs)+ , ('\1111', '\1081' : '\1110' : jottedConv xs)+ ]+ y+ )+ | otherwise = x : jottedConv (y : xs) jottedConv xs = xs --- | Can be used to prepare the text after 'convertToProperUkrainian' from 'Melodics.Ukrainian' module from @mmsyn6ukr@ package so that all the 'String' can--- be represented as unique 'Char'.+{- | Can be used to prepare the text after 'convertToProperUkrainian' from 'Melodics.Ukrainian' module from @mmsyn6ukr@ package so that all the 'String' can+be represented as unique 'Char'.+-} aux4 :: String -> Char aux4 xs- | xs == "\1076\1078" = 'j'- | xs == "\1076\1079" = 'z'- | xs == "\1089\1100" = 's'- | xs == "\1094\1100" = 'c'- | null xs = error "Aftovolio.Ukrainian.PrepareText.aux4: Empty String. "- | otherwise = head xs+ | xs == "\1076\1078" = 'j'+ | xs == "\1076\1079" = 'z'+ | xs == "\1089\1100" = 's'+ | xs == "\1094\1100" = 'c'+ | null xs = error "Aftovolio.Ukrainian.PrepareText.aux4: Empty String. "+ | otherwise = head xs -- | Is taken from the @mmsyn6ukr@ package version 0.8.1.0 so that the amount of dependencies are reduced (and was slightly modified). isUkrainianL :: Char -> Bool-isUkrainianL y | (y >= '\1040' && y <= '\1065') || (y >= '\1070' && y <= '\1097') = True- | otherwise = getBFstLSorted' False (map (\x -> (x, True)) $ "\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217") y+isUkrainianL y+ | (y >= '\1040' && y <= '\1065') || (y >= '\1070' && y <= '\1097') = True+ | otherwise =+ getBFstLSorted'+ False+ ( map (\x -> (x, True)) $+ "\1028\1030\1031\1068\1100\1102\1103\1108\1110\1111\1168\1169\8217"+ )+ y ------------------------------------- -{-| @ since 0.2.0.0+{- | @ since 0.2.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+ | 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.2.0.0+{- | @ since 0.2.0.0 The function combines the 'prepareTextN' and 'growLinesN' function. Applies needed phonetic language preparations to the Ukrainian 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- -> [String]+prepareGrowTextMN ::+ -- | 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.+ Int ->+ String ->+ [String] prepareGrowTextMN m n = growLinesN m . prepareTextN n {-# INLINE prepareGrowTextMN #-} -{-| @ since 0.11.0.0+{- | @ since 0.11.0.0 The generalized version of the 'prepareGrowTextMN' with additional possibility to provide custom function for symbols filtering inside. -}-prepareGrowTextMNG- :: (Char -> Bool) -- ^ A predicate to filter the symbols during preparation.- -> 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- -> [String]+prepareGrowTextMNG ::+ -- | A predicate to filter the symbols during preparation.+ (Char -> Bool) ->+ -- | 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.+ Int ->+ String ->+ [String] prepareGrowTextMNG f m n = growLinesN m . prepareTextNG f n {-# INLINE prepareGrowTextMNG #-} ------------------------------------- -{-| @ since 0.6.0.0+{- | @ 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+ | 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+{- | @ since 0.6.0.0 The function combines the 'prepareTextN' and 'tuneLinesN' functions. Applies needed phonetic language preparations to the Ukrainian 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 number of the words or their concatenations in the resulting list of 'String's (except probably the last one).- -> 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- -> [String]+prepareTuneTextMN ::+ -- | A number of the words or their concatenations in the resulting list of 'String's (except probably the last one).+ 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.+ Int ->+ String ->+ [String] prepareTuneTextMN m n = tuneLinesN m . prepareTextN n {-# INLINE prepareTuneTextMN #-} -{-| @ since 0.11.0.0+{- | @ since 0.11.0.0 The generalized version of the 'prepareTuneTextMN' with additional possibility to provide custom function for symbols filtering inside. -}-prepareTuneTextMNG- :: (Char -> Bool) -- ^ A predicate to filter the symbols during preparation.- -> Int -- ^ A number of the words or their concatenations in the resulting list of 'String's (except probably the last one).- -> 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- -> [String]+prepareTuneTextMNG ::+ -- | A predicate to filter the symbols during preparation.+ (Char -> Bool) ->+ -- | A number of the words or their concatenations in the resulting list of 'String's (except probably the last one).+ 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.+ Int ->+ String ->+ [String] prepareTuneTextMNG f m n = tuneLinesN m . prepareTextNG f n {-# INLINE prepareTuneTextMNG #-}-
Aftovolio/Ukrainian/ReadDurations.hs view
@@ -1,71 +1,124 @@--- |--- Module : Aftovolio.Ukrainian.ReadDurations--- Copyright : (c) OleksandrZhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Functions to read the properties data from the files with the special Haskell-like syntaxis.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns, NoImplicitPrelude #-}+{- |+Module : Aftovolio.Ukrainian.ReadDurations+Copyright : (c) OleksandrZhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Functions to read the properties data from the files with the special Haskell-like syntaxis.+-} module Aftovolio.Ukrainian.ReadDurations where -import GHC.Base-import CaseBi.Arr (getBFstLSorted')+import Aftovolio.General.Datatype3 (zippedDouble2Word8)+import Aftovolio.Ukrainian.Melodics import Aftovolio.Ukrainian.SyllableWord8-import Text.Read (readMaybe)+import CaseBi.Arr (getBFstLSorted')+import Data.List (lines, unlines) import Data.Maybe-import System.IO+import GHC.Base import GHC.List-import Data.List (unlines,lines)-import System.Directory (doesFileExist)-import Aftovolio.Ukrainian.Melodics import GHC.Word-import Aftovolio.General.Datatype3 (zippedDouble2Word8) +import System.Directory (doesFileExist)+import System.IO+import Text.Read (readMaybe) -{-| For more information on implementation, please refer to the link:- -<https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#ability-to-use-your-own-durations-of-representations-of-sounds-or-phonetic-phenomena> +{- | For more information on implementation, please refer to the link:++<https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#ability-to-use-your-own-durations-of-representations-of-sounds-or-phonetic-phenomena> -} sound8s :: FlowSound-sound8s = [1,2,3,4,5,6,7,8,9,10,11,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,- 43,44,45,46,47,48,49,50,51,52,53,54,66,101]--+sound8s =+ [ 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 9+ , 10+ , 11+ , 15+ , 16+ , 17+ , 18+ , 19+ , 20+ , 21+ , 22+ , 23+ , 24+ , 25+ , 26+ , 27+ , 28+ , 29+ , 30+ , 31+ , 32+ , 33+ , 34+ , 35+ , 36+ , 37+ , 38+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , 47+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 66+ , 101+ ] -{-|+{- | -Since the version 0.5.0.0 the semantics changed. Now, there is no duration for the pause between words. +Since the version 0.5.0.0 the semantics changed. Now, there is no duration for the pause between words. The 52 'Double' numbers become the durations of the above specified 'Sound8' values respectively, the order must be preserved (if you consider it important, well, it should be!). If some number in the file cannot be read as a 'Double' number the function uses the first one that can be instead (the default value). If no such is specified at all, then the default number is 5 for all the 'Sound8' sound representations.- -}-readSound8ToWord8 :: String -> (Word8,[(Sound8, Word8)])+readSound8ToWord8 :: String -> (Word8, [(Sound8, Word8)]) readSound8ToWord8 xs- | null xs = (5,zip sound8s . replicate 10000 $ 5)- | otherwise =- let wws = lines xs- dbls = map (\ks -> readMaybe ks::Maybe Double) wws- dbSs = map (fromMaybe 5) dbls in (5,zippedDouble2Word8 . zip sound8s $ dbSs `mappend` replicate 10000 1.0)+ | null xs = (5, zip sound8s . replicate 10000 $ 5)+ | otherwise =+ let wws = lines xs+ dbls = map (\ks -> readMaybe ks :: Maybe Double) wws+ dbSs = map (fromMaybe 5) dbls+ in (5, zippedDouble2Word8 . zip sound8s $ dbSs `mappend` replicate 10000 1.0) divide2SDDs :: String -> [String] divide2SDDs ys- | null tss = [unlines kss]- | otherwise = unlines kss : divide2SDDs (unlines rss)- where wwss = lines ys- (kss,tss) = break (any (=='*')) wwss- rss = dropWhile (any (== '*')) tss+ | null tss = [unlines kss]+ | otherwise = unlines kss : divide2SDDs (unlines rss)+ where+ wwss = lines ys+ (kss, tss) = break (any (== '*')) wwss+ rss = dropWhile (any (== '*')) tss readSyllableDurations :: FilePath -> IO [[[[Sound8]]] -> [[Word8]]] readSyllableDurations file = do- exists <- doesFileExist file- if exists then do - xs <- readFile file- let yss = take 9 . divide2SDDs $ xs- readData = map readSound8ToWord8 yss- return . map (\(d,zs) -> syllableDurationsGDc (getBFstLSorted' d zs)) $ readData- else return []-+ exists <- doesFileExist file+ if exists+ then do+ xs <- readFile file+ let yss = take 9 . divide2SDDs $ xs+ readData = map readSound8ToWord8 yss+ return . map (\(d, zs) -> syllableDurationsGDc (getBFstLSorted' d zs)) $ readData+ else return []
Aftovolio/Ukrainian/ReverseConcatenations.hs view
@@ -1,218 +1,625 @@--- |--- Module : Aftovolio.Ukrainian.ReverseConcatenations--- Copyright : (c) OleksandrZhabenko 2020-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Contains several functions that helps to reverse many of the phonetic languages approach concatenations--- for the Ukrainian language.-+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -threaded -rtsopts #-}- {-# OPTIONS_HADDOCK -show-extensions #-}-{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} +{- |+Module : Aftovolio.Ukrainian.ReverseConcatenations+Copyright : (c) OleksandrZhabenko 2020-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com++Contains several functions that helps to reverse many of the phonetic languages approach concatenations+for the Ukrainian language.+-} module Aftovolio.Ukrainian.ReverseConcatenations where -import Data.Tuple (snd)-import GHC.Base-import Data.List import CaseBi.Arr (getBFstLSorted') import Data.IntermediateStructures1 (mapI)+import Data.List+import Data.Tuple (snd)+import GHC.Base -{-| Reverses many phonetic languages approach related concatenations for the Ukrainian text. Is intended to be used-with the text on several lines. -}+{- | Reverses many phonetic languages approach related concatenations for the Ukrainian text. Is intended to be used+with the text on several lines.+-} reverseConcatenations :: Int -> String -> String reverseConcatenations n xs- | null xs = []- | otherwise = unlines . map (unwords . mapI (const True) (reverseConcat1 n) . words) . lines $ xs- where yss = lines xs- zsss = map words yss+ | null xs = []+ | otherwise =+ unlines . map (unwords . mapI (const True) (reverseConcat1 n) . words) . lines $+ xs+ where+ yss = lines xs+ zsss = map words yss -{-| Reverses many phonetic languages approach related concatenations for just one Ukrainian word. Is used-internally in the 'reverseConcatenations'. -}+{- | Reverses many phonetic languages approach related concatenations for just one Ukrainian word. Is used+internally in the 'reverseConcatenations'.+-} reverseConcat1 :: Int -> String -> [String] reverseConcat1 n xs- | null xs = []- | otherwise = getBFstLSorted' (if n == 2 then reverseConcat2 n xs ts us else [xs]) [- howConcat1WordEntirely n "\1040\1073\1086"us,- ("\1040\1076\1078", howConcat1Word n 1 us "\1077" "\1040\1076\1078\1077" xs),- howConcat1WordEntirely n "\1040\1083\1077" us,- ("\1040\1085\1110", howConcat1Word n 1 us "\1078" "\1040\1085\1110\1078" xs),- ("\1041\1086\1076", howConcat1Word n 2 us "\1072\1081" "\1041\1086\1076\1072\1081" xs),- ("\1041\1091\1094", howConcat1Word n 4 us "\1110\1084\1090\1086" "\1041\1091\1094\1110\1084\1090\1086" xs),- howConcat1WordEntirely n "\1042\1078\1077" us,- ("\1042\1083\1072", howConcat1Word n 3 us "\1089\1085\1077" "\1042\1083\1072\1089\1085\1077" xs),- ("\1042\1090\1110", howConcat1Word n 1 us "\1084" "\1042\1090\1110\1084" xs),- howConcat1WordEntirely n "\1044\1083\1103" us,- ("\1047\1072\1088", howConcat1Word n 3 us "\1072\1076\1080" "\1047\1072\1088\1072\1076\1080" xs),- ("\1050\1088\1110", if take 2 us == "\1079\1100" then "\1050\1088\1110\1079\1100":reverseConcat1 n (drop 2 us)- else if take 1 us == "\1084" then "\1050\1088\1110\1084":reverseConcat1 n (drop 1 us) else [xs]),- ("\1053\1110\1073", if take 3 us == "\1080\1090\1086" then "\1053\1110\1073\1080\1090\1086":- reverseConcat1 n (drop 3 us) else if take 1 us == "\1080" then "\1053\1110\1073\1080":reverseConcat1 n (drop 1 us)- else [xs]),- ("\1054\1082\1088", howConcat1Word n 2 us "\1110\1084" "\1054\1082\1088\1110\1084" xs),- ("\1054\1090\1078", howConcat1Word n 1 us "\1077" "\1054\1090\1078\1077" xs),- ("\1054\1090\1086", howConcat1Word n 1 us "\1078" "\1054\1090\1086\1078" xs),- ("\1055\1088\1080", if take 4 us == "\1090\1086\1084\1091" then "\1055\1088\1080\1090\1086\1084\1091":- reverseConcat1 n (drop 4 us) else if take 3 us == "\1090\1110\1084"- then "\1055\1088\1080\1090\1110\1084":reverseConcat1 n (drop 3 us) else if take 4 us == "\1095\1086\1084\1091"- then "\1055\1088\1080\1095\1086\1084\1091":reverseConcat1 n (drop 4 us)- else if take 3 us == "\1095\1110\1084" then "\1055\1088\1080\1095\1110\1084":reverseConcat1 n (drop 3 us)- else [xs]),- ("\1057\1072\1084", howConcat1Word n 1 us "\1077" "\1057\1072\1084\1077" xs),- ("\1057\1077\1073", howConcat1Word n 2 us "\1090\1086" "\1057\1077\1073\1090\1086" xs),- ("\1058\1072\1082", howConcat1Word n 1 us "\1080" "\1058\1072\1082\1080" xs),- ("\1058\1086\1073", howConcat1Word n 2 us "\1090\1086" "\1058\1086\1073\1090\1086" xs),- howConcat1WordEntirely n "\1061\1072\1081" us,- ("\1061\1110\1073", howConcat1Word n 1 us "\1072" "\1061\1110\1073\1072" xs),- ("\1062\1077\1073", howConcat1Word n 2 us "\1090\1086" "\1062\1077\1073\1090\1086" xs),- howConcat1WordEntirely n "\1065\1086\1073" us,- ("\1071\1082\1073", howConcat1Word n 1 us "\1080" "\1071\1082\1073\1080" xs),- ("\1071\1082\1088", howConcat1Word n 2 us "\1072\1079" "\1071\1082\1088\1072\1079" xs),- ("\1071\1082\1097", howConcat1Word n 1 us "\1086" "\1071\1082\1097\1086" xs),- howConcat1WordEntirely n "\1072\1073\1086" us,("\1072\1076\1078",- howConcat1Word n 1 us "\1077" "\1072\1076\1078\1077" xs),howConcat1WordEntirely n "\1072\1083\1077" us,- ("\1072\1085\1110", howConcat1Word n 1 us "\1078" "\1072\1085\1110\1078" xs),- ("\1073\1086\1076",howConcat1Word n 2 us "\1072\1081" "\1073\1086\1076\1072\1081" xs),- ("\1073\1091\1094",howConcat1Word n 4 us "\1110\1084\1090\1086" "\1073\1091\1094\1110\1084\1090\1086" xs),- howConcat1WordEntirely n "\1074\1078\1077" us, ("\1074\1080\1082",- howConcat1Word n 5 us "\1083\1102\1095\1085\1086" "\1074\1080\1082\1083\1102\1095\1085\1086" xs),- ("\1074\1083\1072",howConcat1Word n 3 us "\1089\1085\1077" "\1074\1083\1072\1089\1085\1077" xs),- ("\1074\1084\1110",if take 8 us == "\1088\1091\1090\1086\1075\1086\1103\1082"- then "\1074":"\1084\1110\1088\1091":"\1090\1086\1075\1086":"\1103\1082":reverseConcat1 n (drop 11 xs)- else [xs]), ("\1074\1090\1110",howConcat1Word n 1 us "\1084" "\1074\1090\1110\1084" xs),- ("\1076\1072\1074",howConcat1Word n 2 us "\1072\1081" "\1076\1072\1074\1072\1081" xs),- ("\1076\1072\1088",howConcat1Word n 4 us "\1084\1072\1097\1086" "\1076\1072\1088\1084\1072\1097\1086" xs),- ("\1076\1083\1103", if take 7 us == "\1090\1086\1075\1086\1097\1086\1073"- then "\1076\1083\1103":"\1090\1086\1075\1086":"\1097\1086\1073":reverseConcat1 n (drop 7 xs)- else [xs]), ("\1079\1072\1083", if take 7 us == "\1077\1078\1085\1086\1074\1110\1076"- then "\1079\1072\1083\1077\1078\1085\1086":"\1074\1110\1076":reverseConcat1 n (drop 7 xs)- else [xs]), ("\1079\1072\1084", if take 11 us == "\1110\1089\1090\1100\1090\1086\1075\1086\1097\1086\1073"- then "\1079\1072\1084\1110\1089\1090\1100":"\1090\1086\1075\1086":"\1097\1086\1073":- reverseConcat1 n (drop 11 xs) else [xs]),- ("\1079\1072\1088", howConcat1Word n 3 us "\1072\1076\1080" "\1079\1072\1088\1072\1076\1080" xs),- ("\1079\1072\1090", howConcat1Word n 1 us "\1077" "\1079\1072\1090\1077" xs), ("\1079\1090\1080",- if take 4 us == "\1084\1097\1086\1073" then "\1079":"\1090\1080\1084":"\1097\1086\1073":- reverseConcat1 n (drop 4 xs) else [xs]),- ("\1079\1090\1086", if take 8 us == "\1075\1086\1095\1072\1089\1091\1103\1082"- then "\1079":"\1090\1086\1075\1086":"\1095\1072\1089\1091":"\1103\1082":reverseConcat1 n (drop 8 xs)- else [xs]), ("\1082\1086\1083", howConcat1Word n 1 us "\1080" "\1082\1086\1083\1080" xs),- ("\1082\1088\1110", if take 2 us == "\1079\1100" then "\1082\1088\1110\1079\1100":reverseConcat1 n (drop 2 us)- else if take 1 us == "\1084" then "\1082\1088\1110\1084":reverseConcat1 n (drop 1 us) else [xs]),- ("\1083\1077\1076", howConcat1Word n 2 us "\1074\1077" "\1083\1077\1076\1074\1077" xs),- ("\1083\1080\1096", howConcat1Word n 1 us "\1077" "\1083\1080\1096\1077" xs),- ("\1084\1072\1081", howConcat1Word n 2 us "\1078\1077" "\1084\1072\1081\1078\1077" xs),- ("\1084\1086\1074", if take 4 us == "\1073\1080\1090\1086" then "\1084\1086\1074\1073\1080\1090\1086":- reverseConcat1 n (drop 4 us)- else if take 2 us == "\1073\1080" then "\1084\1086\1074\1073\1080":reverseConcat1 n (drop 2 us)- else snd (howConcat1WordEntirely n "\1084\1086\1074" us)),- ("\1085\1072\1074", howConcat1Word n 3 us "\1110\1090\1100" "\1085\1072\1074\1110\1090\1100" xs),- ("\1085\1072\1089", howConcat1Word n 6 us "\1082\1110\1083\1100\1082\1080" "\1085\1072\1089\1082\1110\1083\1100\1082\1080" xs),- ("\1085\1072\1095", if take 4 us == "\1077\1073\1090\1086" then "\1085\1072\1095\1077\1073\1090\1086":- reverseConcat1 n (drop 4 us)- else if take 2 us == "\1077\1073" then "\1085\1072\1095\1077\1073":reverseConcat1 n (drop 2 us)- else if take 1 us == "\1077"- then "\1085\1072\1095\1077":reverseConcat1 n (drop 1 us) else [xs]),("\1085\1077\1074",- howConcat1Word n 2 us "\1078\1077" "\1085\1077\1074\1078\1077" xs),- ("\1085\1077\1079", if take 9 us == "\1072\1083\1077\1078\1085\1086\1074\1110\1076"- then "\1085\1077\1079\1072\1083\1077\1078\1085\1086\1074\1110\1076":reverseConcat1 n (drop 9 us) else- if take 13 us == "\1074\1072\1078\1072\1102\1095\1080\1085\1072\1090\1077\1097\1086"- then "\1085\1077\1079\1074\1072\1078\1072\1102\1095\1080\1085\1072\1090\1077\1097\1086":- reverseConcat1 n (drop 13 us)- else [xs]),("\1085\1077\1084", if take 6 us == "\1086\1074\1073\1080\1090\1086"- then "\1085\1077\1084\1086\1074\1073\1080\1090\1086":reverseConcat1 n (drop 6 us)- else if take 4 us == "\1086\1074\1073\1080" then "\1085\1077\1084\1086\1074\1073\1080":- reverseConcat1 n (drop 4 us) else- if take 2 us == "\1086\1074" then "\1085\1077\1084\1086\1074":reverseConcat1 n (drop 2 us) else [xs]),- ("\1085\1077\1085", if take 6 us == "\1072\1095\1077\1073\1090\1086"- then "\1085\1077\1085\1072\1095\1077\1073\1090\1086":reverseConcat1 n (drop 6 us)- else if take 3 us == "\1072\1095\1077" then "\1085\1077\1085\1072\1095\1077":- reverseConcat1 n (drop 3 us) else [xs]),- ("\1085\1077\1093", howConcat1Word n 2 us "\1072\1081" "\1085\1077\1093\1072\1081" xs),- ("\1085\1110\1073", if take 3 us == "\1080\1090\1086" then "\1085\1110\1073\1080\1090\1086":- reverseConcat1 n (drop 3 us) else- if take 1 us == "\1080" then "\1085\1110\1073\1080":reverseConcat1 n (drop 1 us) else [xs]),- howConcat1WordEntirely n "\1085\1110\1078" us,- ("\1086\1082\1088", howConcat1Word n 2 us "\1110\1084" "\1086\1082\1088\1110\1084" xs),- ("\1086\1090\1078", howConcat1Word n 1 us "\1077" "\1086\1090\1078\1077" xs),- ("\1086\1090\1086", howConcat1Word n 1 us "\1078" "\1086\1090\1086\1078" xs),- ("\1087\1086\1087", if take 6 us == "\1088\1080\1090\1077\1097\1086"- then "\1087\1086\1087\1088\1080":"\1090\1077":"\1097\1086":reverseConcat1 n (drop 6 us) else [xs]),- ("\1087\1088\1080", if take 4 us == "\1090\1086\1084\1091" then "\1087\1088\1080\1090\1086\1084\1091":- reverseConcat1 n (drop 4 us)- else if take 3 us == "\1090\1110\1084" then "\1087\1088\1080\1090\1110\1084":- reverseConcat1 n (drop 3 us) else- if take 5 us == "\1094\1100\1086\1084\1091" then "\1087\1088\1080\1094\1100\1086\1084\1091":- reverseConcat1 n (drop 5 us) else- if take 4 us == "\1095\1086\1084\1091" then "\1087\1088\1080\1095\1086\1084\1091":- reverseConcat1 n (drop 4 us) else- if take 3 us == "\1095\1110\1084" then "\1087\1088\1080\1095\1110\1084":reverseConcat1 n (drop 3 us)- else [xs]),- ("\1087\1088\1086", howConcat1Word n 2 us "\1090\1077" "\1087\1088\1086\1090\1077" xs),- ("\1087\1110\1089", if take 8 us == "\1083\1103\1090\1086\1075\1086\1103\1082"- then "\1087\1110\1089\1083\1103":"\1090\1086\1075\1086":"\1103\1082":reverseConcat1 n (drop 8 us)- else [xs]), ("\1089\1072\1084", howConcat1Word n 1 us "\1077" "\1089\1072\1084\1077" xs),- ("\1089\1077\1073", howConcat1Word n 2 us "\1090\1086" "\1089\1077\1073\1090\1086" xs),- ("\1090\1072\1082", if take 1 us == "\1080" then "\1090\1072\1082\1080":reverseConcat1 n (drop 1 us) else- if take 3 us == "\1081\1072\1082" then "\1090\1072\1082":"\1103\1082":reverseConcat1 n (drop 3 us) else- if take 2 us == "\1097\1086" then "\1090\1072\1082":"\1097\1086":reverseConcat1 n (drop 2 us) else [xs]),- ("\1090\1080\1084", if take 8 us == "\1095\1072\1089\1086\1084\1081\1072\1082"- then "\1090\1080\1084":"\1095\1072\1089\1086\1084":"\1103\1082":reverseConcat1 n (drop 8 us) else [xs]),- ("\1090\1086\1073", howConcat1Word n 2 us "\1090\1086" "\1090\1086\1073\1090\1086" xs),- ("\1090\1086\1084", if take 3 us == "\1091\1097\1086" then "\1090\1086\1084\1091":"\1097\1086":- reverseConcat1 n (drop 3 us)- else if take 3 us == "\1091\1103\1082" then "\1090\1086\1084\1091":"\1103\1082":- reverseConcat1 n (drop 3 us) else [xs]),- ("\1090\1110\1083", howConcat1Word n 3 us "\1100\1082\1080" "\1090\1110\1083\1100\1082\1080" xs),- ("\1091\1079\1074", if take 6 us == "\1081\1072\1079\1082\1091\1079"- then "\1091":"\1079\1074\x02BC\1103\1079\1082\1091":"\1079":reverseConcat1 n (drop 6 us) else [xs]),- ("\1091\1084\1110", if take 8 us == "\1088\1091\1090\1086\1075\1086\1103\1082"- then "\1091":"\1084\1110\1088\1091":"\1090\1086\1075\1086":"\1103\1082":reverseConcat1 n (drop 8 us)- else [xs]), howConcat1WordEntirely n "\1093\1072\1081" us,("\1093\1086\1095", if take 2 us == "\1073\1080"- then "\1093\1086\1095":"\1073\1080":reverseConcat1 n (drop 2 us) else if take 2 us == "\1072\1073"- then "\1093\1086\1095\1072":"\1073":reverseConcat1 n (drop 2 us) else "\1093\1086\1095":[us]),- ("\1093\1110\1073", howConcat1Word n 1 us "\1072" "\1093\1110\1073\1072" xs),- ("\1094\1077\1073", howConcat1Word n 2 us "\1090\1086" "\1094\1077\1073\1090\1086" xs),- ("\1095\1077\1088", if take 6 us == "\1077\1079\1090\1077\1097\1086"- then "\1095\1077\1088\1077\1079":"\1090\1077":"\1097\1086":reverseConcat1 n (drop 6 us) else [xs]),- howConcat1WordEntirely n "\1097\1086\1073" us, ("\1103\1082\1073",- howConcat1Word n 1 us "\1080" "\1103\1082\1073\1080" xs),- ("\1103\1082\1088", howConcat1Word n 2 us "\1072\1079" "\1103\1082\1088\1072\1079" xs),- ("\1103\1082\1097", howConcat1Word n 1 us "\1086" "\1103\1082\1097\1086" xs)] ts- where (ts,us) = splitAt 3 xs+ | null xs = []+ | otherwise =+ getBFstLSorted'+ (if n == 2 then reverseConcat2 n xs ts us else [xs])+ [ howConcat1WordEntirely n "\1040\1073\1086" us+ , ("\1040\1076\1078", howConcat1Word n 1 us "\1077" "\1040\1076\1078\1077" xs)+ , howConcat1WordEntirely n "\1040\1083\1077" us+ , ("\1040\1085\1110", howConcat1Word n 1 us "\1078" "\1040\1085\1110\1078" xs)+ ,+ ( "\1041\1086\1076"+ , howConcat1Word n 2 us "\1072\1081" "\1041\1086\1076\1072\1081" xs+ )+ ,+ ( "\1041\1091\1094"+ , howConcat1Word+ n+ 4+ us+ "\1110\1084\1090\1086"+ "\1041\1091\1094\1110\1084\1090\1086"+ xs+ )+ , howConcat1WordEntirely n "\1042\1078\1077" us+ ,+ ( "\1042\1083\1072"+ , howConcat1Word n 3 us "\1089\1085\1077" "\1042\1083\1072\1089\1085\1077" xs+ )+ , ("\1042\1090\1110", howConcat1Word n 1 us "\1084" "\1042\1090\1110\1084" xs)+ , howConcat1WordEntirely n "\1044\1083\1103" us+ ,+ ( "\1047\1072\1088"+ , howConcat1Word n 3 us "\1072\1076\1080" "\1047\1072\1088\1072\1076\1080" xs+ )+ ,+ ( "\1050\1088\1110"+ , if take 2 us == "\1079\1100"+ then "\1050\1088\1110\1079\1100" : reverseConcat1 n (drop 2 us)+ else+ if take 1 us == "\1084"+ then "\1050\1088\1110\1084" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ ,+ ( "\1053\1110\1073"+ , if take 3 us == "\1080\1090\1086"+ then+ "\1053\1110\1073\1080\1090\1086"+ : reverseConcat1 n (drop 3 us)+ else+ if take 1 us == "\1080"+ then "\1053\1110\1073\1080" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ ,+ ( "\1054\1082\1088"+ , howConcat1Word n 2 us "\1110\1084" "\1054\1082\1088\1110\1084" xs+ )+ , ("\1054\1090\1078", howConcat1Word n 1 us "\1077" "\1054\1090\1078\1077" xs)+ , ("\1054\1090\1086", howConcat1Word n 1 us "\1078" "\1054\1090\1086\1078" xs)+ ,+ ( "\1055\1088\1080"+ , if take 4 us == "\1090\1086\1084\1091"+ then+ "\1055\1088\1080\1090\1086\1084\1091"+ : reverseConcat1 n (drop 4 us)+ else+ if take 3 us == "\1090\1110\1084"+ then "\1055\1088\1080\1090\1110\1084" : reverseConcat1 n (drop 3 us)+ else+ if take 4 us == "\1095\1086\1084\1091"+ then "\1055\1088\1080\1095\1086\1084\1091" : reverseConcat1 n (drop 4 us)+ else+ if take 3 us == "\1095\1110\1084"+ then "\1055\1088\1080\1095\1110\1084" : reverseConcat1 n (drop 3 us)+ else [xs]+ )+ , ("\1057\1072\1084", howConcat1Word n 1 us "\1077" "\1057\1072\1084\1077" xs)+ ,+ ( "\1057\1077\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1057\1077\1073\1090\1086" xs+ )+ , ("\1058\1072\1082", howConcat1Word n 1 us "\1080" "\1058\1072\1082\1080" xs)+ ,+ ( "\1058\1086\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1058\1086\1073\1090\1086" xs+ )+ , howConcat1WordEntirely n "\1061\1072\1081" us+ , ("\1061\1110\1073", howConcat1Word n 1 us "\1072" "\1061\1110\1073\1072" xs)+ ,+ ( "\1062\1077\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1062\1077\1073\1090\1086" xs+ )+ , howConcat1WordEntirely n "\1065\1086\1073" us+ , ("\1071\1082\1073", howConcat1Word n 1 us "\1080" "\1071\1082\1073\1080" xs)+ ,+ ( "\1071\1082\1088"+ , howConcat1Word n 2 us "\1072\1079" "\1071\1082\1088\1072\1079" xs+ )+ , ("\1071\1082\1097", howConcat1Word n 1 us "\1086" "\1071\1082\1097\1086" xs)+ , howConcat1WordEntirely n "\1072\1073\1086" us+ ,+ ( "\1072\1076\1078"+ , howConcat1Word n 1 us "\1077" "\1072\1076\1078\1077" xs+ )+ , howConcat1WordEntirely n "\1072\1083\1077" us+ , ("\1072\1085\1110", howConcat1Word n 1 us "\1078" "\1072\1085\1110\1078" xs)+ ,+ ( "\1073\1086\1076"+ , howConcat1Word n 2 us "\1072\1081" "\1073\1086\1076\1072\1081" xs+ )+ ,+ ( "\1073\1091\1094"+ , howConcat1Word+ n+ 4+ us+ "\1110\1084\1090\1086"+ "\1073\1091\1094\1110\1084\1090\1086"+ xs+ )+ , howConcat1WordEntirely n "\1074\1078\1077" us+ ,+ ( "\1074\1080\1082"+ , howConcat1Word+ n+ 5+ us+ "\1083\1102\1095\1085\1086"+ "\1074\1080\1082\1083\1102\1095\1085\1086"+ xs+ )+ ,+ ( "\1074\1083\1072"+ , howConcat1Word n 3 us "\1089\1085\1077" "\1074\1083\1072\1089\1085\1077" xs+ )+ ,+ ( "\1074\1084\1110"+ , if take 8 us == "\1088\1091\1090\1086\1075\1086\1103\1082"+ then+ "\1074"+ : "\1084\1110\1088\1091"+ : "\1090\1086\1075\1086"+ : "\1103\1082"+ : reverseConcat1 n (drop 11 xs)+ else [xs]+ )+ , ("\1074\1090\1110", howConcat1Word n 1 us "\1084" "\1074\1090\1110\1084" xs)+ ,+ ( "\1076\1072\1074"+ , howConcat1Word n 2 us "\1072\1081" "\1076\1072\1074\1072\1081" xs+ )+ ,+ ( "\1076\1072\1088"+ , howConcat1Word+ n+ 4+ us+ "\1084\1072\1097\1086"+ "\1076\1072\1088\1084\1072\1097\1086"+ xs+ )+ ,+ ( "\1076\1083\1103"+ , if take 7 us == "\1090\1086\1075\1086\1097\1086\1073"+ then+ "\1076\1083\1103"+ : "\1090\1086\1075\1086"+ : "\1097\1086\1073"+ : reverseConcat1 n (drop 7 xs)+ else [xs]+ )+ ,+ ( "\1079\1072\1083"+ , if take 7 us == "\1077\1078\1085\1086\1074\1110\1076"+ then+ "\1079\1072\1083\1077\1078\1085\1086"+ : "\1074\1110\1076"+ : reverseConcat1 n (drop 7 xs)+ else [xs]+ )+ ,+ ( "\1079\1072\1084"+ , if take 11 us == "\1110\1089\1090\1100\1090\1086\1075\1086\1097\1086\1073"+ then+ "\1079\1072\1084\1110\1089\1090\1100"+ : "\1090\1086\1075\1086"+ : "\1097\1086\1073"+ : reverseConcat1 n (drop 11 xs)+ else [xs]+ )+ ,+ ( "\1079\1072\1088"+ , howConcat1Word n 3 us "\1072\1076\1080" "\1079\1072\1088\1072\1076\1080" xs+ )+ , ("\1079\1072\1090", howConcat1Word n 1 us "\1077" "\1079\1072\1090\1077" xs)+ ,+ ( "\1079\1090\1080"+ , if take 4 us == "\1084\1097\1086\1073"+ then+ "\1079"+ : "\1090\1080\1084"+ : "\1097\1086\1073"+ : reverseConcat1 n (drop 4 xs)+ else [xs]+ )+ ,+ ( "\1079\1090\1086"+ , if take 8 us == "\1075\1086\1095\1072\1089\1091\1103\1082"+ then+ "\1079"+ : "\1090\1086\1075\1086"+ : "\1095\1072\1089\1091"+ : "\1103\1082"+ : reverseConcat1 n (drop 8 xs)+ else [xs]+ )+ , ("\1082\1086\1083", howConcat1Word n 1 us "\1080" "\1082\1086\1083\1080" xs)+ ,+ ( "\1082\1088\1110"+ , if take 2 us == "\1079\1100"+ then "\1082\1088\1110\1079\1100" : reverseConcat1 n (drop 2 us)+ else+ if take 1 us == "\1084"+ then "\1082\1088\1110\1084" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ ,+ ( "\1083\1077\1076"+ , howConcat1Word n 2 us "\1074\1077" "\1083\1077\1076\1074\1077" xs+ )+ , ("\1083\1080\1096", howConcat1Word n 1 us "\1077" "\1083\1080\1096\1077" xs)+ ,+ ( "\1084\1072\1081"+ , howConcat1Word n 2 us "\1078\1077" "\1084\1072\1081\1078\1077" xs+ )+ ,+ ( "\1084\1086\1074"+ , if take 4 us == "\1073\1080\1090\1086"+ then+ "\1084\1086\1074\1073\1080\1090\1086"+ : reverseConcat1 n (drop 4 us)+ else+ if take 2 us == "\1073\1080"+ then "\1084\1086\1074\1073\1080" : reverseConcat1 n (drop 2 us)+ else snd (howConcat1WordEntirely n "\1084\1086\1074" us)+ )+ ,+ ( "\1085\1072\1074"+ , howConcat1Word n 3 us "\1110\1090\1100" "\1085\1072\1074\1110\1090\1100" xs+ )+ ,+ ( "\1085\1072\1089"+ , howConcat1Word+ n+ 6+ us+ "\1082\1110\1083\1100\1082\1080"+ "\1085\1072\1089\1082\1110\1083\1100\1082\1080"+ xs+ )+ ,+ ( "\1085\1072\1095"+ , if take 4 us == "\1077\1073\1090\1086"+ then+ "\1085\1072\1095\1077\1073\1090\1086"+ : reverseConcat1 n (drop 4 us)+ else+ if take 2 us == "\1077\1073"+ then "\1085\1072\1095\1077\1073" : reverseConcat1 n (drop 2 us)+ else+ if take 1 us == "\1077"+ then "\1085\1072\1095\1077" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ ,+ ( "\1085\1077\1074"+ , howConcat1Word n 2 us "\1078\1077" "\1085\1077\1074\1078\1077" xs+ )+ ,+ ( "\1085\1077\1079"+ , if take 9 us == "\1072\1083\1077\1078\1085\1086\1074\1110\1076"+ then+ "\1085\1077\1079\1072\1083\1077\1078\1085\1086\1074\1110\1076"+ : reverseConcat1 n (drop 9 us)+ else+ if take 13 us+ == "\1074\1072\1078\1072\1102\1095\1080\1085\1072\1090\1077\1097\1086"+ then+ "\1085\1077\1079\1074\1072\1078\1072\1102\1095\1080\1085\1072\1090\1077\1097\1086"+ : reverseConcat1 n (drop 13 us)+ else [xs]+ )+ ,+ ( "\1085\1077\1084"+ , if take 6 us == "\1086\1074\1073\1080\1090\1086"+ then "\1085\1077\1084\1086\1074\1073\1080\1090\1086" : reverseConcat1 n (drop 6 us)+ else+ if take 4 us == "\1086\1074\1073\1080"+ then+ "\1085\1077\1084\1086\1074\1073\1080"+ : reverseConcat1 n (drop 4 us)+ else+ if take 2 us == "\1086\1074"+ then "\1085\1077\1084\1086\1074" : reverseConcat1 n (drop 2 us)+ else [xs]+ )+ ,+ ( "\1085\1077\1085"+ , if take 6 us == "\1072\1095\1077\1073\1090\1086"+ then "\1085\1077\1085\1072\1095\1077\1073\1090\1086" : reverseConcat1 n (drop 6 us)+ else+ if take 3 us == "\1072\1095\1077"+ then+ "\1085\1077\1085\1072\1095\1077"+ : reverseConcat1 n (drop 3 us)+ else [xs]+ )+ ,+ ( "\1085\1077\1093"+ , howConcat1Word n 2 us "\1072\1081" "\1085\1077\1093\1072\1081" xs+ )+ ,+ ( "\1085\1110\1073"+ , if take 3 us == "\1080\1090\1086"+ then+ "\1085\1110\1073\1080\1090\1086"+ : reverseConcat1 n (drop 3 us)+ else+ if take 1 us == "\1080"+ then "\1085\1110\1073\1080" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ , howConcat1WordEntirely n "\1085\1110\1078" us+ ,+ ( "\1086\1082\1088"+ , howConcat1Word n 2 us "\1110\1084" "\1086\1082\1088\1110\1084" xs+ )+ , ("\1086\1090\1078", howConcat1Word n 1 us "\1077" "\1086\1090\1078\1077" xs)+ , ("\1086\1090\1086", howConcat1Word n 1 us "\1078" "\1086\1090\1086\1078" xs)+ ,+ ( "\1087\1086\1087"+ , if take 6 us == "\1088\1080\1090\1077\1097\1086"+ then+ "\1087\1086\1087\1088\1080"+ : "\1090\1077"+ : "\1097\1086"+ : reverseConcat1 n (drop 6 us)+ else [xs]+ )+ ,+ ( "\1087\1088\1080"+ , if take 4 us == "\1090\1086\1084\1091"+ then+ "\1087\1088\1080\1090\1086\1084\1091"+ : reverseConcat1 n (drop 4 us)+ else+ if take 3 us == "\1090\1110\1084"+ then+ "\1087\1088\1080\1090\1110\1084"+ : reverseConcat1 n (drop 3 us)+ else+ if take 5 us == "\1094\1100\1086\1084\1091"+ then+ "\1087\1088\1080\1094\1100\1086\1084\1091"+ : reverseConcat1 n (drop 5 us)+ else+ if take 4 us == "\1095\1086\1084\1091"+ then+ "\1087\1088\1080\1095\1086\1084\1091"+ : reverseConcat1 n (drop 4 us)+ else+ if take 3 us == "\1095\1110\1084"+ then "\1087\1088\1080\1095\1110\1084" : reverseConcat1 n (drop 3 us)+ else [xs]+ )+ ,+ ( "\1087\1088\1086"+ , howConcat1Word n 2 us "\1090\1077" "\1087\1088\1086\1090\1077" xs+ )+ ,+ ( "\1087\1110\1089"+ , if take 8 us == "\1083\1103\1090\1086\1075\1086\1103\1082"+ then+ "\1087\1110\1089\1083\1103"+ : "\1090\1086\1075\1086"+ : "\1103\1082"+ : reverseConcat1 n (drop 8 us)+ else [xs]+ )+ , ("\1089\1072\1084", howConcat1Word n 1 us "\1077" "\1089\1072\1084\1077" xs)+ ,+ ( "\1089\1077\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1089\1077\1073\1090\1086" xs+ )+ ,+ ( "\1090\1072\1082"+ , if take 1 us == "\1080"+ then "\1090\1072\1082\1080" : reverseConcat1 n (drop 1 us)+ else+ if take 3 us == "\1081\1072\1082"+ then "\1090\1072\1082" : "\1103\1082" : reverseConcat1 n (drop 3 us)+ else+ if take 2 us == "\1097\1086"+ then "\1090\1072\1082" : "\1097\1086" : reverseConcat1 n (drop 2 us)+ else [xs]+ )+ ,+ ( "\1090\1080\1084"+ , if take 8 us == "\1095\1072\1089\1086\1084\1081\1072\1082"+ then+ "\1090\1080\1084"+ : "\1095\1072\1089\1086\1084"+ : "\1103\1082"+ : reverseConcat1 n (drop 8 us)+ else [xs]+ )+ ,+ ( "\1090\1086\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1090\1086\1073\1090\1086" xs+ )+ ,+ ( "\1090\1086\1084"+ , if take 3 us == "\1091\1097\1086"+ then+ "\1090\1086\1084\1091"+ : "\1097\1086"+ : reverseConcat1 n (drop 3 us)+ else+ if take 3 us == "\1091\1103\1082"+ then+ "\1090\1086\1084\1091"+ : "\1103\1082"+ : reverseConcat1 n (drop 3 us)+ else [xs]+ )+ ,+ ( "\1090\1110\1083"+ , howConcat1Word n 3 us "\1100\1082\1080" "\1090\1110\1083\1100\1082\1080" xs+ )+ ,+ ( "\1091\1079\1074"+ , if take 6 us == "\1081\1072\1079\1082\1091\1079"+ then+ "\1091"+ : "\1079\1074\x02BC\1103\1079\1082\1091"+ : "\1079"+ : reverseConcat1 n (drop 6 us)+ else [xs]+ )+ ,+ ( "\1091\1084\1110"+ , if take 8 us == "\1088\1091\1090\1086\1075\1086\1103\1082"+ then+ "\1091"+ : "\1084\1110\1088\1091"+ : "\1090\1086\1075\1086"+ : "\1103\1082"+ : reverseConcat1 n (drop 8 us)+ else [xs]+ )+ , howConcat1WordEntirely n "\1093\1072\1081" us+ ,+ ( "\1093\1086\1095"+ , if take 2 us == "\1073\1080"+ then "\1093\1086\1095" : "\1073\1080" : reverseConcat1 n (drop 2 us)+ else+ if take 2 us == "\1072\1073"+ then "\1093\1086\1095\1072" : "\1073" : reverseConcat1 n (drop 2 us)+ else "\1093\1086\1095" : [us]+ )+ , ("\1093\1110\1073", howConcat1Word n 1 us "\1072" "\1093\1110\1073\1072" xs)+ ,+ ( "\1094\1077\1073"+ , howConcat1Word n 2 us "\1090\1086" "\1094\1077\1073\1090\1086" xs+ )+ ,+ ( "\1095\1077\1088"+ , if take 6 us == "\1077\1079\1090\1077\1097\1086"+ then+ "\1095\1077\1088\1077\1079"+ : "\1090\1077"+ : "\1097\1086"+ : reverseConcat1 n (drop 6 us)+ else [xs]+ )+ , howConcat1WordEntirely n "\1097\1086\1073" us+ ,+ ( "\1103\1082\1073"+ , howConcat1Word n 1 us "\1080" "\1103\1082\1073\1080" xs+ )+ ,+ ( "\1103\1082\1088"+ , howConcat1Word n 2 us "\1072\1079" "\1103\1082\1088\1072\1079" xs+ )+ , ("\1103\1082\1097", howConcat1Word n 1 us "\1086" "\1103\1082\1097\1086" xs)+ ]+ ts+ where+ (ts, us) = splitAt 3 xs reverseConcat2 :: Int -> String -> String -> String -> [String] reverseConcat2 n xs ts us =- getBFstLSorted' [xs] [("\1041\1110\1083", howConcat1Word n 1 us "\1103" "\1041\1110\1083\1103" xs),- ("\1042\1080\1082", howConcat1Word n 5 us "\1083\1102\1095\1085\1086" "\1042\1080\1082\1083\1102\1095\1085\1086" xs),- ("\1044\1072\1074", howConcat1Word n 2 us "\1072\1081" "\1044\1072\1074\1072\1081" xs),- ("\1047\1072\1090", howConcat1Word n 1 us "\1077" "\1047\1072\1090\1077" xs),- ("\1050\1086\1083", if take 1 us == "\1080" then "\1050\1086\1083\1080":reverseConcat1 n (drop 1 us)- else if take 1 us == "\1086" then "\1050\1086\1083\1086":reverseConcat1 n (drop 1 us) else [xs]),- ("\1051\1080\1096", howConcat1Word n 1 us "\1077" "\1051\1080\1096\1077" xs),- howConcat1WordEntirely n "\1053\1110\1078" us,- ("\1055\1110\1089", howConcat1Word n 2 us "\1083\1103" "\1055\1110\1089\1083\1103" xs),- ("\1057\1077\1088", howConcat1Word n 2 us "\1077\1076" "\1057\1077\1088\1077\1076" xs),- ("\1058\1110\1083", howConcat1Word n 3 us "\1100\1082\1080" "\1058\1110\1083\1100\1082\1080" xs),- ("\1073\1110\1083", howConcat1Word n 1 us "\1103" "\1073\1110\1083\1103" xs),- ("\1076\1072\1074", howConcat1Word n 2 us "\1072\1081" "\1076\1072\1074\1072\1081" xs),- ("\1079\1072\1090", howConcat1Word n 1 us "\1077" "\1079\1072\1090\1077" xs),- ("\1082\1086\1083", if take 1 us == "\1080" then "\1082\1086\1083\1080":reverseConcat1 n xs- else if take 1 us == "\1086" then "\1082\1086\1083\1086":reverseConcat1 n xs else [xs]),- ("\1083\1080\1096", howConcat1Word n 1 us "\1077" "\1083\1080\1096\1077" xs),- howConcat1WordEntirely n "\1085\1110\1078" us,- ("\1087\1077\1088", howConcat1Word n 2 us "\1077\1076" "\1087\1077\1088\1077\1076" xs),- ("\1087\1110\1089", howConcat1Word n 2 us "\1083\1103" "\1087\1110\1089\1083\1103" xs),- ("\1089\1077\1088", howConcat1Word n 2 us "\1077\1076" "\1089\1077\1088\1077\1076" xs)] ts+ getBFstLSorted'+ [xs]+ [ ("\1041\1110\1083", howConcat1Word n 1 us "\1103" "\1041\1110\1083\1103" xs)+ ,+ ( "\1042\1080\1082"+ , howConcat1Word+ n+ 5+ us+ "\1083\1102\1095\1085\1086"+ "\1042\1080\1082\1083\1102\1095\1085\1086"+ xs+ )+ ,+ ( "\1044\1072\1074"+ , howConcat1Word n 2 us "\1072\1081" "\1044\1072\1074\1072\1081" xs+ )+ , ("\1047\1072\1090", howConcat1Word n 1 us "\1077" "\1047\1072\1090\1077" xs)+ ,+ ( "\1050\1086\1083"+ , if take 1 us == "\1080"+ then "\1050\1086\1083\1080" : reverseConcat1 n (drop 1 us)+ else+ if take 1 us == "\1086"+ then "\1050\1086\1083\1086" : reverseConcat1 n (drop 1 us)+ else [xs]+ )+ , ("\1051\1080\1096", howConcat1Word n 1 us "\1077" "\1051\1080\1096\1077" xs)+ , howConcat1WordEntirely n "\1053\1110\1078" us+ ,+ ( "\1055\1110\1089"+ , howConcat1Word n 2 us "\1083\1103" "\1055\1110\1089\1083\1103" xs+ )+ ,+ ( "\1057\1077\1088"+ , howConcat1Word n 2 us "\1077\1076" "\1057\1077\1088\1077\1076" xs+ )+ ,+ ( "\1058\1110\1083"+ , howConcat1Word n 3 us "\1100\1082\1080" "\1058\1110\1083\1100\1082\1080" xs+ )+ , ("\1073\1110\1083", howConcat1Word n 1 us "\1103" "\1073\1110\1083\1103" xs)+ ,+ ( "\1076\1072\1074"+ , howConcat1Word n 2 us "\1072\1081" "\1076\1072\1074\1072\1081" xs+ )+ , ("\1079\1072\1090", howConcat1Word n 1 us "\1077" "\1079\1072\1090\1077" xs)+ ,+ ( "\1082\1086\1083"+ , if take 1 us == "\1080"+ then "\1082\1086\1083\1080" : reverseConcat1 n xs+ else+ if take 1 us == "\1086"+ then "\1082\1086\1083\1086" : reverseConcat1 n xs+ else [xs]+ )+ , ("\1083\1080\1096", howConcat1Word n 1 us "\1077" "\1083\1080\1096\1077" xs)+ , howConcat1WordEntirely n "\1085\1110\1078" us+ ,+ ( "\1087\1077\1088"+ , howConcat1Word n 2 us "\1077\1076" "\1087\1077\1088\1077\1076" xs+ )+ ,+ ( "\1087\1110\1089"+ , howConcat1Word n 2 us "\1083\1103" "\1087\1110\1089\1083\1103" xs+ )+ ,+ ( "\1089\1077\1088"+ , howConcat1Word n 2 us "\1077\1076" "\1089\1077\1088\1077\1076" xs+ )+ ]+ ts howConcat1Word :: Int -> Int -> String -> String -> String -> String -> [String] howConcat1Word m n us us' us'' xs- | take n us == us' = us'':reverseConcat1 m (drop n us)- | otherwise = [xs]+ | take n us == us' = us'' : reverseConcat1 m (drop n us)+ | otherwise = [xs] {-# INLINE howConcat1Word #-} howConcat1WordEntirely :: Int -> String -> String -> (String, [String])-howConcat1WordEntirely m ts us = (ts,ts:reverseConcat1 m us)+howConcat1WordEntirely m ts us = (ts, ts : reverseConcat1 m us) {-# INLINE howConcat1WordEntirely #-}
Aftovolio/Ukrainian/Syllable.hs view
@@ -1,58 +1,59 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude, BangPatterns #-} --- |--- Module : Aftovolio.Ukrainian.Syllable--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ This module works with syllable segmentation in Ukrainian. It is rewritten--- module MMSyn7.Syllable from the @mmsyn7s@ package : https://hackage.haskell.org/package/mmsyn7s--- The information on Ukrainian syllable segmentation is taken 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---+{- |+Module : Aftovolio.Ukrainian.Syllable+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +This module works with syllable segmentation in Ukrainian. It is rewritten+module MMSyn7.Syllable from the @mmsyn7s@ package : https://hackage.haskell.org/package/mmsyn7s+The information on Ukrainian syllable segmentation is taken 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+-} module Aftovolio.Ukrainian.Syllable (- -- * Basic functionality- isVowel1- , isSonorous1- , isVoicedC1- , isVoicelessC1- , isNotVowel2- , isNotVowel2'- , sndGroups- , groupSnds- , divCnsnts- , reSyllableCntnts- , divVwls- , createSyllablesUkrS- , notEqC- , representProlonged- , showS8- , showFS- -- * With additional data used (probably for speed up)- , notEqCTup- , divCnsntsTup- , reSyllableCntntsTup- , createSyllablesUkrSTup+ -- * Basic functionality+ isVowel1,+ isSonorous1,+ isVoicedC1,+ isVoicelessC1,+ isNotVowel2,+ isNotVowel2',+ sndGroups,+ groupSnds,+ divCnsnts,+ reSyllableCntnts,+ divVwls,+ createSyllablesUkrS,+ notEqC,+ representProlonged,+ showS8,+ showFS,++ -- * With additional data used (probably for speed up)+ notEqCTup,+ divCnsntsTup,+ reSyllableCntntsTup,+ createSyllablesUkrSTup, ) where -import GHC.Base-import GHC.List-import Data.Tuple -import GHC.Num (abs,(-))-import GHC.Arr-import Data.Typeable-import qualified Data.List as L (groupBy) import Aftovolio.Ukrainian.Melodics import CaseBi.Arr-import GHC.Int import Data.IntermediateStructures1 (mapI)+import qualified Data.List as L (groupBy) import Data.Maybe (mapMaybe)-+import Data.Tuple+import Data.Typeable+import GHC.Arr+import GHC.Base+import GHC.Int+import GHC.List+import GHC.Num (abs, (-)) -- Inspired by: https://github.com/OleksandrZhabenko/mm1/releases/tag/0.2.0.0 @@ -76,138 +77,176 @@ isVoicelessC1 x = x > 37 && x < 54 {-# INLINE isVoicelessC1 #-} --- | Binary function-predicate 'isNotVowel2' checks whether its arguments are both consonant representations in the 'Sound8' format.--- Starting from the version 0.6.0.0 variants of either of arguments is greater than 99 is also included.+{- | Binary function-predicate 'isNotVowel2' checks whether its arguments are both consonant representations in the 'Sound8' format.+Starting from the version 0.6.0.0 variants of either of arguments is greater than 99 is also included.+-} isNotVowel2 :: Sound8 -> Sound8 -> Bool isNotVowel2 x y = x > 6 && y > 6 {-# INLINE isNotVowel2 #-} --- | Binary function-predicate 'isNotVowel2'' checks whether its arguments are both consonant representations in the 'Sound8' format.--- Starting from the version 0.6.0.0 variants of either of arguments is greater than 99 are not included (so its behaviour is equivalent to the--- 'isNotVowel2' till the 0.5.3.0 version).+{- | Binary function-predicate 'isNotVowel2'' checks whether its arguments are both consonant representations in the 'Sound8' format.+Starting from the version 0.6.0.0 variants of either of arguments is greater than 99 are not included (so its behaviour is equivalent to the+'isNotVowel2' till the 0.5.3.0 version).+-} isNotVowel2' :: Sound8 -> Sound8 -> Bool isNotVowel2' x y = x < 100 && y < 100 && x > 6 && y > 6 {-# INLINE isNotVowel2' #-} --- | Function 'sndGroups' converts a Ukrainian word being a list of 'Sound8' to the list of phonetically similar (consonants grouped with consonants and each vowel separately)--- sounds representations in 'Sound8' format.+{- | Function 'sndGroups' converts a Ukrainian word being a list of 'Sound8' to the list of phonetically similar (consonants grouped with consonants and each vowel separately)+sounds representations in 'Sound8' format.+-} sndGroups :: FlowSound -> [FlowSound]-sndGroups ys@(_:_) = L.groupBy isNotVowel2 ys+sndGroups ys@(_ : _) = L.groupBy isNotVowel2 ys sndGroups _ = [] groupSnds :: FlowSound -> [FlowSound] groupSnds = L.groupBy (\x y -> isVowel1 x == isVowel1 y) --- | Function 'divCnsnts' is used to divide groups of Ukrainian 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 phonetical information for the proper performance is taken 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-divCnsnts :: FlowSound -> (FlowSound -> FlowSound,FlowSound -> FlowSound)-divCnsnts xs@(x:ys@(y:zs@(z:ts@(_:_))))- | isSonorous1 x || isVoicedC1 x =- case y of- 7 -> ((`mappend` [x,7]),mappend zs) -- "рибаль-ство"- _ -> ((`mappend` [x]),mappend ys)- | isSonorous1 y =- case z of- 7 -> ((`mappend` [x,y,7]),mappend ts) -- "рокль-ський" (?), "супрасль-ський"- _ -> ((`mappend` [x,y]),mappend zs) -- "дофр-ський" (?)- | otherwise = (id,mappend xs)-divCnsnts xs@(x:ys@(y:zs@(z:ts)))- | isSonorous1 x =- case y of- 7 -> ((`mappend` [x,7]),mappend zs) -- "поль-ка", "каль-ка"- _ -> ((`mappend` [x]),mappend ys)- | isSonorous1 y =- case z of- 7 -> (id,mappend xs) -- "сього-дні"- _ -> ((`mappend` [x,y]),mappend zs)- | otherwise = (id,mappend xs)-divCnsnts xs@(x:ys@(y:zs))- | (isSonorous1 x && notEqC x y && y /= 7) || (isVoicedC1 x && isVoicelessC1 y) = ((`mappend` [x]),mappend ys)- | otherwise = (id,mappend xs)-divCnsnts xs = (id,mappend xs)+{- | Function 'divCnsnts' is used to divide groups of Ukrainian 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 phonetical information for the proper performance is taken 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+-}+divCnsnts :: FlowSound -> (FlowSound -> FlowSound, FlowSound -> FlowSound)+divCnsnts xs@(x : ys@(y : zs@(z : ts@(_ : _))))+ | isSonorous1 x || isVoicedC1 x =+ case y of+ 7 -> ((`mappend` [x, 7]), mappend zs) -- "рибаль-ство"+ _ -> ((`mappend` [x]), mappend ys)+ | isSonorous1 y =+ case z of+ 7 -> ((`mappend` [x, y, 7]), mappend ts) -- "рокль-ський" (?), "супрасль-ський"+ _ -> ((`mappend` [x, y]), mappend zs) -- "дофр-ський" (?)+ | otherwise = (id, mappend xs)+divCnsnts xs@(x : ys@(y : zs@(z : ts)))+ | isSonorous1 x =+ case y of+ 7 -> ((`mappend` [x, 7]), mappend zs) -- "поль-ка", "каль-ка"+ _ -> ((`mappend` [x]), mappend ys)+ | isSonorous1 y =+ case z of+ 7 -> (id, mappend xs) -- "сього-дні"+ _ -> ((`mappend` [x, y]), mappend zs)+ | otherwise = (id, mappend xs)+divCnsnts xs@(x : ys@(y : zs))+ | (isSonorous1 x && notEqC x y && y /= 7) || (isVoicedC1 x && isVoicelessC1 y) =+ ((`mappend` [x]), mappend ys)+ | otherwise = (id, mappend xs)+divCnsnts xs = (id, mappend xs) -- | Function 'divCnsntsTup' is a variant of the 'divCnsts' where you can provide the tuple element for 'getBFst'' inside.-divCnsntsTup :: Array Int (Int8,Bool) -> FlowSound -> (FlowSound -> FlowSound,FlowSound -> FlowSound)-divCnsntsTup !tup17 xs@(x:ys@(y:zs@(z:ts@(_:_))))- | isSonorous1 x || isVoicedC1 x =- case y of- 7 -> ((`mappend` [x,7]),mappend zs) -- "рибаль-ство"- _ -> ((`mappend` [x]),mappend ys)- | isSonorous1 y =- case z of- 7 -> ((`mappend` [x,y,7]),mappend ts) -- "рокль-ський" (?), "супрасль-ський"- _ -> ((`mappend` [x,y]),mappend zs) -- "дофр-ський" (?)- | otherwise = (id,mappend xs)-divCnsntsTup !tup17 xs@(x:ys@(y:zs@(z:ts)))- | isSonorous1 x =- case y of- 7 -> ((`mappend` [x,7]),mappend zs) -- "поль-ка", "каль-ка"- _ -> ((`mappend` [x]),mappend ys)- | isSonorous1 y =- case z of- 7 -> (id,mappend xs) -- "сього-дні"- _ -> ((`mappend` [x,y]),mappend zs) - | otherwise = (id,mappend xs)-divCnsntsTup !tup17 xs@(x:ys@(y:_))- | (isSonorous1 x && (notEqCTup tup17 x y) && y /= 7) || (isVoicedC1 x && isVoicelessC1 y) = ((`mappend` [x]),mappend ys)- | otherwise = (id,mappend xs)-divCnsntsTup _ xs = (id,mappend xs)+divCnsntsTup ::+ Array Int (Int8, Bool) ->+ FlowSound ->+ (FlowSound -> FlowSound, FlowSound -> FlowSound)+divCnsntsTup !tup17 xs@(x : ys@(y : zs@(z : ts@(_ : _))))+ | isSonorous1 x || isVoicedC1 x =+ case y of+ 7 -> ((`mappend` [x, 7]), mappend zs) -- "рибаль-ство"+ _ -> ((`mappend` [x]), mappend ys)+ | isSonorous1 y =+ case z of+ 7 -> ((`mappend` [x, y, 7]), mappend ts) -- "рокль-ський" (?), "супрасль-ський"+ _ -> ((`mappend` [x, y]), mappend zs) -- "дофр-ський" (?)+ | otherwise = (id, mappend xs)+divCnsntsTup !tup17 xs@(x : ys@(y : zs@(z : ts)))+ | isSonorous1 x =+ case y of+ 7 -> ((`mappend` [x, 7]), mappend zs) -- "поль-ка", "каль-ка"+ _ -> ((`mappend` [x]), mappend ys)+ | isSonorous1 y =+ case z of+ 7 -> (id, mappend xs) -- "сього-дні"+ _ -> ((`mappend` [x, y]), mappend zs)+ | otherwise = (id, mappend xs)+divCnsntsTup !tup17 xs@(x : ys@(y : _))+ | (isSonorous1 x && (notEqCTup tup17 x y) && y /= 7)+ || (isVoicedC1 x && isVoicelessC1 y) =+ ((`mappend` [x]), mappend ys)+ | otherwise = (id, mappend xs)+divCnsntsTup _ xs = (id, mappend xs) -reSyllableCntntsTup :: Array Int (Int8,Bool) -> [FlowSound] -> [FlowSound]-reSyllableCntntsTup !tup17 (xs:ys:zs:xss)- | (> 6) . last $ ys = fst (divCnsntsTup tup17 ys) xs:reSyllableCntntsTup tup17 (snd (divCnsntsTup tup17 ys) zs:xss)- | otherwise = reSyllableCntntsTup tup17 ((xs `mappend` ys):zs:xss)-reSyllableCntntsTup !tup17 (xs:ys:_) = [xs `mappend` ys]+reSyllableCntntsTup :: Array Int (Int8, Bool) -> [FlowSound] -> [FlowSound]+reSyllableCntntsTup !tup17 (xs : ys : zs : xss)+ | (> 6) . last $ ys =+ fst (divCnsntsTup tup17 ys) xs+ : reSyllableCntntsTup tup17 (snd (divCnsntsTup tup17 ys) zs : xss)+ | otherwise = reSyllableCntntsTup tup17 ((xs `mappend` ys) : zs : xss)+reSyllableCntntsTup !tup17 (xs : ys : _) = [xs `mappend` ys] reSyllableCntntsTup !tup17 xss = xss reSyllableCntnts :: [FlowSound] -> [FlowSound]-reSyllableCntnts (xs:ys:zs:xss)- | (> 6) . last $ ys = fst (divCnsnts ys) xs:reSyllableCntnts (snd (divCnsnts ys) zs:xss)- | otherwise = reSyllableCntnts ((xs `mappend` ys):zs:xss)-reSyllableCntnts (xs:ys:_) = [xs `mappend` ys]+reSyllableCntnts (xs : ys : zs : xss)+ | (> 6) . last $ ys =+ fst (divCnsnts ys) xs : reSyllableCntnts (snd (divCnsnts ys) zs : xss)+ | otherwise = reSyllableCntnts ((xs `mappend` ys) : zs : xss)+reSyllableCntnts (xs : ys : _) = [xs `mappend` ys] reSyllableCntnts xss = xss divVwls :: [FlowSound] -> [FlowSound] divVwls = mapI (\ws -> (length . filter isVowel1 $ ws) > 1) h3- where h3 us = [ys `mappend` take 1 zs] `mappend` (L.groupBy (\x y -> isVowel1 x && y > 6) . drop 1 $ zs)- where (ys,zs) = span (>6) us+ where+ h3 us =+ [ys `mappend` take 1 zs]+ `mappend` (L.groupBy (\x y -> isVowel1 x && y > 6) . drop 1 $ zs)+ where+ (ys, zs) = span (> 6) us createSyllablesUkrS :: String -> [[FlowSound]]-createSyllablesUkrS = map (divVwls . reSyllableCntnts . groupSnds) . words1 . convertToProperUkrainianI8+createSyllablesUkrS =+ map (divVwls . reSyllableCntnts . groupSnds)+ . words1+ . convertToProperUkrainianI8 {-# INLINE createSyllablesUkrS #-} -createSyllablesUkrSTup- :: Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int (Int8, Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Int8)- -> Array Int (Int8, FlowSound -> Sound8)- -> Array Int (Int8, Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Bool)- -> Array Int ([Int8], Bool)- -> Array Int (Int8, [Int8])- -> Array Int (Char,Int8)- -> Array Int (Int8,[Int8])- -> Array Int (Char, Bool)- -> Array Int (Char, Bool)- -> Array Int (Int8,Bool)- -> String- -> [[FlowSound]]+createSyllablesUkrSTup ::+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Int8) ->+ Array Int (Int8, FlowSound -> Sound8) ->+ Array Int (Int8, Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int ([Int8], Bool) ->+ Array Int (Int8, [Int8]) ->+ Array Int (Char, Int8) ->+ Array Int (Int8, [Int8]) ->+ Array Int (Char, Bool) ->+ Array Int (Char, Bool) ->+ Array Int (Int8, Bool) ->+ String ->+ [[FlowSound]] createSyllablesUkrSTup !tup1 !tup2 !tup3 !tup4 !tup5 !tup6 !tup7 !tup8 !tup9 !tup10 !tup11 !tup12 !tup13 !tup14 !tup15 !tup16 !tup17 =- map (divVwls . reSyllableCntntsTup tup17 . groupSnds) . words1 .- convertToProperUkrainianI8WithTuples tup1 tup2 tup3 tup4 tup5 tup6 tup7 tup8 tup9 tup10 tup11 tup12 tup13 tup14 tup15 tup16+ map (divVwls . reSyllableCntntsTup tup17 . groupSnds)+ . words1+ . convertToProperUkrainianI8WithTuples+ tup1+ tup2+ tup3+ tup4+ tup5+ tup6+ tup7+ tup8+ tup9+ tup10+ tup11+ tup12+ tup13+ tup14+ tup15+ tup16 {-# INLINE createSyllablesUkrSTup #-} -- | Practically this is an optimized version for this case 'words' function from Prelude. words1 :: FlowSound -> [FlowSound]-words1 xs = if null ts then [] else w : words1 s'' - where ts = dropWhile (> 99) xs- (w, s'') = span (< 100) ts+words1 xs = if null ts then [] else w : words1 s''+ where+ ts = dropWhile (> 99) xs+ (w, s'') = span (< 100) ts {-# NOINLINE words1 #-} -----------------------------------------------------@@ -215,61 +254,135 @@ -- | Binary function-predicate 'notEqC' checks whether its arguments are not the same consonant sound representations (not taking palatalization into account). notEqC :: Sound8 -> Sound8 -> Bool notEqC x y- | x == 49 || x == 54 =- case y of- 49 -> False- 54 -> False- _ -> True- | x == 66 || x == 38 =- case y of- 38 -> False- 66 -> False- _ -> True- | x == y = False- | abs (x - y) == 1 =- getBFstLSorted' True ([(8,False),(10,False),(15,False),(17,False),(19,False),(21,False),(23,False),(25,False),- (28,False),(30,False),(32,False),(34,False),(36,False),(39,False),(41,False),(43,False),(45,False),(47,False),- (50,False),(52,False)]) . min x $ y- | otherwise = True+ | x == 49 || x == 54 =+ case y of+ 49 -> False+ 54 -> False+ _ -> True+ | x == 66 || x == 38 =+ case y of+ 38 -> False+ 66 -> False+ _ -> True+ | x == y = False+ | abs (x - y) == 1 =+ getBFstLSorted'+ True+ ( [ (8, False)+ , (10, False)+ , (15, False)+ , (17, False)+ , (19, False)+ , (21, False)+ , (23, False)+ , (25, False)+ , (28, False)+ , (30, False)+ , (32, False)+ , (34, False)+ , (36, False)+ , (39, False)+ , (41, False)+ , (43, False)+ , (45, False)+ , (47, False)+ , (50, False)+ , (52, False)+ ]+ )+ . min x+ $ y+ | otherwise = True {-# INLINE notEqC #-} -- | Binary function-predicate 'notEqC' checks whether its arguments are not the same consonant sound representations (not taking palatalization into account).-notEqCTup :: Array Int (Int8,Bool) -> Sound8 -> Sound8 -> Bool+notEqCTup :: Array Int (Int8, Bool) -> Sound8 -> Sound8 -> Bool notEqCTup !tup17 x y- | x == 49 || x == 54 =- case y of- 49 -> False- 54 -> False- _ -> True- | x == 66 || x == 38 =- case y of- 38 -> False- 66 -> False- _ -> True- | x == y = False- | abs (x - y) == 1 = getBFst' (True, tup17) . min x $ y- | otherwise = True+ | x == 49 || x == 54 =+ case y of+ 49 -> False+ 54 -> False+ _ -> True+ | x == 66 || x == 38 =+ case y of+ 38 -> False+ 66 -> False+ _ -> True+ | x == y = False+ | abs (x - y) == 1 = getBFst' (True, tup17) . min x $ y+ | otherwise = True {-# INLINE notEqCTup #-} --- | Function 'representProlonged' converts duplicated consequent in the syllable consonants--- so that they are represented by just one 'Sound8'. After applying the function to the list of 'Sound8' being a syllable all groups of duplicated consequent consonants--- in every syllable are represented with only one 'Sound8' respectively.+{- | Function 'representProlonged' converts duplicated consequent in the syllable consonants+so that they are represented by just one 'Sound8'. After applying the function to the list of 'Sound8' being a syllable all groups of duplicated consequent consonants+in every syllable are represented with only one 'Sound8' respectively.+-} representProlonged :: FlowSound -> FlowSound-representProlonged (x:y:xs)- | isVowel1 x = x:representProlonged (y:xs)- | not . notEqC x $ y = y:representProlonged xs- | otherwise = x:representProlonged (y:xs)+representProlonged (x : y : xs)+ | isVowel1 x = x : representProlonged (y : xs)+ | not . notEqC x $ y = y : representProlonged xs+ | otherwise = x : representProlonged (y : xs) representProlonged xs = xs showS8 :: Sound8 -> String-showS8 = getBFstLSorted' " " [(1,"\1072"),(2,"\1077"),(3,"\1086"),(4,"\1091"),(5,"\1080"),(6,"\1110"),(7,"\1100"),(8,"\1076\1079"),- (9,"\1076\1079"),(10,"\1078"),(11,"\1078"),(15,"\1073"),(16,"\1073"),(17,"\1076"),(18,"\1076"),(19,"\1169"),(20,"\1169"),- (21,"\1075"),(22,"\1075"),(23,"\1076\1078"),(24,"\1076\1078"),(25,"\1079"),(26,"\1079"),(27,"\1081"),(28,"\1083"),(29,"\1083"),- (30,"\1084"),(31,"\1084"),(32,"\1085"),(33,"\1085"),(34,"\1088"),(35,"\1088"),(36,"\1074"),(37,"\1074"),(38,"\1094"),- (39,"\1095"),(40,"\1095"),(41,"\1096"),(42,"\1096"),(43,"\1092"),(44,"\1092"),(45,"\1082"),(46,"\1082"),(47,"\1087"),- (48,"\1087"),(49,"\1089"),(50,"\1090"),(51,"\1090"),(52,"\1093"),(53,"\1093"),(54,"\1089\1100"),(66,"\1094\1100")]+showS8 =+ getBFstLSorted'+ " "+ [ (1, "\1072")+ , (2, "\1077")+ , (3, "\1086")+ , (4, "\1091")+ , (5, "\1080")+ , (6, "\1110")+ , (7, "\1100")+ , (8, "\1076\1079")+ , (9, "\1076\1079")+ , (10, "\1078")+ , (11, "\1078")+ , (15, "\1073")+ , (16, "\1073")+ , (17, "\1076")+ , (18, "\1076")+ , (19, "\1169")+ , (20, "\1169")+ , (21, "\1075")+ , (22, "\1075")+ , (23, "\1076\1078")+ , (24, "\1076\1078")+ , (25, "\1079")+ , (26, "\1079")+ , (27, "\1081")+ , (28, "\1083")+ , (29, "\1083")+ , (30, "\1084")+ , (31, "\1084")+ , (32, "\1085")+ , (33, "\1085")+ , (34, "\1088")+ , (35, "\1088")+ , (36, "\1074")+ , (37, "\1074")+ , (38, "\1094")+ , (39, "\1095")+ , (40, "\1095")+ , (41, "\1096")+ , (42, "\1096")+ , (43, "\1092")+ , (44, "\1092")+ , (45, "\1082")+ , (46, "\1082")+ , (47, "\1087")+ , (48, "\1087")+ , (49, "\1089")+ , (50, "\1090")+ , (51, "\1090")+ , (52, "\1093")+ , (53, "\1093")+ , (54, "\1089\1100")+ , (66, "\1094\1100")+ ] {-# INLINE showS8 #-} showFS :: FlowSound -> String-showFS = concatMap showS8 -- Probably, it is better to transform several consequent spaces into the combination smth like \", \" (but not in this version)+showFS = concatMap showS8 -- Probably, it is better to transform several consequent spaces into the combination smth like \", \" (but not in this version) {-# INLINE showFS #-}
Aftovolio/Ukrainian/SyllableWord8.hs view
@@ -1,59 +1,283 @@-{-# LANGUAGE TypeSynonymInstances, NoImplicitPrelude, Strict, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK show-extensions #-}--- |--- Module : Aftovolio.Ukrainian.SyllableWord8--- Copyright : (c) Oleksandr Zhabenko 2021-2024--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ This module works with syllable segmentation in Ukrainian. Uses 'Word8' whenever possible.--- Is inspired by the DobutokO.Sound.DIS5G6G module from @dobutokO2@ package.--- See: 'https://hackage.haskell.org/package/dobutokO2-0.43.0.0/docs/DobutokO-Sound-DIS5G6G.html'.--- The initial 'Word8' data are gotten from there. +{- |+Module : Aftovolio.Ukrainian.SyllableWord8+Copyright : (c) Oleksandr Zhabenko 2021-2024+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com++This module works with syllable segmentation in Ukrainian. Uses 'Word8' whenever possible.+Is inspired by the DobutokO.Sound.DIS5G6G module from @dobutokO2@ package.+See: 'https://hackage.haskell.org/package/dobutokO2-0.43.0.0/docs/DobutokO-Sound-DIS5G6G.html'.+The initial 'Word8' data are gotten from there.+-} module Aftovolio.Ukrainian.SyllableWord8 where -import GHC.Base-import GHC.Num ((+))-import CaseBi.Arr import Aftovolio.Ukrainian.Melodics (Sound8)-import GHC.Int+import CaseBi.Arr import Data.Foldable (foldl')+import GHC.Base+import GHC.Int+import GHC.Num ((+)) import GHC.Word s0DuratD1 :: Sound8 -> Word8-s0DuratD1 = getBFstLSorted' 5 [(1,15),(2,10),(3,13),(4,12),(5,11),(6,10),(7,1),(8,6),(9,6),(10,7),(11,7),(15,6),(16,6),(17,8),(18,8),(19,7),(20,7),(21,8),(22,8),(23,5),(24,5),(25,6),(26,6),(27,6),(28,7),(29,7),(30,8),(31,8),(32,8),(33,8),(34,5),(35,5),(36,9),(37,9),(38,5),(39,6),(40,6),(41,7),(42,7),(43,6),(44,6),(45,4),(46,4),(47,15),(48,15),(49,8),(50,12),(51,12),(52,8),(53,8),(54,8),(66,10)] +s0DuratD1 =+ getBFstLSorted'+ 5+ [ (1, 15)+ , (2, 10)+ , (3, 13)+ , (4, 12)+ , (5, 11)+ , (6, 10)+ , (7, 1)+ , (8, 6)+ , (9, 6)+ , (10, 7)+ , (11, 7)+ , (15, 6)+ , (16, 6)+ , (17, 8)+ , (18, 8)+ , (19, 7)+ , (20, 7)+ , (21, 8)+ , (22, 8)+ , (23, 5)+ , (24, 5)+ , (25, 6)+ , (26, 6)+ , (27, 6)+ , (28, 7)+ , (29, 7)+ , (30, 8)+ , (31, 8)+ , (32, 8)+ , (33, 8)+ , (34, 5)+ , (35, 5)+ , (36, 9)+ , (37, 9)+ , (38, 5)+ , (39, 6)+ , (40, 6)+ , (41, 7)+ , (42, 7)+ , (43, 6)+ , (44, 6)+ , (45, 4)+ , (46, 4)+ , (47, 15)+ , (48, 15)+ , (49, 8)+ , (50, 12)+ , (51, 12)+ , (52, 8)+ , (53, 8)+ , (54, 8)+ , (66, 10)+ ] {-# INLINE s0DuratD1 #-} --- | s0DuratD2 :: Sound8 -> Word8-s0DuratD2 = getBFstLSorted' 5 [(1,15),(2,15),(3,15),(4,14),(5,11),(6,11),(7,1),(8,4),(9,4),(10,5),(11,5),(15,6),(16,6),(17,4),(18,4),(19,4),(20,4),(21,3),(22,3),(23,5),(24,5),(25,4),(26,4),(27,5),(28,6),(29,6),(30,8),(31,8),(32,3),(33,3),(34,4),(35,4),(36,5),(37,5),(38,3),(39,7),(40,7),(41,7),(42,7),(43,9),(44,9),(45,3),(46,3),(47,5),(48,5),(49,3),(50,3),(51,3),(52,5),(53,5),(54,4),(66,4)]+s0DuratD2 =+ getBFstLSorted'+ 5+ [ (1, 15)+ , (2, 15)+ , (3, 15)+ , (4, 14)+ , (5, 11)+ , (6, 11)+ , (7, 1)+ , (8, 4)+ , (9, 4)+ , (10, 5)+ , (11, 5)+ , (15, 6)+ , (16, 6)+ , (17, 4)+ , (18, 4)+ , (19, 4)+ , (20, 4)+ , (21, 3)+ , (22, 3)+ , (23, 5)+ , (24, 5)+ , (25, 4)+ , (26, 4)+ , (27, 5)+ , (28, 6)+ , (29, 6)+ , (30, 8)+ , (31, 8)+ , (32, 3)+ , (33, 3)+ , (34, 4)+ , (35, 4)+ , (36, 5)+ , (37, 5)+ , (38, 3)+ , (39, 7)+ , (40, 7)+ , (41, 7)+ , (42, 7)+ , (43, 9)+ , (44, 9)+ , (45, 3)+ , (46, 3)+ , (47, 5)+ , (48, 5)+ , (49, 3)+ , (50, 3)+ , (51, 3)+ , (52, 5)+ , (53, 5)+ , (54, 4)+ , (66, 4)+ ] {-# INLINE s0DuratD2 #-} s0DuratD3 :: Sound8 -> Word8-s0DuratD3 = getBFstLSorted' 5 [(1,15),(2,14),(3,15),(4,12),(5,12),(6,12),(7,1),(8,5),(9,5),(10,6),(11,6),(15,8),(16,8),(17,5),(18,5),(19,5),(20,5),(21,6),(22,6),(23,6),(24,6),(25,4),(26,4),(27,7),(28,7),(29,7),(30,9),(31,9),(32,4),(33,4),(34,4),(35,4),(36,5),(37,5),(38,4),(39,7),(40,7),(41,9),(42,9),(43,10),(44,10),(45,4),(46,4),(47,7),(48,7),(49,4),(50,4),(51,4),(52,8),(53,8),(54,5),(66,5)]+s0DuratD3 =+ getBFstLSorted'+ 5+ [ (1, 15)+ , (2, 14)+ , (3, 15)+ , (4, 12)+ , (5, 12)+ , (6, 12)+ , (7, 1)+ , (8, 5)+ , (9, 5)+ , (10, 6)+ , (11, 6)+ , (15, 8)+ , (16, 8)+ , (17, 5)+ , (18, 5)+ , (19, 5)+ , (20, 5)+ , (21, 6)+ , (22, 6)+ , (23, 6)+ , (24, 6)+ , (25, 4)+ , (26, 4)+ , (27, 7)+ , (28, 7)+ , (29, 7)+ , (30, 9)+ , (31, 9)+ , (32, 4)+ , (33, 4)+ , (34, 4)+ , (35, 4)+ , (36, 5)+ , (37, 5)+ , (38, 4)+ , (39, 7)+ , (40, 7)+ , (41, 9)+ , (42, 9)+ , (43, 10)+ , (44, 10)+ , (45, 4)+ , (46, 4)+ , (47, 7)+ , (48, 7)+ , (49, 4)+ , (50, 4)+ , (51, 4)+ , (52, 8)+ , (53, 8)+ , (54, 5)+ , (66, 5)+ ] {-# INLINE s0DuratD3 #-} s0DuratD4 :: Sound8 -> Word8-s0DuratD4 = getBFstLSorted' 5 [(1,12),(2,12),(3,12),(4,12),(5,12),(6,12),(7,1),(8,5),(9,5),(10,10),(11,10),(15,5),(16,5),(17,8),(18,8),(19,8),(20,8),(21,13),(22,13),(23,10),(24,10),(25,5),(26,5),(27,4),(28,10),(29,10),(30,15),(31,15),(32,8),(33,8),(34,4),(35,4),(36,6),(37,6),(38,4),(39,12),(40,12),(41,14),(42,14),(43,11),(44,11),(45,6),(46,6),(47,4),(48,4),(49,6),(50,11),(51,11),(52,15),(53,15),(54,7),(66,5)]+s0DuratD4 =+ getBFstLSorted'+ 5+ [ (1, 12)+ , (2, 12)+ , (3, 12)+ , (4, 12)+ , (5, 12)+ , (6, 12)+ , (7, 1)+ , (8, 5)+ , (9, 5)+ , (10, 10)+ , (11, 10)+ , (15, 5)+ , (16, 5)+ , (17, 8)+ , (18, 8)+ , (19, 8)+ , (20, 8)+ , (21, 13)+ , (22, 13)+ , (23, 10)+ , (24, 10)+ , (25, 5)+ , (26, 5)+ , (27, 4)+ , (28, 10)+ , (29, 10)+ , (30, 15)+ , (31, 15)+ , (32, 8)+ , (33, 8)+ , (34, 4)+ , (35, 4)+ , (36, 6)+ , (37, 6)+ , (38, 4)+ , (39, 12)+ , (40, 12)+ , (41, 14)+ , (42, 14)+ , (43, 11)+ , (44, 11)+ , (45, 6)+ , (46, 6)+ , (47, 4)+ , (48, 4)+ , (49, 6)+ , (50, 11)+ , (51, 11)+ , (52, 15)+ , (53, 15)+ , (54, 7)+ , (66, 5)+ ] {-# INLINE s0DuratD4 #-} class (Eq a) => SyllableDurations4 a where- sDuratsD :: a -> Word8- sDuratsD2 :: a -> Word8- sDuratsD3 :: a -> Word8- sDuratsD4 :: a -> Word8- syllableDurationsGDc :: (a -> Word8) -> [[[a]]] -> [[Word8]]- syllableDurationsGDc g = map (map (k g))- where k f = foldl' (\y x -> f x + y) 0- {-# INLINE syllableDurationsGDc #-}+ sDuratsD :: a -> Word8+ sDuratsD2 :: a -> Word8+ sDuratsD3 :: a -> Word8+ sDuratsD4 :: a -> Word8+ syllableDurationsGDc :: (a -> Word8) -> [[[a]]] -> [[Word8]]+ syllableDurationsGDc g = map (map (k g))+ where+ k f = foldl' (\y x -> f x + y) 0+ {-# INLINE syllableDurationsGDc #-} instance SyllableDurations4 Sound8 where- sDuratsD = s0DuratD1- sDuratsD2 = s0DuratD2- sDuratsD3 = s0DuratD3- sDuratsD4 = s0DuratD4+ sDuratsD = s0DuratD1+ sDuratsD2 = s0DuratD2+ sDuratsD3 = s0DuratD3+ sDuratsD4 = s0DuratD4 -- | General variant of the 'syllableDurationsD' function. syllableDurationsGD :: (Sound8 -> Word8) -> [[[Sound8]]] -> [[Word8]]@@ -75,4 +299,3 @@ syllableDurationsD4 :: [[[Sound8]]] -> [[Word8]] syllableDurationsD4 = syllableDurationsGDc s0DuratD4 {-# INLINE syllableDurationsD4 #-}-
Aftovolio/UniquenessPeriodsG.hs view
@@ -1,55 +1,77 @@-{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoImplicitPrelude #-}---- |--- Module : Aftovolio.UniquenessPeriodsG--- Copyright : (c) OleksandrZhabenko 2020-2023--- License : MIT--- Stability : Experimental--- Maintainer : oleksandr.zhabenko@yahoo.com------ Generalization of the uniqueness-periods and uniqueness-periods-general--- packages functionality for small 'F.Foldable' data structures. Uses less dependencies.---+{-# OPTIONS_HADDOCK show-extensions #-} -{-# LANGUAGE BangPatterns #-}+{- |+Module : Aftovolio.UniquenessPeriodsG+Copyright : (c) OleksandrZhabenko 2020-2023+License : MIT+Stability : Experimental+Maintainer : oleksandr.zhabenko@yahoo.com +Generalization of the uniqueness-periods and uniqueness-periods-general+packages functionality for small 'F.Foldable' data structures. Uses less dependencies.+-} module Aftovolio.UniquenessPeriodsG (- -- * List functions- uniquenessPeriodsGG- , uniquenessPeriodsG- , uniquenessPeriodsGI8- , diverse2GGL- , diverse2GL- , diverse2GLInt8-) where+ -- * List functions+ uniquenessPeriodsGG,+ uniquenessPeriodsG,+ uniquenessPeriodsGI8,+ diverse2GGL,+ diverse2GL,+ diverse2GLInt8,+) where +import qualified Data.Foldable as F+import Data.List hiding (foldr)+import Data.Maybe (mapMaybe)+import Data.Tuple import GHC.Base import GHC.Int-import Data.List hiding (foldr) import GHC.Num ((-))-import Data.Tuple-import Data.Maybe (mapMaybe)-import qualified Data.Foldable as F -- | A generalization of the uniquenessPeriods function of the @uniqueness-periods@ package.-uniquenessPeriodsGG :: (F.Foldable t1, F.Foldable t2, F.Foldable t3, Ord a) => t3 a -> t1 a -> t2 a -> [Int16]+uniquenessPeriodsGG ::+ (F.Foldable t1, F.Foldable t2, F.Foldable t3, Ord a) =>+ t3 a ->+ t1 a ->+ t2 a ->+ [Int16] uniquenessPeriodsGG sels whspss ws- | F.null ws = []- | otherwise = mapMaybe (helpGSel sels F.sum whspss) . unfoldr f $ ks- where !ks = indexedL ws- !vs = mapMaybe g ks- g (x,y)- | y `F.elem` whspss = Just x- | otherwise = Nothing- {-# INLINE g #-}- f ys@(y:_) = let !idX0 = snd y in Just . (\(v2,v3) -> ((helpUPV3 vs [] .- map fst $ v2,snd . head $ v2),v3)) . partition (\(_,xs) -> xs == idX0) $ ys- f _ = Nothing+ | F.null ws = []+ | otherwise = mapMaybe (helpGSel sels F.sum whspss) . unfoldr f $ ks+ where+ !ks = indexedL ws+ !vs = mapMaybe g ks+ g (x, y)+ | y `F.elem` whspss = Just x+ | otherwise = Nothing+ {-# INLINE g #-}+ f ys@(y : _) =+ let !idX0 = snd y+ in Just+ . ( \(v2, v3) ->+ (+ ( helpUPV3 vs []+ . map fst+ $ v2+ , snd . head $ v2+ )+ , v3+ )+ )+ . partition (\(_, xs) -> xs == idX0)+ $ ys+ f _ = Nothing {-# INLINE uniquenessPeriodsGG #-} -- | A general variant of the diversity property. Use it in general case.-diverse2GGL :: (F.Foldable t1, F.Foldable t2, F.Foldable t3, Ord a) => t3 a -> t1 a -> t2 a -> Int16+diverse2GGL ::+ (F.Foldable t1, F.Foldable t2, F.Foldable t3, Ord a) =>+ t3 a ->+ t1 a ->+ t2 a ->+ Int16 diverse2GGL sels whspss = sum . uniquenessPeriodsGG sels whspss {-# INLINE diverse2GGL #-} @@ -57,9 +79,12 @@ diverse2GL :: (F.Foldable t1, F.Foldable t2) => t1 Char -> t2 Char -> Int16 diverse2GL = diverse2GGL [] {-# INLINE diverse2GL #-}+ --+ -- | A variant for the 'uniquenessPeriodsGG' function for 'Char'.-uniquenessPeriodsG :: (F.Foldable t1, F.Foldable t2) => t1 Char -> t2 Char -> [Int16]+uniquenessPeriodsG ::+ (F.Foldable t1, F.Foldable t2) => t1 Char -> t2 Char -> [Int16] uniquenessPeriodsG = uniquenessPeriodsGG [] {-# INLINE uniquenessPeriodsG #-} @@ -69,36 +94,48 @@ {-# INLINE diverse2GLInt8 #-} -- | A variant for the 'uniquenessPeriodsGG' function for 'Int8'.-uniquenessPeriodsGI8 :: (F.Foldable t1, F.Foldable t2) => t1 Int8 -> t2 Int8 -> [Int16]+uniquenessPeriodsGI8 ::+ (F.Foldable t1, F.Foldable t2) => t1 Int8 -> t2 Int8 -> [Int16] uniquenessPeriodsGI8 = uniquenessPeriodsGG [] {-# INLINE uniquenessPeriodsGI8 #-} -- | The first and the third list arguments of numbers (if not empty) must be sorted in the ascending order. helpUPV3 :: [Int16] -> [Int16] -> [Int16] -> [Int16]-helpUPV3 ks@(!z:zs) !acc ps@(!x:qs@(!y:_))- | z < y && z > x = helpUPV3 zs ((y - x):acc) qs - | z < y = helpUPV3 zs acc ps- | otherwise = helpUPV3 ks acc qs+helpUPV3 ks@(!z : zs) !acc ps@(!x : qs@(!y : _))+ | z < y && z > x = helpUPV3 zs ((y - x) : acc) qs+ | z < y = helpUPV3 zs acc ps+ | otherwise = helpUPV3 ks acc qs helpUPV3 _ !acc _ = acc -indexedL :: F.Foldable t => t b -> [(Int16, b)]+indexedL :: (F.Foldable t) => t b -> [(Int16, b)] indexedL = F.foldr f []- where f x ((j,z):ys) = (j-1,x):(j,z):ys- f x _ = [(1,x)]+ where+ f x ((j, z) : ys) = (j - 1, x) : (j, z) : ys+ f x _ = [(1, x)] -helpG :: (Eq a, F.Foldable t1, F.Foldable t2) => (t1 b -> b) -> t2 a -> (t1 b, a) -> Maybe b+helpG ::+ (Eq a, F.Foldable t1, F.Foldable t2) =>+ (t1 b -> b) ->+ t2 a ->+ (t1 b, a) ->+ Maybe b helpG h xs (ts, x)- | F.null ts = Nothing- | x `F.elem` xs = Nothing- | otherwise = Just (h ts)+ | F.null ts = Nothing+ | x `F.elem` xs = Nothing+ | otherwise = Just (h ts) {-# INLINE helpG #-} -helpGSel :: (Eq a, F.Foldable t1, F.Foldable t2, F.Foldable t3) => t3 a -> (t1 b -> b) -> t2 a -> (t1 b, a) -> Maybe b+helpGSel ::+ (Eq a, F.Foldable t1, F.Foldable t2, F.Foldable t3) =>+ t3 a ->+ (t1 b -> b) ->+ t2 a ->+ (t1 b, a) ->+ Maybe b helpGSel sels h xs (ts, x)- | F.null sels = helpG h xs (ts,x)- | F.null ts = Nothing- | x `F.elem` xs = Nothing- | x `F.elem` sels = Just (h ts)- | otherwise = Nothing+ | F.null sels = helpG h xs (ts, x)+ | F.null ts = Nothing+ | x `F.elem` xs = Nothing+ | x `F.elem` sels = Just (h ts)+ | otherwise = Nothing {-# INLINE helpGSel #-}-
CHANGELOG.md view
@@ -27,3 +27,8 @@ ## 0.4.0.0 -- 2024-10-22 * Fourth version. Added new command line parameter "-e" to control whether to print groups of "={digits}" on the screen while making output. Changed the number of arguments in various functions. ++## 0.5.0.0 -- 2024-11-18++* Fifth version. Removed +n command line parameter and the descending sorting of the resulting data. Changed the printing behaviour so that there is no longer too long half of the columns as empty one printed. Some code simplification in the module Aftovolio.Halfsplit. Added new constraint type G for specifying that more than two elements should be groupped together as a one whole (with possible inner permutations inside the group) during all the permutations.+
README.md view
@@ -1,4 +1,4 @@-# aftovolio-ukrainian+# AFTOVolio Author and [software developer:](https://hackage.haskell.org/package/aftovolio-ukrainian)@@ -6,7 +6,7 @@ # Introduction -Here is a brief introduction of AFTOVolio ideas and usage (that is Dutch 'Aanpak van Fonetische Talen voor het Ontdekken van de VOorkeursLIjnOpties' (Dutch people consider ji as a one letter and consequently one sound, but we use just first one for good readability) — Phonetic Languages Approach for Discovering the Preferred Line Options).+Here is a brief introduction of AFTOVolio ideas and usage (that is Dutch 'Aanpak van Fonetische Talen voor het Ontdekken van de VOorkeursLIjnOpties' (Dutch people consider ij as a one letter and consequently one sound, but we use just first one for good readability) — 'Phonetic Languages Approach for Discovering the Preferred Line Options'). Using AFTOVolio lets a person learn how to write the texts with the desired properties in pronunciation. @@ -421,8 +421,7 @@ not to break them in the analysis. For the general case, it should be borne in mind that auxiliar or dependent words can go after the independent or the main, so this should be considered separately (and-attach such words to the previous, not to the next). Currently, the-generalized version of aftovolio-general-simple supports both.+attach such words to the previous, not to the next). ## Advice how to use the programs @@ -625,6 +624,16 @@ generalisation of the W constraint, where the user can specify their own distance between words. +- Constraint G --- (Groupped together) --- two unequal digits, each of+ them indicates the sequence number of the first and the last elements+ of the group of words or their concatenations that should be groupped + together as a one whole (with possible inner permutations inside + the group) during all the permutations. Is useful mostly for some + syntactic constructions such as a sentence or a phrase. The inner + counting are not implemented yet and probably will be implemented in+ the future releases. Now the group is just used as a non-interrupted+ groupping of the words to be preserved as a one whole.+ ## Simple linear \"AND\" logic If only one of the basic constraints is used, or it is known for sure@@ -954,7 +963,7 @@ \... 8 садок вишневий колохати надвишнями гудуть хрущі 711 -as the element with the maximum value (since the 0.4.0.0 version the "-e" command line argument suppresses output of "={digits}" for better readability). The second line is changed because of the last syllable in the first line that is redundant as for the iambic meter.+as the element with the maximum value (the "-e" command line argument suppresses output of "={digits}" for better readability). The second line is changed because of the last syllable in the first line that is redundant as for the iambic meter. You can easily paste the =133 group into the text in many editors or on the command line directly. @@ -971,36 +980,34 @@ SYNOPSIS: -- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [+r <groupping info>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] Ukrainian textual line+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [+r <groupping info>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] Ukrainian textual line OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [-t <number of the test or its absence if 1 is here> [-C +RTS -N -RTS]] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+x <maximum number of words taken>]] Ukrainian textual line+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [-t <number of the test or its absence if 1 is here> [-C +RTS -N -RTS]] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+x <maximum number of words taken>]] Ukrainian textual line OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+ul <diversity property encoding string>] [+n] [+l] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] Ukrainian textual line+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+ul <diversity property encoding string>] [+l] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] Ukrainian textual line OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+l2 <a Ukrainian text line to compare similarity with> -l2]] [+di] Ukrainian textual line+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+l2 <a Ukrainian text line to compare similarity with> -l2]] [+di] Ukrainian textual line OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+ln <a sequence of positive Word8 values not greater than 255 e. g. 24 157 45 68 45 56 59 to compare similarity with> -ln]] [+di] Ukrainian textual line+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+ln <a sequence of positive Word8 values not greater than 255 e. g. 24 157 45 68 45 56 59 to compare similarity with> -ln]] [+di] Ukrainian textual line OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m <FilePath> <num1> +m2 <num2>]]+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m <FilePath> <num1> +m2 <num2>]] OR:-- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m3 <FilePath> <num1> <num2>]]+- aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m3 <FilePath> <num1> <num2>]] OR: - aftovolioUkr [-cm <FilePath to write the resulting combined output to> <FilePaths of the files to be compared and chosen the resulting options line-by-line>] ### Executable commandline parameters and their meaning -- +n — if specified then the order of sorting and printing is descending (the reverse one to the default otherwise).- - +l — if specified then the output for one property (no tests) contains empty lines between the groups of the line option with the same value of property. -- +w — if specified with the next Int8 number then the splitting of the output for non-testing options is used. Is used when no "-t" argument is given. The output is splitten into two columns to improve overall experience. The parameter after the "+w" is divided by 10 (-10 for negative numbers) to obtain the quotient and remainder (Int8 numbers). The quotient specifies the number of spaces or tabular characters to be used between columns (if the parameter is positive then the spaces are used, otherwise tabular characters). The remainder specifies the option of displaying. If the absolute value of the remainder (the last digit of the parameter) is 1 then the output in the second column is reversed; if it is in the range [2..5] then the output is groupped by the estimation values: if it is 2 then the first column is reversed; if it is 3 then the second column is reversed; if it is 4 then like 2 but additionally the empty line is added between the groups; if it is 5 then like for 3 and additionally the empty line is added between the groups. Otherwise, the second column is reversed. The rules are rather complex, but you can give a try to any number (Int8, [129..128] in the fullscreen terminal). The default value is 50 that corresponds to some reasonable layout.+- +w — if specified with the next Int8 number then the splitting of the output for non-testing options is used. Is used when no "-t" argument is given. The output is split into two columns to improve overall experience. The parameter after the "+w" is divided by 10 (-10 for negative numbers) to obtain the quotient and remainder (Int8 numbers). The quotient specifies the number of spaces or tabular characters to be used between columns (if the parameter is positive then the spaces are used, otherwise tabular characters). The remainder specifies the option of displaying. If the absolute value of the remainder (the last digit of the parameter) is 1 then the output in the second column is reversed; if it is in the range [2..5] then the output is groupped by the estimation values: if it is 2 then the first column is reversed; if it is 3 then the second column is reversed; if it is 4 then like 2 but additionally the empty line is added between the groups; if it is 5 then like for 3 and additionally the empty line is added between the groups. Otherwise, the second column is reversed. The rules are rather complex, but you can give a try to any number (Int8, [129..128] in the fullscreen terminal). The default value is 54 that corresponds to some reasonable layout. - +s — the next is the digit from 1 to 4 included. The default one is 2. Influences the result in the case of +d parameter is not given. @@ -1045,7 +1052,7 @@ - +ul — afterwards there is a string that encodes which sounds are used for diversity property evaluation. If used, then +r group has no meaning and is not used. Unlike in the link, the argument "1" means computing the property for all the sound representations included (for all of the present representations, so the value is maximal between all other strings instead of "1"). For more information, [see](https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types) -- +r — afterwards are several unique digits not greater than 8 in the descending order — the first one is the length of the group of syllables to be considered as a period, the rest — positions of the maximums and minimums. Example: "543" means that the line is splitted into groups of 5 syllables starting from the beginning, then the positions of the most maximum (4 = 5 - 1) and the next (smaller) maximum (3 = 4 - 1). If there are no duplicated values then the lowest possible value here is 0, that corresponds to the lowest minimum. If there are duplicates then the lowest value here is the number of the groups of duplicates, e. g. in the sequence 1,6,3,3,4,4,5 that is one group there are two groups of duplicates — with 3 and 4 — and, therefore, the corresponding data after +r should be 7\...2. The values less than the lowest minimum are neglected.+- +r — afterwards are several unique digits not greater than 8 in the descending order — the first one is the length of the group of syllables to be considered as a period, the rest — positions of the maximums and minimums. Example: "543" means that the line is split into groups of 5 syllables starting from the beginning, then the positions of the most maximum (4 = 5 - 1) and the next (smaller) maximum (3 = 4 - 1). If there are no duplicated values then the lowest possible value here is 0, that corresponds to the lowest minimum. If there are duplicates then the lowest value here is the number of the groups of duplicates, e. g. in the sequence 1,6,3,3,4,4,5 that is one group there are two groups of duplicates — with 3 and 4 — and, therefore, the corresponding data after +r should be 7\...2. The values less than the lowest minimum are neglected. - +c — see explanation at [the link](https://hackage.haskell.org/package/rhythmic-sequences-0.3.0.0/docs/src/Rhythmicity.MarkerSeqs.html#HashCorrections). Some preliminary tests show that theee corrections influence the result but not drastically, they can lead to changes in groupping and order, but mostly leave the structure similar. This shows that the algorithms used are more stable for such changes.
aftovolio.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aftovolio-version: 0.4.0.0+version: 0.5.0.0 -- A short (one-line) description of the package. synopsis: An AFTOVolio implementation for creating texts with special phonetic / prosodic properties.
src/Main.hs view
@@ -59,7 +59,7 @@ prepare = oneA "-p" argsA selStr = concat . getB "+ul" $ argsB grpp = R.grouppingR . concat . getB "+r" $ argsB- splitting = fromMaybe 50 (readMaybe (concat . getB "+w" $ argsB)::Maybe Int8)+ splitting = fromMaybe 54 (readMaybe (concat . getB "+w" $ argsB)::Maybe Int8) emptyline = oneA "+l" argsA numTest = fromMaybe 1 (readMaybe (concat . getB "-t" $ argsB)::Maybe Int) hashStep = fromMaybe 20 (readMaybe (concat . getB "+k" $ argsB)::Maybe Int)@@ -137,19 +137,19 @@ | not (null argCBs) = filterGeneralConv l argCBs . genPermutationsL $ l | null argCs = genPermutationsL l | otherwise = decodeLConstraints argCs . genPermutationsL $ l - descending = oneA "+n" argsA+-- descending = oneA "+n" argsA variants1 = force . uniquenessVariants2GNBL ' ' id id id perms $ ll if helpMessage then do hSetNewlineMode stdout universalNewlineMode helpPrint helpArg- else generalF power10 ldc compards html filtering dcfile selStr (prestr, poststr) lineNmb fileDu numTest hc grpp sylD descending hashStep emptyline splitting (filesave, codesave) concurrently (unwords arg3s) variants1 >> return ()+ else generalF power10 ldc compards html filtering dcfile selStr (prestr, poststr) lineNmb fileDu numTest hc grpp sylD hashStep emptyline splitting (filesave, codesave) concurrently (unwords arg3s) variants1 >> return () bSpecs :: CLSpecifications bSpecs = (zip ["+c","+d","+k","-h","+r","+s","-t","+ul","+w","+x","+q","+m2","-cm"] . cycle $ [1]) `mappend` [("+f",2),("+m",2),("+dc",2),("+m3",3)] aSpecs :: CLSpecifications-aSpecs = zip ["+di", "-e", "+l", "+n","-p", "-C"] . cycle $ [0]+aSpecs = zip ["+di", "-e", "+l", "-p", "-C"] . cycle $ [0] cSpecs :: CLSpecifications cSpecs = [("+a",-1),("+l2",-1),("+ln",-1)]@@ -157,18 +157,17 @@ helpPrint :: String -> IO () helpPrint xs | xs == "0" = putStrLn "SYNOPSIS:\n"- | xs == "1" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [+r <groupping info>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] <Ukrainian textual line>\n" - | xs == "2" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [-t <number of the test or its absence if 1 is here> [-C +RTS -N -RTS]] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+x <maximum number of words taken>]] <Ukrainian textual line>\n"- | xs == "3" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+ul <diversity property encoding string>] [+n] [+l] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] <Ukrainian textual line>\n"- | xs == "4" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+l2 <a Ukrainian text line to compare similarity with> -l2]] [+di] <Ukrainian textual line>\n"- | xs == "5" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m <FilePath> <num1> +m2 <num2>]]\n"- | xs == "6" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m3 <FilePath> <num1> <num2>]]\n"+ | xs == "1" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [+r <groupping info>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] <Ukrainian textual line>\n" + | xs == "2" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+c <HashCorrections encoded>] [-e] [+l] [+d <FilePath to file with durations>] [+k <number - hash step>] [-t <number of the test or its absence if 1 is here> [-C +RTS -N -RTS]] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+x <maximum number of words taken>]] <Ukrainian textual line>\n"+ | xs == "3" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [+ul <diversity property encoding string>] [+l] [-p] [+w <splitting parameter>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>]] <Ukrainian textual line>\n"+ | xs == "4" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+l2 <a Ukrainian text line to compare similarity with> -l2]] [+di] <Ukrainian textual line>\n"+ | xs == "5" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m <FilePath> <num1> +m2 <num2>]]\n"+ | xs == "6" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+di] [+m3 <FilePath> <num1> <num2>]]\n" | xs == "7" = putStrLn "aftovolioUkr [-cm <FilePath to write the resulting combined output to> <FilePaths of the files to be compared and chosen the resulting options line-by-line>]\n"- | xs == "8" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+n] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+ln <a sequence of Word8 positive integer values not greater than 255 e. g. 24 54 57 159 45 39 to compare similarity with> -ln]][+di] <Ukrainian textual line>\n"+ | xs == "8" = putStrLn "aftovolioUkr [[+a <AFTOVolio constraints> -a] [+b <extended algebraic AFTOVolio constraints> -b] [-e] [+l] [+d <FilePath to file with durations>] [+s <syllable durations function number>] [-p] [+w <splitting parameter>] [+q <power of 10 for multiplier in [2..6]>] [+f <FilePath to the file to be appended the resulting String> <control parameter for output parts>] [+x <maximum number of words taken>] [+dc <whether to print <br> tag at the end of each line for two-column output> <FilePath to the file where the two-column output will be written in addition to stdout>] [+ln <a sequence of Word8 positive integer values not greater than 255 e. g. 24 54 57 159 45 39 to compare similarity with> -ln]][+di] <Ukrainian textual line>\n" | xs == "OR" = putStrLn "OR:"- | xs == "n" = putStrLn "+n \t— if specified then the order of sorting and printing is descending (the reverse one to the default otherwise). \n" | xs == "l" = putStrLn "+l \t— if specified then the output for one property (no tests) contains empty lines between the groups of the line option with the same value of property. \n"- | xs == "w" = putStrLn "+w \t— if specified with the next Int8 number then the splitting of the output for non-testing options is used. Is used when no \"-t\" argument is given. The output is splitten into two columns to improve overall experience. The parameter after the \"+w\" is divided by 10 (-10 for negative numbers) to obtain the quotient and remainder (Int8 numbers). The quotient specifies the number of spaces or tabular characters to be used between columns (if the parameter is positive then the spaces are used, otherwise tabular characters). The remainder specifies the option of displaying. If the absolute value of the remainder (the last digit of the parameter) is 1 then the output in the second column is reversed; if it is in the range [2..5] then the output is groupped by the estimation values: if it is 2 then the first column is reversed; if it is 3 then the second column is reversed; if it is 4 then like 2 but additionally the empty line is added between the groups; if it is 5 then like for 3 and additionally the empty line is added between the groups. Otherwise, the second column is reversed. The rules are rather complex, but you can give a try to any number (Int8, [129..128] in the fullscreen terminal). The default value is 50 that corresponds to some reasonable layout.\n"+ | xs == "w" = putStrLn "+w \t— if specified with the next Int8 number then the splitting of the output for non-testing options is used. Is used when no \"-t\" argument is given. The output is split into two columns to improve overall experience. The parameter after the \"+w\" is divided by 10 (-10 for negative numbers) to obtain the quotient and remainder (Int8 numbers). The quotient specifies the number of spaces or tabular characters to be used between columns (if the parameter is positive then the spaces are used, otherwise tabular characters). The remainder specifies the option of displaying. If the absolute value of the remainder (the last digit of the parameter) is 1 then the output in the second column is reversed; if it is in the range [2..5] then the output is groupped by the estimation values: if it is 2 then the first column is reversed; if it is 3 then the second column is reversed; if it is 4 then like 2 but additionally the empty line is added between the groups; if it is 5 then like for 3 and additionally the empty line is added between the groups. Otherwise, the second column is reversed. The rules are rather complex, but you can give a try to any number (Int8, [129..128] in the fullscreen terminal). The default value is 54 that corresponds to some reasonable layout.\n" | xs == "s" = putStrLn "+s \t— the next is the digit from 1 to 4 included. The default one is 2. Influences the result in the case of +d parameter is not given. \n" | xs == "d" = putStrLn "+d \t— if present, then afterwards should be a FilePath to the file with new durations of the Ukrainian AFTOVolio representations. They can be obtained using the information in the manual by the link: https://oleksandr-zhabenko.github.io/uk/rhythmicity/phladiprelioEng.7.pdf#page=12 and the 2 next pages in the pdf file, besides on the page https://hackage.haskell.org/package/r-glpk-phonetic-languages-ukrainian-durations and on the commentaries here: https://hackage.haskell.org/package/phladiprelio-ukrainian-shared-0.5.0.0/docs/Aftovolio-Ukrainian-ReadDurations.html#v:readSound8ToWord8 with the last one having priority.\n" | xs == "p" = putStrLn "-p \t— if present the minimal grammar transformations (appending and prepending the dependent parts) are not applied. Can be useful also if the text is analyzed as a Ukrainian transcription of text in some other language.\n"@@ -182,7 +181,7 @@ | xs == "e" = putStrLn "-e \t— if present suppresses the printing of \"={digits}\" in the line option to the screen. Is used for better readability, often with \"+di\"." | xs == "q" = putStrLn "+q \t— if present with +l2 ... -l2 group of arguments then the next argument is a power of 10 which the distance between line option and the predefined line is quoted by. The default one is 0 (that means no change). You can specify not less than 0 and not greater than 4. Otherwise, these limit numbers are used instead. The greater value here leads to more groupped options output.\n" | xs == "ul" = putStrLn "+ul \t— afterwards there is a string that encodes which sounds are used for diversity property evaluation. If used, then +r group has no meaning and is not used. Unlike in the link, the argument \"1\" means computing the property for all the sound representations included (for all of the present representations, so the value is maximal between all other strings instead of \"1\"). For more information, see: https://oleksandr-zhabenko.github.io/uk/rhythmicity/PhLADiPreLiO.Eng.21.html#types\n"- | xs == "r" = putStrLn "+r \t— afterwards are several unique digits not greater than 8 in the descending order — the first one is the length of the group of syllables to be considered as a period, the rest — positions of the maximums and minimums. Example: \"543\" means that the line is splitted into groups of 5 syllables starting from the beginning, then the positions of the most maximum (4 = 5 - 1) and the next (smaller) maximum (3 = 4 - 1). If there are no duplicated values then the lowest possible value here is 0, that corresponds to the lowest minimum. If there are duplicates then the lowest value here is the number of the groups of duplicates, e. g. in the sequence 1,6,3,3,4,4,5 that is one group there are two groups of duplicates — with 3 and 4 — and, therefore, the corresponding data after +r should be 7...2. The values less than the lowest minimum are neglected.\n"+ | xs == "r" = putStrLn "+r \t— afterwards are several unique digits not greater than 8 in the descending order — the first one is the length of the group of syllables to be considered as a period, the rest — positions of the maximums and minimums. Example: \"543\" means that the line is split into groups of 5 syllables starting from the beginning, then the positions of the most maximum (4 = 5 - 1) and the next (smaller) maximum (3 = 4 - 1). If there are no duplicated values then the lowest possible value here is 0, that corresponds to the lowest minimum. If there are duplicates then the lowest value here is the number of the groups of duplicates, e. g. in the sequence 1,6,3,3,4,4,5 that is one group there are two groups of duplicates — with 3 and 4 — and, therefore, the corresponding data after +r should be 7...2. The values less than the lowest minimum are neglected.\n" | xs == "c" = putStrLn "+c \t— see explanation at the link: https://hackage.haskell.org/package/rhythmic-sequences-0.3.0.0/docs/src/Rhythmicity.MarkerSeqs.html#HashCorrections Some preliminary tests show that theee corrections influence the result but not drastically, they can lead to changes in groupping and order, but mostly leave the structure similar. This shows that the algorithms used are more stable for such changes.\n" | xs == "t" = putStrLn "-t \t— and afterwards the number in the range [0..179] (with some exceptions) showing the test for \'smoothness\' (to be more accurate - absence or presence of some irregularities that influences the prosody) to be run - you can see a list of possible values for the parameter here at the link: \nhttps://hackage.haskell.org/package/phladiprelio-ukrainian-simple-0.6.0.0/src/app/Main.hs on the lines number: 51; 56-115; 118-126. The first section of the lines numbers 56-63 and 120 corresponds to the detailed explanation below. \nFor ideas of actual usage of the tests, see the documentation by the links: https://www.academia.edu/105067723/%D0%A7%D0%BE%D0%BC%D1%83_%D0%B4%D0%B5%D1%8F%D0%BA%D1%96_%D1%80%D1%8F%D0%B4%D0%BA%D0%B8_%D0%BB%D0%B5%D0%B3%D0%BA%D0%BE_%D0%B2%D0%B8%D0%BC%D0%BE%D0%B2%D0%BB%D1%8F%D1%82%D0%B8_%D0%B0_%D1%96%D0%BD%D1%88%D1%96_%D0%BD%D1%96_%D0%B0%D0%B1%D0%BE_%D0%BF%D1%80%D0%BE%D1%81%D0%BE%D0%B4%D0%B8%D1%87%D0%BD%D0%B0_%D0%BD%D0%B5%D1%81%D0%BF%D1%80%D0%BE%D0%B3%D0%BD%D0%BE%D0%B7%D0%BE%D0%B2%D0%B0%D0%BD%D1%96%D1%81%D1%82%D1%8C_%D1%8F%D0%BA_%D1%85%D0%B0%D1%80%D0%B0%D0%BA%D1%82%D0%B5%D1%80%D0%B8%D1%81%D1%82%D0%B8%D0%BA%D0%B0_%D1%82%D0%B5%D0%BA%D1%81%D1%82%D1%83?source=swp_share and https://www.academia.edu/105067761/Why_some_lines_are_easy_to_pronounce_and_others_are_not_or_prosodic_unpredictability_as_a_characteristic_of_text\n" | xs == "C" = putStrLn "-C \t— If specified with +RTS -N -RTS rtsoptions for the multicore computers with -t option then it can speed up the full computation of the all tests using more resources. Uses asynchcronous concurrent threads in computation. This groups (-C and rtsoptions) can be specified in any position as command line groups of arguments. The output is in this case not sorted in the order of 2,3,4,5,6,7, but can vary depending on your CPU configurations and states and / or some other factors.\n"@@ -195,7 +194,6 @@ where helpFE xs = mapM helpPrint js >> return () js | xs == "-cm" = ["0","7","cm"] - | xs == "+n" = ["0","1","OR","2","OR","3","OR","4","OR","5","OR","6","OR","8","n"] | xs == "+l" = ["0","1","OR","2","OR","3","OR","4","OR","5","OR","6","OR","8","l"] | xs == "+w" = ["0","1","OR","2","OR","3","OR","4","OR","5","OR","6","OR","8","w"] | xs == "+s" = ["0","1","OR","2","OR","4","OR","5","OR","6","OR","8","s"] @@ -220,5 +218,5 @@ | xs == "+m" = ["0","5","m"] | xs == "+m2" = ["0","5","m2"] | xs == "+m3" = ["0","6","m3"] - | otherwise = ["0","1","OR","2","OR","3","OR","4","OR","5","OR","6","OR","7","OR","8","n","l","w","s","d","p","f","dc","a","b","l2","q","ul","r","c","t","C","k","x","m","m2","cm"]+ | otherwise = ["0","1","OR","2","OR","3","OR","4","OR","5","OR","6","OR","7","OR","8","l","w","s","d","p","f","dc","a","b","l2","q","ul","r","c","t","C","k","x","m","m2","cm"]