module Data.Ring.Semi.BitSet
( module Data.Monoid.Reducer
, module Data.Ring
, BitSet
, empty
, singleton
, full
, union
, intersection
, complement
, insert
, delete
, (\\)
, fromList
, fromDistinctAscList
, member
, null
, size
, isComplemented
, toInteger
) where
import Prelude hiding ( null, exponent, toInteger, foldl, foldr, foldl1, foldr1 )
import Data.Bits
import Data.Foldable hiding ( toList )
import Data.Data
import Data.Ring.Semi.Natural
import Data.Ring
import Data.Monoid.Reducer
import Data.Generator
import Data.Ring.Module
import Text.Read
import Text.Show
data BitSet a = BS
{ _countAtLeast :: !Int
, _countAtMost :: !Int
, _count :: Int
, exponent :: !Int
, _hwm :: !Int
, mantissa :: !Integer
, _universe :: (Int,Int)
, _fromEnum :: Int -> a
} deriving (Typeable)
instance (Enum a, Data a) => Data (BitSet a) where
gfoldl f z im = z fromList `f` toList im
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNorepType "Data.Ring.Semi.BitSet.BitSet"
dataCast1 f = gcast1 f
bs :: Enum a => 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 toEnum
| otherwise = BS a b c l h m u toEnum
toList :: BitSet a -> [a]
toList (BS _ _ _ l h m u f)
| m < 0 = map f [ul..max (pred l) ul] ++ toList' l (map f [min (succ h) uh..uh])
| otherwise = toList' 0 []
where
~(ul,uh) = u
toList' !n t
| n > h = t
| testBit m (n l) = f n : toList' (n+1) t
| otherwise = toList' (n+1) t
empty :: Enum a => BitSet a
empty = BS 0 0 0 0 0 0 undefined toEnum
singleton :: Enum a => a -> BitSet a
singleton x = BS 1 1 1 e e 1 undefined toEnum where e = fromEnum x
null :: BitSet a -> Bool
null (BS a b c _ _ _ _ _)
| a > 0 = False
| b == 0 = True
| otherwise = c == 0
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
full :: (Enum a, Bounded a) => BitSet a
full = complement' empty
recomplement :: BitSet a -> BitSet a
recomplement (BS a b c l h m u f) = BS (complement b) (complement a) (complement c) l h (complement m) u f
pseudoComplement :: BitSet a -> (Int,Int) -> BitSet a
pseudoComplement (BS a b c l h m _ f) u = BS (complement b) (complement a) (complement c) l h (complement m) u f
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 toEnum
fromDistinctAscList' (c':cs') !n _ !m =
let h' = fromEnum c' in
fromDistinctAscList' cs' (n+1) h' (setBit m (h' l))
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
| b == 0 = singleton x
| a == 1 = r
| 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 p = 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 (shiftL m (l e) .&. complement 1) u
| m < 0, e > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u
| b == 0 = r
| a == 1 = pseudoComplement (singleton x) 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
toInteger :: BitSet a -> Integer
toInteger x = mantissa x `shift` exponent x
union :: Enum a => BitSet a -> BitSet a -> BitSet a
union x@(BS a b c l h m u f) y@(BS a' b' c' l' h' m' u' _)
| l' < l = union y x
| b == 0 = y
| b' == 0 = x
| a == 1 = entire u
| a' == 1 = entire u'
| m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y))
| m' < 0 = recomplement (diff (recomplement y) x u')
| m < 0 = recomplement (diff (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)
entire u'' = BS (1) (1) (1) 0 0 (1) u'' f
isComplemented :: Enum a => BitSet a -> Bool
isComplemented = (<0) . mantissa
intersection :: Enum a => 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 = diff x (recomplement y) u'
| m < 0 = diff 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')
diff :: Enum a => BitSet a -> BitSet a -> (Int,Int) -> BitSet a
diff 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 (complement m') (l' l)
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 = diff (recomplement y) (recomplement x) u
| m < 0 = pseudoComplement (recomplement x `union` y) u
| m' < 0 = x `union` recomplement y
| otherwise = diff x y u
(\\) :: Enum a => BitSet a -> BitSet a -> BitSet a
(\\) = difference
instance Eq (BitSet a) where
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 (Enum a, Bounded a) => Bounded (BitSet a) where
minBound = empty
maxBound = result where
result = BS n n n l h m (l,h) toEnum
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 !n
| n < 0 = complement (recount (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)
hwm :: Integer -> Int
hwm !n
| n < 0 = hwm (n)
| n > 1 = scan p (2*p)
| otherwise = 0
where
p = probe 1
probe :: Int -> Int
probe !i
| bit (2*i) > n = i
| otherwise = probe (2*i)
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 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
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 toEnum
l = fromEnum (minBound `asArgTypeOf` result)
h = fromEnum (maxBound `asArgTypeOf` result)
m = fromIntegral i
a | m /= 0 = 1
| otherwise = 0
instance Foldable BitSet where
fold = fold . toList
foldMap f = foldMap f . toList
foldr f z = foldr f z . toList
foldl f z = foldl f z . toList
foldr1 f = foldr1 f . toList
foldl1 f = foldl1 f . toList
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) => Ringoid (BitSet a)
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 => Module Natural (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 => Bimodule Natural (BitSet a)
instance (Bounded a, Enum a) => Algebra Natural (BitSet a)
instance (Bounded a, Enum a) => Module (BitSet a) (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) => Bimodule (BitSet a) (BitSet a)
instance (Bounded a, Enum a) => Algebra (BitSet a) (BitSet a)
instance Generator (BitSet a) where
type Elem (BitSet a) = a
mapReduce f = mapReduce f . toList
instance (Show a, Bounded a, Enum a) => Num (BitSet a) where
(+) = union
() = difference
(*) = intersection
fromInteger m = r where
r = BS c c c 0 (hwm m) m u toEnum where
c = recount m
u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))
abs b | mantissa b < 0 = recomplement b
| otherwise = b
signum = error "BitSet.signum undefined"
instance (Show a, Bounded a, Enum a) => Bits (BitSet a) where
(.&.) = intersection
(.|.) = union
a `xor` b = (a .|. b) .&. complement (a .&. b)
complement r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where
u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))
shift = error "BitSet.shift undefined"
rotate = error "BitSet.rotate undefined"
bit = singleton . toEnum
setBit s b = s `union` singleton (toEnum b)
clearBit s b = s `difference` singleton (toEnum b)
complementBit s b = s `xor` singleton (toEnum b)
testBit s b = member (toEnum b) s
bitSize r = fromEnum (maxBound `asArgTypeOf` r) fromEnum (minBound `asArgTypeOf` r)
isSigned _ = True
complement' :: (Bounded a, Enum a) => BitSet a -> BitSet a
complement' r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where
u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))