version 0.1.0.0HEAD0.1.0.0master

8 files changed, 429 insertions, 0 deletions

diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..02531eb
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Henri Verroken (c) 2018
+
+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 the name of Henri Verroken nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+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
+OWNER 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.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..301212d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,12 @@
+# intset-imperative
+
+[![Travis](https://travis-ci.org/hverr/haskell-intset-imperative.svg?branch=master)](https://travis-ci.org/hverr/haskell-intset-imperative)
+[![Hackage](https://img.shields.io/hackage/v/intset-imperative.svg?maxAge=600)](https://hackage.haskell.org/package/intset-imperative)
+[![Stackage Nightly](http://stackage.org/package/intset-imperative/badge/nightly)](http://stackage.org/nightly/package/intset-imperative)
+[![Stackage LTS](http://stackage.org/package/intset-imperative/badge/lts)](http://stackage.org/lts/package/intset-imperative)
+
+
+An imperative integer set written in Haskell.
+
+## Extra resources
+- Blog Post: [*Making Haskell as fast as C: Imperative programming in Haskell*](https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644
index 0000000..d57f390
--- /dev/null
+++ b/bench/Bench.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+
+import Control.Monad
+
+import Criterion.Main
+
+import Data.Word
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+import System.Random
+
+main :: IO ()
+main = defaultMain [
+    bgroup "intset" [ let n = 1000;         !v = generateInts 0 n (fromIntegral n)  in bench (show n)  $ whnfIO (benchIntset 0 n v)
+                    , let n = 10*1000;      !v = generateInts 0 n (fromIntegral n)  in bench (show n)  $ whnfIO (benchIntset 0 n v)
+                    , let n = 100*1000;     !v = generateInts 0 n (fromIntegral n)  in bench (show n)  $ whnfIO (benchIntset 0 n v)
+                    , let n = 1000*1000;    !v = generateInts 0 n (fromIntegral n)  in bench (show n)  $ whnfIO (benchIntset 0 n v)
+                    , let n = 10*1000*1000; !v = generateInts 0 n (fromIntegral n)  in bench (show n)  $ whnfIO (benchIntset 0 n v)
+                    ]
+  ]
+
+benchIntset :: Word64
+             -> Word64
+             -> Vector Word64
+             -> IO ()
+benchIntset minB maxB xs = do
+    s <- BIS.empty minB maxB
+    forM_ xs $ \i -> do
+        BIS.insert s i
+        f <- BIS.member s i
+        unless f $
+            throwIO $ userError "implementation errors"
+
+generateInts :: Word64
+             -> Word64
+             -> Int
+             -> Vector Word64
+generateInts minB maxB n =
+    V.fromList . take n $ randomRs (minB, maxB) (mkStdGen 0x214f36c9)
diff --git a/intset-imperative.cabal b/intset-imperative.cabal
new file mode 100644
index 0000000..6ab39a8
--- /dev/null
+++ b/intset-imperative.cabal
@@ -0,0 +1,69 @@
+name:           intset-imperative
+version:        0.1.0.0
+description:
+    An imperative integer set written in Haskell.
+    .
+    Read <https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html> for more information.
+synopsis:       An imperative integer set written in Haskell.
+homepage:       https://github.com/hverr/haskell-intset-imperative#readme
+bug-reports:    https://github.com/hverr/haskell-intset-imperative/issues
+author:         Henri Verroken
+maintainer:     henriverroken@gmail.com
+copyright:      2018 Henri Verroken
+license:        BSD3
+license-file:   LICENSE
+category:       Data Structures
+build-type:     Simple
+cabal-version:  >= 1.10
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/hverr/intset-imperative
+
+library
+  exposed-modules:      Data.IntSet.Bounded.Imperative
+  hs-source-dirs:       src
+  build-depends:        base >=4.7 && <5
+                      , deepseq
+                      , primitive
+  default-language:     Haskell2010
+  ghc-options:          -Wall
+
+test-suite intset-imperative-test-random
+  type:                 exitcode-stdio-1.0
+  main-is:              Spec.hs
+  hs-source-dirs:       test-random
+  build-depends:        base >=4.7 && <5
+                      , intset-imperative
+                      , mtl
+                      , primitive
+                      , random
+                      , transformers
+                      , unordered-containers
+  default-language:     Haskell2010
+  ghc-options:          -Wall -threaded -rtsopts -with-rtsopts=-N
+
+test-suite intset-imperative-test-fixed
+  type:                 exitcode-stdio-1.0
+  main-is:              Spec.hs
+  hs-source-dirs:       test-fixed
+  build-depends:        base >=4.7 && <5
+                      , intset-imperative
+  default-language:     Haskell2010
+  ghc-options:          -Wall -threaded -rtsopts -with-rtsopts=-N
+
+benchmark intset-imperative-bench
+  type:                 exitcode-stdio-1.0
+  hs-source-dirs:       bench
+  main-is:              Bench.hs
+  build-depends:        base
+                      , intset-imperative
+                      , containers
+                      , criterion
+                      , random
+                      , unordered-containers
+                      , vector
+  ghc-options:          -Wall -O2
+  default-language:     Haskell2010
diff --git a/src/Data/IntSet/Bounded/Imperative.hs b/src/Data/IntSet/Bounded/Imperative.hs
new file mode 100644
index 0000000..d3f09d6
--- /dev/null
+++ b/src/Data/IntSet/Bounded/Imperative.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+-- | An imperative integer set written in Haskell.
+--
+-- See \"/Making Haskell as fast as C: Imperative programming in Haskell/\" for a more detailed discussion, <https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html>.
+module Data.IntSet.Bounded.Imperative (
+  -- * Types
+  IntSet
+, IOIntSet
+, intSetMinBound
+, intSetMaxBound
+
+  -- * Construction
+, empty
+
+  -- * Insertion
+, insert
+
+  -- * Query
+, member
+, notMember
+
+  -- * Deletion
+, delete
+) where
+
+import Control.DeepSeq (deepseq)
+import Control.Monad.Primitive (PrimMonad(..))
+import Control.Monad.ST (ST)
+
+import Data.Bits
+import Data.Primitive.ByteArray
+import Data.Primitive.MutVar
+import Data.Word (Word64)
+
+-- | A strict bounded integer set.
+--
+-- The set is very efficient when accessing elements within the bounds
+-- of the set. It uses a regular list to hold numbers outside of this
+-- range.
+--
+-- The type parameter @s@ is determined by the monad the data structure
+-- lives in.
+data IntSet s = IntSet {
+    intSetMinBound#  :: {-# UNPACK #-} !Word64
+  , intSetMaxBound#  :: {-# UNPACK #-} !Word64
+  , intSetInBounds#  :: {-# UNPACK #-} !(MutableByteArray s)
+  , intSetOutBounds# :: {-# UNPACK #-} !(MutVar s [Word64])
+  }
+
+-- | An 'IntSet' inside the 'IO' monad.
+type IOIntSet = IntSet (PrimState IO)
+
+-- | Get the minimum efficient bound of the integer set.
+intSetMinBound :: IntSet s -> Word64
+intSetMinBound = intSetMinBound#
+{-# INLINE intSetMinBound #-}
+
+-- | Get the maximum efficient bound of the integer set.
+intSetMaxBound :: IntSet s -> Word64
+intSetMaxBound = intSetMaxBound#
+{-# INLINE intSetMaxBound #-}
+
+-- | Construct an empty integer set.
+empty :: PrimMonad m
+      => Word64           -- ^ Minimum bound of the integer set
+      -> Word64           -- ^ Maximum bound of the integer set
+      -> m (IntSet (PrimState m))
+empty !minB !maxB = do
+    let !numInBounds = (maxB - minB) `div` 8 + 1
+    set <- newByteArray (fromIntegral numInBounds)
+    fillByteArray set 0 (fromIntegral numInBounds) 0
+    outBounds <- newMutVar []
+    return $! IntSet {
+        intSetMinBound#  = minB
+      , intSetMaxBound#  = maxB
+      , intSetInBounds#  = set
+      , intSetOutBounds# = outBounds
+      }
+{-# SPECIALIZE empty :: Word64 -> Word64 -> IO (IntSet (PrimState IO)) #-}
+{-# SPECIALIZE empty :: Word64 -> Word64 -> ST s (IntSet s) #-}
+
+-- | Insert the integer in a set.
+insert :: PrimMonad m
+       => IntSet (PrimState m)
+       -> Word64
+       -> m ()
+insert !set !n = do
+    if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+        let !n'   = n - intSetMinBound# set
+        let !o    = fromIntegral $ n' `shiftR` 6
+        let !i    = fromIntegral $ n' .&. 63
+        let !mask = (1 :: Word64) `shiftL` i
+        b <- readByteArray (intSetInBounds# set) o
+        let !b' = b .|. mask
+        writeByteArray (intSetInBounds# set) o b'
+
+    else do
+        ns <- readMutVar (intSetOutBounds# set)
+        let !ns' = if n `elem` ns then ns else (n:ns)
+        writeMutVar (intSetOutBounds# set) ns'
+{-# SPECIALIZE insert :: IntSet (PrimState IO) -> Word64 -> IO () #-}
+{-# SPECIALIZE insert :: IntSet s -> Word64 -> ST s () #-}
+
+-- | Delete the integer from the set.
+delete :: PrimMonad m
+       => IntSet (PrimState m)
+       -> Word64
+       -> m ()
+delete !set !n = do
+    if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+        let !n'   = n - intSetMinBound# set
+        let !o    = fromIntegral $ n' `shiftR` 6
+        let !i    = fromIntegral $ n' .&. 63
+        let !mask = (1 :: Word64) `shiftL` i
+        b <- readByteArray (intSetInBounds# set) o
+        let !b' = b .&. (complement mask)
+        writeByteArray (intSetInBounds# set) o b'
+
+    else do
+        ns <- readMutVar (intSetOutBounds# set)
+        let ns' = filter (/= n) ns
+        ns' `deepseq` writeMutVar (intSetOutBounds# set) ns'
+{-# SPECIALIZE delete :: IntSet (PrimState IO) -> Word64 -> IO () #-}
+{-# SPECIALIZE delete :: IntSet s -> Word64 -> ST s () #-}
+
+-- | Is the integer in the set?
+member :: PrimMonad m
+       => IntSet (PrimState m)
+       -> Word64
+       -> m Bool
+member !set !n = do
+    if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+        let !n'   = n - intSetMinBound# set
+        let !o    = fromIntegral $ n' `shiftR` 6
+        let !i    = fromIntegral $ n' .&. 63
+        let !mask = (1 :: Word64) `shiftL` i
+        b <- readByteArray (intSetInBounds# set) o
+        return $! (b .&. mask) /= 0
+
+    else do
+        ns <- readMutVar (intSetOutBounds# set)
+        return $! n `elem` ns
+{-# SPECIALIZE member :: IntSet (PrimState IO) -> Word64 -> IO Bool #-}
+{-# SPECIALIZE member :: IntSet s -> Word64 -> ST s Bool #-}
+
+-- | Is the integer not in the set?
+notMember :: PrimMonad m
+          => IntSet (PrimState m)
+          -> Word64
+          -> m Bool
+notMember !set !n = not <$> member set n
+{-# INLINE notMember #-}
+{-# SPECIALIZE notMember :: IntSet (PrimState IO) -> Word64 -> IO Bool #-}
+{-# SPECIALIZE notMember :: IntSet s -> Word64 -> ST s Bool #-}
diff --git a/test-fixed/Spec.hs b/test-fixed/Spec.hs
new file mode 100644
index 0000000..9104d57
--- /dev/null
+++ b/test-fixed/Spec.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+
+import Data.Word
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+main :: IO ()
+main = do
+    let minB = 1000
+        minC = minB - 100
+    let maxB = 2000
+        maxC = maxB + 100
+    set <- BIS.empty minB maxB
+    forM_ [minC..maxC] $ \n ->
+        pass set minC maxC n
+
+pass :: BIS.IOIntSet -> Word64 -> Word64 -> Word64 -> IO ()
+pass !set !minC !maxC !n = do
+    when ((maxC - n) `rem` 100 == 0) $
+        print (maxC - n)
+
+    BIS.delete set (n-1)
+    BIS.insert set n
+
+    forM_ [minC..maxC] $ \i -> do
+        f <- BIS.member set i
+        unless ((not f && (i /= n)) || (f && (i == n))) $
+            throwIO . TestError $ "test error at " ++ show (n, i)
+
+data TestError = TestError String deriving (Show)
+
+instance Exception TestError
diff --git a/test-random/Spec.hs b/test-random/Spec.hs
new file mode 100644
index 0000000..b875a43
--- /dev/null
+++ b/test-random/Spec.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Primitive
+import Control.Monad.State
+
+import Data.HashSet (HashSet)
+import Data.Word
+import qualified Data.HashSet as HS
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+import System.Random
+
+main :: IO ()
+main = evalStateT testOnce (mkStdGen 0x28761967)
+
+testOnce :: StateT StdGen IO ()
+testOnce = do
+    let minB = 0
+    let maxB = 1*1000
+
+    let newRand :: StateT StdGen IO Word64
+        newRand = do
+            f <- getRandom
+            if f then getRandom else getRandomR (minB, maxB)
+
+    doAll 1000 HS.empty newRand =<< liftIO (BIS.empty minB maxB)
+
+    liftIO $ putStrLn "Success"
+  where
+    doAll :: Int -> HashSet Word64 -> StateT StdGen IO Word64 -> BIS.IntSet (PrimState IO) -> StateT StdGen IO ()
+    doAll !k !s' newRand s
+        | k <= 0 = return ()
+        | otherwise = do
+            when (k `rem` 100 == 0) $
+                liftIO $ print k
+
+            forM_ (HS.toList s') $ \n -> do
+                f <- liftIO $ BIS.member s n
+                unless f $
+                    liftIO . throwIO $ TestError "added number did not return true"
+
+            replicateM_ 100 $ do
+                n <- getRandom
+                f <- liftIO $ BIS.member s n
+                let g = HS.member n s'
+                when (g /= f) $
+                    liftIO . throwIO $ TestError "random number did not match"
+
+            n <- newRand
+            liftIO $ BIS.insert s n
+
+            m <- newRand
+            liftIO $ BIS.delete s m
+
+            doAll (k-1) (HS.delete m $ HS.insert n s') newRand s
+
+
+getRandom :: (MonadState g m, RandomGen g, Random a) => m a
+getRandom = do
+    g <- get
+    let (!x, !h) = random g
+    put h
+    return x
+
+getRandomR :: (MonadState g m, RandomGen g, Random a) => (a, a) -> m a
+getRandomR b = do
+    g <- get
+    let (!x, !h) = randomR b g
+    put h
+    return x
+
+
+data TestError = TestError String deriving (Show)
+
+instance Exception TestError