Commit 4efb0309 authored by Petr Pudlak's avatar Petr Pudlak

Add module for implementing bit arrays in Haskell

Internally, they're implemented using IntSets, which work quite well for
both sparse and dense sets. The implementation is hidden outside the
module so it's possible to replace it with something else, if needed.
Signed-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent 3a0d7e53
......@@ -157,6 +157,7 @@ HS_DIRS = \
test/hs/Test/Ganeti/Hypervisor \
test/hs/Test/Ganeti/Hypervisor/Xen \
test/hs/Test/Ganeti/Locking \
test/hs/Test/Ganeti/Objects \
test/hs/Test/Ganeti/Query \
test/hs/Test/Ganeti/THH \
test/hs/Test/Ganeti/Utils
......@@ -819,6 +820,7 @@ HS_LIB_SRCS = \
src/Ganeti/Monitoring/Server.hs \
src/Ganeti/Network.hs \
src/Ganeti/Objects.hs \
src/Ganeti/Objects/BitArray.hs \
src/Ganeti/Objects/Lens.hs \
src/Ganeti/OpCodes.hs \
src/Ganeti/OpCodes/Lens.hs \
......@@ -919,6 +921,7 @@ HS_TEST_SRCS = \
test/hs/Test/Ganeti/Locking/Waiting.hs \
test/hs/Test/Ganeti/Network.hs \
test/hs/Test/Ganeti/Objects.hs \
test/hs/Test/Ganeti/Objects/BitArray.hs \
test/hs/Test/Ganeti/OpCodes.hs \
test/hs/Test/Ganeti/Query/Aliases.hs \
test/hs/Test/Ganeti/Query/Filter.hs \
......
{-# LANGUAGE BangPatterns, RankNTypes #-}
{-| Space efficient bit arrays
The module is meant to be imported qualified
(as it is common with collection libraries).
-}
{-
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.
-}
module Ganeti.Objects.BitArray
( BitArray
, size
, empty
, zeroes
, count0
, count1
, foldr
, (!)
, setAt
, (-&-)
, (-|-)
, subset
, asString
, fromList
, toList
) where
import Prelude hiding (foldr)
import qualified Prelude as P
import Control.Monad
import Control.Monad.Error
import qualified Data.IntSet as IS
import qualified Text.JSON as J
import Ganeti.BasicTypes
import Ganeti.JSON
-- | A fixed-size, space-efficient array of bits.
data BitArray = BitArray
{ size :: !Int
, _bitArrayBits :: !IS.IntSet
-- ^ Must not contain elements outside [0..size-1].
}
deriving (Eq, Ord)
instance Show BitArray where
show = asString '0' '1'
empty :: BitArray
empty = BitArray 0 IS.empty
zeroes :: Int -> BitArray
zeroes s = BitArray s IS.empty
-- | Right fold over the set, including indexes of each value.
foldr :: (Bool -> Int -> a -> a) -> a -> BitArray -> a
foldr f z (BitArray s bits) = let (j, x) = IS.foldr loop (s, z) bits
in feed0 (-1) j x
where
loop i (!l, x) = (i, f True i (feed0 i l x))
feed0 !i !j x | i >= j' = x
| otherwise = feed0 i j' (f False j' x)
where j' = j - 1
-- | Converts a bit array into a string, given characters
-- for @0@ and @1@/
asString :: Char -> Char -> BitArray -> String
asString c0 c1 = foldr f []
where f b _ = ((if b then c1 else c0) :)
-- | Computes the number of zeroes in the array.
count0 :: BitArray -> Int
count0 ba@(BitArray s _) = s - count1 ba
-- | Computes the number of ones in the array.
count1 :: BitArray -> Int
count1 (BitArray _ bits) = IS.size bits
infixl 9 !
-- | Test a given bit in an array.
-- If it's outside its scope, it's always @False@.
(!) :: BitArray -> Int -> Bool
(!) (BitArray s bits) i | (i >= 0) && (i < s) = IS.member i bits
| otherwise = False
-- | Sets or removes an element from a bit array.
-- | Sets a given bit in an array. Fails if the index is out of bounds.
setAt :: (MonadError e m, Error e) => Int -> Bool -> BitArray -> m BitArray
setAt i False (BitArray s bits) =
return $ BitArray s (IS.delete i bits)
setAt i True (BitArray s bits) | (i >= 0) && (i < s) =
return $ BitArray s (IS.insert i bits)
setAt i True _ = failError $ "Index out of bounds: " ++ show i
infixl 7 -&-
-- | An intersection of two bit arrays.
-- The length of the result is the minimum length of the two.
(-&-) :: BitArray -> BitArray -> BitArray
BitArray xs xb -&- BitArray ys yb = BitArray (min xs ys)
(xb `IS.intersection` yb)
infixl 5 -|-
-- | A union of two bit arrays.
-- The length of the result is the maximum length of the two.
(-|-) :: BitArray -> BitArray -> BitArray
BitArray xs xb -|- BitArray ys yb = BitArray (max xs ys) (xb `IS.union` yb)
-- | Checks if the first array is a subset of the other.
subset :: BitArray -> BitArray -> Bool
subset (BitArray _ xs) (BitArray _ ys) = IS.isSubsetOf xs ys
-- | Converts a bit array into a list of booleans.
toList :: BitArray -> [Bool]
toList = foldr (\b _ -> (b :)) []
-- | Converts a list of booleans to a 'BitArray'.
fromList :: [Bool] -> BitArray
fromList xs =
-- Note: This traverses the list twice. It'd be better to compute everything
-- in one pass.
BitArray (length xs) (IS.fromList . map fst . filter snd . zip [0..] $ xs)
instance J.JSON BitArray where
showJSON = J.JSString . J.toJSString . show
readJSON j = do
let parseBit '0' = return False
parseBit '1' = return True
parseBit c = fail $ "Neither '0' nor '1': '" ++ [c] ++ "'"
str <- readEitherString j
fromList `liftM` mapM parseBit str
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-| Unittests for bit arrays
-}
{-
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.
-}
module Test.Ganeti.Objects.BitArray
( testObjects_BitArray
, genBitArray
) where
import Test.QuickCheck
import Control.Applicative
import Control.Monad
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
import Ganeti.Objects.BitArray as BA
-- * Arbitrary instances
instance Arbitrary BitArray where
arbitrary = fromList <$> arbitrary
genBitArray :: Int -> Gen BitArray
genBitArray = liftA fromList . vector
prop_BitArray_serialisation :: BitArray -> Property
prop_BitArray_serialisation = testSerialisation
prop_BitArray_foldr :: [Bool] -> Property
prop_BitArray_foldr bs =
BA.foldr (((:) .) . (,)) [] (fromList bs) ==? zip bs [0..]
prop_BitArray_fromToList :: BitArray -> Property
prop_BitArray_fromToList bs =
BA.fromList (BA.toList bs) ==? bs
prop_BitArray_and :: [Bool] -> [Bool] -> Property
prop_BitArray_and xs ys =
(BA.fromList xs -&- BA.fromList ys) ==? BA.fromList (zipWith (&&) xs ys)
prop_BitArray_or :: [Bool] -> [Bool] -> Property
prop_BitArray_or xs ys =
let xsl = length xs
ysl = length ys
l = max xsl ysl
comb = zipWith (||) (xs ++ replicate (l - xsl) False)
(ys ++ replicate (l - ysl) False)
in (BA.fromList xs -|- BA.fromList ys) ==? BA.fromList comb
-- | Check that the counts of 1 bits holds.
prop_BitArray_counts :: Property
prop_BitArray_counts = do
n <- choose (0, 3)
ones <- replicateM n (lst True)
zrs <- replicateM n (lst False)
start <- lst False
let count = sum . map length $ ones
bs = start ++ concat (zipWith (++) ones zrs)
count1 (BA.fromList bs) ==? count
where
lst x = (`replicate` x) `liftM` choose (0, 2)
-- | Check that the counts of free and occupied bits add up.
prop_BitArray_countsSum :: BitArray -> Property
prop_BitArray_countsSum a =
count0 a + count1 a ==? size a
testSuite "Objects_BitArray"
[ 'prop_BitArray_serialisation
, 'prop_BitArray_foldr
, 'prop_BitArray_fromToList
, 'prop_BitArray_and
, 'prop_BitArray_or
, 'prop_BitArray_counts
, 'prop_BitArray_countsSum
]
......@@ -62,6 +62,7 @@ import Test.Ganeti.Locking.Waiting
import Test.Ganeti.Luxi
import Test.Ganeti.Network
import Test.Ganeti.Objects
import Test.Ganeti.Objects.BitArray
import Test.Ganeti.OpCodes
import Test.Ganeti.Query.Aliases
import Test.Ganeti.Query.Filter
......@@ -131,6 +132,7 @@ allTests =
, testLuxi
, testNetwork
, testObjects
, testObjects_BitArray
, testOpCodes
, testQuery_Aliases
, testQuery_Filter
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment