Rewrite of the core to be more correct.

IreneKnapp · Feb 10, 2012 · 759114c · 759114c
1 parent d4d083c
commit 759114c
Showing 1 changed file with 81 additions and 77 deletions.
diff --git a/Data/Digest/Murmur3.hs b/Data/Digest/Murmur3.hs
@@ -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)
+      totalLength = fromIntegral $ BS.length input
-           -> Word8
+  let step :: Word64 -> Word64
-           -> (Word64, Word64, Word64, Word64, Int)
+           -> Word64 -> Word64
-      loop (h1, h2, k1, k2, fillCount) byte =
+           -> Identity (Word64, Word64)
-        let shiftAmount = mod (8 * fillCount) 64
+      step h1 h2 k1 k2 = do
-        in case fillCount of
+        -- First line
-             _ | fillCount < 8 ->
+        k1 <- return $ k1 * c1
-                  (h1, h2,
+        k1 <- return $ rotateL k1 31
-                   k1 .|. (shiftL (fromIntegral byte) shiftAmount), k2,
+        k1 <- return $ k1 * c2
-                   fillCount + 1)
+        h1 <- return $ xor h1 k1
-               | fillCount == 15 ->
+        -- Second line
-                  let k1'0 = k1
+        h1 <- return $ rotateL h1 27
-                      k2'0 = k2 .|. (shiftL (fromIntegral byte) shiftAmount)
+        h1 <- return $ h1 + h2
-                      (h1'1, k1'1) = stepA1 h1 k1'0
+        h1 <- return $ h1 * 5 + 0x52dce729
-                      h1'2 = stepB1 h1'2 h2
+        -- Third line
-                      (h2'1, k2'1) = stepA2 h2 k1'0
+        k2 <- return $ k2 * c2
-                      h2'2 = stepB2 h2'1 h1'2
+        k2 <- return $ rotateL k2 33
-                  in (h1'2, h2'2, 0, 0, 0)
+        k2 <- return $ k2 * c1
-               | otherwise ->
+        h2 <- return $ xor h2 k2
-                  (h1, h2,
+        -- Fourth line
-                   k1, k2 .|. (shiftL (fromIntegral byte) shiftAmount),
+        h2 <- return $ rotateL h2 31
-                   fillCount + 1)
+        h2 <- return $ h2 + h1
-      stepA1 h1 k1 =
+        h2 <- return $ h2 * 5 + 0x38495ab5
-        let k1'1 = k1 * c1
+        return (h1, h2)
-            k1'2 = rotateL k1'1 31
+      finish :: Word64 -> Word64
-            k1'3 = k1'2 * c2
+             -> Word64 -> Word64
-            h1'1 = xor h1 k1'3
+             -> Identity Hash
-        in (h1'1, k1'3)
+      finish h1 h2 k1 k2 = do
-      stepB1 h1 h2 =
+        -- First line
-        let h1'1 = rotateL h1 27
+        k1 <- return $ k1 * c1
-            h1'2 = h1'1 + h2
+        k1 <- return $ rotateL k1 31
-            h1'3 = h1'2 * 5 + 0x52dce729
+        k1 <- return $ k1 * c2
-        in h1'3
+        h1 <- return $ xor h1 k1
-      stepA2 h2 k2 =
+        -- Third line
-        let k2'1 = k2'0 * c2
+        k2 <- return $ k2 * c2
-            k2'2 = rotateL k2'1 33
+        k2 <- return $ rotateL k2 33
-            k2'3 = k2'2 * c1
+        k2 <- return $ k2 * c1
-            h2'0 = h2
+        h2 <- return $ xor h2 k2
-            h2'1 = xor h2'0 k2'3
+        -- Finalization
-        in (h2'1, k2'3)
+        h1 <- return $ xor h1 totalLength
-      stepB2 h2 h1 =
+        h2 <- return $ xor h2 totalLength
-        let h2'1 = rotateL h2 31
+        h1 <- mix h1
-            h2'2 = h2'1 + h1
+        h2 <- mix h2
-            h2'3 = h2'2 * 5 + 0x38495ab5
+        h1 <- return $ h1 + h2
-        in h2'3
+        h2 <- return $ h2 + h1
-      finish h1 h2 =
+        return $ Hash h1 h2
-        let h1'1 = xor h1 $ fromIntegral $ BS.length input
+      mix :: Word64 -> Identity Word64
-            h2'1 = xor h2 $ fromIntegral $ BS.length input
+      mix k = do
-            h1'2 = h1'1 + h2'1
+        k <- return $ xor k (shiftR k 33)
-            h2'2 = h2'1 + h1'2
+        k <- return $ k * 0xff51afd7ed558ccd
-            h1'3 = fmix h1'2
+        k <- return $ xor k (shiftR k 33)
-            h2'3 = fmix h2'2
+        k <- return $ k * 0xc4ceb9fe1a85ec53
-            h1'4 = h1'3 + h2'3
+        k <- return $ xor k (shiftR k 33)
-            h2'4 = h2'3 + h1'4
+        return k
-        in (h1'4, h2'4)
+      loop :: Word64 -> Word64 -> ByteString -> Identity Hash
-      fmix h =
+      loop h1 h2 input = do
-        let h'1 = xor h (shiftR h 16)
+        (k1, input) <- takeWord64 input
-            h'2 = h'1 * 0x85ebca6b
+        (k2, input) <- takeWord64 input
-            h'3 = xor h'2 (shiftR h'2 13)
+        if BS.null input
-            h'4 = h'3 * 0xc2b2ae35
+          then finish h1 h2 k1 k2
-            h'5 = xor h'3 (shiftR h'4 16)
+          else do
-        in h'5
+            (h1, h2) <- step h1 h2 k1 k2
-      (h1'0, h2'0, k1'0, k2'0, fillCount) =
+            loop h1 h2 input
-        BS.foldl loop (seed, seed, 0, 0, 0) input
+      takeWord64 :: ByteString -> Identity (Word64, ByteString)
-      (h1'1, k1'1) =
+      takeWord64 input = do
-        if fillCount > 8
+        let (front, rest) = BS.splitAt 8 input
-          then stepA1 h1'0 k1'0
+        word <- foldM (\sum (byte, offset) -> do
-          else (h1'0, k1'0)
+                         return $ sum + (shiftL (fromIntegral byte) offset))
-      (h2'1, k2'1) =
+                      0
-        if fillCount > 0
+                      (zip (BS.unpack front) [0, 8 .. 56])
-          then stepA2 h2'0 k2'0
+        return (word, rest)
-          else (h2'0, k2'0)
+  loop seed seed input
-      (h1'2, h2'2) = finish h1'1 h2'1
-      result = Hash h1'2 h2'2
- in result