mini-2.0.0.0: src/Mini/Data/Map.hs

-- | A structure mapping unique keys to values
module Mini.Data.Map (
  -- * Type
  Map,
  map,

  -- * Construction
  fromList,
  fromListWith,
  singleton,

  -- * Combination
  compose,
  difference,
  differenceWith,
  intersection,
  intersectionWith,
  union,
  unionWith,

  -- * Conversion
  toAscList,
  toDescList,

  -- * Fold
  foldlWith,
  foldrWith,

  -- * Max/Min
  adjustMax,
  adjustMin,
  deleteMax,
  deleteMin,
  lookupMax,
  lookupMin,
  splitMax,
  splitMin,
  updateMax,
  updateMin,

  -- * Modification
  adjust,
  delete,
  filter,
  insert,
  insertWith,
  update,

  -- * Partition
  partition,
  split,

  -- * Query
  disjoint,
  lookup,
  lookupGE,
  lookupGT,
  lookupLE,
  lookupLT,
  member,
  submap,
  submapBy,

  -- * Traversal
  fmapWith,
  traverseWith,
) where

import Control.Applicative (
  (<|>),
 )
import Data.Bifunctor (
  first,
  second,
 )
import Data.Bool (
  bool,
 )
import Data.Function (
  on,
 )
import Mini.Data.Recursion (
  ordering,
 )
import Mini.Hash.Class (
  Hashable,
  toBytes,
 )
import Prelude (
  Applicative,
  Bool (
    False,
    True
  ),
  Eq,
  Foldable,
  Functor,
  Maybe (
    Just,
    Nothing
  ),
  Monoid,
  Ord,
  Semigroup,
  Show,
  Traversable,
  compare,
  concatMap,
  const,
  error,
  flip,
  fmap,
  foldl,
  foldr,
  fst,
  maximum,
  maybe,
  mempty,
  minimum,
  not,
  null,
  pure,
  show,
  traverse,
  uncurry,
  ($),
  (&&),
  (.),
  (<$>),
  (<*>),
  (<>),
  (==),
  (||),
 )

-- Type

-- | A map from keys /k/ to values /a/, internally structured as an AVL tree
data Map k a
  = -- | Empty bin
    E
  | -- | Left-heavy bin
    L (Map k a) k a (Map k a)
  | -- | Balanced bin
    B (Map k a) k a (Map k a)
  | -- | Right-heavy bin
    R (Map k a) k a (Map k a)

instance (Eq k, Eq a) => Eq (Map k a) where
  (==) = (==) `on` toAscList

instance (Ord k, Ord a) => Ord (Map k a) where
  compare = compare `on` toAscList

instance (Show k, Show a) => Show (Map k a) where
  show = show . toAscList

instance Functor (Map k) where
  fmap = fmapWith . const

instance Foldable (Map k) where
  foldr = foldrWith . const
  null = map' True go go go where go _ _ _ _ _ _ = False
  maximum = map' (error "maximum: empty map") go go go
   where
    go _ _ a r _ recr = map' a go' go' go' r
     where
      go' _ _ _ _ _ _ = recr
  minimum = map' (error "minimum: empty map") go go go
   where
    go l _ a _ recl _ = map' a go' go' go' l
     where
      go' _ _ _ _ _ _ = recl

instance Traversable (Map k) where
  traverse = traverseWith . const

instance (Ord k) => Semigroup (Map k a) where
  (<>) = union

instance (Ord k) => Monoid (Map k a) where
  mempty = E

instance (Hashable a) => Hashable (Map k a) where
  toBytes = concatMap toBytes

-- | Primitive recursion on maps (internally structured as trees)
map
  :: b
  -- ^ Value in case of empty node
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of non-empty node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> Map k a
  -- ^ Object of the case analysis
  -> b
map e f = map' e f f f

-- Primitive recursion on maps
map'
  :: b
  -- ^ Value in case of empty node
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of left-heavy node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of balanced node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> (Map k a -> k -> a -> Map k a -> b -> b -> b)
  -- ^ Function applied in case of right-heavy node:
  -- left child, key, value, right child, left recursion, right recursion
  -- (keys are lesser to the left, greater to the right)
  -> Map k a
  -- ^ Object of the case analysis
  -> b
map' e f g h obj = case obj of
  L l k a r -> f l k a r (map' e f g h l) (map' e f g h r)
  R l k a r -> h l k a r (map' e f g h l) (map' e f g h r)
  B l k a r -> g l k a r (map' e f g h l) (map' e f g h r)
  E -> e

