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

-- | A structure containing unique elements
module Mini.Data.Set (
  -- * Type
  Set,
  set,

  -- * Construction
  fromList,
  singleton,

  -- * Combination
  difference,
  intersection,
  union,

  -- * Conversion
  toAscList,
  toDescList,

  -- * Max/Min
  deleteMax,
  deleteMin,
  lookupMax,
  lookupMin,
  splitMax,
  splitMin,

  -- * Modification
  delete,
  filter,
  insert,

  -- * Partition
  partition,
  split,

  -- * Query
  disjoint,
  lookupGE,
  lookupGT,
  lookupLE,
  lookupLT,
  member,
  subset,
) 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 (
  Bool (
    False,
    True
  ),
  Eq,
  Foldable,
  Maybe (
    Just,
    Nothing
  ),
  Monoid,
  Ord,
  Semigroup,
  Show,
  all,
  any,
  compare,
  concatMap,
  error,
  flip,
  foldl,
  foldr,
  maximum,
  maybe,
  mempty,
  minimum,
  not,
  null,
  show,
  uncurry,
  ($),
  (.),
  (<$>),
  (<*>),
  (<>),
  (==),
 )

-- Type

-- | A set containing elements of type /a/, internally structured as an AVL tree
data Set a
  = -- | Empty node
    E
  | -- | Left-heavy node
    L (Set a) a (Set a)
  | -- | Balanced node
    B (Set a) a (Set a)
  | -- | Right-heavy node
    R (Set a) a (Set a)

instance (Eq a) => Eq (Set a) where
  (==) = (==) `on` toAscList

instance (Ord a) => Ord (Set a) where
  compare = compare `on` toAscList

instance (Show a) => Show (Set a) where
  show = show . toAscList

instance Foldable Set where
  foldr f b = set' b go go go
   where
    go l a _ _ recr = foldr f (f a recr) l
  null = set' True go go go where go _ _ _ _ _ = False
  maximum = set' (error "maximum: empty set") go go go
   where
    go _ a r _ recr = set' a go' go' go' r
     where
      go' _ _ _ _ _ = recr
  minimum = set' (error "minimum: empty set") go go go
   where
    go l a _ recl _ = set' a go' go' go' l
     where
      go' _ _ _ _ _ = recl

instance (Ord a) => Semigroup (Set a) where
  (<>) = union

instance (Ord a) => Monoid (Set a) where
  mempty = E

instance (Hashable a) => Hashable (Set a) where
  toBytes = concatMap toBytes

-- | Primitive recursion on sets (internally structured as trees)
set
  :: b
  -- ^ Value in case of empty node
  -> (Set a -> a -> Set a -> b -> b -> b)
  -- ^ Function applied in case of non-empty node:
  -- left child, element, right child, left recursion, right recursion
  -- (elements are lesser to the left, greater to the right)
  -> Set a
  -- ^ Object of the case analysis
  -> b
set e f = set' e f f f

-- Primitive recursion on sets
set'
  :: b
  -- ^ Value in case of empty node
  -> (Set a -> a -> Set a -> b -> b -> b)
  -- ^ Function applied in case of left-heavy node:
  -- left child, element, right child, left recursion, right recursion
  -- (elements are lesser to the left, greater to the right)
  -> (Set a -> a -> Set a -> b -> b -> b)
  -- ^ Function applied in case of balanced node:
  -- left child, element, right child, left recursion, right recursion
  -- (elements are lesser to the left, greater to the right)
  -> (Set a -> a -> Set a -> b -> b -> b)
  -- ^ Function applied in case of right-heavy node:
  -- left child, element, right child, left recursion, right recursion
  -- (elements are lesser to the left, greater to the right)
  -> Set a
  -- ^ Object of the case analysis
  -> b
set' e f g h obj = case obj of
  L l a r -> f l a r (set' e f g h l) (set' e f g h r)
  R l a r -> h l a r (set' e f g h l) (set' e f g h r)
  B l a r -> g l a r (set' e f g h l) (set' e f g h r)
  E -> e

-- Construction

-- | /O(n log n)/ Make a set from a list of elements
fromList :: (Ord a) => [a] -> Set a
fromList = foldl (flip insert) mempty

