{-# 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 -----------------------
-----------------------------------------------------------------------