-- Construction

-- | /O(n log n)/ Make a map from a tail-biased list of @(key, value)@ pairs
fromList :: (Ord k) => [(k, a)] -> Map k a
fromList = fromListWith $ const const

-- | /O(n log n)/ Make a map from a list of pairs, combining matching keys
fromListWith :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromListWith f = foldl (flip . uncurry $ insertWith f) mempty

-- | /O(1)/ Make a map with a single bin
singleton :: (Ord k) => k -> a -> Map k a
singleton k a = B mempty k a mempty

-- Combination

-- | /O(n log m)/ Compose the keys of one set with the values of another
compose :: (Ord a, Ord b) => Map b c -> Map a b -> Map a c
compose t1 t2 = map' mempty go go go t1
 where
  go _ _ _ _ _ _ =
    foldrWith
      (\a b ac -> maybe ac (\c -> insert a c ac) $ lookup b t1)
      mempty
      t2

-- | /O(m log n)/ Subtract a map by another via key matching
difference :: (Ord k) => Map k a -> Map k b -> Map k a
difference t1 t2 = map' mempty go go go t1
 where
  go _ _ _ _ _ _ =
    foldrWith (\k _ b -> bool b (delete k b) $ k `member` b) t1 t2

-- | /O(m log n)/ Subtract a map by another, updating bins of matching keys
differenceWith
  :: (Ord k) => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
differenceWith f t1 t2 = map' mempty go go go t1
 where
  go _ _ _ _ _ _ =
    foldrWith
      ( \k b t' ->
          maybe
            t'
            (\a -> maybe (delete k t') (\a' -> insert k a' t') $ f k a b)
            $ lookup k t1
      )
      t1
      t2

-- | /O(n log m)/ Intersect a map with another via left-biased key matching
intersection :: (Ord k) => Map k a -> Map k b -> Map k a
intersection = intersectionWith $ const const

-- | /O(n log m)/ Intersect a map with another by key matching, combining values
intersectionWith
  :: (Ord k) => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWith f t1 t2 = map' mempty go go go t2
 where
  go _ _ _ _ _ _ =
    foldrWith
      (\k a c -> maybe c (\b -> insert k (f k a b) c) $ lookup k t2)
      mempty
      t1

-- | /O(m log n)/ Unite a map with another via left-biased key matching
union :: (Ord k) => Map k a -> Map k a -> Map k a
union = unionWith $ const const

-- | /O(m log n)/ Unite a map with another, combining values of matching keys
unionWith :: (Ord k) => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith f t1 t2 = map' t1 go go go t2
 where
  go _ _ _ _ _ _ = foldrWith (insertWith f) t2 t1

-- Conversion

-- | /O(n)/ Turn a map into a list of @(key, value)@ pairs in ascending order
toAscList :: Map k a -> [(k, a)]
toAscList = foldrWith (\k a b -> (k, a) : b) []

-- | /O(n)/ Turn a map into a list of @(key, value)@ pairs in descending order
toDescList :: Map k a -> [(k, a)]
toDescList = foldlWith (\b k a -> (k, a) : b) []

-- Fold

-- | /O(n)/ Reduce a map with a left-associative operation and an accumulator
foldlWith :: (b -> k -> a -> b) -> b -> Map k a -> b
foldlWith f b = map' b go go go
 where
  go _ k a r recl _ = foldlWith f (f recl k a) r

-- | /O(n)/ Reduce a map with a right-associative operation and an accumulator
foldrWith :: (k -> a -> b -> b) -> b -> Map k a -> b
foldrWith f b = map' b go go go
 where
  go l k a _ _ recr = foldrWith f (f k a recr) l

-- Max/Min

-- | /O(log n)/ Adjust with an operation the value of the maximum key in a map
adjustMax :: (k -> a -> a) -> Map k a -> Map k a
adjustMax f = map' E (go L) (go B) (go R)
 where
  go c l k a r _ recr = map' (c l k (f k a) r) go' go' go' r
   where
    go' _ _ _ _ _ _ = c l k a recr

-- | /O(log n)/ Adjust with an operation the value of the minimum key in a map
adjustMin :: (k -> a -> a) -> Map k a -> Map k a
adjustMin f = map' E (go L) (go B) (go R)
 where
  go c l k a r recl _ = map' (c l k (f k a) r) go' go' go' l
   where
    go' _ _ _ _ _ _ = c recl k a r

