module Data.Ring.Semi.BitSet
( module Data.Monoid.Reducer
, BitSet
, empty
, singleton
, null
, full
, complement
, insert
, delete
, fromList
, fromDistinctAscList
, toInteger
, (\\)
, member
, size
) where
import Prelude hiding ( null, exponent, toInteger )
import Data.Bits hiding ( complement )
import qualified Data.Bits as Bits
import Data.Data
import Data.Ring.Semi.Natural
import Data.Monoid.Reducer
import Data.Generator
import Data.Ring.Algebra
data BitSet a = BS
{ _countAtLeast :: !Int
, _countAtMost :: !Int
, _count :: Int
, exponent :: !Int
, _hwm :: !Int
, mantissa :: !Integer
, _universe :: (Int,Int)
} 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)
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
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])
| otherwise = toList' 0 []
where
~(ul,uh) = u
toList' :: Enum a => Int -> [a] -> [a]
toList' !n t | n > h = t
| testBit m (n l) = toEnum n : toList' (n+1) t
| otherwise = toList' (n+1) t
empty :: BitSet a
empty = BS 0 0 0 0 0 0 undefined
singleton :: Enum a => a -> BitSet a
singleton x = BS 1 1 1 e e 1 undefined where e = fromEnum x
null :: BitSet a -> Bool
null (BS a b c _ _ _ _)
| a > 0 = False
| b == 0 = True
| otherwise = c == 0
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))
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)
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
fromList :: Enum a => [a] -> BitSet a
fromList = foldr insert empty
fromDistinctAscList :: Enum a => [a] -> BitSet a
fromDistinctAscList [] = empty
fromDistinctAscList (c:cs) = fromDistinctAscList' cs 1 0 1
where
l = fromEnum c
fromDistinctAscList' :: Enum a => [a] -> Int -> Int -> Integer -> BitSet a
fromDistinctAscList' [] !n !h !m = BS n n n l h m undefined
fromDistinctAscList' (c':cs') !n _ !m = fromDistinctAscList' cs' (n+1) h' (setBit m (h' l))
where
h' = fromEnum c'
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 > h = bs (a+1) (b+1) (c+1) l p (setBit m p) u
| testBit m (e l) = r
| otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) u
where
e = fromEnum x
p = e l
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 > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u
| e < l = r
| e > h = r
| testBit m p = bs (a1) (b1) (c1) l h (clearBit m p) u
| otherwise = r
where
e = fromEnum x
p = e l
member :: Enum a => a -> BitSet a -> Bool
member x (BS _ _ _ l h m _)
| e < l = m < 0
| e > h = m > 0
| otherwise = testBit m (e l)
where
e = fromEnum x
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
toInteger :: BitSet a -> Integer
toInteger x = mantissa x `shift` exponent x
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
| b == 0 = y
| b' == 0 = x
| a == 1 = BS (1) (1) (1) 0 0 (1) u
| a' == 1 = BS (1) (1) (1) 0 0 (1) u'
| m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y))
| m' < 0 = recomplement (pseudoDiff (recomplement y) x u')
| m < 0 = recomplement (pseudoDiff (recomplement x) y u)
| h < l' = bs (a + a') (b + b') (c + c') l h' m'' u
| otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' u
where
m'' = m .|. shiftL m' (l' l)
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
| b == 0 = empty
| b' == 0 = empty
| a == 1 = y
| a' == 1 = x
| m < 0, m' < 0 = recomplement (union (recomplement x) (recomplement y))
| m' < 0 = pseudoDiff x (recomplement y) u'
| m < 0 = pseudoDiff y (recomplement x) u
| h < l' = empty
| otherwise = bs 0 (b `min` b') (recount m'') l'' (h `min` h') m'' u
where
l'' = max l l'
m'' = shift m (l'' l) .&. shift m' (l'' l')
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)
(\\) :: (Enum a, Bounded a) => BitSet a -> BitSet a -> BitSet a
x \\ y = x `intersection` complement y
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'
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
maxBound = result where
result = BS n n n l h m (l,h)
n = h l + 1
l = fromEnum (minBound `asArgTypeOf` result)
h = fromEnum (maxBound `asArgTypeOf` result)
m = setBit 0 n 1
asArgTypeOf :: a -> f a -> a
asArgTypeOf = const
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)
instance (Enum a, Bounded a) => Enum (BitSet a) where
fromEnum b@(BS _ _ _ l _ m _) = fromInteger (shiftL m (l l'))
where
l' = fromEnum (minBound `asArgTypeOf` b)
toEnum i = result
where
result = BS a i (recount m) l h m undefined
l = fromEnum (minBound `asArgTypeOf` result)
h = fromEnum (maxBound `asArgTypeOf` result)
m = fromIntegral i
a | m /= 0 = 1
| otherwise = 0
instance Enum a => Monoid (BitSet a) where
mempty = empty
mappend = union
instance Enum a => Reducer a (BitSet a) where
unit = singleton
snoc = flip insert
cons = insert
instance (Bounded a, Enum a) => Multiplicative (BitSet a) where
one = full
times = intersection
instance (Bounded a, Enum a) => LeftSemiNearRing (BitSet a)
instance (Bounded a, Enum a) => RightSemiNearRing (BitSet a)
instance (Bounded a, Enum a) => SemiRing (BitSet a)
instance Enum a => LeftModule Natural (BitSet a) where
0 *. _ = empty
_ *. m = m
instance Enum a => RightModule Natural (BitSet a) where
_ .* 0 = empty
m .* _ = m
instance Enum a => Module Natural (BitSet a)
instance (Bounded a, Enum a) => LeftModule (BitSet a) (BitSet a) where (*.) = times
instance (Bounded a, Enum a) => RightModule (BitSet a) (BitSet a) where (.*) = times
instance (Bounded a, Enum a) => Module (BitSet a) (BitSet a)
instance (Bounded a, Enum a) => Algebra Natural (BitSet a)
instance Enum a => Generator (BitSet a) where
type Elem (BitSet a) = a
mapReduce f = mapReduce f . toList