mini-1.6.5.0: src/Mini/Data/Map.hs
-- incomplete patterns in 'fromDistinct{Asc,Desc}List'
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | A structure mapping unique keys to values
module Mini.Data.Map (
-- * Type
Map,
map,
-- * Construction
empty,
fromAscList,
fromAscListWith,
fromAscListWithKey,
fromDescList,
fromDescListWith,
fromDescListWithKey,
fromDistinctAscList,
fromDistinctDescList,
fromList,
fromListWith,
fromListWithKey,
singleton,
-- * Combination
compose,
difference,
differenceWith,
differenceWithKey,
intersection,
intersectionWith,
intersectionWithKey,
union,
unionWith,
unionWithKey,
unions,
unionsWith,
unionsWithKey,
-- * Conversion
toAscList,
toDescList,
-- * Fold
foldlWithKey,
foldrWithKey,
-- * Modification
adjust,
adjustMax,
adjustMaxWithKey,
adjustMin,
adjustMinWithKey,
adjustWithKey,
delete,
deleteMax,
deleteMin,
filter,
filterWithKey,
insert,
insertWith,
insertWithKey,
update,
updateMax,
updateMaxWithKey,
updateMin,
updateMinWithKey,
updateWithKey,
-- * Partition
partition,
partitionWithKey,
split,
splitMax,
splitMin,
-- * Query
disjoint,
isSubmapOf,
isSubmapOfBy,
lookup,
lookupGE,
lookupGT,
lookupLE,
lookupLT,
lookupMax,
lookupMin,
member,
null,
size,
-- * Traversal
fmapWithKey,
traverseWithKey,
-- * Validation
valid,
) where
import Control.Applicative (
liftA2,
(<|>),
)
import Data.Bifunctor (
bimap,
first,
second,
)
import Data.Bool (
bool,
)
import Data.Function (
on,
)
import Mini.Data.Recursion (
list,
ordering,
)
import Prelude (
Applicative,
Bool (
False,
True
),
Eq,
Foldable,
Functor,
Int,
Maybe (
Just,
Nothing
),
Monoid,
Ord,
Semigroup,
Show,
Traversable,
compare,
const,
div,
error,
flip,
fmap,
foldl,
foldr,
fst,
length,
max,
maybe,
mempty,
not,
pure,
show,
splitAt,
traverse,
uncurry,
until,
($),
(&&),
(*),
(+),
(-),
(.),
(<),
(<$>),
(<*>),
(<>),
(==),
(>),
(||),
)
-- 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 = fmapWithKey . const
instance Foldable (Map k) where
foldr = foldrWithKey . const
instance Traversable (Map k) where
traverse = traverseWithKey . const
instance (Ord k) => Semigroup (Map k a) where
(<>) = union
instance (Ord k) => Monoid (Map k a) where
mempty = empty
-- | 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(1)/ The empty map
empty :: Map k a
empty = E
-- | /O(n)/ Make a map from a tail-biased list of key-sorted pairs
fromAscList :: (Eq k) => [(k, a)] -> Map k a
fromAscList = fromDistinctAscList . essence
-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromAscListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromAscListWith = fromAscListWithKey . const
-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromAscListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromAscListWithKey f = fromDistinctAscList . essenceWithKey f
-- | /O(n)/ Make a map from a tail-biased list of key-sorted pairs
fromDescList :: (Eq k) => [(k, a)] -> Map k a
fromDescList = fromDistinctDescList . essence
-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromDescListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromDescListWith = fromDescListWithKey . const
-- | /O(n)/ Make a map from a list of key-sorted pairs, combining matching keys
fromDescListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromDescListWithKey f = fromDistinctDescList . essenceWithKey f
-- | /O(n)/ Make a map from a sorted list of key-distinct pairs
fromDistinctAscList :: [(k, a)] -> Map k a
fromDistinctAscList = go <*> power
where
go ps n = list E go' ps
where
go' (k, a) = const . list (B E k a E) go''
where
go'' _ _ _ =
let len = length ps
n' = n `div` 2
c = bool B L $ len == n
(l, (k', a') : r) = splitAt (len `div` 2) ps
in c (go l n') k' a' (go r n')
-- | /O(n)/ Make a map from a sorted list of key-distinct pairs
fromDistinctDescList :: [(k, a)] -> Map k a
fromDistinctDescList = go <*> power
where
go ps n = list E go' ps
where
go' (k, a) = const . list (B E k a E) go''
where
go'' _ _ _ =
let len = length ps
n' = n `div` 2
c = bool B R $ len == n
(l, (k', a') : r) = splitAt (len `div` 2) ps
in c (go r n') k' a' (go l n')
-- | /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 = fromListWithKey $ const const
-- | /O(n log n)/ Make a map from a list of pairs, combining matching keys
fromListWith :: (Ord k) => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith = fromListWithKey . const
-- | /O(n log n)/ Make a map from a list of pairs, combining matching keys
fromListWithKey :: (Ord k) => (k -> a -> a -> a) -> [(k, a)] -> Map k a
fromListWithKey f = foldl (flip . uncurry $ insertWithKey f) empty
-- | /O(1)/ Make a map with a single bin
singleton :: k -> a -> Map k a
singleton k a = B E k a E
-- Combination
-- | /O(n log m)/ Compose the keys of one set with the values of another
compose :: (Ord b) => Map b c -> Map a b -> Map a c
compose t1 t2 = map' empty go go go t1
where
go _ _ _ _ _ _ =
fromDistinctAscList $
foldrWithKey
(\a b ac -> maybe ac (\c -> (a, c) : ac) $ lookup b t1)
[]
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' empty go go go t1
where
go _ _ _ _ _ _ = foldrWithKey (\k _ b -> delete k b) t1 t2
-- | /O(m log n)/ Subtract a map by another, updating bins of matching keys
differenceWith
:: (Ord k) => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
differenceWith = differenceWithKey . const
-- | /O(m log n)/ Subtract a map by another, updating bins of matching keys
differenceWithKey
:: (Ord k) => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
differenceWithKey f t1 t2 = map' empty go go go t1
where
go _ _ _ _ _ _ =
foldrWithKey
( \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 = intersectionWithKey $ const const
-- | /O(n log m)/ Intersect a map with another by key matching, combining values
intersectionWith :: (Ord k) => (a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWith = intersectionWithKey . const
-- | /O(n log m)/ Intersect a map with another by key matching, combining values
intersectionWithKey
:: (Ord k) => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
intersectionWithKey f t1 t2 = map' empty go go go t2
where
go _ _ _ _ _ _ =
fromDistinctAscList $
foldrWithKey
(\k a c -> maybe c (\b -> (k, f k a b) : c) $ lookup k t2)
[]
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 = unionWithKey $ const const
-- | /O(m log n)/ Unite a map with another, combining values of matching keys
unionWith :: (Ord k) => (a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWith = unionWithKey . const
-- | /O(m log n)/ Unite a map with another, combining values of matching keys
unionWithKey :: (Ord k) => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
unionWithKey f t1 t2 = map' t1 go go go t2
where
go _ _ _ _ _ _ = foldrWithKey (insertWithKey f) t2 t1
-- | Unite a collection of maps via left-biased key matching
unions :: (Foldable t, Ord k) => t (Map k a) -> Map k a
unions = unionsWithKey $ const const
-- | Unite a collection of maps, combining values of matching keys
unionsWith :: (Foldable t, Ord k) => (a -> a -> a) -> t (Map k a) -> Map k a
unionsWith = unionsWithKey . const
-- | Unite a collection of maps, combining values of matching keys
unionsWithKey :: (Foldable t, Ord k) => (k -> a -> a -> a) -> t (Map k a) -> Map k a
unionsWithKey f = foldr (unionWithKey f) empty
-- Conversion
-- | /O(n)/ Turn a map into a list of @(key, value)@ pairs in ascending order
toAscList :: Map k a -> [(k, a)]
toAscList = foldrWithKey (\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 = foldlWithKey (\b k a -> (k, a) : b) []
-- Fold
-- | /O(n)/ Reduce a map with a left-associative operation and an accumulator
foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b
foldlWithKey f b = map' b go go go
where
go _ k a r recl _ = foldlWithKey f (f recl k a) r
-- | /O(n)/ Reduce a map with a right-associative operation and an accumulator
foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
foldrWithKey f b = map' b go go go
where
go l k a _ _ recr = foldrWithKey f (f k a recr) l
-- Modification
-- | /O(log n)/ Adjust with an operation the value of a key in a map
adjust :: (Ord k) => (a -> a) -> k -> Map k a -> Map k a
adjust = adjustWithKey . const
-- | /O(log n)/ Adjust with an operation the value of the maximum key in a map
adjustMax :: (a -> a) -> Map k a -> Map k a
adjustMax = adjustMaxWithKey . const
-- | /O(log n)/ Adjust with an operation the value of the maximum key in a map
adjustMaxWithKey :: (k -> a -> a) -> Map k a -> Map k a
adjustMaxWithKey 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 :: (a -> a) -> Map k a -> Map k a
adjustMin = adjustMinWithKey . const
-- | /O(log n)/ Adjust with an operation the value of the minimum key in a map
adjustMinWithKey :: (k -> a -> a) -> Map k a -> Map k a
adjustMinWithKey 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)/ Adjust with an operation the value of a key in a map
adjustWithKey :: (Ord k) => (k -> a -> a) -> k -> Map k a -> Map k a
adjustWithKey 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(log n)/ Delete a key from a map
delete :: (Ord k) => k -> Map k a -> Map k a
delete k t = bool t (delete' k t) $ k `member` t
-- | /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(n)/ Keep the bins whose values satisfy a predicate
filter :: (a -> Bool) -> Map k a -> Map k a
filter = filterWithKey . const
-- | /O(n)/ Keep the bins whose keys and values satisfy a predicate
filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a
filterWithKey p =
fromDistinctAscList
. foldrWithKey (\k a b -> bool b ((k, a) : b) $ p k a) []
-- | /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 = insertWithKey $ const const
-- | /O(log n)/ Insert a key and its value, combining new and old if present
insertWith :: (Ord k) => (a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWith = insertWithKey . const
-- | /O(log n)/ Modify the value of a key or delete its bin with an operation
update :: (Ord k) => (a -> Maybe a) -> k -> Map k a -> Map k a
update = updateWithKey . const
-- | /O(log n)/ Modify the value of the maximum key or delete its bin
updateMax :: (Ord k) => (a -> Maybe a) -> Map k a -> Map k a
updateMax = updateMaxWithKey . const
-- | /O(log n)/ Modify the value of the maximum key or delete its bin
updateMaxWithKey :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMaxWithKey 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) => (a -> Maybe a) -> Map k a -> Map k a
updateMin = updateMinWithKey . const
-- | /O(log n)/ Modify the value of the minimum key or delete its bin
updateMinWithKey :: (Ord k) => (k -> a -> Maybe a) -> Map k a -> Map k a
updateMinWithKey f t =
maybe
t
( \(k, a) ->
maybe
(delete' k t)
(\a' -> insert k a' t)
$ f k a
)
$ lookupMin t
-- | /O(log n)/ Modify the value of a key or delete its bin with an operation
updateWithKey :: (Ord k) => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
updateWithKey f k t =
maybe
t
( maybe
(delete' k t)
(\a' -> insert k a' t)
. f k
)
$ lookup k t
-- Partition
-- | /O(n)/ Partition a map with a predicate into @(true, false)@ submaps
partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a)
partition = partitionWithKey . const
-- | /O(n)/ Partition a map with a predicate into @(true, false)@ submaps
partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
partitionWithKey p =
bimap fromDistinctAscList fromDistinctAscList
. foldrWithKey
(\k a -> bool second first (p k a) ((k, a) :))
([], [])
-- | /O(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 =
(\(lt, a, gt) -> (fromDistinctAscList lt, a, fromDistinctAscList gt))
. foldrWithKey
( \k a (lt, a', gt) ->
ordering
((k, a) : lt, a', gt)
(lt, Just a, gt)
(lt, a', (k, a) : gt)
$ compare k k0
)
([], Nothing, [])
-- | /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
-- 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 $ foldrWithKey (\k _ b -> k `member` t1 || b) False t2
-- | /O(n log m)/ Check whether the bins of one map exist in the other
isSubmapOf :: (Ord k, Eq a) => Map k a -> Map k a -> Bool
isSubmapOf = isSubmapOfBy (==)
-- | /O(n log m)/ Check if the bins of one map exist in the other by combination
isSubmapOfBy :: (Ord k) => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
isSubmapOfBy p t1 t2 = map' (null t1) go go go t2
where
go _ _ _ _ _ _ =
foldrWithKey
(\k a b -> maybe False ((&& b) . p a) $ lookup k t2)
True
t1
-- | /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)/ 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)/ 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(1)/ Check whether a map is empty
null :: Map k a -> Bool
null = map' True go go go where go _ _ _ _ _ _ = False
-- | /O(n)/ Get the size of a map
size :: Map k a -> Int
size = map' 0 go go go where go _ _ _ _ recl recr = 1 + recl + recr
-- Traversal
-- | /O(n)/ Apply an operation across a map, transforming its values
fmapWithKey :: (k -> a -> b) -> Map k a -> Map k b
fmapWithKey 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
traverseWithKey :: (Applicative f) => (k -> a -> f b) -> Map k a -> f (Map k b)
traverseWithKey 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
-- Validation
-- | /O(n^2)/ Check whether a map is internally height-balanced and ordered
valid :: (Ord k) => Map k a -> Bool
valid = liftA2 (&&) balanced ordered
where
balanced =
map'
True
(\l _ _ r recl recr -> levels l - levels r == 1 && recl && recr)
(\l _ _ r recl recr -> levels l - levels r == 0 && recl && recr)
(\l _ _ r recl recr -> levels r - levels l == 1 && recl && recr)
levels = map' 0 go go go
where
go _ _ _ _ recl recr = 1 + max recl recr :: Int
ordered = map' True go go go
where
go l k _ r recl recr =
map' True lt lt lt l
&& map' True gt gt gt r
where
lt _ lk _ _ _ _ = lk < k && recl && recr
gt _ rk _ _ _ _ = rk > k && recl && recr
-- Helpers
-- O(n) 'nub' on keys for sorted lists of pairs
essence :: (Eq k) => [(k, a)] -> [(k, a)]
essence = list [] go
where
go p1@(k1, _) ps rec = list [p1] go' ps
where
go' (k2, _) _ _ = bool (p1 : rec) rec $ k1 == k2
-- O(n) 'nub' with a combining function for sorted lists of pairs
essenceWithKey :: (Eq k) => (k -> a -> a -> a) -> [(k, a)] -> [(k, a)]
essenceWithKey f = list [] (\p -> const . go p)
where
go p1@(k1, a1) = list [p1] go'
where
go' p2@(k2, a2) ps _ =
bool
(p1 : go p2 ps)
(go (k1, f k1 a2 a1) ps)
$ k1 == k2
-- O(log n) The greatest power of 2 <= the length of a non-empty collection
power :: (Foldable t) => t a -> Int
power as = until (> length as) (* 2) 2 `div` 2
{-
- 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
insertWithKey :: (Ord k) => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWithKey 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