phonetic-languages-rhythmicity 0.3.2.0 → 0.4.0.0

raw patch · 4 files changed

+387/−14 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• Rhythmicity/PolyRhythm.hs +347/−0
• Rhythmicity/TwoFourth.hs +33/−11
• phonetic-languages-rhythmicity.cabal +3/−3

@@ -34,3 +34,7 @@  * Third version revised B. Some changes to the code and documentation in the Rhythmicity.TwoFourth module. +## 0.4.0.0 -- 2021-07-27++* Fourth version. Fixed some issues with the Rhythmicity.TwoFourth module. Added a new module Rhythmicity.PolyRhythm.+Added GHC extension usage of MultiWayIf.

@@ -0,0 +1,347 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Rhythmicity.PolyRhythm+-- Copyright   :  (c) OleksandrZhabenko 2021+-- License     :  MIT+-- Stability   :  Experimental+-- Maintainer  :  olexandr543@yahoo.com+--+-- The module is highly experimental approach to estimate further the rhythmicity (using some extent of the+-- music concept of polyrhythm) of the not very long lists (well, not longer than e. g. 30 elements).+-- Is rather computationally expensive, so must be used with caution. If the period+-- of rhythm is less than 5 or even 6 it is not effective.++module Rhythmicity.PolyRhythm where++import Data.List (sort)+import Data.Maybe (fromJust)+import Data.Char (toLower)+import GHC.Float (int2Double)++data Marker4s = D | E | F | G deriving (Eq,Ord,Show)++newtype PolyMarkers = PolyMs Char deriving (Eq,Ord)++instance Show PolyMarkers where+  show (PolyMs c) = 'P':' ':[toLower c]++data PolyMrks = R4 Marker4s | RP PolyMarkers deriving (Eq,Ord,Show)++is4s :: PolyMrks -> Bool+is4s (R4 _) = True+is4s _ = False++isPoly :: PolyMrks -> Bool+isPoly (RP _) = True+isPoly _ = False++{-| Data to specify some quantitative information of the structure of rhythmicity.+-}+data PolyRhythmBasis = PolyRhythm [Int] deriving (Eq,Show)++vals :: PolyRhythmBasis -> [Int]+vals (PolyRhythm xs) = xs++{-| Data to specify (mostly) the qualitative information of the structure of rhythmicity.+-}+data PolyChoices = PolyCh {+  xn :: [Bool], -- ^ the 'True' corresponds to maximums, 'False' -- to minimums+  pqty :: Int -- ^ general quantity of the elements to be taken as one period. Must be not less than the sum of 'cheis' and 'chbis'. Symbolically, it must be 'sum' . 'vals' . 'PolyRhythm' $ ['Int'] = 'PolyCh' 'pqty'.+} deriving Eq++{-| The predicate to check whether the two given arguments can be used together to get meaningful results.+-}+validPolyChRhPair :: PolyChoices -> PolyRhythmBasis -> Bool+validPolyChRhPair (PolyCh xs n) (PolyRhythm ys)+ | ks <= [0] = False+ | any (<0) rs = False+ | length xs < n && drop l ys > [0] && l == length xs = n == sum ys+ | otherwise = False+     where (ks,rs) = splitAt 1 ys+           l = length ys - 1++data Intermediate a = J a | I PolyMarkers deriving (Eq, Ord)++isJI :: Intermediate a -> Bool+isJI (J _) = True+isJI _ = False++fromIntermediate :: Intermediate a -> Maybe PolyMrks+fromIntermediate (I k) = Just (RP k)+fromIntermediate _ = Nothing+     +getPolyChRhData+  :: (Ord a) => Char -- ^ The start of the 'RP' 'PolyMarkers' count in case of 'PolyMrks' with 'Char's. The usual one can be \'a\' or \'h\'.+  -> Int -- ^ If the argument is less or equal to 4, then 'Marker4s' is used, if it is greater than 4, then 'PolyMarkers' is used.+  -> PolyChoices+  -> PolyRhythmBasis+  -> [a]+  -> [[PolyMrks]]+getPolyChRhData c r choice@(PolyCh ts l1) rhythm@(PolyRhythm ys) xs+ | r <= 4 && validPolyChRhPair choice rhythm = map (g4 choice rhythm) . f choice $ xs+ | r > 4 && validPolyChRhPair choice rhythm =+    map (\ks -> map (fromJust . fromIntermediate) . gPoly [c..] choice rhythm ks . map J $ ks) . f choice $ xs+ | otherwise = error "Rhythmicity.PolyRhythm.getPolyChRhData: the first two arguments cannot be used together to get some meaningful result. "+     where g4 (PolyCh js l) (PolyRhythm ys) us = let ws = sort us in case (ys,js) of+             (x1:x2:x3:zs,[False,False,False]) -> let !k1 = ws !! (x1 - 1)+                                                      !k2 = ws !! (x1 + x2 - 1)+                                                      !k3 = ws !! (x1 + x2 + x3 - 1) in+                                                        map (\t -> if+                                                                | t <= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t <= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t <= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[True,False,False]) -> let !k1 = ws !! (length ws - x1)+                                                     !k2+                                                       | x2 < 2 = head ws+                                                       | otherwise = ws !! (x2 - 1)+                                                     !k3+                                                       | x2 == 0 = head ws+                                                       | otherwise = ws !! (x2 + x3 - 1) in+                                                        map (\t -> if+                                                                | t >= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t <= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t <= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[False,True,False]) -> let !k1 = ws !! (x1 - 1)+                                                     !k2+                                                       | x2 == 0 = last ws+                                                       | otherwise = ws !! (length ws - x2)+                                                     !k3 = ws !! (x1 + x3 - 1) in+                                                        map (\t -> if+                                                                | t <= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t >= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t <= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[False,False,True]) -> let !k1 = ws !! (x1 - 1)+                                                     !k2 = ws !! (x1 + x2 - 1)+                                                     !k3+                                                       | x3 == 0 = last ws+                                                       | otherwise = ws !! (length ws - x3) in+                                                        map (\t -> if+                                                                | t <= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t <= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t >= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[True,True,False]) -> let !k1 = ws !! (length ws - x1)+                                                    !k2 = ws !! (length ws - x1 - x2 - 1)+                                                    !k3+                                                      | x3 == 0 = head ws+                                                      | otherwise = ws !! (x3 - 1) in+                                                        map (\t -> if+                                                                | t >= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t >= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t <= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[True,False,True]) -> let !k1 = ws !! (length ws - x1)+                                                    !k2+                                                      | x2 == 0 = head ws+                                                      | otherwise = ws !! (x2 - 1)+                                                    !k3 = ws !! (length ws - x1 - x3) in+                                                        map (\t -> if+                                                                | t >= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t <= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t >= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[False,True,True]) -> let !k1 = ws !! (x1 - 1)+                                                    !k2+                                                      | x2 == 0 = last ws+                                                      | otherwise = ws !! (length ws - x2)+                                                    !k3+                                                      | x2 == 0 = last ws+                                                      | otherwise = ws !! (length ws - x2 - x3) in+                                                        map (\t -> if+                                                                | t <= k1 -> R4 D+                                                                | x2 == 0 -> R4 G+                                                                | t >= k2 -> R4 E+                                                                | x3 == 0 -> R4 G+                                                                | t >= k3 -> R4 F+                                                                | otherwise -> R4 G) us+             (x1:x2:x3:zs,[_,_,_]) -> let !k1 = ws !! (length ws - x1)+                                          !k2 = ws !! (length ws - x1 - x2)+                                          !k3 = ws !! (length ws - x1 - x2 - x3) in+                                             map (\t -> if+                                                     | t >= k1 -> R4 D+                                                     | x2 == 0 -> R4 G+                                                     | t >= k2 -> R4 E+                                                     | x3 == 0 -> R4 G+                                                     | t >= k3 -> R4 F+                                                     | otherwise -> R4 G) us+           gPoly wws (PolyCh (j:js) l) (PolyRhythm (y:ys)) vs us+            | null vs = map (\r -> if | isJI r -> (\q@(J rr) -> I (PolyMs (head wws))) r+                                      | otherwise -> r) us+            | y == 0 = map (\r -> if | isJI r -> (\q@(J rr) -> I (PolyMs (head wws))) r+                                     | otherwise -> r) us+            | otherwise = let ws = sort vs in case j of+               False -> let !k = ws !! (y - 1) in+                                gPoly (drop 1 wws) (PolyCh js l) (PolyRhythm ys) (filter (> k) vs) +                                 (map (\r -> if+                                              | isJI r -> (\q@(J rr) -> if+                                                                         | rr <= k -> I (PolyMs (head wws))+                                                                         | otherwise -> q) r+                                              | otherwise -> r) us)+               _  -> let !k = ws !! (length ws - y) in+                              gPoly (drop 1 wws) (PolyCh js l) (PolyRhythm ys) (filter (< k) vs)+                               (map (\r -> if+                                            | isJI r -> (\q@(J rr) -> if+                                                                       | rr >= k -> I (PolyMs (head wws))+                                                                       | otherwise -> q) r+                                            | otherwise -> r) us)+           gPoly wws (PolyCh [] l)  _ vs us = map (\r -> if isJI r then I (PolyMs (head wws)) else r) us+           f ch@(PolyCh _ l1) ys@(_:_) =+             let !q = length ys `quot` l1+                 rs = take (q * l1) ys in f' ch rs+           f' ch@(PolyCh _ l1) qs@(_:_) = let (ts,zs) = splitAt l1 qs in ts : f' ch zs+           f' _ [] = []++increasingF+ :: Int+ -> Double+ -> Double+increasingF n x+ | n <= 0 || x <= 0 = error $ "Rhythmicity.PolyRhythm.increasingF: not defined for the arguments. " ++ show n ++ " " ++ show x+ | x < 1 = int2Double (n + 1) - int2Double n * x+ | otherwise = x ^ n++decreasingF+ :: Int+ -> Double+ -> Double+decreasingF n x+ | n <= 0 || x <= 0 = error $ "Rhythmicity.PolyRhythm.decreasingF: not defined for the arguments. " ++ show n ++ " " ++ show x+ | x < 1 = x / int2Double n+ | otherwise = x ** (1.0 / int2Double n)++similarityF1+ :: Char -- ^ The start of the counting.+ -> PolyMrks+ -> PolyMrks+ -> Double -- ^ The initial value.+ -> Double+similarityF1 c m1 m2 x0+ | is4s m1 = if+    | m1 == m2 -> case (\(R4 t0) -> t0) m1 of+        D -> increasingF 4 x0+        E -> increasingF 3 x0+        F -> increasingF 2 x0+        _ -> increasingF 1 x0+    | otherwise -> case (\(R4 t0) -> t0) . min m1 $ m2 of+        D -> decreasingF 4 x0+        E -> decreasingF 3 x0+        F -> decreasingF 2 x0+        _ -> decreasingF 1 x0+ | otherwise = let n = length [c..(\(RP (PolyMs t0)) -> t0) (min m1 m2)] in+     if+       | m1 == m2 -> increasingF n x0+       | otherwise -> decreasingF n x0+{-# INLINE similarityF1 #-} ++{-| The more straightforward variant of the 'similarityF1' function. -}+similarityF0+ :: Char -- ^ The start of the counting.+ -> PolyMrks+ -> PolyMrks+ -> Double -- ^ The initial value.+ -> Double+similarityF0 c m1 m2 x0+ | is4s m1 = if+    | m1 == m2 -> case (\(R4 t0) -> t0) m1 of+        D -> increasingF 4 x0+        E -> increasingF 3 x0+        F -> increasingF 2 x0+        _ -> increasingF 1 x0+    | otherwise -> x0+ | otherwise = let n = length [c..(\(RP (PolyMs t0)) -> t0) (min m1 m2)] in+     if+       | m1 == m2 -> increasingF n x0+       | otherwise -> x0+{-# INLINE similarityF0 #-} ++{-| The function that uses a simple arithmetic logics to calculate the similarity of the two equal by length (if not they are truncated to the least one)+lists of 'PolyMrks'. Uses both increasing and decreasing functions. +-}+similarityLogics+  :: Char -- ^ The start of the counting.+  -> Double -- ^ An initial value.+  -> [PolyMrks]+  -> [PolyMrks]+  -> Double  -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+similarityLogics c x0 (x:xs) (y:ys) = similarityLogics c (similarityF1 c x y x0) xs ys+similarityLogics c x0 _ _ = x0++{-| The more straightforward variant of the 'similarityLogics' function. -}+similarityLogics0+  :: Char -- ^ The start of the counting.+  -> Double -- ^ An initial value.+  -> [PolyMrks]+  -> [PolyMrks]+  -> Double  -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+similarityLogics0 c x0 (x:xs) (y:ys) = similarityLogics0 c (similarityF0 c x y x0) xs ys+similarityLogics0 c x0 _ _ = x0++{-| The function that uses a simple arithmetic logics to calculate the similarity of the two equal by length (if not they are truncated to the least one)+lists of 'PolyMrks'. Uses 'similarityLogics' inside.+-}           +similarityPoly+ :: Char -- ^ The start of the counting.+ -> Double -- ^ The initial value starting from which it counts. Usually, equals to 1.0.+ -> [[PolyMrks]]+ -> Double  -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+similarityPoly c z (xs:ys:xss) = similarityPoly c (z * similarityLogics c z xs ys) (ys:xss)+similarityPoly _ z _ = z++{-| The function that uses a simple arithmetic logics to calculate the similarity of the two equal by length (if not they are truncated to the least one)+lists of 'PolyMrks'. Uses 'similarityLogics0' inside.+The more straightforward variant of the 'similarityPoly' function.+-}           +similarityPoly0+ :: Char -- ^ The start of the counting.+ -> Double -- ^ The initial value starting from which it counts. Usually, equals to 1.0.+ -> [[PolyMrks]]+ -> Double  -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+similarityPoly0 c z (xs:ys:xss) = similarityPoly0 c (z * similarityLogics0 c z xs ys) (ys:xss)+similarityPoly0 _ z _ = z++++{-| General function to estimate the inner rhythmicity of the 'Ord'ered list of values. For many cases its arguments can be+guessed or approximated by some reasonable values. Nevertheless, it is a highly experimental one.+-}+rhythmicityPoly+  :: (Ord a) => Double -- ^ The initial value starting from which it counts. Usually, equals to 1.0.+  -> Int -- ^ If the argument is less or equal to 4, then 'Marker4s' is used, if it is greater than 4, then 'PolyMarkers' is used.+  -> PolyChoices+  -> PolyRhythmBasis+  -> [a]+  -> Double -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+rhythmicityPoly x0 r choices rhythm = similarityPoly 'a' x0 . getPolyChRhData 'a' r choices rhythm+{-# INLINE rhythmicityPoly #-}++{-| General function to estimate the inner rhythmicity of the 'Ord'ered list of values. For many cases its arguments can be+guessed or approximated by some reasonable values. Nevertheless, it is a highly experimental one.+The more straightforward variant of the 'rhythmicityPoly' function. +-}+rhythmicityPoly0+  :: (Ord a) => Double -- ^ The initial value starting from which it counts. Usually, equals to 1.0.+  -> Int -- ^ If the argument is less or equal to 4, then 'Marker4s' is used, if it is greater than 4, then 'PolyMarkers' is used.+  -> PolyChoices+  -> PolyRhythmBasis+  -> [a]+  -> Double -- ^ In case of positive previous 'Double' arguments this is a positive value. The greater one corresponds to (probably) more rhythmic list.+rhythmicityPoly0 x0 r choices rhythm = similarityPoly0 'a' x0 . getPolyChRhData 'a' r choices rhythm+{-# INLINE rhythmicityPoly0 #-}

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_HADDOCK show-extensions #-}  -- |@@ -47,8 +48,9 @@ -} validChRhPair :: Choices -> RhythmBasis -> Bool validChRhPair (Ch x y n) (Rhythm p q l)- | p < 0 || q < 0 || l < 0 = False- | n > 1 = if n == p + q + l then n >= x + y else False+ | p <= 0 = False+ | q < 0 = False+ | l > 0 = n == p + q + l  | otherwise = False  {-| The value for the 'Choices' with the two maximum highlighted values and two other ones in the 4-element period.@@ -70,16 +72,36 @@      where g ch@(Ch n m l) rh@(Rhythm x y z) us = let ws = sort us in case (x,y,n,m) of              (x1,y1,0,0) -> let !k1 = ws !! (x1 - 1)                                 !k2 = ws !! (x1 + y1 - 1) in-                                  map (\t -> if t <= k1 then A else if t <= k2 then B else C) us-             (x1,y1,u,0) -> let !k1 = ws !! (length us - x1)-                                !k2 = ws !! (x1 + y1 - 1) in-                                  map (\t -> if t >= k1 then A else if t <= k2 then B else C) us-             (x1,y1,0,w) -> let !k1 = ws !! (x1 - 1)-                                !k2 = ws !! (length us - y1) in-                                  map (\t -> if t <= k1 then A else if t >= k2 then B else C) us-             (x1,y1,u,w) -> let !k1 = ws !! (length us - x1)+                                  map (\t -> if+                                          | t <= k1 -> A+                                          | y1 == 0 -> C+                                          | t <= k2 -> B+                                          | otherwise -> C) us+             (x1,y1,_,0) -> let !k1 = ws !! (length us - x1)+                                !k2+                                  | y1 < 2 = head ws+                                  | otherwise = ws !! (y1 - 1) in+                                  map (\t -> if+                                          | t >= k1 -> A+                                          | y1 == 0 -> C+                                          | t <= k2 -> B+                                          | otherwise -> C) us+             (x1,y1,0,_) -> let !k1 = ws !! (x1 - 1)+                                !k2+                                  | y1 == 0 = last ws+                                  | otherwise = ws !! (length us - y1) in+                                  map (\t -> if+                                          | t <= k1 -> A+                                          | y1 == 0 -> C+                                          | t >= k2 -> B+                                          | otherwise -> C) us+             (x1,y1,_,_) -> let !k1 = ws !! (length us - x1)                                 !k2 = ws !! (length us - x1 - y1) in-                                  map (\t -> if t >= k1 then A else if t >= k2 then B else C) us+                                  map (\t -> if+                                          | t >= k1 -> A+                                          | y1 == 0 -> C+                                          | t >= k2 -> B+                                          | otherwise -> C) us            f ch@(Ch _ _ l1) ys@(_:_) =              let !q = length ys `quot` l1                  rs = take (q * l1) ys in f' ch rs

@@ -2,7 +2,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:                phonetic-languages-rhythmicity-version:             0.3.2.0+version:             0.4.0.0 synopsis:            Allows to estimate the rhythmicity properties for the text (usually, the Ukrainian poetic one) description:         Allows to estimate (somewhat to say, evaluate) the rhythmicity properties for the text (usually, the Ukrainian poetic one, but it can be extrapolated to other ones). Inspired by the ancient Greek and Latin poetry. @@ -18,9 +18,9 @@ cabal-version:       >=1.10  library-  exposed-modules:     Languages.Rhythmicity, Languages.Rhythmicity.Factor, Rhythmicity.TwoFourth+  exposed-modules:     Languages.Rhythmicity, Languages.Rhythmicity.Factor, Rhythmicity.TwoFourth, Rhythmicity.PolyRhythm   -- other-modules:-  other-extensions:    BangPatterns+  other-extensions:    BangPatterns, MultiWayIf   ghc-options:         -funbox-strict-fields   build-depends:       base >=4.7 && <4.15   -- hs-source-dirs: