bv-little 0.1.2 → 1.0.0
raw patch · 11 files changed
+1630/−172 lines, 11 filesdep +keysdep +mono-traversable-keysdep +smallcheckdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: keys, mono-traversable-keys, smallcheck, tasty-smallcheck, text-show
Dependency ranges changed: base
API changes (from Hackage documentation)
- Data.BitVector.LittleEndian: instance Data.Semigroup.Semigroup Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoAdjustable Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoFoldableWithKey Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoIndexable Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoKeyed Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoLookup Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoTraversableWithKey Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoZip Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance Data.MonoTraversable.Keys.MonoZipWithKey Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance GHC.Base.Semigroup Data.BitVector.LittleEndian.BitVector
+ Data.BitVector.LittleEndian: instance TextShow.Classes.TextShow Data.BitVector.LittleEndian.BitVector
Files
- Setup.hs +0/−2
- bench/Benchmarks.hs +51/−0
- bv-little.cabal +26/−6
- changelog.md +34/−1
- src/Data/BitVector/LittleEndian.hs +511/−53
- stack.yaml +4/−1
- test/Data/BitVector/Visual.hs +166/−0
- test/TestSuite.hs +399/−109
- util/Operator/Binary/Comparison.hs +87/−0
- util/Operator/Binary/Logical.hs +231/−0
- util/Operator/Unary/Logical.hs +121/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
bench/Benchmarks.hs view
@@ -8,12 +8,16 @@ import Data.BitVector.LittleEndian import Data.List (nubBy) import Data.Hashable+import Data.MonoTraversable import Data.Semigroup+import Operator.Binary.Logical+import Operator.Unary.Logical main :: IO () main = defaultMain [ benchmarks ] + benchmarks :: Benchmark benchmarks = bgroup "BitVector" [ toBitsBench@@ -29,6 +33,7 @@ , finiteBitsBench , hashableBench , semigroupBench+ , monoFoldableBench ] @@ -177,6 +182,16 @@ ] +monoFoldableBench :: Benchmark+monoFoldableBench = bgroup "MonoFoldable"+ [ fold1Benchmark "ofoldr1Ex" ofoldr1Ex+ , fold1Benchmark "ofoldl1Ex'" ofoldl1Ex'+ , mapBenchmark "omap" omap+ , queryBenchmark "oall" oall + , queryBenchmark "oany" oany + ]++ constantNumberTimeBenchmark :: (NFData a, NFData b) => String -> (Integer -> a) -> (Integer -> a -> b) -> Benchmark constantNumberTimeBenchmark label f g = bgroup label $ generateBenchmark <$> magicNumbers where@@ -221,6 +236,42 @@ (c, d) <- nubBy (\x y -> snd x == snd y) [("first", 0), ("middle", bitCount `div` 2), ("last", bitCount - 1)] let e = force (a,b,c,d) [e]+++fold1Benchmark :: String -> ((Bool -> Bool -> Bool) -> BitVector -> Bool) -> Benchmark+fold1Benchmark label fold1Fun = bgroup label $ generateBenchmark <$> combinations+ where+ generateBenchmark (intLabel, intValue, lOp) = bench message $ nf id target+ where+ message = unwords ["fold1", getBinaryLogicalSymbol lOp, intLabel]+ !op = getBinaryLogicalOperator lOp+ !bv = bvGen intValue+ target = fold1Fun op bv+ combinations = [ (a,b, op) | (a,b) <- magicNumbers, op <- [minBound .. maxBound] ]+++mapBenchmark :: String -> ((Bool -> Bool) -> BitVector -> BitVector) -> Benchmark+mapBenchmark label mapFun = bgroup label $ generateBenchmark <$> combinations+ where+ generateBenchmark (intLabel, intValue, lOp) = bench message $ nf id target+ where+ message = unwords ["map", getUnaryLogicalSymbol lOp, intLabel]+ !op = getUnaryLogicalOperator lOp+ !bv = bvGen intValue+ target = mapFun op bv+ combinations = [ (a,b, op) | (a,b) <- magicNumbers, op <- [minBound .. maxBound] ]+++queryBenchmark :: String -> ((Bool -> Bool) -> BitVector -> Bool) -> Benchmark+queryBenchmark label mapFun = bgroup label $ generateBenchmark <$> combinations+ where+ generateBenchmark (intLabel, intValue, lOp) = bench message $ nf id target+ where+ message = unwords ["query", getUnaryLogicalSymbol lOp, intLabel]+ !op = getUnaryLogicalOperator lOp+ !bv = bvGen intValue+ target = mapFun op bv+ combinations = [ (a,b, op) | (a,b) <- magicNumbers, op <- [minBound .. maxBound] ] bvGen :: Integer -> BitVector
bv-little.cabal view
@@ -1,5 +1,5 @@ name: bv-little-version: 0.1.2+version: 1.0.0 synopsis: Efficient little-endian bit vector library category: Data, Bit Vectors license: BSD3@@ -20,8 +20,8 @@ build-type: Simple cabal-version: >= 1.22 -tested-with: GHC == 8.6.1- GHC == 8.4.3+tested-with: GHC == 8.6.2+ GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3@@ -37,13 +37,16 @@ library - build-depends: base >= 4.5.1 && < 4.13+ build-depends: base >= 4.5.1 && < 5 , deepseq , hashable , integer-gmp+ , keys , mono-traversable+ , mono-traversable-keys , primitive , QuickCheck+ , text-show if !impl(ghc >= 8.0) @@ -105,10 +108,14 @@ , deepseq , hashable , mono-traversable+ , mono-traversable-keys , QuickCheck+ , smallcheck >= 1.1.5 , tasty , tasty-hunit , tasty-quickcheck+ , tasty-smallcheck+ , text-show if !impl(ghc >= 8.0) @@ -117,8 +124,13 @@ default-language: Haskell2010 - hs-source-dirs: test+ hs-source-dirs: test, util + other-modules: Data.BitVector.Visual+ Operator.Binary.Comparison+ Operator.Binary.Logical+ Operator.Unary.Logical+ benchmark benchmark-suite @@ -131,6 +143,9 @@ , criterion , deepseq , hashable+ , mono-traversable+ , QuickCheck+ , smallcheck >= 1.1.5 if !impl(ghc >= 8.0) @@ -155,4 +170,9 @@ -- Turn off type default warnings -fno-warn-type-defaults - hs-source-dirs: bench+ hs-source-dirs: bench, util++ other-modules: Operator.Binary.Comparison+ Operator.Binary.Logical+ Operator.Unary.Logical+
changelog.md view
@@ -1,5 +1,37 @@-### [v0.1.2][1]+### Unreleased Changes + * None+++### [v1.0.0][3]++ * Added explicit recursion to monomorphic folds to improve time and space performance++ * Added the following instances:+ * `MonoAdjustable`+ * `MonoFoldableWithKey`+ * `MonoIndexable`+ * `MonoKeyed`+ * `MonoLookup`+ * `MonoTraversableWithKey`+ * `MonoZip`+ * `MonoZipWithKey`+ * `TextShow`++ * Updated the following functions to be constant time:+ * `omap`+ * `olength64`+ * `oall`+ * `oany`+ * `ofoldr1Ex`+ * `ofoldl1Ex`+ * `oelem`+ * `onotElem`+ * `ozipWith`+++### [v0.1.2][2]+ * Updating to base bounds for GHC 8.6.1 @@ -32,3 +64,4 @@ [0]: https://github.com/recursion-ninja/bv-little/tree/v0.1.0 [1]: https://github.com/recursion-ninja/bv-little/tree/v0.1.1 [2]: https://github.com/recursion-ninja/bv-little/tree/v0.1.2+[3]: https://github.com/recursion-ninja/bv-little/tree/v1.0.0
src/Data/BitVector/LittleEndian.hs view
@@ -22,8 +22,15 @@ -- * 'FiniteBits' -- * 'Semigroup' -- * 'Monoid'+-- * 'MonoAdjustable'+-- * 'MonoIndexable'+-- * 'MonoKeyed'+-- * 'MonoLookup' -- * 'MonoFoldable'+-- * 'MonoFoldableWithKey' -- * 'MonoTraversable'+-- * 'MonoTraversableWithKey'+-- * 'MonoZipWithKey' -- -- For an implementation of bit vectors which are isomorphic to a @[Bool]@ with the /most/ -- significant bit at the head of the list and the /least/ significant bit at the@@ -36,8 +43,13 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, MagicHash #-}-{-# LANGUAGE Trustworthy, TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-} module Data.BitVector.LittleEndian ( BitVector()@@ -60,9 +72,12 @@ import Data.Data import Data.Foldable import Data.Hashable-import Data.List.NonEmpty (NonEmpty(..))-import Data.Monoid ()+import Data.Key+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Monoid () import Data.MonoTraversable+import Data.MonoTraversable.Keys import Data.Ord import Data.Primitive.ByteArray import Data.Semigroup@@ -72,7 +87,8 @@ import GHC.Integer.GMP.Internals import GHC.Integer.Logarithms import GHC.Natural-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat, variant)+import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), suchThat, variant)+import TextShow (TextShow(showb)) -- |@@ -88,12 +104,17 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 type instance Element BitVector = Bool -- |--- /Since: 0.1.0.0/+-- @since 1.0.0+type instance MonoKey BitVector = Word+++-- |+-- @since 0.1.0 instance Arbitrary BitVector where arbitrary = do@@ -104,7 +125,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Bits BitVector where {-# INLINE (.&.) #-}@@ -117,7 +138,7 @@ (BV w1 a) `xor` (BV w2 b) = BV (max w1 w2) $ a `xor` b {-# INLINE complement #-}- complement (BV w n) = BV w $ (shiftL 1 (fromEnum w)) - 1 - n+ complement (BV w n) = BV w $ shiftL 1 (fromEnum w) - 1 - n {-# INLINE zeroBits #-} zeroBits = BV 0 0@@ -206,14 +227,14 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance CoArbitrary BitVector where coarbitrary bv = variant (dimension bv) -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Eq BitVector where {-# INLINE (==) #-}@@ -221,7 +242,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance FiniteBits BitVector where {-# INLINE finiteBitSize #-}@@ -261,7 +282,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Hashable BitVector where hash (BV w n) = fromEnum w `hashWithSalt` hash n@@ -270,7 +291,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Monoid BitVector where {-# INLINE mappend #-}@@ -287,61 +308,477 @@ -- |--- /Since: 0.1.0.0/+-- @since 1.0.0+instance MonoAdjustable BitVector where++ -- | /O(1)/+ {-# INLINE oadjust #-}+ oadjust f k bv@(BV w n)+ | k >= w = bv+ | v == b = bv+ | otherwise = bv `complementBit` i+ where+ !i = fromEnum k+ !v = n `testBit` i+ !b = f v++ -- | /O(1)/+ {-# INLINE oreplace #-}+ oreplace k v bv@(BV w _)+ | k >= w = bv+ | v = bv `setBit` i+ | otherwise = bv `clearBit` i+ where+ !i = fromEnum k+++-- |+-- @since 0.1.0 instance MonoFoldable BitVector where {-# INLINE ofoldMap #-}- ofoldMap f = mconcat . fmap f. toBits-+ ofoldMap f (BV w n) = go m+ where+ !m = fromEnum w+ go 0 = mempty+ go !c = let !i = m - c+ !j = c - 1+ !b = n `testBit` i+ in f b `mappend` go j+ {-# INLINE ofoldr #-}- ofoldr f e = foldr f e . toBits+ ofoldr f e (BV w n) =+ let !m = fromEnum w+ go 0 acc = acc+ go !c acc = let !i = m - c+ !j = c - 1+ !b = n `testBit` i+ in f b $ go j acc+ in go m e {-# INLINE ofoldl' #-}- ofoldl' f e = foldl' f e . toBits+ ofoldl' f e (BV w n) = go m e+ where+ !m = fromEnum w+ go 0 acc = acc+ go !c acc = let !i = m - c+ !j = c - 1+ !b = n `testBit` i+ !a = f acc b+ in go j a - {-# INLINE ofoldr1Ex #-}- ofoldr1Ex f = foldr1 f . toBits+ {-# INLINE otoList #-}+ otoList = toBits - {-# INLINE ofoldl1Ex' #-}- ofoldl1Ex' f = foldl1 f . toBits+ -- | /O(1)/+ {-# INLINE oall #-}+ oall _ (BV 0 _) = True+ oall f (BV w n) =+ case (f False, f True) of+ (False, False) -> False+ (True , True ) -> True+ (False, True ) -> n == bit (fromEnum w) - 1+ (True , False) -> n == 0 + -- | /O(1)/+ {-# INLINE oany #-}+ oany _ (BV 0 _) = False+ oany f (BV w n) =+ case (f False, f True) of+ (False, False) -> False+ (True , True ) -> True+ (False, True ) -> n > 0+ (True , False) -> n < bit (fromEnum w) - 1++ -- | /O(1)/ {-# INLINE onull #-} onull = (== 0) . dim + -- | /O(1)/ {-# INLINE olength #-} olength = fromEnum . dim + -- | /O(1)/+ {-# INLINE olength64 #-}+ olength64 = toEnum . olength + {-# INLINE otraverse_ #-}+ otraverse_ f (BV w n) = go (fromEnum w) + where+ go 0 = pure ()+ go !c = let !j = c - 1+ !a = f (n `testBit` j)+ in a *> go j+++ {-# INLINE ofoldlM #-}+ ofoldlM f e (BV w n) = go (fromEnum w) e+ where+ go 0 acc = pure acc+ go !c acc = let !j = c - 1+ !x = f acc (n `testBit` j)+ in x >>= go j+ + {-# INLINE ofoldMap1Ex #-}+ ofoldMap1Ex _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldMap1Ex on an empty BitVector!"+ ofoldMap1Ex f (BV w n) = go 0+ where+ !m = fromEnum w+ go !c+ | c >= m - 1 = f $ n `testBit` c+ | otherwise = let !j = c + 1+ !b = n `testBit` c+ in f b <> go j++ -- | /O(1)/+ {-# INLINE ofoldr1Ex #-}+ ofoldr1Ex _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldr1Ex on an empty BitVector!"+ ofoldr1Ex _ (BV 1 n) = n > 0+ ofoldr1Ex f bv@(BV w n) =+ -- See the following entry for explanation:+ -- https://en.wikipedia.org/wiki/Truth_table#Truth_table_for_all_binary_logical_operators+ --+ -- cases of f p q+ case (f True True, f True False, f False True, f False False) of+ -- Contradiction (Const False)+ (False, False, False, False) -> False+ -- Logical NOR+ (False, False, False, True ) -> let !lzs = toEnum $ countLeadingZeros bv+ in if (w - lzs) == 1 || n == 0+ then even lzs+ else odd lzs+ -- Converse non-implication+ -- Only True when of the form <0+1>+ (False, False, True , False) -> n == bit (fromEnum w - 1)+ -- NOT p+ (False, False, True , True ) -> not (n `testBit` 0)+ -- Logical non-implication+ -- Only True when the number of leading ones is even+ (False, True , False, False) -> let !los = countLeadingZeros $ complement bv+ in odd los+ -- NOT q+ (False, True , False, True ) -> let !v = n `testBit` (fromEnum w - 1)+ in if even w then not v else v+ -- Logical XOR+ (False, True , True , False) -> odd $ popCount n+ -- Logical NAND+ (False, True , True , True ) -> let !los = countLeadingZeros $ complement bv+ !x = bit (fromEnum w - 1) - 1+ !y = bit (fromEnum w ) - 1+ in if n == x || n == y+ then odd los+ else even los+ -- Logical AND+ (True , False, False, False) -> n == bit (fromEnum w) - 1+ -- Logical XNOR+ (True , False, False, True ) -> let !pc = popCount n+ in if even w+ then even pc+ else odd pc+ -- Const q+ (True , False, True , False) -> n `testBit` (fromEnum w - 1)+ -- Logical implication+ -- only False when of the form <1+0>+ (True , False, True , True ) -> let !i = fromEnum w - 1+ in n /= bit i - 1+ -- Const p+ (True , True , False, False) -> n `testBit` 0+ -- Converse implication+ (True , True , False, True ) -> even $ countLeadingZeros bv+ -- Logical OR+ (True , True , True , False) -> n > 0+ -- Constant True+ (True , True , True , True ) -> True++ -- | /O(n)/+ {-# INLINE ofoldl1Ex' #-}+ ofoldl1Ex' _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldl1Ex' on an empty BitVector!"+ ofoldl1Ex' _ (BV 1 n) = n > 0+ ofoldl1Ex' f bv@(BV w n) =+ -- See the following entry for explanation:+ -- https://en.wikipedia.org/wiki/Truth_table#Truth_table_for_all_binary_logical_operators+ --+ -- cases of f p q+ case (f True True, f True False, f False True, f False False) of+ -- Contradiction (Const False)+ (False, False, False, False) -> False+ -- Logical NOR+ (False, False, False, True ) -> let !tzs = toEnum $ countTrailingZeros bv+ in if (w - tzs) == 1 || n == 0+ then even tzs+ else odd tzs+ -- Converse non-implication+ (False, False, True , False) -> let !tzs = countTrailingZeros $ complement bv+ in odd tzs+ -- NOT p+ (False, False, True , True ) -> even w == even n+ -- Logical non-implication+ (False, True , False, False) -> n == 1+ -- NOT q+ (False, True , False, True ) -> not $ n `testBit` (fromEnum w - 1)+ -- Logical XOR+ (False, True , True , False) -> odd $ popCount n+ -- Logical NAND+ (False, True , True , True ) -> let !tos = countTrailingZeros $ complement bv+ !x = bit (fromEnum w) - 1+ !y = bit (fromEnum w) - 2+ in if n == x || n == y+ then odd tos+ else even tos+ -- Logical AND+ (True , False, False, False) -> n == bit (fromEnum w) - 1+ -- Logical XNOR+ (True , False, False, True ) -> let !pc = popCount n+ in if even w+ then even pc+ else odd pc+ -- Const q+ (True , False, True , False) -> n `testBit` (fromEnum w - 1)+ -- Logical implication+ (True , False, True , True ) -> even $ countTrailingZeros bv+ -- Const p+ (True , True , False, False) -> n `testBit` 0+ -- Converse implication+ -- only False when of the form <01+>+ (True , True , False, True ) -> n /= bit (fromEnum w) - 2+ -- Logical OR+ (True , True , True , False) -> n > 0+ -- Constant True+ (True , True , True , True ) -> True++ -- | /O(1)/+ {-# INLINE headEx #-}+ headEx (BV 0 _) = error "Call to Data.MonoFoldable.headEx on an empty BitVector!"+ headEx (BV _ n) = n `testBit` 0++ -- | /O(1)/+ {-# INLINE lastEx #-}+ lastEx (BV 0 _) = error "Call to Data.MonoFoldable.lastEx on an empty BitVector!"+ lastEx (BV w n) = n `testBit` (fromEnum w - 1)++ -- | /O(n)/+ {-# INLINE maximumByEx #-}+ maximumByEx _ (BV 0 _) = error "Call to Data.MonoFoldable.maximumByEx on an empty BitVector!"+ maximumByEx _ (BV 1 n) = n /= 0+ maximumByEx f bv = maximumBy f $ toBits bv++ -- | /O(n)/+ {-# INLINE minimumByEx #-}+ minimumByEx _ (BV 0 _) = error "Call to Data.MonoFoldable.minimumByEx on an empty BitVector!"+ minimumByEx _ (BV 1 n) = n /= 0+ minimumByEx f bv = minimumBy f $ toBits bv++ -- | /O(1)/+ {-# INLINE oelem #-}+ oelem _ (BV 0 _) = False+ oelem True (BV _ n) = n > 0+ oelem False (BV w n) = n < bit (fromEnum w) - 1++ -- | /O(1)/+ {-# INLINE onotElem #-}+ onotElem e = not . oelem e++ -- |--- /Since: 0.1.0.0/+-- @since 1.0.0+instance MonoFoldableWithKey BitVector where++ -- | /O(n)/+ {-# INLINE otoKeyedList #-}+ otoKeyedList (BV w n) = + let go 0 = []+ go !c = let !k = w - c+ !v = n `testBit` fromEnum k+ !i = c - 1+ in (k, v) : go i+ in go w++ -- | /O(n)/+ {-# INLINE ofoldMapWithKey #-}+ ofoldMapWithKey f (BV w n) =+ let go 0 = mempty+ go !c = let !k = w - c+ !v = n `testBit` fromEnum k+ !i = c - 1+ !m = f k v+ in m `mappend` go i+ in go w++ -- | /O(n)/+ {-# INLINE ofoldrWithKey #-}+ ofoldrWithKey f e (BV w n) =+ let go 0 acc = acc+ go !c acc = let !k = w - c+ !i = c - 1+ !b = n `testBit` fromEnum k+ in f k b $ go i acc+ in go w e++ -- | /O(n)/+ {-# INLINE ofoldlWithKey #-}+ ofoldlWithKey f e (BV w n) = go w e+ where+ go 0 acc = acc+ go !c acc = let !k = w - c+ !i = c - 1+ !b = n `testBit` fromEnum k+ !a = f acc k b+ in go i a+++-- |+-- @since 0.1.0 instance MonoFunctor BitVector where - omap f (BV w n) = BV w . go (fromEnum w) $ n `xor` n- -- NB: 'setBit' is a GMP function, faster than regular addition.+ -- | /O(1)/+ {-# INLINE omap #-}+ omap f bv@(BV w n) =+ case (f False, f True) of+ (False, False) -> BV w 0+ (True , True ) -> BV w $ bit (fromEnum w) - 1+ (False, True ) -> bv+ (True , False) -> let !allOnes = bit (fromEnum w) - 1+ in BV w $ n `xor` allOnes+++-- |+-- @since 1.0.0+instance MonoIndexable BitVector where++ -- | /O(1)/+ {-# INLINE oindex #-}+ oindex bv@(BV w _) i = fromMaybe errorMessage $ i `olookup` bv where- go 0 !acc = acc- go !i !acc = go i' acc'- where- i' = i - 1- acc'- | f (testBit n i') = acc `setBit` i'- | otherwise = acc+ errorMessage = error $ mconcat+ [ "Data.BitVector.LittleEndian.oindex: "+ , "The index "+ , show i+ , " was greater than or equal to the length of the bit vector "+ , show w+ ] +-- |+-- @since 1.0.0+instance MonoKeyed BitVector where + -- | /O(n)/+ {-# INLINE omapWithKey #-}+ omapWithKey f (BV w n) =+ let go 0 acc = acc+ go !c acc = let !k = w - c+ !i = fromEnum k+ !j = c - 1+ !b = n `testBit` i+ !a | f k b = acc `setBit` i+ | otherwise = acc+ in go j a+ in go w $ BV w 0++ -- |--- /Since: 0.1.0.0/+-- @since 1.0.0+instance MonoLookup BitVector where++ -- | /O(1)/+ {-# INLINE olookup #-}+ olookup k (BV w n)+ | k <= w = Nothing+ | otherwise = Just $ n `testBit` fromEnum k+++-- |+-- @since 0.1.0 instance MonoTraversable BitVector where + -- | /O(n)/ {-# INLINE otraverse #-} otraverse f = fmap fromBits . traverse f . toBits + -- | /O(n)/ {-# INLINE omapM #-} omapM = otraverse -- |--- /Since: 0.1.0.0/+-- @since 1.0.0+instance MonoTraversableWithKey BitVector where++ -- | /O(n)/+ {-# INLINE otraverseWithKey #-}+ otraverseWithKey f = fmap fromBits . traverseWithKey (f . toEnum) . toBits++ +-- |+-- @since 1.0.0+instance MonoZip BitVector where++ -- | /O(1)/+ {-# INLINE ozipWith #-}+ ozipWith f lhs@(BV w1 p) rhs@(BV w2 q) =+ let !w0 = min w1 w2+ !mask = bit (fromEnum w0) - 1+ bv = BV w0 . (mask .&.)+ not' = nat . complement+ -- See the following entry for explanation:+ -- https://en.wikipedia.org/wiki/Truth_table#Truth_table_for_all_binary_logical_operators+ --+ -- cases of f p q+ in case (f True True, f True False, f False True, f False False) of+ -- Contradiction (Const False)+ (False, False, False, False) -> bv 0+ -- Logical NOR+ (False, False, False, True ) -> bv $ not' lhs .&. not' rhs+ -- Converse non-implication+ (False, False, True , False) -> bv $ not' lhs .&. q+ -- NOT p+ (False, False, True , True ) -> bv $ not' lhs+ -- Logical non-implication+ (False, True , False, False) -> bv $ p .&. not' rhs+ -- NOT q+ (False, True , False, True ) -> bv $ not' rhs+ -- Logical XOR+ (False, True , True , False) -> bv $ p `xor` q+ -- Logical NAND+ (False, True , True , True ) -> bv $ not' lhs .|. not' rhs+ -- Logical AND+ (True , False, False, False) -> bv $ p .&. q+ -- Logical XNOR+ (True , False, False, True ) -> bv $ (p .&. q) .|. (not' lhs .&. not' rhs)+ -- Const q+ (True , False, True , False) -> bv q+ -- Logical implication+ (True , False, True , True ) -> bv $ not' lhs .|. q+ -- Const p+ (True , True , False, False) -> bv p+ -- Converse implication+ (True , True , False, True ) -> bv $ p .|. not' rhs+ -- Logical OR+ (True , True , True , False) -> bv $ p .|. q+ -- Constant True+ (True , True , True , True ) -> bv $ bit (fromEnum w0) - 1++ +-- |+-- @since 1.0.0+instance MonoZipWithKey BitVector where++ {-# INLINE ozipWithKey #-}+ ozipWithKey f (BV w1 n) (BV w2 m) =+ let w0 = min w1 w2+ go 0 _ = 0+ go c e = let !k = w0 - c+ !i = fromEnum k+ !j = c - 1+ !b = f k (n `testBit` i) (m `testBit` i)+ !a = e `shiftL` 1+ !v = if b then e else 0+ in v + go j a+ in BV w0 $ go w0 1+++-- |+-- @since 0.1.0 instance NFData BitVector where -- Already a strict data type,@@ -351,7 +788,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Ord BitVector where {-# INLINE compare #-}@@ -362,7 +799,7 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Semigroup BitVector where {-# INLINE (<>) #-}@@ -387,13 +824,20 @@ -- |--- /Since: 0.1.0.0/+-- @since 0.1.0 instance Show BitVector where show (BV w n) = mconcat [ "[", show w, "]", show n ] -- |+-- @since 1.0.0+instance TextShow BitVector where++ showb (BV w n) = mconcat [ "[", showb w, "]", showb n ]+++-- | -- Create a bit vector from a /little-endian/ list of bits. -- -- The following will hold:@@ -403,7 +847,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( n \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -416,7 +860,7 @@ where (!n, !k) = foldl' go (0, 0) bs go (!i, !v) b- | b = (i+1, setBit v i)+ | b = (i+1, v `setBit` i) | otherwise = (i+1, v) @@ -430,7 +874,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( n \right) \) ----- /Since: 0.1.0.0/+-- /Since:/ 0.1.0 -- -- ==== __Examples__ --@@ -438,7 +882,11 @@ -- [True, True, False, True] {-# INLINE toBits #-} toBits :: BitVector -> [Bool]-toBits (BV w n) = testBit n <$> [ 0 .. fromEnum w - 1 ]+toBits (BV w n) = go (fromEnum w) []+ where+ go 0 bs = bs+ go i bs = let !j = i - 1+ in go j $ n `testBit` j : bs -- |@@ -458,7 +906,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -470,7 +918,7 @@ -- -- >>> fromNumber 6 96 -- [6]32-{-# INLINE fromNumber #-}+{-# INLINE[1] fromNumber #-} fromNumber :: Integral v => Word -- ^ dimension of bit vector@@ -478,7 +926,7 @@ -> BitVector fromNumber !dimValue !intValue = BV dimValue . intToNat $ mask .&. v where- !v | signum int < 0 = negate $ (shiftL 1 intBits) - int+ !v | signum int < 0 = negate $ shiftL 1 intBits - int | otherwise = int !int = toInteger intValue@@ -486,12 +934,18 @@ !mask = 2 ^ dimValue - 1 +{-# RULES+"fromNumber/Natural" forall w (n :: Natural). fromNumber w n = BV w n+"fromNumber/Word" forall w (v :: Word ). fromNumber w v = BV w (wordToNatural v)+ #-}++ -- | -- Two's complement value of a bit vector. -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -517,7 +971,7 @@ toSignedNumber (BV w n) = fromInteger v where !i = toInteger n- !v | n `testBit` (fromEnum w - 1) = negate $ (shiftL 1 (fromEnum w)) - i+ !v | n `testBit` (fromEnum w - 1) = negate $ shiftL 1 (fromEnum w) - i | otherwise = i @@ -526,7 +980,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -547,11 +1001,16 @@ -- -- >>> toSignedNumber [4]15 -- 15-{-# INLINE toUnsignedNumber #-}+{-# INLINE[1] toUnsignedNumber #-} toUnsignedNumber :: Num a => BitVector -> a toUnsignedNumber = fromInteger . toInteger . nat +{-# RULES+"toUnsignedNumber/Natural" toUnsignedNumber = nat+ #-}++ -- | -- Get the dimension of a 'BitVector'. Preferable to 'finiteBitSize' as it -- returns a type which cannot represent a non-negative value and a 'BitVector'@@ -559,7 +1018,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -579,7 +1038,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -602,7 +1061,7 @@ -- -- /Time:/ \(\, \mathcal{O} \left( 1 \right) \) ----- /Since: 0.1.0.0/+-- /Since: 0.1.0/ -- -- ==== __Examples__ --@@ -646,7 +1105,6 @@ | otherwise = Just $ fromEnum w where maxInt = toEnum (maxBound :: Int)- -- |
stack.yaml view
@@ -1,3 +1,6 @@ allow-newer: true -resolver: lts-10.3+extra-deps:+ - mono-traversable-keys-0.1.0++resolver: lts-11.0
+ test/Data/BitVector/Visual.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.BitVector.Visual+ ( VisualBitVector()+ , VisualBitVectorSmall()+ , HasBitVector(..)+ )where++import Control.DeepSeq+import Data.Bits+import Data.BitVector.LittleEndian+import Data.Data+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ()+import Data.MonoTraversable+import Data.Semigroup+import GHC.Generics+import GHC.Natural+import Test.QuickCheck hiding (generate)+import Test.SmallCheck.Series+++newtype VisualBitVector = VBV BitVector+ deriving (Data, Eq, Ord, Generic, NFData, Typeable)+++newtype VisualBitVectorSmall = VBVS BitVector+ deriving (Data, Eq, Ord, Generic, NFData, Typeable)+++class HasBitVector a where++ getBitVector :: a -> BitVector+++instance HasBitVector BitVector where++ getBitVector = id+++instance HasBitVector VisualBitVector where++ getBitVector (VBV bv) = bv+++instance HasBitVector VisualBitVectorSmall where++ getBitVector (VBVS bv) = bv+++instance CoArbitrary VisualBitVector where++ coarbitrary = coarbitraryEnum+++instance CoArbitrary VisualBitVectorSmall where++ coarbitrary = coarbitraryEnum+++{-+instance Monad m => CoSerial m VisualBitVector where++ coseries x = genericCoseries x+-}+++instance Bounded VisualBitVector where++ minBound = VBV $ fromNumber 0 0++ maxBound = VBV $ fromNumber 8 (bit 8 - 1 :: Natural)+++instance Bounded VisualBitVectorSmall where++ minBound = VBVS $ fromNumber 0 0++ maxBound = VBVS $ fromNumber 3 (bit 3 - 1 :: Natural)+++instance Enum VisualBitVector where++ toEnum n = go $ n `mod` (bit 9 - 1)+ where+ go i = VBV $ fromNumber (toEnum dim) num+ where+ (num, off, dim) = getEnumContext i++ fromEnum (VBV bv) =+ case dim of+ 0 -> 0+ n -> num + 2^dim - 1+ where+ num = toUnsignedNumber bv+ dim = dimension bv+++instance Enum VisualBitVectorSmall where++ toEnum n = go $ n `mod` (bit 4 - 1)+ where+ go i = VBVS $ fromNumber (toEnum dim) num+ where+ (num, off, dim) = getEnumContext i++ fromEnum (VBVS bv) =+ case dim of+ 0 -> 0+ n -> num + 2^dim - 1+ where+ num = toUnsignedNumber bv+ dim = dimension bv+++instance Monad m => Serial m VisualBitVector where++ series = generate $ const allVBVs+ where+ allVBVs = toEnum <$> [0 .. fromEnum (maxBound :: VisualBitVector)]+++instance Monad m => Serial m VisualBitVectorSmall where++ series = generate $ const allVBVs+ where+ allVBVs = toEnum <$> [0 .. fromEnum (maxBound :: VisualBitVectorSmall)]+++instance Show VisualBitVector where++ show (VBV bv) = mconcat+ [ "["+ , show $ dimension bv+ , "]"+ , "<"+ , foldMap (\b -> if b then "1" else "0") $ toBits bv+ , ">"+ ]++instance Show VisualBitVectorSmall where++ show (VBVS bv) = mconcat+ [ "["+ , show $ dimension bv+ , "]"+ , "<"+ , foldMap (\b -> if b then "1" else "0") $ toBits bv+ , ">"+ ]+++getEnumContext i = (num, off, dim)+ where+ num = i - off+ off = bit dim - 1+ dim = logBase2 $ i + 1+ logBase2 x = finiteBitSize x - 1 - countLeadingZeros x+
test/TestSuite.hs view
@@ -7,19 +7,29 @@ module Main ( main ) where -import Control.DeepSeq-import Data.Bits-import Data.BitVector.LittleEndian-import Data.Functor.Compose-import Data.Functor.Identity-import Data.Hashable-import Data.List.NonEmpty (NonEmpty(..))-import Data.Monoid ()-import Data.MonoTraversable-import Data.Semigroup-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck hiding ((.&.))+import Control.DeepSeq+import Data.Bits+import Data.BitVector.LittleEndian+import Data.BitVector.Visual+import Data.Foldable+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ()+import Data.MonoTraversable+import Data.MonoTraversable.Keys+import Data.Semigroup+import Operator.Binary.Comparison+import Operator.Binary.Logical+import Operator.Unary.Logical+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding ((.&.), forAll, testProperty)+import qualified Test.Tasty.QuickCheck as QC+import Test.Tasty.SmallCheck hiding ((===), (==>), Property, testProperty)+import qualified Test.Tasty.SmallCheck as SC+import TextShow (TextShow(showb), toString) main :: IO ()@@ -31,36 +41,46 @@ [ bitsTests , finiteBitsTests , hashableTests+ , monoAdjustableProperties , monoFunctorProperties , monoFoldableProperties- , monoidProperties+ , monoFoldableWithKeyProperties+ , monoKeyedProperties , monoTraversableProperties+ , monoTraversableWithKeyProperties+ , monoZipProperties+ , monoZipWithKeyProperties+ , monoidProperties , normalFormDataProperties , orderingProperties , semigroupProperties , showProperties+ , textshowProperties , bitVectorProperties+ , monoFunctorEquivelence+ , monoFoldableEquivelence+ , monoZipEquivelence ] bitsTests :: TestTree bitsTests = testGroup "Properties of Bits"- [ testProperty "∀ i ≥ 0, clearBit zeroBits i === zeroBits" zeroBitsAndClearBit- , testProperty "∀ i ≥ 0, setBit zeroBits i === bit i" zeroBitsAndSetBit- , testProperty "∀ i ≥ 0, testBit zeroBits i === False" zeroBitsAndTestBit- , testCase " popCount zeroBits === 0" zeroBitsAndPopCount- , testProperty "complement === omap not" complementOmapNot- , testProperty "(`setBit` i) === (.|. bit i)" setBitDefinition- , testProperty "(`clearBit` i) === (.&. complement (bit i))" clearBitDefinition- , testProperty "(`complementBit` i) === (`xor` bit i)" complementBitDefinition- , testProperty "(`testBit` i) . (`setBit` n)" testBitAndSetBit- , testProperty "not . (`testBit` i) . (`clearBit` i)" testBitAndClearBit- , testProperty "(`shiftL` i) === (`shift` i)" leftShiftPositiveShift- , testProperty "(`shiftR` i) === (`shift` -i)" rightShiftNegativeShift- , testProperty "(`rotateL` i) === (`rotate` i)" leftRotatePositiveRotate- , testProperty "(`rotateR` i) === (`rotate` -i)" rightRotateNegativeRotate- , testProperty "(`rotateR` i) . (`rotateL` i) === id" leftRightRotateIdentity- , testProperty "(`rotateL` i) . (`rotateR` i) === id" rightLeftRotateIdentity+ [ QC.testProperty "∀ i ≥ 0, clearBit zeroBits i === zeroBits" zeroBitsAndClearBit+ , QC.testProperty "∀ i ≥ 0, setBit zeroBits i === bit i" zeroBitsAndSetBit+ , QC.testProperty "∀ i ≥ 0, testBit zeroBits i === False" zeroBitsAndTestBit+ , testCase " popCount zeroBits === 0" zeroBitsAndPopCount+ , QC.testProperty "complement === omap not" complementOmapNot+ , QC.testProperty "(`setBit` i) === (.|. bit i)" setBitDefinition+ , QC.testProperty "(`clearBit` i) === (.&. complement (bit i))" clearBitDefinition+ , QC.testProperty "(`complementBit` i) === (`xor` bit i)" complementBitDefinition+ , QC.testProperty "(`testBit` i) . (`setBit` n)" testBitAndSetBit+ , QC.testProperty "not . (`testBit` i) . (`clearBit` i)" testBitAndClearBit+ , QC.testProperty "(`shiftL` i) === (`shift` i)" leftShiftPositiveShift+ , QC.testProperty "(`shiftR` i) === (`shift` -i)" rightShiftNegativeShift+ , QC.testProperty "(`rotateL` i) === (`rotate` i)" leftRotatePositiveRotate+ , QC.testProperty "(`rotateR` i) === (`rotate` -i)" rightRotateNegativeRotate+ , QC.testProperty "(`rotateR` i) . (`rotateL` i) === id" leftRightRotateIdentity+ , QC.testProperty "(`rotateL` i) . (`rotateR` i) === id" rightLeftRotateIdentity ] where zeroBitsAndClearBit :: NonNegative Int -> Property@@ -99,12 +119,12 @@ bv `complementBit` i === bv `xor` bit i testBitAndSetBit :: NonNegative Int -> BitVector -> Bool- testBitAndSetBit (NonNegative i) bv =- ((`testBit` i) . (`setBit` i)) bv+ testBitAndSetBit (NonNegative i) =+ (`testBit` i) . (`setBit` i) testBitAndClearBit :: NonNegative Int -> BitVector -> Bool- testBitAndClearBit (NonNegative i) bv =- (not . (`testBit` i) . (`clearBit` i)) bv+ testBitAndClearBit (NonNegative i) =+ not . (`testBit` i) . (`clearBit` i) leftShiftPositiveShift :: NonNegative Int -> BitVector -> Property leftShiftPositiveShift (NonNegative i) bv =@@ -133,14 +153,15 @@ finiteBitsTests :: TestTree finiteBitsTests = testGroup "Properties of FiniteBits"- [ testProperty "bitSize == finiteBitSize" finiteBitSizeIsBitSize- , testProperty "bitSizeMaybe == Just . finiteBitSize" finiteBitSizeIsBitSizeMaybe- , testProperty "fromEnum . dimension === finiteBitSize" finiteBitSizeIsDimension- , testProperty "length . toBits === finiteBitSize" finiteBitSizeIsBitLength- , testProperty "length . takeWhile not === countLeadingZeros . fromBits" countLeadingZeroAndFromBits- , testProperty "length . takeWhile not . toBits === countLeadingZeros" countLeadingZeroAndToBits- , testProperty "length . takeWhile not . reverse === countTrailingZeros . fromBits" countTrailingZeroAndFromBits- , testProperty "length . takeWhile not . reverse . toBits === countTrailingZeros" countTrailingZeroAndToBits+ [ QC.testProperty "bitSize === finiteBitSize" finiteBitSizeIsBitSize+ , QC.testProperty "bitSizeMaybe === Just . finiteBitSize" finiteBitSizeIsBitSizeMaybe+ , QC.testProperty "countLeadingZeros <= finiteBitSize" finiteBitSizeIsGreaterThanLeadingZeros+ , QC.testProperty "countTrailingZeros <= finiteBitSize" finiteBitSizeIsGreaterThanTrailingZeros+ , QC.testProperty "length . toBits === finiteBitSize" finiteBitSizeIsBitLength+ , QC.testProperty "length . takeWhile not === countLeadingZeros . fromBits" countLeadingZeroAndFromBits+ , QC.testProperty "length . takeWhile not . toBits === countLeadingZeros" countLeadingZeroAndToBits+ , QC.testProperty "length . takeWhile not . reverse === countTrailingZeros . fromBits" countTrailingZeroAndFromBits+ , QC.testProperty "length . takeWhile not . reverse . toBits === countTrailingZeros" countTrailingZeroAndToBits ] where finiteBitSizeIsBitSize :: BitVector -> Property@@ -155,6 +176,14 @@ finiteBitSizeIsDimension bv = (fromEnum . dimension) bv === finiteBitSize bv + finiteBitSizeIsGreaterThanLeadingZeros :: BitVector -> Bool+ finiteBitSizeIsGreaterThanLeadingZeros bv =+ countLeadingZeros bv <= finiteBitSize bv++ finiteBitSizeIsGreaterThanTrailingZeros :: BitVector -> Bool+ finiteBitSizeIsGreaterThanTrailingZeros bv =+ countTrailingZeros bv <= finiteBitSize bv+ finiteBitSizeIsBitLength :: BitVector -> Property finiteBitSizeIsBitLength bv = (length . toBits) bv === finiteBitSize bv@@ -179,23 +208,54 @@ hashableTests :: TestTree hashableTests = testGroup "Properties of Hashable" [ localOption (QuickCheckTests 10000)- $ testProperty "a == b ==> (hashWithSalt a) === (hashWithSalt b)" differentSaltsDifferentHashes+ $ QC.testProperty "a == b ==> (hashWithSalt a) === (hashWithSalt b)" differentSaltsDifferentHashes ] where differentSaltsDifferentHashes :: BitVector -> Int -> Int -> Property differentSaltsDifferentHashes bv salt1 salt2 =- salt1 /= salt2 ==> (hashWithSalt salt1 bv) /= (hashWithSalt salt2 bv)+ salt1 /= salt2 ==> hashWithSalt salt1 bv /= hashWithSalt salt2 bv - +++monoAdjustableProperties :: TestTree+monoAdjustableProperties = testGroup "Properites of a MonoAdjustable"+ [ QC.testProperty "oadjust id k === id" oadjustId+ , QC.testProperty "oadjust (f . g) k === oadjust f k . oadjust g k" oadjustComposition+ , QC.testProperty "oadjust f k === omapWithKey (\\i -> if i == k then f else id)" omapConditionality+ , QC.testProperty "oreplace k v === oreplace k v . oadjust f k" oreplaceNullification+ , QC.testProperty "oreplace (f v) k === oadjust f k . oreplace k v" oreplaceApplication+ ]+ where+ oadjustId :: Word -> BitVector -> Property+ oadjustId k bv = + oadjust id k bv === bv++ oadjustComposition :: Blind (Bool -> Bool) -> Blind (Bool -> Bool) -> Word -> BitVector -> Property+ oadjustComposition (Blind f) (Blind g) k bv =+ oadjust (f . g) k bv === (oadjust f k . oadjust g k) bv++ omapConditionality :: Blind (Bool -> Bool) -> Word -> BitVector -> Property+ omapConditionality (Blind f) k bv =+ oadjust f k bv === omapWithKey (\i -> if i == k then f else id) bv++ oreplaceNullification :: Blind (Bool -> Bool) -> Word -> Bool -> BitVector -> Property+ oreplaceNullification (Blind f) k v bv =+ oreplace k v bv === (oreplace k v . oadjust f k) bv++ oreplaceApplication :: Blind (Bool -> Bool) -> Word -> Bool -> BitVector -> Property+ oreplaceApplication (Blind f) k v bv =+ oreplace k (f v) bv === (oadjust f k . oreplace k v) bv++ monoFunctorProperties :: TestTree monoFunctorProperties = testGroup "Properites of a MonoFunctor"- [ testProperty "omap id === id" omapId- , testProperty "omap (f . g) === omap f . omap g" omapComposition+ [ QC.testProperty "omap id === id" omapId+ , QC.testProperty "omap (f . g) === omap f . omap g" omapComposition ] where omapId :: BitVector -> Property omapId bv =- omap id bv === id bv+ omap id bv === bv omapComposition :: Blind (Bool -> Bool) -> Blind (Bool -> Bool) -> BitVector -> Property omapComposition (Blind f) (Blind g) bv =@@ -204,19 +264,19 @@ monoFoldableProperties :: TestTree monoFoldableProperties = testGroup "Properties of MonoFoldable"- [ testProperty "ofoldr f z t === appEndo (ofoldMap (Endo . f) t ) z" testFoldrFoldMap- , testProperty "ofoldl' f z t === appEndo (getDual (ofoldMap (Dual . Endo . flip f) t)) z" testFoldlFoldMap- , testProperty "ofoldr f z === ofoldr f z . otoList" testFoldr- , testProperty "ofoldl' f z === ofoldl' f z . otoList" testFoldl- , testProperty "ofoldr1Ex f z === ofoldr1Ex f z . otoList" testFoldr1- , testProperty "ofoldl1Ex' f z === ofoldl1Ex' f z . otoList" testFoldl1- , testProperty "oall f === getAll . ofoldMap (All . f)" testAll- , testProperty "oany f === getAny . ofoldMap (Any . f)" testAny- , testProperty "olength === length . otoList" testLength- , testProperty "onull === (0 ==) . olength" testNull- , testProperty "headEx === getFirst . ofoldMap1Ex First" testHead- , testProperty "lastEx === getLast . ofoldMap1Ex Last" testTail- , testProperty "oelem e /== onotElem e" testInclusionConsistency+ [ QC.testProperty "ofoldr f z t === appEndo (ofoldMap (Endo . f) t ) z" testFoldrFoldMap+ , QC.testProperty "ofoldl' f z t === appEndo (getDual (ofoldMap (Dual . Endo . flip f) t)) z" testFoldlFoldMap+ , QC.testProperty "ofoldr f z === ofoldr f z . otoList" testFoldr+ , QC.testProperty "ofoldl' f z === ofoldl' f z . otoList" testFoldl+ , QC.testProperty "ofoldr1Ex f === foldr1 f . otoList" testFoldr1+ , QC.testProperty "ofoldl1Ex' f === foldl1 f . otoList" testFoldl1+ , QC.testProperty "oall f === getAll . ofoldMap (All . f)" testAll+ , QC.testProperty "oany f === getAny . ofoldMap (Any . f)" testAny+ , QC.testProperty "olength === length . otoList" testLength+ , QC.testProperty "onull === (0 ==) . olength" testNull+ , QC.testProperty "headEx === getFirst . ofoldMap1Ex First" testHead+ , QC.testProperty "lastEx === getLast . ofoldMap1Ex Last" testTail+ , QC.testProperty "oelem e /== onotElem e" testInclusionConsistency ] where testFoldrFoldMap :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property@@ -235,13 +295,17 @@ testFoldl (Blind f) z bv = ofoldl' f z bv === (ofoldl' f z . otoList) bv - testFoldr1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property- testFoldr1 (Blind f) bv =- (not . onull) bv ==> ofoldr1Ex f bv === (ofoldr1Ex f . otoList) bv+-- testFoldr1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property+ testFoldr1 :: BinaryLogicalOperator -> BitVector -> Property+-- testFoldr1 (Blind f) bv =+ testFoldr1 x bv =+ (not . onull) bv ==> ofoldr1Ex f bv === (foldr1 f . otoList) bv+ where+ f = getBinaryLogicalOperator x testFoldl1 :: Blind (Bool -> Bool -> Bool) -> BitVector -> Property testFoldl1 (Blind f) bv =- (not . onull) bv ==> ofoldl1Ex' f bv === (ofoldl1Ex' f . otoList) bv+ (not . onull) bv ==> ofoldl1Ex' f bv === (foldl1 f . otoList) bv testAll :: Blind (Bool -> Bool) -> BitVector -> Property testAll (Blind f) bv =@@ -272,37 +336,67 @@ oelem e bv === (not . onotElem e) bv -monoidProperties :: TestTree-monoidProperties = testGroup "Properties of a Monoid"- [ testProperty "left identity" leftIdentity- , testProperty "right identity" rightIdentity- , testProperty "mempty is associative" operationAssocativity- , testProperty "mconcat === foldr (<>) mempty" foldableApplication+monoFoldableWithKeyProperties :: TestTree+monoFoldableWithKeyProperties = testGroup "Properties of MonoFoldableWithKey"+ [ QC.testProperty "otoKeyedList === zip [0..] . otoList" testNaturalKeyedList+ , QC.testProperty "ofoldMapWithKey (const f) === ofoldMap f" testConstantFoldMap+ , QC.testProperty "ofoldrWithKey (const f) === ofoldr f" testConstantFoldr+ , QC.testProperty "ofoldlWithKey (const . f) === ofoldl f" testConstantFoldl+ , QC.testProperty "ofoldMapWithKey f === foldMap (uncurry f) . otoKeyedList" testUncurriedFoldMap+ , QC.testProperty "ofoldrWithKey f === foldr (uncurry f) . otoKeyedList" testUncurriedFoldr+ , QC.testProperty "ofoldlWithKey f === foldl (uncurry . f) . otoKeyedList" testUncurriedFoldl ] where- leftIdentity :: BitVector -> Property- leftIdentity a =- mempty `mappend` a === a+ testNaturalKeyedList :: BitVector -> Property+ testNaturalKeyedList bv =+ otoKeyedList bv === (zip [0..] . otoList) bv - rightIdentity :: BitVector -> Property- rightIdentity a =- a `mappend` mempty === a+ testConstantFoldMap :: Blind (Bool -> [Word]) -> BitVector -> Property+ testConstantFoldMap (Blind f) bv =+ ofoldMapWithKey (const f) bv === ofoldMap f bv - operationAssocativity :: BitVector -> BitVector -> BitVector -> Property- operationAssocativity a b c =- a `mappend` (b `mappend` c) === (a `mappend` b) `mappend` c+ testConstantFoldr :: Blind (Bool -> Word -> Word) -> Word -> BitVector -> Property+ testConstantFoldr (Blind f) e bv =+ ofoldrWithKey (const f) e bv === ofoldr f e bv - foldableApplication :: [BitVector] -> Property- foldableApplication bvs = - mconcat bvs === foldr mappend mempty bvs+ testConstantFoldl :: Blind (Word -> Bool -> Word) -> Word -> BitVector -> Property+ testConstantFoldl (Blind f) e bv =+ ofoldlWithKey (const . f) e bv === ofoldl' f e bv + testUncurriedFoldMap :: Blind (Word -> Bool -> [Word]) -> BitVector -> Property+ testUncurriedFoldMap (Blind f) bv =+ ofoldMapWithKey f bv === (foldMap (uncurry f) . otoKeyedList) bv + testUncurriedFoldr :: Blind (Word -> Bool -> Word -> Word) -> Word -> BitVector -> Property+ testUncurriedFoldr (Blind f) e bv =+ ofoldrWithKey f e bv === (foldr (uncurry f) e . otoKeyedList) bv++ testUncurriedFoldl :: Blind (Word -> Word -> Bool -> Word) -> Word -> BitVector -> Property+ testUncurriedFoldl (Blind f) e bv =+ ofoldlWithKey f e bv === (foldl (uncurry . f) e . otoKeyedList) bv+++monoKeyedProperties :: TestTree+monoKeyedProperties = testGroup "Properites of a MonoKeyed"+ [ QC.testProperty "omapWithKey (const id) === id" omapId+ , QC.testProperty "omapWithKey (\\k -> f k . g k) === omapWithKey f . omapWithKey g" omapComposition+ ]+ where+ omapId :: BitVector -> Property+ omapId bv =+ omapWithKey (const id) bv === bv++ omapComposition :: Blind (Word -> Bool -> Bool) -> Blind (Word -> Bool -> Bool) -> BitVector -> Property+ omapComposition (Blind f) (Blind g) bv =+ omapWithKey (\k -> f k . g k) bv === (omapWithKey f . omapWithKey g) bv++ monoTraversableProperties :: TestTree monoTraversableProperties = testGroup "Properties of MonoTraversable"- [ testProperty "t . otraverse f === otraverse (t . f)" testNaturality- , testProperty "otraverse Identity === Identity" testIdentity- , testProperty "otraverse (Compose . fmap g . f) === Compose . fmap (otraverse g) . otraverse f" testComposition- , testProperty "otraverse === omapM" testDefinitionEquality+ [ QC.testProperty "t . otraverse f === otraverse (t . f)" testNaturality+ , QC.testProperty "otraverse Identity === Identity" testIdentity+ , QC.testProperty "otraverse (Compose . fmap g . f) === Compose . fmap (otraverse g) . otraverse f" testComposition+ , QC.testProperty "otraverse === omapM" testDefinitionEquality ] where testNaturality :: Blind (Bool -> [Bool]) -> BitVector -> Property@@ -322,9 +416,92 @@ otraverse f bv === omapM f bv +monoTraversableWithKeyProperties :: TestTree+monoTraversableWithKeyProperties = testGroup "Properties of MonoTraversableWithKey"+ [ QC.testProperty "t . otraverseWithKey f === otraverseWithKey (\\k -> t . f k)" testNaturality+ , QC.testProperty "otraverseWithKey (const Identity) === Identity" testIdentity+ , QC.testProperty "otraverseWithKey (\\k -> Compose . fmap (g k) . f k) === Compose . fmap (otraverseWithKey g) . otraverseWithKey f" testComposition+ , QC.testProperty "otraverseWithKey === omapWithKeyM" testDefinitionEquality+ ]+ where+ testNaturality :: Blind (Word -> Bool -> [Bool]) -> BitVector -> Property+ testNaturality (Blind f) bv =+ (headMay . otraverseWithKey f) bv === otraverseWithKey (\k -> headMay . f k) bv++ testIdentity :: BitVector -> Property+ testIdentity bv =+ otraverseWithKey (const Identity) bv === Identity bv++ testComposition :: Blind (Word -> Bool -> Either Word Bool) -> Blind (Word -> Bool -> Maybe Bool) -> BitVector -> Property+ testComposition (Blind f) (Blind g) bv =+ otraverseWithKey (\k -> Compose . fmap (g k) . f k) bv === (Compose . fmap (otraverseWithKey g) . otraverseWithKey f) bv++ testDefinitionEquality :: Blind (Word -> Bool -> Maybe Bool) -> BitVector -> Property+ testDefinitionEquality (Blind f) bv =+ otraverseWithKey f bv === omapWithKeyM f bv+++monoZipProperties :: TestTree+monoZipProperties = testGroup "Properites of a MonoZip"+ [ QC.testProperty "ozipWith const u u === ozipWith (flip const) u u === u" ozipWithConst+ , QC.testProperty "ozipWith (flip f) x y === ozipWith f y x" ozipWithTransposition+ , QC.testProperty "ozipWith (\\a b -> f (g a) (h b)) x y === ozipWith f (omap g x) (omap h y)" ozipWithComposition+ ]+ where+ ozipWithConst :: BitVector -> Property+ ozipWithConst u =+ ozipWith const u u === u .&&. ozipWith (flip const) u u === u++ ozipWithTransposition :: Blind (Bool -> Bool -> Bool) -> BitVector -> BitVector -> Property+ ozipWithTransposition (Blind f) x y =+ ozipWith (flip f) x y === ozipWith f y x++ ozipWithComposition+ :: Blind (Bool -> Bool -> Bool)+ -> Blind (Bool -> Bool)+ -> Blind (Bool -> Bool) -> BitVector -> BitVector -> Property+ ozipWithComposition (Blind f) (Blind g) (Blind h) x y =+ ozipWith (\a b -> f (g a) (h b)) x y === ozipWith f (omap g x) (omap h y)+++monoZipWithKeyProperties :: TestTree+monoZipWithKeyProperties = testGroup "Properites of a MonoZipWithKey"+ [ QC.testProperty "ozipWithKey (const f) === ozipWith f" ozipWithKeyConst+ ]+ where+ ozipWithKeyConst :: Blind (Bool -> Bool -> Bool) -> BitVector -> BitVector -> Property+ ozipWithKeyConst (Blind f) x y =+ ozipWithKey (const f) x y === ozipWith f x y+++monoidProperties :: TestTree+monoidProperties = testGroup "Properties of a Monoid"+ [ QC.testProperty "left identity" leftIdentity+ , QC.testProperty "right identity" rightIdentity+ , QC.testProperty "mempty is associative" operationAssocativity+ , QC.testProperty "mconcat === foldr (<>) mempty" foldableApplication+ ]+ where+ leftIdentity :: BitVector -> Property+ leftIdentity a =+ mempty `mappend` a === a++ rightIdentity :: BitVector -> Property+ rightIdentity a =+ a `mappend` mempty === a++ operationAssocativity :: BitVector -> BitVector -> BitVector -> Property+ operationAssocativity a b c =+ a `mappend` (b `mappend` c) === (a `mappend` b) `mappend` c++ foldableApplication :: [BitVector] -> Property+ foldableApplication bvs = + mconcat bvs === foldr mappend mempty bvs++ normalFormDataProperties :: TestTree normalFormDataProperties = testGroup "Properties of NFData"- [ testProperty "rnf result is finite" finiteReduction+ [ QC.testProperty "rnf result is finite" finiteReduction ] where finiteReduction :: BitVector -> Property@@ -334,8 +511,8 @@ orderingProperties :: TestTree orderingProperties = testGroup "Properties of an Ordering"- [ testProperty "ordering preserves symetry" symetry- , testProperty "ordering is transitive (total)" transitivity+ [ QC.testProperty "ordering preserves symetry" symetry+ , QC.testProperty "ordering is transitive (total)" transitivity ] where symetry :: BitVector -> BitVector -> Bool@@ -356,9 +533,9 @@ semigroupProperties :: TestTree semigroupProperties = testGroup "Properties of a Semigroup" [ localOption (QuickCheckTests 10000)- $ testProperty "(<>) is associative" operationAssocativity- , testProperty "sconcat === foldr1 (<>)" foldableApplication- , testProperty "stimes n === mconcat . replicate n" repeatedApplication+ $ QC.testProperty "(<>) is associative" operationAssocativity+ , QC.testProperty "sconcat === foldr1 (<>)" foldableApplication+ , QC.testProperty "stimes n === mconcat . replicate n" repeatedApplication ] where operationAssocativity :: BitVector -> BitVector -> BitVector -> Property@@ -373,15 +550,15 @@ bvs = let x:xs = getNonEmpty nel in x:|xs - repeatedApplication :: (NonNegative Int) -> BitVector -> Property+ repeatedApplication :: NonNegative Int -> BitVector -> Property repeatedApplication (NonNegative i) bv = stimes i bv === (mconcat . replicate i) bv showProperties :: TestTree showProperties = testGroup "Properties of Show"- [ testProperty "show result is finite" finiteString- , testProperty "show result is non-null" nonNullString+ [ QC.testProperty "show result is finite" finiteString+ , QC.testProperty "show result is non-null" nonNullString ] where finiteString :: BitVector -> Property@@ -391,23 +568,33 @@ nonNullString :: BitVector -> Bool nonNullString = not . null . show- +textshowProperties :: TestTree+textshowProperties = testGroup "Properties of TextShow"+ [ QC.testProperty "textshow and show result agree" textshowCoherence+ ]+ where+ textshowCoherence :: BitVector -> Property+ textshowCoherence bv =+ (toString . showb $ bv) === show bv+++ bitVectorProperties :: TestTree bitVectorProperties = testGroup "BitVector properties"- [ testProperty "otoList === toBits" otoListTest- , testProperty "dimension === length . toBits" dimensionAndToBits- , testProperty "dimension === finiteBitSize" dimensionAndFiniteBitSize- , testProperty "fromBits . toBits === id" toBitsFromBits- , testCase "isZeroVector zeroBits" zeroBitsIsZeroVector- , testProperty "isZeroVector === (0 ==) . popCount" popCountAndZeroVector- , testProperty "isZeroVector === all not . toBits" zeroVectorAndAllBitsOff- , testProperty "(0 ==) . toUnsignedNumber ==> isZeroVector" toUnsignedNumImpliesZeroVector- , testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity- , testProperty "isSigned == const False" noSignBitVector+ [ QC.testProperty "otoList === toBits" otoListTest+ , QC.testProperty "dimension === length . toBits" dimensionAndToBits+ , QC.testProperty "dimension === finiteBitSize" dimensionAndFiniteBitSize+ , QC.testProperty "fromBits . toBits === id" toBitsFromBits+ , testCase "isZeroVector zeroBits" zeroBitsIsZeroVector+ , QC.testProperty "isZeroVector === (0 ==) . popCount" popCountAndZeroVector+ , QC.testProperty "isZeroVector === all not . toBits" zeroVectorAndAllBitsOff+ , QC.testProperty "(0 ==) . toUnsignedNumber ==> isZeroVector" toUnsignedNumImpliesZeroVector+ , QC.testProperty "toSignedNumber . fromNumber === id" bitVectorUnsignedNumIdentity+ , QC.testProperty "isSigned == const False" noSignBitVector -- For an unknown reason, this test case causes GHC to panic!--- , testProperty "i > j ==> subRange (i,j) === const zeroBits" badSubRangeEmptyResult- , testProperty "i <= j ==> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension+-- , QC.testProperty "i > j ==> subRange (i,j) === const zeroBits" badSubRangeEmptyResult+ , QC.testProperty "i <= j ==> dimension . subRange (i,j) === const (j - i + 1)" subRangeFixedDimension ] where otoListTest :: BitVector -> Property@@ -462,3 +649,106 @@ where lower = toEnum lowerI upper = toEnum upperI+++monoFunctorEquivelence :: TestTree+monoFunctorEquivelence = testGroup "Equivelence of a MonoFunctor"+ [ SC.testProperty "omap f === fromBits . map f . toBits" $ forAll omapOptimizationIsValid+ ]+ where+ omapOptimizationIsValid :: (Bool -> Bool, VisualBitVector) -> Bool+ omapOptimizationIsValid (f, y) = omap f bv == (fromBits . map f . toBits) bv+ where+ bv = getBitVector y+++monoFoldableEquivelence :: TestTree+monoFoldableEquivelence = testGroup "Equivelence of a MonoFoldable"+ [ SC.testProperty "oall f === all f . otoList" $ forAll oallOptimizationIsValid+ , SC.testProperty "oany f === any f . otoList" $ forAll oanyOptimizationIsValid+ , SC.testProperty "ofoldr1Ex f === foldr1 f . otoList" $ forAll ofoldr1ExOptimizationIsValid+ , SC.testProperty "ofold'1Ex' f === foldl1 f . otoList" $ forAll ofoldl1ExOptimizationIsValid+ , SC.testProperty "headEx === head . otoList" $ forAll headExOptimizationIsValid+ , SC.testProperty "lastEx === last . otoList" $ forAll lastExOptimizationIsValid+-- , SC.testProperty "maximumByEx f === maximumBy f . otoList" $ forAll maximumByExOptimizationIsValid+-- , SC.testProperty "minimumByEx f === minimumBy f . otoList" $ forAll minimumByExOptimizationIsValid+ , SC.testProperty "oelem e === oelem e . otoList" $ forAll oelemOptimizationIsValid+ , SC.testProperty "onotElem e === onotElem e . otoList" $ forAll onotElemOptimizationIsValid+ ]+ where+ oallOptimizationIsValid :: (UnaryLogicalOperator, VisualBitVector) -> Bool+ oallOptimizationIsValid (y, x) = oall op bv == (all op . otoList) bv+ where+ bv = getBitVector x+ op = getUnaryLogicalOperator y++ oanyOptimizationIsValid :: (UnaryLogicalOperator, VisualBitVector) -> Bool+ oanyOptimizationIsValid (y, x) = oany op bv == (any op . otoList) bv+ where+ bv = getBitVector x+ op = getUnaryLogicalOperator y++ ofoldr1ExOptimizationIsValid :: (BinaryLogicalOperator, VisualBitVector) -> Bool+ ofoldr1ExOptimizationIsValid (y, x) =+ isZeroVector bv || ofoldr1Ex op bv == (foldr1 op . otoList) bv+ where+ bv = getBitVector x+ op = getBinaryLogicalOperator y++ ofoldl1ExOptimizationIsValid :: (BinaryLogicalOperator, VisualBitVector) -> Bool+ ofoldl1ExOptimizationIsValid (y, x) =+ isZeroVector bv || ofoldl1Ex' op bv == (foldl1 op . otoList) bv+ where+ bv = getBitVector x+ op = getBinaryLogicalOperator y++ headExOptimizationIsValid :: VisualBitVector -> Bool+ headExOptimizationIsValid x =+ isZeroVector bv || headEx bv == (head . otoList) bv+ where+ bv = getBitVector x++ lastExOptimizationIsValid :: VisualBitVector -> Bool+ lastExOptimizationIsValid x =+ isZeroVector bv || lastEx bv == (last . otoList) bv+ where+ bv = getBitVector x++ maximumByExOptimizationIsValid :: (VisualBitVector, ComparisonOperator) -> Bool+ maximumByExOptimizationIsValid (x, y) =+ isZeroVector bv || maximumByEx op bv == (maximumBy op . otoList) bv+ where+ bv = getBitVector x+ op = getComparator y++ minimumByExOptimizationIsValid :: (VisualBitVector, ComparisonOperator) -> Bool+ minimumByExOptimizationIsValid (x, y) =+ isZeroVector bv || minimumByEx op bv == (minimumBy op . otoList) bv+ where+ bv = getBitVector x+ op = getComparator y++ oelemOptimizationIsValid :: (VisualBitVector, Bool) -> Bool+ oelemOptimizationIsValid (x, e) = oelem e bv == (oelem e . otoList) bv+ where+ bv = getBitVector x++ onotElemOptimizationIsValid :: (VisualBitVector, Bool) -> Bool+ onotElemOptimizationIsValid (x, e) = onotElem e bv == (onotElem e . otoList) bv+ where+ bv = getBitVector x+++monoZipEquivelence :: TestTree+monoZipEquivelence = testGroup "Equivelence of a MonoZip"+ [ SC.testProperty "ozipWith f x === fromBits . zipWith f . (toBits x) . toBits" $ forAll omapOptimizationIsValid+ ]+ where+ omapOptimizationIsValid :: (BinaryLogicalOperator, VisualBitVectorSmall, VisualBitVectorSmall) -> Bool+ omapOptimizationIsValid (f, x, y) = ozipWith op lhs rhs == (fromBits . zipWith op (toBits lhs) . toBits) rhs+ where+ op = getBinaryLogicalOperator f+ lhs = getBitVector x+ rhs = getBitVector y++
+ util/Operator/Binary/Comparison.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Operator.Binary.Comparison+ ( ComparisonOperator(getComparator)+ ) where++import Control.DeepSeq+import Data.Data+import Data.List (elemIndex)+import Data.Maybe (fromJust)+import Data.Monoid ()+import Data.Semigroup+import GHC.Generics+import Test.QuickCheck hiding (generate)+import Test.SmallCheck.Series+++newtype ComparisonOperator = CO { getComparator :: Bool -> Bool -> Ordering }+ deriving (Generic, NFData, Typeable)+++comparatorList :: [ComparisonOperator]+comparatorList = do+ w <- [minBound .. maxBound]+ x <- [minBound .. maxBound]+ y <- [minBound .. maxBound]+ z <- [minBound .. maxBound]+ pure . CO $ \a b -> if not a && not b then w+ else if not a && b then x+ else if a && not b then y+ else {- a && b -} z+++instance Arbitrary ComparisonOperator where++ arbitrary = arbitraryBoundedEnum+++instance Bounded ComparisonOperator where++ minBound = head comparatorList++ maxBound = last comparatorList+++instance CoArbitrary ComparisonOperator where++ coarbitrary = coarbitraryEnum+++instance Enum ComparisonOperator where++ toEnum n = let !i = n `quot` length comparatorList+ in comparatorList !! i++ fromEnum c = fromJust $ elemIndex c comparatorList+++instance Eq ComparisonOperator where++ (CO f) == (CO g) = and+ [ f False False == g False False+ , f False True == g False True+ , f True False == g True False+ , f True True == g True True+ ]+++instance Monad m => Serial m ComparisonOperator where++ series = generate $ const comparatorList+++instance Show ComparisonOperator where++ show (CO f) = unlines+ [ ""+ , "f / F F -> " <> show (f False False)+ , " | F T -> " <> show (f False True )+ , " | T F -> " <> show (f True False)+ , " \\ T T -> " <> show (f True True )+ ]
+ util/Operator/Binary/Logical.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Operator.Binary.Logical+ ( BinaryLogicalOperator()+ , getBinaryLogicalSymbol+ , getBinaryLogicalOperator+ , fromBinaryLogicalFunction+ ) where++import Control.DeepSeq+import Data.Data+import Data.Monoid ()+import Data.Semigroup+import GHC.Generics+import Test.QuickCheck hiding (generate)+import Test.SmallCheck.Series+++data BinaryLogicalOperator+ = AlwaysFalse+ | LogicalNOR+ | ConverseNonImplication+ | NotFirstArgument+ | NonImplication+ | NotSecondArgument+ | LogicalXOR+ | LogicalNAND+ | LogicalAND+ | LogicalXNOR+ | SecondArgument+ | Implication+ | FirstArgument+ | ConverseImplication+ | LogicalOR+ | AlwaysTrue+ deriving (Data, Eq, Ord, Generic, NFData, Typeable)+++instance Arbitrary BinaryLogicalOperator where++ arbitrary = arbitraryBoundedEnum+++instance Bounded BinaryLogicalOperator where++ minBound = AlwaysFalse++ maxBound = AlwaysTrue+++instance CoArbitrary BinaryLogicalOperator where++ coarbitrary = coarbitraryEnum+++instance Enum BinaryLogicalOperator where++ toEnum n =+ case n `rem` 16 of+ 0 -> AlwaysFalse+ 1 -> LogicalNOR+ 2 -> ConverseNonImplication+ 3 -> NotFirstArgument+ 4 -> NonImplication+ 5 -> NotSecondArgument+ 6 -> LogicalXOR+ 7 -> LogicalNAND+ 8 -> LogicalAND+ 9 -> LogicalXNOR+ 10 -> SecondArgument+ 11 -> Implication+ 12 -> FirstArgument+ 13 -> ConverseImplication+ 14 -> LogicalOR+ _ -> AlwaysTrue++ fromEnum x =+ case x of+ AlwaysFalse -> 0+ LogicalNOR -> 1+ ConverseNonImplication -> 2+ NotFirstArgument -> 3+ NonImplication -> 4+ NotSecondArgument -> 5+ LogicalXOR -> 6+ LogicalNAND -> 7+ LogicalAND -> 8+ LogicalXNOR -> 9+ SecondArgument -> 10+ Implication -> 11+ FirstArgument -> 12+ ConverseImplication -> 13+ LogicalOR -> 14+ AlwaysTrue -> 15++ succ x =+ case x of+ AlwaysFalse -> LogicalNOR+ LogicalNOR -> ConverseNonImplication+ ConverseNonImplication -> NotFirstArgument+ NotFirstArgument -> NonImplication+ NonImplication -> NotSecondArgument+ NotSecondArgument -> LogicalXOR+ LogicalXOR -> LogicalNAND+ LogicalNAND -> LogicalAND+ LogicalAND -> LogicalXNOR+ LogicalXNOR -> SecondArgument+ SecondArgument -> Implication+ Implication -> FirstArgument+ FirstArgument -> ConverseImplication+ ConverseImplication -> LogicalOR+ LogicalOR -> AlwaysTrue+ AlwaysTrue -> AlwaysFalse++ pred x =+ case x of+ AlwaysFalse -> AlwaysTrue+ LogicalNOR -> AlwaysFalse+ ConverseNonImplication -> LogicalNOR+ NotFirstArgument -> ConverseNonImplication+ NonImplication -> NotFirstArgument+ NotSecondArgument -> NonImplication+ LogicalXOR -> NotSecondArgument+ LogicalNAND -> LogicalXOR+ LogicalAND -> LogicalNAND+ LogicalXNOR -> LogicalAND+ SecondArgument -> LogicalXNOR+ Implication -> SecondArgument+ FirstArgument -> Implication+ ConverseImplication -> FirstArgument+ LogicalOR -> ConverseImplication+ AlwaysTrue -> LogicalOR++-- enumFrom x = toEnum <$> [fromEnum x .. 15]++-- enumFromTo x y = +++instance Monad m => Serial m BinaryLogicalOperator where++ series = generate $ const [minBound .. maxBound]+++instance Show BinaryLogicalOperator where++ show x = "f p q = " <> s+ where+ s = case x of+ AlwaysFalse -> "False (Contradiction)"+ LogicalNOR -> "¬p ∧ ¬q (Logical NOR)"+ ConverseNonImplication -> "¬p ∧ q (Converse Non-Implication)"+ NotFirstArgument -> "¬p (Not First)"+ NonImplication -> "p ∧ ¬q (Non-Implication)"+ NotSecondArgument -> "¬q (Not Second)"+ LogicalXOR -> "(p ∧ ¬q) ∨ (¬p ∧ q) (Logical XOR)"+ LogicalNAND -> "¬p ∨ ¬q (Logical NAND)"+ LogicalAND -> "p ∧ q (Logical AND)"+ LogicalXNOR -> "(p ∧ q) ∨ (¬p ∧ ¬q) (Logical XNOR)"+ SecondArgument -> "q (Second)"+ Implication -> "¬p ∨ q (Implication)"+ FirstArgument -> "p (First)"+ ConverseImplication -> "p ∨ ¬q (Converse Implication)"+ LogicalOR -> "p ∧ q (Logical OR)"+ AlwaysTrue -> "True (Tautology)"+++getBinaryLogicalOperator :: BinaryLogicalOperator -> Bool -> Bool -> Bool+getBinaryLogicalOperator x =+ case x of+ AlwaysFalse -> const (const False)+ LogicalNOR -> \p q -> not $ p || q+ ConverseNonImplication -> \p q -> not p && q+ NotFirstArgument -> \p _ -> not p+ NonImplication -> \p q -> p && not q+ NotSecondArgument -> \_ q -> not q+ LogicalXOR -> (/=)+ LogicalNAND -> \p q -> not $ p && q+ LogicalAND -> (&&)+ LogicalXNOR -> (==)+ SecondArgument -> \_ q -> q+ Implication -> \p q -> not p || q+ FirstArgument -> const+ ConverseImplication -> \p q -> p || not q+ LogicalOR -> (||)+ AlwaysTrue -> const (const True)+++getBinaryLogicalSymbol :: BinaryLogicalOperator -> String+getBinaryLogicalSymbol x =+ case x of+ AlwaysFalse -> "(const False)"+ LogicalNOR -> "(not . (||))"+ ConverseNonImplication -> "(</=)"+ NotFirstArgument -> "(not . fst)"+ NonImplication -> "(=/>)"+ NotSecondArgument -> "(not . snd)"+ LogicalXOR -> "(/=)"+ LogicalNAND -> "(not . (&&))"+ LogicalAND -> "(&&)"+ LogicalXNOR -> "(==)"+ SecondArgument -> "(snd)"+ Implication -> "(==>)"+ FirstArgument -> "(fst)"+ ConverseImplication -> "(<==)"+ LogicalOR -> "(||)"+ AlwaysTrue -> "(const True)"+++fromBinaryLogicalFunction :: (Bool -> Bool -> Bool) -> BinaryLogicalOperator+fromBinaryLogicalFunction f = + case (f True True, f True False, f False True, f False False) of+ (False, False, False, False) -> AlwaysFalse+ (False, False, False, True ) -> LogicalNOR+ (False, False, True , False) -> ConverseNonImplication+ (False, False, True , True ) -> NotFirstArgument+ (False, True , False, False) -> NonImplication+ (False, True , False, True ) -> NotSecondArgument+ (False, True , True , False) -> LogicalXOR+ (False, True , True , True ) -> LogicalNAND+ (True , False, False, False) -> LogicalAND+ (True , False, False, True ) -> LogicalXNOR+ (True , False, True , False) -> SecondArgument+ (True , False, True , True ) -> Implication+ (True , True , False, False) -> FirstArgument+ (True , True , False, True ) -> ConverseImplication+ (True , True , True , False) -> LogicalOR + (True , True , True , True ) -> AlwaysTrue
+ util/Operator/Unary/Logical.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Operator.Unary.Logical+ ( UnaryLogicalOperator()+ , getUnaryLogicalSymbol+ , getUnaryLogicalOperator+ , fromUnaryLogicalFunction+ ) where++import Control.DeepSeq+import Data.Data+import Data.Monoid ()+import Data.Semigroup+import GHC.Generics+import Test.QuickCheck hiding (generate)+import Test.SmallCheck.Series+++data UnaryLogicalOperator+ = AlwaysFalse+ | Identity+ | Negation+ | AlwaysTrue+ deriving (Data, Eq, Ord, Generic, NFData, Typeable)+++instance Arbitrary UnaryLogicalOperator where++ arbitrary = arbitraryBoundedEnum+++instance Bounded UnaryLogicalOperator where++ minBound = AlwaysFalse++ maxBound = AlwaysTrue+++instance CoArbitrary UnaryLogicalOperator where++ coarbitrary = coarbitraryEnum+++instance Enum UnaryLogicalOperator where++ toEnum n =+ case n `rem` 4 of+ 0 -> AlwaysFalse+ 1 -> Identity+ 2 -> Negation+ _ -> AlwaysTrue++ fromEnum x =+ case x of+ AlwaysFalse -> 0+ Identity -> 1+ Negation -> 2+ AlwaysTrue -> 3++ succ x =+ case x of+ AlwaysFalse -> Identity+ Identity -> Negation+ Negation -> AlwaysTrue+ AlwaysTrue -> AlwaysFalse+++ pred x =+ case x of+ AlwaysFalse -> AlwaysTrue+ Identity -> AlwaysFalse+ Negation -> Identity+ AlwaysTrue -> Negation+++instance Monad m => Serial m UnaryLogicalOperator where++ series = generate $ const [minBound .. maxBound]+++instance Show UnaryLogicalOperator where++ show x = "f p q = " <> s+ where+ s = case x of+ AlwaysFalse -> "False (Contradiction)"+ Identity -> "id (Identity)"+ Negation -> "not (Negation)"+ AlwaysTrue -> "True (Tautology)"+++getUnaryLogicalOperator :: UnaryLogicalOperator -> Bool -> Bool+getUnaryLogicalOperator x =+ case x of+ AlwaysFalse -> const False+ Identity -> id+ Negation -> not+ AlwaysTrue -> const True+++getUnaryLogicalSymbol :: UnaryLogicalOperator -> String+getUnaryLogicalSymbol x =+ case x of+ AlwaysFalse -> "(const False)"+ Identity -> "(id)"+ Negation -> "(not)"+ AlwaysTrue -> "(const True)"+++fromUnaryLogicalFunction :: (Bool -> Bool) -> UnaryLogicalOperator+fromUnaryLogicalFunction f = + case (f False, f True) of+ (False, False) -> AlwaysFalse+ (False, True ) -> Identity+ (True , False) -> Negation+ (True , True ) -> AlwaysTrue+