Permalink
Browse files

Rewrite of the core to be more correct.

  • Loading branch information...
1 parent d4d083c commit 759114c15f12f6213b3acc7d35a8b4c6442002e1 @IreneKnapp committed Feb 10, 2012
Showing with 81 additions and 77 deletions.
  1. +81 −77 Data/Digest/Murmur3.hs
View
@@ -4,6 +4,7 @@ module Data.Digest.Murmur3
hash)
where
+import Control.Monad
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
@@ -14,6 +15,12 @@ data Hash = Hash Word64 Word64
deriving (Eq, Ord)
+newtype Identity a = MakeIdentity { identityAction :: a }
+instance Monad Identity where
+ return a = MakeIdentity a
+ (>>=) x f = f $ identityAction x
+
+
asByteString :: Hash -> ByteString
asByteString (Hash h1 h2) =
BS.pack [fromIntegral $ shiftR h1 0 .&. 0xFF,
@@ -35,82 +42,79 @@ asByteString (Hash h1 h2) =
hash :: ByteString -> Hash
-hash input =
+hash input = identityAction $ do
let c1 = 0x87c37b91114253d5
- c2 = 0x4cf5ad432745937f
+ let c2 = 0x4cf5ad432745937f
seed = 0
- loop :: (Word64, Word64, Word64, Word64, Int)
- -> Word8
- -> (Word64, Word64, Word64, Word64, Int)
- loop (h1, h2, k1, k2, fillCount) byte =
- let shiftAmount = mod (8 * fillCount) 64
- in case fillCount of
- _ | fillCount < 8 ->
- (h1, h2,
- k1 .|. (shiftL (fromIntegral byte) shiftAmount), k2,
- fillCount + 1)
- | fillCount == 15 ->
- let k1'0 = k1
- k2'0 = k2 .|. (shiftL (fromIntegral byte) shiftAmount)
- (h1'1, k1'1) = stepA1 h1 k1'0
- h1'2 = stepB1 h1'2 h2
- (h2'1, k2'1) = stepA2 h2 k1'0
- h2'2 = stepB2 h2'1 h1'2
- in (h1'2, h2'2, 0, 0, 0)
- | otherwise ->
- (h1, h2,
- k1, k2 .|. (shiftL (fromIntegral byte) shiftAmount),
- fillCount + 1)
- stepA1 h1 k1 =
- let k1'1 = k1 * c1
- k1'2 = rotateL k1'1 31
- k1'3 = k1'2 * c2
- h1'1 = xor h1 k1'3
- in (h1'1, k1'3)
- stepB1 h1 h2 =
- let h1'1 = rotateL h1 27
- h1'2 = h1'1 + h2
- h1'3 = h1'2 * 5 + 0x52dce729
- in h1'3
- stepA2 h2 k2 =
- let k2'1 = k2'0 * c2
- k2'2 = rotateL k2'1 33
- k2'3 = k2'2 * c1
- h2'0 = h2
- h2'1 = xor h2'0 k2'3
- in (h2'1, k2'3)
- stepB2 h2 h1 =
- let h2'1 = rotateL h2 31
- h2'2 = h2'1 + h1
- h2'3 = h2'2 * 5 + 0x38495ab5
- in h2'3
- finish h1 h2 =
- let h1'1 = xor h1 $ fromIntegral $ BS.length input
- h2'1 = xor h2 $ fromIntegral $ BS.length input
- h1'2 = h1'1 + h2'1
- h2'2 = h2'1 + h1'2
- h1'3 = fmix h1'2
- h2'3 = fmix h2'2
- h1'4 = h1'3 + h2'3
- h2'4 = h2'3 + h1'4
- in (h1'4, h2'4)
- fmix h =
- let h'1 = xor h (shiftR h 16)
- h'2 = h'1 * 0x85ebca6b
- h'3 = xor h'2 (shiftR h'2 13)
- h'4 = h'3 * 0xc2b2ae35
- h'5 = xor h'3 (shiftR h'4 16)
- in h'5
- (h1'0, h2'0, k1'0, k2'0, fillCount) =
- BS.foldl loop (seed, seed, 0, 0, 0) input
- (h1'1, k1'1) =
- if fillCount > 8
- then stepA1 h1'0 k1'0
- else (h1'0, k1'0)
- (h2'1, k2'1) =
- if fillCount > 0
- then stepA2 h2'0 k2'0
- else (h2'0, k2'0)
- (h1'2, h2'2) = finish h1'1 h2'1
- result = Hash h1'2 h2'2
- in result
+ totalLength = fromIntegral $ BS.length input
+ let step :: Word64 -> Word64
+ -> Word64 -> Word64
+ -> Identity (Word64, Word64)
+ step h1 h2 k1 k2 = do
+ -- First line
+ k1 <- return $ k1 * c1
+ k1 <- return $ rotateL k1 31
+ k1 <- return $ k1 * c2
+ h1 <- return $ xor h1 k1
+ -- Second line
+ h1 <- return $ rotateL h1 27
+ h1 <- return $ h1 + h2
+ h1 <- return $ h1 * 5 + 0x52dce729
+ -- Third line
+ k2 <- return $ k2 * c2
+ k2 <- return $ rotateL k2 33
+ k2 <- return $ k2 * c1
+ h2 <- return $ xor h2 k2
+ -- Fourth line
+ h2 <- return $ rotateL h2 31
+ h2 <- return $ h2 + h1
+ h2 <- return $ h2 * 5 + 0x38495ab5
+ return (h1, h2)
+ finish :: Word64 -> Word64
+ -> Word64 -> Word64
+ -> Identity Hash
+ finish h1 h2 k1 k2 = do
+ -- First line
+ k1 <- return $ k1 * c1
+ k1 <- return $ rotateL k1 31
+ k1 <- return $ k1 * c2
+ h1 <- return $ xor h1 k1
+ -- Third line
+ k2 <- return $ k2 * c2
+ k2 <- return $ rotateL k2 33
+ k2 <- return $ k2 * c1
+ h2 <- return $ xor h2 k2
+ -- Finalization
+ h1 <- return $ xor h1 totalLength
+ h2 <- return $ xor h2 totalLength
+ h1 <- mix h1
+ h2 <- mix h2
+ h1 <- return $ h1 + h2
+ h2 <- return $ h2 + h1
+ return $ Hash h1 h2
+ mix :: Word64 -> Identity Word64
+ mix k = do
+ k <- return $ xor k (shiftR k 33)
+ k <- return $ k * 0xff51afd7ed558ccd
+ k <- return $ xor k (shiftR k 33)
+ k <- return $ k * 0xc4ceb9fe1a85ec53
+ k <- return $ xor k (shiftR k 33)
+ return k
+ loop :: Word64 -> Word64 -> ByteString -> Identity Hash
+ loop h1 h2 input = do
+ (k1, input) <- takeWord64 input
+ (k2, input) <- takeWord64 input
+ if BS.null input
+ then finish h1 h2 k1 k2
+ else do
+ (h1, h2) <- step h1 h2 k1 k2
+ loop h1 h2 input
+ takeWord64 :: ByteString -> Identity (Word64, ByteString)
+ takeWord64 input = do
+ let (front, rest) = BS.splitAt 8 input
+ word <- foldM (\sum (byte, offset) -> do
+ return $ sum + (shiftL (fromIntegral byte) offset))
+ 0
+ (zip (BS.unpack front) [0, 8 .. 56])
+ return (word, rest)
+ loop seed seed input

0 comments on commit 759114c

Please sign in to comment.