diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,335 @@ +Summary: This library is licensed under Apache-2.0, BSD2, and MIT. + +Some code in this library is derived from the process library, whose license +is in the "Library" section. + +----------------------------------------------------------------------------- + +== The 2-Clause BSD License == + +Copyright 2016-2017 XT + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------------------- + +== The MIT License == + +Copyright (c) 2016-2017 XT + +Permission is hereby granted, free of charge, to any +person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the +Software without restriction, including without +limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software +is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice +shall be included in all copies or substantial portions +of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED +TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT +SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR +IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +----------------------------------------------------------------------------- + +== The Apache License Version 2.0 == + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + +----------------------------------------------------------------------------- + +== Library == + +The libraries (process and directory) are derived from code from two +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + +The full text of these licenses is reproduced below. Both of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- diff --git a/demo/IntsDemo.hs b/demo/IntsDemo.hs new file mode 100644 --- /dev/null +++ b/demo/IntsDemo.hs @@ -0,0 +1,70 @@ +import System.Random (RandomGen, mkStdGen, randomR) + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import qualified Data.PerfectHash.Construction as Construction +import qualified Data.PerfectHash.Lookup as Lookup +import qualified Data.Vector.Unboxed as Vector +import Exercise (Atom (Atom)) +import qualified Exercise + + +valueCount = 500000 + +upperBound = 2^32 - 1 +randomRange = (0, upperBound) + + +data RandIntAccum t = RandIntAccum + t -- ^ random number generator + Int -- ^ max count + IntSet -- ^ accumulated unique random numbers + + +-- | Since computing the size of the set is O(N), we +-- maintain the count separately. +getUniqueRandomIntegers :: RandomGen t => RandIntAccum t -> IntSet +getUniqueRandomIntegers (RandIntAccum std_gen count current_set) = + + if count == 0 + then current_set + else getUniqueRandomIntegers newstate + + where + (next_int, next_std_gen) = randomR randomRange std_gen + + a = RandIntAccum next_std_gen + newstate = if IntSet.member next_int current_set + then a count current_set + else a (count - 1) (IntSet.insert next_int current_set) + + +intMapTuples :: [(Atom Int, Int)] +intMapTuples = zip (map Atom random_ints) [1..] + where + seed_value = RandIntAccum (mkStdGen 0) valueCount IntSet.empty + random_ints = IntSet.toList $ getUniqueRandomIntegers seed_value + + +main = do + + putStrLn $ unwords ["Keys size:", show $ length intMapTuples] + + let lookup_table = Construction.createMinimalPerfectHash intMapTuples + + putStrLn $ unwords [ + "Finished computing lookup table with" + , show $ Lookup.size lookup_table + , "entries." + ] + + let direct_mapping_nonces = Vector.filter (< 0) $ Lookup.nonces lookup_table + + putStrLn $ unwords [ + "There were" + , show $ Vector.length direct_mapping_nonces + , "lookup entries with direct mappings." + ] + + let test_result_either = Exercise.testLookups lookup_table intMapTuples + Exercise.eitherExit test_result_either diff --git a/demo/StringsDemo.hs b/demo/StringsDemo.hs new file mode 100644 --- /dev/null +++ b/demo/StringsDemo.hs @@ -0,0 +1,33 @@ +import Control.Monad (when) + +import qualified Data.PerfectHash.Construction as Construction +import qualified Data.PerfectHash.Lookup as Lookup +import qualified Exercise + + +enableDebug = False + +dictionaryPath = "/usr/share/dict/words" + + +main = do + + word_index_tuples <- Exercise.wordsFromFile dictionaryPath + + putStrLn $ unwords ["Words size:", show $ length word_index_tuples] + + let lookup_table = Construction.createMinimalPerfectHash word_index_tuples + + putStrLn $ unwords [ + "Finished computing lookup table with" + , show $ Lookup.size lookup_table + , "entries." + ] + + when enableDebug $ do + putStrLn $ unwords ["Vector G:", show $ Lookup.nonces lookup_table] + putStrLn $ unwords ["Vector V:", show $ Lookup.values lookup_table] + + + let test_result_either = Exercise.testLookups lookup_table word_index_tuples + Exercise.eitherExit test_result_either diff --git a/perfect-hash-generator.cabal b/perfect-hash-generator.cabal new file mode 100644 --- /dev/null +++ b/perfect-hash-generator.cabal @@ -0,0 +1,126 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: perfect-hash-generator +version: 0.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@. + . + In contrast with the , which is a binding to a C-based library, this package is a fully-native Haskell implementation. + . + 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 __-free hash tables__. + . + Though lookups also perform reasonably well for Haskell applications, it hasn't been benchmarked thorougly with respect to other data structures. + . + This implementation was adapted from . + . + = Usage + The library is written generically to hash both strings and raw integers. Integers should be wrapped in the @Atom@ newtype: + . + > import Data.PerfectHash.Construction (createMinimalPerfectHash) + > + > tuples = [ + > (Atom 1000, 1) + > , (Atom 5555, 2) + > , (Atom 9876, 3) + > ] + > + > lookup_table = createMinimalPerfectHash 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. + . + See the @hash-perfectly-strings-demo@ and @hash-perfectly-ints-demo@, as well as the test suite, for working examples. + . + > $ stack build + > $ stack exec hash-perfectly-strings-demo + . + = Caveats + Only integer keys of at most __32-bits__ have been demonstrated to work properly. Since the hash function masks to 32 bits, colliding 64-bit integers can hang the lookup table construction. +category: Data Structures, Embedded +author: Karl Ostmo +maintainer: kostmo@gmail.com +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: + src + ghc-options: -fwarn-tabs -W + build-depends: + base >= 4.5 && <= 4.10 + , unordered-containers + , containers + , data-ordlist + , directory + , filepath + , hashable + , vector + exposed-modules: + Data.PerfectHash.Construction + Data.PerfectHash.Hashing + Data.PerfectHash.Lookup + default-language: Haskell2010 + +executable hash-perfectly-ints-demo + main-is: IntsDemo.hs + hs-source-dirs: + demo + test + ghc-options: -fwarn-tabs -W + build-depends: + base >= 4.5 && <= 4.10 + , unordered-containers + , perfect-hash-generator + , random + , optparse-applicative + , vector + , hashable + , containers + other-modules: + StringsDemo + Exercise + Test + default-language: Haskell2010 + +executable hash-perfectly-strings-demo + main-is: StringsDemo.hs + hs-source-dirs: + demo + test + ghc-options: -fwarn-tabs -W + build-depends: + base >= 4.5 && <= 4.10 + , unordered-containers + , perfect-hash-generator + , random + , optparse-applicative + , vector + , hashable + other-modules: + IntsDemo + Exercise + Test + default-language: Haskell2010 + +test-suite regression-tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: + test + ghc-options: -fwarn-tabs -W + build-depends: + base >= 4.5 && <= 4.10 + , unordered-containers + , perfect-hash-generator + , optparse-applicative + , test-framework + , HUnit + , test-framework-hunit + , hashable + , vector + other-modules: + Exercise + default-language: Haskell2010 diff --git a/src/Data/PerfectHash/Construction.hs b/src/Data/PerfectHash/Construction.hs new file mode 100644 --- /dev/null +++ b/src/Data/PerfectHash/Construction.hs @@ -0,0 +1,216 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | Constructs a minimal perfect hash. +-- +-- Implementation was transliterated from Python on +-- +-- and then refactored. +module Data.PerfectHash.Construction ( + createMinimalPerfectHash + , Defaultable + ) where + +import Control.Arrow (second) +import Control.Monad (join) +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 qualified Data.Vector.Unboxed as Vector + +import qualified Data.PerfectHash.Hashing as Hashing +import qualified Data.PerfectHash.Lookup as Lookup + + +-- | NOTE: Vector may peform better for these structures, but +-- the code may not be as clean. +data LookupTable a = NewLookupTable { + redirs :: HashMap Int Int + , vals :: HashMap Int a + } + + +emptyLookupTable = NewLookupTable HashMap.empty HashMap.empty + + +class Defaultable a where + getDefault :: a + + +instance Defaultable Int where + getDefault = 0 + + +data HashMapAndSize a b = HashMapAndSize (HashMap a b) Int + + +convertToVector :: (Vector.Unbox a, Defaultable 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) + + +attemptNonceRecursive :: (Foldable f, Hashing.ToNumeric a) => + HashMapAndSize Int b + -> Int + -> IntSet + -> [f a] + -> [Maybe Int] +attemptNonceRecursive _ _ _ [] = [] +attemptNonceRecursive values_and_size nonce previous_slots (x:xs) = + + if cannot_use_slot + then [Nothing] + else Just slot : recursive_result + + where + HashMapAndSize values size = values_and_size + slot = Hashing.hash nonce x `mod` size + + cannot_use_slot = IntSet.member slot previous_slots || HashMap.member slot values + + next_slots = IntSet.insert slot previous_slots + recursive_result = attemptNonceRecursive values_and_size nonce next_slots xs + + +-- | 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. +-- Theoretically we're guaranteed to eventually find a solution. +findNonceForBucket :: (Foldable f, Hashing.ToNumeric a) => + Int + -> HashMapAndSize Int b + -> [f a] + -> ([Int], Int) +findNonceForBucket nonce_attempt values_and_size bucket = + + maybe recursive_result (\x -> (x, nonce_attempt)) maybe_attempt_result + where + recursive_result = findNonceForBucket (nonce_attempt + 1) values_and_size bucket + maybe_attempt_result = sequenceA $ attemptNonceRecursive + values_and_size + nonce_attempt + mempty + bucket + + +handleMultiBuckets :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => + HashMapAndSize (f a) b + -> (Int, [f a]) + -> LookupTable b + -> LookupTable b +handleMultiBuckets sized_words_dict (computed_hash, bucket) old_lookup_table = + NewLookupTable new_g new_values + where + HashMapAndSize words_dict size = sized_words_dict + + sized_vals_dict = HashMapAndSize (vals old_lookup_table) size + (slots, d) = findNonceForBucket 1 sized_vals_dict bucket + + new_g = HashMap.insert computed_hash d (redirs old_lookup_table) + new_values = foldr fold_func (vals old_lookup_table) $ zip [0..] bucket + + fold_func (i, bucket_val) = HashMap.insert (slots !! i) $ + HashMap.lookupDefault (error "not found") bucket_val words_dict + + +-- | This function exploits the sorted structure of the list twice, +-- first by skimming the multi-entry buckets, then by skimming +-- the single-entry buckets and dropping the empty buckets. +findCollisionNonces :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => + HashMapAndSize (f a) b + -> [(Int, [f a])] + -> (LookupTable b, [(Int, f a)]) +findCollisionNonces sized_words_dict sorted_bucket_hash_tuples = + + (lookup_table, remaining_words) + 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 + + lookup_table = foldr (handleMultiBuckets sized_words_dict) emptyLookupTable multi_entry_buckets + + single_entry_buckets = takeWhile (not . null . snd) single_or_fewer_buckets + remaining_words = map (second head) single_entry_buckets + + +-- | Sort buckets by descending size +preliminaryBucketPlacement :: (Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => + HashMap (f a) b + -> [(Int, [f a])] +preliminaryBucketPlacement words_dict = + sortOn (negate . length . snd) bucket_hash_tuples + where + size = HashMap.size words_dict + slot_key_pairs = deriveTuples ((`mod` size) . Hashing.hash 0) $ HashMap.keys words_dict + + bucket_hash_tuples = HashMap.toList $ binTuplesBySecond slot_key_pairs + + +-- | Generates a minimal perfect hash for a set of key-value pairs. +-- +-- The keys must be 'Foldable's of 'ToNumeric' instances in order to be hashable. +-- The values may be of arbitrary type. +-- +-- /__N.b.__/ It is assumed that the input tuples list has no duplicate keys. +createMinimalPerfectHash :: (Vector.Unbox b, Defaultable b, Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => + [(f a, b)] + -> Lookup.LookupTable b +createMinimalPerfectHash tuples = + convertToVector $ NewLookupTable final_g final_values + where + words_dict = HashMap.fromList tuples + size = HashMap.size words_dict + + sorted_bucket_hash_tuples = preliminaryBucketPlacement words_dict + + (intermediate_lookup_table, remaining_word_hash_tuples) = findCollisionNonces + (HashMapAndSize words_dict 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 + + +-- * Utilities + +-- | Place the second 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 + where + f tuple = HashMap.insertWith (++) (snd tuple) [fst tuple] + + +-- | duplicates the argument into both members of the tuple +duple :: a -> (a, a) +duple = join (,) + + +-- | Given a function and a value, create a pair +-- where the first element is the value, and the +-- second element is the function applied to the value +derivePair :: (a -> b) -> a -> (a, b) +derivePair g = fmap g . duple + + +deriveTuples :: (a -> b) -> [a] -> [(a, b)] +deriveTuples = map . derivePair diff --git a/src/Data/PerfectHash/Hashing.hs b/src/Data/PerfectHash/Hashing.hs new file mode 100644 --- /dev/null +++ b/src/Data/PerfectHash/Hashing.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | Implements the specialized hash function for +-- this perfect hashing algorithm. +module Data.PerfectHash.Hashing where + +import Data.Bits (xor, (.&.)) +import Data.Char (ord) + + +-- | This choice of prime number was taken from the Python implementation +-- on . +primeFNV = 0x01000193 + + +-- | A Foldable of any data type may be hashed, so long as it implements +-- an instance of this class. +class ToNumeric a where + toNum :: a -> Int + +-- | The numeric value of a character is simply its ordinal value. +instance ToNumeric Char where + toNum = ord + +instance ToNumeric Int where + toNum = id + + +-- | Uses the \"FNV-1a\" algorithm from the +-- : +-- +-- > hash = offset_basis +-- > for each octet_of_data to be hashed +-- > hash = hash xor octet_of_data +-- > hash = hash * FNV_prime +-- > return hash +-- +-- The interface is comparable to the +-- +-- function from the @hashable@ package. +hash :: (Foldable f, ToNumeric a) => Int -> f a -> Int +hash nonce = + + foldl combine d -- NOTE: This must be 'foldl', not 'foldr' + where + d = if nonce == 0 + then primeFNV + else nonce + + combine acc = (.&. 0xffffffff) . (* primeFNV) . xor acc . toNum diff --git a/src/Data/PerfectHash/Lookup.hs b/src/Data/PerfectHash/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Data/PerfectHash/Lookup.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | Note that what is referred to as a \"nonce\" in this library may be +-- equivalently described as a \"salt\" by some. +module Data.PerfectHash.Lookup ( + LookupTable (LookupTable) + , nonces + , values + , size + , encodeDirectEntry + , lookupPerfect + ) where + +import Data.Vector.Unboxed (Vector, (!)) +import qualified Data.Vector.Unboxed as Vector + +import qualified Data.PerfectHash.Hashing as Hashing + + +-- | Inputs for the lookup function. +-- +-- There are two arrays used in successive stages of the lookup. +-- In this implementation, both arrays are the same length. +data LookupTable a = LookupTable { + nonces :: Vector Int + -- ^ This is the intermediate lookup table. + -- + -- In the lookup process, the key's hash is computed first with a nonce of + -- zero to obtain an index into this array. + -- + -- If the value at this index is negative, it is (after negating and + -- subtracting one) a direct index into the 'values' array. + -- Otherwise, the value shall be used as a nonce in a second application of + -- the hashing function to compute the index into the 'values' array. + -- + -- See the documentation of 'lookupPerfect' for details. + , values :: Vector a + -- ^ An array of values of arbitrary type. + -- + -- The objective of the perfect hash is to efficiently obtain an index into + -- this array, given the associated key for the value at that index. + } + + +size :: Vector.Unbox a => LookupTable a -> Int +size = Vector.length . values + + +encodeDirectEntry = subtract 1 . negate + + +-- | For embedded applications, this function would usually be re-implemented +-- in C code. +-- +-- == Algorithm description +-- The lookup procedure is three steps: +-- +-- 1. Compute the 'Hashing.hash' (with a nonce of zero) of the "key", modulo +-- the length of the 'values' array. +-- 2. Use the resulting value as an index into the 'nonces' array. The value +-- found there represents either a direct index into the 'values' array +-- or a nonce for a second round of hashing. +-- +-- * If negative, it is the former. Negate it (to obtain a positive +-- value) and subtract one to obtain the actual index. +-- * Otherwise, re-compute the hash of the key, using this +-- value instead of zero as the nonce. Again, compute the modulus with +-- respect to the length of the 'values' array. +-- +-- 3. Use the result of (2) as the index into the 'values' array. +lookupPerfect :: (Foldable f, Hashing.ToNumeric a, Vector.Unbox b) => + LookupTable b + -> f a + -> b +lookupPerfect lookup_table key = + + values lookup_table ! v_key + + where + table_size = size lookup_table + + nonce_index = Hashing.hash 0 key `mod` table_size + 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.hash nonce key `mod` table_size diff --git a/test/Exercise.hs b/test/Exercise.hs new file mode 100644 --- /dev/null +++ b/test/Exercise.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Exercise where + +import Control.Monad (unless) +import Data.Foldable (traverse_) +import Data.Hashable (Hashable) +import qualified Data.Vector.Unboxed as Vector +import GHC.Generics (Generic) + +import qualified Data.PerfectHash.Hashing as Hashing +import qualified Data.PerfectHash.Lookup as Lookup + + +-- | Wrapper to allow hashing of an integer +newtype Atom a = Atom {value :: a} deriving (Eq, Show, Generic) + +instance Hashable a => Hashable (Atom a) + + +instance Foldable Atom where + foldr f acc (Atom val) = f val acc + + +testLookups :: (Show b, Eq b, Show (f a), Foldable f, Hashing.ToNumeric a, Vector.Unbox b) => + Lookup.LookupTable b + -> [(f a, b)] + -> Either String () +testLookups lookup_table = + traverse_ check_entry + where + check_entry (word, source_index) = unless (lookup_result == source_index) $ + Left $ unwords [ + "Result for key" + , show word + , "had incorrect index" + , show lookup_result + , "; should have been" + , show source_index + ] + where + lookup_result = Lookup.lookupPerfect lookup_table word + + +-- | 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 + + +eitherExit :: Either String b -> IO () +eitherExit x = case x of + Left err -> error err + Right _ -> return () diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,57 @@ +import Data.Either (isRight) +import Data.Hashable (Hashable) +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 qualified Data.PerfectHash.Hashing as Hashing +import Exercise (Atom (Atom)) +import qualified Exercise + + +testHashComputation :: String -> Int -> IO () +testHashComputation key val = + assertEqual error_message val computed_hash + where + error_message = unwords ["Incorrect hash computation of", key] + computed_hash = Hashing.hash 0 key + + +wordIndexTuples = [ + ("apple", 1 :: Int) + , ("banana", 2) + , ("carrot", 3) + ] + + +intMapTuples :: [(Atom Int, Int)] +intMapTuples = [ + (Atom 1000, 1) + , (Atom 5555, 2) + , (Atom 9876, 3) + ] + + +testHashLookups :: (Show (f a), Show b, Eq b, Vector.Unbox b, Construction.Defaultable b, Foldable f, Hashing.ToNumeric a, Eq (f a), Hashable (f a)) => + [(f a, b)] -> IO () +testHashLookups 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 + + +tests = [ + testGroup "Hash computation" [ + testCase "compute-hash1" $ testHashComputation "blarg" 3322346319 + ] + , testGroup "Hash lookups" [ + testCase "word-lookups" $ testHashLookups wordIndexTuples + , testCase "int-lookups" $ testHashLookups intMapTuples + ] + ] + + +main = defaultMain tests