gmap-0.1: src/Data/GMap/IntMap.hs
{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -Wall #-}
module Data.GMap.IntMap
(-- * IntMap type
IntMap
) where
import Prelude hiding (foldr,map,filter,lookup)
import Data.GMap
import qualified Data.Monoid as M (Monoid(..))
import qualified Data.Foldable as F (Foldable(..))
import Data.Bits(shiftR,(.&.))
import Data.Typeable
-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import
-- See Tickets 1074 and 1148
import qualified Data.List as L
import qualified Data.Maybe as MB
import Control.Monad(foldM)
import GHC.Base hiding (map)
import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)
-- | Type synonym used to distinguish a key Int# from other Int#.
-- (BTW, the Haddock lies. This synonym is not exported.
-- This is only used in the haddock to distinguish Ints that are Keys from Ints used for other purposes.)
type Key = Int#
-- This is basically the same as AVL (from Data.Tree.AVL package) but with an
-- extra Int field (which is unboxed for ghc).
-- | The GT type for 'Int' keys.
data IntMap a = E -- ^ Empty IntMap
| N {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=-1 (right height > left height)
| Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF= 0
| P {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=+1 (left height > right height)
instance Map IntMap Int where
-- fromAssocsWith
-- fromAssocsMaybe
empty = emptyIntMap
nonEmpty = nonEmptyIntMap
status = statusIntMap
addSize = addSizeIntMap
union = unionIntMap
union' = unionIntMap'
unionMaybe = unionMaybeIntMap
disjointUnion = disjointUnionIntMap
intersection = intersectionIntMap
intersection' = intersectionIntMap'
intersectionMaybe = intersectionMaybeIntMap
difference = differenceIntMap
differenceMaybe = differenceMaybeIntMap
isSubsetOf = isSubsetOfIntMap
isSubmapOf = isSubmapOfIntMap
map = mapIntMap
map' = mapIntMap'
mapMaybe = mapMaybeIntMap
mapWithKey f imp = mapWithKeyIntMap (\i a -> f (I# (i)) a) imp
mapWithKey' f imp = mapWithKeyIntMap' (\i a -> f (I# (i)) a) imp
filter = filterIntMap
foldKeys f imp b0 = foldKeysAscIntMap (\i b -> f (I# (i)) b) imp b0
foldAssocs f imp b0 = foldAssocsAscIntMap (\i a b -> f (I# (i)) a b) imp b0
foldElems = foldElemsAscIntMap
foldElems' = foldElemsAscIntMap'
foldKeys' f imp b0 = foldKeysAscIntMap' (\i b -> f (I# (i)) b) imp b0
foldAssocs' f imp b0 = foldAssocsAscIntMap' (\i a b -> f (I# (i)) a b) imp b0
foldElemsUInt = foldElemsUIntIntMap
valid = validIntMap
singleton (I# (i)) a = singletonIntMap i a
pair (I# (i0)) (I# (i1)) = pairIntMap i0 i1
lookup (I# (i)) imp = lookupIntMap i imp
lookupCont f (I# (i)) imp = lookupContIntMap f i imp
alter f (I# (i)) imp = alterIntMap f i imp
insertWith f (I# (i)) a imp = insertWithIntMap f i a imp
insertWith' f (I# (i)) a imp = insertWithIntMap' f i a imp
insertMaybe f (I# (i)) a imp = insertMaybeIntMap f i a imp
delete (I# (i)) imp = deleteIntMap i imp
adjustWith f (I# (i)) imp = adjustWithIntMap f i imp
adjustWith' f (I# (i)) imp = adjustWithIntMap' f i imp
adjustMaybe f (I# (i)) imp = adjustMaybeIntMap f i imp
venn = vennIntMap
venn' = vennIntMap'
vennMaybe = vennMaybeIntMap
instance OrderedMap IntMap Int where
compareKey = compareKeyIntMap
fromAssocsAscWith = fromAssocsAscWithIntMap
fromAssocsDescWith = fromAssocsDescWithIntMap
fromAssocsAscMaybe = fromAssocsAscMaybeIntMap
fromAssocsDescMaybe = fromAssocsDescMaybeIntMap
foldKeysAsc f imp b0 = foldKeysAscIntMap (\i b -> f (I# (i)) b) imp b0
foldKeysDesc f imp b0 = foldKeysDescIntMap (\i b -> f (I# (i)) b) imp b0
foldAssocsAsc f imp b0 = foldAssocsAscIntMap (\i a b -> f (I# (i)) a b) imp b0
foldAssocsDesc f imp b0 = foldAssocsDescIntMap (\i a b -> f (I# (i)) a b) imp b0
foldElemsAsc = foldElemsAscIntMap
foldElemsDesc = foldElemsDescIntMap
foldElemsAsc' = foldElemsAscIntMap'
foldElemsDesc' = foldElemsDescIntMap'
foldKeysAsc' f imp b0 = foldKeysAscIntMap' (\i b -> f (I# (i)) b) imp b0
foldKeysDesc' f imp b0 = foldKeysDescIntMap' (\i b -> f (I# (i)) b) imp b0
foldAssocsAsc' f imp b0 = foldAssocsAscIntMap' (\i a b -> f (I# (i)) a b) imp b0
foldAssocsDesc' f imp b0 = foldAssocsDescIntMap' (\i a b -> f (I# (i)) a b) imp b0
-- Local module error prefix
mErr :: String
mErr = "Data.Trie.General.IntMap.Set-"
-- | See 'Map' class method 'empty'.
emptyIntMap :: IntMap a
emptyIntMap = E
{-# INLINE emptyIntMap #-}
-- | See 'Map' class method 'singleton'.
singletonIntMap :: Key -> a -> IntMap a
singletonIntMap i a = Z i E a E
{-# INLINE singletonIntMap #-}
-- !!! This might cause problems where the list and the map cant both fit into memory at the same time. Dont use length.
fromAssocsAscIntMap :: [(Int,a)] -> IntMap a
fromAssocsAscIntMap ias = fromAssocsAscLIntMap (length ias) ias
{-# INLINE fromAssocsAscIntMap #-}
fromAssocsDescIntMap :: [(Int,a)] -> IntMap a
fromAssocsDescIntMap ias = fromAssocsDescLIntMap (length ias) ias
{-# INLINE fromAssocsDescIntMap #-}
fromAssocsAscLIntMap :: Int -> [(Int,a)] -> IntMap a
fromAssocsAscLIntMap n ias = case suba (rep n) ias of
(# imp,[] #) -> imp
(# _,_ #) -> error (mErr ++ "fromAssocsAscLIntMap: List too long.")
where
suba ET as = (# E,as #)
suba (NT l r) as = suba_ N l r as
suba (ZT l r) as = suba_ Z l r as
suba (PT l r) as = suba_ P l r as
{-# INLINE suba_ #-}
suba_ c l r as = case suba l as of
(# l_,as_ #) -> case as_ of
(((I# (ka),a):as__)) -> case suba r as__ of
(# r_,as___ #) -> let t = c ka l_ a r_
in t `seq` (# t,as___ #)
[] -> error (mErr ++ "fromAssocsAscLIntMap: List too short.")
fromAssocsDescLIntMap :: Int -> [(Int,a)] -> IntMap a
fromAssocsDescLIntMap n ias = case subd (rep n) ias of
(# imp,[] #) -> imp
(# _,_ #) -> error (mErr ++ "fromAssocsDescLIntMap: List too long.")
where
subd ET as = (# E,as #)
subd (NT l r) as = subd_ N l r as
subd (ZT l r) as = subd_ Z l r as
subd (PT l r) as = subd_ P l r as
{-# INLINE subd_ #-}
subd_ c l r as = case subd r as of
(# r_,as_ #) -> case as_ of
(((I# (ka),a):as__)) -> case subd l as__ of
(# l_,as___ #) -> let t = c ka l_ a r_
in t `seq` (# t,as___ #)
[] -> error (mErr ++ "fromAssocsDescLIntMap: List too short.")
-- Group an ordered list of assocs by key
clump :: Eq k => [(k,a)] -> [(k,[a])]
clump [] = []
clump kas = list' [(k',as' [])]
where (k',as',list') = L.foldl' combine (fst $ head kas,id,id) kas
-- 'as' and 'list' are list building continuations - so order of 'kas' is preserved
combine (k1,as,list) (k2,a) =
if k1 == k2
then (k1, as . (a:), list )
else (k2, (a:), list . ((k1,as []):) )
fromAssocsAscWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a
fromAssocsAscWithIntMap f kas = fromAssocsAscIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas]
fromAssocsDescWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a
fromAssocsDescWithIntMap f kas = fromAssocsDescIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas]
fromAssocsAscMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a
fromAssocsAscMaybeIntMap f kas = fromAssocsAscIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas]
where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as)
fromAssocsDescMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a
fromAssocsDescMaybeIntMap f kas = fromAssocsDescIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas]
where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as)
-- | See 'Map' class method 'pair'.
pairIntMap :: Key -> Key -> Maybe (a -> a -> IntMap a)
pairIntMap i0 i1 = case compareInt# i0 i1 of
LT -> Just (\a0 a1 -> P i1 (Z i0 E a0 E) a1 E)
EQ -> Nothing
GT -> Just (\a0 a1 -> P i0 (Z i1 E a1 E) a0 E)
-- | See 'Map' class method 'nonEmpty'.
nonEmptyIntMap :: IntMap a -> Maybe (IntMap a)
nonEmptyIntMap E = Nothing
nonEmptyIntMap imp = Just imp
-- | See 'Map' class method 'status'.
statusIntMap :: IntMap a -> Status Int a
statusIntMap E = None
statusIntMap (Z i E a _) = One (I# (i)) a
statusIntMap _ = Many
{-----------------------------------------
Notes for fast size calculation.
case (h,avl)
(0,_ ) -> 0 -- Must be E
(1,_ ) -> 1 -- Must be (Z E _ E )
(2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E))
(2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E))
(2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E )
(3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r )
(3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E))
------------------------------------------}
-- | See 'Map' class method 'addSize'.
addSizeIntMap :: IntMap a -> Int# -> Int#
addSizeIntMap E n = n
addSizeIntMap (N _ l _ r) n = case addHeight 2# l of
2# -> ((n)+#2#)
h -> fasN n h l r
addSizeIntMap (Z _ l _ r) n = case addHeight 1# l of
1# -> ((n)+#1#)
2# -> ((n)+#3#)
h -> fasZ n h l r
addSizeIntMap (P _ l _ r) n = case addHeight 2# r of
2# -> ((n)+#2#)
h -> fasP n h l r
-- Local utilities used by addSizeIntMap, Only work if h >=3 !!
fasN,fasZ,fasP :: Int# -> Int# -> IntMap e -> IntMap e -> Int#
fasN n 3# _ r = fas ((n)+#2#) 2# r
fasN n h l r = fas (fas ((n)+#1#) ((h)-#2#) l) ((h)-#1#) r -- h>=4
fasZ n h l r = fas (fas ((n)+#1#) ((h)-#1#) l) ((h)-#1#) r
fasP n 3# l _ = fas ((n)+#2#) 2# l
fasP n h l r = fas (fas ((n)+#1#) ((h)-#2#) r) ((h)-#1#) l -- h>=4
-- Local Utility used by fasN,fasZ,fasP, Only works if h >= 2 !!
fas :: Int# -> Int# -> IntMap e -> Int#
fas _ 2# E = error "fas: Bug0"
fas n 2# (N _ _ _ _) = ((n)+#2#)
fas n 2# (Z _ _ _ _) = ((n)+#3#)
fas n 2# (P _ _ _ _) = ((n)+#2#)
-- So h must be >= 3 if we get here
fas n h (N _ l _ r) = fasN n h l r
fas n h (Z _ l _ r) = fasZ n h l r
fas n h (P _ l _ r) = fasP n h l r
fas _ _ E = error "fas: Bug1"
-----------------------------------------------------------------------
------------------------ addSizeIntMap Ends Here -----------------------
-----------------------------------------------------------------------
-- | Adds the height of a tree to the first argument.
--
-- Complexity: O(log n)
addHeight :: Int# -> IntMap e -> Int#
addHeight h E = h
addHeight h (N _ l _ _) = addHeight ((h)+#2#) l
addHeight h (Z _ l _ _) = addHeight ((h)+#1#) l
addHeight h (P _ _ _ r) = addHeight ((h)+#2#) r
-- | See 'Map' class method 'lookup'.
lookupIntMap :: Key -> IntMap a -> Maybe a
lookupIntMap i0 t = rd t where
rd E = Nothing
rd (N i l a r) = rd_ i l a r
rd (Z i l a r) = rd_ i l a r
rd (P i l a r) = rd_ i l a r
rd_ i l a r = case compareInt# i0 i of
LT -> rd l
EQ -> Just a
GT -> rd r
-- | See 'Map' class method 'lookupCont'.
lookupContIntMap :: (a -> Maybe b) -> Key -> IntMap a -> Maybe b
lookupContIntMap f i0 t = rd t where
rd E = Nothing
rd (N i l a r) = rd_ i l a r
rd (Z i l a r) = rd_ i l a r
rd (P i l a r) = rd_ i l a r
rd_ i l a r = case compareInt# i0 i of
LT -> rd l
EQ -> f a
GT -> rd r
-- | Determine if the supplied key is present in the IntMap.
hasKeyIntMap :: IntMap a -> Key -> Bool
hasKeyIntMap t i0 = rd t where
rd E = False
rd (N i l _ r) = rd_ i l r
rd (Z i l _ r) = rd_ i l r
rd (P i l _ r) = rd_ i l r
rd_ i l r = case compareInt# i0 i of
LT -> rd l
EQ -> True
GT -> rd r
-- | Overwrite an existing association pair. This function does not force evaluation of the new associated
-- value. An error is raised if the IntMap does not already contain an entry for the Key.
--
-- Complexity: O(log n)
assertWriteIntMap :: Key -> a -> IntMap a -> IntMap a
assertWriteIntMap i0 a0 = w where
w E = error "assertWrite: Key not found."
w (N i l a r) = case compareInt# i0 i of
LT -> let l' = w l in l' `seq` N i l' a r
EQ -> N i0 l a0 r
GT -> let r' = w r in r' `seq` N i l a r'
w (Z i l a r) = case compareInt# i0 i of
LT -> let l' = w l in l' `seq` Z i l' a r
EQ -> Z i0 l a0 r
GT -> let r' = w r in r' `seq` Z i l a r'
w (P i l a r) = case compareInt# i0 i of
LT -> let l' = w l in l' `seq` P i l' a r
EQ -> P i0 l a0 r
GT -> let r' = w r in r' `seq` P i l a r'
-- | See 'Map' class method 'alter'.
alterIntMap :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
alterIntMap f i t = case lookupIntMap i t of
Nothing -> case f Nothing of
Nothing -> t
Just a -> ins i a t
ja -> case f ja of
Nothing -> del i t
Just a' -> assertWriteIntMap i a' t
-- | See 'Map' class method 'insertMaybe'.
insertMaybeIntMap :: (a -> Maybe a) -> Key -> a -> IntMap a -> IntMap a
insertMaybeIntMap f i0 a0 t = case lookupIntMap i0 t of
Nothing -> ins i0 a0 t
Just a' -> case f a' of
Nothing -> del i0 t
Just a'' -> assertWriteIntMap i0 a'' t
-- | See 'Map' class method 'delete'.
deleteIntMap :: Key -> IntMap a -> IntMap a
deleteIntMap i t = if t `hasKeyIntMap` i then del i t else t
-- | See 'Map' class method 'adjust'.
adjustWithIntMap :: (a -> a) -> Key -> IntMap a -> IntMap a
adjustWithIntMap f i t = case lookupIntMap i t of
Nothing -> t
Just a -> assertWriteIntMap i (f a) t
-- | See 'Map' class method 'adjust''.
adjustWithIntMap' :: (a -> a) -> Key -> IntMap a -> IntMap a
adjustWithIntMap' f i t = case lookupIntMap i t of
Nothing -> t
Just a -> let a' = f a in a' `seq` assertWriteIntMap i a' t
-- | See 'Map' class method 'adjustMaybe'.
adjustMaybeIntMap :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
adjustMaybeIntMap f i t = case lookupIntMap i t of
Nothing -> t
Just a -> case f a of
Nothing -> del i t
Just a' -> assertWriteIntMap i a' t
-- | See 'Map' class method 'isSubsetOf'.
isSubsetOfIntMap :: IntMap a -> IntMap b -> Bool
isSubsetOfIntMap = s where
-- s :: IntMap a -> IntMap b -> Bool
s E _ = True
s _ E = False
s (N ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb
s (N ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb
s (N ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb
s (Z ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb
s (Z ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb
s (Z ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb
s (P ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb
s (P ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb
s (P ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb
s' ka la ra kb lb rb =
case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case forkL ka lb of
(# False,_ ,_,_ ,_ #) -> False
(# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb of -- (llb < ka < kb) & (ka < lrb < kb)
(# rla,_,rra,_ #) -> (s rla lrb) && (s rra rb) -- (ka < rla < kb) & (ka < kb < rra)
-- ka = kb
EQ -> (s la lb) && (s ra rb)
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case forkL ka rb of
(# False,_ ,_,_ ,_ #) -> False
(# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb of -- (kb < rlb < ka) & (kb < ka < rrb)
(# lla,_,lra,_ #) -> (s lra rlb) && (s lla lb) -- (lla < kb < ka) & (kb < lra < ka)
-- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b)
-- forkL :: Key -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True!
forkL ka tb = forkL_ tb 0# where
forkL_ E h = (# False,E,h,E,h #)
forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#)
forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#)
forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#)
forkL__ k l hl b r hr = case compareInt# ka k of
LT -> case forkL_ l hl of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of
(# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #)
EQ -> (# True,l,hl,r,hr #)
GT -> case forkL_ r hr of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of
(# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #)
-- forkR discards an element from set a if it is equal to the element from set b
-- forkR :: IntMap a -> Key -> (# IntMap a,Int#,IntMap a,Int# #)
forkR ta kb = forkR_ ta 0# where
forkR_ E h = (# E,h,E,h #) -- Relative heights!!
forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#)
forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#)
forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#)
forkR__ k l hl a r hr = case compareInt# k kb of
LT -> case forkR_ r hr of
(# t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of
(# t0_,ht0_ #) -> (# t0_,ht0_,t1,ht1 #)
EQ -> (# l,hl,r,hr #) -- e is discarded from set a
GT -> case forkR_ l hl of
(# t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of
(# t1_,ht1_ #) -> (# t0,ht0,t1_,ht1_ #)
-----------------------------------------------------------------------
----------------------- isSubsetOfIntMap Ends Here ---------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'isSubmapOf'.
isSubmapOfIntMap :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
isSubmapOfIntMap p = s where
-- s :: IntMap a -> IntMap b -> Bool
s E _ = True
s _ E = False
s (N ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb
s (N ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb
s (N ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb
s (Z ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb
s (Z ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb
s (Z ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb
s (P ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb
s (P ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb
s (P ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb
s' ka la a ra kb lb b rb =
case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case forkL ka a lb of
(# False,_ ,_,_ ,_ #) -> False
(# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb b of -- (llb < ka < kb) & (ka < lrb < kb)
(# False,_ ,_,_ ,_ #) -> False
(# True ,rla,_,rra,_ #) -> (s rla lrb) && (s rra rb) -- (ka < rla < kb) & (ka < kb < rra)
-- ka = kb
EQ -> (p a b) && (s la lb) && (s ra rb)
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case forkL ka a rb of
(# False,_ ,_,_ ,_ #) -> False
(# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb b of -- (kb < rlb < ka) & (kb < ka < rrb)
(# False,_ ,_,_ ,_ #) -> False
(# True, lla,_,lra,_ #) -> (s lra rlb) && (s lla lb) -- (lla < kb < ka) & (kb < lra < ka)
-- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b)
-- forkL :: Key -> a -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True!
forkL ka a tb = forkL_ tb 0# where
forkL_ E h = (# False,E,h,E,h #)
forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#)
forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#)
forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#)
forkL__ k l hl b r hr = case compareInt# ka k of
LT -> case forkL_ l hl of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of
(# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #)
EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #)
GT -> case forkL_ r hr of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of
(# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #)
-- forkR discards an element from set a if it is equal to the element from set b
-- forkR :: IntMap a -> Key -> b -> (# Bool,IntMap a,Int#,IntMap a,Int# #)
forkR ta kb b = forkR_ ta 0# where
forkR_ E h = (# True,E,h,E,h #) -- Relative heights!!
forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#)
forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#)
forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#)
forkR__ k l hl a r hr = case compareInt# k kb of
LT -> case forkR_ r hr of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of
(# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #)
EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #) -- e is discarded from set a
GT -> case forkR_ l hl of
(# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #)
(# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of
(# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #)
-----------------------------------------------------------------------
----------------------- isSubmapOfIntMap Ends Here ---------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'map'.
mapIntMap :: (a -> b) -> IntMap a -> IntMap b
mapIntMap f = mapit where
mapit E = E
mapit (N i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` N i l_ (f a) r_
mapit (Z i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` Z i l_ (f a) r_
mapit (P i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` P i l_ (f a) r_
-- | See 'Map' class method 'map''.
mapIntMap' :: (a -> b) -> IntMap a -> IntMap b
mapIntMap' f = mapit where
mapit E = E
mapit (N i l a r) = let l_ = mapit l
r_ = mapit r
b = f a
in b `seq` l_ `seq` r_ `seq` N i l_ b r_
mapit (Z i l a r) = let l_ = mapit l
r_ = mapit r
b = f a
in b `seq` l_ `seq` r_ `seq` Z i l_ b r_
mapit (P i l a r) = let l_ = mapit l
r_ = mapit r
b = f a
in b `seq` l_ `seq` r_ `seq` P i l_ b r_
-- | See 'Map' class method 'mapMaybe'.
mapMaybeIntMap :: (a -> Maybe b) -> IntMap a -> IntMap b
mapMaybeIntMap f t0 = case mapMaybe_ 0# t0 of (# t_,_ #) -> t_ -- Work with relative heights!!
where mapMaybe_ h t = case t of
E -> (# E,h #)
N i l a r -> m i l ((h)-#2#) a r ((h)-#1#)
Z i l a r -> m i l ((h)-#1#) a r ((h)-#1#)
P i l a r -> m i l ((h)-#1#) a r ((h)-#2#)
where m i l hl a r hr = case mapMaybe_ hl l of
(# l_,hl_ #) -> case mapMaybe_ hr r of
(# r_,hr_ #) -> case f a of
Just b -> spliceH i l_ hl_ b r_ hr_
Nothing -> joinH l_ hl_ r_ hr_
-- | See 'Map' class method 'mapWithKey'.
mapWithKeyIntMap :: (Key -> a -> b) -> IntMap a -> IntMap b
mapWithKeyIntMap f = mapit where
mapit E = E
mapit (N i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` N i l_ (f i a) r_
mapit (Z i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` Z i l_ (f i a) r_
mapit (P i l a r) = let l_ = mapit l
r_ = mapit r
in l_ `seq` r_ `seq` P i l_ (f i a) r_
-- | See 'Map' class method 'mapWithKey''.
mapWithKeyIntMap' :: (Key -> a -> b) -> IntMap a -> IntMap b
mapWithKeyIntMap' f = mapit where
mapit E = E
mapit (N i l a r) = let l_ = mapit l
r_ = mapit r
b = f i a
in b `seq` l_ `seq` r_ `seq` N i l_ b r_
mapit (Z i l a r) = let l_ = mapit l
r_ = mapit r
b = f i a
in b `seq` l_ `seq` r_ `seq` Z i l_ b r_
mapit (P i l a r) = let l_ = mapit l
r_ = mapit r
b = f i a
in b `seq` l_ `seq` r_ `seq` P i l_ b r_
-- | See 'Map' class method 'filter'.
filterIntMap :: (a -> Bool) -> IntMap a -> IntMap a
filterIntMap p t0 = case filter_ 0# t0 of (# _,t_,_ #) -> t_ -- Work with relative heights!!
where filter_ h t = case t of
E -> (# False,E,h #)
N i l e r -> f i l ((h)-#2#) e r ((h)-#1#)
Z i l e r -> f i l ((h)-#1#) e r ((h)-#1#)
P i l e r -> f i l ((h)-#1#) e r ((h)-#2#)
where f i l hl e r hr = case filter_ hl l of
(# bl,l_,hl_ #) -> case filter_ hr r of
(# br,r_,hr_ #) -> if p e
then if bl || br
then case spliceH i l_ hl_ e r_ hr_ of
(# t_,h_ #) -> (# True,t_,h_ #)
else (# False,t,h #)
else case joinH l_ hl_ r_ hr_ of
(# t_,h_ #) -> (# True,t_,h_ #)
-- | See 'Map' class method 'foldElemsAsc'.
foldElemsAscIntMap :: (a -> b -> b) -> b -> IntMap a -> b
foldElemsAscIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N _ l a r) b = foldV l a r b
foldU (Z _ l a r) b = foldV l a r b
foldU (P _ l a r) b = foldV l a r b
foldV l a r b = foldU l (f a (foldU r b))
-- | See 'Map' class method 'foldElemsDesc'.
foldElemsDescIntMap :: (a -> b -> b) -> b -> IntMap a -> b
foldElemsDescIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N _ l a r) b = foldV l a r b
foldU (Z _ l a r) b = foldV l a r b
foldU (P _ l a r) b = foldV l a r b
foldV l a r b = foldU r (f a (foldU l b))
-- | See 'Map' class method 'foldKeysAsc'.
foldKeysAscIntMap :: (Key -> b -> b) -> b -> IntMap a -> b
foldKeysAscIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l _ r) b = foldV k l r b
foldU (Z k l _ r) b = foldV k l r b
foldU (P k l _ r) b = foldV k l r b
foldV k l r b = foldU l (f k (foldU r b))
-- | See 'Map' class method 'foldKeysDesc'.
foldKeysDescIntMap :: (Key -> b -> b) -> b -> IntMap a -> b
foldKeysDescIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l _ r) b = foldV k l r b
foldU (Z k l _ r) b = foldV k l r b
foldU (P k l _ r) b = foldV k l r b
foldV k l r b = foldU r (f k (foldU l b))
-- | See 'Map' class method 'foldAssocsAsc'.
foldAssocsAscIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldAssocsAscIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l a r) b = foldV k l a r b
foldU (Z k l a r) b = foldV k l a r b
foldU (P k l a r) b = foldV k l a r b
foldV k l a r b = foldU l (f k a (foldU r b))
-- | See 'Map' class method 'foldAssocsDesc'.
foldAssocsDescIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldAssocsDescIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l a r) b = foldV k l a r b
foldU (Z k l a r) b = foldV k l a r b
foldU (P k l a r) b = foldV k l a r b
foldV k l a r b = foldU r (f k a (foldU l b))
-- | See 'Map' class method 'foldElemsAsc''.
foldElemsAscIntMap' :: (a -> b -> b) -> b -> IntMap a -> b
foldElemsAscIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N _ l a r) b = foldV l a r b
foldU (Z _ l a r) b = foldV l a r b
foldU (P _ l a r) b = foldV l a r b
foldV l a r b = let b' = foldU r b
b'' = f a b'
in b' `seq` b'' `seq` foldU l b''
-- | See 'Map' class method 'foldElemsDesc''.
foldElemsDescIntMap' :: (a -> b -> b) -> b -> IntMap a -> b
foldElemsDescIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N _ l a r) b = foldV l a r b
foldU (Z _ l a r) b = foldV l a r b
foldU (P _ l a r) b = foldV l a r b
foldV l a r b = let b' = foldU l b
b'' = f a b'
in b' `seq` b'' `seq` foldU r b''
-- | See 'Map' class method 'foldKeysAsc''.
foldKeysAscIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b
foldKeysAscIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l _ r) b = foldV k l r b
foldU (Z k l _ r) b = foldV k l r b
foldU (P k l _ r) b = foldV k l r b
foldV k l r b = let b' = foldU r b
b'' = f k b'
in b' `seq` b'' `seq` foldU l b''
-- | See 'Map' class method 'foldKeysDesc''.
foldKeysDescIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b
foldKeysDescIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l _ r) b = foldV k l r b
foldU (Z k l _ r) b = foldV k l r b
foldU (P k l _ r) b = foldV k l r b
foldV k l r b = let b' = foldU l b
b'' = f k b'
in b' `seq` b'' `seq` foldU r b''
-- | See 'Map' class method 'foldAssocsAsc''.
foldAssocsAscIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldAssocsAscIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l a r) b = foldV k l a r b
foldU (Z k l a r) b = foldV k l a r b
foldU (P k l a r) b = foldV k l a r b
foldV k l a r b = let b' = foldU r b
b'' = f k a b'
in b' `seq` b'' `seq` foldU l b''
-- | See 'Map' class method 'foldAssocsDesc''.
foldAssocsDescIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldAssocsDescIntMap' f bb mp = foldU mp bb where
foldU E b = b
foldU (N k l a r) b = foldV k l a r b
foldU (Z k l a r) b = foldV k l a r b
foldU (P k l a r) b = foldV k l a r b
foldV k l a r b = let b' = foldU l b
b'' = f k a b'
in b' `seq` b'' `seq` foldU r b''
-- | See 'Map' class method 'foldElemsUInt'.
foldElemsUIntIntMap :: (a -> Int# -> Int#) -> Int# -> IntMap a -> Int#
foldElemsUIntIntMap f bb mp = foldU mp bb where
foldU E b = b
foldU (N _ l a r) b = foldV l a r b
foldU (Z _ l a r) b = foldV l a r b
foldU (P _ l a r) b = foldV l a r b
foldV l a r b = foldU l (f a (foldU r b))
-- | See 'Map' class method 'valid'.
validIntMap :: IntMap a -> Maybe String
validIntMap imp = if (isBalanced imp) then if (isSorted imp) then Nothing
else Just "IntMap: Tree is not sorted."
else Just "IntMap: Tree is not balanced."
-- | Verify that an IntMap (tree) is height balanced and that the BF of each node is correct.
--
-- Complexity: O(n)
isBalanced :: IntMap a -> Bool
isBalanced t = not (cH t ==# -1#)
-- Local utility, returns height if balanced, -1 if not
cH :: IntMap a -> Int#
cH E = 0#
cH (N _ l _ r) = cH_ 1# l r -- (hr-hl) = 1
cH (Z _ l _ r) = cH_ 0# l r -- (hr-hl) = 0
cH (P _ l _ r) = cH_ 1# r l -- (hl-hr) = 1
cH_ :: Int# -> IntMap a -> IntMap a -> Int#
cH_ delta l r = let hl = cH l
in if hl ==# -1# then hl
else let hr = cH r
in if hr ==# -1# then hr
else if ((hr)-#(hl)) ==# delta then ((hr)+#1#)
else -1#
-- | Verify that an IntMap (tree) is sorted.
--
-- Complexity: O(n)
isSorted :: IntMap a -> Bool
isSorted E = True
isSorted (N i l _ r) = isSorted_ i l r
isSorted (Z i l _ r) = isSorted_ i l r
isSorted (P i l _ r) = isSorted_ i l r
isSorted_ :: Int# -> IntMap a -> IntMap a -> Bool
isSorted_ i l r = (isSortedU l i) && (isSortedL i r)
-- Verify tree is sorted and rightmost element is less than an upper limit (ul)
isSortedU :: IntMap a -> Int# -> Bool
isSortedU E _ = True
isSortedU (N i l _ r) ul = isSortedU_ i l r ul
isSortedU (Z i l _ r) ul = isSortedU_ i l r ul
isSortedU (P i l _ r) ul = isSortedU_ i l r ul
isSortedU_ :: Int# -> IntMap a -> IntMap a -> Int# -> Bool
isSortedU_ i l r ul = case compareInt# i ul of
LT -> (isSortedU l i) && (isSortedLU i r ul)
_ -> False
-- Verify tree is sorted and leftmost element is greater than a lower limit (ll)
isSortedL :: Int# -> IntMap a -> Bool
isSortedL _ E = True
isSortedL ll (N i l _ r) = isSortedL_ ll i l r
isSortedL ll (Z i l _ r) = isSortedL_ ll i l r
isSortedL ll (P i l _ r) = isSortedL_ ll i l r
isSortedL_ :: Int# -> Int# -> IntMap a -> IntMap a -> Bool
isSortedL_ ll i l r = case compareInt# i ll of
GT -> (isSortedLU ll l i) && (isSortedL i r)
_ -> False
-- Verify tree is sorted and leftmost element is greater than a lower limit (ll)
-- and rightmost element is less than an upper limit (ul)
isSortedLU :: Int# -> IntMap a -> Int# -> Bool
isSortedLU _ E _ = True
isSortedLU ll (N i l _ r) ul = isSortedLU_ ll i l r ul
isSortedLU ll (Z i l _ r) ul = isSortedLU_ ll i l r ul
isSortedLU ll (P i l _ r) ul = isSortedLU_ ll i l r ul
isSortedLU_ :: Int# -> Int# -> IntMap a -> IntMap a -> Int# -> Bool
isSortedLU_ ll i l r ul = case compareInt# i ll of
GT -> case compareInt# i ul of
LT -> (isSortedLU ll l i) && (isSortedLU i r ul)
_ -> False
_ -> False
-- isSorted ends --
-------------------
-- | See 'Map' class method compareKey
compareKeyIntMap :: IntMap a -> Int -> Int -> Ordering
compareKeyIntMap _ = compare
urk :: String
urk = "Urk .. Bug in IntMap!"
-- | See 'Map' class method 'insert'.
insertWithIntMap :: (a -> a) -> Key -> a -> IntMap a -> IntMap a
insertWithIntMap _ k0 a0 E = Z k0 E a0 E
insertWithIntMap f k0 a0 (N k l a r) = putN f k0 a0 k l a r
insertWithIntMap f k0 a0 (Z k l a r) = putZ f k0 a0 k l a r
insertWithIntMap f k0 a0 (P k l a r) = putP f k0 a0 k l a r
-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and
-- returns the updated (relative) tree height.
pushH :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)
pushH _ k0 a0 h E = (# Z k0 E a0 E, ((h)+#1#) #)
pushH f k0 a0 h (N k l a r) = let t_ = putN f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change
pushH f k0 a0 h (Z k l a r) = let t_ = putZ f k0 a0 k l a r in
case t_ of
E -> error urk -- impossible
Z _ _ _ _ -> (# t_, h #)
_ -> (# t_,((h)+#1#) #)
pushH f k0 a0 h (P k l a r) = let t_ = putP f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change
----------------------------- LEVEL 1 ---------------------------------
-- putN, putZ, putP --
-----------------------------------------------------------------------
-- Put in (N k l a r), BF=-1 , (never returns P)
putN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putN f k0 a0 k l a r = case compareInt# k0 k of
LT -> putNL f k0 a0 k l a r
EQ -> let a' = f a in N k0 l a' r
GT -> putNR f k0 a0 k l a r
-- Put in (Z k l a r), BF= 0
putZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putZ f k0 a0 k l a r = case compareInt# k0 k of
LT -> putZL f k0 a0 k l a r
EQ -> let a' = f a in Z k0 l a' r
GT -> putZR f k0 a0 k l a r
-- Put in (P k l a r), BF=+1 , (never returns N)
putP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putP f k0 a0 k l a r = case compareInt# k0 k of
LT -> putPL f k0 a0 k l a r
EQ -> let a' = f a in P k0 l a' r
GT -> putPR f k0 a0 k l a r
----------------------------- LEVEL 2 ---------------------------------
-- putNL, putZL, putPL --
-- putNR, putZR, putPR --
-----------------------------------------------------------------------
-- (putNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)
{-# INLINE putNL #-}
putNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putNL _ k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0
putNL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
putNL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
putNL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
_ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0
-- (putZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N)
{-# INLINE putZL #-}
putZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putZL _ k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1
putZL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
putZL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
putZL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1
-- (putZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)
{-# INLINE putZR #-}
putZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putZR _ k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1
putZR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
putZR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
putZR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1
-- (putPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)
{-# INLINE putPR #-}
putPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putPR _ k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0
putPR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
putPR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
putPR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
_ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0
-------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------
-- (putNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)
{-# INLINE putNR #-}
putNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1
putNR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
putNR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
putNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL
LT -> putNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P)
EQ -> let ra' = f ra in N k l a (Z k0 rl ra' rr) -- new ra
GT -> putNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P)
-- (putPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)
{-# INLINE putPL #-}
putPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1
putPL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
putPL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
putPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR
LT -> putPLL f k0 a0 k lk ll la lr a r -- LL (never returns N)
EQ -> let la' = f la in P k (Z k0 ll la' lr) a r -- new la
GT -> putPLR f k0 a0 k lk ll la lr a r -- LR (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- putNRR, putPLL --
-- putNRL, putPLR --
-----------------------------------------------------------------------
-- (putNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE putNRR #-}
putNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putNRR _ k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!!
putNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = putN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
putNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = putP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
putNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = putZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes
in case rr' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change
_ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
-- (putPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE putPLL #-}
putPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
putPLL _ k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!!
putPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = putN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
putPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = putP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
putPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = putZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes
in case ll' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change
_ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-- (putNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE putNRL #-}
putNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
putNRL _ k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !!
putNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = putN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
putNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = putP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
putNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = putZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes
in case rl' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change
N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!
P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!
-- (putPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE putPLR #-}
putPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
putPLR _ k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !!
putPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = putN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
putPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = putP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
putPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = putZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes
in case lr' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change
N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!
P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!
-----------------------------------------------------------------------
--------------------- insertWithIntMap/pushH Ends Here ---------------------
-----------------------------------------------------------------------
-----------------------------------------------------------------------
--------------------- insertWithIntMap/pushH Ends Here ---------------------
-----------------------------------------------------------------------
-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and
-- returns the updated (relative) tree height.
pushH' -- cpp madness
:: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)
pushH' _ k0 a0 h E = -- cpp madness
(# Z k0 E a0 E, ((h)+#1#) #)
pushH' f k0 a0 h (N k l a r) = let t_ = pputN f k0 a0 k l a r in t_ `seq`
(# t_,h #) -- Height can't change
pushH' f k0 a0 h (Z k l a r) = let t_ = pputZ f k0 a0 k l a r in
case t_ of
E -> error urk -- impossible
Z _ _ _ _ -> (# t_, h #)
_ -> (# t_,((h)+#1#) #)
pushH' f k0 a0 h (P k l a r) = let t_ = pputP f k0 a0 k l a r in t_ `seq`
(# t_,h #) -- Height can't change
----------------------------- LEVEL 1 ---------------------------------
-- pputN, pputZ, pputP --
-----------------------------------------------------------------------
-- Put in (N k l a r), BF=-1 , (never returns P)
pputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputN f k0 a0 k l a r = case compareInt# k0 k of
LT -> pputNL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` N k0 l a' r
GT -> pputNR f k0 a0 k l a r
-- Put in (Z k l a r), BF= 0
pputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputZ f k0 a0 k l a r = case compareInt# k0 k of
LT -> pputZL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` Z k0 l a' r
GT -> pputZR f k0 a0 k l a r
-- Put in (P k l a r), BF=+1 , (never returns N)
pputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputP f k0 a0 k l a r = case compareInt# k0 k of
LT -> pputPL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` P k0 l a' r
GT -> pputPR f k0 a0 k l a r
----------------------------- LEVEL 2 ---------------------------------
-- pputNL, pputZL, pputPL --
-- pputNR, pputZR, pputPR --
-----------------------------------------------------------------------
-- (pputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)
{-# INLINE pputNL #-}
pputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputNL _ k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0
pputNL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
pputNL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
pputNL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
_ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0
-- (pputZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N)
{-# INLINE pputZL #-}
pputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputZL _ k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1
pputZL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
pputZL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
pputZL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1
-- (pputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)
{-# INLINE pputZR #-}
pputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputZR _ k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1
pputZR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
pputZR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
pputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1
-- (pputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)
{-# INLINE pputPR #-}
pputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputPR _ k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0
pputPR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
pputPR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
pputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
_ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0
-------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------
-- (pputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)
{-# INLINE pputNR #-}
pputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1
pputNR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
pputNR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
pputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL
LT -> pputNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P)
EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr) -- new ra
GT -> pputNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P)
-- (pputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)
{-# INLINE pputPL #-}
pputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1
pputPL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
pputPL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
pputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR
LT -> pputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N)
EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la
GT -> pputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- pputNRR, pputPLL --
-- pputNRL, pputPLR --
-----------------------------------------------------------------------
-- (pputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE pputNRR #-}
pputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputNRR _ k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!!
pputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = pputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
pputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = pputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
pputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = pputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes
in case rr' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change
_ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
-- (pputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE pputPLL #-}
pputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
pputPLL _ k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!!
pputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = pputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
pputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = pputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
pputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = pputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes
in case ll' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change
_ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-- (pputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE pputNRL #-}
pputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
pputNRL _ k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !!
pputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = pputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
pputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = pputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
pputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = pputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes
in case rl' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change
N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!
P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!
-- (pputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE pputPLR #-}
pputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
pputPLR _ k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !!
pputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = pputN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
pputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = pputP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
pputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = pputZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes
in case lr' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change
N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!
P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!
-----------------------------------------------------------------------
-------------------- insertWithIntMap'/pushH' Ends Here --------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'insert'.
insertWithIntMap' -- cpp madness
:: (a -> a) -> Key -> a -> IntMap a -> IntMap a
insertWithIntMap' _ k0 a0 E = a0 `seq` Z k0 E a0 E
insertWithIntMap' f k0 a0 (N k l a r) = ppputN f k0 a0 k l a r
insertWithIntMap' f k0 a0 (Z k l a r) = ppputZ f k0 a0 k l a r
insertWithIntMap' f k0 a0 (P k l a r) = ppputP f k0 a0 k l a r
{- Not used currently -
-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and
-- returns the updated (relative) tree height.
pushH'' -- cpp madness
:: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)
pushH'' _ k0 a0 h E = -- cpp madness
a0 `seq` (# Z k0 E a0 E, ((h)+#1#) #)
pushH'' f k0 a0 h (N k l a r) = let t_ = ppputN f k0 a0 k l a r in t_ `seq`
(# t_,h #) -- Height can't change
pushH'' f k0 a0 h (Z k l a r) = let t_ = ppputZ f k0 a0 k l a r in
case t_ of
E -> error urk -- impossible
Z _ _ _ _ -> (# t_, h #)
_ -> (# t_,((h)+#1#) #)
pushH'' f k0 a0 h (P k l a r) = let t_ = ppputP f k0 a0 k l a r in t_ `seq`
(# t_,h #) -- Height can't change
- Not used currently -}
----------------------------- LEVEL 1 ---------------------------------
-- ppputN, ppputZ, ppputP --
-----------------------------------------------------------------------
-- Put in (N k l a r), BF=-1 , (never returns P)
ppputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputN f k0 a0 k l a r = case compareInt# k0 k of
LT -> ppputNL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` N k0 l a' r
GT -> ppputNR f k0 a0 k l a r
-- Put in (Z k l a r), BF= 0
ppputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputZ f k0 a0 k l a r = case compareInt# k0 k of
LT -> ppputZL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` Z k0 l a' r
GT -> ppputZR f k0 a0 k l a r
-- Put in (P k l a r), BF=+1 , (never returns N)
ppputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputP f k0 a0 k l a r = case compareInt# k0 k of
LT -> ppputPL f k0 a0 k l a r
EQ -> let a' = f a in a' `seq` P k0 l a' r
GT -> ppputPR f k0 a0 k l a r
----------------------------- LEVEL 2 ---------------------------------
-- ppputNL, ppputZL, ppputPL --
-- ppputNR, ppputZR, ppputPR --
-----------------------------------------------------------------------
-- (ppputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)
{-# INLINE ppputNL #-}
ppputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputNL _ k0 a0 k E a r = a0 `seq` Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0
ppputNL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
ppputNL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
ppputNL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
_ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0
-- (ppputZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N)
{-# INLINE ppputZL #-}
ppputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputZL _ k0 a0 k E a r = a0 `seq` P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1
ppputZL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
ppputZL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
ppputZL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1
-- (ppputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)
{-# INLINE ppputZR #-}
ppputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputZR _ k0 a0 k l a E = a0 `seq` N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1
ppputZR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
ppputZR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
ppputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1
-- (ppputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)
{-# INLINE ppputPR #-}
ppputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputPR _ k0 a0 k l a E = a0 `seq` Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0
ppputPR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
ppputPR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
ppputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
_ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0
-------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------
-- (ppputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)
{-# INLINE ppputNR #-}
ppputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1
ppputNR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
ppputNR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
ppputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL
LT -> ppputNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P)
EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr) -- new ra
GT -> ppputNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P)
-- (ppputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)
{-# INLINE ppputPL #-}
ppputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1
ppputPL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
ppputPL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
ppputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR
LT -> ppputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N)
EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la
GT -> ppputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- ppputNRR, ppputPLL --
-- ppputNRL, ppputPLR --
-----------------------------------------------------------------------
-- (ppputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE ppputNRR #-}
ppputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputNRR _ k0 a0 k l a rk rl ra E = a0 `seq` Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!!
ppputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = ppputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
ppputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = ppputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
ppputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = ppputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes
in case rr' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change
_ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
-- (ppputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE ppputPLL #-}
ppputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
ppputPLL _ k0 a0 k lk E la lr a r = a0 `seq` Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!!
ppputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = ppputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
ppputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = ppputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
ppputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = ppputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes
in case ll' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change
_ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-- (ppputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE ppputNRL #-}
ppputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
ppputNRL _ k0 a0 k l a rk E ra rr = a0 `seq` Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !!
ppputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = ppputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
ppputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = ppputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
ppputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = ppputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes
in case rl' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change
N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!
P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!
-- (ppputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE ppputPLR #-}
ppputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
ppputPLR _ k0 a0 k lk ll la E a r = a0 `seq` Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !!
ppputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = ppputN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
ppputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = ppputP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
ppputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = ppputZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes
in case lr' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change
N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!
P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!
-----------------------------------------------------------------------
------------------ insertWithIntMap'/pushH'' Ends Here --------------------
-----------------------------------------------------------------------
-- | Local insertion facility which just overwrites any existing entry.
ins :: Key -> a -> IntMap a -> IntMap a
ins k0 a0 E = Z k0 E a0 E
ins k0 a0 (N k l a r) = insN k0 a0 k l a r
ins k0 a0 (Z k l a r) = insZ k0 a0 k l a r
ins k0 a0 (P k l a r) = insP k0 a0 k l a r
-- | Same as 'ins', but takes the (relative) tree height as an extra argument and
-- returns the updated (relative) tree height.
insH :: Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)
insH k0 a0 h E = (# Z k0 E a0 E, ((h)+#1#) #)
insH k0 a0 h (N k l a r) = let t_ = insN k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change
insH k0 a0 h (Z k l a r) = let t_ = insZ k0 a0 k l a r in
case t_ of
N _ _ _ _ -> (# t_,((h)+#1#) #)
P _ _ _ _ -> (# t_,((h)+#1#) #)
_ -> (# t_, h #)
insH k0 a0 h (P k l a r) = let t_ = insP k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change
----------------------------- LEVEL 1 ---------------------------------
-- insN, insZ, insP --
-----------------------------------------------------------------------
-- Put in (N k l a r), BF=-1 , (never returns P)
insN :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insN k0 a0 k l a r = case compareInt# k0 k of
LT -> insNL k0 a0 k l a r
EQ -> N k l a0 r
GT -> insNR k0 a0 k l a r
-- Put in (Z k l a r), BF= 0
insZ :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insZ k0 a0 k l a r = case compareInt# k0 k of
LT -> insZL k0 a0 k l a r
EQ -> Z k l a0 r
GT -> insZR k0 a0 k l a r
-- Put in (P k l a r), BF=+1 , (never returns N)
insP :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insP k0 a0 k l a r = case compareInt# k0 k of
LT -> insPL k0 a0 k l a r
EQ -> P k l a0 r
GT -> insPR k0 a0 k l a r
----------------------------- LEVEL 2 ---------------------------------
-- insNL, insZL, insPL --
-- insNR, insZR, insPR --
-----------------------------------------------------------------------
-- (insNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P)
{-# INLINE insNL #-}
insNL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insNL k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0
insNL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
insNL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l' `seq` N k l' a r
insNL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
_ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0
-- (insZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N)
{-# INLINE insZL #-}
insZL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insZL k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1
insZL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
insZL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l' `seq` Z k l' a r
insZL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes
in case l' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1
-- (insZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P)
{-# INLINE insZR #-}
insZR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insZR k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1
insZR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
insZR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r' `seq` Z k l a r'
insZR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
_ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1
-- (insPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N)
{-# INLINE insPR #-}
insPR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insPR k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0
insPR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
insPR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r' `seq` P k l a r'
insPR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes
in case r' of
E -> error urk -- impossible
Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
_ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0
-------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 ---------
-- (insNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P)
{-# INLINE insNR #-}
insNR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insNR _ _ _ _ _ E = error urk -- impossible if BF=-1
insNR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
insNR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r' `seq` N k l a r'
insNR k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL
LT -> insNRL k0 a0 k l a rk rl ra rr -- RL (never returns P)
EQ -> N k l a (Z rk rl a0 rr)
GT -> insNRR k0 a0 k l a rk rl ra rr -- RR (never returns P)
-- (insPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N)
{-# INLINE insPL #-}
insPL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insPL _ _ _ E _ _ = error urk -- impossible if BF=+1
insPL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
insPL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l' `seq` P k l' a r
insPL k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR
LT -> insPLL k0 a0 k lk ll la lr a r -- LL (never returns N)
EQ -> P k (Z lk ll a0 lr) a r
GT -> insPLR k0 a0 k lk ll la lr a r -- LR (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- insNRR, insPLL --
-- insNRL, insPLR --
-----------------------------------------------------------------------
-- (insNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE insNRR #-}
insNRR :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insNRR k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!!
insNRR k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = insN k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
insNRR k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = insP k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr' `seq` N k l a (Z rk rl ra rr')
insNRR k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = insZ k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes
in case rr' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change
_ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
-- (insPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE insPLL #-}
insPLL :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
insPLL k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!!
insPLL k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = insN k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
insPLL k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = insP k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll' `seq` P k (Z lk ll' la lr) a r
insPLL k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = insZ k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes
in case ll' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change
_ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-- (insNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P)
{-# INLINE insNRL #-}
insNRL :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a
insNRL k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !!
insNRL k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = insN k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
insNRL k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = insP k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change
in rl' `seq` N k l a (Z rk rl' ra rr)
insNRL k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = insZ k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes
in case rl' of
E -> error urk -- impossible
Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change
N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !!
P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !!
-- (insPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N)
{-# INLINE insPLR #-}
insPLR :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a
insPLR k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !!
insPLR k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = insN k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
insPLR k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = insP k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change
in lr' `seq` P k (Z lk ll la lr') a r
insPLR k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = insZ k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes
in case lr' of
E -> error urk -- impossible
Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change
N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !!
P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !!
-----------------------------------------------------------------------
-------------------------- ins/insH End Here --------------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'union'.
unionIntMap :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionIntMap f t0_ t1_ = u0 t0_ t1_ where
u0 E t1 = t1
u0 t0 E = t0
u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1
u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1
u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1
u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1
u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1
-- uH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- IntMap a
uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t
-- u :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- (# Int#,IntMap a #) -- Output IntMap with height
------------------------------------------------
u 0# _ h1 t1 = (# t1,h1 #)
u h0 t0 0# _ = (# t0,h0 #)
------------------------------------------------
u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of
LT -> (# N k0 E a0 t1, 2# #)
EQ -> (# Z k0 E (f a0 a1) E , 1# #)
GT -> (# P k0 t1 a0 E , 2# #)
u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1
u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0
------------------------------------------------
u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1
u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0
------------------------------------------------
u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u _ _ _ _ = error (mErr ++ "unionIntMap: Bad IntMap.")
u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =
case compareInt# k0 k1 of
-- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)
LT -> case forkR hr0 r0 k1 a1 of
(# hrl0,rl0,a1_,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0)
(# hll1,ll1,a0_,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1)
-- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)
case u hl0 l0 hll1 ll1 of
(# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of
(# m,hm #) -> case u hrr0 rr0 hr1 r1 of
(# r,hr #) -> case spliceH k1 m hm a1_ r hr of
(# t,ht #) -> spliceH k0 l hl a0_ t ht
-- k0 = k1
EQ -> case u hl0 l0 hl1 l1 of
(# l,hl #) -> case u hr0 r0 hr1 r1 of
(# r,hr #) -> spliceH k0 l hl (f a0 a1) r hr
-- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)
GT -> case forkL k0 a0 hr1 r1 of
(# hrl1,rl1,a0_,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1)
(# hll0,ll0,a1_,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0)
-- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)
case u hll0 ll0 hl1 l1 of
(# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of
(# m,hm #) -> case u hr0 r0 hrr1 rr1 of
(# r,hr #) -> case spliceH k1 l hl a1_ m hm of
(# t,ht #) -> spliceH k0 t ht a0_ r hr
-- We need 2 different versions of fork (L & R) to ensure that values are combined in
-- the right order (f a0 a1)
------------------------------------------------
-- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #)
forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where
forkL_ h E = (# h,E,a0,h,E #)
forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r
forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r
forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r
forkL__ k hl l a hr r = case compareInt# k0 k of
LT -> case forkL_ hl l of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #)
EQ -> (# hl,l,f a0 a,hr,r #)
GT -> case forkL_ hr r of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #)
------------------------------------------------
-- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #)
forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where
forkR_ h E = (# h,E,a1,h,E #)
forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r
forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r
forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r
forkR__ k hl l a hr r = case compareInt# k k1 of
LT -> case forkR_ hr r of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #)
EQ -> (# hl,l,f a a1,hr,r #)
GT -> case forkR_ hl l of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #)
------------------------------------------------
-- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB k0 a0 ht1 t1 = pushH (\a1 -> f a0 a1) k0 a0 ht1 t1
------------------------------------------------
-- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA k1 a1 ht0 t0 = pushH (\a0 -> f a0 a1) k1 a1 ht0 t0
------------------------------------------------
-- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of
(# t,h #) -> pushAB k0 a0 h t
------------------------------------------------
-- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of
(# t,h #) -> pushBA k1 a1 h t
------------------------------------------------
-- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of
(# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t
------------------------------------------------
-- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of
(# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t
-----------------------------------------------------------------------
----------------------- unionIntMap Ends Here --------------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'union''.
unionIntMap' :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionIntMap' f t0_ t1_ = u0 t0_ t1_ where
u0 E t1 = t1
u0 t0 E = t0
u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1
u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1
u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1
u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1
u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1
-- uH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- IntMap a
uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t
-- u :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- (# Int#,IntMap a #) -- Output IntMap with height
------------------------------------------------
u 0# _ h1 t1 = (# t1,h1 #)
u h0 t0 0# _ = (# t0,h0 #)
------------------------------------------------
u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of
LT -> (# N k0 E a0 t1, 2# #)
EQ -> let a_ = f a0 a1 in a_ `seq`
(# Z k0 E a_ E , 1# #)
GT -> (# P k0 t1 a0 E , 2# #)
u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1
u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0
------------------------------------------------
u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1
u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0
------------------------------------------------
u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u _ _ _ _ = error (mErr ++ "unionIntMap: Bad IntMap.")
u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =
case compareInt# k0 k1 of
-- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)
LT -> case forkR hr0 r0 k1 a1 of
(# hrl0,rl0,a1_,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0)
(# hll1,ll1,a0_,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1)
-- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)
case u hl0 l0 hll1 ll1 of
(# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of
(# m,hm #) -> case u hrr0 rr0 hr1 r1 of
(# r,hr #) -> case spliceH k1 m hm a1_ r hr of
(# t,ht #) -> spliceH k0 l hl a0_ t ht
-- k0 = k1
EQ -> case u hl0 l0 hl1 l1 of
(# l,hl #) -> case u hr0 r0 hr1 r1 of
(# r,hr #) -> let a_ = f a0 a1 in a_ `seq` spliceH k0 l hl a_ r hr
-- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)
GT -> case forkL k0 a0 hr1 r1 of
(# hrl1,rl1,a0_,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1)
(# hll0,ll0,a1_,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0)
-- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)
case u hll0 ll0 hl1 l1 of
(# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of
(# m,hm #) -> case u hr0 r0 hrr1 rr1 of
(# r,hr #) -> case spliceH k1 l hl a1_ m hm of
(# t,ht #) -> spliceH k0 t ht a0_ r hr
-- We need 2 different versions of fork (L & R) to ensure that values are combined in
-- the right order (f a0 a1)
------------------------------------------------
-- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #)
forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where
forkL_ h E = (# h,E,a0,h,E #)
forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r
forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r
forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r
forkL__ k hl l a hr r = case compareInt# k0 k of
LT -> case forkL_ hl l of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #)
EQ -> let a_ = f a0 a in a_ `seq`
(# hl,l,a_,hr,r #)
GT -> case forkL_ hr r of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #)
------------------------------------------------
-- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #)
forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where
forkR_ h E = (# h,E,a1,h,E #)
forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r
forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r
forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r
forkR__ k hl l a hr r = case compareInt# k k1 of
LT -> case forkR_ hr r of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #)
EQ -> let a_ = f a a1 in a_ `seq`
(# hl,l,a_,hr,r #)
GT -> case forkR_ hl l of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #)
------------------------------------------------
-- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB k0 a0 ht1 t1 = pushH' (\a1 -> f a0 a1) k0 a0 ht1 t1
------------------------------------------------
-- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA k1 a1 ht0 t0 = pushH' (\a0 -> f a0 a1) k1 a1 ht0 t0
------------------------------------------------
-- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of
(# t,h #) -> pushAB k0 a0 h t
------------------------------------------------
-- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of
(# t,h #) -> pushBA k1 a1 h t
------------------------------------------------
-- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of
(# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t
------------------------------------------------
-- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of
(# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t
-----------------------------------------------------------------------
----------------------- unionIntMap' Ends Here --------------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'unionMaybe'.
unionMaybeIntMap :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a
unionMaybeIntMap f t0_ t1_ = u0 t0_ t1_ where
u0 E t1 = t1
u0 t0 E = t0
u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1
u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1
u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1
u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1
u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1
u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1
u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1
-- uH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- IntMap a
uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t
-- u :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap a -> -- 2nd IntMap with height
-- (# Int#,IntMap a #) -- Output IntMap with height
------------------------------------------------
u 0# _ h1 t1 = (# t1,h1 #)
u h0 t0 0# _ = (# t0,h0 #)
------------------------------------------------
u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of
LT -> (# N k0 E a0 t1, 2# #)
EQ -> case f a0 a1 of
Just a -> (# Z k0 E a E , 1# #)
Nothing -> (# E , 0# #)
GT -> (# P k0 t1 a0 E , 2# #)
u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1
u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0
------------------------------------------------
u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1
u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0
u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1
u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0
------------------------------------------------
u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1
u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1
u _ _ _ _ = error (mErr ++ "unionMaybeIntMap: Bad IntMap.")
u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 =
case compareInt# k0 k1 of
-- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1)
LT -> case forkR hr0 r0 k1 a1 of
(# hrl0,rl0,mba1,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0)
(# hll1,ll1,mba0,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1)
-- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1)
case u hl0 l0 hll1 ll1 of
(# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of
(# m,hm #) -> case u hrr0 rr0 hr1 r1 of
(# r,hr #) -> case (case mba1 of Just a -> spliceH k1 m hm a r hr
Nothing -> joinH m hm r hr
) of
(# t,ht #) -> case mba0 of Just a -> spliceH k0 l hl a t ht
Nothing -> joinH l hl t ht
-- k0 = k1
EQ -> case u hl0 l0 hl1 l1 of
(# l,hl #) -> case u hr0 r0 hr1 r1 of
(# r,hr #) -> case f a0 a1 of Just a -> spliceH k0 l hl a r hr
Nothing -> joinH l hl r hr
-- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)
GT -> case forkL k0 a0 hr1 r1 of
(# hrl1,rl1,mba0,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1)
(# hll0,ll0,mba1,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0)
-- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)
case u hll0 ll0 hl1 l1 of
(# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of
(# m,hm #) -> case u hr0 r0 hrr1 rr1 of
(# r,hr #) -> case (case mba1 of Just a -> spliceH k1 l hl a m hm
Nothing -> joinH l hl m hm
) of
(# t,ht #) -> case mba0 of Just a -> spliceH k0 t ht a r hr
Nothing -> joinH t ht r hr
-- We need 2 different versions of fork (L & R) to ensure that values are combined in
-- the right order (f a0 a1)
------------------------------------------------
-- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #)
forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where
forkL_ h E = (# h,E,Just a0,h,E #)
forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r
forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r
forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r
forkL__ k hl l a hr r = case compareInt# k0 k of
LT -> case forkL_ hl l of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #)
EQ -> let mba = f a0 a in mba `seq` (# hl,l,mba,hr,r #)
GT -> case forkL_ hr r of
(# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #)
------------------------------------------------
-- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #)
forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where
forkR_ h E = (# h,E,Just a1,h,E #)
forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r
forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r
forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r
forkR__ k hl l a hr r = case compareInt# k k1 of
LT -> case forkR_ hr r of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #)
EQ -> let mba = f a a1 in mba `seq` (# hl,l,mba,hr,r #)
GT -> case forkR_ hl l of
(# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of
(# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #)
------------------------------------------------
-- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB k0 a0 ht1 t1 = pushMaybeH (\a1 -> f a0 a1) k0 a0 ht1 t1
------------------------------------------------
-- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA k1 a1 ht0 t0 = pushMaybeH (\a0 -> f a0 a1) k1 a1 ht0 t0
------------------------------------------------
-- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of
(# t,h #) -> pushAB k0 a0 h t
------------------------------------------------
-- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of
(# t,h #) -> pushBA k1 a1 h t
------------------------------------------------
-- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of
(# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t
------------------------------------------------
-- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of
(# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t
-----------------------------------------------------------------------
-------------------- unionMaybeIntMap Ends Here ------------------------
-----------------------------------------------------------------------
-- Utility used by unionMaybeIntMap
pushMaybeH :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushMaybeH f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of
Nothing -> insH k0 a0 ht1 t1
Just a -> case f a of
Nothing -> delH k0 ht1 t1
Just a_ -> let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq`
(# t_,ht1 #) -- No height change
-- -- Utility used by unionMaybeIntMap
-- pushMaybeH' :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #)
-- pushMaybeH' f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of
-- Nothing -> insH k0 a0 ht1 t1
-- Just a -> case f a of
-- Nothing -> delH k0 ht1 t1
-- Just a_ -> a_ `seq` let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq`
-- (# t_,ht1 #) -- No height change
-- | Specialised association list.
data IAList a = Empt
| Cons {-# UNPACK #-} !Int# a (IAList a)
deriving(Eq,Ord)
-- | Convert an 'IntMap' to an 'IAList' (in ascending order).
asIAList :: IntMap a -> IAList a
asIAList imp = f imp Empt where
f E ial = ial
f (N k l a r) ial = f' k l a r ial
f (Z k l a r) ial = f' k l a r ial
f (P k l a r) ial = f' k l a r ial
f' k l a r ial = let ial' = f r ial
ial'' = ial' `seq` Cons k a ial'
in ial'' `seq` f l ial''
-- | See 'Map' class method 'intersection'.
intersectionIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
intersectionIntMap f ta0 tb0 = i0 ta0 tb0 where
-- i0 :: IntMap a -> IntMap b -> IntMap c
i0 E _ = E
i0 _ E = E
i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb
i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb
i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb
i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb
i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb
i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb
i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb
i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb
i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb
-- iH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IntMap c
iH hta ta htb tb = case i hta ta htb tb Empt 0# of
(# ial,n #) -> case subst (rep (I# (n))) ial of
(# imp,rm #) -> case rm of
Empt -> imp
_ -> error (mErr ++ "intersectionIntMap: Bad IAList.")
-- i :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IAList c -> Int# -> -- Input IAList with length
-- (# IAList c, Int# #) -- Output IAList with length
------------------------------------------------
i 0# _ _ _ cs n = (# cs,n #)
i _ _ 0# _ cs n = (# cs,n #)
------------------------------------------------
i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then (# Cons ka (f ea eb) cs, ((n)+#1#) #)
else (# cs,n #)
i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n
i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n
------------------------------------------------
i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n
i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n
------------------------------------------------
-- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1
i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i _ _ _ _ _ _ = error (mErr ++ "intersectionIntMap: Bad IntMap.")
------------------------------------------------
i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case fork kb hra ra of
(# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra)
(# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb)
-- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)
(# cs_,n_ #) -> case (case mbb of
Nothing -> i hrla rla hlrb lrb cs_ n_
Just b -> i hrla rla hlrb lrb (Cons ka (f ea b) cs_) ((n_)+#1#)
) of
(# cs__,n__ #) -> case mba of
Nothing -> i hla la hllb llb cs__ n__
Just a -> i hla la hllb llb (Cons kb (f a eb) cs__) ((n__)+#1#)
-- ka = kb
EQ -> case i hra ra hrb rb cs n of
(# cs_,n_ #) -> i hla la hlb lb (Cons ka (f ea eb) cs_) ((n_)+#1#)
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case fork ka hrb rb of
(# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb)
(# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka)
-- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)
(# cs_,n_ #) -> case (case mba of
Nothing -> i hlra lra hrlb rlb cs_ n_
Just a -> i hlra lra hrlb rlb (Cons kb (f a eb) cs_) ((n_)+#1#)
) of
(# cs__,n__ #) -> case mbb of
Nothing -> i hlla lla hlb lb cs__ n__
Just b -> i hlla lla hlb lb (Cons ka (f ea b) cs__) ((n__)+#1#)
------------------------------------------------
-- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)
-- Tree height (ht) is known to be >= 1, can we exploit this ??
fork k0 ht t = fork_ ht t where
fork_ h E = (# h,E,Nothing,h,E #)
fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r
fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r
fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r
fork__ k hl l x hr r = case compareInt# k0 k of
LT -> case fork_ hl l of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of
(# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #)
EQ -> (# hl,l,Just x,hr,r #)
GT -> case fork_ hr r of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #)
------------------------------------------------
-- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB ka ea tb cs n = rd tb where
rd E = (# cs,n #)
rd (N k l b r) = rd_ k l b r
rd (Z k l b r) = rd_ k l b r
rd (P k l b r) = rd_ k l b r
rd_ k l b r = case compareInt# ka k of
LT -> rd l
EQ -> (# Cons ka (f ea b) cs, ((n)+#1#) #)
GT -> rd r
------------------------------------------------
-- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA kb eb ta cs n = rd ta where
rd E = (# cs,n #)
rd (N k l a r) = rd_ k l a r
rd (Z k l a r) = rd_ k l a r
rd (P k l a r) = rd_ k l a r
rd_ k l a r = case compareInt# kb k of
LT -> rd l
EQ -> (# Cons kb (f a eb) cs, ((n)+#1#) #)
GT -> rd r
------------------------------------------------
-- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of
(# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_
------------------------------------------------
-- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of
(# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of
(# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of
(# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_
-----------------------------------------------------------------------
-------------------- intersectionIntMap Ends Here ----------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'intersection''.
intersectionIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
intersectionIntMap' f ta0 tb0 = i0 ta0 tb0 where
-- i0 :: IntMap a -> IntMap b -> IntMap c
i0 E _ = E
i0 _ E = E
i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb
i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb
i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb
i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb
i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb
i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb
i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb
i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb
i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb
-- iH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IntMap c
iH hta ta htb tb = case i hta ta htb tb Empt 0# of
(# ial,n #) -> case subst (rep (I# (n))) ial of
(# imp,rm #) -> case rm of
Empt -> imp
_ -> error (mErr ++ "intersectionIntMap': Bad IAList.")
-- i :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IAList c -> Int# -> -- Input IAList with length
-- (# IAList c, Int# #) -- Output IAList with length
------------------------------------------------
i 0# _ _ _ cs n = (# cs,n #)
i _ _ 0# _ cs n = (# cs,n #)
------------------------------------------------
i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then let c = f ea eb in c `seq`
(# Cons ka c cs, ((n)+#1#) #)
else (# cs,n #)
i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n
i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n
------------------------------------------------
i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n
i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n
------------------------------------------------
-- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1
i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i _ _ _ _ _ _ = error (mErr ++ "intersectionIntMap': Bad IntMap.")
------------------------------------------------
i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case fork kb hra ra of
(# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra)
(# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb)
-- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)
(# cs_,n_ #) -> case (case mbb of
Nothing -> i hrla rla hlrb lrb cs_ n_
Just b -> let c = f ea b in c `seq`
i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#)
) of
(# cs__,n__ #) -> case mba of
Nothing -> i hla la hllb llb cs__ n__
Just a -> let c = f a eb in c `seq`
i hla la hllb llb (Cons kb c cs__) ((n__)+#1#)
-- ka = kb
EQ -> case i hra ra hrb rb cs n of
(# cs_,n_ #) -> let c = f ea eb in c `seq`
i hla la hlb lb (Cons ka c cs_) ((n_)+#1#)
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case fork ka hrb rb of
(# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb)
(# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka)
-- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)
(# cs_,n_ #) -> case (case mba of
Nothing -> i hlra lra hrlb rlb cs_ n_
Just a -> let c = f a eb in c `seq`
i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#)
) of
(# cs__,n__ #) -> case mbb of
Nothing -> i hlla lla hlb lb cs__ n__
Just b -> let c = f ea b in c `seq`
i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#)
------------------------------------------------
-- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)
-- Tree height (ht) is known to be >= 1, can we exploit this ??
fork k0 ht t = fork_ ht t where
fork_ h E = (# h,E,Nothing,h,E #)
fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r
fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r
fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r
fork__ k hl l x hr r = case compareInt# k0 k of
LT -> case fork_ hl l of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of
(# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #)
EQ -> (# hl,l,Just x,hr,r #)
GT -> case fork_ hr r of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #)
------------------------------------------------
-- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB ka ea tb cs n = rd tb where
rd E = (# cs,n #)
rd (N k l b r) = rd_ k l b r
rd (Z k l b r) = rd_ k l b r
rd (P k l b r) = rd_ k l b r
rd_ k l b r = case compareInt# ka k of
LT -> rd l
EQ -> let c = f ea b in c `seq` (# Cons ka c cs, ((n)+#1#) #)
GT -> rd r
------------------------------------------------
-- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA kb eb ta cs n = rd ta where
rd E = (# cs,n #)
rd (N k l a r) = rd_ k l a r
rd (Z k l a r) = rd_ k l a r
rd (P k l a r) = rd_ k l a r
rd_ k l a r = case compareInt# kb k of
LT -> rd l
EQ -> let c = f a eb in c `seq` (# Cons kb c cs, ((n)+#1#) #)
GT -> rd r
------------------------------------------------
-- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of
(# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_
------------------------------------------------
-- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of
(# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of
(# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of
(# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_
-----------------------------------------------------------------------
-------------------- intersectionIntMap' Ends Here ---------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'intersectionMaybe'.
intersectionMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> IntMap c
intersectionMaybeIntMap f ta0 tb0 = i0 ta0 tb0 where
-- i0 :: IntMap a -> IntMap b -> IntMap c
i0 E _ = E
i0 _ E = E
i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb
i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb
i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb
i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb
i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb
i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb
i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb
i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb
i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb
-- iH :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IntMap c
iH hta ta htb tb = case i hta ta htb tb Empt 0# of
(# ial,n #) -> case subst (rep (I# (n))) ial of
(# imp,rm #) -> case rm of
Empt -> imp
_ -> error (mErr ++ "intersectionMaybeIntMap: Bad IAList.")
-- i :: Int# -> IntMap a -> -- 1st IntMap with height
-- Int# -> IntMap b -> -- 2nd IntMap with height
-- IAList c -> Int# -> -- Input IAList with length
-- (# IAList c, Int# #) -- Output IAList with length
------------------------------------------------
i 0# _ _ _ cs n = (# cs,n #)
i _ _ 0# _ cs n = (# cs,n #)
------------------------------------------------
i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then case f ea eb of
Just c -> (# Cons ka c cs, ((n)+#1#) #)
Nothing -> (# cs,n #)
else (# cs,n #)
i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n
i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n
------------------------------------------------
i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n
i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n
i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n
i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n
------------------------------------------------
-- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1
i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n
i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n
i _ _ _ _ _ _ = error (mErr ++ "intersectionMaybeIntMap: Bad IntMap.")
------------------------------------------------
i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case fork kb hra ra of
(# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra)
(# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb)
-- (la + llb) < ka < (rla + lrb) < kb < (rra + rb)
(# cs_,n_ #) -> case (case mbb of
Nothing -> i hrla rla hlrb lrb cs_ n_
Just b -> case f ea b of
Just c -> i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#)
Nothing -> i hrla rla hlrb lrb cs_ n_
) of
(# cs__,n__ #) -> case mba of
Nothing -> i hla la hllb llb cs__ n__
Just a -> case f a eb of
Just c -> i hla la hllb llb (Cons kb c cs__) ((n__)+#1#)
Nothing -> i hla la hllb llb cs__ n__
-- ka = kb
EQ -> case i hra ra hrb rb cs n of
(# cs_,n_ #) -> case f ea eb of
Just c -> i hla la hlb lb (Cons ka c cs_) ((n_)+#1#)
Nothing -> i hla la hlb lb cs_ n_
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case fork ka hrb rb of
(# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb)
(# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka)
-- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb)
(# cs_,n_ #) -> case (case mba of
Nothing -> i hlra lra hrlb rlb cs_ n_
Just a -> case f a eb of
Just c -> i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#)
Nothing -> i hlra lra hrlb rlb cs_ n_
) of
(# cs__,n__ #) -> case mbb of
Nothing -> i hlla lla hlb lb cs__ n__
Just b -> case f ea b of
Just c -> i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#)
Nothing -> i hlla lla hlb lb cs__ n__
------------------------------------------------
-- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #)
-- Tree height (ht) is known to be >= 1, can we exploit this ??
fork k0 ht t = fork_ ht t where
fork_ h E = (# h,E,Nothing,h,E #)
fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r
fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r
fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r
fork__ k hl l x hr r = case compareInt# k0 k of
LT -> case fork_ hl l of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of
(# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #)
EQ -> (# hl,l,Just x,hr,r #)
GT -> case fork_ hr r of
(# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of
(# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #)
------------------------------------------------
-- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB ka ea tb cs n = rd tb where
rd E = (# cs,n #)
rd (N k l b r) = rd_ k l b r
rd (Z k l b r) = rd_ k l b r
rd (P k l b r) = rd_ k l b r
rd_ k l b r = case compareInt# ka k of
LT -> rd l
EQ -> case f ea b of
Just c -> (# Cons ka c cs, ((n)+#1#) #)
Nothing -> (# cs,n #)
GT -> rd r
------------------------------------------------
-- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA kb eb ta cs n = rd ta where
rd E = (# cs,n #)
rd (N k l a r) = rd_ k l a r
rd (Z k l a r) = rd_ k l a r
rd (P k l a r) = rd_ k l a r
rd_ k l a r = case compareInt# kb k of
LT -> rd l
EQ -> case f a eb of
Just c -> (# Cons kb c cs, ((n)+#1#) #)
Nothing -> (# cs,n #)
GT -> rd r
------------------------------------------------
-- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of
(# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_
------------------------------------------------
-- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of
(# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #)
lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of
(# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_
------------------------------------------------
-- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #)
lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of
(# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_
-----------------------------------------------------------------------
----------------- intersectionMaybeIntMap Ends Here --------------------
-----------------------------------------------------------------------
-- AVL template, output of rep
data Tmp = ET | NT Tmp Tmp | ZT Tmp Tmp | PT Tmp Tmp
-- Construct a template of size n (n>=0). This is for internal use only.
-- N.B. Uses regular (boxed) Ints. Optimising for unboxed Ints is just too painful in this case.
-- Hopefully the compiler will do a decent job for us...???
rep :: Int -> Tmp
rep n | odd n = repOdd n -- n is odd , >=1
rep n = repEvn n -- n is even, >=0
-- n is known to be odd (>=1), so left and right sub-trees are identical
repOdd :: Int -> Tmp
repOdd n = let sub = rep (n `shiftR` 1) in ZT sub sub
-- n is known to be even (>=0)
repEvn :: Int -> Tmp
repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too
repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even)
nr = nl - 1 -- size of right subtree (even or odd)
in if odd nr
then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2)
r = repOdd nr
in l `seq` r `seq` ZT l r
else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2)
r = repEvn nr
in l `seq` r `seq` ZT l r
-- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16..
repP2 :: Int -> Tmp
repP2 0 = ET
repP2 1 = ZT ET ET
repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2
nr = nl - 1 -- nr is one less that an exact power of 2
l = repP2 nl
r = repP2M1 nr
in l `seq` r `seq` PT l r -- BF=+1
-- n is one less than an exact power of 2, I.E. 0,1,3,7,15..
repP2M1 :: Int -> Tmp
repP2M1 0 = ET
repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` ZT sub sub
-- Substitute template values for real values taken from the IAList. This is for internal use only.
-- Length of IAList should match Template size
subst :: Tmp -> IAList a -> (# IntMap a, IAList a #)
subst ET as = (# E,as #)
subst (NT l r) as = subst_ N l r as
subst (ZT l r) as = subst_ Z l r as
subst (PT l r) as = subst_ P l r as
subst_ :: (Key -> IntMap a -> a -> IntMap a -> IntMap a) -> Tmp -> Tmp -> IAList a -> (# IntMap a, IAList a #)
{-# INLINE subst_ #-}
subst_ c l r as = case subst l as of
(# l_,as_ #) -> case as_ of
Cons ka a as__ -> case subst r as__ of
(# r_,as___ #) -> let t = c ka l_ a r_
in t `seq` (# t,as___ #)
Empt -> error (mErr ++ "subst: List too short.")
-- | See 'Map' class method 'difference'.
differenceIntMap :: IntMap a -> IntMap b -> IntMap a
differenceIntMap ta0 tb0 = d0 ta0 tb0 where
d0 E _ = E
d0 _ E = ta0
d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here!
d0 (Z _ la _ _ ) _ = dH (addHeight 1# la)
d0 (P _ _ _ ra) _ = dH (addHeight 2# ra)
dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t
-- d :: Int# -> IntMap a -> -- 1st IntMap with height
-- IntMap b -> -- 2nd IntMap (without height)
-- (# Int#,IntMap a #) -- Output IntMap with height
------------------------------------------------
d ha E _ = (# E ,ha #) -- Relative heights!!
d ha ta E = (# ta,ha #)
d ha (N ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb
d ha (N ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb
d ha (N ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb
d ha (Z ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb
d ha (Z ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb
d ha (Z ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb
d ha (P ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb
d ha (P ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb
d ha (P ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb
d_ ka hla la a hra ra kb lb rb =
case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case fork hra ra kb of
(# hrla,rla,hrra,rra #) -> case spliceH ka la hla a rla hrla of
(# la_,hla_ #) -> case d hla_ la_ lb of
(# l,hl #) -> case d hrra rra rb of
(# r,hr #) -> joinH l hl r hr
-- ka = kb
EQ -> case d hra ra rb of -- right
(# r,hr #) -> case d hla la lb of -- left
(# l,hl #) -> joinH l hl r hr
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case fork hla la kb of
(# hlla,lla,hlra,lra #) -> case spliceH ka lra hlra a ra hra of
(# ra_,hra_ #) -> case d hra_ ra_ rb of
(# r,hr #) -> case d hlla lla lb of
(# l,hl #) -> joinH l hl r hr
-- fork :: Int# -> IntMap a -> Key -> (# Int#, IntMap a, Int#, IntMap a #)
fork hta ta kb = fork_ hta ta where
fork_ h E = (# h,E,h,E #) -- Relative heights!!
fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r
fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r
fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r
fork__ k hl l a hr r = case compareInt# k kb of
LT -> case fork_ hr r of
(# hx0,x0,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of
(# x0_,hx0_ #) -> (# hx0_,x0_,hx1,x1 #)
EQ -> (# hl,l,hr,r #) -- (k,a) is dropped.
GT -> case fork_ hl l of
(# hx0,x0,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of
(# x1_,hx1_ #) -> (# hx0,x0,hx1_,x1_ #)
-----------------------------------------------------------------------
--------------------- differenceIntMap Ends Here -----------------------
-----------------------------------------------------------------------
-- | See 'Map' class method 'differenceMaybe'.
differenceMaybeIntMap :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
differenceMaybeIntMap f ta0 tb0 = d0 ta0 tb0 where
d0 E _ = E
d0 _ E = ta0
d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here!
d0 (Z _ la _ _ ) _ = dH (addHeight 1# la)
d0 (P _ _ _ ra) _ = dH (addHeight 2# ra)
dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t
-- d :: Int# -> IntMap a -> -- 1st IntMap with height
-- IntMap b -> -- 2nd IntMap (without height)
-- (# Int#,IntMap a #) -- Output IntMap with height
------------------------------------------------
d ha E _ = (# E ,ha #) -- Relative heights!!
d ha ta E = (# ta,ha #)
d ha (N ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb
d ha (N ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb
d ha (N ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb
d ha (Z ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb
d ha (Z ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb
d ha (Z ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb
d ha (P ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb
d ha (P ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb
d ha (P ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb
d_ ka hla la a hra ra kb lb b rb =
case compareInt# ka kb of
-- ka < kb, so (la < ka < kb) & (ka < kb < rb)
LT -> case fork hra ra kb b of
(# hrla,rla,mba,hrra,rra #) -> case spliceH ka la hla a rla hrla of
(# la_,hla_ #) -> case d hla_ la_ lb of
(# l,hl #) -> case d hrra rra rb of
(# r,hr #) -> case mba of
Nothing -> joinH l hl r hr
Just a' -> spliceH kb l hl a' r hr
-- ka = kb
EQ -> case d hra ra rb of -- right
(# r,hr #) -> case d hla la lb of -- left
(# l,hl #) -> case f a b of
Nothing -> joinH l hl r hr
Just a' -> spliceH kb l hl a' r hr
-- kb < ka, so (lb < kb < ka) & (kb < ka < ra)
GT -> case fork hla la kb b of
(# hlla,lla,mba,hlra,lra #) -> case spliceH ka lra hlra a ra hra of
(# ra_,hra_ #) -> case d hra_ ra_ rb of
(# r,hr #) -> case d hlla lla lb of
(# l,hl #) -> case mba of
Nothing -> joinH l hl r hr
Just a' -> spliceH kb l hl a' r hr
-- fork :: Int# -> IntMap a -> Key -> b -> (# Int#, IntMap a, Maybe a, Int#, IntMap a #)
fork hta ta kb b = fork_ hta ta where
fork_ h E = (# h,E,Nothing,h,E #) -- Relative heights!!
fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r
fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r
fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r
fork__ k hl l a hr r = case compareInt# k kb of
LT -> case fork_ hr r of
(# hx0,x0,mba,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of
(# x0_,hx0_ #) -> (# hx0_,x0_,mba,hx1,x1 #)
EQ -> let mba = f a b in mba `seq` (# hl,l,mba,hr,r #)
GT -> case fork_ hl l of
(# hx0,x0,mba,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of
(# x1_,hx1_ #) -> (# hx0,x0,mba,hx1_,x1_ #)
-----------------------------------------------------------------------
------------------ differenceMaybeIntMap Ends Here ---------------------
-----------------------------------------------------------------------
-- | Join two IntMaps of known height, returning an IntMap of known height.
-- It_s OK if heights are relative (I.E. if they share same fixed offset).
--
-- Complexity: O(d), where d is the absolute difference in tree heights.
joinH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #)
joinH l hl r hr =
case compareInt# hl hr of
-- hr > hl
LT -> case l of
E -> (# r,hr #)
N li ll la lr -> case popRN li ll la lr of
(# l_,iv,v #) -> case l_ of
Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1
_ -> spliceHL iv l_ hl v r hr -- dH= 0
Z li ll la lr -> case popRZ li ll la lr of
(# l_,iv,v #) -> case l_ of
E -> pushHL l r hr -- l had only 1 element
_ -> spliceHL iv l_ hl v r hr -- dH=0
P li ll la lr -> case popRP li ll la lr of
(# l_,iv,v #) -> case l_ of
Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1
_ -> spliceHL iv l_ hl v r hr -- dH= 0
-- hr = hl
EQ -> case l of
E -> (# l,hl #) -- r must be empty too
N li ll la lr -> case popRN li ll la lr of
(# l_,iv,v #) -> case l_ of
Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1
_ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0
Z li ll la lr -> case popRZ li ll la lr of
(# l_,iv,v #) -> case l_ of
E -> pushHL l r hr -- l had only 1 element
_ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0
P li ll la lr -> case popRP li ll la lr of
(# l_,iv,v #) -> case l_ of
Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1
_ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0
-- hl > hr
GT -> case r of
E -> (# l,hl #)
N ri rl ra rr -> case popLN ri rl ra rr of
(# iv,v,r_ #) -> case r_ of
Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1
_ -> spliceHR iv l hl v r_ hr -- dH= 0
Z ri rl ra rr -> case popLZ ri rl ra rr of
(# iv,v,r_ #) -> case r_ of
E -> pushHR l hl r -- r had only 1 element
_ -> spliceHR iv l hl v r_ hr -- dH=0
P ri rl ra rr -> case popLP ri rl ra rr of
(# iv,v,r_ #) -> case r_ of
Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1
_ -> spliceHR iv l hl v r_ hr -- dH= 0
-- | Splice two IntMaps of known height using the supplied bridging association pair.
-- That is, the bridging pair appears \"in the middle\" of the resulting IntMap.
-- The pairs of the first tree argument are to the left of the bridging pair and
-- the pairs of the second tree are to the right of the bridging pair.
--
-- This function does not require that the IntMap heights are absolutely correct, only that
-- the difference in supplied heights is equal to the difference in actual heights. So it_s
-- OK if the input heights both have the same unknown constant offset. (The output height
-- will also have the same constant offset in this case.)
--
-- Complexity: O(d), where d is the absolute difference in tree heights.
spliceH :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)
-- You_d think inlining this function would make a significant difference to many functions
-- (such as set operations), but it doesn_t. It makes them marginally slower!!
spliceH ib l hl b r hr =
case compareInt# hl hr of
LT -> spliceHL ib l hl b r hr
EQ -> (# Z ib l b r, ((hl)+#1#) #)
GT -> spliceHR ib l hl b r hr
-----------------------------------------------------------------------
----------------------------- spliceHL --------------------------------
-----------------------------------------------------------------------
-- Splice tree s into the left edge of tree t (where ht>hs) using the supplied bridging pair (ib,b),
-- returning another tree of known relative height.
spliceHL :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)
spliceHL ib s hs b t ht = let d = ((ht)-#(hs))
in if d ==# 1# then (# N ib s b t, ((ht)+#1#) #)
else sHL ht d t
where -- s, ib and b are free
-- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element,
-- returning another tree of known relative height. d >= 2
{-# INLINE sHL #-}
sHL _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl
sHL hr d (N ri rl ra rr) = let r_ = sLN ((d)-#2#) ri rl ra rr
in r_ `seq` (# r_,hr #)
sHL hr d (Z ri rl ra rr) = let r_ = sLZ ((d)-#1#) ri rl ra rr
in case r_ of
E -> error "spliceHL: Bug1"
Z _ _ _ _ -> (# r_, hr #)
_ -> (# r_,((hr)+#1#) #)
sHL hr d (P ri rl ra rr) = let r_ = sLP ((d)-#1#) ri rl ra rr
in r_ `seq` (# r_,hr #)
-- Splice into left subtree of (N i l a r), height cannot change as a result of this
sLN 0# i l a r = Z i (Z ib s b l) a r -- dH=0
sLN 1# i l a r = Z i (N ib s b l) a r -- dH=0
sLN d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` N i l_ a r
sLN d i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr
in case l_ of
Z _ _ _ _ -> N i l_ a r -- dH=0
P _ _ _ _ -> Z i l_ a r -- dH=0
_ -> error "spliceHL: Bug2" -- impossible
sLN d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` N i l_ a r
sLN _ _ E _ _ = error "spliceHL: Bug3" -- impossible
-- Splice into left subtree of (Z i l a r), Z->P if dH=1, Z->Z if dH=0
sLZ 1# i l a r = P i (N ib s b l) a r -- Z->P, dH=1
sLZ d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0
sLZ d i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr
in case l_ of
Z _ _ _ _ -> Z i l_ a r -- Z->Z, dH=0
P _ _ _ _ -> P i l_ a r -- Z->P, dH=1
_ -> error "spliceHL: Bug4" -- impossible
sLZ d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0
sLZ _ _ E _ _ = error "spliceHL: Bug5" -- impossible
-- Splice into left subtree of (P i l a r), height cannot change as a result of this
sLP 1# i (N li ll la lr) a r = Z li (P ib s b ll) la (Z i lr a r) -- dH=0
sLP 1# i (Z li ll la lr) a r = Z li (Z ib s b ll) la (Z i lr a r) -- dH=0
sLP 1# i (P li ll la lr) a r = Z li (Z ib s b ll) la (N i lr a r) -- dH=0
sLP d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` P i l_ a r -- dH=0
sLP d i (Z li ll la lr) a r = sLPZ ((d)-#1#) i li ll la lr a r -- dH=0
sLP d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` P i l_ a r -- dH=0
sLP _ _ E _ _ = error "spliceHL: Bug6"
-- Splice into left subtree of (P i (Z li ll la lr) a r)
{-# INLINE sLPZ #-}
sLPZ 1# i li ll la lr a r = Z li (N ib s b ll) la (Z i lr a r) -- dH=0
sLPZ d i li (N lli lll lle llr) la lr a r = let ll_ = sLN ((d)-#2#) lli lll lle llr -- dH=0
in ll_ `seq` P i (Z li ll_ la lr) a r
sLPZ d i li (Z lli lll lle llr) la lr a r = let ll_ = sLZ ((d)-#1#) lli lll lle llr -- dH=0
in case ll_ of
Z _ _ _ _ -> P i (Z li ll_ la lr) a r -- dH=0
P _ _ _ _ -> Z li ll_ la (Z i lr a r) -- dH=0
_ -> error "spliceHL: Bug7" -- impossible
sLPZ d i li (P lli lll lle llr) la lr a r = let ll_ = sLP ((d)-#1#) lli lll lle llr -- dH=0
in ll_ `seq` P i (Z li ll_ la lr) a r
sLPZ _ _ _ E _ _ _ _ = error "spliceHL: Bug8"
-----------------------------------------------------------------------
------------------------- spliceHL Ends Here --------------------------
-----------------------------------------------------------------------
-----------------------------------------------------------------------
----------------------------- spliceHR --------------------------------
-----------------------------------------------------------------------
-- Splice tree t into the right edge of tree s (where hs>ht) using the supplied bridging pair (ib,b),
-- returning another tree of known relative height.
spliceHR :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #)
spliceHR ib s hs b t ht = let d = ((hs)-#(ht))
in if d ==# 1# then (# P ib s b t, ((hs)+#1#) #)
else sHR hs d s
where -- t, ib and b are free
{-# INLINE sHR #-}
sHR _ _ E = error "spliceHL: Bug0" -- impossible if hl>hr
sHR hl d (N li ll la lr) = let l_ = sRN ((d)-#1#) li ll la lr
in l_ `seq` (# l_,hl #)
sHR hl d (Z li ll la lr) = let l_ = sRZ ((d)-#1#) li ll la lr
in case l_ of
E -> error "spliceHL: Bug1"
Z _ _ _ _ -> (# l_, hl #)
_ -> (# l_,((hl)+#1#) #)
sHR hl d (P li ll la lr) = let l_ = sRP ((d)-#2#) li ll la lr
in l_ `seq` (# l_,hl #)
-- Splice into right subtree of (P i l a r), height cannot change as a result of this
sRP 0# i l a r = Z i l a (Z ib r b t) -- dH=0
sRP 1# i l a r = Z i l a (P ib r b t) -- dH=0
sRP d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` P i l a r_
sRP d i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr
in case r_ of
Z _ _ _ _ -> P i l a r_ -- dH=0
N _ _ _ _ -> Z i l a r_ -- dH=0
_ -> error "spliceHL: Bug2" -- impossible
sRP d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` P i l a r_
sRP _ _ _ _ E = error "spliceHL: Bug3" -- impossible
-- Splice into right subtree of (Z i l a r), Z->N if dH=1, Z->Z if dH=0
sRZ 1# i l a r = N i l a (P ib r b t) -- Z->N, dH=1
sRZ d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0
sRZ d i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr
in case r_ of
Z _ _ _ _ -> Z i l a r_ -- Z->Z, dH=0
N _ _ _ _ -> N i l a r_ -- Z->N, dH=1
_ -> error "spliceHL: Bug4" -- impossible
sRZ d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0
sRZ _ _ _ _ E = error "spliceHL: Bug5" -- impossible
-- Splice into right subtree of (N i l a r), height cannot change as a result of this
sRN 1# i l a (N ri rl ra rr) = Z ri (P i l a rl) ra (Z ib rr b t) -- dH=0
sRN 1# i l a (Z ri rl ra rr) = Z ri (Z i l a rl) ra (Z ib rr b t) -- dH=0
sRN 1# i l a (P ri rl ra rr) = Z ri (Z i l a rl) ra (N ib rr b t) -- dH=0
sRN d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0
sRN d i l a (Z ri rl ra rr) = sRNZ ((d)-#1#) i l a ri rl ra rr -- dH=0
sRN d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0
sRN _ _ _ _ E = error "spliceHL: Bug6"
-- Splice into right subtree of (N i l a (Z ri rl ra rr))
{-# INLINE sRNZ #-}
sRNZ 1# i l a ri rl ra rr = Z ri (Z i l a rl) ra (P ib rr b t) -- dH=0
sRNZ d i l a ri rl ra (N rri rrl rre rrr) = let rr_ = sRN ((d)-#1#) rri rrl rre rrr
in rr_ `seq` N i l a (Z ri rl ra rr_) -- dH=0
sRNZ d i l a ri rl ra (Z rri rrl rre rrr) = let rr_ = sRZ ((d)-#1#) rri rrl rre rrr -- dH=0
in case rr_ of
Z _ _ _ _ -> N i l a (Z ri rl ra rr_) -- dH=0
N _ _ _ _ -> Z ri (Z i l a rl) ra rr_ -- dH=0
_ -> error "spliceHL: Bug7" -- impossible
sRNZ d i l a ri rl ra (P rri rrl rre rrr) = let rr_ = sRP ((d)-#2#) rri rrl rre rrr -- dH=0
in rr_ `seq` N i l a (Z ri rl ra rr_)
sRNZ _ _ _ _ _ _ _ E = error "spliceHL: Bug8"
-----------------------------------------------------------------------
------------------------- spliceHR Ends Here --------------------------
-----------------------------------------------------------------------
-- | Push a singleton IntMap to the leftmost position of an IntMap of known height.
-- Returns an IntMap of known height.
-- It_s OK if height is relative, with fixed offset. In this case the height of the result
-- will have the same fixed offset.
pushHL :: IntMap a -> IntMap a -> Int# -> (# IntMap a,Int# #)
pushHL t0 t h = case t of
E -> (# t0, ((h)+#1#) #) -- Relative Heights
N i l a r -> let t_ = potNL i l a r in t_ `seq` (# t_,h #)
P i l a r -> let t_ = potPL i l a r in t_ `seq` (# t_,h #)
Z i l a r -> let t_ = potZL i l a r
in case t_ of
Z _ _ _ _ -> (# t_, h #)
P _ _ _ _ -> (# t_, ((h)+#1#) #)
_ -> error "pushHL: Bug0" -- impossible
where
----------------------------- LEVEL 2 ---------------------------------
-- potNL, potZL, potPL --
-----------------------------------------------------------------------
-- (potNL i l a r): Put t0 in L subtree of (N i l a r), BF=-1 (Never requires rebalancing) , (never returns P)
potNL i E a r = Z i t0 a r -- L subtree empty, H:0->1, parent BF:-1-> 0
potNL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l_ `seq` N i l_ a r
potNL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1
in l_ `seq` N i l_ a r
potNL i (Z li ll la lr) a r = let l_ = potZL li ll la lr -- L subtree BF= 0, so need to look for changes
in case l_ of
Z _ _ _ _ -> N i l_ a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1
P _ _ _ _ -> Z i l_ a r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0
_ -> error "pushHL: Bug1" -- impossible
-- (potZL i l a r): Put t0 in L subtree of (Z i l a r), BF= 0 (Never requires rebalancing) , (never returns N)
potZL i E a r = P i t0 a r -- L subtree H:0->1, parent BF: 0->+1
potZL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l_ `seq` Z i l_ a r
potZL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0
in l_ `seq` Z i l_ a r
potZL i (Z li ll la lr) a r = let l_ = potZL li ll la lr -- L subtree BF= 0, so need to look for changes
in case l_ of
Z _ _ _ _ -> Z i l_ a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
N _ _ _ _ -> error "pushHL: Bug2" -- impossible
_ -> P i l_ a r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1
-------- This case (PL) may need rebalancing if it goes to LEVEL 3 ---------
-- (potPL i l a r): Put t0 in L subtree of (P i l a r), BF=+1 , (never returns N)
potPL _ E _ _ = error "pushHL: Bug3" -- impossible if BF=+1
potPL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l_ `seq` P i l_ a r
potPL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1
in l_ `seq` P i l_ a r
potPL i (Z li ll la lr) a r = potPLL i li ll la lr a r -- LL (never returns N)
----------------------------- LEVEL 3 ---------------------------------
-- potPLL --
-----------------------------------------------------------------------
-- (potPLL i li ll la lr a r): Put t0 in LL subtree of (P i (Z li ll la lr) a r) , (never returns N)
{-# INLINE potPLL #-}
potPLL i li E la lr a r = Z li t0 la (Z i lr a r) -- r and lr must also be E, special CASE LL!!
potPLL i li (N lli lll lla llr) la lr a r = let ll_ = potNL lli lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll_ `seq` P i (Z li ll_ la lr) a r
potPLL i li (P lli lll lla llr) la lr a r = let ll_ = potPL lli lll lla llr -- LL subtree BF<>0, H:h->h, so no change
in ll_ `seq` P i (Z li ll_ la lr) a r
potPLL i li (Z lli lll lla llr) la lr a r = let ll_ = potZL lli lll lla llr -- LL subtree BF= 0, so need to look for changes
in case ll_ of
Z _ _ _ _ -> P i (Z li ll_ la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change
N _ _ _ _ -> error "pushHL: Bug4" -- impossible
_ -> Z li ll_ la (Z i lr a r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !!
-----------------------------------------------------------------------
-------------------------- pushHL Ends Here ---------------------------
-----------------------------------------------------------------------
-- | Push a singleton IntMap to the rightmost position of an IntMap of known height.
-- Returns an IntMap of known height.
-- It_s OK if height is relative, with fixed offset. In this case the height of the result
-- will have the same fixed offset.
pushHR :: IntMap a -> Int# -> IntMap a -> (# IntMap a,Int# #)
pushHR t h t0 = case t of
E -> (# t0, ((h)+#1#) #) -- Relative Heights
N i l a r -> let t_ = potNR i l a r in t_ `seq` (# t_,h #)
P i l a r -> let t_ = potPR i l a r in t_ `seq` (# t_,h #)
Z i l a r -> let t_ = potZR i l a r
in case t_ of
Z _ _ _ _ -> (# t_, h #)
N _ _ _ _ -> (# t_, ((h)+#1#) #)
_ -> error "pushHR: Bug0" -- impossible
where
----------------------------- LEVEL 2 ---------------------------------
-- potNR, potZR, potPR --
-----------------------------------------------------------------------
-- (potZR i l a r): Put t0 in R subtree of (Z i l a r), BF= 0 (Never requires rebalancing) , (never returns P)
potZR i l a E = N i l a t0 -- R subtree H:0->1, parent BF: 0->-1
potZR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r_ `seq` Z i l a r_
potZR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0
in r_ `seq` Z i l a r_
potZR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr -- R subtree BF= 0, so need to look for changes
in case r_ of
Z _ _ _ _ -> Z i l a r_ -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0
N _ _ _ _ -> N i l a r_ -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1
_ -> error "pushHR: Bug1" -- impossible
-- (potPR i l a r): Put t0 in R subtree of (P i l a r), BF=+1 (Never requires rebalancing) , (never returns N)
potPR i l a E = Z i l a t0 -- R subtree empty, H:0->1, parent BF:+1-> 0
potPR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r_ `seq` P i l a r_
potPR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1
in r_ `seq` P i l a r_
potPR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr -- R subtree BF= 0, so need to look for changes
in case r_ of
Z _ _ _ _ -> P i l a r_ -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1
N _ _ _ _ -> Z i l a r_ -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0
_ -> error "pushHR: Bug2" -- impossible
-------- This case (NR) may need rebalancing if it goes to LEVEL 3 ---------
-- (potNR i l a r): Put t0 in R subtree of (N i l a r), BF=-1 , (never returns P)
potNR _ _ _ E = error "pushHR: Bug3" -- impossible if BF=-1
potNR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r_ `seq` N i l a r_
potNR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1
in r_ `seq` N i l a r_
potNR i l a (Z ri rl ra rr) = potNRR i l a ri rl ra rr -- RR (never returns P)
----------------------------- LEVEL 3 ---------------------------------
-- potNRR --
-----------------------------------------------------------------------
-- (potNRR i l a ri rl ra rr): Put t0 in RR subtree of (N i l a (Z ri rl ra rr)) , (never returns P)
{-# INLINE potNRR #-}
potNRR i l a ri rl ra E = Z ri (Z i l a rl) ra t0 -- l and rl must also be E, special CASE RR!!
potNRR i l a ri rl ra (N rri rrl rra rrr) = let rr_ = potNR rri rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr_ `seq` N i l a (Z ri rl ra rr_)
potNRR i l a ri rl ra (P rri rrl rra rrr) = let rr_ = potPR rri rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change
in rr_ `seq` N i l a (Z ri rl ra rr_)
potNRR i l a ri rl ra (Z rri rrl rra rrr) = let rr_ = potZR rri rrl rra rrr -- RR subtree BF= 0, so need to look for changes
in case rr_ of
Z _ _ _ _ -> N i l a (Z ri rl ra rr_) -- RR subtree BF: 0-> 0, H:h->h, so no change
N _ _ _ _ -> Z ri (Z i l a rl) ra rr_ -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !!
_ -> error "pushHR: Bug4" -- impossible
-----------------------------------------------------------------------
-------------------------- pushHR Ends Here ---------------------------
-----------------------------------------------------------------------
-- | Delete the association pair with the supplied Key from an IntMap.
-- For use only if it is already known to contain an entry for the supplied key.
-- This function raises an error if there is no such pair.
del :: Key -> IntMap a -> IntMap a
del _ E = error "del: Key not found."
del k0 (N k l a r) = delN k0 k l a r
del k0 (Z k l a r) = delZ k0 k l a r
del k0 (P k l a r) = delP k0 k l a r
-- | Same as 'del', but takes the (relative) tree height as an extra argument and
-- returns the updated (relative) tree height.
delH :: Key -> Int# -> IntMap a -> (# IntMap a,Int# #)
delH _ _ E = error "delH: Key not found."
delH k0 ht (N k l a r) = let t_ = delN k0 k l a r in
case t_ of
Z _ _ _ _ -> (# t_,((ht)-#1#) #)
_ -> (# t_, ht #)
delH k0 ht (Z k l a r) = let t_ = delZ k0 k l a r in
case t_ of
E -> (# t_,((ht)-#1#) #)
_ -> (# t_, ht #)
delH k0 ht (P k l a r) = let t_ = delP k0 k l a r in
case t_ of
Z _ _ _ _ -> (# t_,((ht)-#1#) #)
_ -> (# t_, ht #)
----------------------------- LEVEL 1 ---------------------------------
-- delN, delZ, delP --
-----------------------------------------------------------------------
-- Delete from (N k l a r)
delN :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delN k0 k l a r = case compareInt# k0 k of
LT -> delNL k0 k l a r
EQ -> subN l r
GT -> delNR k0 k l a r
-- Delete from (Z k l a r)
delZ :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delZ k0 k l a r = case compareInt# k0 k of
LT -> delZL k0 k l a r
EQ -> subZR l r
GT -> delZR k0 k l a r
-- Delete from (P k l a r)
delP :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delP k0 k l a r = case compareInt# k0 k of
LT -> delPL k0 k l a r
EQ -> subP l r
GT -> delPR k0 k l a r
----------------------------- LEVEL 2 ---------------------------------
-- delNL, delZL, delPL --
-- delNR, delZR, delPR --
-----------------------------------------------------------------------
-- Delete from the left subtree of (N k l a r)
delNL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delNL _ _ E _ _ = error "assertDelete: Key not found." -- Left sub-tree is empty
delNL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLN k (delNL k0 lk ll la lr) a r
EQ -> chkLN k (subN ll lr) a r
GT -> chkLN k (delNR k0 lk ll la lr) a r
delNL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of
LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` N k l_ a r -- height can't change
EQ -> chkLN_ k (subZR ll lr) a r -- << But it can here
GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` N k l_ a r -- height can't change
delNL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLN k (delPL k0 lk ll la lr) a r
EQ -> chkLN k (subP ll lr) a r
GT -> chkLN k (delPR k0 lk ll la lr) a r
-- Delete from the right subtree of (N k l a r)
delNR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delNR _ _ _ _ E = error "delNR: Bug0" -- Impossible
delNR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRN k l a (delNL k0 rk rl ra rr)
EQ -> chkRN k l a (subN rl rr)
GT -> chkRN k l a (delNR k0 rk rl ra rr)
delNR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of
LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` N k l a r_ -- height can't change
EQ -> chkRN_ k l a (subZL rl rr) -- << But it can here
GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` N k l a r_ -- height can't change
delNR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRN k l a (delPL k0 rk rl ra rr)
EQ -> chkRN k l a (subP rl rr)
GT -> chkRN k l a (delPR k0 rk rl ra rr)
-- Delete from the left subtree of (Z k l a r)
delZL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delZL _ _ E _ _ = error "assertDelete: Key not found." -- Left sub-tree is empty
delZL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLZ k (delNL k0 lk ll la lr) a r
EQ -> chkLZ k (subN ll lr) a r
GT -> chkLZ k (delNR k0 lk ll la lr) a r
delZL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of
LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` Z k l_ a r -- height can't change
EQ -> chkLZ_ k (subZR ll lr) a r -- << But it can here
GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` Z k l_ a r -- height can't change
delZL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLZ k (delPL k0 lk ll la lr) a r
EQ -> chkLZ k (subP ll lr) a r
GT -> chkLZ k (delPR k0 lk ll la lr) a r
-- Delete from the right subtree of (Z k l a r)
delZR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delZR _ _ _ _ E = error "assertDelete: Key not found." -- Right sub-tree is empty
delZR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRZ k l a (delNL k0 rk rl ra rr)
EQ -> chkRZ k l a (subN rl rr)
GT -> chkRZ k l a (delNR k0 rk rl ra rr)
delZR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of
LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` Z k l a r_ -- height can't change
EQ -> chkRZ_ k l a (subZL rl rr) -- << But it can here
GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` Z k l a r_ -- height can't change
delZR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRZ k l a (delPL k0 rk rl ra rr)
EQ -> chkRZ k l a (subP rl rr)
GT -> chkRZ k l a (delPR k0 rk rl ra rr)
-- Delete from the left subtree of (P k l a r)
delPL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delPL _ _ E _ _ = error "delPL: Bug0" -- Impossible
delPL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLP k (delNL k0 lk ll la lr) a r
EQ -> chkLP k (subN ll lr) a r
GT -> chkLP k (delNR k0 lk ll la lr) a r
delPL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of
LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` P k l_ a r -- height can't change
EQ -> chkLP_ k (subZR ll lr) a r -- << But it can here
GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` P k l_ a r -- height can't change
delPL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of
LT -> chkLP k (delPL k0 lk ll la lr) a r
EQ -> chkLP k (subP ll lr) a r
GT -> chkLP k (delPR k0 lk ll la lr) a r
-- Delete from the right subtree of (P l a r)
delPR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a
delPR _ _ _ _ E = error "assertDelete: Key not found." -- Right sub-tree is empty
delPR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRP k l a (delNL k0 rk rl ra rr)
EQ -> chkRP k l a (subN rl rr)
GT -> chkRP k l a (delNR k0 rk rl ra rr)
delPR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of
LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` P k l a r_ -- height can't change
EQ -> chkRP_ k l a (subZL rl rr) -- << But it can here
GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` P k l a r_ -- height can't change
delPR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of
LT -> chkRP k l a (delPL k0 rk rl ra rr)
EQ -> chkRP k l a (subP rl rr)
GT -> chkRP k l a (delPR k0 rk rl ra rr)
-----------------------------------------------------------------------
------------------------- del/delH End Here ---------------------------
-----------------------------------------------------------------------
-----------------------------------------------------------------------
------------------------ popL Starts Here -----------------------------
-----------------------------------------------------------------------
-------------------------- popL LEVEL 1 -------------------------------
-- popLN, popLZ, popLP --
-----------------------------------------------------------------------
-- Delete leftmost from (N k l a r)
popLN :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLN k E a r = (# k,a,r #) -- Terminal case, r must be of form (Z a ra E)
popLN k (N lk ll la lr) a r = case popLN lk ll la lr of
(# iv,v,l #) -> let t = chkLN k l a r in t `seq` (# iv,v,t #)
popLN k (Z lk ll la lr) a r = popLNZ k lk ll la lr a r
popLN k (P lk ll la lr) a r = case popLP lk ll la lr of
(# iv,v,l #) -> let t = chkLN k l a r in t `seq` (# iv,v,t #)
-- Delete leftmost from (Z k l a r)
popLZ :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLZ k E a _ = (# k,a,E #) -- Terminal case, r must be E
popLZ k (N lk ll la lr) a r = popLZN k lk ll la lr a r
popLZ k (Z lk ll la lr) a r = popLZZ k lk ll la lr a r
popLZ k (P lk ll la lr) a r = popLZP k lk ll la lr a r
-- Delete leftmost from (P k l a r)
popLP :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLP _ E _ _ = error "popLP: Bug!" -- Impossible if BF=+1
popLP k (N lk ll la lr) a r = case popLN lk ll la lr of
(# iv,v,l #) -> let t = chkLP k l a r in t `seq` (# iv,v,t #)
popLP k (Z lk ll la lr) a r = popLPZ k lk ll la lr a r
popLP k (P lk ll la lr) a r = case popLP lk ll la lr of
(# iv,v,l #) -> let t = chkLP k l a r in t `seq` (# iv,v,t #)
-------------------------- popL LEVEL 2 -------------------------------
-- popLNZ, popLZZ, popLPZ --
-- popLZN, popLZP --
-----------------------------------------------------------------------
-- Delete leftmost from (N k (Z lk ll la lr) a r), height of left sub-tree can't change in this case
popLNZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
{-# INLINE popLNZ #-}
popLNZ k lk E la _ a r = let t = rebalN k E a r -- Terminal case, Needs rebalancing
in t `seq` (# lk,la,t #)
popLNZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,N k l a r #)
popLNZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,N k l a r #)
popLNZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,N k l a r #)
-- Delete leftmost from (Z k (Z lk ll la lr) a r), height of left sub-tree can't change in this case
-- Don't INLINE this!
popLZZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLZZ k lk E la _ a r = (# lk,la,N k E a r #) -- Terminal case
popLZZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,Z k l a r #)
popLZZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,Z k l a r #)
popLZZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,Z k l a r #)
-- Delete leftmost from (P k (Z lk ll la lr) a r), height of left sub-tree can't change in this case
popLPZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
{-# INLINE popLPZ #-}
popLPZ k lk E la _ a _ = (# lk,la,Z k E a E #) -- Terminal case
popLPZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,P k l a r #)
popLPZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,P k l a r #)
popLPZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of
(# iv,v,l #) -> (# iv,v,P k l a r #)
-- Delete leftmost from (Z k (N lk ll la lr) a r)
-- Don't INLINE this!
popLZN :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLZN k lk ll la lr a r = case popLN lk ll la lr of
(# iv,v,l #) -> let t = chkLZ k l a r in t `seq` (# iv,v,t #)
-- Delete leftmost from (Z k (P lk ll la lr) a r)
-- Don't INLINE this!
popLZP :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #)
popLZP k lk ll la lr a r = case popLP lk ll la lr of
(# iv,v,l #) -> let t = chkLZ k l a r in t `seq` (# iv,v,t #)
-----------------------------------------------------------------------
-------------------------- popL Ends Here -----------------------------
-----------------------------------------------------------------------
-----------------------------------------------------------------------
------------------------ popR Starts Here -----------------------------
-----------------------------------------------------------------------
-------------------------- popR LEVEL 1 -------------------------------
-- popRN, popRZ, popRP --
-----------------------------------------------------------------------
-- Delete rightmost from (N k l a r)
popRN :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRN _ _ _ E = error "popRN: Bug!" -- Impossible if BF=-1
popRN k l a (N rk rl ra rr) = case popRN rk rl ra rr of
(# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #)
popRN k l a (Z rk rl ra rr) = popRNZ k l a rk rl ra rr
popRN k l a (P rk rl ra rr) = case popRP rk rl ra rr of
(# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #)
-- Delete rightmost from (Z k l a r)
popRZ :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRZ k _ a E = (# E,k,a #) -- Terminal case, l must be E
popRZ k l a (N rk rl ra rr) = popRZN k l a rk rl ra rr
popRZ k l a (Z rk rl ra rr) = popRZZ k l a rk rl ra rr
popRZ k l a (P rk rl ra rr) = popRZP k l a rk rl ra rr
-- Delete rightmost from (P k l a r)
popRP :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRP k l a E = (# l,k,a #) -- Terminal case, l must be of form (Z a la E)
popRP k l a (N rk rl ra rr) = case popRN rk rl ra rr of
(# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #)
popRP k l a (Z rk rl ra rr) = popRPZ k l a rk rl ra rr
popRP k l a (P rk rl ra rr) = case popRP rk rl ra rr of
(# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #)
-------------------------- popR LEVEL 2 -------------------------------
-- popRNZ, popRZZ, popRPZ --
-- popRZN, popRZP --
-----------------------------------------------------------------------
-- Delete rightmost from (N k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case
popRNZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
{-# INLINE popRNZ #-}
popRNZ k _ a rk _ ra E = (# Z k E a E,rk,ra #) -- Terminal case
popRNZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# N k l a r,iv,v #)
popRNZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# N k l a r,iv,v #)
popRNZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# N k l a r,iv,v #)
-- Delete rightmost from (Z k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case
-- Don't INLINE this!
popRZZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRZZ k l a rk _ ra E = (# P k l a E,rk,ra #) -- Terminal case
popRZZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# Z k l a r,iv,v #)
popRZZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# Z k l a r,iv,v #)
popRZZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# Z k l a r,iv,v #)
-- Delete rightmost from (P k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case
popRPZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
{-# INLINE popRPZ #-}
popRPZ k l a rk _ ra E = let t = rebalP k l a E -- Terminal case, Needs rebalancing
in t `seq` (# t,rk,ra #)
popRPZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# P k l a r,iv,v #)
popRPZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# P k l a r,iv,v #)
popRPZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of
(# r,iv,v #) -> (# P k l a r,iv,v #)
-- Delete rightmost from (Z k l a (N rk rl ra rr))
-- Don't INLINE this!
popRZN :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRZN k l a rk rl ra rr = case popRN rk rl ra rr of
(# r,iv,v #) -> let t = chkRZ k l a r in t `seq` (# t,iv,v #)
-- Delete rightmost from (Z k l a (P rk rl ra rr))
-- Don't INLINE this!
popRZP :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #)
popRZP k l a rk rl ra rr = case popRP rk rl ra rr of
(# r,iv,v #) -> let t = chkRZ k l a r in t `seq` (# t,iv,v #)
-----------------------------------------------------------------------
-------------------------- popR Ends Here -----------------------------
-----------------------------------------------------------------------
{-************************** Balancing Utilities Below Here ************************************-}
-- Rebalance a tree of form (N k l a r) which has become unbalanced as
-- a result of the height of the left sub-tree (l) decreasing by 1.
-- N.B Result is never of form (N _ _ _ _) (or E!)
rebalN :: Key -> IntMap a -> a -> IntMap a -> IntMap a
rebalN _ _ _ E = error "rebalN: Bug0" -- impossible case
rebalN k l a (N rk rl ra rr) = Z rk (Z k l a rl) ra rr -- N->Z, dH=-1
rebalN k l a (Z rk rl ra rr) = P rk (N k l a rl) ra rr -- N->P, dH= 0
rebalN _ _ _ (P _ E _ _ ) = error "rebalN: Bug1" -- impossible case
rebalN k l a (P rk (N rlk rll rla rlr) ra rr) = Z rlk (P k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1
rebalN k l a (P rk (Z rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1
rebalN k l a (P rk (P rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (N rk rlr ra rr) -- N->Z, dH=-1
-- Rebalance a tree of form (P k l a r) which has become unbalanced as
-- a result of the height of the right sub-tree (r) decreasing by 1.
-- N.B Result is never of form (P _ _ _ _) (or E!)
rebalP :: Key -> IntMap a -> a -> IntMap a -> IntMap a
rebalP _ E _ _ = error "rebalP: Bug0" -- impossible case
rebalP k (P lk ll la lr ) a r = Z lk ll la (Z k lr a r) -- P->Z, dH=-1
rebalP k (Z lk ll la lr ) a r = N lk ll la (P k lr a r) -- P->N, dH= 0
rebalP _ (N _ _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case
rebalP k (N lk ll la (P lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (N k lrr a r) -- P->Z, dH=-1
rebalP k (N lk ll la (Z lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1
rebalP k (N lk ll la (N lrk lrl lra lrr)) a r = Z lrk (P lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1
-- Check for height changes in left subtree of (N k l a r),
-- where l was (N lk ll la lr) or (P lk ll la lr)
chkLN :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLN k l a r = case l of
E -> error "chkLN: Bug0" -- impossible if BF<>0
N _ _ _ _ -> N k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> rebalN k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> N k l a r -- BF +/-1 -> +1, so dH= 0
-- Check for height changes in left subtree of (Z k l a r),
-- where l was (N lk ll la lr) or (P lk ll la lr)
chkLZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLZ k l a r = case l of
E -> error "chkLZ: Bug0" -- impossible if BF<>0
N _ _ _ _ -> Z k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> N k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> Z k l a r -- BF +/-1 -> +1, so dH= 0
-- Check for height changes in left subtree of (P k l a r),
-- where l was (N lk ll la lr) or (P lk ll la lr)
chkLP :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLP k l a r = case l of
E -> error "chkLP: Bug0" -- impossible if BF<>0
N _ _ _ _ -> P k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> Z k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> P k l a r -- BF +/-1 -> +1, so dH= 0
-- Check for height changes in right subtree of (N k l a r),
-- where r was (N rk rl ra rr) or (P rk rl ra rr)
chkRN :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRN k l a r = case r of
E -> error "chkRN: Bug0" -- impossible if BF<>0
N _ _ _ _ -> N k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> Z k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> N k l a r -- BF +/-1 -> +1, so dH= 0
-- Check for height changes in right subtree of (Z k l a r),
-- where r was (N rk rl ra rr) or (P rk rl ra rr)
chkRZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRZ k l a r = case r of
E -> error "chkRZ: Bug0" -- impossible if BF<>0
N _ _ _ _ -> Z k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> P k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> Z k l a r -- BF +/-1 -> +1, so dH= 0
-- Check for height changes in right subtree of (P k l a r),
-- where l was (N rk rl ra rr) or (P rk rl ra rr)
chkRP :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRP k l a r = case r of
E -> error "chkRP: Bug0" -- impossible if BF<>0
N _ _ _ _ -> P k l a r -- BF +/-1 -> -1, so dH= 0
Z _ _ _ _ -> rebalP k l a r -- BF +/-1 -> 0, so dH=-1
P _ _ _ _ -> P k l a r -- BF +/-1 -> +1, so dH= 0
-- Substitute deleted element from (N _ l _ r)
subN :: IntMap a -> IntMap a -> IntMap a
subN _ E = error "subN: Bug0" -- Impossible
subN l (N rk rl ra rr) = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRN iv l v r_
subN l (Z rk rl ra rr) = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRN_ iv l v r_
subN l (P rk rl ra rr) = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRN iv l v r_
-- Substitute deleted element from (Z _ l _ r)
-- Pops the replacement from the right sub-tree, so result may be (P _ _ _)
subZR :: IntMap a -> IntMap a -> IntMap a
subZR _ E = E -- Both left and right subtrees must have been empty
subZR l (N rk rl ra rr) = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRZ iv l v r_
subZR l (Z rk rl ra rr) = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRZ_ iv l v r_
subZR l (P rk rl ra rr) = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRZ iv l v r_
-- Local utility to substitute deleted element from (Z _ l _ r)
-- Pops the replacement from the left sub-tree, so result may be (N _ _ _)
subZL :: IntMap a -> IntMap a -> IntMap a
subZL E _ = E -- Both left and right subtrees must have been empty
subZL (N lk ll la lr) r = case popRN lk ll la lr of (# l_,iv,v #) -> chkLZ iv l_ v r
subZL (Z lk ll la lr) r = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLZ_ iv l_ v r
subZL (P lk ll la lr) r = case popRP lk ll la lr of (# l_,iv,v #) -> chkLZ iv l_ v r
-- Substitute deleted element from (P _ l _ r)
subP :: IntMap a -> IntMap a -> IntMap a
subP E _ = error "subP: Bug0" -- Impossible
subP (N lk ll la lr) r = case popRN lk ll la lr of (# l_,iv,v #) -> chkLP iv l_ v r
subP (Z lk ll la lr) r = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLP_ iv l_ v r
subP (P lk ll la lr) r = case popRP lk ll la lr of (# l_,iv,v #) -> chkLP iv l_ v r
-- Check for height changes in left subtree of (N k l a r),
-- where l was (Z lk ll la lr)
chkLN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLN_ k l a r = case l of
E -> rebalN k l a r -- BF 0 -> E, so dH=-1
_ -> N k l a r -- Otherwise dH=0
-- Check for height changes in left subtree of (Z k l a r),
-- where l was (Z lk ll la lr)
chkLZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLZ_ k l a r = case l of
E -> N k l a r -- BF 0 -> E, so dH=-1
_ -> Z k l a r -- Otherwise dH=0
-- Check for height changes in left subtree of (P k l a r),
-- where l was (Z lk ll la lr)
chkLP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkLP_ k l a r = case l of
E -> Z k l a r -- BF 0 -> E, so dH=-1
_ -> P k l a r -- Otherwise dH=0
-- Check for height changes in right subtree of (N k l a r),
-- where r was (Z lk rl ra rr)
chkRN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRN_ k l a r = case r of
E -> Z k l a r -- BF 0 -> E, so dH=-1
_ -> N k l a r -- Otherwise dH=0
-- Check for height changes in right subtree of (Z k l a r),
-- where r was (Z lk rl ra rr)
chkRZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRZ_ k l a r = case r of
E -> P k l a r -- BF 0 -> E, so dH=-1
_ -> Z k l a r -- Otherwise dH=0
-- Check for height changes in right subtree of (P k l a r),
-- where l was (Z lk rl ra rr)
chkRP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a
chkRP_ k l a r = case r of
E -> rebalP k l a r -- BF 0 -> E, so dH=-1
_ -> P k l a r -- Otherwise dH=0
--------------------------------------------------------------------------
-- OTHER INSTANCES --
--------------------------------------------------------------------------
--------
-- Eq --
--------
instance (Eq a) => Eq (IntMap a) where
imp0 == imp1 = asIAList imp0 == asIAList imp1
---------
-- Ord --
---------
instance Ord a => Ord (IntMap a) where
compare imp0 imp1 = compare (asIAList imp0) (asIAList imp1)
----------
-- Show --
----------
instance Show a => Show (IntMap a) where
showsPrec d mp = showParen (d > 10) $
showString "fromAssocsAsc " . shows (assocsAsc mp)
----------
-- Read --
----------
instance R.Read a => R.Read (IntMap a) where
readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocsAsc" <- R.lexP
xs <- R.readPrec
return (fromAssocsAsc xs)
readListPrec = R.readListPrecDefault
------------------------
-- Typeable/Typeable1 --
------------------------
instance Typeable1 IntMap where
typeOf1 _ = mkTyConApp (mkTyCon "Data.GMap.IntMap.IntMap") []
--------------
instance Typeable a => Typeable (IntMap a) where
typeOf = typeOfDefault
-------------
-- Functor --
-------------
instance Functor IntMap where
-- fmap :: (a -> b) -> IntMap a -> IntMap b
fmap = mapIntMap -- The lazy version
-----------------
-- Data.Monoid --
-----------------
instance M.Monoid a => M.Monoid (IntMap a) where
-- mempty :: IntMap a
mempty = emptyIntMap
-- mappend :: IntMap a -> IntMap a -> IntMap a
mappend map0 map1 = unionIntMap M.mappend map0 map1
-- mconcat :: [IntMap a] -> IntMap a
mconcat maps = L.foldr (unionIntMap M.mappend) emptyIntMap maps
-------------------
-- Data.Foldable --
-------------------
instance F.Foldable IntMap where
-- fold :: Monoid m => IntMap m -> m
fold mp = foldElemsAscIntMap M.mappend M.mempty mp
-- foldMap :: Monoid m => (a -> m) -> IntMap a -> m
foldMap f mp = foldElemsAscIntMap (\a b -> M.mappend (f a) b) M.mempty mp
-- foldr :: (a -> b -> b) -> b -> IntMap a -> b
foldr f b0 mp = foldElemsAscIntMap f b0 mp
-- foldl :: (a -> b -> a) -> a -> IntMap b -> a
foldl f b0 mp = foldElemsDescIntMap (flip f) b0 mp
{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists.
-- fold1 :: (a -> a -> a) -> IntMap a -> a
fold1 = undefined
-- foldl1 :: (a -> a -> a) -> IntMap a -> a
foldl1 = undefined
-}
{- ??
data IntMap a = E -- ^ Empty IntMap
| N {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=-1 (right height > left height)
| Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF= 0
| P {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=+1 (left height > right height)
-}
---- ToDo: Tidy This Stuff up later --
vennIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)
vennIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets
gu E t1 = (E ,E,t1)
gu t0 E = (t0,E,E )
gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)
gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)
gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)
gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)
gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)
gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)
gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)
gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)
gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)
gu_ t0 h0 t1 h1 = case vennH f Empt 0# t0 h0 t1 h1 of
(# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)
vennH :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
vennH f = v where
-- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #)
v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #)
v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)
v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =
case compareInt# ka kb of
-- a < b, so (la < a < b) & (a < b < rb)
LT -> case forkVenn ka lb hlb of
(# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of
(# lra,hlra,myba,rra,hrra #) ->
-- (la + llb) < a < (lra + rlb) < b < (rra + rb)
case v cs cl rra hrra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of
Nothing -> case v cs0 cl0 lra hlra rlb hrlb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
Just a_ -> case (let c = f a_ b
in v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
) of
(# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> case (case mybb of
Nothing -> case v cs1 cl1 la hla llb hllb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
Just b_ -> case (let c = f a b_
in v (Cons ka c cs1) (cl1+#1#) la hla llb hllb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
) of
(# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #)
-- a = b
EQ -> case v cs cl ra hra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (let c = f a b
in v (Cons ka c cs0) (cl0+#1#) la hla lb hlb
) of
(# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of
(# ab,hab #) -> case joinH lba hlba rba hrba of
(# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #)
-- b < a, so (lb < b < a) & (b < a < ra)
GT -> case forkVenn ka rb hrb of
(# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of
(# lla,hlla,myba,rla,hrla #) ->
-- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)
case v cs cl ra hra rrb hrrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of
Nothing -> case v cs0 cl0 rla hrla lrb hlrb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
Just b_ -> case (let c = f a b_
in v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
) of
(# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> case (case myba of
Nothing -> case v cs1 cl1 lla hlla lb hlb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
Just a_ -> case (let c = f a_ b
in v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
) of
(# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #)
-----------------------------------------------------------------------
-------------------------- vennH Ends Here ----------------------------
-----------------------------------------------------------------------
vennIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)
vennIntMap' f = gu where -- This is to avoid O(log n) height calculation for empty sets
gu E t1 = (E ,E,t1)
gu t0 E = (t0,E,E )
gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)
gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)
gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)
gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)
gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)
gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)
gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)
gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)
gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)
gu_ t0 h0 t1 h1 = case vennH' f Empt 0# t0 h0 t1 h1 of
(# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)
-- Strict version of vennH
vennH' :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
vennH' f = v where
-- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #)
v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #)
v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)
v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =
case compareInt# ka kb of
-- a < b, so (la < a < b) & (a < b < rb)
LT -> case forkVenn ka lb hlb of
(# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of
(# lra,hlra,myba,rra,hrra #) ->
-- (la + llb) < a < (lra + rlb) < b < (rra + rb)
case v cs cl rra hrra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of
Nothing -> case v cs0 cl0 lra hlra rlb hrlb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
Just a_ -> case (let c = f a_ b
in c `seq` v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
) of
(# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> case (case mybb of
Nothing -> case v cs1 cl1 la hla llb hllb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
Just b_ -> case (let c = f a b_
in c `seq` v (Cons ka c cs1) (cl1+#1#) la hla llb hllb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
) of
(# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #)
-- a = b
EQ -> case v cs cl ra hra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (let c = f a b
in c `seq` v (Cons ka c cs0) (cl0+#1#) la hla lb hlb
) of
(# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of
(# ab,hab #) -> case joinH lba hlba rba hrba of
(# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #)
-- b < a, so (lb < b < a) & (b < a < ra)
GT -> case forkVenn ka rb hrb of
(# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of
(# lla,hlla,myba,rla,hrla #) ->
-- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)
case v cs cl ra hra rrb hrrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of
Nothing -> case v cs0 cl0 rla hrla lrb hlrb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
Just b_ -> case (let c = f a b_
in c `seq` v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
) of
(# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> case (case myba of
Nothing -> case v cs1 cl1 lla hlla lb hlb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
Just a_ -> case (let c = f a_ b
in c `seq` v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
) of
(# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #)
-----------------------------------------------------------------------
-------------------------- vennH' Ends Here ---------------------------
-----------------------------------------------------------------------
vennMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b)
vennMaybeIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets
gu E t1 = (E ,E,t1)
gu t0 E = (t0,E,E )
gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)
gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)
gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)
gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)
gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)
gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)
gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)
gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)
gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)
gu_ t0 h0 t1 h1 = case vennMaybeH f Empt 0# t0 h0 t1 h1 of
(# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba)
vennMaybeH :: (a -> b -> Maybe c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
vennMaybeH f = v where
-- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #)
v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #)
v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #)
v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#)
v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#)
v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#)
v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb =
case compareInt# ka kb of
-- a < b, so (la < a < b) & (a < b < rb)
LT -> case forkVenn ka lb hlb of
(# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of
(# lra,hlra,myba,rra,hrra #) ->
-- (la + llb) < a < (lra + rlb) < b < (rra + rb)
case v cs cl rra hrra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of
Nothing -> case v cs0 cl0 lra hlra rlb hrlb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
Just a_ -> case (case f a_ b of
Nothing -> v cs0 cl0 lra hlra rlb hrlb
Just c -> v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #)
) of
(# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> case (case mybb of
Nothing -> case v cs1 cl1 la hla llb hllb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
Just b_ -> case (case f a b_ of
Nothing -> v cs1 cl1 la hla llb hllb
Just c -> v (Cons ka c cs1) (cl1+#1#) la hla llb hllb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #)
) of
(# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #)
-- a = b
EQ -> case v cs cl ra hra rb hrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case f a b of
Nothing -> v cs0 cl0 la hla lb hlb
Just c -> v (Cons ka c cs0) (cl0+#1#) la hla lb hlb
) of
(# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of
(# ab,hab #) -> case joinH lba hlba rba hrba of
(# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #)
-- b < a, so (lb < b < a) & (b < a < ra)
GT -> case forkVenn ka rb hrb of
(# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of
(# lla,hlla,myba,rla,hrla #) ->
-- (lla + lb) < b < (rla + lrb) < a < (ra + rrb)
case v cs cl ra hra rrb hrrb of
(# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of
Nothing -> case v cs0 cl0 rla hrla lrb hlrb of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
Just b_ -> case (case f a b_ of
Nothing -> v cs0 cl0 rla hrla lrb hlrb
Just c -> v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb
) of
(# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of
(# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #)
) of
(# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of
(# mrba,hmrba #) -> case (case myba of
Nothing -> case v cs1 cl1 lla hlla lb hlb of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
Just a_ -> case (case f a_ b of
Nothing -> v cs1 cl1 lla hlla lb hlb
Just c -> v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb
) of
(# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of
(# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #)
) of
(# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of
(# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #)
-----------------------------------------------------------------------
------------------------ vennMaybeH Ends Here -------------------------
-----------------------------------------------------------------------
-- Common fork for Vennops
forkVenn :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,Maybe a,IntMap a,Int# #)
forkVenn k ta hta = f ta hta where
f E h = (# E,h,Nothing,E,h #)
f (N ka l a r) h = f_ ka l (h-#2#) a r (h-#1#)
f (Z ka l a r) h = f_ ka l (h-#1#) a r (h-#1#)
f (P ka l a r) h = f_ ka l (h-#1#) a r (h-#2#)
f_ ka l hl a r hr = case compareInt# k ka of
LT -> case f l hl of
(# ll,hll,mba,lr,hlr #) -> case spliceH ka lr hlr a r hr of
(# r_,hr_ #) -> (# ll,hll,mba,r_,hr_ #)
EQ -> (# l,hl,Just a,r,hr #)
GT -> case f r hr of
(# rl,hrl,mbc,rr,hrr #) -> case spliceH ka l hl a rl hrl of
(# l_,hl_ #) -> (# l_,hl_,mbc,rr,hrr #)
disjointUnionIntMap :: IntMap a -> IntMap a -> IntMap a
disjointUnionIntMap = gu where -- This is to avoid O(log n) height calculation for empty sets
gu E t1 = t1
gu t0 E = t0
gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1)
gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1)
gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1)
gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1)
gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1)
gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1)
gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1)
gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1)
gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1)
gu_ t0 h0 t1 h1 = case disjointUnionH t0 h0 t1 h1 of (# t,_ #) -> t
disjointUnionH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #)
disjointUnionH = u where
-- u :: IntMap a -> UINT -> IntMap a -> UINT -> (# IntMap a,UINT #)
u E _ t1 h1 = (# t1,h1 #)
u t0 h0 E _ = (# t0,h0 #)
u (N k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)
u (N k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)
u (N k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)
u (Z k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)
u (Z k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)
u (Z k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)
u (P k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#2#) e1 r1 (h1-#1#)
u (P k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#1#)
u (P k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#2#)
u_ k0 l0 hl0 e0 r0 hr0 k1 l1 hl1 e1 r1 hr1 =
case compareInt# k0 k1 of
-- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1)
LT -> case fork k1 r0 hr0 of
(# rl0,hrl0,rr0,hrr0 #) -> case fork k0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0)
(# ll1,hll1,lr1,hlr1 #) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1)
-- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1)
case u l0 hl0 ll1 hll1 of
(# l,hl #) -> case u rl0 hrl0 lr1 hlr1 of
(# m,hm #) -> case u rr0 hrr0 r1 hr1 of
(# r,hr #) -> case spliceH k1 m hm e1 r hr of
(# t,ht #) -> spliceH k0 l hl e0 t ht
-- e0 = e1
EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0# #)
-- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0)
GT -> case fork k0 r1 hr1 of
(# rl1,hrl1,rr1,hrr1 #) -> case fork k1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1)
(# ll0,hll0,lr0,hlr0 #) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0)
-- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1)
case u ll0 hll0 l1 hl1 of
(# l,hl #) -> case u lr0 hlr0 rl1 hrl1 of
(# m,hm #) -> case u r0 hr0 rr1 hrr1 of
(# r,hr #) -> case spliceH k1 l hl e1 m hm of
(# t,ht #) -> spliceH k0 t ht e0 r hr
-- fork :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,IntMap a,Int# #)
fork k0 t1 ht1 = fork_ t1 ht1 where
fork_ E _ = (# E,0#,E,0# #)
fork_ (N k l e r) h = fork__ k l (h-#2#) e r (h-#1#)
fork_ (Z k l e r) h = fork__ k l (h-#1#) e r (h-#1#)
fork_ (P k l e r) h = fork__ k l (h-#1#) e r (h-#2#)
fork__ k l hl e r hr = case compareInt# k0 k of
LT -> case fork_ l hl of
(# l0,hl0,l1,hl1 #) -> case spliceH k l1 hl1 e r hr of
(# l1_,hl1_ #) -> (# l0,hl0,l1_,hl1_ #)
EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0#,E,0# #)
GT -> case fork_ r hr of
(# l0,hl0,l1,hl1 #) -> case spliceH k l hl e l0 hl0 of
(# l0_,hl0_ #) -> (# l0_,hl0_,l1,hl1 #)
-----------------------------------------------------------------------
---------------------- disjointUnionH Ends Here -----------------------
-----------------------------------------------------------------------