-- | /O(1)/ Make a set with a single element
singleton :: (Ord a) => a -> Set a
singleton a = B mempty a mempty

-- Combination

-- | /O(m log n)/ Subtract a set by another
difference :: (Ord a) => Set a -> Set a -> Set a
difference t1 t2 = set' mempty go go go t1
 where
  go _ _ _ _ _ = foldr (\a b -> bool b (delete a b) $ a `member` b) t1 t2

-- | /O(m log n)/ Intersect a set with another
intersection :: (Ord a) => Set a -> Set a -> Set a
intersection t1 t2 = set' mempty go go go t2
 where
  go _ _ _ _ _ = foldr (\a b -> bool b (insert a b) $ a `member` t2) mempty t1

-- | /O(m log n)/ Unite a set with another
union :: (Ord a) => Set a -> Set a -> Set a
union t1 t2 = set' t2 go go go t1
 where
  go _ _ _ _ _ = foldr (\a b -> bool (insert a b) b $ a `member` b) t1 t2

-- Conversion

-- | /O(n)/ Turn a set into a list of elements in ascending order
toAscList :: Set a -> [a]
toAscList = foldr (:) []

-- | /O(n)/ Turn a set into a list of elements in descending order
toDescList :: Set a -> [a]
toDescList = foldl (flip (:)) []

-- Max/Min

-- | /O(log n)/ Delete the maximum element from a set
deleteMax :: (Ord a) => Set a -> Set a
deleteMax t = maybe t (`delete` t) $ lookupMax t

-- | /O(log n)/ Delete the minimum element from a set
deleteMin :: (Ord a) => Set a -> Set a
deleteMin t = maybe t (`delete` t) $ lookupMin t

-- | /O(log n)/ Fetch the maximum element
lookupMax :: Set a -> Maybe a
lookupMax = set' Nothing go go go
 where
  go _ a r _ recr = set' (Just a) go' go' go' r
   where
    go' _ _ _ _ _ = recr

-- | /O(log n)/ Fetch the minimum element
lookupMin :: Set a -> Maybe a
lookupMin = set' Nothing go go go
 where
  go l a _ recl _ = set' (Just a) go' go' go' l
   where
    go' _ _ _ _ _ = recl

-- | /O(log n)/ Split a set by its maximum element
splitMax :: (Ord a) => Set a -> Maybe (a, Set a)
splitMax t = ((,) <*> flip delete t) <$> lookupMax t

-- | /O(log n)/ Split a set by its minimum element
splitMin :: (Ord a) => Set a -> Maybe (a, Set a)
splitMin t = ((,) <*> flip delete t) <$> lookupMin t

-- Modification

-- | /O(n log n)/ Keep the elements satisfying a predicate
filter :: (Ord a) => (a -> Bool) -> Set a -> Set a
filter p = foldr (\a b -> bool b (insert a b) $ p a) mempty

-- Partition

-- | /O(n log n)/ Partition a set with a predicate into @(true, false)@ subsets
partition :: (Ord a) => (a -> Bool) -> Set a -> (Set a, Set a)
partition p = foldr (\a -> bool second first (p a) (insert a)) (mempty, mempty)

