perfect-hash-generator 0.2.0.6 → 1.0.0

raw patch · 11 files changed

+658/−247 lines, 11 filesdep +data-defaultdep +sorted-listPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, sorted-list

API changes (from Hackage documentation)

Files

• changelog.md +9/−0
• demo/ints/Main.hs +55/−33
• demo/strings/Main.hs +38/−8
• docs/images/algorithm-diagram.svg +3/−0
• perfect-hash-generator.cabal +34/−23
• src/Data/PerfectHash/Construction.hs +299/−112
• src/Data/PerfectHash/Hashing.hs +52/−23
• src/Data/PerfectHash/Lookup.hs +38/−15
• src/Data/PerfectHash/Types/Nonces.hs +24/−0
• test-utils/Exercise.hs +65/−11
• test/Main.hs +41/−22

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg stroke="rgb(0,0,0)" xmlns="http://www.w3.org/2000/svg" font-size="1" width="260.0000" stroke-opacity="1" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0.0 0.0 260.00000000000006 220.0" height="220.0000" version="1.1"><defs></defs><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="15.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,205.0000)" text-anchor="middle">value table</text></g><g fill="rgb(222,203,228)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 220.0000,185.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,175.0000)" text-anchor="middle">3</text></g><g fill="rgb(222,203,228)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 220.0000,145.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,135.0000)" text-anchor="middle">3</text></g><g fill="rgb(222,203,228)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 220.0000,105.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,95.0000)" text-anchor="middle">3</text></g><g fill="rgb(222,203,228)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 220.0000,65.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,55.0000)" text-anchor="middle">3</text></g><g fill="rgb(222,203,228)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 220.0000,25.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,200.0000,15.0000)" text-anchor="middle">3</text></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="15.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,205.0000)" text-anchor="middle">intermediate table</text></g><g fill="rgb(254,217,166)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 80.0000,185.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,175.0000)" text-anchor="middle"></text></g><g fill="rgb(254,217,166)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 80.0000,145.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,135.0000)" text-anchor="middle">blah</text></g><g fill="rgb(254,217,166)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 80.0000,105.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,95.0000)" text-anchor="middle"></text></g><g fill="rgb(254,217,166)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 80.0000,65.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,55.0000)" text-anchor="middle">bar</text></g><g fill="rgb(254,217,166)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.0" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><path d="M 80.0000,25.0000 v -20.0000 c 0.0000,-2.7614 -2.2386,-5.0000 -5.0000 -5.0000h -30.0000 c -2.7614,-0.0000 -5.0000,2.2386 -5.0000 5.0000v 20.0000 c -0.0000,2.7614 2.2386,5.0000 5.0000 5.0000h 30.0000 c 2.7614,0.0000 5.0000,-2.2386 5.0000 -5.0000Z"/></g><g fill="rgb(0,0,0)" stroke="rgb(0,0,0)" stroke-linecap="butt" stroke-width="0.956660859448112" font-size="20.0px" stroke-miterlimit="10.0" fill-opacity="1.0" stroke-opacity="1.0" stroke-linejoin="miter"><text dominant-baseline="middle" stroke="none" transform="matrix(1.0000,0.0000,0.0000,1.0000,60.0000,15.0000)" text-anchor="middle">foo</text></g></svg>

@@ -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 <https://en.wikipedia.org/wiki/Perfect_hash_function perfect hash function> for a set @S@ is a hash function that maps distinct elements in @S@ to a set of integers, with __no collisions__. A <https://en.wikipedia.org/wiki/Perfect_hash_function#Minimal_perfect_hash_function minimal perfect hash function> 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 @<https://www.gnu.org/software/gperf/manual/gperf.html#Search-Structures gperf>@). The output of this tool is a pair of arrays that can be included in generated C code for __<https://en.wikipedia.org/wiki/C_dynamic_memory_allocation allocation-free> 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 <https://hackage.haskell.org/package/unordered-containers/docs/Data-HashMap-Strict.html#t:HashMap HashMap>.                 .                 This implementation was adapted from <http://stevehanov.ca/blog/index.php?id=119 Steve Hanov's Blog>.                 .@@ -21,7 +21,7 @@                 The library is written generically to hash both strings and raw integers according to the <http://isthe.com/chongo/tech/comp/fnv/ FNV-1a algorithm>. 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

@@ -2,229 +2,416 @@  -- | Constructs a minimal perfect hash from a map of key-value pairs. ----- Implementation was adapted from--- <http://stevehanov.ca/blog/index.php?id=119 Steve Hanov's Blog>.+-- = 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 <http://cmph.sourceforge.net/papers/esa09.pdf this paper>,+-- the algorithm is assured to run in linear time.+--+-- = Provenance+-- This implementation was adapted from+-- <http://stevehanov.ca/blog/index.php?id=119 Steve Hanov's Blog>. -- A refactoring of that Python implementation may be found -- <https://github.com/kostmo/perfect-hash-generator/blob/master/python/perfect-hash.py here>.--- 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

@@ -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 <http://stevehanov.ca/blog/index.php?id=119 Steve Hanov's page>. primeFNV :: Int@@ -31,30 +44,52 @@ mask32bits = 0xffffffff  +-- * Class instances+ -- | Mechanism for a key to be decomposed into units processable by the -- <http://isthe.com/chongo/tech/comp/fnv/#FNV-1a FNV-1a> 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+-- <https://hackage.haskell.org/package/hashable-1.2.6.1/docs/Data-Hashable.html#v:hashWithSalt hashWithSalt>+-- function from the @hashable@ package.+--+-- Uses the \"FNV-1a\" algorithm from the -- <http://isthe.com/chongo/tech/comp/fnv/#FNV-1a FNV website>: -- -- > 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--- <https://hackage.haskell.org/package/hashable-1.2.6.1/docs/Data-Hashable.html#v:hashWithSalt hashWithSalt>--- 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

@@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK prune #-}  -- | Note that what is referred to as a \"nonce\" in this library may be--- better known as <https://en.wikipedia.org/wiki/Salt_(cryptography) \"salt\">.+-- better known as a \"<https://en.wikipedia.org/wiki/Salt_(cryptography) salt>\". 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

@@ -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

@@ -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

@@ -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