#if __GLASGOW_HASKELL__
#endif
#if __GLASGOW_HASKELL__ >= 720
#endif
module Data.IntervalSet.Internal
(
IntSet(..), Key
, Union, Intersection, Difference
, Data.IntervalSet.Internal.null
, size
, member, notMember
, isSubsetOf, isSupersetOf
, isProperSubsetOf, isProperSupersetOf
, empty
, singleton
, interval
, naturals
, negatives
, universe
, insert
, delete
, Data.IntervalSet.Internal.map
, Data.IntervalSet.Internal.foldr
, Data.IntervalSet.Internal.filter
, split, splitGT, splitLT
, partition
, findMin, findMax
, union, unions
, intersection, intersections
, difference, symDiff
, elems
, toList, fromList
, toAscList, toDescList
, fromAscList
, Prefix, Mask, BitMap
, finMask, nomatch, match, mask, insertFin, properSubsetOf
, intersectBM
, tip, tipI, tipD, bin
, insertBM
, unionBM
, splitFin
, binCount, tipCount, finCount
, wordCount
, savedSpace
, ppStats
, isValid
, showTree, showRaw
, putTree, putRaw
, symDiff'
) where
import Control.DeepSeq
import Data.Bits as Bits
import Data.Bits.Extras
import Data.Data
import qualified Data.List as L
import Data.Monoid
import Data.Ord
import Data.Word
import Text.ParserCombinators.ReadP
#if defined(__GLASGOW_HASKELL__)
#include "MachDeps.h"
#endif
type Prefix = Int
type Mask = Int
type BitMap = Word
type Key = Int
data IntSet
= Bin !Prefix !Mask !IntSet !IntSet
| Tip !Prefix !BitMap
| Fin !Prefix !Mask
| Nil
deriving
( Eq
#if defined(__GLASGOW_HASKELL__)
, Typeable, Data
#endif
)
isValid :: IntSet -> Bool
isValid Nil = True
isValid (Tip p bm) = not (isFull bm) && (p `mod` WORD_SIZE_IN_BITS == 0)
isValid (Fin _ m ) = m >= WORD_SIZE_IN_BITS
isValid (Bin _ _ Nil _ ) = error "Bin _ _ Nil _"
isValid (Bin _ _ _ Nil) = error "Bin _ _ _ Nil"
isValid (Bin _ m (Fin _ m1) (Fin _ m2))
= not (m == m1 && m == m2)
isValid (Bin _ _ l r)
= isValid l && isValid r
instance Show IntSet where
showsPrec _ s = showString "{" . list (toList s) . showString "}"
where
list [] = showString ""
list [x] = shows x
list (x : xs) = shows x . showString "," . list xs
instance Read IntSet where
readsPrec _ = readP_to_S $ do
"{" <- readS_to_P lex
xs <- readS_to_P reads `sepBy` (skipSpaces >> char ',')
"}" <- readS_to_P lex
return (fromList xs)
instance Ord IntSet where
compare = comparing toList
instance Monoid IntSet where
mempty = empty
mappend = union
mconcat = unions
instance Num IntSet where
(+) = union
(*) = intersection
() = difference
negate = Data.IntervalSet.Internal.complement
abs = error "IntervalSet.abs: not implemented"
signum = error "IntervalSet.singum: not implemented"
fromInteger = singleton . fromIntegral
instance Bounded IntSet where
minBound = empty
maxBound = universe
instance NFData IntSet where
newtype Union = Union { getUnion :: IntSet }
deriving (Show, Read, Eq, Ord)
instance Monoid Union where
mempty = Union empty
mappend a b = Union (getUnion a `union` getUnion b)
mconcat = Union . unions . L.map getUnion
newtype Intersection = Intersection { getIntersection :: IntSet }
deriving (Show, Read, Eq, Ord)
instance Monoid Intersection where
mempty = Intersection universe
mappend a b = Intersection (getIntersection a `intersection` getIntersection b)
mconcat = Intersection . intersections . L.map getIntersection
newtype Difference = Difference { getDifference :: IntSet }
deriving (Show, Read, Eq, Ord)
instance Monoid Difference where
mempty = Difference empty
mappend a b = Difference (getDifference a `symDiff` getDifference b)
null :: IntSet -> Bool
null Nil = True
null _ = False
size :: IntSet -> Int
size (Bin _ _ l r) = size l + size r
size (Tip _ bm ) = popCount bm
size (Fin _ m ) | m > 0 = m
| otherwise = error "IntSet.size: int overflow"
size Nil = 0
member :: Key -> IntSet -> Bool
member !x = go
where
go (Bin p m l r)
| nomatch x p m = False
| zero x m = go l
| otherwise = go r
go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0
go (Fin p m) = p <= x && (x <= (p + m 1))
go Nil = False
notMember :: Key -> IntSet -> Bool
notMember !x = not . member x
isSubsetOf :: IntSet -> IntSet -> Bool
isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
| m1 `shorter` m2 = False
| m2 `shorter` m1 = match p1 p2 m2 && matchDown
| otherwise = p1 == p2 && isSubsetOf l1 l2 && isSubsetOf r1 r2
where
matchDown
| zero p1 m2 = isSubsetOf t1 l2
| otherwise = isSubsetOf t1 r2
isSubsetOf Bin {} Tip {} = False
isSubsetOf (Bin p1 m1 _ _) (Fin p2 m2)
= finMask m2 `shorterEq` m1 && match p1 p2 (finMask m2)
isSubsetOf Bin {} Nil = False
isSubsetOf t1@(Tip p1 _ ) (Bin p2 m2 l r)
| nomatch p1 p2 m2 = False
| zero p1 m2 = isSubsetOf t1 l
| otherwise = isSubsetOf t1 r
isSubsetOf (Tip p1 bm1) (Tip p2 bm2)
= p1 == p2 && isSubsetOfBM bm1 bm2
isSubsetOf (Tip p1 _ ) (Fin p2 m2 ) = match p1 p2 (finMask m2)
isSubsetOf Tip {} Nil = False
isSubsetOf t1@(Fin p1 m1 ) (Bin p2 m2 l r)
| finMask m1 `shorterEq` m2 = False
| nomatch p1 p2 m2 = False
| zero p1 m2 = isSubsetOf t1 l
| otherwise = isSubsetOf t1 r
isSubsetOf Fin {} Tip {} = False
isSubsetOf (Fin p1 m1 ) (Fin p2 m2)
= m2 `shorterEq` m1 && match p1 p2 (finMask m2)
isSubsetOf Fin {} Nil = False
isSubsetOf Nil _ = True
isSubsetOfBM :: BitMap -> BitMap -> Bool
isSubsetOfBM bm1 bm2 = bm1 .|. bm2 == bm2
isSupersetOf :: IntSet -> IntSet -> Bool
isSupersetOf = flip isSubsetOf
isProperSubsetOf :: IntSet -> IntSet -> Bool
isProperSubsetOf = error "isProper subset of"
isProperSupersetOf :: IntSet -> IntSet -> Bool
isProperSupersetOf = flip isProperSubsetOf
empty :: IntSet
empty = Nil
singleton :: Key -> IntSet
singleton x = Tip (prefixOf x) (bitmapOf x)
interval :: Key -> Key -> IntSet
interval l r
| l < 0 && r >= 0 = go l (1) `union` go 0 r
| otherwise = go l r
where
go a b
| b < a = empty
| WORD_SIZE_IN_BITS `shorter` m = tip (prefixOf a) (intervalBM a b)
| otherwise = bin p m (interval a (mid 1)) (interval mid b)
where
mid = p .|. m
p = mask a m
m = branchMask a b
intervalBM :: Int -> Int -> BitMap
intervalBM a b =
let abm = bitmapOf a
bbm = bitmapOf b
in fromIntegral (Bits.complement (abm 1) .&. ((bbm 1) .|. bbm))
naturals :: IntSet
naturals = Fin 0 (bit (WORD_SIZE_IN_BITS 1))
negatives :: IntSet
negatives = Fin (bit (WORD_SIZE_IN_BITS 1)) (bit (WORD_SIZE_IN_BITS 1))
universe :: IntSet
universe = Fin (bit (WORD_SIZE_IN_BITS 1)) 0
insert :: Key -> IntSet -> IntSet
insert !x = insertBM (prefixOf x) (bitmapOf x)
insertBM :: Prefix -> BitMap -> IntSet -> IntSet
insertBM !kx !bm = go
where
go t@(Bin p m l r)
| nomatch kx p m = join kx (Tip kx bm) p t
| zero kx m = binI p m (insertBM kx bm l) r
| otherwise = binI p m l (insertBM kx bm r)
go t@(Tip kx' bm')
| kx' == kx = tipI kx (bm .|. bm')
| otherwise = join kx (Tip kx bm) kx' t
go t@(Fin p m )
| nomatch kx p (finMask m) = join kx (Tip kx bm) p t
| otherwise = t
go Nil = Tip kx bm
delete :: Key -> IntSet -> IntSet
delete !x = deleteBM (prefixOf x) (bitmapOf x)
deleteBM :: Prefix -> BitMap -> IntSet -> IntSet
deleteBM !kx !bm = go
where
go t@(Bin p m l r)
| nomatch kx p m = t
| zero kx m = binD p m (deleteBM kx bm l) r
| otherwise = binD p m l (deleteBM kx bm r)
go t@(Tip kx' bm')
| kx == kx' = tipD kx (bm' .&. Bits.complement bm)
| otherwise = t
go t@(Fin p m)
| nomatch kx p (finMask m) = t
| otherwise = deleteBM kx bm (splitFin p m)
go Nil = Nil
splitFin :: Prefix -> Mask -> IntSet
splitFin p m
| m == WORD_SIZE_IN_BITS = Tip p (Bits.complement 0)
| otherwise = Bin p m' (Fin p m') (Fin (p + m') m')
where
m' = intFromNat (natFromInt m `shiftR` 1)
complement :: IntSet -> IntSet
complement Nil = universe
complement _ = error "complement: not implemented"
infixl 6 `union`
union :: IntSet -> IntSet -> IntSet
union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = leftiest
| shorter m2 m1 = rightiest
| p1 == p2 = binI p1 m1 (l1 `union` l2) (r1 `union` r2)
| otherwise = join p1 t1 p2 t2
where
leftiest
| nomatch p2 p1 m1 = join p1 t1 p2 t2
| zero p2 m1 = binI p1 m1 (l1 `union` t2) r1
| otherwise = binI p1 m1 l1 (r1 `union` t2)
rightiest
| nomatch p1 p2 m2 = join p1 t1 p2 t2
| zero p1 m2 = binI p2 m2 (t1 `union` l2) r2
| otherwise = binI p2 m2 l2 (t1 `union` r2)
union t@ Bin {} (Tip p bm) = insertBM p bm t
union t@ Bin {} (Fin p m ) = insertFin p m t
union t@ Bin {} Nil = t
union (Fin p m ) t = insertFin p m t
union (Tip p bm) t = insertBM p bm t
union Nil t = t
insertFin :: Prefix -> Mask -> IntSet -> IntSet
insertFin p1 m1 t2@(Bin p2 m2 l r)
| m2 `shorterEq` m1 && match p1 p2 m2 =
if zero p1 m2
then binI p2 m2 (insertFin p1 m1 l) r
else binI p2 m2 l (insertFin p1 m1 r)
| match p2 p1 (finMask m1) = Fin p1 m1
| otherwise = join p1 (Fin p1 m1) p2 t2
insertFin p1 m1 (Tip p bm) = insertBM p bm (Fin p1 m1)
insertFin p1 m1 (Fin p2 m2 )
| isBuddy p1 m1 p2 m2 = Fin p1 (m1 * 2)
| isBuddy p2 m2 p1 m1 = Fin p2 (m1 * 2)
| properSubsetOf p1 m1 p2 m2 = Fin p2 m2
| properSubsetOf p2 m2 p1 m1 = Fin p1 m1
| m1 == m2 && p1 == p2 = Fin p1 m1
| otherwise = join p1 (Fin p1 m1) p2 (Fin p2 m2)
insertFin p m Nil = Fin p m
unions :: [IntSet] -> IntSet
unions = L.foldl' union empty
isBuddy :: Prefix -> Mask -> Prefix -> Mask -> Bool
isBuddy !p1 !m1 !p2 !m2 = m1 == m2 && xor p1 p2 == m1 && p1 .&. m1 == 0
properSubsetOf :: Prefix -> Mask -> Prefix -> Mask -> Bool
properSubsetOf !p1 !m1 !p2 !m2 = (m2 `shorter` m1) && match p1 p2 (finMask m2)
unionBM :: Prefix -> BitMap -> IntSet -> IntSet
unionBM !p !bm !t = case tip p bm of
Bin {} -> error "unionBM: impossible"
Fin p' m' -> insertFin p' m' t
Tip p' bm' -> insertBM p' bm' t
Nil -> t
infixl 7 `intersection`
intersection :: IntSet -> IntSet -> IntSet
intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| m1 `shorter` m2 = leftiest
| m2 `shorter` m1 = rightiest
| p1 == p2 = binD p1 m1 (intersection l1 l2) (intersection r1 r2)
| otherwise = Nil
where
leftiest
| nomatch p2 p1 m1 = Nil
| zero p2 m1 = intersection l1 t2
| otherwise = intersection r1 t2
rightiest
| nomatch p1 p2 m2 = Nil
| zero p1 m2 = intersection t1 l2
| otherwise = intersection t1 r2
intersection t@ Bin {} (Tip p bm) = intersectBM p bm t
intersection t@ Bin {} (Fin p m) = intersectFin p m t
intersection Bin {} Nil = Nil
intersection (Tip p bm) t = intersectBM p bm t
intersection (Fin p m) t = intersectFin p m t
intersection Nil _ = Nil
intersectFin :: Prefix -> Mask -> IntSet -> IntSet
intersectFin p1 m1 t@(Bin p2 m2 l r)
| m2 `shorterEq` m1 && match p1 p2 m2
= if zero p1 m2
then intersectFin p1 m1 l
else intersectFin p1 m1 r
| match p2 p1 (finMask m1) = t
| otherwise = Nil
intersectFin p1 m1 (Tip p2 bm2)
| match p2 p1 (finMask m1) = Tip p2 bm2
| otherwise = Nil
intersectFin p1 m1 (Fin p2 m2)
| finSubsetOf p1 m1 p2 m2 = Fin p1 m1
| finSubsetOf p2 m2 p1 m1 = Fin p2 m2
| otherwise = Nil
intersectFin _ _ Nil = Nil
finSubsetOf :: Prefix -> Mask -> Prefix -> Mask -> Bool
finSubsetOf p1 m1 p2 m2 = (m2 `shorterEq` m1) && match p1 p2 (finMask m2)
intersectBM :: Prefix -> BitMap -> IntSet -> IntSet
intersectBM p1 bm1 (Bin p2 m2 l r)
| nomatch p1 p2 m2 = Nil
| zero p1 m2 = intersectBM p1 bm1 l
| otherwise = intersectBM p1 bm1 r
intersectBM p1 bm1 (Tip p2 bm2 )
| p1 == p2 = tipD p1 (bm1 .&. bm2)
| otherwise = Nil
intersectBM p1 bm1 (Fin p2 m2)
| match p1 p2 (finMask m2) = Tip p1 bm1
| otherwise = Nil
intersectBM _ _ Nil = Nil
intersections :: [IntSet] -> IntSet
intersections = L.foldl' intersection empty
infixl 6 `difference`
difference :: IntSet -> IntSet -> IntSet
difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| m1 `shorter` m2 = leftiest
| m2 `shorter` m1 = rightiest
| p1 == p2 = binD p1 m1 (difference l1 l2) (difference r1 r2)
| otherwise = t1
where
leftiest
| nomatch p2 p1 m1 = t1
| zero p2 m1 = binD p1 m1 (difference l1 t2) r1
| otherwise = binD p1 m1 l1 (difference r1 t2)
rightiest
| nomatch p1 p2 m2 = t1
| zero p1 m2 = difference t1 l2
| otherwise = difference t1 r2
difference t1@ Bin {} (Tip p bm) = deleteBM p bm t1
difference t1@(Bin p1 m1 _ _) (Fin p2 m2)
| m1 `shorter` finMask m2
= if match p2 p1 m1
then difference t1 (splitFin p2 m2)
else t1
| finMask m2 `shorter` m1
= if match p1 p2 (finMask m2)
then Nil
else t1
| p1 == p2 = Nil
| otherwise = t1
difference t1@ Bin {} Nil = t1
difference t1@(Tip p _ ) (Bin p2 m2 l r)
| nomatch p p2 m2 = t1
| zero p m2 = difference t1 l
| otherwise = difference t1 r
difference t1@ Tip {} (Tip p bm) = deleteBM p bm t1
difference t1@(Tip p1 _) (Fin p2 m2 )
| nomatch p1 p2 (finMask m2) = t1
| otherwise = Nil
difference t1@(Tip _ _) Nil = t1
difference t1@(Fin p1 m1) t2@(Bin p2 m2 l r)
| finMask m1 `shorter` m2
= if match p2 p1 (finMask m1)
then difference (splitFin p1 m1) t2
else t1
| m2 `shorter` finMask m1 = down
| p1 == p2 = difference (splitFin p1 m1) t2
| otherwise = t1
where
down
| nomatch p1 p2 m2 = t1
| zero p1 m2 = difference t1 l
| otherwise = difference t1 r
difference t1@(Fin _ _) (Tip p bm) = deleteBM p bm t1
difference t1@(Fin p1 m1) t2@(Fin p2 m2)
| m1 `shorter` m2
= if match p2 p1 (finMask m1)
then difference (splitFin p1 m1) t2
else t1
| m2 `shorter` m1 =
if match p1 p2 (finMask m2)
then Nil
else t1
| p1 == p2 = Nil
| otherwise = t1
difference t1@(Fin _ _) Nil = t1
difference Nil _ = Nil
symDiff' :: IntSet -> IntSet -> IntSet
symDiff' a b = (a `union` b) `difference` (a `intersection` b)
symDiff :: IntSet -> IntSet -> IntSet
symDiff t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| m1 `shorter` m2 = leftiest
| m2 `shorter` m1 = rightiest
| p1 == p2 = bin p1 m1 (symDiff l1 l2) (symDiff r1 r2)
| otherwise = join p1 t1 p2 t2
where
leftiest
| nomatch p2 p1 m1 = join p1 t1 p2 t2
| zero p2 m1 = bin p1 m1 (symDiff l1 t2) r1
| otherwise = bin p1 m1 l1 (symDiff r1 t2)
rightiest
| nomatch p1 p2 m2 = join p2 t2 p1 t1
| zero p1 m2 = bin p2 m2 (symDiff l2 t1) r2
| otherwise = bin p2 m2 l2 (symDiff r2 t1)
symDiff t1@ Bin {} (Tip p2 bm2 ) = symDiffTip p2 bm2 t1
symDiff t1@ Bin {} (Fin p2 m2 ) = symDiffFin p2 m2 t1
symDiff t1@ Bin {} Nil = t1
symDiff (Tip p1 bm1 ) t2 = symDiffTip p1 bm1 t2
symDiff (Fin p1 m1 ) t2 = symDiffFin p1 m1 t2
symDiff Nil t2 = t2
symDiffTip :: Prefix -> BitMap -> IntSet -> IntSet
symDiffTip !p1 !bm1 = go
where
go t2@(Bin p2 m2 l r)
| nomatch p1 p2 m2 = join p1 (Tip p1 bm1) p2 t2
| zero p1 m2 = bin p2 m2 (symDiffTip p1 bm1 l) r
| otherwise = bin p2 m2 l (symDiffTip p1 bm1 r)
go t2@(Tip p2 bm2)
| p1 == p2 = tip p1 (bm1 `xor` bm2)
| otherwise = join p1 (Tip p1 bm1) p2 t2
go t2@(Fin p2 m2)
| nomatch p1 p2 (finMask m2) = join p1 (Tip p1 bm1) p2 t2
| otherwise = symDiffTip p1 bm1 (splitFin p2 m2)
go Nil = Tip p1 bm1
symDiffFin :: Prefix -> Mask -> IntSet -> IntSet
symDiffFin !p1 !m1 = go
where
go t2@(Bin p2 m2 l r)
| finMask m1 `shorterEq` m2
= if match p2 p1 (finMask m1)
then symDiff (splitFin p1 m1) t2
else join p1 (Fin p1 m1) p2 t2
| otherwise = goDown
where
goDown
| nomatch p1 p2 m2 = join p1 (Fin p1 m1) p2 t2
| zero p1 m2 = bin p2 m2 (go l) r
| otherwise = bin p2 m2 l (go r)
go (Fin p2 m2 )
| m1 `shorter` m2 = if match p2 p1 (finMask m1)
then symDiffFin p2 m2 (splitFin p1 m1)
else join p1 (Fin p1 m1) p2 (Fin p2 m2)
| m2 `shorter` m1 = if match p1 p2 (finMask m2)
then symDiffFin p2 m2 (splitFin p1 m1)
else join p1 (Fin p1 m1) p2 (Fin p2 m2)
| p1 == p2 = Nil
| xor p1 p2 == m1 = if p1 < p2
then Fin p1 (m1 * 2)
else Fin p2 (m1 * 2)
| otherwise = join p1 (Fin p1 m1) p2 (Fin p2 m2)
go (Tip p2 bm2) = symDiffTip p2 bm2 (Fin p1 m1)
go Nil = Fin p1 m1
data SPair a b = !a :*: !b
unStrict :: SPair a b -> (a, b)
unStrict (a :*: b) = (a, b)
split :: Key -> IntSet -> (IntSet, IntSet)
split !k = unStrict . splitBM (prefixOf k) (bitmapOf k)
splitBM :: Prefix -> BitMap -> IntSet -> SPair IntSet IntSet
splitBM !px !tbm = root
where
root t@(Bin _ m l r)
| m >= 0 = go t
| px >= 0 = let posLT :*: posGT = go l in (r `union` posLT) :*: posGT
| otherwise = let negLT :*: negGT = go r in negLT :*: (negGT `union` l)
root t = go t
go t@(Bin p m l r)
| nomatch px p m = if p < px then t :*: Nil else Nil :*: t
| zero px m = let ll :*: lr = go l in ll :*: (lr `union` r)
| otherwise = let rl :*: rr = go r in (l `union` rl) :*: rr
go t@(Tip p bm)
| px < p = Nil :*: t
| p < px = t :*: Nil
| otherwise = tipD px (bm .&. lowBM) :*: tipD px (bm .&. hghBM)
where
lowBM = tbm 1
hghBM = Bits.complement (lowBM + tbm)
go t@(Fin p m )
| match px p (finMask m) = go (splitFin p m)
| p < px = t :*: Nil
| otherwise = Nil :*: t
go Nil = Nil :*: Nil
splitGT :: Key -> IntSet -> IntSet
splitGT !k = splitBMGT (prefixOf k) (bitmapOf k)
splitBMGT :: Prefix -> BitMap -> IntSet -> IntSet
splitBMGT !px !tbm = root
where
root t@(Bin _ m l r)
| m >= 0 = go t
| px >= 0 = go l
| otherwise = let !r' = go r in union r' l
root t = go t
go t@(Bin p m l r)
| nomatch px p m = if p < px then Nil else t
| zero px m = let !l' = go l in union l' r
| otherwise = go r
go t@(Tip p bm)
| px < p = t
| p < px = Nil
| otherwise = tipD px (bm .&. hghBM)
where
lowBM = tbm 1
hghBM = Bits.complement (lowBM + tbm)
go t@(Fin p m)
| match px p (finMask m) = go (splitFin p m)
| p < px = Nil
| otherwise = t
go Nil = Nil
splitLT :: Key -> IntSet -> IntSet
splitLT !x = splitBMLT (prefixOf x) (bitmapOf x)
splitBMLT :: Prefix -> BitMap -> IntSet -> IntSet
splitBMLT !px !tbm = root
where
root t@(Bin _ m l r)
| m >= 0 = go t
| px >= 0 = r `union` go l
| otherwise = go r
root t = go t
go t@(Bin p m l r)
| nomatch px p m = if p < px then t else Nil
| zero px m = go l
| otherwise = l `union` go r
go t@(Tip p bm)
| px < p = Nil
| p < px = t
| otherwise = tipD px (bm .&. lowBM)
where
lowBM = tbm 1
go t@(Fin p m)
| match px p (finMask m) = go (splitFin p m)
| p < px = t
| otherwise = Nil
go Nil = Nil
partition :: (Key -> Bool) -> IntSet -> (IntSet, IntSet)
partition f = unStrict . go
where
go (Bin p m l r) = let ll :*: lr = go l
rl :*: rr = go r
in bin p m ll rl :*: bin p m lr rr
go (Tip p bm) = let bm' = filterBitMap p f bm
in tip p bm' :*: tip p (bm' `xor` bm)
go (Fin p m) = let (l, r) = L.partition f (listFin p m)
in fromList l :*: fromList r
go Nil = Nil :*: Nil
findMin :: IntSet -> Key
findMin (Bin _ rootM l r)
| rootM < 0 = go r
| otherwise = go l
where
go (Bin _ _ lb _) = go lb
go (Tip p bm) = p + findMinBM bm
go (Fin p _) = p
go Nil = error "findMax.go: Bin Nil invariant failed"
findMin (Tip p bm) = p + findMinBM bm
findMin (Fin p _) = p
findMin Nil = error "findMin: empty set"
findMinBM :: BitMap -> Int
findMinBM = fromIntegral . trailingZeros
findMax :: IntSet -> Key
findMax (Bin _ rootM l r)
| rootM < 0 = go l
| otherwise = go r
where
go (Bin _ _ _ ri) = go ri
go (Tip p bm) = p + findMaxBM bm
go (Fin p m) = p + m 1
go Nil = error "findMax.go: Bin Nil invariant failed"
findMax (Tip p bm) = p + findMaxBM bm
findMax (Fin p m ) = p + m 1
findMax Nil = error "findMax: empty set"
findMaxBM :: BitMap -> Int
findMaxBM x = fromIntegral ((WORD_SIZE_IN_BITS 1) leadingZeros x)
stream :: IntSet -> [Key]
stream = toList
unstream :: [Key] -> IntSet
unstream = fromList
map :: (Key -> Key) -> IntSet -> IntSet
map f = unstream . L.map f . stream
foldr :: (Key -> a -> a) -> a -> IntSet -> a
foldr f a = wrap
where
wrap (Bin _ m l r)
| m > 0 = go (go a r) l
| otherwise = go (go a l) r
wrap t = go a t
go z (Bin _ _ l r) = go (go z r) l
go z (Tip p bm) = foldrBits p f z bm
go z (Fin p m) = L.foldr f z (listFin p m)
go z Nil = z
filter :: (Key -> Bool) -> IntSet -> IntSet
filter f = go
where
go (Bin p m l r) = binD p m (go l) (go r)
go (Tip p bm) = fromList $ L.filter f $ toList (Tip p bm)
go (Fin p m) = fromList $ L.filter f $ listFin p m
go Nil = Nil
listFin :: Prefix -> Mask -> [Key]
listFin p m = [p..(p + m) 1]
fromList :: [Key] -> IntSet
fromList = L.foldl' (flip insert) empty
toList :: IntSet -> [Key]
toList = Data.IntervalSet.Internal.foldr (:) []
elems :: IntSet -> [Key]
elems = toList
toAscList :: IntSet -> [Key]
toAscList = toList
toDescList :: IntSet -> [Key]
toDescList = reverse . toAscList
fromAscList :: [Key] -> IntSet
fromAscList = fromList
tipI :: Prefix -> BitMap -> IntSet
tipI p bm
| isFull bm = Fin p WORD_SIZE_IN_BITS
| otherwise = Tip p bm
tipD :: Prefix -> BitMap -> IntSet
tipD _ 0 = Nil
tipD p bm = Tip p bm
tip :: Prefix -> BitMap -> IntSet
tip p bm
| bm == 0 = Nil
| isFull bm = Fin p WORD_SIZE_IN_BITS
| otherwise = Tip p bm
binI :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
binI p m (Fin _ m1) (Fin _ m2)
| m1 == m && m2 == m
= Fin p (m * 2)
binI p m l r = Bin p m l r
binD :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
binD _ _ Nil r = r
binD _ _ l Nil = l
binD p m l r = Bin p m l r
bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
bin _ _ Nil r = r
bin _ _ l Nil = l
bin p m (Fin _ m1) (Fin _ m2)
| m1 == m && m2 == m
= Fin p (m * 2)
bin p m l r = Bin p m l r
join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
join p1 t1 p2 t2
| zero p1 m = Bin p m t1 t2
| otherwise = Bin p m t2 t1
where
p = mask p1 m
m = branchMask p1 p2
binCount :: IntSet -> Int
binCount (Bin _ _ l r) = 1 + binCount l + binCount r
binCount _ = 0
tipCount :: IntSet -> Int
tipCount (Bin _ _ l r) = tipCount l + tipCount r
tipCount (Tip _ _) = 1
tipCount _ = 0
finCount :: IntSet -> Int
finCount (Bin _ _ l r) = finCount l + finCount r
finCount (Fin _ _) = 1
finCount _ = 0
wordCount :: IntSet -> Int
wordCount (Bin _ _ l r) = 5 + wordCount l + wordCount r
wordCount (Tip _ _) = 3
wordCount (Fin _ _) = 3
wordCount Nil = 1
origSize :: IntSet -> Int
origSize (Bin _ _ l r) = 5 + origSize l + origSize r
origSize (Tip _ _) = 3
origSize (Fin _ m) =
let tips = m `div` WORD_SIZE_IN_BITS
bins = tips 1
in tips * 3 + bins * 5
origSize Nil = 1
savedSpace :: IntSet -> Int
savedSpace s = origSize s wordCount s
bsSize :: IntSet -> Int
bsSize s = findMax s `div` 8
ppStats :: IntSet -> IO ()
ppStats s = do
putStrLn $ "Bin count: " ++ show (binCount s)
putStrLn $ "Tip count: " ++ show (tipCount s)
putStrLn $ "Fin count: " ++ show (finCount s)
let treeSize = wordCount s
putStrLn $ "Size in bytes: " ++ show (treeSize * 8)
let savedSize = savedSpace s
let bssize = bsSize s
let savedSizeBS = bssize treeSize * 8
putStrLn $ "Saved space over dense set: " ++ show (savedSize * 8)
putStrLn $ "Saved space over bytestring: " ++ show savedSizeBS
let orig = origSize s
let per = (fromIntegral savedSize / fromIntegral orig) * (100 :: Double)
let perBS = (fromIntegral savedSizeBS / fromIntegral bssize) * (100 :: Double)
putStrLn $ "Percent saved over dense set: " ++ show per ++ "%"
putStrLn $ "Percent saved over bytestring: " ++ show perBS ++ "%"
showTree :: IntSet -> String
showTree = go 0
where
indent n = replicate (4 * n) ' '
go n Nil = indent n ++ "{}"
go n (Fin p m) = indent n ++ show p ++ ".." ++ show (p + m 1)
go n (Tip p bm) = indent n ++ show p ++ " " ++ show bm
go n (Bin p m l r) = concat
[ go (succ n) l, "\n"
, indent n, "+", show p, " ", show m, "\n"
, go (succ n) r
]
showRaw :: IntSet -> String
showRaw = go 0
where
indent n = replicate (4 * n) ' '
go n Nil = indent n ++ "Nil"
go n (Fin p m) = indent n ++ show p ++ " " ++ show m
go n (Tip p bm) = indent n ++ show p ++ " " ++ show bm
go n (Bin p m l r) = concat
[ go (succ n) l, "\n"
, indent n, "+", show p, " ", show m, "\n"
, go (succ n) r
]
putTree :: IntSet -> IO ()
putTree = putStrLn . showTree
putRaw :: IntSet -> IO ()
putRaw = putStrLn . showRaw
foldrBits :: Int -> (Int -> a -> a) -> a -> BitMap -> a
foldrBits p f acc bm = go 0
where
go i
| i == WORD_SIZE_IN_BITS = acc
| testBit bm i = f (p + i) (go (succ i))
| otherwise = go (succ i)
filterBitMap :: Prefix -> (Key -> Bool) -> BitMap -> BitMap
filterBitMap px f bm = go 0 0
where
go !i !acc
| i == WORD_SIZE_IN_BITS = acc
| testBit bm i && f (px + i) = go (succ i) (bitmapOfSuffix i .|. acc)
| otherwise = go (succ i) acc
isFull :: BitMap -> Bool
isFull x = x == Bits.complement 0
type Nat = Word
natFromInt :: Int -> Nat
natFromInt = fromIntegral
intFromNat :: Nat -> Int
intFromNat = fromIntegral
zero :: Int -> Mask -> Bool
zero i m = (natFromInt i .&. natFromInt m) == 0
mask :: Int -> Mask -> Prefix
mask i m
= maskW (natFromInt i) (natFromInt m)
match :: Int -> Prefix -> Mask -> Bool
match i p m = mask i m == p
nomatch :: Int -> Prefix -> Mask -> Bool
nomatch i p m = mask i m /= p
shorter :: Mask -> Mask -> Bool
shorter m1 m2 = natFromInt m1 > natFromInt m2
shorterEq :: Mask -> Mask -> Bool
shorterEq m1 m2 = natFromInt m1 >= natFromInt m2
branchMask :: Prefix -> Prefix -> Mask
branchMask p1 p2
= intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
highestBitMask :: Word -> Word
highestBitMask x1 =
let x2 = x1 .|. x1 `shiftR` 1
x3 = x2 .|. x2 `shiftR` 2
x4 = x3 .|. x3 `shiftR` 4
x5 = x4 .|. x4 `shiftR` 8
x6 = x5 .|. x5 `shiftR` 16
#if WORD_SIZE_IN_BITS == 64
x7 = x6 .|. x6 `shiftR` 32
in x7 `xor` (x7 `shiftR` 1)
#else
in x6 `xor` (x6 `shiftRL` 1)
#endif
maskW :: Nat -> Nat -> Prefix
maskW i m = intFromNat (i .&. (Bits.complement (m1) `xor` m))
finMask :: Mask -> Mask
finMask m = m `shiftR` 1
suffixBitMask :: Int
suffixBitMask = bitSize (undefined :: Word) 1
prefixBitMask :: Int
prefixBitMask = Bits.complement suffixBitMask
prefixOf :: Int -> Prefix
prefixOf x = x .&. prefixBitMask
suffixOf :: Int -> Int
suffixOf x = x .&. suffixBitMask
bitmapOfSuffix :: Int -> BitMap
bitmapOfSuffix s = 1 `shiftL` s
bitmapOf :: Int -> BitMap
bitmapOf x = bitmapOfSuffix (suffixOf x)