phonetic-languages-constraints-array 0.1.2.0 → 0.8.0.0
raw patch · 8 files changed
Files
- CHANGELOG.md +77/−0
- LICENSE +1/−1
- Languages/UniquenessPeriods/Array/Constraints.hs +0/−106
- Languages/UniquenessPeriods/Array/Constraints/Encoded.hs +0/−192
- Phladiprelio/Constraints.hs +363/−0
- Phladiprelio/ConstraintsEncoded.hs +456/−0
- README.md +22/−0
- phonetic-languages-constraints-array.cabal +7/−6
CHANGELOG.md view
@@ -13,3 +13,80 @@ * First version revised B. Added the new constraint P functionality. +## 0.2.0.0 -- 2023-01-31++* Second version. Switched to NoImplicitPrelude extension. Changed the names of the modules. Updated the dependencies boundaries.++## 0.3.0.0 -- 2023-05-15++* Third version. Added new types of constraints based on the signed and unsigned distance(s)+between two or three elements (encoded with the capital letters V, W, H, R).++## 0.4.0.0 -- 2023-05-15++* Fourth version. Added a new type of constraint based on both signed and unsigned distances+between three elements (encoded with M). Some documentation improvements.++## 0.4.1.0 -- 2023-05-16++* Fourth version revised. Changed the number of parameters for the new constructors added. Added+isM function to the export from the module.++## 0.5.0.0 -- 2023-05-17++* Fifth version. Changed representation in the EncodedCnstr data type. Removed the readMaybeEC+function. Reduced code duplication. Switched the way of counting -- moved all to one natural base+of 1 and more.++## 0.6.0.0 -- 2023-05-22 ++* Sixth version. Added new functions to the Phladiprelio.Constraints module for negated constraints. +Added some boolean algebra interpeter for constraints to Phladiprelio.ConstraintsEncoded module. +Added README.md file and devotion of the project to Foundation Gastrostars. ++## 0.6.1.0 -- 2023-05-23++* Sixth version revised A. Added new function filterGeneralConv to Phladiprelio.ConstraintsEncoded +module. Added also validOrdStr to the export list in the module. Some minor documentation+improvements. ++## 0.6.1.1 -- 2023-05-23++* Sixth version revised B. Some minor code improvements.++## 0.6.2.0 -- 2023-05-25++* 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.++## 0.7.0.1 -- 2023-05-31++* Seventh version revised A. Some minor documentation improvements.++## 0.7.1.0 -- 2023-06-01++* Seventh version revised B. Fixed some issues with incorrect False validation for algebraic constraints+handling that lead to no constraints at all for applications and in the oneChange function with +incorrect foldr function definition. Now the algebraic constraints functionality should work better +(hopefully, as expected).++## 0.7.2.0 -- 2023-06-02++* Seventh version revised C. Fixed issue with the shadowing of the variable in the lambda function+in the oneChange function definition that leads to incorrect behaviour of the parentheses handling.+Some minor documentation and code improvements.++## 0.7.3.0 -- 2023-06-06++* Seventh version revised D. Added new constraint type U for five elements. Switched to bit+ algorithms in some functions (mostly for testing and more readable code). ++## 0.8.0.0 -- 2024-01-27++* Eighth version. Updated the dependencies and switched to monoid-insertleft instead of subG. Added specializing and inlining for some functions to improve performance. Some documentation improvements.+
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2020 OleksandrZhabenko+Copyright (c) 2020-2024 Oleksandr Zhabenko Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
− Languages/UniquenessPeriods/Array/Constraints.hs
@@ -1,106 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-}---- |--- Module : Languages.UniquenessPeriods.Array.Constraints--- Copyright : (c) OleksandrZhabenko 2020-2022--- License : MIT--- Stability : Experimental--- Maintainer : olexandr543@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 and the 'Int'--- arguments must be in the range [0..n] though these inner constraints are--- not checked. It is up to user to check them.--- Uses arrays instead of vectors.--{-# LANGUAGE BangPatterns, FlexibleContexts #-}--module Languages.UniquenessPeriods.Array.Constraints (- -- * Basic predicate- unsafeOrderIJ- -- * Functions to work with permutations with basic constraints ('Array'-based)- , filterOrderIJ- , unsafeTriples- , unsafeQuadruples- -- ** With multiple elements specified- , unsafeSeveralA- , unsafeSeveralB- -- ** With fixed points- , fixedPointsG- , fixedPointsS-) where--import Data.Maybe (fromJust)-import Data.SubG (InsertLeft(..),filterG)-import GHC.Arr-import Data.Foldable (foldl')---- | Being given the data satisfying the constraints in the module header checks whether in the 'Array' the first argument stands before the second one.-unsafeOrderIJ :: Int -> Int -> Array Int Int -> Bool-unsafeOrderIJ i j = (\(_,_,r) -> if r == 0 then True else False) . foldl' helpG (i,j,0)--helpG (t,u,n) z- | z == t = (t,u,1)- | z == u =- case n of- 0 -> (t,u,2)- _ -> (t,u,n - 1)- | otherwise = (t,u,n)-{-# INLINE helpG #-}---- | 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 i j = filterG (unsafeOrderIJ i j)---- | 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] without duplication if the--- arguments are the indeces of the duplicated words or their concatenated combinations in the corresponding line.--- The first three arguments--- are 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 (\v -> unsafeOrderIJ i j v && unsafeOrderIJ j k v)---- | 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] without duplication if the--- arguments are the indeces of the duplicated words or their concatenated combinations in the corresponding line.--- The first four arguments--- are 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 (\v -> unsafeOrderIJ i j v && unsafeOrderIJ j k v && unsafeOrderIJ k l v)---- | 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] 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]. 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 x = filterG (g i0 arr) x- where g !i0 !arr1 arr2 = all (\k -> unsafeOrderIJ i0 k arr2) arr1---- | 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] 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]. 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 x = filterG (g i0 arr) x- where g !i0 !arr1 arr2 = all (\k -> unsafeOrderIJ k i0 arr2) arr1-------------------------------------------------------------------------------------- | 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 xs = filterG (f arr) xs- where f arr1 arr2 = all (\(k,j) -> unsafeAt arr2 k == j) arr1---- | 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 xs = filterG (f arr) xs- where f arr1 arr2 = all (\k -> unsafeAt arr2 k == k) arr1-
− Languages/UniquenessPeriods/Array/Constraints/Encoded.hs
@@ -1,192 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-}---- |--- Module : Languages.UniquenessPeriods.Array.Constraints.Encoded--- Copyright : (c) OleksandrZhabenko 2020-2022--- License : MIT--- Stability : Experimental--- Maintainer : olexandr543@yahoo.com------ Provides a way to encode the needed constraint with possibly less symbols.--- Uses arrays instead of vectors.--{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}--module Languages.UniquenessPeriods.Array.Constraints.Encoded (- -- * Data types- EncodedContraints(..)- , EncodedCnstrs- -- * Functions to work with them- -- ** Read functions- , readMaybeEC- , readMaybeECG- -- ** Process-encoding functions- , decodeConstraint1- , decodeLConstraints- -- ** Modifiers and getters- , getIEl- , setIEl- -- ** Predicates- , isE- , isP- , isF- , isQ- , isT- , isSA- , isSB-) where--import Data.Monoid (mappend)-import Text.Read (readMaybe)-import Data.Maybe-import GHC.Arr-import Languages.UniquenessPeriods.Array.Constraints-import Data.SubG (InsertLeft(..))--data EncodedContraints a b = E a | 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 deriving (Eq, Ord)---- | 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' than more restricted--- but safer 'readMaybeECG'. It is up to user to check whether the parameters are in the correct form, the function does--- not do the full checking. For phonetic-languages applications, it is better to use 'readMaybeECG' function instead.-readMaybeEC :: Int -> String -> Maybe EncodedCnstrs-readMaybeEC n xs- | null xs = Nothing- | n >=0 && n <= 9 =- let h = take 1 xs- ts = filter (\x -> x >= '0' && [x] <= show n) . drop 1 $ xs in- case h of- "E" -> Just (E (fromMaybe 0 (readMaybe (take 1 . tail $ xs)::Maybe Int)))- "F" -> let (y,z) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)) in- case (y,z) of- (Nothing,_) -> Nothing- (_,Nothing) -> Nothing- ~(Just x1, Just x2) -> Just (F undefined x1 x2)- "T" -> let (y,z,u) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)::Maybe Int, readMaybe (take 1 . drop 2 $ ts)::Maybe Int) in- case (y,z,u) of- (Nothing,_,_) -> Nothing- (_,Nothing,_) -> Nothing- (_,_,Nothing) -> Nothing- ~(Just x1, Just x2, Just x3) -> Just (T undefined x1 x2 x3)- "A" -> let y = readMaybe (take 1 ts)::Maybe Int in- if isJust y then- let y0 = fromJust y- zs = filter (/= y0) . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in- case zs of- [] -> Nothing- ~x2 -> Just (SA undefined y0 (listArray (0,length x2 - 1) x2))- else Nothing- "B" -> let y = readMaybe (take 1 ts)::Maybe Int in- if isJust y then- let y0 = fromJust y- zs = filter (/= y0) . catMaybes . map (\t -> readMaybe [t]::Maybe Int) . drop 1 $ ts in- case zs of- [] -> Nothing- ~x2 -> Just (SB undefined y0 (listArray (0,length x2 - 1) x2))- else Nothing- "Q" -> let (y,z,u,w) = (readMaybe (take 1 ts)::Maybe Int, readMaybe (take 1 . drop 1 $ ts)::Maybe Int, readMaybe (take 1 . drop 2 $ ts)::Maybe Int,- readMaybe (take 1 . drop 3 $ ts)::Maybe Int) in- case (y,z,u,w) of- (Nothing,_,_,_) -> Nothing- (_,Nothing,_,_) -> Nothing- (_,_,Nothing,_) -> Nothing- (_,_,_,Nothing) -> Nothing- ~(Just x1, Just x2, Just x3, Just x4) -> Just (Q undefined x1 x2 x3 x4)- "P" -> if null ts then Just (E 0) else let l = length ts in Just . P n . listArray (0,l-1) . map (\x -> case (fromJust (readMaybe [x]::Maybe Int)) of {0 -> 9; n -> n - 1}) $ ts- _ -> Nothing- | otherwise = Nothing---- | Is used inside 'readMaybeECG' to remove the 'undefined' inside the 'EncodedCnstrs'.-setWordsN :: Int -> Maybe EncodedCnstrs -> Maybe EncodedCnstrs-setWordsN _ Nothing = Nothing-setWordsN _ (Just (E x)) = Just (E x)-setWordsN n (Just (P _ v)) = Just (P n v)-setWordsN n (Just (T _ i j k)) = Just (T n i j k)-setWordsN n (Just (Q _ i j k l)) = Just (Q n i j k l)-setWordsN n (Just (SA _ i v)) = Just (SA n i v)-setWordsN n (Just (SB _ i v)) = Just (SB n i v)-setWordsN n (Just (F _ i j)) = Just (F n i j)---- | A safer variant of the 'readMaybeEC' more suitable for applications, e. g. for phonetic-languages series of packages.-readMaybeECG :: Int -> String -> Maybe EncodedCnstrs-readMaybeECG n xs- | n <= 9 && n >=0 = setWordsN n . readMaybeEC n $ xs- | otherwise = Nothing--type EncodedCnstrs = EncodedContraints 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] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. Besides,--- @n@ is (probably must be) not greater than 6.-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-decodeConstraint1 (T _ i j k) = unsafeTriples i j k-decodeConstraint1 (SA _ i v) = unsafeSeveralA i v-decodeConstraint1 (SB _ i v) = unsafeSeveralB i v-decodeConstraint1 (F _ i j) = filterOrderIJ i j---- | 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] where @n@ corresponds to the maximum element in the permutation 'Array' 'Int' 'Int'. Besides,--- @n@ is (probably must be) not greater than 6.-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--isE :: EncodedCnstrs -> Bool-isE (E _) = True-isE _ = False--isP :: EncodedCnstrs -> Bool-isP (P _ _) = True-isP _ = False--isF :: EncodedCnstrs -> Bool-isF (F _ _ _) = True-isF _ = False--isT :: EncodedCnstrs -> Bool-isT (T _ _ _ _) = True-isT _ = False--isQ :: EncodedCnstrs -> Bool-isQ (Q _ _ _ _ _) = True-isQ _ = False--isSA :: EncodedCnstrs -> Bool-isSA (SA _ _ _) = True-isSA _ = False--isSB :: EncodedCnstrs -> Bool-isSB (SB _ _ _) = True-isSB _ = False--{-| Works only with the correctly defined argument though it is not checked. Use with this caution.--}-getIEl :: EncodedCnstrs -> Int-getIEl (E i) = i-getIEl (P _ arr) = unsafeAt arr 0-getIEl (Q _ i _ _ _) = i-getIEl (T _ i _ _) = i-getIEl (SA _ i _) = i-getIEl (SB _ i _) = i-getIEl (F _ i _) = i--{-| Works only with the correctly defined arguments though it is not checked. Use with this caution.--}-setIEl :: Int -> EncodedCnstrs -> EncodedCnstrs-setIEl i (E _) = E 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-setIEl i (SB n _ v) = SB n i v-setIEl i (F n _ j) = F n i j
+ Phladiprelio/Constraints.hs view
@@ -0,0 +1,363 @@+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module : Pladiprelio.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 Phladiprelio.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+) where++import GHC.Base hiding (foldr)+import GHC.Num (Num, (-),(+))+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)++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+{-# 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+{-# 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+{-# 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+{-# INLINE f5 #-}+{-# 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 = (if bool then setBit else clearBit)+{-# INLINE bitChange #-}++-- | Being given the data satisfying the constraints in the module header checks whether in the 'Array' the first argument stands before the second one.+unsafeOrderIJ :: Int -> Int -> Array Int Int -> Bool+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)+{-# 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)+{-# INLINE helpG2 #-}+{-# 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)+{-# 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)+{-# 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 i j = filterG (unsafeOrderIJ i j)+{-# INLINE filterOrderIJ #-}+{-# 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 i j d = filterG (unsafeSignDistanceIJ i j d)+{-# INLINE filterSignDistanceIJ #-}+{-# 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 i j d = filterG (unsafeUnsignDistanceIJ i j d)+{-# INLINE filterUnsignDistanceIJ #-}+{-# 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 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] #-}++-- | 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 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] #-}++-- | 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 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] #-}++-- | 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] #-}++-- | 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] #-}++-- | 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] #-}++-- | 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] #-}++-- | 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] #-}++--------------------------------------------------------------------------------++-- | 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] #-}++-- | 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] #-}++------------------------------------------++isSignDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+isSignDistIJK3 i j k d1 d2 arr = unsafeSignDistanceIJ i j d1 arr && unsafeSignDistanceIJ j k d2 arr+{-# INLINE isSignDistIJK3 #-}++isUnsignDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+isUnsignDistIJK3 i j k d1 d2 arr = unsafeUnsignDistanceIJ i j d1 arr && unsafeUnsignDistanceIJ j k d2 arr+{-# INLINE isUnsignDistIJK3 #-}++isMixedDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+isMixedDistIJK3 i j k d1 d2 arr = unsafeSignDistanceIJ i j d1 arr && unsafeUnsignDistanceIJ j k d2 arr+{-# INLINE isMixedDistIJK3 #-}++isTripleOrdered :: Int -> Int -> Int -> Array Int Int -> Bool+isTripleOrdered i j k = (== 7) . f3 i j k+{-# INLINE isTripleOrdered #-}++isQuadrupleOrdered :: Int -> Int -> Int -> Int -> Array Int Int -> Bool+isQuadrupleOrdered i j k l = (== 15) . f4 i j k l+{-# INLINE isQuadrupleOrdered #-}++isQuintupleOrdered :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+isQuintupleOrdered i j k l m = (== 31) . f5 i j k l m+{-# INLINE isQuintupleOrdered #-}++isSeveralAOrdered :: Int -> Array Int Int -> Array Int Int -> Bool+isSeveralAOrdered !i0 !arr1 arr2 = all (\k -> unsafeOrderIJ i0 k arr2) arr1+{-# INLINE isSeveralAOrdered #-}++isSeveralBOrdered :: Int -> Array Int Int -> Array Int Int -> Bool+isSeveralBOrdered !i0 !arr1 arr2 = all (\k -> unsafeOrderIJ k i0 arr2) arr1+{-# INLINE isSeveralBOrdered #-}++isFixedPointTup :: Array Int (Int, Int) -> Array Int Int -> Bool+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 #-}++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 #-}++notUnsignDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+notUnsignDistIJK3 i j k d1 d2 = not . isUnsignDistIJK3 i j k d1 d2+{-# INLINE notUnsignDistIJK3 #-}++notMixedDistIJK3 :: Int -> Int -> Int -> Int -> Int -> Array Int Int -> Bool+notMixedDistIJK3 i j k d1 d2 arr = unsafeSignDistanceIJ j i d1 arr || not (unsafeUnsignDistanceIJ j k d2 arr)+{-# INLINE notMixedDistIJK3 #-}++notTripleOrdered :: Int -> Int -> Int -> Array Int Int -> Bool+notTripleOrdered i j k = (/= 7) . f3 i j k+{-# INLINE notTripleOrdered #-}++notQuadrupleOrdered :: Int -> Int -> Int -> Int -> Array Int Int -> Bool+notQuadrupleOrdered i j k l = (/= 15) . f4 i j k l+{-# INLINE notQuadrupleOrdered #-}++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 #-}++notSeveralAOrdered :: Int -> Array Int Int -> Array Int Int -> Bool+notSeveralAOrdered !i0 !arr1 = not . isSeveralAOrdered i0 arr1+{-# INLINE notSeveralAOrdered #-}++notSeveralBOrdered :: Int -> Array Int Int -> Array Int Int -> Bool+notSeveralBOrdered !i0 !arr1 = not . isSeveralBOrdered i0 arr1+{-# INLINE notSeveralBOrdered #-}++notFixedPointTup :: Array Int (Int, Int) -> Array Int Int -> Bool+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 #-}+
+ Phladiprelio/ConstraintsEncoded.hs view
@@ -0,0 +1,456 @@+{-# OPTIONS_HADDOCK show-extensions #-}+++++-- |+-- Module : Phladiprelio.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 #-}++module Phladiprelio.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+) where++import GHC.Base+import GHC.List+import GHC.Num ((+),(-),abs)+import Text.Show (show, Show(..))+import Text.Read (readMaybe)+import Data.Maybe+import Data.List (nub, words, groupBy)+import GHC.Arr+import Data.Char (isDigit, isLetter)+import Phladiprelio.Constraints+import Data.InsertLeft (InsertLeft(..), splitAtEndG)+import Data.Tuple (fst)++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)++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++-- | 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 +{-# INLINE validOrdStr #-}++stage1Parsing :: String -> [String]+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 _ _ _ = []++splitNoParenAtDisjunction :: [String] -> [[String]]+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 _ = True++noParenString :: [String] -> Bool+noParenString = or . map noParenString0 . splitNoParenAtDisjunction+{-# INLINE noParenString #-}++oneStep :: Int -> Array Int Int -> [String] -> Bool+oneStep m arr = noParenString . words . convertToBools m arr+{-# 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+ _ -> []++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+{-# 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 = []+{-# 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.+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+++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)+decodeConstraint1 E = id+decodeConstraint1 (P _ v) = fixedPointsS v+decodeConstraint1 (Q _ i j k l) = unsafeQuadruples i j k l+decodeConstraint1 (T _ i j k) = unsafeTriples i j k+decodeConstraint1 (SA _ i v) = unsafeSeveralA i v+decodeConstraint1 (SB _ i v) = unsafeSeveralB i v+decodeConstraint1 (F _ i j) = filterOrderIJ i j+decodeConstraint1 (V _ i j) = filterSignDistanceIJ i j (abs $ j - i)+decodeConstraint1 (W _ i j) = filterUnsignDistanceIJ i j (abs $ j - i)+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)+decodeConstraint1 (U _ i j k l m) = unsafeQuintuples i j k l m+{-# 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+decodeLConstraints _ = id+{-# 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 ++isE :: EncodedCnstrs -> Bool+isE E = True+isE _ = False++isP :: EncodedCnstrs -> Bool+isP (P _ _) = True+isP _ = False++isF :: EncodedCnstrs -> Bool+isF (F _ _ _) = True+isF _ = False++isT :: EncodedCnstrs -> Bool+isT (T _ _ _ _) = True+isT _ = False++isQ :: EncodedCnstrs -> Bool+isQ (Q _ _ _ _ _) = True+isQ _ = False++isSA :: EncodedCnstrs -> Bool+isSA (SA _ _ _) = True+isSA _ = False++isSB :: EncodedCnstrs -> Bool+isSB (SB _ _ _) = True+isSB _ = False++isV :: EncodedCnstrs -> Bool+isV (V _ _ _) = True+isV _ = False++isW :: EncodedCnstrs -> Bool+isW (W _ _ _) = True+isW _ = False++isH :: EncodedCnstrs -> Bool+isH (H _ _ _ _) = True+isH _ = False++isR :: EncodedCnstrs -> Bool+isR (R _ _ _ _) = True+isR _ = False++isM :: EncodedCnstrs -> Bool+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++isU :: EncodedCnstrs -> Bool+isU (U _ _ _ _ _ _) = True+isU _ = False+++{-| 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+getIEl (Q _ i _ _ _) = i+getIEl (T _ i _ _) = i+getIEl (SA _ i _) = i+getIEl (SB _ i _) = i+getIEl (F _ i _) = i+getIEl (V _ i _) = i+getIEl (W _ i _) = i+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+getIEl (U _ i _ _ _ _) = i++{-| 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 (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+setIEl i (SB n _ v) = SB n i v+setIEl i (F n _ j) = F n i j+setIEl i (V n _ j) = V n i j+setIEl i (W n _ j) = W n i j+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 _ (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+setIEl i (U n _ j k l m) = U n i j k l m+
+ README.md view
@@ -0,0 +1,22 @@+ Devotion+ ========++Since the 0.6.0.0 version, the author would like to devote this project to support the [Foundation Gastrostars](https://gastrostars.nl).++The foundation founder is [Emma Kok](https://www.emmakok.nl).++On the 06/01/2024 there is Sophie's Kok, a sister of Emma Kok, 19th Birthday (she is 18). Therefore, the version 0.5.0.0 is additionally devoted also to her. On the 22/01/2023 there is Day of Unity of Ukraine, and on the 23/01/2024 the Orthodox Christians have memory of St. Paulinus of Nola.++Besides, you can support Ukraine and Ukrainian people. ++All support is welcome, including donations for the needs of the Ukrainian army, IDPs and refugees.++If you would like to share some financial support with Gastrostars, please, contact the mentioned foundation+using the URL:++[Contact Foundation GASTROSTARS](https://gastrostars.nl/hou-mij-op-de-hoogte)++or ++[Donation Page](https://gastrostars.nl/doneren)+
phonetic-languages-constraints-array.cabal view
@@ -2,24 +2,25 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/ name: phonetic-languages-constraints-array-version: 0.1.2.0+version: 0.8.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+bug-reports: https://github.com/Oleksandr-Zhabenko/phonetic-languages-constraints-array/issues license: MIT license-file: LICENSE author: OleksandrZhabenko-maintainer: olexandr543@yahoo.com+maintainer: oleksandr.zhabenko@yahoo.com copyright: Oleksandr Zhabenko category: Language, Math build-type: Simple-extra-source-files: CHANGELOG.md+extra-source-files: CHANGELOG.md, README.md cabal-version: >=1.10 library- exposed-modules: Languages.UniquenessPeriods.Array.Constraints, Languages.UniquenessPeriods.Array.Constraints.Encoded+ exposed-modules: Phladiprelio.Constraints, Phladiprelio.ConstraintsEncoded -- other-modules:- other-extensions: BangPatterns, FlexibleInstances, FlexibleContexts- build-depends: base >=4.8 && <5, subG == 0.5.3.0+ other-extensions: BangPatterns, FlexibleInstances, FlexibleContexts, NoImplicitPrelude+ build-depends: base >=4.13 && <5, monoid-insertleft == 0.1.0.1 -- hs-source-dirs: default-language: Haskell2010