diff --git a/Data/Ring/Semi/BitSet.hs b/Data/Ring/Semi/BitSet.hs --- a/Data/Ring/Semi/BitSet.hs +++ b/Data/Ring/Semi/BitSet.hs @@ -1,20 +1,44 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable, BangPatterns, PatternGuards, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ring.Semi.BitSet +-- Copyright : (c) Edward Kmett 2009. +-- Based on Data.BitSet (c) Denis Bueno 2008-2009 +-- License : BSD3 +-- Maintainer : ekmett@gmail.com +-- Stability : experimental +-- Portability : portable (instances use MPTCs) +-- +-- Replacement for "Data.BitSet" extended to handle enumerations where fromEnum +-- can return negative values, support efficient intersection and union +-- and allow complementing of the set with respect to the bounds of the +-- enumeration +------------------------------------------------------------------------------- + module Data.Ring.Semi.BitSet ( module Data.Monoid.Reducer + , module Data.Ring.Semi + -- * BitSet , BitSet + -- * Manipulation , empty , singleton - , null , full + , union + , intersection , complement , insert , delete + , (\\) , fromList , fromDistinctAscList - , toInteger - , (\\) + -- * Acessors , member + , null , size + , isComplemented + , toInteger ) where import Prelude hiding ( null, exponent, toInteger ) @@ -22,33 +46,33 @@ import qualified Data.Bits as Bits import Data.Data import Data.Ring.Semi.Natural +import Data.Ring.Semi import Data.Monoid.Reducer import Data.Generator import Data.Ring.Algebra +import Text.Read +import Text.Show data BitSet a = BS - { _countAtLeast :: {-# UNPACK #-} !Int -- ^ a conservative upper bound on the element count - , _countAtMost :: {-# UNPACK #-} !Int -- ^ a conservative lower bound on the element count - , _count :: Int -- ^ the actual element count (lazy) used when the above two disagree - , exponent :: {-# UNPACK #-} !Int -- ^ low water mark - , _hwm :: {-# UNPACK #-} !Int -- ^ high water mark - , mantissa :: {-# UNPACK #-} !Integer -- ^ the set of bits. TODO: negative mantissa = complement - , _universe :: (Int,Int) -- ^ invariant: mantissa < 0 => universe = (fromEnum minBound,fromEnum maxBound) - } deriving (Data, Typeable,Show) - -debug :: BitSet a -> (Int,Int,Int,Int,Int,Integer) -debug (BS a b c d e f _) = (a,b,c,d,e,f) + { _countAtLeast :: {-# UNPACK #-} !Int -- ^ A conservative upper bound on the element count. + -- If negative, we are complemented with respect to the universe + , _countAtMost :: {-# UNPACK #-} !Int -- ^ A conservative lower bound on the element count. + -- If negative, we are complemented with respect to the universe + , _count :: Int -- ^ Lazy element count used when the above two disagree. O(1) environment size + , exponent :: {-# UNPACK #-} !Int -- ^ Low water mark. index of the least element potentially in the set. + , _hwm :: {-# UNPACK #-} !Int -- ^ High water mark. index of the greatest element potentially in the set. + , mantissa :: {-# UNPACK #-} !Integer -- ^ the set of bits starting from the exponent. + -- if negative, then we are complmenented with respect to universe + , _universe :: (Int,Int) -- ^ invariant: whenever mantissa < 0 => universe = (fromEnum minBound,fromEnum maxBound) + } deriving (Data, Typeable) --- | internal smart constructor: makes sure the count is forced when known +-- | Internal smart constructor. Forces count whenever it is pigeonholed. bs :: Int -> Int -> Int -> Int -> Int -> Integer -> (Int,Int) -> BitSet a bs !a !b c !l !h !m u | a == b = BS a a a l h m u | otherwise = BS a b c l h m u {-# INLINE bs #-} --- instance (Enum a, Show a) => Show (BitSet a) where --- show s = "fromDistinctAscList " ++ show (toList s) ++ - --- | /O(d)/ where /d/ is absolute deviation in fromEnum from the least element in the set. +-- | /O(d)/ where /d/ is absolute deviation in fromEnum over the set toList :: Enum a => BitSet a -> [a] toList (BS _ _ _ l h m u) | m < 0 = map toEnum [ul..max (pred l) ul] ++ toList' l (map toEnum [min (succ h) uh..uh]) @@ -61,16 +85,18 @@ | otherwise = toList' (n+1) t {-# INLINE toList #-} --- | The empty bit set. +-- | /O(1)/ The empty set. Permits /O(1)/ null and size. empty :: BitSet a empty = BS 0 0 0 0 0 0 undefined {-# INLINE empty #-} +-- | /O(1)/ Construct a @BitSet@ with a single element. Permits /O(1)/ null and size singleton :: Enum a => a -> BitSet a singleton x = BS 1 1 1 e e 1 undefined where e = fromEnum x {-# INLINE singleton #-} --- | Is the bit set empty? Asymptotically faster than checking if size == 0 in some cases. +-- | /O(1|d)/ Is the 'BitSet' empty? May be faster than checking if @'size' == 0@ after union. +-- Operations that require a recount are noted. null :: BitSet a -> Bool null (BS a b c _ _ _ _) | a > 0 = False @@ -78,25 +104,42 @@ | otherwise = c == 0 {-# INLINE null #-} +-- | /O(1|d)/ The number of elements in the bit set. +size :: BitSet a -> Int +size (BS a b c _ _ m (ul,uh)) + | a == b, m >= 0 = a + | a == b = uh - ul - a + | m >= 0 = c + | otherwise = uh - ul - c +{-# INLINE size #-} + +-- | /O(d)/ A 'BitSet' containing every member of the enumeration of @a@. full :: (Enum a, Bounded a) => BitSet a full = complement empty - -universeOf :: (Bounded a, Enum a) => BitSet a -> (Int,Int) -universeOf x = (fromEnum (minBound `asArgTypeOf` x), fromEnum (maxBound `asArgTypeOf` x)) +{-# INLINE full #-} --- ensures valid universe, may result in negative bitset, note recalculation of universe +-- | /O(d)/ Complements a 'BitSet' with respect to the bounds of @a@. Preserves order of 'null' and 'size' complement :: (Enum a, Bounded a) => BitSet a -> BitSet a -complement r@(BS a b c l h m _) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) (universeOf r) +complement r@(BS a b c l h m _) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u where + u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r)) +{-# INLINE complement #-} --- proof obligation: either the value is already complemented or it is a complement-complement, note retention of u +-- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once. recomplement :: BitSet a -> BitSet a recomplement (BS a b c l h m u) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u +{-# INLINE recomplement #-} --- | /O(d * n)/ Make a @BitSet@ from a list of items. +-- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once. +pseudoComplement :: BitSet a -> (Int,Int) -> BitSet a +pseudoComplement (BS a b c l h m _) u = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u +{-# INLINE pseudoComplement #-} + +-- | /O(d * n)/ Make a 'BitSet' from a list of items. fromList :: Enum a => [a] -> BitSet a fromList = foldr insert empty {-# INLINE fromList #-} +-- | /O(d * n)/ Make a 'BitSet' from a distinct ascending list of items fromDistinctAscList :: Enum a => [a] -> BitSet a fromDistinctAscList [] = empty fromDistinctAscList (c:cs) = fromDistinctAscList' cs 1 0 1 @@ -109,24 +152,24 @@ h' = fromEnum c' {-# INLINE fromDistinctAscList #-} --- | /O(d)/ Insert an item into the bit set. +-- | /O(d)/ Insert a single element of type @a@ into the 'BitSet'. Preserves order of 'null' and 'size' insert :: Enum a => a -> BitSet a -> BitSet a insert x r@(BS a b c l h m u) | m < 0, e < l = r | m < 0, e > h = r - | e < l = bs (a+1) (b+1) (c+1) e (h - e) (shiftL m (l - e) .|. 1) u + | e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .|. 1) u | e > h = bs (a+1) (b+1) (c+1) l p (setBit m p) u - | testBit m (e - l) = r + | testBit m p = r | otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) u where e = fromEnum x p = e - l {-# INLINE insert #-} --- | /O(d)/ Delete an item from the bit set. +-- | /O(d)/ Delete a single item from the 'BitSet'. Preserves order of 'null' and 'size' delete :: Enum a => a -> BitSet a -> BitSet a delete x r@(BS a b c l h m u) - | m < 0, e < l = bs (a+1) (b+1) (c+1) e (h - e) (shiftL m (l - e) .&. Bits.complement 1) u + | m < 0, e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .&. Bits.complement 1) u | m < 0, e > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u | e < l = r | e > h = r @@ -137,7 +180,7 @@ p = e - l {-# INLINE delete #-} --- | /O(testBit on Integer)/ Ask whether the item is in the bit set. +-- | /O(1)/ Test for membership in a 'BitSet' member :: Enum a => a -> BitSet a -> Bool member x (BS _ _ _ l h m _) | e < l = m < 0 @@ -147,33 +190,32 @@ e = fromEnum x {-# INLINE member #-} --- | /O(1)/ or /O(d)/ The number of elements in the bit set. -size :: BitSet a -> Int -size (BS a b c _ _ m (ul,uh)) - | a == b, m >= 0 = a - | a == b = uh - ul - a - | m >= 0 = c - | otherwise = uh - ul - c - -- | /O(d)/ convert to an Integer representation. Discards negative elements toInteger :: BitSet a -> Integer toInteger x = mantissa x `shift` exponent x +-- | /O(d)/. May force 'size' to take /O(d)/ if ranges overlap, preserves order of 'null' union :: BitSet a -> BitSet a -> BitSet a union x@(BS a b c l h m u) y@(BS a' b' c' l' h' m' u') - | l' < l = union y x -- ensure left side has lower exponent - | b == 0 = y -- fast empty union - | b' == 0 = x -- fast empty union - | a == -1 = BS (-1) (-1) (-1) 0 0 (-1) u -- fast full union, recomplement obligation met by negative size - | a' == -1 = BS (-1) (-1) (-1) 0 0 (-1) u' -- fast full union, recomplement obligation met by negative size - | m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y)) -- appeal to intersection, recomplement obligation met by 2s complement - | m' < 0 = recomplement (pseudoDiff (recomplement y) x u') -- union with complement, recomplement obligation met by 2s complement -- THESE ARE WRONG FIX! - | m < 0 = recomplement (pseudoDiff (recomplement x) y u) -- union with complement, recomplement obligation met by 2s complement -- THESE ARE WRONG FIX! - | h < l' = bs (a + a') (b + b') (c + c') l h' m'' u -- disjoint positive ranges - | otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' u -- overlapped positives + | l' < l = union y x -- ensure left side has lower exponent + | b == 0 = y -- fast empty union + | b' == 0 = x -- fast empty union + | a == -1 = entire u -- fast full union, recomplement obligation met by negative size + | a' == -1 = entire u' -- fast full union, recomplement obligation met by negative size + | m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y)) -- appeal to intersection, recomplement obligation met by 2s complement + | m' < 0 = recomplement (pseudoDiff (recomplement y) x u') -- union with complement, recomplement obligation met by 2s complement + | m < 0 = recomplement (pseudoDiff (recomplement x) y u) -- union with complement, recomplement obligation met by 2s complement + | h < l' = bs (a + a') (b + b') (c + c') l h' m'' u -- disjoint positive ranges + | otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' u -- overlapped positives where m'' = m .|. shiftL m' (l' - l) + entire = BS (-1) (-1) (-1) 0 0 (-1) +-- | /O(1)/ check to see if we are represented as a complemented 'BitSet'. +isComplemented :: BitSet a -> Bool +isComplemented = (<0) . mantissa + +-- | /O(d)/. May force 'size' and 'null' both to take /O(d)/. intersection :: BitSet a -> BitSet a -> BitSet a intersection x@(BS a b _ l h m u) y@(BS a' b' _ l' h' m' u') | l' < l = intersection y x @@ -190,24 +232,46 @@ l'' = max l l' m'' = shift m (l'' - l) .&. shift m' (l'' - l') --- we know m >= 0, m' >= 0, a /= -1, a' /= -1, b /= 0, b' /= 0, u' is the universe of discourse +-- | Unsafe internal method for computing differences in a particular universe of discourse +-- preconditions: +-- m >= 0, m' >= 0, a /= -1, a' /= -1, b /= 0, b' /= 0, u'' is the universe of discourse pseudoDiff :: BitSet a -> BitSet a -> (Int,Int) -> BitSet a pseudoDiff x@(BS a _ _ l h m _) (BS _ b' _ l' h' m' _) u'' | h < l' = x | h' < l = x | otherwise = bs (max (a - b') 0) a (recount m'') l h m'' u'' - where m'' = m .&. shift (Bits.complement m') (l' - l) + where + m'' = m .&. shift (Bits.complement m') (l' - l) -(\\) :: (Enum a, Bounded a) => BitSet a -> BitSet a -> BitSet a -x \\ y = x `intersection` complement y +-- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'. +difference :: Enum a => BitSet a -> BitSet a -> BitSet a +difference x@(BS a b _ _ _ m u) y@(BS a' b' _ _ _ m' _) + | a == -1 = pseudoComplement y u + | a' == -1 = empty + | b == 0 = empty + | b' == 0 = x + | m < 0, m' < 0 = pseudoDiff (recomplement y) (recomplement x) u + | m < 0 = pseudoComplement (recomplement x `union` y) u + | m' < 0 = x `union` recomplement y + | otherwise = pseudoDiff x y u + +-- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'. +(\\) :: Enum a => BitSet a -> BitSet a -> BitSet a +(\\) = difference --- TODO: fix this so that it handles complements correctly instance Eq (BitSet a) where - BS _ _ _ l _ m _ == BS _ _ _ l' _ m' _ = shift m (l'' - l) == shift m' (l'' - l) where l'' = min l l' - BS _ _ _ l _ m _ /= BS _ _ _ l' _ m' _ = shift m (l'' - l) /= shift m' (l'' - l) where l'' = min l l' + x@(BS _ _ _ l _ m u) == y@(BS _ _ _ l' _ m' _) + | signum m == signum m' = shift m (l - l'') == shift m' (l - l'') + | m' < 0 = y == x + | otherwise = mask .&. shift m (l - ul) == shift m' (l - ul) + where + l'' = min l l' + mask = setBit 0 (uh - ul + 1) - 1 + ul = fst u + uh = snd u -instance Ord (BitSet a) where - BS _ _ _ l _ m _ `compare` BS _ _ _ l' _ m' _ = shift m (l'' - l) `compare` shift m' (l'' - l) where l'' = min l l' +-- instance Ord (BitSet a) where +-- BS _ _ _ l _ m _ `compare` BS _ _ _ l' _ m' _ = shift m (l'' - l) `compare` shift m' (l'' - l) where l'' = min l l' instance (Enum a, Bounded a) => Bounded (BitSet a) where minBound = empty @@ -218,15 +282,58 @@ h = fromEnum (maxBound `asArgTypeOf` result) m = setBit 0 n - 1 +-- | Utility function to avoid requiring ScopedTypeVariables asArgTypeOf :: a -> f a -> a asArgTypeOf = const {-# INLINE asArgTypeOf #-} +-- | /O(d)/ recount :: Integer -> Int -recount = recount' 0 where - recount' :: Int -> Integer -> Int - recount' !n 0 = n - recount' !n !m = recount' (if testBit m 0 then n+1 else n) (shiftR m 1) +recount !n + | n < 0 = Bits.complement (recount (Bits.complement n)) + | otherwise = recount' 0 0 + where + h = hwm n + recount' !i !c + | i > h = c + | otherwise = recount' (i+1) (if testBit n i then c+1 else c) + +-- | /O(d)/. Computes the equivalent of (truncate . logBase 2 . abs) extended with 0 at 0 +hwm :: Integer -> Int +hwm !n + | n < 0 = hwm (-n) + | n > 1 = scan p (2*p) + | otherwise = 0 + where + p = probe 1 + -- incrementally compute 2^(2^(i+1)) until it exceeds n + probe :: Int -> Int + probe !i + | bit (2*i) > n = i + | otherwise = probe (2*i) + + -- then scan the powers for the highest set bit + scan :: Int -> Int -> Int + scan !l !h + | l == h = l + | bit (m+1) > n = scan l m + | otherwise = scan (m+1) h + where m = l + (h - l) `div` 2 + +instance (Enum a, Show a) => Show (BitSet a) where + showsPrec d x@(BS _ _ _ _ _ m u) + | m < 0 = showParen (d > 10) $ showString "pseudoComplement " . showsPrec 11 (recomplement x) . showString " " . showsPrec 11 u + | otherwise = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toList x) + +instance (Enum a, Read a) => Read (BitSet a) where + readPrec = parens $ complemented +++ normal where + complemented = prec 10 $ do + Ident "pseudoComplement" <- lexP + x <- step readPrec + pseudoComplement x `fmap` step readPrec + normal = prec 10 $ do + Ident "fromDistinctAscList" <- lexP + fromDistinctAscList `fmap` step readPrec -- note that operations on values generated by toEnum are pretty slow because the bounds are suboptimal instance (Enum a, Bounded a) => Enum (BitSet a) where diff --git a/monoids.cabal b/monoids.cabal --- a/monoids.cabal +++ b/monoids.cabal @@ -1,5 +1,5 @@ name: monoids -version: 0.1.28 +version: 0.1.30 license: BSD3 license-file: LICENSE author: Edward A. Kmett