source.hs

{-# LANGUAGE BangPatterns #-}
module Main where

import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Data.ByteString as BS
import System.IO.Unsafe
import Data.ByteString.Internal as BSI
import Data.Word


import Codec.Digest.SHA
import Control.Monad
import Data.Bits
import Data.ByteString as BS(ByteString, pack, unpack)
import qualified Data.HashTable.IO as H
import Data.Int
import Data.Maybe
import Data.Word
import Data.Vector.Storable as V(Vector, last)
import Data.Vector.Storable.ByteString -- hiding (pack, unpack, ByteString)

mkWord_ :: BS.ByteString -> Word64
mkWord_ str = (V.last vec) .&. 0xFFFFFFFFFFF --0x3FFFFFFFFFFFF
    where
    vec :: Vector Word64
    vec = byteStringToVector str

mkWord :: BS.ByteString -> Word64
mkWord bs = 
        let (fp, off,len) = BSI.toForeignPtr bs
        in unsafePerformIO $ withForeignPtr fp $ \p -> do
                let dp = p `plusPtr` (off + BS.length bs - 8)
                let p64 = castPtr p :: Ptr Word64
                peek p64


mkByteString :: Word64 -> ByteString -> ByteString
mkByteString !i !sbs =
        let (fp, off,len) = BSI.toForeignPtr sbs
        in unsafePerformIO $ withForeignPtr fp $ \p -> do
                let dp = p `plusPtr` (off + BS.length sbs - 8)
                let p64 = castPtr p :: Ptr Word64
                poke p64 i
                return sbs

mkByteString_ i = BS.pack (mksplit i)
    where
--    mksplit :: Integer -> [Word8]
    mksplit 0 = []
    mksplit n = fromIntegral r : mksplit q
        where
        (q, r) = quotRem n 256

hashWord :: Word64 -> Int32
hashWord w = if testBit w 40 then v else negate v
    where
    v :: Int32
    v = fromIntegral (w .&. 0x7FFFFFFF)


type HashTable k v = H.CuckooHashTable k v

mkht :: IO (HashTable Word64 Word64)
mkht = do
     ht <- H.newSized 0xffffff
     return ht



main = do
    ht <- mkht
    let sbs = BS.pack [0,0,0,0,0,0,0,0]
    loop_ 1 ht sbs
    
  where loop_ !i ht sbs = do
        let str = mkByteString i sbs            -- 149 M
        let hv = mkWord (hash SHA256 str)   -- 1453 M
        found <- liftM isJust (H.lookup ht hv)
        when found $ do
           return ()
        -- when (hv == 1) $ Prelude.putStrLn "OK"
        {-
           iold <- liftM fromJust (H.lookup ht hv)
           let sbs2 = BS.pack [0,0,0,0,0,0,0,0]
           let sbs3 = BS.pack [0,0,0,0,0,0,0,0]
           error (show (unpack $ mkByteString i sbs2) ++ " " ++ show (unpack $ mkByteString iold sbs3 ))
        -}
        H.insert ht hv i
        if (i < 3000000) then
                loop_ (i+1) ht sbs
          else
                return ()