diff --git a/demo-ints/Main.hs b/demo-ints/Main.hs deleted file mode 100644 --- a/demo-ints/Main.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Main where - -import System.Random (RandomGen, mkStdGen, randomR) - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import qualified Data.PerfectHash.Construction as Construction -import qualified Data.PerfectHash.Hashing as Hashing -import qualified Data.PerfectHash.Lookup as Lookup -import qualified Data.Vector.Unboxed as Vector -import Exercise (Atom (Atom)) -import qualified Exercise - - -valueCount = 500000 - -randomRange = (0, Hashing.mask32bits) - - -data RandIntAccum t = RandIntAccum - t -- ^ random number generator - Int -- ^ max count - IntSet -- ^ accumulated unique random numbers - - --- | Since computing the size of the set is O(N), we --- maintain the count separately. -getUniqueRandomIntegers :: RandomGen t => RandIntAccum t -> IntSet -getUniqueRandomIntegers (RandIntAccum std_gen count current_set) = - - if count == 0 - then current_set - else getUniqueRandomIntegers newstate - - where - (next_int, next_std_gen) = randomR randomRange std_gen - - a = RandIntAccum next_std_gen - newstate = if IntSet.member next_int current_set - then a count current_set - else a (count - 1) (IntSet.insert next_int current_set) - - -intMapTuples :: [(Atom Int, Int)] -intMapTuples = zip (map Atom random_ints) [1..] - where - seed_value = RandIntAccum (mkStdGen 0) valueCount IntSet.empty - random_ints = IntSet.toList $ getUniqueRandomIntegers seed_value - - -main = do - - putStrLn $ unwords ["Keys size:", show $ length intMapTuples] - - let lookup_table = Construction.createMinimalPerfectHash intMapTuples - - putStrLn $ unwords [ - "Finished computing lookup table with" - , show $ Lookup.size lookup_table - , "entries." - ] - - let direct_mapping_nonces = Vector.filter (< 0) $ Lookup.nonces lookup_table - - putStrLn $ unwords [ - "There were" - , show $ Vector.length direct_mapping_nonces - , "lookup entries with direct mappings." - ] - - Exercise.eitherExit $ Exercise.testLookups lookup_table intMapTuples diff --git a/demo-strings/Main.hs b/demo-strings/Main.hs deleted file mode 100644 --- a/demo-strings/Main.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Main where - -import Control.Monad (when) - -import qualified Data.PerfectHash.Construction as Construction -import qualified Data.PerfectHash.Lookup as Lookup -import qualified Exercise - - -enableDebug = False - -dictionaryPath = "/usr/share/dict/words" - - -main = do - - word_index_tuples <- Exercise.wordsFromFile dictionaryPath - - putStrLn $ unwords ["Words size:", show $ length word_index_tuples] - - let lookup_table = Construction.createMinimalPerfectHash word_index_tuples - - putStrLn $ unwords [ - "Finished computing lookup table with" - , show $ Lookup.size lookup_table - , "entries." - ] - - when enableDebug $ do - putStrLn $ unwords ["Vector G:", show $ Lookup.nonces lookup_table] - putStrLn $ unwords ["Vector V:", show $ Lookup.values lookup_table] - - Exercise.eitherExit $ Exercise.testLookups lookup_table word_index_tuples diff --git a/demo/Ints/Main.hs b/demo/Ints/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Ints/Main.hs @@ -0,0 +1,66 @@ +module Main where + +import System.Random (RandomGen, mkStdGen, random) + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import qualified Data.PerfectHash.Construction as Construction +import qualified Data.PerfectHash.Lookup as Lookup +import qualified Data.Vector.Unboxed as Vector +import qualified Exercise + + +valueCount = 250000 + + +data RandIntAccum t = RandIntAccum + t -- ^ random number generator + Int -- ^ max count + IntSet -- ^ accumulated unique random numbers + + +-- | Since computing the size of the set is O(N), we +-- maintain the count separately. +getUniqueRandomIntegers :: RandomGen t => RandIntAccum t -> IntSet +getUniqueRandomIntegers (RandIntAccum std_gen count current_set) = + + if count == 0 + then current_set + else getUniqueRandomIntegers newstate + + where + (next_int, next_std_gen) = random std_gen + + a = RandIntAccum next_std_gen + newstate = if IntSet.member next_int current_set + then a count current_set + else a (count - 1) (IntSet.insert next_int current_set) + + +intMapTuples :: [(Int, Int)] +intMapTuples = zip random_ints [1..] + where + seed_value = RandIntAccum (mkStdGen 0) valueCount IntSet.empty + random_ints = IntSet.toList $ getUniqueRandomIntegers seed_value + + +main = do + putStrLn $ unwords ["Keys size:", show $ length intMapTuples] + + let lookup_table = Construction.createMinimalPerfectHash intMapTuples + + putStrLn $ unwords [ + "Finished computing lookup table with" + , show $ Lookup.size lookup_table + , "entries." + ] + + let direct_mapping_nonces = Vector.filter (< 0) $ Lookup.nonces lookup_table + + putStrLn $ unwords [ + "There were" + , show $ Vector.length direct_mapping_nonces + , "lookup entries with direct mappings." + ] + + Exercise.eitherExit $ Exercise.testLookups lookup_table intMapTuples diff --git a/demo/Strings/Main.hs b/demo/Strings/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Strings/Main.hs @@ -0,0 +1,33 @@ +module Main where + +import Control.Monad (when) + +import qualified Data.PerfectHash.Construction as Construction +import qualified Data.PerfectHash.Lookup as Lookup +import qualified Exercise + + +enableDebug = False + +dictionaryPath = "/usr/share/dict/words" + + +main = do + + word_index_tuples <- Exercise.wordsFromFile dictionaryPath + + putStrLn $ unwords ["Words size:", show $ length word_index_tuples] + + let lookup_table = Construction.createMinimalPerfectHash word_index_tuples + + putStrLn $ unwords [ + "Finished computing lookup table with" + , show $ Lookup.size lookup_table + , "entries." + ] + + when enableDebug $ do + putStrLn $ unwords ["Vector G:", show $ Lookup.nonces lookup_table] + putStrLn $ unwords ["Vector V:", show $ Lookup.values lookup_table] + + Exercise.eitherExit $ Exercise.testLookups lookup_table word_index_tuples diff --git a/perfect-hash-generator.cabal b/perfect-hash-generator.cabal --- a/perfect-hash-generator.cabal +++ b/perfect-hash-generator.cabal @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.17.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: fc4c141081795a861f9768551508e74ca60a61d1b8061163c7ee9567b112173c name: perfect-hash-generator -version: 0.1.0.4 +version: 0.2.0.0 synopsis: Perfect minimal hashing implementation in native Haskell description: A for a set @S@ is a hash function that maps distinct elements in @S@ to a set of integers, with __no collisions__. A is a perfect hash function that maps @n@ keys to @n@ __consecutive__ integers, e.g. the numbers from @0@ to @n-1@. . @@ -16,14 +18,13 @@ This implementation was adapted from . . = Usage - The library is written generically to hash both strings and raw integers. Integers should be wrapped in the @Atom@ newtype: - . + The library is written generically to hash both strings and raw integers according to the . Integers are split by octets before hashing. > import Data.PerfectHash.Construction (createMinimalPerfectHash) > > tuples = [ - > (Atom 1000, 1) - > , (Atom 5555, 2) - > , (Atom 9876, 3) + > (1000, 1) + > , (5555, 2) + > , (9876, 3) > ] > > lookup_table = createMinimalPerfectHash tuples @@ -56,55 +57,72 @@ src ghc-options: -fwarn-tabs -W build-depends: - base >= 4.5 && <= 4.10 - , unordered-containers + base >=4.5 && <=4.10 + , binary + , bytestring , containers , data-ordlist , directory , filepath , hashable + , text + , unordered-containers , vector exposed-modules: Data.PerfectHash.Construction Data.PerfectHash.Hashing Data.PerfectHash.Lookup + other-modules: + Paths_perfect_hash_generator default-language: Haskell2010 executable hash-perfectly-ints-demo - main-is: Main.hs + main-is: Ints/Main.hs hs-source-dirs: - demo-ints + demo test ghc-options: -fwarn-tabs -W build-depends: - base >= 4.5 && <= 4.10 - , unordered-containers + base >=4.5 && <=4.10 + , binary + , bytestring + , containers + , hashable + , optparse-applicative , perfect-hash-generator , random - , optparse-applicative + , text + , unordered-containers , vector - , hashable - , containers other-modules: + Strings.Main Exercise + Main + Paths_perfect_hash_generator default-language: Haskell2010 executable hash-perfectly-strings-demo - main-is: Main.hs + main-is: Strings/Main.hs hs-source-dirs: - demo-strings + demo test ghc-options: -fwarn-tabs -W build-depends: - base >= 4.5 && <= 4.10 - , unordered-containers + base >=4.5 && <=4.10 + , binary + , bytestring + , hashable + , optparse-applicative , perfect-hash-generator , random - , optparse-applicative + , text + , unordered-containers , vector - , hashable other-modules: + Ints.Main Exercise + Main + Paths_perfect_hash_generator default-language: Haskell2010 test-suite regression-tests @@ -114,15 +132,19 @@ test ghc-options: -fwarn-tabs -W build-depends: - base >= 4.5 && <= 4.10 - , unordered-containers - , perfect-hash-generator + HUnit + , base >=4.5 && <=4.10 + , binary + , bytestring + , hashable , optparse-applicative + , perfect-hash-generator , test-framework - , HUnit , test-framework-hunit - , hashable + , text + , unordered-containers , vector other-modules: Exercise + Paths_perfect_hash_generator default-language: Haskell2010 diff --git a/src/Data/PerfectHash/Construction.hs b/src/Data/PerfectHash/Construction.hs --- a/src/Data/PerfectHash/Construction.hs +++ b/src/Data/PerfectHash/Construction.hs @@ -12,12 +12,14 @@ import Control.Arrow (second) import Control.Monad (join) +import Data.Foldable (foldl') import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.List (sortOn) +import Data.Ord (Down (Down)) import qualified Data.Vector.Unboxed as Vector import qualified Data.PerfectHash.Hashing as Hashing @@ -32,13 +34,13 @@ } +emptyLookupTable :: LookupTable a emptyLookupTable = NewLookupTable HashMap.empty HashMap.empty class Defaultable a where getDefault :: a - instance Defaultable Int where getDefault = 0 @@ -58,14 +60,14 @@ -- for every element in this multi-entry bucket, for the given nonce. -- -- Return a Nothing for a slot if it collides. -attemptNonceRecursive :: (Foldable f, Hashing.ToNumeric a) => +attemptNonceRecursive :: Hashing.ToHashableChunks a => HashMapAndSize Int b - -> Int - -> IntSet - -> [f a] + -> Int -- ^ nonce + -> IntSet -- ^ occupied slots + -> [a] -- ^ keys -> [Maybe Int] attemptNonceRecursive _ _ _ [] = [] -attemptNonceRecursive values_and_size nonce occupied_slots (x:xs) = +attemptNonceRecursive values_and_size nonce occupied_slots (current_key:remaining_bucket_keys) = if cannot_use_slot then pure Nothing @@ -73,7 +75,7 @@ where HashMapAndSize values size = values_and_size - slot = Hashing.hashToSlot nonce x size + slot = Hashing.hashToSlot nonce current_key size cannot_use_slot = IntSet.member slot occupied_slots || HashMap.member slot values @@ -81,7 +83,7 @@ values_and_size nonce (IntSet.insert slot occupied_slots) - xs + remaining_bucket_keys -- | Repeatedly try different values of the nonce until we find a hash function @@ -89,10 +91,10 @@ -- -- Keeps trying forever, incrementing the candidate nonce by @1@ each time. -- Theoretically we're guaranteed to eventually find a solution. -findNonceForBucket :: (Foldable f, Hashing.ToNumeric a) => - Int +findNonceForBucket :: Hashing.ToHashableChunks a => + Int -- ^ nonce to attempt -> HashMapAndSize Int b - -> [f a] + -> [a] -- ^ colliding keys for this bucket -> ([Int], Int) findNonceForBucket nonce_attempt values_and_size bucket = @@ -109,12 +111,12 @@ -- | Searches for a nonce for this bucket, starting with the value @1@, -- until one is found that results in no collisions for both this bucket -- and all previous buckets. -handleMultiBuckets :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => - HashMapAndSize (f a) b - -> (Int, [f a]) +handleMultiBuckets :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => + HashMapAndSize a b -> LookupTable b + -> (Int, [a]) -> LookupTable b -handleMultiBuckets sized_words_dict (computed_hash, bucket) old_lookup_table = +handleMultiBuckets sized_words_dict old_lookup_table (computed_hash, bucket) = NewLookupTable new_g new_values where HashMapAndSize words_dict size = sized_words_dict @@ -132,10 +134,10 @@ -- | This function exploits the sorted structure of the list twice, -- first by skimming the multi-entry buckets, then by skimming -- the single-entry buckets and dropping the empty buckets. -findCollisionNonces :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => - HashMapAndSize (f a) b - -> [(Int, [f a])] - -> (LookupTable b, [(Int, f a)]) +findCollisionNonces :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => + HashMapAndSize a b + -> [(Int, [a])] + -> (LookupTable b, [(Int, a)]) findCollisionNonces sized_words_dict sorted_bucket_hash_tuples = (lookup_table, remaining_words) @@ -146,18 +148,22 @@ -- we know there are no more collision buckets. (multi_entry_buckets, single_or_fewer_buckets) = span ((> 1) . length . snd) sorted_bucket_hash_tuples - lookup_table = foldr (handleMultiBuckets sized_words_dict) emptyLookupTable multi_entry_buckets + -- XXX Using 'foldl' rather than 'foldr' is crucial here, given the order + -- of the buckets. 'foldr' would actually try to place the smallest buckets + -- first, making it improbable that the large buckets will be placeable, + -- and potentially resulting in an infinite loop. + lookup_table = foldl' (handleMultiBuckets sized_words_dict) emptyLookupTable multi_entry_buckets single_entry_buckets = takeWhile (not . null . snd) single_or_fewer_buckets remaining_words = map (second head) single_entry_buckets -- | Sort buckets by descending size -preliminaryBucketPlacement :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => - HashMap (f a) b - -> [(Int, [f a])] +preliminaryBucketPlacement :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => + HashMap a b + -> [(Int, [a])] preliminaryBucketPlacement words_dict = - sortOn (negate . length . snd) bucket_hash_tuples + sortOn (Down . length . snd) bucket_hash_tuples where size = HashMap.size words_dict slot_key_pairs = deriveTuples (\k -> Hashing.hashToSlot 0 k size) $ HashMap.keys words_dict @@ -171,8 +177,8 @@ -- The values may be of arbitrary type. -- -- /__N.b.__/ It is assumed that the input tuples list has no duplicate keys. -createMinimalPerfectHash :: (Vector.Unbox b, Defaultable b, Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => - [(f a, b)] +createMinimalPerfectHash :: (Vector.Unbox b, Defaultable b, Hashing.ToHashableChunks a, Eq a, Hashable a) => + [(a, b)] -- ^ key-value pairs -> Lookup.LookupTable b createMinimalPerfectHash tuples = convertToVector $ NewLookupTable final_g final_values diff --git a/src/Data/PerfectHash/Hashing.hs b/src/Data/PerfectHash/Hashing.hs --- a/src/Data/PerfectHash/Hashing.hs +++ b/src/Data/PerfectHash/Hashing.hs @@ -1,37 +1,47 @@ {-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + + -- | Implements the specialized hash function for -- this perfect hashing algorithm. module Data.PerfectHash.Hashing where -import Data.Bits (xor, (.&.)) -import Data.Char (ord) +import Data.Binary (encode) +import Data.Bits (xor, (.&.)) +import Data.ByteString.Lazy (unpack) +import Data.Char (ord) +import Data.Text (Text) +import qualified Data.Text as T -- | This choice of prime number was taken from the Python implementation -- on . +primeFNV :: Int primeFNV = 0x01000193 +mask32bits :: Int mask32bits = 0xffffffff --- | A Foldable of any data type may be hashed, so long as it implements --- an instance of this class. -class ToNumeric a where - toNum :: a -> Int +class ToHashableChunks a where + toHashableChunks :: a -> [Int] --- | The numeric value of a character is simply its ordinal value. -instance ToNumeric Char where - toNum = ord +instance ToHashableChunks Int where + toHashableChunks = map fromIntegral . unpack . encode -instance ToNumeric Int where - toNum = id +instance ToHashableChunks Text where + toHashableChunks = map ord . T.unpack +instance ToHashableChunks String where + toHashableChunks = map ord -hashToSlot :: (Foldable f, ToNumeric a) => + +hashToSlot :: ToHashableChunks a => Int -- ^ nonce - -> f a -- ^ key + -> a -- ^ key -> Int -- ^ array size -> Int hashToSlot nonce key size = hash nonce key `mod` size @@ -49,13 +59,17 @@ -- The interface is comparable to the -- -- function from the @hashable@ package. -hash :: (Foldable f, ToNumeric a) => Int -> f a -> Int +hash :: ToHashableChunks a => + Int -- ^ nonce + -> a -- ^ key + -> Int hash nonce = - foldl combine d -- NOTE: This must be 'foldl', not 'foldr' + -- NOTE: This must be 'foldl', not 'foldr' + foldl combine d . toHashableChunks where d = if nonce == 0 then primeFNV else nonce - combine acc = (.&. mask32bits) . (* primeFNV) . xor acc . toNum + combine acc = (.&. mask32bits) . (* primeFNV) . xor acc diff --git a/src/Data/PerfectHash/Lookup.hs b/src/Data/PerfectHash/Lookup.hs --- a/src/Data/PerfectHash/Lookup.hs +++ b/src/Data/PerfectHash/Lookup.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK prune #-} -- | Note that what is referred to as a \"nonce\" in this library may be --- referred to by some as a \"salt\". +-- equivalently described as a \"salt\" by some. module Data.PerfectHash.Lookup ( LookupTable (LookupTable) , nonces @@ -46,6 +46,7 @@ size = Vector.length . values +encodeDirectEntry :: Int -> Int encodeDirectEntry = subtract 1 . negate @@ -68,9 +69,9 @@ -- respect to the length of the 'values' array. -- -- 3. Use the result of (2) as the index into the 'values' array. -lookupPerfect :: (Foldable f, Hashing.ToNumeric a, Vector.Unbox b) => +lookupPerfect :: (Hashing.ToHashableChunks a, Vector.Unbox b) => LookupTable b - -> f a + -> a -- ^ key -> b lookupPerfect lookup_table key = diff --git a/test/Exercise.hs b/test/Exercise.hs --- a/test/Exercise.hs +++ b/test/Exercise.hs @@ -1,30 +1,16 @@ -{-# LANGUAGE DeriveGeneric #-} - module Exercise where import Control.Monad (unless) import Data.Foldable (traverse_) -import Data.Hashable (Hashable) import qualified Data.Vector.Unboxed as Vector -import GHC.Generics (Generic) import qualified Data.PerfectHash.Hashing as Hashing import qualified Data.PerfectHash.Lookup as Lookup --- | Wrapper to allow hashing of an integer -newtype Atom a = Atom {value :: a} deriving (Eq, Show, Generic) - -instance Hashable a => Hashable (Atom a) - - -instance Foldable Atom where - foldr f acc (Atom val) = f val acc - - -testLookups :: (Show b, Eq b, Show (f a), Foldable f, Hashing.ToNumeric a, Vector.Unbox b) => +testLookups :: (Show b, Eq b, Show a, Hashing.ToHashableChunks a, Vector.Unbox b) => Lookup.LookupTable b - -> [(f a, b)] + -> [(a, b)] -> Either String () testLookups lookup_table = traverse_ check_entry diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Data.Either (isRight) import Data.Hashable (Hashable) +import Data.Text (Text) import qualified Data.Vector.Unboxed as Vector import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase) @@ -9,35 +12,46 @@ import qualified Data.PerfectHash.Construction as Construction import qualified Data.PerfectHash.Hashing as Hashing -import Exercise (Atom (Atom)) import qualified Exercise -testHashComputation :: String -> Int -> IO () +testHashComputation :: (Hashing.ToHashableChunks a, Show a) => + a + -> Int + -> IO () testHashComputation key val = assertEqual error_message val computed_hash where - error_message = unwords ["Incorrect hash computation of", key] + error_message = unwords ["Incorrect hash computation of", show key] computed_hash = Hashing.hash 0 key -wordIndexTuples = [ - ("apple", 1 :: Int) - , ("banana", 2) - , ("carrot", 3) - ] +wordIndexTuplesString :: [(String, Int)] +wordIndexTuplesString = zip [ + "apple" + , "banana" + , "carrot" + ] [1..] -intMapTuples :: [(Atom Int, Int)] +wordIndexTuplesText :: [(Text, Int)] +wordIndexTuplesText = zip [ + "alpha" + , "beta" + , "gamma" + ] [1..] + + +intMapTuples :: [(Int, Int)] intMapTuples = [ - (Atom 1000, 1) - , (Atom 5555, 2) - , (Atom 9876, 3) + (1000, 1) + , (5555, 2) + , (9876, 3) ] -testHashLookups :: (Show (f a), Show b, Eq b, Vector.Unbox b, Construction.Defaultable b, Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => - [(f a, b)] -> IO () +testHashLookups :: (Show a, Show b, Eq b, Vector.Unbox b, Construction.Defaultable b, Hashing.ToHashableChunks a, Eq a, Hashable a) => + [(a, b)] -> IO () testHashLookups word_index_tuples = assertBool "Perfect hash lookups failed to match the input" $ isRight test_result_either where @@ -47,10 +61,12 @@ tests = [ testGroup "Hash computation" [ - testCase "compute-hash1" $ testHashComputation "blarg" 3322346319 + testCase "compute-string-hash" $ testHashComputation ("blarg" :: String) 3322346319 + , testCase "compute-int-hash" $ testHashComputation (70000 :: Int) 4169891409 ] , testGroup "Hash lookups" [ - testCase "word-lookups" $ testHashLookups wordIndexTuples + testCase "word-lookups-string" $ testHashLookups wordIndexTuplesString + , testCase "word-lookups-text" $ testHashLookups wordIndexTuplesText , testCase "int-lookups" $ testHashLookups intMapTuples ] ]