-- | /O(log n)/ Delete the maximum key from a map
deleteMax :: (Ord k) => Map k a -> Map k a
deleteMax t = maybe t (flip delete t . fst) $ lookupMax t

-- | /O(log n)/ Delete the minimum key from a map
deleteMin :: (Ord k) => Map k a -> Map k a
deleteMin t = maybe t (flip delete t . fst) $ lookupMin t

-- | /O(log n)/ Fetch the bin with the maximum key
lookupMax :: Map k a -> Maybe (k, a)
lookupMax = map' Nothing go go go
 where
  go _ k a r _ recr = map' (Just (k, a)) go' go' go' r
   where
    go' _ _ _ _ _ _ = recr

-- | /O(log n)/ Fetch the bin with the minimum key
lookupMin :: Map k a -> Maybe (k, a)
lookupMin = map' Nothing go go go
 where
  go l k a _ recl _ = map' (Just (k, a)) go' go' go' l
   where
    go' _ _ _ _ _ _ = recl

-- | /O(log n)/ Split a map by its maximum key
splitMax :: (Ord k) => Map k a -> Maybe ((k, a), Map k a)
splitMax t = ((,) <*> flip delete t . fst) <$> lookupMax t

-- | /O(log n)/ Split a map by its minimum key
splitMin :: (Ord k) => Map k a -> Maybe ((k, a), Map k a)
splitMin t = ((,) <*> flip delete t . fst) <$> lookupMin t

-- | /O(log n)/ Modify the value of the maximum key or delete its bin
updateMax :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMax f t =
  maybe
    t
    (\(k, a) -> maybe (delete k t) (\a' -> insert k a' t) $ f k a)
    $ lookupMax t

-- | /O(log n)/ Modify the value of the minimum key or delete its bin
updateMin :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMin f t =
  maybe
    t
    (\(k, a) -> maybe (delete k t) (\a' -> insert k a' t) $ f k a)
    $ lookupMin t

-- Modification

-- | /O(log n)/ Adjust with an operation the value of a key in a map
adjust :: (Ord k) => (k -> a -> a) -> k -> Map k a -> Map k a
adjust f k0 = map' E (go L) (go B) (go R)
 where
  go c l k a r recl recr =
    ordering (c recl k a r) (c l k (f k a) r) (c l k a recr) $ compare k0 k

-- | /O(n log n)/ Keep the bins whose keys and values satisfy a predicate
filter :: (Ord k) => (k -> a -> Bool) -> Map k a -> Map k a
filter p = foldrWith (\k a b -> bool b (insert k a b) $ p k a) mempty

-- | /O(log n)/ Insert a key and its value into a map, overwriting if present
insert :: (Ord k) => k -> a -> Map k a -> Map k a
insert = insertWith $ const const

-- | /O(log n)/ Modify the value of a key or delete its bin with an operation
update :: (Ord k) => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
update f k t =
  maybe t (maybe (delete k t) (\a' -> insert k a' t) . f k) $ lookup k t

-- Partition