-- | /O(n log n)/ Split a set by an element into @(lt, eq, gt)@ subsets
split :: (Ord a) => a -> Set a -> (Set a, Bool, Set a)
split a0 =
  foldr
    ( \a (lt, a', gt) ->
        ordering
          (insert a lt, a', gt)
          (lt, True, gt)
          (lt, a', insert a gt)
          $ compare a a0
    )
    (mempty, False, mempty)

-- Query

-- | /O(m log n)/ Check whether two sets have no elements in common
disjoint :: (Ord a) => Set a -> Set a -> Bool
disjoint t1 t2 = set' True go go go t1
 where
  go _ _ _ _ _ = not $ any (`member` t1) t2

-- | /O(log n)/ Fetch the least element greater than or equal to the given one
lookupGE :: (Ord a) => a -> Set a -> Maybe a
lookupGE a0 = set' Nothing go go go
 where
  go _ a _ recl recr = ordering recr (Just a) (recl <|> Just a) $ compare a a0

-- | /O(log n)/ Fetch the least element strictly greater than the given one
lookupGT :: (Ord a) => a -> Set a -> Maybe a
lookupGT a0 = set' Nothing go go go
 where
  go _ a _ recl recr = ordering recr recr (recl <|> Just a) $ compare a a0

-- | /O(log n)/ Fetch the greatest element less than or equal to the given one
lookupLE :: (Ord a) => a -> Set a -> Maybe a
lookupLE a0 = set' Nothing go go go
 where
  go _ a _ recl recr = ordering (recr <|> Just a) (Just a) recl $ compare a a0

-- | /O(log n)/ Fetch the greatest element strictly less than the given one
lookupLT :: (Ord a) => a -> Set a -> Maybe a
lookupLT a0 = set' Nothing go go go
 where
  go _ a _ recl recr = ordering (recr <|> Just a) recl recl $ compare a a0

-- | /O(log n)/ Check whether an element is in a set
member :: (Ord a) => a -> Set a -> Bool
member a0 = set' False go go go
 where
  go _ a _ recl recr = ordering recl True recr $ compare a0 a

-- | /O(n log m)/ Check whether the elements of a set exist in the other
subset :: (Ord a) => Set a -> Set a -> Bool
subset t1 t2 = set' (null t1) go go go t2
 where
  go _ _ _ _ _ = all (`member` t2) t1

{-
 - 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 an element from a set without checking for membership
delete :: (Ord a) => a -> Set a -> Set a
delete a0 =
  set'
    (error "Set.delete: L0")
    ( \l a r _ _ ->
        ordering
          (deleteLl l a r)
          (substituteL l r)
          (deleteLr l a r)
          $ compare a0 a
    )
    ( \l a r _ _ ->
        ordering
          (deleteBl l a r)
          (substituteBr l r)
          (deleteBr l a r)
          $ compare a0 a
    )
    ( \l a r _ _ ->
        ordering
          (deleteRl l a r)
          (substituteR l r)
          (deleteRr l a r)
          $ compare a0 a
    )
 where
  deleteRl l a r =
    set'
      (error "Set.delete: L1")
      ( \ll la lr _ _ ->
          ordering
            (checkLeftR (deleteLl ll la lr) a r)
            (checkLeftR (substituteL ll lr) a r)
            (checkLeftR (deleteLr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (R (deleteBl ll la lr) a r)
            (checkLeftR' (substituteBr ll lr) a r)
            (R (deleteBr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (checkLeftR (deleteRl ll la lr) a r)
            (checkLeftR (substituteR ll lr) a r)
            (checkLeftR (deleteRr ll la lr) a r)
            $ compare a0 la
      )
      l
  deleteRr l a =
    set'
      (error "Set.delete: L2")
      ( \rl ra rr _ _ ->
          ordering
            (checkRightR l a $ deleteLl rl ra rr)
            (checkRightR l a $ substituteL rl rr)
            (checkRightR l a $ deleteLr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (R l a $ deleteBl rl ra rr)
            (checkRightR' l a $ substituteBl rl rr)
            (R l a $ deleteBr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (checkRightR l a $ deleteRl rl ra rr)
            (checkRightR l a $ substituteR rl rr)
            (checkRightR l a $ deleteRr rl ra rr)
            $ compare a0 ra
      )
  deleteBl l a r =
    set'
      (error "Set.delete: L3")
      ( \ll la lr _ _ ->
          ordering
            (checkLeftB (deleteLl ll la lr) a r)
            (checkLeftB (substituteL ll lr) a r)
            (checkLeftB (deleteLr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (B (deleteBl ll la lr) a r)
            (checkLeftB' (substituteBr ll lr) a r)
            (B (deleteBr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (checkLeftB (deleteRl ll la lr) a r)
            (checkLeftB (substituteR ll lr) a r)
            (checkLeftB (deleteRr ll la lr) a r)
            $ compare a0 la
      )
      l
  deleteBr l a =
    set'
      (error "Set.delete: L4")
      ( \rl ra rr _ _ ->
          ordering
            (checkRightB l a $ deleteLl rl ra rr)
            (checkRightB l a $ substituteL rl rr)
            (checkRightB l a $ deleteLr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (B l a $ deleteBl rl ra rr)
            (checkRightB' l a $ substituteBl rl rr)
            (B l a $ deleteBr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (checkRightB l a $ deleteRl rl ra rr)
            (checkRightB l a $ substituteR rl rr)
            (checkRightB l a $ deleteRr rl ra rr)
            $ compare a0 ra
      )
  deleteLl l a r =
    set'
      (error "Set.delete: L5")
      ( \ll la lr _ _ ->
          ordering
            (checkLeftL (deleteLl ll la lr) a r)
            (checkLeftL (substituteL ll lr) a r)
            (checkLeftL (deleteLr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (L (deleteBl ll la lr) a r)
            (checkLeftL' (substituteBr ll lr) a r)
            (L (deleteBr ll la lr) a r)
            $ compare a0 la
      )
      ( \ll la lr _ _ ->
          ordering
            (checkLeftL (deleteRl ll la lr) a r)
            (checkLeftL (substituteR ll lr) a r)
            (checkLeftL (deleteRr ll la lr) a r)
            $ compare a0 la
      )
      l
  deleteLr l a =
    set'
      (error "Set.delete: L6")
      ( \rl ra rr _ _ ->
          ordering
            (checkRightL l a $ deleteLl rl ra rr)
            (checkRightL l a $ substituteL rl rr)
            (checkRightL l a $ deleteLr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (L l a $ deleteBl rl ra rr)
            (checkRightL' l a $ substituteBl rl rr)
            (L l a $ deleteBr rl ra rr)
            $ compare a0 ra
      )
      ( \rl ra rr _ _ ->
          ordering
            (checkRightL l a $ deleteRl rl ra rr)
            (checkRightL l a $ substituteR rl rr)
            (checkRightL l a $ deleteRr rl ra rr)
            $ compare a0 ra
      )
  rebalanceR l a =
    set'
      (error "Set.delete: L7")
      ( \rl ra rr _ _ ->
          set'
            (error "Set.delete: L8")
            (\rll rla rlr _ _ -> B (B l a rll) rla $ R rlr ra rr)
            (\rll rla rlr _ _ -> B (B l a rll) rla $ B rlr ra rr)
            (\rll rla rlr _ _ -> B (L l a rll) rla $ B rlr ra rr)
            rl
      )
      (\rl ra rr _ _ -> L (R l a rl) ra rr)
      (\rl ra rr _ _ -> B (B l a rl) ra rr)
  rebalanceL l a r =
    set'
      (error "Set.delete: L9")
      (\ll la lr _ _ -> B ll la $ B lr a r)
      (\ll la lr _ _ -> R ll la $ L lr a r)
      ( \ll la lr _ _ ->
          set'
            (error "Set.delete: L10")
            (\lrl lra lrr _ _ -> B (B ll la lrl) lra $ R lrr a r)
            (\lrl lra lrr _ _ -> B (B ll la lrl) lra $ B lrr a r)
            (\lrl lra lrr _ _ -> B (L ll la lrl) lra $ B lrr a r)
            lr
      )
      l
  checkLeftR l a r =
    set'
      (error "Set.delete: L11")
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> rebalanceR l a r)
      (\_ _ _ _ _ -> R l a r)
      l
  checkLeftB l a r =
    set'
      (error "Set.delete: L12")
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> B l a r)
      l
  checkLeftL l a r =
    set'
      (error "Set.delete: L13")
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> L l a r)
      l
  checkRightR l a r =
    set'
      (error "Set.delete: L14")
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> R l a r)
      r
  checkRightB l a r =
    set'
      (error "Set.delete: L15")
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> B l a r)
      r
  checkRightL l a r =
    set'
      (error "Set.delete: L16")
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> rebalanceL l a r)
      (\_ _ _ _ _ -> L l a r)
      r
  substituteR l =
    set'
      (error "Set.delete: L17")
      (\rl ra rr _ _ -> uncurry (checkRightR l) $ popLeftL rl ra rr)
      (\rl ra rr _ _ -> uncurry (checkRightR' l) $ popLeftB rl ra rr)
      (\rl ra rr _ _ -> uncurry (checkRightR l) $ popLeftR rl ra rr)
  substituteBr l =
    set'
      E
      (\rl ra rr _ _ -> uncurry (checkRightB l) $ popLeftL rl ra rr)
      (\rl ra rr _ _ -> uncurry (checkRightB' l) $ popLeftB rl ra rr)
      (\rl ra rr _ _ -> uncurry (checkRightB l) $ popLeftR rl ra rr)
  substituteBl l r =
    set'
      E
      (\ll la lr _ _ -> (\(l', a) -> checkLeftB l' a r) $ popRightL ll la lr)
      (\ll la lr _ _ -> (\(l', a) -> checkLeftB' l' a r) $ popRightB ll la lr)
      (\ll la lr _ _ -> (\(l', a) -> checkLeftB l' a r) $ popRightR ll la lr)
      l
  substituteL l r =
    set'
      (error "Set.delete: L18")
      (\ll la lr _ _ -> (\(l', a) -> checkLeftL l' a r) $ popRightL ll la lr)
      (\ll la lr _ _ -> (\(l', a) -> checkLeftL' l' a r) $ popRightB ll la lr)
      (\ll la lr _ _ -> (\(l', a) -> checkLeftL l' a r) $ popRightR ll la lr)
      l
  checkLeftR' l a r =
    set'
      (rebalanceR l a r)
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> R l a r)
      l
  checkLeftB' l a r =
    set'
      (R l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> B l a r)
      l
  checkLeftL' l a r =
    set'
      (B l a r)
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> L l a r)
      l
  checkRightR' l a r =
    set'
      (B l a r)
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> R l a r)
      (\_ _ _ _ _ -> R l a r)
      r
  checkRightB' l a r =
    set'
      (L l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> B l a r)
      (\_ _ _ _ _ -> B l a r)
      r
  checkRightL' l a r =
    set'
      (rebalanceL l a r)
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> L l a r)
      (\_ _ _ _ _ -> L l a r)
      r
  popLeftR l a r =
    set'
      (a, r)
      ( \ll la lr _ _ ->
          (\(a', l') -> (a', checkLeftR l' a r)) $
            popLeftL ll la lr
      )
      (\ll la lr _ _ -> popLeftRB ll la lr a r)
      ( \ll la lr _ _ ->
          (\(a', l') -> (a', checkLeftR l' a r)) $
            popLeftR ll la lr
      )
      l
  popLeftB l a r =
    set'
      (a, E)
      (\ll la lr _ _ -> popLeftBL ll la lr a r)
      (\ll la lr _ _ -> popLeftBB ll la lr a r)
      (\ll la lr _ _ -> popLeftBR ll la lr a r)
      l
  popLeftL l a r =
    set'
      (error "Set.delete: L19")
      ( \ll la lr _ _ ->
          (\(a', l') -> (a', checkLeftL l' a r)) $
            popLeftL ll la lr
      )
      (\ll la lr _ _ -> popLeftLB ll la lr a r)
      ( \ll la lr _ _ ->
          (\(a', l') -> (a', checkLeftL l' a r)) $
            popLeftR ll la lr
      )
      l
  popLeftRB ll la lr a r =
    set'
      (la, rebalanceR E a r)
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', R l a r)) $
            popLeftBL lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', R l a r)) $
            popLeftBB lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', R l a r)) $
            popLeftBR lll lla llr la lr
      )
      ll
  popLeftBB ll la lr a r =
    set'
      (la, R E a r)
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', B l a r)) $
            popLeftBL lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', B l a r)) $
            popLeftBB lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', B l a r)) $
            popLeftBR lll lla llr la lr
      )
      ll
  popLeftLB ll la lr a r =
    set'
      (la, B E a E)
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', L l a r)) $
            popLeftBL lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', L l a r)) $
            popLeftBB lll lla llr la lr
      )
      ( \lll lla llr _ _ ->
          (\(a', l) -> (a', L l a r)) $
            popLeftBR lll lla llr la lr
      )
      ll
  popLeftBR ll la lr a r =
    (\(a', l) -> (a', checkLeftB l a r)) $
      popLeftR ll la lr
  popLeftBL ll la lr a r =
    (\(a', l) -> (a', checkLeftB l a r)) $
      popLeftL ll la lr
  popRightR l a =
    set'
      (error "Set.delete: L20")
      (\rl ra rr _ _ -> first (checkRightR l a) $ popRightL rl ra rr)
      (\rl ra rr _ _ -> popRightRB l a rl ra rr)
      (\rl ra rr _ _ -> first (checkRightR l a) $ popRightR rl ra rr)
  popRightB l a =
    set'
      (E, a)
      (\rl ra rr _ _ -> popRightBL l a rl ra rr)
      (\rl ra rr _ _ -> popRightBB l a rl ra rr)
      (\rl ra rr _ _ -> popRightBR l a rl ra rr)
  popRightL l a =
    set'
      (l, a)
      (\rl ra rr _ _ -> first (checkRightL l a) $ popRightL rl ra rr)
      (\rl ra rr _ _ -> popRightLB l a rl ra rr)
      (\rl ra rr _ _ -> first (checkRightL l a) $ popRightR rl ra rr)
  popRightRB l a rl ra =
    set'
      (B E a E, ra)
      (\rrl rra rrr _ _ -> first (R l a) $ popRightBL rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (R l a) $ popRightBB rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (R l a) $ popRightBR rl ra rrl rra rrr)
  popRightBB l a rl ra =
    set'
      (L l a E, ra)
      (\rrl rra rrr _ _ -> first (B l a) $ popRightBL rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (B l a) $ popRightBB rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (B l a) $ popRightBR rl ra rrl rra rrr)
  popRightLB l a rl ra =
    set'
      (rebalanceL l a E, ra)
      (\rrl rra rrr _ _ -> first (L l a) $ popRightBL rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (L l a) $ popRightBB rl ra rrl rra rrr)
      (\rrl rra rrr _ _ -> first (L l a) $ popRightBR rl ra rrl rra rrr)
  popRightBR l a rl ra rr = first (checkRightB l a) $ popRightR rl ra rr
  popRightBL l a rl ra rr = first (checkRightB l a) $ popRightL rl ra rr

-- | /O(log n)/ Insert an element into a set without checking for membership
insert :: (Ord a) => a -> Set a -> Set a
insert a0 =
  set'
    (B E a0 E)
    (\l a r _ _ -> insertL l a r)
    (\l a r _ _ -> insertB l a r)
    (\l a r _ _ -> insertR l a r)
 where
  insertR l a r =
    ordering
      (insertRl l a r)
      (R l a0 r)
      (insertRr l a r)
      $ compare a0 a
  insertB l a r =
    ordering
      (insertBl l a r)
      (B l a0 r)
      (insertBr l a r)
      $ compare a0 a
  insertL l a r =
    ordering
      (insertLl l a r)
      (L l a0 r)
      (insertLr l a r)
      $ compare a0 a
  insertRl l a r =
    set'
      (B (B E a0 E) a r)
      (\ll la lr _ _ -> R (insertL ll la lr) a r)
      ( \ll la lr _ _ ->
          let l' = insertB ll la lr
           in set'
                (error "Set.insert: L0")
                (\_ _ _ _ _ -> B l' a r)
                (\_ _ _ _ _ -> R l' a r)
                (\_ _ _ _ _ -> B l' a r)
                l'
      )
      (\ll la lr _ _ -> R (insertR ll la lr) a r)
      l
  insertBl l a r =
    set'
      (L (B E a0 E) a r)
      (\ll la lr _ _ -> B (insertL ll la lr) a r)
      ( \ll la lr _ _ ->
          let l' = insertB ll la lr
           in set'
                (error "Set.insert: L1")
                (\_ _ _ _ _ -> L l' a r)
                (\_ _ _ _ _ -> B l' a r)
                (\_ _ _ _ _ -> L l' a r)
                l'
      )
      (\ll la lr _ _ -> B (insertR ll la lr) a r)
      l
  insertBr l a =
    set'
      (R l a $ B E a0 E)
      (\rl ra rr _ _ -> B l a $ insertL rl ra rr)
      ( \rl ra rr _ _ ->
          let r = insertB rl ra rr
           in set'
                (error "Set.insert: L2")
                (\_ _ _ _ _ -> R l a r)
                (\_ _ _ _ _ -> B l a r)
                (\_ _ _ _ _ -> R l a r)
                r
      )
      (\rl ra rr _ _ -> B l a $ insertR rl ra rr)
  insertLr l a =
    set'
      (B l a $ B E a0 E)
      (\rl ra rr _ _ -> L l a $ insertL rl ra rr)
      ( \rl ra rr _ _ ->
          let r = insertB rl ra rr
           in set'
                (error "Set.insert: L3")
                (\_ _ _ _ _ -> B l a r)
                (\_ _ _ _ _ -> L l a r)
                (\_ _ _ _ _ -> B l a r)
                r
      )
      (\rl ra rr _ _ -> L l a $ insertR rl ra rr)
  insertRr l a =
    set'
      (error "Set.insert: L4")
      (\rl ra rr _ _ -> R l a $ insertL rl ra rr)
      ( \rl ra rr _ _ ->
          ordering
            (insertRrl l a rl ra rr)
            (R l a $ B rl a0 rr)
            (insertRrr l a rl ra rr)
            $ compare a0 ra
      )
      (\rl ra rr _ _ -> R l a $ insertR rl ra rr)
  insertLl l a r =
    set'
      (error "Set.insert: L5")
      (\ll la lr _ _ -> L (insertL ll la lr) a r)
      ( \ll la lr _ _ ->
          ordering
            (insertLll ll la lr a r)
            (L (B ll a0 lr) a r)
            (insertLlr ll la lr a r)
            $ compare a0 la
      )
      (\ll la lr _ _ -> L (insertR ll la lr) a r)
      l
  insertRrr l a rl ra =
    set'
      (B (B l a rl) ra $ B E a0 E)
      (\rrl rra rrr _ _ -> R l a . B rl ra $ insertL rrl rra rrr)
      ( \rrl rra rrr _ _ ->
          let rr = insertB rrl rra rrr
           in set'
                (error "Set.insert: L6")
                (\_ _ _ _ _ -> B (B l a rl) ra rr)
                (\_ _ _ _ _ -> R l a $ B rl ra rr)
                (\_ _ _ _ _ -> B (B l a rl) ra rr)
                rr
      )
      (\rrl rra rrr _ _ -> R l a . B rl ra $ insertR rrl rra rrr)
  insertLll ll la lr a r =
    set'
      (B (B E a0 E) la $ B lr a r)
      (\lll lla llr _ _ -> L (B (insertL lll lla llr) la lr) a r)
      ( \lll lla llr _ _ ->
          let ll' = insertB lll lla llr
           in set'
                (error "Set.insert: L7")
                (\_ _ _ _ _ -> B ll' la $ B lr a r)
                (\_ _ _ _ _ -> L (B ll' la lr) a r)
                (\_ _ _ _ _ -> B ll' la $ B lr a r)
                ll'
      )
      (\lll lla llr _ _ -> L (B (insertR lll lla llr) la lr) a r)
      ll
  insertRrl l a rl ra rr =
    set'
      (B (B l a E) a0 $ B E ra rr)
      (\rll rla rlr _ _ -> R l a $ B (insertL rll rla rlr) ra rr)
      ( \rll rla rlr _ _ ->
          let rl' = insertB rll rla rlr
           in set'
                (error "Set.insert: L8")
                (\rll' rla' rlr' _ _ -> B (B l a rll') rla' $ R rlr' ra rr)
                (\_ _ _ _ _ -> R l a $ B rl' ra rr)
                (\rll' rla' rlr' _ _ -> B (L l a rll') rla' $ B rlr' ra rr)
                rl'
      )
      (\rll rla rlr _ _ -> R l a $ B (insertR rll rla rlr) ra rr)
      rl
  insertLlr ll la lr a r =
    set'
      (B (B ll la E) a0 $ B E a r)
      (\lrl lra lrr _ _ -> L (B ll la $ insertL lrl lra lrr) a r)
      ( \lrl lra lrr _ _ ->
          let lr' = insertB lrl lra lrr
           in set'
                (error "Set.insert: L9")
                (\lrl' lra' lrr' _ _ -> B (B ll la lrl') lra' $ R lrr' a r)
                (\_ _ _ _ _ -> L (B ll la lr') a r)
                (\lrl' lra' lrr' _ _ -> B (L ll la lrl') lra' $ B lrr' a r)
                lr'
      )
      (\lrl lra lrr _ _ -> L (B ll la $ insertR lrl lra lrr) a r)
      lr