diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Benchmarks.hs b/bench/Benchmarks.hs --- a/bench/Benchmarks.hs +++ b/bench/Benchmarks.hs @@ -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 diff --git a/bv-little.cabal b/bv-little.cabal --- a/bv-little.cabal +++ b/bv-little.cabal @@ -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 + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/src/Data/BitVector/LittleEndian.hs b/src/Data/BitVector/LittleEndian.hs --- a/src/Data/BitVector/LittleEndian.hs +++ b/src/Data/BitVector/LittleEndian.hs @@ -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) - -- | diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,6 @@ allow-newer: true -resolver: lts-10.3 +extra-deps: + - mono-traversable-keys-0.1.0 + +resolver: lts-11.0 diff --git a/test/Data/BitVector/Visual.hs b/test/Data/BitVector/Visual.hs new file mode 100644 --- /dev/null +++ b/test/Data/BitVector/Visual.hs @@ -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 + diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -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 + + diff --git a/util/Operator/Binary/Comparison.hs b/util/Operator/Binary/Comparison.hs new file mode 100644 --- /dev/null +++ b/util/Operator/Binary/Comparison.hs @@ -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 ) + ] diff --git a/util/Operator/Binary/Logical.hs b/util/Operator/Binary/Logical.hs new file mode 100644 --- /dev/null +++ b/util/Operator/Binary/Logical.hs @@ -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 -> "( "(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 diff --git a/util/Operator/Unary/Logical.hs b/util/Operator/Unary/Logical.hs new file mode 100644 --- /dev/null +++ b/util/Operator/Unary/Logical.hs @@ -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 +