phonetic-languages-constraints-array 0.6.2.0 → 0.7.0.0

raw patch · 3 files changed

+86/−30 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Phladiprelio/ConstraintsEncoded.hs +80/−29
• phonetic-languages-constraints-array.cabal +1/−1

@@ -59,3 +59,8 @@ * Sixth version revised C. Fixed the issues with precedence of the (&&) and (||) logical operators.  Now it should behave as usual and as is defined in Haskell98 and Haskell2010.  +## 0.7.0.0 -- 2023-05-31++* Seventh version. Added new constraints encoding to the Phladiprelio.ContstraintsEncoded module +(N, D, I). Some documentation improvements.+

@@ -39,6 +39,9 @@   , isH   , isR   , isM+  , isN+  , isD+  , isI   -- * Algebraic general conversion   , validOrdStr   , generalConversion@@ -49,28 +52,32 @@ import GHC.List import GHC.Num ((+),(-),abs) import Text.Show (show, Show(..))-import Text.Read (readMaybe)+import Text.Read (readMaybe, read) import Data.Maybe import Data.List (nub, words, groupBy) import GHC.Arr import Data.Char (isDigit, isLetter) import Phladiprelio.Constraints-import Data.SubG (InsertLeft(..))+import Data.SubG (InsertLeft(..), splitAtEndG) import Data.Tuple (fst) -data EncodedContraints a b = E -                           | P a b -                           | Q a a a a a -                           | T a a a a -                           | SA a a b -                           | SB a a b -                           | F a a a -                           | V a a a -                           | W a a a -                           | H a a a a -                           | R a a a a -                           | M a a a a -                           deriving (Eq, Ord, Show)+data EncodedContraints a b c +  = 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 c  -- ^ 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.+  deriving (Eq, Ord, Show)  validOrdStr0    :: String @@ -79,30 +86,30 @@   -> Bool validOrdStr0 xs@('E':ys) n m = validOrdStr0 ys n m validOrdStr0 xs@(' ':y:t:ys) n m-  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m+  | y `elem` "ABDFHIMNPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m   | y `elem` "-(E" = validOrdStr0 (y:t:ys) n m   | otherwise = False   validOrdStr0 xs@('(':y:t:ys) n m-  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) (n + 1) m+  | y `elem` "ABDFHIMNPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) (n + 1) m   | y `elem` "-(E" = validOrdStr0 (y:t:ys) (n + 1) m   | otherwise = False   validOrdStr0 xs@(')':y:t:ys) n m-  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n (m + 1)+  | y `elem` "ABDFHIMNPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n (m + 1)   | y `elem` "-()E" = validOrdStr0 (y:t:ys) n (m + 1)   | otherwise = False   validOrdStr0 xs@('-':y:t:ys) n m-  | y `elem` "ABFHMPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m +  | y `elem` "ABDFHIMNPQRTVW" && isDigit t = validOrdStr0 (dropWhile isDigit ys) n m    | y `elem` "-)" || isDigit y = False   | otherwise = validOrdStr0 (y:t:ys) n m  validOrdStr0 xs@(x:y:t:ys) n m -  | x `elem` "ABFHMPQRTVW" = if isDigit y then validOrdStr0 (dropWhile isDigit (t:ys)) n m else False+  | x `elem` "ABDFHIMNPQRTVW" = if isDigit y then validOrdStr0 (dropWhile isDigit (t:ys)) n m else False   | otherwise = validOrdStr0 (y:t:ys) n (m + 1)  validOrdStr0 xs@(x:')':ys) n m    | isDigit x || x == ')' = validOrdStr0 ys n (if x == ')' then m + 2 else m + 1)    | otherwise = False validOrdStr0 xs@(x:y:ys) n m -  | x `elem` "(ABFHMQRTVW" = False-  | y `elem` " -(ABFHMPQRTVW" = False+  | x `elem` "(ABDFHIMNQRTVW" = False+  | y `elem` " -(ABDFHIMNPQRTVW" = False   | x == 'P' && not (isDigit y) = False   | x == ')' && y `notElem` ")E" = False   | x == 'P' && n == m = True@@ -226,12 +233,18 @@        _   -> f n h ts  | otherwise = Nothing          where f n c ts -                 | c `elem` "HFMRQTVW" = let ys = nub . catMaybes . map (\t -> readMaybe [t]::Maybe Int) $ ts-                                             res -                                               | 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 `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; ~ww -> W}) n y z)-                                               | otherwise = 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; ~rr -> R}) n y z u) in res+                 | c `elem` "DFHIMQRQTVW" = +                       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 `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; ~ww -> 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; ~rr -> 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@@ -241,14 +254,24 @@                                                  ~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; n -> n-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; n -> n-1})) $ h3                  | otherwise = Nothing+                        where h1 bs@(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                  | otherwise = 3  -type EncodedCnstrs = EncodedContraints Int (Array 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'. @@ -265,7 +288,11 @@ decodeConstraint1 (H _ i j k) = filterSignDistanceIJK3 i j k (abs $ j - i) (abs $ k - j) decodeConstraint1 (R _ i j k) = filterUnsignDistanceIJK3 i j k (abs $ j - i) (abs $ k - j) decodeConstraint1 (M _ i j k) = filterMixedDistanceIJK3 i j k (abs $ j - i) (abs $ k - j)+decodeConstraint1 (N _ v) = fixedPointsG v+decodeConstraint1 (D _ i j d) = filterSignDistanceIJ i j (abs d)+decodeConstraint1 (I _ i j d) = filterUnsignDistanceIJ i j (abs d) + -- | 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)@@ -292,6 +319,9 @@ 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 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 @@ -303,6 +333,9 @@ 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   isE :: EncodedCnstrs -> Bool isE E = True@@ -352,7 +385,19 @@ isM (M _ _ _ _) = True isM _ = False +isN :: EncodedCnstrs -> Bool+isN (N _ _) = True+isN _ = False +isD :: EncodedCnstrs -> Bool+isD (D _ _ _ _) = True+isD _ = False++isI :: EncodedCnstrs -> Bool+isI (I _ _ _ _) = True+isI _ = False++ {-| Works only with the correctly defined argument though it is not checked. Use with this caution. -} getIEl :: EncodedCnstrs -> Int@@ -368,6 +413,9 @@ getIEl (H _ i _ _) = i getIEl (R _ i _ _) = i getIEl (M _ i _ _) = i+getIEl (N _ arr) = fst . unsafeAt arr $ 0 +getIEl (D _ i _ _) = i+getIEl (I _ i _ _) = i  {-| Works only with the correctly defined arguments though it is not checked. Use with this caution. -}@@ -384,4 +432,7 @@ setIEl i (H n _ j k) = H n i j k setIEl i (R n _ j k) = R n i j k setIEl i (M n _ j k) = M n i j k+setIEl i (N n arr) = N n arr+setIEl i (D n _ j k) = D n i j k+setIEl i (I n _ j k) = I n i j k 

@@ -2,7 +2,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:                phonetic-languages-constraints-array-version:             0.6.2.0+version:             0.7.0.0 synopsis:            Constraints to filter the needed permutations description:         Provides several the most important variants of constraints. Can be used with the phonetic-languages-common series of package. Instead of vectors, uses arrays. homepage:            https://hackage.haskell.org/package/phonetic-languages-constraints-array