diff --git a/Data/LargeWord.hs b/Data/LargeWord.hs --- a/Data/LargeWord.hs +++ b/Data/LargeWord.hs @@ -1,8 +1,16 @@ -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.LargeWord --- Copyright : (c) Dominic Steinitz 2004 - 2011 +-- Copyright : (c) Dominic Steinitz 2004 - 2014 -- License : BSD -- -- Maintainer : dominic@steinitz.org @@ -29,75 +37,75 @@ import Data.Word import Data.Bits import Numeric -import Data.Char import Control.Applicative ((<$>), (<*>)) import Data.Binary (Binary, put, get) + -- Keys have certain capabilities. class LargeWord a where largeWordToInteger :: a -> Integer integerToLargeWord :: Integer -> a - largeWordPlus :: a -> a -> a - largeWordMinus :: a -> a -> a - largeWordAnd :: a -> a -> a - largeWordOr :: a -> a -> a - largeWordShift :: a -> Int -> a - largeWordXor :: a -> a -> a - largeBitSize :: a -> Int + largeWordPlus :: a -> a -> a + largeWordMinus :: a -> a -> a + largeWordAnd :: a -> a -> a + largeWordOr :: a -> a -> a + largeWordShift :: a -> Int -> a + largeWordXor :: a -> a -> a + largeBitSize :: a -> Int -- Word8 is a key in the obvious way instance LargeWord Word8 where largeWordToInteger = toInteger integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordMinus = (-) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize + largeWordPlus = (+) + largeWordMinus = (-) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = finiteBitSize -- Word16 is a key in the obvious way instance LargeWord Word16 where largeWordToInteger = toInteger integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordMinus = (-) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize + largeWordPlus = (+) + largeWordMinus = (-) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = finiteBitSize -- Word32 is a key in the obvious way. instance LargeWord Word32 where largeWordToInteger = toInteger integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordMinus = (-) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize + largeWordPlus = (+) + largeWordMinus = (-) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = finiteBitSize -- Word64 is a key in the obvious way. instance LargeWord Word64 where largeWordToInteger = toInteger integerToLargeWord = fromInteger - largeWordPlus = (+) - largeWordMinus = (-) - largeWordAnd = (.&.) - largeWordOr = (.|.) - largeWordShift = shift - largeWordXor = xor - largeBitSize = bitSize + largeWordPlus = (+) + largeWordMinus = (-) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = finiteBitSize -- Define larger keys from smaller ones. @@ -105,16 +113,18 @@ deriving (Eq, Ord) {-# INLINE loHalf #-} -loHalf (LargeKey a b) = a +loHalf :: LargeKey a b -> a +loHalf (LargeKey a _b) = a {-# INLINE hiHalf #-} -hiHalf (LargeKey a b) = b +hiHalf :: LargeKey a b -> b +hiHalf (LargeKey _a b) = b -instance (Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) => +instance (Ord a, Bits a, FiniteBits a, Num a, LargeWord a, Bits b, FiniteBits b, Num b, LargeWord b) => LargeWord (LargeKey a b) where largeWordToInteger (LargeKey lo hi) = - largeWordToInteger lo + (2^(bitSize lo)) * largeWordToInteger hi + largeWordToInteger lo + (2^(finiteBitSize lo)) * largeWordToInteger hi integerToLargeWord x = - let (h,l) = x `quotRem` (2^(bitSize lo)) + let (h,l) = x `quotRem` (2^(finiteBitSize lo)) (lo,hi) = (integerToLargeWord l, integerToLargeWord h) in LargeKey lo hi largeWordPlus (LargeKey alo ahi) (LargeKey blo bhi) = @@ -140,27 +150,40 @@ largeWordShift w 0 = w largeWordShift (LargeKey lo hi) x = if x >= 0 - then - LargeKey (shift lo x) - (shift hi x .|. (convab $ shift lo (x - (bitSize lo)))) - else - LargeKey (shift lo x .|. (convba $ shift hi (x + (bitSize hi)))) - (shift hi x) - where convab = integerToLargeWord . largeWordToInteger - convba = integerToLargeWord . largeWordToInteger + then + if loSize <= hiSize + then + LargeKey (shift lo x) + (shift hi x .|. (shift (convab lo) (x - (finiteBitSize lo)))) + else + LargeKey (shift lo x) + (shift hi x .|. (convab (shift lo (x - (finiteBitSize lo))))) + else + if loSize <= hiSize + then + LargeKey (shift lo x .|. (convba (shift hi (x + (finiteBitSize lo))))) + (shift hi x) + else + LargeKey (shift lo x .|. (shift (convba hi) (x + (finiteBitSize lo)))) + (shift hi x) + where + loSize = finiteBitSize lo + hiSize = finiteBitSize hi + convab = integerToLargeWord . largeWordToInteger + convba = integerToLargeWord . largeWordToInteger largeBitSize ~(LargeKey lo hi) = largeBitSize lo + largeBitSize hi -instance (Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) => Show (LargeKey a b) where - showsPrec p = showInt . largeWordToInteger +instance (Ord a, Bits a, FiniteBits a, Num a, LargeWord a, Bits b, FiniteBits b, Num b, LargeWord b) => Show (LargeKey a b) where + showsPrec _p = showInt . largeWordToInteger -instance (Ord b, Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) => +instance (Ord b, Ord a, Bits a, FiniteBits a, Num a, LargeWord a, Bits b, FiniteBits b, Num b, LargeWord b) => Num (LargeKey a b) where (+) = largeWordPlus (-) = largeWordMinus (*) a b = go 0 0 where go i r - | i == bitSize r = r + | i == finiteBitSize r = r | testBit b i = go (i+1) (r + (a `shiftL` i)) | otherwise = go (i+1) r negate = id @@ -170,7 +193,7 @@ -- Larger keys are instances of Bits provided their constituents are keys. -instance (Ord a, Ord b, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) => +instance (Ord a, Ord b, Bits a, FiniteBits a, Num a, LargeWord a, Bits b, FiniteBits b, Num b, LargeWord b) => Bits (LargeKey a b) where (.&.) = largeWordAnd (.|.) = largeWordOr @@ -181,8 +204,11 @@ | i == 0 = x | i > 0 = (x `largeWordShift` i) .|. (x `largeWordShift` (i - largeBitSize x)) + | otherwise = error $ "Clearly i must be < 0, == 0 or > 0" ++ + "but ghc can't determine this" complement (LargeKey a b) = LargeKey (complement a) (complement b) bitSize = largeBitSize + bitSizeMaybe = Just . largeBitSize isSigned _ = False #if MIN_VERSION_base(4,6,0) bit = bitDefault @@ -190,8 +216,12 @@ popCount = popCountDefault #endif -instance (Ord a, Bits a, Bounded a, Integral a, LargeWord a, - Bits b, Bounded b, Integral b, LargeWord b) => +instance (LargeWord a, FiniteBits a, Ord a, Num a, + LargeWord b, FiniteBits b, Ord b, Num b) => FiniteBits (LargeKey a b) where + finiteBitSize = largeBitSize + +instance (Ord a, Bits a, FiniteBits a, Bounded a, Integral a, LargeWord a, + Bits b, FiniteBits b, Bounded b, Integral b, LargeWord b) => Bounded (LargeKey a b) where minBound = 0 maxBound = @@ -206,12 +236,12 @@ boflk :: (LargeKey a b) -> b boflk = undefined -instance (Bounded a, Bounded b, Enum b, Enum a, Ord a, Bits a, Num a, LargeWord a, Ord b, Bits b, Num b, LargeWord b) => +instance (Bounded a, Bounded b, Enum b, Enum a, Ord a, Bits a, FiniteBits a, Num a, LargeWord a, Ord b, Bits b, FiniteBits b, Num b, LargeWord b) => Integral (LargeKey a b) where toInteger = largeWordToInteger quotRem a b = let r = a - q*b - q = go 0 (bitSize a) 0 + q = go 0 (finiteBitSize a) 0 in (q,r) where -- Trivial long division @@ -225,7 +255,7 @@ v2 = ((v - b) `shiftL` 1) .|. newBit divMod = quotRem -instance (Ord a, Bits a, Num a, Bounded a, Bounded b, Enum a, Enum b, LargeWord a, Ord b, Bits b, Num b, LargeWord b) => Real (LargeKey a b) where +instance (Ord a, Bits a, FiniteBits a, Num a, Bounded a, Bounded b, Enum a, Enum b, LargeWord a, Ord b, Bits b, FiniteBits b, Num b, LargeWord b) => Real (LargeKey a b) where toRational w = toRational (fromIntegral w :: Integer) diff --git a/Tests/Properties.hs b/Tests/Properties.hs --- a/Tests/Properties.hs +++ b/Tests/Properties.hs @@ -1,8 +1,15 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Main (main) where import Test.HUnit hiding (Test) import Test.QuickCheck hiding ((.&.)) -import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework ( Test, defaultMain ) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit import Data.LargeWord @@ -11,29 +18,99 @@ import Data.Binary (encode, decode, Binary) import qualified Data.ByteString.Lazy as LZ +import Text.Printf +import Data.Word + + instance (Arbitrary a, Arbitrary b) => Arbitrary (LargeKey a b) where arbitrary = liftM2 LargeKey arbitrary arbitrary pShiftRightShiftLeft :: Word128 -> Bool pShiftRightShiftLeft x = shiftR (shiftL x 1) 1 == x .&. (fromInteger ((2^127) - 1)) +u1 :: Assertion u1 = shiftR (18446744073709551616 :: Word128) 64 @?= 1 +pQuotRem :: Word256 -> Bool +pQuotRem x = rx == fromInteger ry + where + (_qx, rx) = quotRem x 16 + (_qy, ry) = quotRem ((fromIntegral x) :: Integer) 16 + encodeDecode :: (Binary a, Binary b, Eq a, Eq b) => LargeKey a b -> Bool encodeDecode word = decode encoded == word where encoded = encode word {-# NOINLINE encoded #-} +correctEncoding :: Assertion correctEncoding = (decode . LZ.pack) - [0,0,0,0,0,0,0,0,50,89,125,125,237,119,73,240,217,12,178,101,235,8,44,221,50,122,244,125,115,181,239,78] + [0,0,0,0,0,0,0,0,50,89,125,125,237,119,73,240 + ,217,12,178,101,235,8,44,221,50,122,244,125,115,181,239,78] @?= (1234567891234567891234567812345678123456781234567812345678 :: Word256) +pRotateLeftRight :: Word256 -> Bool +pRotateLeftRight x = rotate (rotate x 8) (-8) == x + +pRepeatedShift :: Int -> Property +pRepeatedShift n = + (n >= 0) ==> (((iterate (`shift` 8) (1::Word192))!!n) == shift (1::Word192) (n*8)) + +pRepeatedShift' :: Int -> Property +pRepeatedShift' n = + (n >= 0) ==> (((iterate (`shift` 8) a)!!n) == shift a (n*8)) + +pRepeatedShift160 :: Int -> Property +pRepeatedShift160 n = + (n >= 0) ==> (((iterate (`shift` 8) (1::Word160))!!n) == shift (1::Word160) (n*8)) + +u2 :: Assertion +u2 = (2 :: LargeKey Word256 Word128) ^ 254 @?= + (fromInteger (2 :: Integer) ^ 254) + +u3 :: Assertion +u3 = rotate (rotate ((2^255) :: Word256) (1)) (-1) @?= + ((2^255) :: Word256) + +a :: Word192 +a = 0x0123456789ABCDEFFEDCBA98765432100011223344556677 + +u4 :: Assertion +u4 = shift (0x0123456789ABCDEFFEDCBA98765432100011223344556677 :: Word192) 80 @?= + (0xBA9876543210001122334455667700000000000000000000 :: Word192) + + + + +x :: Word96 +x = 0x112233445566778899AABBCC + +y :: Word128 +y = 0x112233445566778899AABBCCDDEEFF11 + +z :: Word160 +z = 0x112233445566778899AABBCCDDEEFF1122334455 + +u5 :: Assertion +u5 = shift (0x112233445566778899AABBCC :: Word96) 40 @?= + (0x66778899AABBCC0000000000 :: Word96) + +u6 :: Assertion +u6 = rotate ((2^95) :: Word96) (1) @?= 1 + tests :: [Test] tests = [ testProperty "largeword shift left then right" pShiftRightShiftLeft + , testProperty "largeword quotRem by 16" pQuotRem + , testProperty "largeword rotate left then right" pRotateLeftRight + , testProperty "largeword repeated shift vs single shift" pRepeatedShift , testCase "largeword shift 2^64 by 2^64" u1 + , testCase "largeword exponentiation 2^254" u2 + , testCase "largeword rotation by 1" u3 + , testCase "largeword shift by 80" u4 + , testCase "largeword shift by 40" u5 + , testCase "largeword rotate by 1" u6 , testCase "big-endian encoding" correctEncoding , testProperty "Word96 encode/decode loop" (encodeDecode::Word96 -> Bool) , testProperty "Word128 encode/decode loop" (encodeDecode::Word128 -> Bool) @@ -43,4 +120,5 @@ , testProperty "Word256 encode/decode loop" (encodeDecode::Word256 -> Bool) ] +main :: IO () main = defaultMain tests diff --git a/largeword.cabal b/largeword.cabal --- a/largeword.cabal +++ b/largeword.cabal @@ -1,5 +1,5 @@ name: largeword -version: 1.1.1 +version: 1.2.0 license: BSD3 copyright: Dominic Steinitz author: Dominic Steinitz