diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,9 @@ +## 0.2.0.1 (Feb. 2018) + +* Fixed a foldr vs. foldl bug with algorithmic implications + +## 1.0.0 (June 2022) + +* Changed input type from `HashMap` to `Map` +* Removed superfluous internal map lookups by threading values alongside keys throughout the algorithm +* Used newtypes internally for algorithmic clarity diff --git a/demo/ints/Main.hs b/demo/ints/Main.hs --- a/demo/ints/Main.hs +++ b/demo/ints/Main.hs @@ -1,53 +1,60 @@ module Main where -import System.Random (RandomGen, mkStdGen, random) +import qualified Data.Vector as Vector +import System.CPUTime +import Text.Printf +import Options.Applicative -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -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 Data.PerfectHash.Types.Nonces as Nonces + import qualified Exercise -valueCount = 250000 +defaultValueCount :: Int +defaultValueCount = 250000 -data RandIntAccum t = RandIntAccum - t -- ^ random number generator - Int -- ^ max count - IntSet -- ^ accumulated unique random numbers +data DemoOptions = DemoOptions { + valueCount :: Int + , debugEnabled :: Bool + } --- | 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) = +optionsParser :: Parser DemoOptions +optionsParser = DemoOptions + <$> option auto + ( long "count" + <> help "Value count" + <> value defaultValueCount) + <*> switch + ( long "debug" + <> help "enable debug mode") - if count == 0 - then current_set - else getUniqueRandomIntegers newstate +main :: IO () +main = run =<< execParser opts 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) + opts = info (optionsParser <**> helper) + ( fullDesc + <> progDesc "Test the hashing on integers" + <> header "int test" ) -intMapTuples :: HashMap Int Int -intMapTuples = HashMap.fromList $ zip random_ints [1..] - where - seed_value = RandIntAccum (mkStdGen 0) valueCount IntSet.empty - random_ints = IntSet.toList $ getUniqueRandomIntegers seed_value +doTimed :: Either String a -> IO Double +doTimed go = do + start <- getCPUTime + Exercise.eitherExit go + end <- getCPUTime + return $ fromIntegral (end - start) / (10^12) -main = do - putStrLn $ unwords ["Keys size:", show $ length intMapTuples] +run (DemoOptions valueCount _debugEnabled) = do + putStrLn $ unwords [ + "Keys size:" + , show $ length intMapTuples + ] let lookup_table = Construction.createMinimalPerfectHash intMapTuples @@ -57,12 +64,27 @@ , "entries." ] - let direct_mapping_nonces = Vector.filter (< 0) $ Lookup.nonces lookup_table + let direct_mapping_nonces = Vector.filter Nonces.isDirectSlot $ Lookup.nonces lookup_table + direct_mapping_count = Vector.length direct_mapping_nonces + total_count = length intMapTuples + direct_mapping_percentage = 100 * direct_mapping_count `div` total_count putStrLn $ unwords [ "There were" , show $ Vector.length direct_mapping_nonces + , "(" ++ show direct_mapping_percentage ++ "%)" , "lookup entries with direct mappings." ] - Exercise.eitherExit $ Exercise.testLookups lookup_table intMapTuples + putStrLn "Testing perfect hash lookups..." + diff1 <- doTimed $ Exercise.testPerfectLookups lookup_table intMapTuples + putStrLn $ printf "Computation time: %0.3f sec\n" diff1 + + putStrLn "Testing HashMap lookups..." + diff2 <- doTimed $ Exercise.testHashMapLookups intMapTuples + putStrLn $ printf "Computation time: %0.3f sec\n" diff2 + + putStrLn "Done." + + where + intMapTuples = Exercise.mkIntMapTuples valueCount diff --git a/demo/strings/Main.hs b/demo/strings/Main.hs --- a/demo/strings/Main.hs +++ b/demo/strings/Main.hs @@ -1,25 +1,54 @@ module Main where import Control.Monad (when) -import qualified Data.HashMap.Strict as HashMap - +import qualified Data.Map as Map +import Options.Applicative import qualified Data.PerfectHash.Construction as Construction import qualified Data.PerfectHash.Lookup as Lookup import qualified Exercise -enableDebug = False +defaultDictionaryPath :: FilePath +defaultDictionaryPath = "/usr/share/dict/words" -dictionaryPath = "/usr/share/dict/words" +data DemoOptions = DemoOptions { + dictionaryPath :: FilePath + , debugEnabled :: Bool + } -main = do +optionsParser :: Parser DemoOptions +optionsParser = DemoOptions + <$> strOption + ( long "dictionary" + <> help "Dictionary path" + <> value defaultDictionaryPath) + <*> switch + ( long "debug" + <> help "enable debug mode") + + +main :: IO () +main = run =<< execParser opts + where + opts = info (optionsParser <**> helper) + ( fullDesc + <> progDesc "Test the hashing on strings" + <> header "string test" ) + + +run (DemoOptions dictionaryPath enableDebug) = do + word_index_tuples <- Exercise.wordsFromFile dictionaryPath - putStrLn $ unwords ["Words size:", show $ length word_index_tuples] + putStrLn $ unwords [ + "Words size:" + , show $ length word_index_tuples + ] - let lookup_table = Construction.createMinimalPerfectHash $ HashMap.fromList word_index_tuples + let lookup_table = Construction.createMinimalPerfectHash $ + Map.fromList word_index_tuples putStrLn $ unwords [ "Finished computing lookup table with" @@ -31,4 +60,5 @@ putStrLn $ unwords ["Vector G:", show $ Lookup.nonces lookup_table] putStrLn $ unwords ["Vector V:", show $ Lookup.values lookup_table] - Exercise.eitherExit $ Exercise.testLookups lookup_table $ HashMap.fromList word_index_tuples + Exercise.eitherExit $ Exercise.testPerfectLookups lookup_table $ + Map.fromList word_index_tuples diff --git a/docs/images/algorithm-diagram.svg b/docs/images/algorithm-diagram.svg new file mode 100644 --- /dev/null +++ b/docs/images/algorithm-diagram.svg @@ -0,0 +1,3 @@ + +value table33333intermediate tableblahbarfoo diff --git a/perfect-hash-generator.cabal b/perfect-hash-generator.cabal --- a/perfect-hash-generator.cabal +++ b/perfect-hash-generator.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 5294c49846f25b6cb06c72295e7bffbdf2443d5e99a7f79652dd5176510b48b5 name: perfect-hash-generator -version: 0.2.0.6 +version: 1.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@. . @@ -13,7 +13,7 @@ . It is intended primarily for generating C code for embedded applications (compare to @@). The output of this tool is a pair of arrays that can be included in generated C code for __ hash tables__. . - Though lookups also perform reasonably well for Haskell applications, it hasn't been benchmarked thorougly with respect to other data structures. + Though conceivably this data structure could be used directly in Haskell applications as a read-only hash table, it is not recommened, as lookups are about 10x slower than . . This implementation was adapted from . . @@ -21,7 +21,7 @@ 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) - > import qualified Data.HashMap.Strict as HashMap + > import qualified Data.Map as Map > > tuples = [ > (1000, 1) @@ -29,10 +29,11 @@ > , (9876, 3) > ] > - > lookup_table = createMinimalPerfectHash $ HashMap.fromList tuples + > lookup_table = createMinimalPerfectHash $ Map.fromList tuples . Generation of C code based on the arrays in @lookup_table@ is left as an exercise to the reader. Algorithm documentation in the "Data.PerfectHash.Hashing" and "Data.PerfectHash.Lookup" modules will be helpful. . + = Demo See the @hash-perfectly-strings-demo@ and @hash-perfectly-ints-demo@, as well as the test suite, for working examples. . > $ stack build @@ -45,13 +46,23 @@ license: Apache-2.0 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 +extra-source-files: + changelog.md +extra-doc-files: + docs/images/algorithm-diagram.svg source-repository head type: git location: https://github.com/kostmo/perfect-hash-generator library + exposed-modules: + Data.PerfectHash.Construction + Data.PerfectHash.Hashing + Data.PerfectHash.Lookup + Data.PerfectHash.Types.Nonces + other-modules: + Paths_perfect_hash_generator hs-source-dirs: src ghc-options: -fwarn-tabs -W @@ -60,23 +71,22 @@ , binary , bytestring , containers + , data-default , data-ordlist , directory , filepath , hashable + , sorted-list , 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 + other-modules: + Exercise + Paths_perfect_hash_generator hs-source-dirs: demo/ints test-utils @@ -93,13 +103,13 @@ , text , unordered-containers , vector - other-modules: - Exercise - Paths_perfect_hash_generator default-language: Haskell2010 executable hash-perfectly-strings-demo main-is: Main.hs + other-modules: + Exercise + Paths_perfect_hash_generator hs-source-dirs: demo/strings test-utils @@ -108,6 +118,7 @@ base >=4.5 && <5 , binary , bytestring + , containers , hashable , optparse-applicative , perfect-hash-generator @@ -115,14 +126,14 @@ , text , unordered-containers , vector - other-modules: - Exercise - Paths_perfect_hash_generator default-language: Haskell2010 test-suite regression-tests type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Exercise + Paths_perfect_hash_generator hs-source-dirs: test test-utils @@ -132,15 +143,15 @@ , base >=4.5 && <5 , binary , bytestring + , containers + , data-default , hashable , optparse-applicative , perfect-hash-generator + , random , test-framework , test-framework-hunit , 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 @@ -2,229 +2,416 @@ -- | Constructs a minimal perfect hash from a map of key-value pairs. -- --- Implementation was adapted from --- . +-- = Overview of algorithm +-- A two-input hash function @F(nonce, key)@ is used. -- +-- 1. Keys are hashed into buckets for the first round with a nonce of @0@. +-- 1. Iterating over each bucket of size @>= 2@ in order of decreasing size, keep +-- testing different nonce values until all members +-- of the bucket fall into open slots in the final array. +-- When a successful nonce is found, write it to the \"intermediate\" array +-- at the bucket's position. +-- 1. For each bucket of size @1@, select an arbitrary open slot in the final +-- array, and write the slot's +-- index (after negation and subtracting @1@) to the intermediate array. +-- +-- According to , +-- the algorithm is assured to run in linear time. +-- +-- = Provenance +-- This implementation was adapted from +-- . -- A refactoring of that Python implementation may be found -- . --- This Haskell implementation is transliterated from that refactoring. +-- This Haskell implementation was transliterated and evolved from that refactoring. +-- module Data.PerfectHash.Construction ( createMinimalPerfectHash - , Defaultable ) where -import Control.Arrow (second) +import Control.Arrow (first) +import Data.Tuple (swap) +import Data.Default (Default, def) import Control.Monad (join) +import Data.SortedList (SortedList, toSortedList, fromSortedList) 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.IntSet (IntSet) +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Function (on) import Data.Ord (Down (Down)) -import qualified Data.Vector.Unboxed as Vector +import qualified Data.Vector as Vector +import qualified Data.Maybe as Maybe import qualified Data.PerfectHash.Hashing as Hashing -import qualified Data.PerfectHash.Lookup as Lookup +import Data.PerfectHash.Hashing (Hash, ArraySize) +import qualified Data.PerfectHash.Lookup as Lookup +import Data.PerfectHash.Types.Nonces (Nonce) +import qualified Data.PerfectHash.Types.Nonces as Nonces --- | NOTE: Vector may peform better for these structures, but +data AlgorithmParams = AlgorithmParams { + getNextNonceCandidate :: Nonce -> Nonce + , startingNonce :: Nonce + } + + +data NonceOrDirect = + WrappedNonce Nonce + | DirectEntry Hashing.SlotIndex + +instance Default NonceOrDirect where + def = WrappedNonce def + + +-- | NOTE: Vector might perform better for these structures, but -- the code may not be as clean. data LookupTable a = NewLookupTable { - redirs :: HashMap Int Int - , vals :: HashMap Int a + nonces :: IntMap NonceOrDirect + , vals :: IntMap a } +data SingletonBucket a = SingletonBucket Hash a + deriving Eq + + +data HashBucket a = HashBucket { + _hashVal :: Hash + , bucketMembers :: [a] + } + +instance Eq (HashBucket a) where + (==) = (==) `on` (Down . length . bucketMembers) + +instance Ord (HashBucket a) where + compare = compare `on` (Down . length . bucketMembers) + + +data SizedList a = SizedList [a] ArraySize + +data IntMapAndSize a = IntMapAndSize (IntMap a) ArraySize + + +-- | slots for each bucket with the current nonce attempt +data PlacementAttempt a = PlacementAttempt Nonce [SingletonBucket a] + + +data PartialSolution a b = PartialSolution (LookupTable b) [SingletonBucket (a, b)] + + +-- * Constants + emptyLookupTable :: LookupTable a -emptyLookupTable = NewLookupTable HashMap.empty HashMap.empty +emptyLookupTable = NewLookupTable mempty mempty --- | Used to fill empty slots when promoting a HashMap to a Vector -class Defaultable a where - getDefault :: a +defaultAlgorithmParams :: AlgorithmParams +defaultAlgorithmParams = AlgorithmParams + (Nonces.mapNonce (+1)) + (Nonces.Nonce 1) -instance Defaultable Int where - getDefault = 0 +-- * Functions -data HashMapAndSize a b = HashMapAndSize (HashMap a b) Int +toRedirector :: NonceOrDirect -> Int +toRedirector (WrappedNonce (Nonces.Nonce x)) = x +toRedirector (DirectEntry free_slot_index) = + Lookup.encodeDirectEntry free_slot_index -convertToVector :: (Vector.Unbox a, Defaultable a) => LookupTable a -> Lookup.LookupTable a +convertToVector + :: (Default a) + => LookupTable a + -> Lookup.LookupTable a convertToVector x = Lookup.LookupTable a1 a2 where size = length $ vals x - a1 = Vector.generate size (\z -> HashMap.lookupDefault 0 z $ redirs x) - a2 = Vector.generate size (\z -> HashMap.lookupDefault getDefault z $ vals x) + + vectorizeNonces input = Vector.generate size $ + toRedirector . flip (IntMap.findWithDefault def) input + a1 = vectorizeNonces $ nonces x + + vectorizeVals input = Vector.generate size $ + flip (IntMap.findWithDefault def) input + + a2 = vectorizeVals $ vals x + + -- | Computes a slot in the destination array (Data.PerfectHash.Lookup.values) -- for every element in this multi-entry bucket, for the given nonce. -- -- Return a Nothing for a slot if it collides. -- -- This function is able to fail fast if one of the elements of the bucket --- yields a collision with the new nonce. -attemptNonceRecursive :: Hashing.ToHashableChunks a => - HashMapAndSize Int b - -> Int -- ^ nonce +-- yields a collision when using the new nonce. +attemptNonceRecursive + :: Hashing.ToHashableChunks a + => IntMapAndSize b + -> Nonce -> IntSet -- ^ occupied slots - -> [a] -- ^ keys - -> [Maybe Int] + -> [(a, b)] -- ^ keys + -> [Maybe Hashing.SlotIndex] attemptNonceRecursive _ _ _ [] = [] -attemptNonceRecursive values_and_size nonce occupied_slots (current_key:remaining_bucket_keys) = +attemptNonceRecursive + values_and_size + nonce + occupied_slots + ((current_key, _):remaining_bucket_keys) = if cannot_use_slot then pure Nothing else Just slot : recursive_result where - HashMapAndSize values size = values_and_size - slot = Hashing.hashToSlot nonce current_key size + IntMapAndSize values size = values_and_size + slot = Hashing.hashToSlot nonce size current_key - cannot_use_slot = IntSet.member slot occupied_slots || HashMap.member slot values + Hashing.SlotIndex slotval = slot + -- TODO: Create a record "SlotOccupation" to encapsulate the IntSet implementation + cannot_use_slot = IntSet.member slotval occupied_slots || IntMap.member slotval values + recursive_result = attemptNonceRecursive values_and_size nonce - (IntSet.insert slot occupied_slots) + (IntSet.insert slotval occupied_slots) remaining_bucket_keys -- | Repeatedly try different values of the nonce until we find a hash function -- that places all items in the bucket into free slots. -- --- Keeps trying forever, incrementing the candidate nonce by @1@ each time. +-- Increment the candidate nonce by @1@ each time. -- Theoretically we're guaranteed to eventually find a solution. -findNonceForBucket :: Hashing.ToHashableChunks a => - Int -- ^ nonce to attempt - -> HashMapAndSize Int b - -> [a] -- ^ colliding keys for this bucket - -> ([(Int, a)], Int) -- ^ slots for each bucket, with the current nonce attempt -findNonceForBucket nonce_attempt values_and_size bucket = +findNonceForBucketRecursive + :: (Hashing.ToHashableChunks a) + => AlgorithmParams + -> Nonce -- ^ nonce to attempt + -> IntMapAndSize b + -> [(a, b)] -- ^ colliding keys for this bucket + -> PlacementAttempt (a, b) +findNonceForBucketRecursive algorithm_params nonce_attempt values_and_size bucket = - maybe recursive_result (\x -> (zip x bucket, nonce_attempt)) maybe_attempt_result + -- This is a "lazy" (and awkward) way to specify recursion: + -- If the result ("result_for_this_iteration") at this iteration of the recursion + -- is not "Nothing", then, wrap it in a "PlacementAttempt" record. + -- Otherwise, descend one layer deeper by computing "recursive_result". + maybe + recursive_result + wrapSlotIndicesAsAttempt + maybe_final_result + where - recursive_result = findNonceForBucket (nonce_attempt + 1) values_and_size bucket - maybe_attempt_result = sequenceA $ attemptNonceRecursive + wrapSlotIndicesAsAttempt = PlacementAttempt nonce_attempt . + flip (zipWith SingletonBucket) bucket . map (Hashing.Hash . Hashing.getIndex) + + -- NOTE: attemptNonceRecursive returns a list of "Maybe SlotIndex" + -- records. If *any* of those elements are Nothing (that is, at + -- least one of the slots were not successfully placed), then applying + -- sequenceA to that list will yield Nothing. + maybe_final_result = sequenceA $ attemptNonceRecursive values_and_size nonce_attempt mempty bucket + recursive_result = findNonceForBucketRecursive + algorithm_params + (getNextNonceCandidate algorithm_params nonce_attempt) + values_and_size + bucket + -- | 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 :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => - HashMapAndSize a b +-- and all previously placed buckets. +processMultiEntryBuckets + :: (Hashing.ToHashableChunks a) + => AlgorithmParams + -> ArraySize -> LookupTable b - -> (Int, [a]) + -> HashBucket (a, b) -> LookupTable b -handleMultiBuckets sized_words_dict old_lookup_table (computed_hash, bucket) = - NewLookupTable new_g new_values_dict +processMultiEntryBuckets + algorithm_params + size + old_lookup_table + (HashBucket computed_hash bucket_members) = + + NewLookupTable new_nonces new_values_dict where - HashMapAndSize words_dict size = sized_words_dict + NewLookupTable old_nonces old_values_dict = old_lookup_table - sized_vals_dict = HashMapAndSize (vals old_lookup_table) size - (slots_for_bucket, nonce) = findNonceForBucket 1 sized_vals_dict bucket + sized_vals_dict = IntMapAndSize old_values_dict size - new_g = HashMap.insert computed_hash nonce $ redirs old_lookup_table - new_values_dict = foldr fold_func (vals old_lookup_table) slots_for_bucket + -- This is assured to succeed; it starts with a nonce of 1 + -- but keeps incrementing it until all of the keys in this + -- bucket are placeable. + PlacementAttempt nonce slots_for_bucket = + findNonceForBucketRecursive + algorithm_params + (startingNonce algorithm_params) + sized_vals_dict + bucket_members - fold_func (slot_val, bucket_val) = HashMap.insert slot_val $ - HashMap.lookupDefault (error "not found") bucket_val words_dict + new_nonces = IntMap.insert + (Hashing.getHash computed_hash) + (WrappedNonce nonce) + old_nonces + new_values_dict = foldr place_values old_values_dict slots_for_bucket --- | 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 :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => - HashMapAndSize a b - -> [(Int, [a])] - -> (LookupTable b, [(Int, a)]) -findCollisionNonces sized_words_dict sorted_bucket_hash_tuples = + place_values (SingletonBucket slot_val (_, value)) = + IntMap.insert (Hashing.getHash slot_val) value - (lookup_table, remaining_words) + +-- | This function exploits the sorted structure of the list +-- by skimming the multi-entry buckets from the front of the +-- list. Then we filter the single-entry buckets by dropping +-- the empty buckets. +-- +-- The partial solution produced by this function entails +-- all of the colliding nonces as fully placed. +handleCollidingNonces + :: (Hashing.ToHashableChunks a) + => AlgorithmParams + -> ArraySize + -> SortedList (HashBucket (a, b)) + -> PartialSolution a b +handleCollidingNonces algorithm_params size sorted_bucket_hash_tuples = + + PartialSolution lookup_table non_colliding_buckets where -- Since the buckets have been sorted by descending size, -- once we get to the bucket with 1 or fewer elements, -- we know there are no more collision buckets. - (multi_entry_buckets, single_or_fewer_buckets) = span ((> 1) . length . snd) sorted_bucket_hash_tuples + (multi_entry_buckets, single_or_fewer_buckets) = + span ((> 1) . length . bucketMembers) $ + fromSortedList sorted_bucket_hash_tuples -- 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 + lookup_table = foldl' + (processMultiEntryBuckets algorithm_params size) + emptyLookupTable + multi_entry_buckets - single_entry_buckets = takeWhile (not . null . snd) single_or_fewer_buckets - remaining_words = map (second head) single_entry_buckets + non_colliding_buckets = Maybe.mapMaybe + convertToSingletonBucket + single_or_fewer_buckets + convertToSingletonBucket (HashBucket hashVal elements) = + SingletonBucket hashVal <$> Maybe.listToMaybe elements --- | Sort buckets by descending size -preliminaryBucketPlacement :: (Hashing.ToHashableChunks a, Eq a, Hashable a) => - HashMap a b - -> [(Int, [a])] -preliminaryBucketPlacement words_dict = - sortOn (Down . length . snd) bucket_hash_tuples + +-- | Hash the keys into buckets and sort them by descending size +preliminaryBucketPlacement + :: (Hashing.ToHashableChunks a) + => SizedList (a, b) + -> SortedList (HashBucket (a, b)) +preliminaryBucketPlacement sized_list = + toSortedList bucket_hash_tuples where - size = HashMap.size words_dict - slot_key_pairs = deriveTuples (\k -> Hashing.hashToSlot 0 k size) $ HashMap.keys words_dict + SizedList tuplified_words_dict size = sized_list - bucket_hash_tuples = HashMap.toList $ binTuplesBySecond slot_key_pairs + f = Hashing.getIndex . Hashing.hashToSlot (Nonces.Nonce 0) size . fst + slot_key_pairs = deriveTuples f tuplified_words_dict + bucket_hash_tuples = map (uncurry HashBucket . first Hashing.Hash) $ + IntMap.toList $ binTuplesBySecond slot_key_pairs + + +-- | Arbitrarily pair the non-colliding buckets with free slots. +-- +-- At this point, all of the "colliding" hashes have been resolved +-- to their own slots, so we just take the leftovers. +assignDirectSlots + :: ArraySize + -> PartialSolution a b + -> LookupTable b +assignDirectSlots size (PartialSolution intermediate_lookup_table non_colliding_buckets) = + NewLookupTable final_nonces final_values + where + isUnusedSlot (Hashing.SlotIndex s) = + not $ IntMap.member s $ vals intermediate_lookup_table + + unused_slots = filter isUnusedSlot $ Hashing.generateArrayIndices size + + zipped_remaining_with_unused_slots = + zip non_colliding_buckets unused_slots + + insertDirectEntry (SingletonBucket computed_hash _, free_slot_index) = + -- Observe here that both the output and input + -- are nonces: + IntMap.insert (Hashing.getHash computed_hash) $ DirectEntry free_slot_index + + final_nonces = foldr + insertDirectEntry + (nonces intermediate_lookup_table) + zipped_remaining_with_unused_slots + + f2 (SingletonBucket _ (_, map_value), Hashing.SlotIndex free_slot_index) = + IntMap.insert free_slot_index map_value + + final_values = foldr + f2 + (vals intermediate_lookup_table) + zipped_remaining_with_unused_slots + + -- | Generates a minimal perfect hash for a set of key-value pairs. -- -- The keys must be instances of 'Hashing.ToHashableChunks'. -- The values may be of arbitrary type. -- --- A 'HashMap' is required as input to guarantee that there are no duplicate keys. -createMinimalPerfectHash :: (Vector.Unbox b, Defaultable b, Hashing.ToHashableChunks a, Eq a, Hashable a) => - HashMap a b -- ^ key-value pairs - -> Lookup.LookupTable b - -- ^ output for use by 'LookupTable.lookup' or a custom code generator -createMinimalPerfectHash words_dict = - convertToVector $ NewLookupTable final_g final_values +-- A 'Map' is required as input to guarantee that there are +-- no duplicate keys. +createMinimalPerfectHash + :: (Hashing.ToHashableChunks k, Default v) + => Map k v -- ^ key-value pairs + -> Lookup.LookupTable v + -- ^ output for use by 'Lookup.lookup' or a custom code generator +createMinimalPerfectHash original_words_dict = + convertToVector final_solution where - size = HashMap.size words_dict + tuplified_words_dict = Map.toList original_words_dict + size = Hashing.ArraySize $ length tuplified_words_dict + sized_list = SizedList tuplified_words_dict size - sorted_bucket_hash_tuples = preliminaryBucketPlacement words_dict + sorted_bucket_hash_tuples = preliminaryBucketPlacement sized_list - (intermediate_lookup_table, remaining_word_hash_tuples) = findCollisionNonces - (HashMapAndSize words_dict size) + partial_solution = handleCollidingNonces + defaultAlgorithmParams + size sorted_bucket_hash_tuples - unused_slots = filter (not . (`HashMap.member` vals intermediate_lookup_table)) [0..(size - 1)] - - zipped_remaining_with_unused_slots = zip remaining_word_hash_tuples unused_slots - - -- We subtract one to ensure it's negative even if the zeroeth slot was used. - f1 ((computed_hash, _), free_slot_index) = HashMap.insert computed_hash $ Lookup.encodeDirectEntry free_slot_index - final_g = foldr f1 (redirs intermediate_lookup_table) zipped_remaining_with_unused_slots - - f2 ((_, word), free_slot_index) = HashMap.insert free_slot_index $ - HashMap.lookupDefault (error "Impossible!") word words_dict - - final_values = foldr f2 (vals intermediate_lookup_table) zipped_remaining_with_unused_slots + final_solution = assignDirectSlots size partial_solution --- * Utilities +-- * Utility functions -- | Place the first elements of the tuples into bins according to the second -- element. -binTuplesBySecond :: (Eq b, Hashable b) => [(a, b)] -> HashMap.HashMap b [a] -binTuplesBySecond = foldr f HashMap.empty +binTuplesBySecond + :: (Foldable t) + => t (a, Int) + -> IntMap [a] +binTuplesBySecond = foldr f mempty where - f tuple = HashMap.insertWith (++) (snd tuple) [fst tuple] + f = uncurry (IntMap.insertWith mappend) . + fmap pure . swap --- * Utility functions - -- | duplicates the argument into both members of the tuple duple :: a -> (a, a) duple = join (,) @@ -237,5 +424,5 @@ derivePair g = fmap g . duple -deriveTuples :: (a -> b) -> [a] -> [(a, b)] -deriveTuples = map . derivePair +deriveTuples :: Functor t => (a -> b) -> t a -> t (a, b) +deriveTuples = fmap . derivePair 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 @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-} -{-# LANGUAGE TypeSynonymInstances #-} -- | Implements the specialized hash function for @@ -14,13 +13,27 @@ import Data.Binary (encode) import Data.Bits (xor, (.&.)) -import Data.ByteString.Lazy (unpack) +import qualified Data.ByteString.Lazy as B (unpack) import Data.Char (ord) import Data.Foldable (foldl') import Data.Text (Text) import qualified Data.Text as T +import qualified Data.PerfectHash.Types.Nonces as Nonces +import Data.PerfectHash.Types.Nonces (Nonce) +-- Types +newtype SlotIndex = SlotIndex {getIndex :: Int} + +newtype Hash = Hash {getHash :: Int} + deriving (Eq, Show) + +newtype ArraySize = ArraySize Int + deriving Show + + +-- * Constants + -- | This choice of prime number @0x01000193@ was taken from the Python implementation -- on . primeFNV :: Int @@ -31,30 +44,52 @@ mask32bits = 0xffffffff +-- * Class instances + -- | Mechanism for a key to be decomposed into units processable by the -- hashing algorithm. class ToHashableChunks a where - toHashableChunks :: a -> [Int] + toHashableChunks :: a -> [Hash] instance ToHashableChunks Int where - toHashableChunks = map fromIntegral . unpack . encode + toHashableChunks = map (Hash. fromIntegral) . B.unpack . encode +instance ToHashableChunks String where + toHashableChunks = map $ Hash . ord + instance ToHashableChunks Text where - toHashableChunks = map ord . T.unpack + toHashableChunks = toHashableChunks . T.unpack -instance ToHashableChunks String where - toHashableChunks = map ord +-- Utilities +generateArrayIndices :: ArraySize -> [SlotIndex] +generateArrayIndices (ArraySize size) = map SlotIndex [0..(size - 1)] + +-- * Main functions + hashToSlot :: ToHashableChunks a => - Int -- ^ nonce + Nonce + -> ArraySize -> a -- ^ key - -> Int -- ^ array size - -> Int -hashToSlot nonce key size = hash nonce key `mod` size + -> SlotIndex +hashToSlot nonce (ArraySize size) key = + SlotIndex $ getHash (hash nonce key) `mod` size --- | Uses the \"FNV-1a\" algorithm from the +-- Used in the 'hash' function +getNonzeroNonceVal :: Nonce -> Int +getNonzeroNonceVal (Nonces.Nonce nonce) = + if nonce == 0 + then primeFNV + else nonce + + +-- | The interface is comparable to the +-- +-- function from the @hashable@ package. +-- +-- Uses the \"FNV-1a\" algorithm from the -- : -- -- > hash = offset_basis @@ -62,21 +97,15 @@ -- > hash = hash xor octet_of_data -- > hash = hash * FNV_prime -- > return hash --- --- The interface is comparable to the --- --- function from the @hashable@ package. hash :: ToHashableChunks a => - Int -- ^ nonce + Nonce -- ^ nonce -> a -- ^ key - -> Int + -> Hash hash nonce = -- NOTE: This must be 'foldl', not 'foldr' - foldl' combine d . toHashableChunks + Hash . foldl' combine d . toHashableChunks where - d = if nonce == 0 - then primeFNV - else nonce + d = getNonzeroNonceVal nonce - combine acc = (.&. mask32bits) . (* primeFNV) . xor acc + combine acc = (.&. mask32bits) . (* primeFNV) . xor acc . getHash 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 --- better known as . +-- better known as a \"\". module Data.PerfectHash.Lookup ( LookupTable (LookupTable, nonces, values) , size @@ -9,11 +9,13 @@ , lookup ) where -import Data.Vector.Unboxed (Vector, (!)) -import qualified Data.Vector.Unboxed as Vector +import Data.Vector (Vector, (!)) +import qualified Data.Vector as Vector import Prelude hiding (lookup) +import Data.PerfectHash.Types.Nonces (Nonce (Nonce)) import qualified Data.PerfectHash.Hashing as Hashing +import qualified Data.PerfectHash.Types.Nonces as Nonces -- | Inputs for the lookup function. @@ -41,18 +43,38 @@ } -size :: Vector.Unbox a => LookupTable a -> Int -size = Vector.length . values +size :: LookupTable a -> Hashing.ArraySize +size = Hashing.ArraySize . Vector.length . values -encodeDirectEntry :: Int -> Int -encodeDirectEntry = subtract 1 . negate +-- NOTE: We subtract one to ensure it's negative even if the +-- zeroeth slot was used. This lets us test for "direct encoding" +-- by checking of the value is negative. +encodeDirectEntry :: Hashing.SlotIndex -> Int +encodeDirectEntry (Hashing.SlotIndex val) = + subtract 1 $ negate val +-- | NOTE: negation, followed by subtracting 1 is its own self-inverse. +-- +-- Example: +-- > a = 7 +-- > f(a) = -7 - 1 +-- > = -8 +-- > +-- > a' = -8 +-- > f(a') = -(-8) - 1 +-- > = 8 - 1 +-- > = 7 +decodeDirectEntry :: Int -> Hashing.SlotIndex +decodeDirectEntry val = + Hashing.SlotIndex $ encodeDirectEntry $ Hashing.SlotIndex val + + -- | For embedded applications, this function would usually be re-implemented -- in C code. -- --- == Algorithm description +-- == Procedure description -- The lookup procedure is three steps: -- -- 1. Compute the 'Hashing.hash' (with a nonce of zero) of the "key", modulo @@ -68,8 +90,9 @@ -- respect to the length of the 'values' array. -- -- 3. Use the result of (2) as the index into the 'values' array. -lookup :: (Hashing.ToHashableChunks a, Vector.Unbox b) => - LookupTable b +lookup + :: (Hashing.ToHashableChunks a) + => LookupTable b -> a -- ^ key -> b -- ^ value lookup lookup_table key = @@ -79,10 +102,10 @@ where table_size = size lookup_table - nonce_index = Hashing.hashToSlot 0 key table_size + Hashing.SlotIndex nonce_index = Hashing.hashToSlot (Nonce 0) table_size key nonce = nonces lookup_table ! nonce_index - -- Negative value indicates that we don't need extra lookup layer - v_key = if nonce < 0 - then encodeDirectEntry nonce - else Hashing.hashToSlot nonce key table_size + -- Negative nonce value indicates that we don't need extra lookup layer + Hashing.SlotIndex v_key = if Nonces.isDirectSlot nonce + then decodeDirectEntry nonce + else Hashing.hashToSlot (Nonces.Nonce nonce) table_size key diff --git a/src/Data/PerfectHash/Types/Nonces.hs b/src/Data/PerfectHash/Types/Nonces.hs new file mode 100644 --- /dev/null +++ b/src/Data/PerfectHash/Types/Nonces.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK hide #-} +module Data.PerfectHash.Types.Nonces where + +import Data.Default (Default, def) + + +-- * Types + +newtype Nonce = Nonce Int + deriving Show + +instance Default Nonce where + def = Nonce 0 + + + +-- * Helper functions + +mapNonce :: (Int -> Int) -> Nonce -> Nonce +mapNonce f (Nonce x) = Nonce $ f x + + +isDirectSlot :: Int -> Bool +isDirectSlot val = val < 0 diff --git a/test-utils/Exercise.hs b/test-utils/Exercise.hs --- a/test-utils/Exercise.hs +++ b/test-utils/Exercise.hs @@ -4,20 +4,24 @@ import Control.Monad (unless) import Data.Foldable (traverse_) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Vector.Unboxed as Vector +import qualified Data.Map as Map +import Data.Map (Map) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import System.Random (RandomGen, mkStdGen, random) import qualified Data.PerfectHash.Hashing as Hashing import qualified Data.PerfectHash.Lookup as Lookup -testLookups :: (Show b, Eq b, Show a, Hashing.ToHashableChunks a, Vector.Unbox b) => - Lookup.LookupTable b - -> HashMap a b +-- | genericized to facilitate benchmarking +testLookupsHelper + :: (Show b, Eq b, Show a, Hashing.ToHashableChunks a) + => (a -> b) -- ^ lookup function + -> Map a b -> Either String () -testLookups lookup_table = - traverse_ check_entry . HashMap.toList +testLookupsHelper lookup_function = + traverse_ check_entry . Map.toList where check_entry (word, source_index) = unless (lookup_result == source_index) $ Left $ unwords [ @@ -29,18 +33,68 @@ , show source_index ] where - lookup_result = Lookup.lookup lookup_table word + lookup_result = lookup_function word +testHashMapLookups + :: (Show b, Eq b, Show a, Ord a, Hashing.ToHashableChunks a) + => Map a b + -> Either String () +testHashMapLookups hash_map = testLookupsHelper + (\x -> Map.findWithDefault (error "not found") x hash_map) + hash_map + + +testPerfectLookups + :: (Show b, Eq b, Show a, Hashing.ToHashableChunks a) + => Lookup.LookupTable b + -> Map a b + -> Either String () +testPerfectLookups = testLookupsHelper . Lookup.lookup + + -- | Generate a map of words from a file to their line numbers. -- -- Intended for use with @\"/usr/share/dict/words\"@. wordsFromFile :: FilePath -> IO [(String, Int)] wordsFromFile path = do file_lines <- readFile path - let word_index_tuples = zip (lines file_lines) [1..] - return word_index_tuples + return $ zip (lines file_lines) [1..] + +-- * Random integers + +data RandIntAccum t = RandIntAccum + t -- ^ random number generator + Int -- ^ max count + IntSet -- ^ accumulated unique random numbers + + +mkIntMapTuples :: Int -> Map Int Int +mkIntMapTuples valueCount = Map.fromList $ zip random_ints [1..] + where + seed_value = RandIntAccum (mkStdGen 0) valueCount IntSet.empty + random_ints = IntSet.toList $ getUniqueRandomIntegers seed_value + + +-- | 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) + +-- * Other utilities eitherExit :: Either String b -> IO () eitherExit x = case x of diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,77 +2,96 @@ module Main where +import Data.Default (Default) import Data.Either (isRight) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import Data.Map (Map) import Data.Text (Text) -import qualified Data.Vector.Unboxed as Vector import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertBool, assertEqual) import qualified Data.PerfectHash.Construction as Construction +import Data.PerfectHash.Hashing (Hash) import qualified Data.PerfectHash.Hashing as Hashing +import qualified Data.PerfectHash.Types.Nonces as Nonces + import qualified Exercise -testHashComputation :: (Hashing.ToHashableChunks a, Show a) => - a - -> Int +testHashComputation + :: (Hashing.ToHashableChunks a, Show a) + => a + -> Hash -> IO () testHashComputation key val = assertEqual error_message val computed_hash where error_message = unwords ["Incorrect hash computation of", show key] - computed_hash = Hashing.hash 0 key + computed_hash = Hashing.hash (Nonces.Nonce 0) key -wordIndexTuplesString :: HashMap String Int -wordIndexTuplesString = HashMap.fromList $ zip [ +mkInputs + :: Ord a + => [a] + -> Map a Int +mkInputs inputs = Map.fromList $ zip inputs [1..] + + +wordIndexTuplesString :: Map String Int +wordIndexTuplesString = mkInputs [ "apple" , "banana" , "carrot" - ] [1..] + ] -wordIndexTuplesText :: HashMap Text Int -wordIndexTuplesText = HashMap.fromList $ zip [ +wordIndexTuplesText :: Map Text Int +wordIndexTuplesText = mkInputs [ "alpha" , "beta" , "gamma" - ] [1..] + ] -intMapTuples :: HashMap Int Int -intMapTuples = HashMap.fromList $ zip [ +intMapTuples :: Map Int Int +intMapTuples = mkInputs [ 1000 , 5555 , 9876 - ] [1..] + ] -testHashLookups :: (Show a, Show b, Eq b, Vector.Unbox b, Construction.Defaultable b, Hashing.ToHashableChunks a, Eq a, Hashable a) => - HashMap a b +testHashLookups + :: (Show a, Show b, Eq b, Default b, Hashing.ToHashableChunks a, Ord a) + => Map a b -> IO () testHashLookups word_index_tuples = assertBool "Perfect hash lookups failed to match the input" $ isRight test_result_either where lookup_table = Construction.createMinimalPerfectHash word_index_tuples - test_result_either = Exercise.testLookups lookup_table word_index_tuples + test_result_either = Exercise.testPerfectLookups lookup_table word_index_tuples tests = [ testGroup "Hash computation" [ - testCase "compute-string-hash" $ testHashComputation ("blarg" :: String) 3322346319 - , testCase "compute-int-hash" $ testHashComputation (70000 :: Int) 4169891409 + testCase "compute-string-hash" $ testHashComputation ("blarg" :: String) $ Hashing.Hash 3322346319 + , testCase "compute-int-hash" $ testHashComputation (70000 :: Int) $ Hashing.Hash 4169891409 ] , testGroup "Hash lookups" [ testCase "word-lookups-string" $ testHashLookups wordIndexTuplesString , testCase "word-lookups-text" $ testHashLookups wordIndexTuplesText , testCase "int-lookups" $ testHashLookups intMapTuples ] + , testGroup "Large scale round-tripping with random inputs" [ + testCase "integers" $ assertBool "Lookups failed to match input" $ + isRight $ Exercise.testPerfectLookups lookup_table intMapTuples + ] ] + where + intMapTuples = Exercise.mkIntMapTuples 100000 + lookup_table = Construction.createMinimalPerfectHash intMapTuples + main = defaultMain tests