module UU.DData.IntMap (
IntMap, Key
, (!), (\\)
, isEmpty
, size
, member
, lookup
, find
, findWithDefault
, empty
, single
, insert
, insertWith, insertWithKey, insertLookupWithKey
, delete
, adjust
, adjustWithKey
, update
, updateWithKey
, updateLookupWithKey
, union
, unionWith
, unionWithKey
, unions
, difference
, differenceWith
, differenceWithKey
, intersection
, intersectionWith
, intersectionWithKey
, map
, mapWithKey
, mapAccum
, mapAccumWithKey
, fold
, foldWithKey
, elems
, keys
, assocs
, toList
, fromList
, fromListWith
, fromListWithKey
, toAscList
, fromAscList
, fromAscListWith
, fromAscListWithKey
, fromDistinctAscList
, filter
, filterWithKey
, partition
, partitionWithKey
, split
, splitLookup
, subset, subsetBy
, properSubset, properSubsetBy
, showTree
, showTreeWith
) where
import Prelude hiding (lookup,map,filter)
import Bits
import Int
#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__ >= 503
import GHC.Word
import GHC.Exts ( Word(..), Int(..), shiftRL# )
#else
import Word
import GlaExts ( Word(..), Int(..), shiftRL# )
#endif
type Nat = Word
natFromInt :: Key -> Nat
natFromInt i = fromIntegral i
intFromNat :: Nat -> Key
intFromNat w = fromIntegral w
shiftRL :: Nat -> Key -> Nat
shiftRL (W# x) (I# i)
= W# (shiftRL# x i)
#elif __HUGS__
import Word
type Nat = Word32
natFromInt :: Key -> Nat
natFromInt i = fromInt i
intFromNat :: Nat -> Key
intFromNat w = toInt w
shiftRL :: Nat -> Key -> Nat
shiftRL x i = shiftR x i
#else
import Word
type Nat = Word
natFromInt :: Key -> Nat
natFromInt i = fromIntegral i
intFromNat :: Nat -> Key
intFromNat w = fromIntegral w
shiftRL :: Nat -> Key -> Nat
shiftRL w i = shiftR w i
#endif
infixl 9 \\
(!) :: IntMap a -> Key -> a
(!) m k = find k m
(\\) :: IntMap a -> IntMap a -> IntMap a
m1 \\ m2 = difference m1 m2
data IntMap a = Nil
| Tip !Key a
| Bin !Prefix !Mask !(IntMap a) !(IntMap a)
type Prefix = Int
type Mask = Int
type Key = Int
isEmpty :: IntMap a -> Bool
isEmpty Nil = True
isEmpty other = False
size :: IntMap a -> Int
size t
= case t of
Bin p m l r -> size l + size r
Tip k x -> 1
Nil -> 0
member :: Key -> IntMap a -> Bool
member k m
= case lookup k m of
Nothing -> False
Just x -> True
lookup :: Key -> IntMap a -> Maybe a
lookup k t
= case t of
Bin p m l r
| nomatch k p m -> Nothing
| zero k m -> lookup k l
| otherwise -> lookup k r
Tip kx x
| (k==kx) -> Just x
| otherwise -> Nothing
Nil -> Nothing
find :: Key -> IntMap a -> a
find k m
= case lookup k m of
Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
Just x -> x
findWithDefault :: a -> Key -> IntMap a -> a
findWithDefault def k m
= case lookup k m of
Nothing -> def
Just x -> x
empty :: IntMap a
empty
= Nil
single :: Key -> a -> IntMap a
single k x
= Tip k x
insert :: Key -> a -> IntMap a -> IntMap a
insert k x t
= case t of
Bin p m l r
| nomatch k p m -> join k (Tip k x) p t
| zero k m -> Bin p m (insert k x l) r
| otherwise -> Bin p m l (insert k x r)
Tip ky y
| k==ky -> Tip k x
| otherwise -> join k (Tip k x) ky t
Nil -> Tip k x
insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
insertWith f k x t
= insertWithKey (\k x y -> f x y) k x t
insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
insertWithKey f k x t
= case t of
Bin p m l r
| nomatch k p m -> join k (Tip k x) p t
| zero k m -> Bin p m (insertWithKey f k x l) r
| otherwise -> Bin p m l (insertWithKey f k x r)
Tip ky y
| k==ky -> Tip k (f k x y)
| otherwise -> join k (Tip k x) ky t
Nil -> Tip k x
insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
insertLookupWithKey f k x t
= case t of
Bin p m l r
| nomatch k p m -> (Nothing,join k (Tip k x) p t)
| zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
| otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
Tip ky y
| k==ky -> (Just y,Tip k (f k x y))
| otherwise -> (Nothing,join k (Tip k x) ky t)
Nil -> (Nothing,Tip k x)
delete :: Key -> IntMap a -> IntMap a
delete k t
= case t of
Bin p m l r
| nomatch k p m -> t
| zero k m -> bin p m (delete k l) r
| otherwise -> bin p m l (delete k r)
Tip ky y
| k==ky -> Nil
| otherwise -> t
Nil -> Nil
adjust :: (a -> a) -> Key -> IntMap a -> IntMap a
adjust f k m
= adjustWithKey (\k x -> f x) k m
adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a
adjustWithKey f k m
= updateWithKey (\k x -> Just (f k x)) k m
update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
update f k m
= updateWithKey (\k x -> f x) k m
updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
updateWithKey f k t
= case t of
Bin p m l r
| nomatch k p m -> t
| zero k m -> bin p m (updateWithKey f k l) r
| otherwise -> bin p m l (updateWithKey f k r)
Tip ky y
| k==ky -> case (f k y) of
Just y' -> Tip ky y'
Nothing -> Nil
| otherwise -> t
Nil -> Nil
updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
updateLookupWithKey f k t
= case t of
Bin p m l r
| nomatch k p m -> (Nothing,t)
| zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
| otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
Tip ky y
| k==ky -> case (f k y) of
Just y' -> (Just y,Tip ky y')
Nothing -> (Just y,Nil)
| otherwise -> (Nothing,t)
Nil -> (Nothing,Nil)
unions :: [IntMap a] -> IntMap a
unions xs
= foldlStrict union empty xs
union :: IntMap a -> IntMap a -> IntMap a
union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = union1
| shorter m2 m1 = union2
| p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
| otherwise = join p1 t1 p2 t2
where
union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
| zero p2 m1 = Bin p1 m1 (union l1 t2) r1
| otherwise = Bin p1 m1 l1 (union r1 t2)
union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
| zero p1 m2 = Bin p2 m2 (union t1 l2) r2
| otherwise = Bin p2 m2 l2 (union t1 r2)
union (Tip k x) t = insert k x t
union t (Tip k x) = insertWith (\x y -> y) k x t
union Nil t = t
union t Nil = t
unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionWith f m1 m2
= unionWithKey (\k x y -> f x y) m1 m2
unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = union1
| shorter m2 m1 = union2
| p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
| otherwise = join p1 t1 p2 t2
where
union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
| zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
| otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
| zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
| otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
unionWithKey f (Tip k x) t = insertWithKey f k x t
unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t
unionWithKey f Nil t = t
unionWithKey f t Nil = t
difference :: IntMap a -> IntMap a -> IntMap a
difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = difference1
| shorter m2 m1 = difference2
| p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
| otherwise = t1
where
difference1 | nomatch p2 p1 m1 = t1
| zero p2 m1 = bin p1 m1 (difference l1 t2) r1
| otherwise = bin p1 m1 l1 (difference r1 t2)
difference2 | nomatch p1 p2 m2 = t1
| zero p1 m2 = difference t1 l2
| otherwise = difference t1 r2
difference t1@(Tip k x) t2
| member k t2 = Nil
| otherwise = t1
difference Nil t = Nil
difference t (Tip k x) = delete k t
difference t Nil = t
differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a
differenceWith f m1 m2
= differenceWithKey (\k x y -> f x y) m1 m2
differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a
differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = difference1
| shorter m2 m1 = difference2
| p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
| otherwise = t1
where
difference1 | nomatch p2 p1 m1 = t1
| zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
| otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
difference2 | nomatch p1 p2 m2 = t1
| zero p1 m2 = differenceWithKey f t1 l2
| otherwise = differenceWithKey f t1 r2
differenceWithKey f t1@(Tip k x) t2
= case lookup k t2 of
Just y -> case f k x y of
Just y' -> Tip k y'
Nothing -> Nil
Nothing -> t1
differenceWithKey f Nil t = Nil
differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
differenceWithKey f t Nil = t
intersection :: IntMap a -> IntMap a -> IntMap a
intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = intersection1
| shorter m2 m1 = intersection2
| p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
| otherwise = Nil
where
intersection1 | nomatch p2 p1 m1 = Nil
| zero p2 m1 = intersection l1 t2
| otherwise = intersection r1 t2
intersection2 | nomatch p1 p2 m2 = Nil
| zero p1 m2 = intersection t1 l2
| otherwise = intersection t1 r2
intersection t1@(Tip k x) t2
| member k t2 = t1
| otherwise = Nil
intersection t (Tip k x)
= case lookup k t of
Just y -> Tip k y
Nothing -> Nil
intersection Nil t = Nil
intersection t Nil = Nil
intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
intersectionWith f m1 m2
= intersectionWithKey (\k x y -> f x y) m1 m2
intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = intersection1
| shorter m2 m1 = intersection2
| p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
| otherwise = Nil
where
intersection1 | nomatch p2 p1 m1 = Nil
| zero p2 m1 = intersectionWithKey f l1 t2
| otherwise = intersectionWithKey f r1 t2
intersection2 | nomatch p1 p2 m2 = Nil
| zero p1 m2 = intersectionWithKey f t1 l2
| otherwise = intersectionWithKey f t1 r2
intersectionWithKey f t1@(Tip k x) t2
= case lookup k t2 of
Just y -> Tip k (f k x y)
Nothing -> Nil
intersectionWithKey f t1 (Tip k y)
= case lookup k t1 of
Just x -> Tip k (f k x y)
Nothing -> Nil
intersectionWithKey f Nil t = Nil
intersectionWithKey f t Nil = Nil
properSubset :: Eq a => IntMap a -> IntMap a -> Bool
properSubset m1 m2
= properSubsetBy (==) m1 m2
properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool
properSubsetBy pred t1 t2
= case subsetCmp pred t1 t2 of
LT -> True
ge -> False
subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = GT
| shorter m2 m1 = subsetCmpLt
| p1 == p2 = subsetCmpEq
| otherwise = GT
where
subsetCmpLt | nomatch p1 p2 m2 = GT
| zero p1 m2 = subsetCmp pred t1 l2
| otherwise = subsetCmp pred t1 r2
subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of
(GT,_ ) -> GT
(_ ,GT) -> GT
(EQ,EQ) -> EQ
other -> LT
subsetCmp pred (Bin p m l r) t = GT
subsetCmp pred (Tip kx x) (Tip ky y)
| (kx == ky) && pred x y = EQ
| otherwise = GT
subsetCmp pred (Tip k x) t
= case lookup k t of
Just y | pred x y -> LT
other -> GT
subsetCmp pred Nil Nil = EQ
subsetCmp pred Nil t = LT
subset :: Eq a => IntMap a -> IntMap a -> Bool
subset m1 m2
= subsetBy (==) m1 m2
subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool
subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = False
| shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2
else subsetBy pred t1 r2)
| otherwise = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2
subsetBy pred (Bin p m l r) t = False
subsetBy pred (Tip k x) t = case lookup k t of
Just y -> pred x y
Nothing -> False
subsetBy pred Nil t = True
map :: (a -> b) -> IntMap a -> IntMap b
map f m
= mapWithKey (\k x -> f x) m
mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
mapWithKey f t
= case t of
Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
Tip k x -> Tip k (f k x)
Nil -> Nil
mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccum f a m
= mapAccumWithKey (\a k x -> f a x) a m
mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumWithKey f a t
= mapAccumL f a t
mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumL f a t
= case t of
Bin p m l r -> let (a1,l') = mapAccumL f a l
(a2,r') = mapAccumL f a1 r
in (a2,Bin p m l' r')
Tip k x -> let (a',x') = f a k x in (a',Tip k x')
Nil -> (a,Nil)
mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumR f a t
= case t of
Bin p m l r -> let (a1,r') = mapAccumR f a r
(a2,l') = mapAccumR f a1 l
in (a2,Bin p m l' r')
Tip k x -> let (a',x') = f a k x in (a',Tip k x')
Nil -> (a,Nil)
filter :: (a -> Bool) -> IntMap a -> IntMap a
filter p m
= filterWithKey (\k x -> p x) m
filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
filterWithKey pred t
= case t of
Bin p m l r
-> bin p m (filterWithKey pred l) (filterWithKey pred r)
Tip k x
| pred k x -> t
| otherwise -> Nil
Nil -> Nil
partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
partition p m
= partitionWithKey (\k x -> p x) m
partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
partitionWithKey pred t
= case t of
Bin p m l r
-> let (l1,l2) = partitionWithKey pred l
(r1,r2) = partitionWithKey pred r
in (bin p m l1 r1, bin p m l2 r2)
Tip k x
| pred k x -> (t,Nil)
| otherwise -> (Nil,t)
Nil -> (Nil,Nil)
split :: Key -> IntMap a -> (IntMap a,IntMap a)
split k t
= case t of
Bin p m l r
| zero k m -> let (lt,gt) = split k l in (lt,union gt r)
| otherwise -> let (lt,gt) = split k r in (union l lt,gt)
Tip ky y
| k>ky -> (t,Nil)
| k<ky -> (Nil,t)
| otherwise -> (Nil,Nil)
Nil -> (Nil,Nil)
splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)
splitLookup k t
= case t of
Bin p m l r
| zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)
| otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)
Tip ky y
| k>ky -> (Nothing,t,Nil)
| k<ky -> (Nothing,Nil,t)
| otherwise -> (Just y,Nil,Nil)
Nil -> (Nothing,Nil,Nil)
fold :: (a -> b -> b) -> b -> IntMap a -> b
fold f z t
= foldWithKey (\k x y -> f x y) z t
foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldWithKey f z t
= foldR f z t
foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldR f z t
= case t of
Bin p m l r -> foldR f (foldR f z r) l
Tip k x -> f k x z
Nil -> z
elems :: IntMap a -> [a]
elems m
= foldWithKey (\k x xs -> x:xs) [] m
keys :: IntMap a -> [Key]
keys m
= foldWithKey (\k x ks -> k:ks) [] m
assocs :: IntMap a -> [(Key,a)]
assocs m
= toList m
toList :: IntMap a -> [(Key,a)]
toList t
= foldWithKey (\k x xs -> (k,x):xs) [] t
toAscList :: IntMap a -> [(Key,a)]
toAscList t
=
let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos
fromList :: [(Key,a)] -> IntMap a
fromList xs
= foldlStrict ins empty xs
where
ins t (k,x) = insert k x t
fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
fromListWith f xs
= fromListWithKey (\k x y -> f x y) xs
fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
fromListWithKey f xs
= foldlStrict ins empty xs
where
ins t (k,x) = insertWithKey f k x t
fromAscList :: [(Key,a)] -> IntMap a
fromAscList xs
= fromList xs
fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
fromAscListWith f xs
= fromListWith f xs
fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
fromAscListWithKey f xs
= fromListWithKey f xs
fromDistinctAscList :: [(Key,a)] -> IntMap a
fromDistinctAscList xs
= fromList xs
instance Eq a => Eq (IntMap a) where
t1 == t2 = equal t1 t2
t1 /= t2 = nequal t1 t2
equal :: Eq a => IntMap a -> IntMap a -> Bool
equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
= (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
equal (Tip kx x) (Tip ky y)
= (kx == ky) && (x==y)
equal Nil Nil = True
equal t1 t2 = False
nequal :: Eq a => IntMap a -> IntMap a -> Bool
nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
= (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
nequal (Tip kx x) (Tip ky y)
= (kx /= ky) || (x/=y)
nequal Nil Nil = False
nequal t1 t2 = True
instance Show a => Show (IntMap a) where
showsPrec d t = showMap (toList t)
showMap :: (Show a) => [(Key,a)] -> ShowS
showMap []
= showString "{}"
showMap (x:xs)
= showChar '{' . showElem x . showTail xs
where
showTail [] = showChar '}'
showTail (x:xs) = showChar ',' . showElem x . showTail xs
showElem (k,x) = shows k . showString ":=" . shows x
showTree :: Show a => IntMap a -> String
showTree s
= showTreeWith True False s
showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
showTreeWith hang wide t
| hang = (showsTreeHang wide [] t) ""
| otherwise = (showsTree wide [] [] t) ""
showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
showsTree wide lbars rbars t
= case t of
Bin p m l r
-> showsTree wide (withBar rbars) (withEmpty rbars) r .
showWide wide rbars .
showsBars lbars . showString (showBin p m) . showString "\n" .
showWide wide lbars .
showsTree wide (withEmpty lbars) (withBar lbars) l
Tip k x
-> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
Nil -> showsBars lbars . showString "|\n"
showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
showsTreeHang wide bars t
= case t of
Bin p m l r
-> showsBars bars . showString (showBin p m) . showString "\n" .
showWide wide bars .
showsTreeHang wide (withBar bars) l .
showWide wide bars .
showsTreeHang wide (withEmpty bars) r
Tip k x
-> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
Nil -> showsBars bars . showString "|\n"
showBin p m
= "*"
showWide wide bars
| wide = showString (concat (reverse bars)) . showString "|\n"
| otherwise = id
showsBars :: [String] -> ShowS
showsBars bars
= case bars of
[] -> id
_ -> showString (concat (reverse (tail bars))) . showString node
node = "+--"
withBar bars = "| ":bars
withEmpty bars = " ":bars
join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
join p1 t1 p2 t2
| zero p1 m = Bin p m t1 t2
| otherwise = Bin p m t2 t1
where
m = branchMask p1 p2
p = mask p1 m
bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
bin p m l Nil = l
bin p m Nil r = r
bin p m l r = Bin p m l r
zero :: Key -> Mask -> Bool
zero i m
= (natFromInt i) .&. (natFromInt m) == 0
nomatch,match :: Key -> Prefix -> Mask -> Bool
nomatch i p m
= (mask i m) /= p
match i p m
= (mask i m) == p
mask :: Key -> Mask -> Prefix
mask i m
= maskW (natFromInt i) (natFromInt m)
maskW :: Nat -> Nat -> Prefix
maskW i m
= intFromNat (i .&. (complement (m1) `xor` m))
shorter :: Mask -> Mask -> Bool
shorter m1 m2
= (natFromInt m1) > (natFromInt m2)
branchMask :: Prefix -> Prefix -> Mask
branchMask p1 p2
= intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
highestBitMask :: Nat -> Nat
highestBitMask x
= case (x .|. shiftRL x 1) of
x -> case (x .|. shiftRL x 2) of
x -> case (x .|. shiftRL x 4) of
x -> case (x .|. shiftRL x 8) of
x -> case (x .|. shiftRL x 16) of
x -> case (x .|. shiftRL x 32) of
x -> (x `xor` (shiftRL x 1))
foldlStrict f z xs
= case xs of
[] -> z
(x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)