module Data.Array.Judy.BitSet where
import Data.Typeable
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import System.IO.Unsafe
import Data.Array.Judy.Private
import Data.Array.Judy.Freeze
import Data.Array.Judy.HashIO
newtype HashIO a => BitSet a = BitSet { judy :: ForeignPtr Judy1 }
deriving (Eq, Ord, Typeable)
instance Show (BitSet a) where
show (BitSet bs) = "<BitSet " ++ show bs ++ ">"
swapBitSets :: BitSet a -> BitSet a -> IO ()
swapBitSets (BitSet j1) (BitSet j2) = do
withForeignPtr j1 $ \p1 -> do
withForeignPtr j2 $ \p2 -> do
v1 <- peek p1
v2 <- peek p2
poke p1 v2
poke p2 v1
new :: HashIO a => IO (BitSet a)
new = do
fp <- mallocForeignPtr
addForeignPtrFinalizer judy1_free_ptr fp
withForeignPtr fp $ flip poke nullPtr
return $ BitSet fp
insert :: HashIO a => a -> BitSet a -> IO ()
insert v (BitSet j) = withForeignPtr j $ \j' -> do
v' <- hashIO v
judy1Set j' v' judyError
if v' == jerr
then putStrLn "HsJudy: Not enough memory."
else return ()
delete :: HashIO a => a -> BitSet a -> IO ()
delete v (BitSet j) = withForeignPtr j $ \j' -> do
v' <- hashIO v
judy1Unset j' v' judyError
if v' == jerr
then error "HsJudy: Not enough memory."
else return ()
set :: HashIO a => BitSet a -> a -> Bool -> IO Bool
set (BitSet k) v True = withForeignPtr k $ \j -> do
vp <- hashIO v
r <- judy1Set j vp judyError
if vp == jerr
then error "HsJudy: Not enough memory."
else return $ r == 0
set (BitSet k) v False = withForeignPtr k $ \j -> do
vp <- hashIO v
r <- judy1Unset j vp judyError
if vp == jerr
then error "HsJudy: Not enough memory."
else return $ r /= 0
get :: HashIO a => BitSet a -> a -> IO Bool
get (BitSet j) v = do
jj <- withForeignPtr j peek
vp <- hashIO v
r <- judy1Test jj vp judyError
return $ r /= 0
member :: HashIO a => a -> BitSet a -> IO Bool
member v (BitSet j) = do
j' <- withForeignPtr j peek
v' <- hashIO v
r <- judy1Test j' v' judyError
return $ r /= 0
null :: BitSet a -> IO Bool
null (BitSet j) = do
j' <- withForeignPtr j peek
return $ j' == nullPtr
size :: BitSet a -> IO Int
size (BitSet j) = do
j' <- withForeignPtr j peek
r <- judy1Count j' 0 (1) judyError
return $ fromEnum r
clear :: HashIO a => BitSet a -> IO ()
clear (BitSet j) = withForeignPtr j $ \j' -> judy1FreeArray j' judyError >> return ()
toList :: (Enum a) => BitSet t -> IO [a]
toList (BitSet j) = do
j' <- withForeignPtr j peek
alloca $ \vp -> do
poke vp (1)
let f 0 xs = return xs
f _ xs = do
v <- peek vp
v' <- unHashIO v
r <- judy1Prev j' vp judyError
f r (v':xs)
r <- judy1Last j' vp judyError
f r []
fromList :: HashIO a => [a] -> BitSet a -> IO ()
fromList vs bs = mapM_ (\v -> insert v bs) vs
instance HashIO a => Freezable (BitSet a) where
freeze = freezeBitSet
freezeBitSet :: HashIO a => BitSet a -> IO (Frozen (BitSet a))
freezeBitSet bs = do
nbs <- new
swapBitSets bs nbs
return (Frozen nbs)
memberF :: HashIO a => a -> Frozen (BitSet a) -> Bool
memberF v (Frozen bs) = unsafePerformIO $ get bs v
fromListF :: HashIO a => [a] -> Frozen (BitSet a)
fromListF vs = Frozen $ unsafePerformIO $ do
bs <- new
fromList vs bs
return bs
toListF :: (Enum a) => Frozen (BitSet t) -> [a]
toListF (Frozen (BitSet j)) = unsafePerformIO $ do
j' <- withForeignPtr j peek
alloca $ \vp -> do
poke vp (1)
let f 0 xs = return xs
f _ xs = do
v <- peek vp
v' <- unHashIO v
r <- judy1Prev j' vp judyError
f r (v':xs)
r <- judy1Last j' vp judyError
f r []