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