-- | /O(n log n)/ Partition a map with a predicate into @(true, false)@ submaps
partition :: (Ord k) => (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
partition p =
  foldrWith (\k a -> bool second first (p k a) (insert k a)) (mempty, mempty)

-- | /O(n log n)/ Split a map by a key into @(lt, eq, gt)@ submaps
split :: (Ord k) => k -> Map k a -> (Map k a, Maybe a, Map k a)
split k0 =
  foldrWith
    ( \k a (lt, a', gt) ->
        ordering
          (insert k a lt, a', gt)
          (lt, Just a, gt)
          (lt, a', insert k a gt)
          $ compare k k0
    )
    (mempty, Nothing, mempty)

-- Query

-- | /O(m log n)/ Check whether two maps have no keys in common
disjoint :: (Ord k) => Map k a -> Map k a -> Bool
disjoint t1 t2 = map' True go go go t1
 where
  go _ _ _ _ _ _ = not $ foldrWith (\k _ b -> k `member` t1 || b) False t2

-- | /O(log n)/ Fetch the value of a key in a map
lookup :: (Ord k) => k -> Map k a -> Maybe a
lookup k = map' Nothing go go go
 where
  go _ k' a _ recl recr = ordering recl (Just a) recr $ compare k k'

-- | /O(log n)/ Fetch the least bin greater than or equal to a key
lookupGE :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupGE k0 = map' Nothing go go go
 where
  go _ k a _ recl recr =
    ordering recr (Just (k, a)) (recl <|> Just (k, a)) $ compare k k0

-- | /O(log n)/ Fetch the least bin strictly greater than a key
lookupGT :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupGT k0 = map' Nothing go go go
 where
  go _ k a _ recl recr =
    ordering recr recr (recl <|> Just (k, a)) $ compare k k0

-- | /O(log n)/ Fetch the greatest bin less than or equal to a key
lookupLE :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupLE k0 = map' Nothing go go go
 where
  go _ k a _ recl recr =
    ordering (recr <|> Just (k, a)) (Just (k, a)) recl $ compare k k0

-- | /O(log n)/ Fetch the greatest bin strictly less than a key
lookupLT :: (Ord k) => k -> Map k a -> Maybe (k, a)
lookupLT k0 = map' Nothing go go go
 where
  go _ k a _ recl recr =
    ordering (recr <|> Just (k, a)) recl recl $ compare k k0

-- | /O(log n)/ Check whether a key is in a map
member :: (Ord k) => k -> Map k a -> Bool
member k0 = map' False go go go
 where
  go _ k _ _ recl recr = ordering recl True recr $ compare k0 k

-- | /O(n log m)/ Check whether the bins of one map exist in the other
submap :: (Ord k, Eq a) => Map k a -> Map k a -> Bool
submap = submapBy (==)

-- | /O(n log m)/ Check if the bins of one map exist in the other by combination
submapBy :: (Ord k) => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
submapBy p t1 t2 = map' (null t1) go go go t2
 where
  go _ _ _ _ _ _ =
    foldrWith (\k a b -> maybe False ((&& b) . p a) $ lookup k t2) True t1

-- Traversal

-- | /O(n)/ Apply an operation across a map, transforming its values
fmapWith :: (k -> a -> b) -> Map k a -> Map k b
fmapWith f = map' E (go L) (go B) (go R)
 where
  go c _ k a _ recl = c recl k (f k a)

-- | /O(n)/ Lift a map with a lifting operation on keys and values
traverseWith :: (Applicative f) => (k -> a -> f b) -> Map k a -> f (Map k b)
traverseWith f = map' (pure E) (go L) (go B) (go R)
 where
  go c _ k a _ recl recr = c <$> recl <*> pure k <*> f k a <*> recr

-- Helpers

{-
 - Let this comment serve as your warning. Return from whence you came and your
 - sanity will be spared. You have been admonished.
 -}

-- | /O(log n)/ Delete a key from a map without checking for membership
delete :: (Ord k) => k -> Map k a -> Map k a
delete k0 =
  map'
    (error "Map.delete: L0")
    ( \l k a r _ _ ->
        ordering
          (deleteLl l k a r)
          (substituteL l r)
          (deleteLr l k a r)
          $ compare k0 k
    )
    ( \l k a r _ _ ->
        ordering
          (deleteBl l k a r)
          (substituteBr l r)
          (deleteBr l k a r)
          $ compare k0 k
    )
    ( \l k a r _ _ ->
        ordering
          (deleteRl l k a r)
          (substituteR l r)
          (deleteRr l k a r)
          $ compare k0 k
    )
 where
  deleteRl l k a r =
    map'
      (error "Map.delete: L1")
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftR (deleteLl ll lk la lr) k a r)
            (checkLeftR (substituteL ll lr) k a r)
            (checkLeftR (deleteLr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (R (deleteBl ll lk la lr) k a r)
            (checkLeftR' (substituteBr ll lr) k a r)
            (R (deleteBr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftR (deleteRl ll lk la lr) k a r)
            (checkLeftR (substituteR ll lr) k a r)
            (checkLeftR (deleteRr ll lk la lr) k a r)
            $ compare k0 lk
      )
      l
  deleteRr l k a =
    map'
      (error "Map.delete: L2")
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightR l k a $ deleteLl rl rk ra rr)
            (checkRightR l k a $ substituteL rl rr)
            (checkRightR l k a $ deleteLr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (R l k a $ deleteBl rl rk ra rr)
            (checkRightR' l k a $ substituteBl rl rr)
            (R l k a $ deleteBr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightR l k a $ deleteRl rl rk ra rr)
            (checkRightR l k a $ substituteR rl rr)
            (checkRightR l k a $ deleteRr rl rk ra rr)
            $ compare k0 rk
      )
  deleteBl l k a r =
    map'
      (error "Map.delete: L3")
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftB (deleteLl ll lk la lr) k a r)
            (checkLeftB (substituteL ll lr) k a r)
            (checkLeftB (deleteLr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (B (deleteBl ll lk la lr) k a r)
            (checkLeftB' (substituteBr ll lr) k a r)
            (B (deleteBr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftB (deleteRl ll lk la lr) k a r)
            (checkLeftB (substituteR ll lr) k a r)
            (checkLeftB (deleteRr ll lk la lr) k a r)
            $ compare k0 lk
      )
      l
  deleteBr l k a =
    map'
      (error "Map.delete: L4")
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightB l k a $ deleteLl rl rk ra rr)
            (checkRightB l k a $ substituteL rl rr)
            (checkRightB l k a $ deleteLr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (B l k a $ deleteBl rl rk ra rr)
            (checkRightB' l k a $ substituteBl rl rr)
            (B l k a $ deleteBr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightB l k a $ deleteRl rl rk ra rr)
            (checkRightB l k a $ substituteR rl rr)
            (checkRightB l k a $ deleteRr rl rk ra rr)
            $ compare k0 rk
      )
  deleteLl l k a r =
    map'
      (error "Map.delete: L5")
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftL (deleteLl ll lk la lr) k a r)
            (checkLeftL (substituteL ll lr) k a r)
            (checkLeftL (deleteLr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (L (deleteBl ll lk la lr) k a r)
            (checkLeftL' (substituteBr ll lr) k a r)
            (L (deleteBr ll lk la lr) k a r)
            $ compare k0 lk
      )
      ( \ll lk la lr _ _ ->
          ordering
            (checkLeftL (deleteRl ll lk la lr) k a r)
            (checkLeftL (substituteR ll lr) k a r)
            (checkLeftL (deleteRr ll lk la lr) k a r)
            $ compare k0 lk
      )
      l
  deleteLr l k a =
    map'
      (error "Map.delete: L6")
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightL l k a $ deleteLl rl rk ra rr)
            (checkRightL l k a $ substituteL rl rr)
            (checkRightL l k a $ deleteLr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (L l k a $ deleteBl rl rk ra rr)
            (checkRightL' l k a $ substituteBl rl rr)
            (L l k a $ deleteBr rl rk ra rr)
            $ compare k0 rk
      )
      ( \rl rk ra rr _ _ ->
          ordering
            (checkRightL l k a $ deleteRl rl rk ra rr)
            (checkRightL l k a $ substituteR rl rr)
            (checkRightL l k a $ deleteRr rl rk ra rr)
            $ compare k0 rk
      )
  rebalanceR l k a =
    map'
      (error "Map.delete: L7")
      ( \rl rk ra rr _ _ ->
          map'
            (error "Map.delete: L8")
            (\rll rlk rla rlr _ _ -> B (B l k a rll) rlk rla $ R rlr rk ra rr)
            (\rll rlk rla rlr _ _ -> B (B l k a rll) rlk rla $ B rlr rk ra rr)
            (\rll rlk rla rlr _ _ -> B (L l k a rll) rlk rla $ B rlr rk ra rr)
            rl
      )
      (\rl rk ra rr _ _ -> L (R l k a rl) rk ra rr)
      (\rl rk ra rr _ _ -> B (B l k a rl) rk ra rr)
  rebalanceL l k a r =
    map'
      (error "Map.delete: L9")
      (\ll lk la lr _ _ -> B ll lk la $ B lr k a r)
      (\ll lk la lr _ _ -> R ll lk la $ L lr k a r)
      ( \ll lk la lr _ _ ->
          map'
            (error "Map.delete: L10")
            (\lrl lrk lra lrr _ _ -> B (B ll lk la lrl) lrk lra $ R lrr k a r)
            (\lrl lrk lra lrr _ _ -> B (B ll lk la lrl) lrk lra $ B lrr k a r)
            (\lrl lrk lra lrr _ _ -> B (L ll lk la lrl) lrk lra $ B lrr k a r)
            lr
      )
      l
  checkLeftR l k a r =
    map'
      (error "Map.delete: L11")
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> rebalanceR l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      l
  checkLeftB l k a r =
    map'
      (error "Map.delete: L12")
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      l
  checkLeftL l k a r =
    map'
      (error "Map.delete: L13")
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      l
  checkRightR l k a r =
    map'
      (error "Map.delete: L14")
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      r
  checkRightB l k a r =
    map'
      (error "Map.delete: L15")
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      r
  checkRightL l k a r =
    map'
      (error "Map.delete: L16")
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> rebalanceL l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      r
  substituteR l =
    map'
      (error "Map.delete: L17")
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR l k a r) $
            popLeftL rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR' l k a r) $
            popLeftB rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightR l k a r) $
            popLeftR rl rk ra rr
      )
  substituteBr l =
    map'
      E
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB l k a r) $
            popLeftL rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB' l k a r) $
            popLeftB rl rk ra rr
      )
      ( \rl rk ra rr _ _ ->
          (\(k, a, r) -> checkRightB l k a r) $
            popLeftR rl rk ra rr
      )
  substituteBl l r =
    map'
      E
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB l' k a r) $
            popRightL ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB' l' k a r) $
            popRightB ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftB l' k a r) $
            popRightR ll lk la lr
      )
      l
  substituteL l r =
    map'
      (error "Map.delete: L18")
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL l' k a r) $
            popRightL ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL' l' k a r) $
            popRightB ll lk la lr
      )
      ( \ll lk la lr _ _ ->
          (\(l', k, a) -> checkLeftL l' k a r) $
            popRightR ll lk la lr
      )
      l
  checkLeftR' l k a r =
    map'
      (rebalanceR l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      l
  checkLeftB' l k a r =
    map'
      (R l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      l
  checkLeftL' l k a r =
    map'
      (B l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      l
  checkRightR' l k a r =
    map'
      (B l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      (\_ _ _ _ _ _ -> R l k a r)
      r
  checkRightB' l k a r =
    map'
      (L l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      (\_ _ _ _ _ _ -> B l k a r)
      r
  checkRightL' l k a r =
    map'
      (rebalanceL l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      (\_ _ _ _ _ _ -> L l k a r)
      r
  popLeftR l k a r =
    map'
      (k, a, r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftR l' k a r)) $
            popLeftL ll lk la lr
      )
      (\ll lk la lr _ _ -> popLeftRB ll lk la lr k a r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftR l' k a r)) $
            popLeftR ll lk la lr
      )
      l
  popLeftB l k a r =
    map'
      (k, a, E)
      (\ll lk la lr _ _ -> popLeftBL ll lk la lr k a r)
      (\ll lk la lr _ _ -> popLeftBB ll lk la lr k a r)
      (\ll lk la lr _ _ -> popLeftBR ll lk la lr k a r)
      l
  popLeftL l k a r =
    map'
      (error "Map.delete: L19")
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftL l' k a r)) $
            popLeftL ll lk la lr
      )
      (\ll lk la lr _ _ -> popLeftLB ll lk la lr k a r)
      ( \ll lk la lr _ _ ->
          (\(k', a', l') -> (k', a', checkLeftL l' k a r)) $
            popLeftR ll lk la lr
      )
      l
  popLeftRB ll lk la lr k a r =
    map'
      (lk, la, rebalanceR E k a r)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', R l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftBB ll lk la lr k a r =
    map'
      (lk, la, R E k a r)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', B l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftLB ll lk la lr k a r =
    map'
      (lk, la, B E k a E)
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBL lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBB lll llk lla llr lk la lr
      )
      ( \lll llk lla llr _ _ ->
          (\(k', a', l) -> (k', a', L l k a r)) $
            popLeftBR lll llk lla llr lk la lr
      )
      ll
  popLeftBR ll lk la lr k a r =
    (\(k', a', l) -> (k', a', checkLeftB l k a r)) $
      popLeftR ll lk la lr
  popLeftBL ll lk la lr k a r =
    (\(k', a', l) -> (k', a', checkLeftB l k a r)) $
      popLeftL ll lk la lr
  popRightR l k a =
    map'
      (error "Map.delete: L20")
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightR l k a r, k', a')) $
            popRightL rl rk ra rr
      )
      (\rl rk ra rr _ _ -> popRightRB l k a rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightR l k a r, k', a')) $
            popRightR rl rk ra rr
      )
  popRightB l k a =
    map'
      (E, k, a)
      (\rl rk ra rr _ _ -> popRightBL l k a rl rk ra rr)
      (\rl rk ra rr _ _ -> popRightBB l k a rl rk ra rr)
      (\rl rk ra rr _ _ -> popRightBR l k a rl rk ra rr)
  popRightL l k a =
    map'
      (l, k, a)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightL l k a r, k', a')) $
            popRightL rl rk ra rr
      )
      (\rl rk ra rr _ _ -> popRightLB l k a rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          (\(r, k', a') -> (checkRightL l k a r, k', a')) $
            popRightR rl rk ra rr
      )
  popRightRB l k a rl rk ra =
    map'
      (B E k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (R l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightBB l k a rl rk ra =
    map'
      (L l k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (B l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightLB l k a rl rk ra =
    map'
      (rebalanceL l k a E, rk, ra)
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBL rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBB rl rk ra rrl rrk rra rrr
      )
      ( \rrl rrk rra rrr _ _ ->
          (\(r, k', a') -> (L l k a r, k', a')) $
            popRightBR rl rk ra rrl rrk rra rrr
      )
  popRightBR l k a rl rk ra rr =
    (\(r, k', a') -> (checkRightB l k a r, k', a')) $
      popRightR rl rk ra rr
  popRightBL l k a rl rk ra rr =
    (\(r, k', a') -> (checkRightB l k a r, k', a')) $
      popRightL rl rk ra rr

-- | /O(log n)/ Insert a key and its value, combining new and old if present
insertWith :: (Ord k) => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWith f k0 a0 =
  map'
    (B E k0 a0 E)
    (\l k a r _ _ -> insertL l k a r)
    (\l k a r _ _ -> insertB l k a r)
    (\l k a r _ _ -> insertR l k a r)
 where
  insertR l k a r =
    ordering
      (insertRl l k a r)
      (R l k (f k a0 a) r)
      (insertRr l k a r)
      $ compare k0 k
  insertB l k a r =
    ordering
      (insertBl l k a r)
      (B l k (f k a0 a) r)
      (insertBr l k a r)
      $ compare k0 k
  insertL l k a r =
    ordering
      (insertLl l k a r)
      (L l k (f k a0 a) r)
      (insertLr l k a r)
      $ compare k0 k
  insertRl l k a r =
    map'
      (B (B E k0 a0 E) k a r)
      (\ll lk la lr _ _ -> R (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          let l' = insertB ll lk la lr
           in map'
                (error "Map.insert: L0")
                (\_ _ _ _ _ _ -> B l' k a r)
                (\_ _ _ _ _ _ -> R l' k a r)
                (\_ _ _ _ _ _ -> B l' k a r)
                l'
      )
      (\ll lk la lr _ _ -> R (insertR ll lk la lr) k a r)
      l
  insertBl l k a r =
    map'
      (L (B E k0 a0 E) k a r)
      (\ll lk la lr _ _ -> B (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          let l' = insertB ll lk la lr
           in map'
                (error "Map.insert: L1")
                (\_ _ _ _ _ _ -> L l' k a r)
                (\_ _ _ _ _ _ -> B l' k a r)
                (\_ _ _ _ _ _ -> L l' k a r)
                l'
      )
      (\ll lk la lr _ _ -> B (insertR ll lk la lr) k a r)
      l
  insertBr l k a =
    map'
      (R l k a $ B E k0 a0 E)
      (\rl rk ra rr _ _ -> B l k a $ insertL rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          let r = insertB rl rk ra rr
           in map'
                (error "Map.insert: L2")
                (\_ _ _ _ _ _ -> R l k a r)
                (\_ _ _ _ _ _ -> B l k a r)
                (\_ _ _ _ _ _ -> R l k a r)
                r
      )
      (\rl rk ra rr _ _ -> B l k a $ insertR rl rk ra rr)
  insertLr l k a =
    map'
      (B l k a $ B E k0 a0 E)
      (\rl rk ra rr _ _ -> L l k a $ insertL rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          let r = insertB rl rk ra rr
           in map'
                (error "Map.insert: L3")
                (\_ _ _ _ _ _ -> B l k a r)
                (\_ _ _ _ _ _ -> L l k a r)
                (\_ _ _ _ _ _ -> B l k a r)
                r
      )
      (\rl rk ra rr _ _ -> L l k a $ insertR rl rk ra rr)
  insertRr l k a =
    map'
      (error "Map.insert: L4")
      (\rl rk ra rr _ _ -> R l k a $ insertL rl rk ra rr)
      ( \rl rk ra rr _ _ ->
          ordering
            (insertRrl l k a rl rk ra rr)
            (R l k a $ B rl rk (f rk a0 ra) rr)
            (insertRrr l k a rl rk ra rr)
            $ compare k0 rk
      )
      (\rl rk ra rr _ _ -> R l k a $ insertR rl rk ra rr)
  insertLl l k a r =
    map'
      (error "Map.insert: L5")
      (\ll lk la lr _ _ -> L (insertL ll lk la lr) k a r)
      ( \ll lk la lr _ _ ->
          ordering
            (insertLll ll lk la lr k a r)
            (L (B ll lk (f lk a0 la) lr) k a r)
            (insertLlr ll lk la lr k a r)
            $ compare k0 lk
      )
      (\ll lk la lr _ _ -> L (insertR ll lk la lr) k a r)
      l
  insertRrr l k a rl rk ra =
    map'
      (B (B l k a rl) rk ra $ B E k0 a0 E)
      (\rrl rrk rra rrr _ _ -> R l k a . B rl rk ra $ insertL rrl rrk rra rrr)
      ( \rrl rrk rra rrr _ _ ->
          let rr = insertB rrl rrk rra rrr
           in map'
                (error "Map.insert: L6")
                (\_ _ _ _ _ _ -> B (B l k a rl) rk ra rr)
                (\_ _ _ _ _ _ -> R l k a $ B rl rk ra rr)
                (\_ _ _ _ _ _ -> B (B l k a rl) rk ra rr)
                rr
      )
      (\rrl rrk rra rrr _ _ -> R l k a . B rl rk ra $ insertR rrl rrk rra rrr)
  insertLll ll lk la lr k a r =
    map'
      (B (B E k0 a0 E) lk la $ B lr k a r)
      (\lll llk lla llr _ _ -> L (B (insertL lll llk lla llr) lk la lr) k a r)
      ( \lll llk lla llr _ _ ->
          let ll' = insertB lll llk lla llr
           in map'
                (error "Map.insert: L7")
                (\_ _ _ _ _ _ -> B ll' lk la $ B lr k a r)
                (\_ _ _ _ _ _ -> L (B ll' lk la lr) k a r)
                (\_ _ _ _ _ _ -> B ll' lk la $ B lr k a r)
                ll'
      )
      (\lll llk lla llr _ _ -> L (B (insertR lll llk lla llr) lk la lr) k a r)
      ll
  insertRrl l k a rl rk ra rr =
    map'
      (B (B l k a E) k0 a0 $ B E rk ra rr)
      (\rll rlk rla rlr _ _ -> R l k a $ B (insertL rll rlk rla rlr) rk ra rr)
      ( \rll rlk rla rlr _ _ ->
          let rl' = insertB rll rlk rla rlr
           in map'
                (error "Map.insert: L8")
                ( \rll' rlk' rla' rlr' _ _ ->
                    B
                      (B l k a rll')
                      rlk'
                      rla'
                      (R rlr' rk ra rr)
                )
                (\_ _ _ _ _ _ -> R l k a $ B rl' rk ra rr)
                ( \rll' rlk' rla' rlr' _ _ ->
                    B
                      (L l k a rll')
                      rlk'
                      rla'
                      (B rlr' rk ra rr)
                )
                rl'
      )
      (\rll rlk rla rlr _ _ -> R l k a $ B (insertR rll rlk rla rlr) rk ra rr)
      rl
  insertLlr ll lk la lr k a r =
    map'
      (B (B ll lk la E) k0 a0 $ B E k a r)
      (\lrl lrk lra lrr _ _ -> L (B ll lk la $ insertL lrl lrk lra lrr) k a r)
      ( \lrl lrk lra lrr _ _ ->
          let lr' = insertB lrl lrk lra lrr
           in map'
                (error "Map.insert: L9")
                ( \lrl' lrk' lra' lrr' _ _ ->
                    B
                      (B ll lk la lrl')
                      lrk'
                      lra'
                      (R lrr' k a r)
                )
                (\_ _ _ _ _ _ -> L (B ll lk la lr') k a r)
                ( \lrl' lrk' lra' lrr' _ _ ->
                    B
                      (L ll lk la lrl')
                      lrk'
                      lra'
                      (B lrr' k a r)
                )
                lr'
      )
      (\lrl lrk lra lrr _ _ -> L (B ll lk la $ insertR lrl lrk lra lrr) k a r)
      lr