{-|
Description      : Utilities for balanced binary trees.
Copyright        : (c) Galois, Inc 2014-2019
Maintainer       : Joe Hendrix <jhendrix@galois.com>
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE Safe #-}
module Data.Parameterized.Utils.BinTree
  ( MaybeS(..)
  , fromMaybeS
  , Updated(..)
  , updatedValue
  , TreeApp(..)
  , IsBinTree(..)
  , balanceL
  , balanceR
  , glue
  , merge
  , filterGt
  , filterLt
  , insert
  , delete
  , union
  , link
  , PairS(..)
  ) where

import Control.Applicative

------------------------------------------------------------------------
-- MaybeS

-- | A strict version of 'Maybe'
data MaybeS v
   = JustS !v
   | NothingS

instance Functor MaybeS where
  fmap :: forall a b. (a -> b) -> MaybeS a -> MaybeS b
fmap a -> b
_ MaybeS a
NothingS = forall v. MaybeS v
NothingS
  fmap a -> b
f (JustS a
v) = forall v. v -> MaybeS v
JustS (a -> b
f a
v)

instance Alternative MaybeS where
  empty :: forall v. MaybeS v
empty = forall v. MaybeS v
NothingS
  mv :: MaybeS a
mv@JustS{} <|> :: forall a. MaybeS a -> MaybeS a -> MaybeS a
<|> MaybeS a
_ = MaybeS a
mv
  MaybeS a
NothingS <|> MaybeS a
v = MaybeS a
v

instance Applicative MaybeS where
  pure :: forall v. v -> MaybeS v
pure = forall v. v -> MaybeS v
JustS

  MaybeS (a -> b)
NothingS <*> :: forall a b. MaybeS (a -> b) -> MaybeS a -> MaybeS b
<*> MaybeS a
_ = forall v. MaybeS v
NothingS
  JustS{} <*> MaybeS a
NothingS = forall v. MaybeS v
NothingS
  JustS a -> b
f <*> JustS a
x = forall v. v -> MaybeS v
JustS (a -> b
f a
x)

fromMaybeS :: a -> MaybeS a -> a
fromMaybeS :: forall a. a -> MaybeS a -> a
fromMaybeS a
r MaybeS a
NothingS = a
r
fromMaybeS a
_ (JustS a
v) = a
v

------------------------------------------------------------------------
-- Updated

-- | @Updated a@ contains a value that has been flagged on whether it was
-- modified by an operation.
data Updated a
   = Updated   !a
   | Unchanged !a

updatedValue :: Updated a -> a
updatedValue :: forall a. Updated a -> a
updatedValue (Updated a
a) = a
a
updatedValue (Unchanged a
a) = a
a

------------------------------------------------------------------------
-- IsBinTree

data TreeApp e t
   = BinTree !e !t !t
   | TipTree

class IsBinTree t e | t -> e where
  asBin :: t -> TreeApp e t
  tip :: t

  bin :: e -> t -> t -> t
  size :: t -> Int

delta,ratio :: Int
delta :: Int
delta = Int
3
ratio :: Int
ratio = Int
2

-- | @balanceL p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@.
--
-- It assumes that @l@ and @r@ are close to being balanced, and that only
-- @l@ may contain too many elements.
balanceL :: (IsBinTree c e) => e -> c -> c -> c
balanceL :: forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
p c
l c
r = do
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
l of
    BinTree e
l_pair c
ll c
lr | forall t e. IsBinTree t e => t -> Int
size c
l forall a. Ord a => a -> a -> Bool
> forall a. Ord a => a -> a -> a
max Int
1 (Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
r) ->
      case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
lr of
        BinTree e
lr_pair c
lrl c
lrr | forall t e. IsBinTree t e => t -> Int
size c
lr forall a. Ord a => a -> a -> Bool
>= forall a. Ord a => a -> a -> a
max Int
2 (Int
ratioforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
ll) ->
          forall c e. IsBinTree c e => e -> c -> c -> c
bin e
lr_pair (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
l_pair c
ll c
lrl) (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
lrr c
r)
        TreeApp e c
_ -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
l_pair c
ll (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
lr c
r)

    TreeApp e c
_ -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
l c
r
{-# INLINE balanceL #-}

-- | @balanceR p l r@ returns a balanced tree for the sequence @l ++ [p] ++ r@.
--
-- It assumes that @l@ and @r@ are close to being balanced, and that only
-- @r@ may contain too many elements.
balanceR :: (IsBinTree c e) => e -> c -> c -> c
balanceR :: forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
p c
l c
r = do
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
r of
    BinTree e
r_pair c
rl c
rr | forall t e. IsBinTree t e => t -> Int
size c
r forall a. Ord a => a -> a -> Bool
> forall a. Ord a => a -> a -> a
max Int
1 (Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
l) ->
      case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
rl of
        BinTree e
rl_pair c
rll c
rlr | forall t e. IsBinTree t e => t -> Int
size c
rl forall a. Ord a => a -> a -> Bool
>= forall a. Ord a => a -> a -> a
max Int
2 (Int
ratioforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
rr) ->
          (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
rl_pair forall a b. (a -> b) -> a -> b
$! forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
l c
rll) forall a b. (a -> b) -> a -> b
$! forall c e. IsBinTree c e => e -> c -> c -> c
bin e
r_pair c
rlr c
rr
        TreeApp e c
_ -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
r_pair (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
l c
rl) c
rr
    TreeApp e c
_ -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
l c
r
{-# INLINE balanceR #-}

-- | Insert a new maximal element.
insertMax :: IsBinTree c e => e -> c -> c
insertMax :: forall c e. IsBinTree c e => e -> c -> c
insertMax e
p c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p forall t e. IsBinTree t e => t
tip forall t e. IsBinTree t e => t
tip
    BinTree e
q c
l c
r -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
q c
l (forall c e. IsBinTree c e => e -> c -> c
insertMax e
p c
r)

-- | Insert a new minimal element.
insertMin :: IsBinTree c e => e -> c -> c
insertMin :: forall c e. IsBinTree c e => e -> c -> c
insertMin e
p c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p forall t e. IsBinTree t e => t
tip forall t e. IsBinTree t e => t
tip
    BinTree e
q c
l c
r -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
q (forall c e. IsBinTree c e => e -> c -> c
insertMin e
p c
l) c
r

-- | @link@ is called to insert a key and value between two disjoint subtrees.
link :: IsBinTree c e => e -> c -> c -> c
link :: forall c e. IsBinTree c e => e -> c -> c -> c
link e
p c
l c
r =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
l, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
r) of
    (TreeApp e c
TipTree, TreeApp e c
_) -> forall c e. IsBinTree c e => e -> c -> c
insertMin e
p c
r
    (TreeApp e c
_, TreeApp e c
TipTree) -> forall c e. IsBinTree c e => e -> c -> c
insertMax e
p c
l
    (BinTree e
py c
ly c
ry, BinTree e
pz c
lz c
rz)
     | Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
l forall a. Ord a => a -> a -> Bool
< forall t e. IsBinTree t e => t -> Int
size c
r -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
pz (forall c e. IsBinTree c e => e -> c -> c -> c
link e
p c
l c
lz) c
rz
     | Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
r forall a. Ord a => a -> a -> Bool
< forall t e. IsBinTree t e => t -> Int
size c
l -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
py c
ly (forall c e. IsBinTree c e => e -> c -> c -> c
link e
p c
ry c
r)
     | Bool
otherwise             -> forall c e. IsBinTree c e => e -> c -> c -> c
bin e
p c
l c
r
{-# INLINE link #-}

-- | A Strict pair
data PairS f s = PairS !f !s

deleteFindMin :: IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMin :: forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMin e
p c
l c
r =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
l of
    TreeApp e c
TipTree -> forall f s. f -> s -> PairS f s
PairS e
p c
r
    BinTree e
lp c
ll c
lr ->
      case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMin e
lp c
ll c
lr of
        PairS e
q c
l' -> forall f s. f -> s -> PairS f s
PairS e
q (forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
p c
l' c
r)
{-# INLINABLE deleteFindMin #-}

deleteFindMax :: IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMax :: forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMax e
p c
l c
r =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
r of
    TreeApp e c
TipTree -> forall f s. f -> s -> PairS f s
PairS e
p c
l
    BinTree e
rp c
rl c
rr ->
      case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMax e
rp c
rl c
rr of
        PairS e
q c
r' -> forall f s. f -> s -> PairS f s
PairS e
q (forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
p c
l c
r')
{-# INLINABLE deleteFindMax #-}

-- | Concatenate two trees that are ordered with respect to each other.
merge :: IsBinTree c e => c -> c -> c
merge :: forall c e. IsBinTree c e => c -> c -> c
merge c
l c
r =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
l, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
r) of
    (TreeApp e c
TipTree, TreeApp e c
_) -> c
r
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
l
    (BinTree e
x c
lx c
rx, BinTree e
y c
ly c
ry)
      | Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
l forall a. Ord a => a -> a -> Bool
< forall t e. IsBinTree t e => t -> Int
size c
r -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
y (forall c e. IsBinTree c e => c -> c -> c
merge c
l c
ly) c
ry
      | Int
deltaforall a. Num a => a -> a -> a
*forall t e. IsBinTree t e => t -> Int
size c
r forall a. Ord a => a -> a -> Bool
< forall t e. IsBinTree t e => t -> Int
size c
l -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
x c
lx (forall c e. IsBinTree c e => c -> c -> c
merge c
rx c
r)
      | forall t e. IsBinTree t e => t -> Int
size c
l forall a. Ord a => a -> a -> Bool
> forall t e. IsBinTree t e => t -> Int
size c
r ->
        case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMax e
x c
lx c
rx of
          PairS e
q c
l' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
q c
l' c
r
      | Bool
otherwise ->
        case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMin e
y c
ly c
ry of
          PairS e
q c
r' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
q c
l c
r'
{-# INLINABLE merge #-}

------------------------------------------------------------------------
-- Ordered operations

-- | @insert p m@ inserts the binding into @m@.  It returns
-- an Unchanged value if the map stays the same size and an updated
-- value if a new entry was inserted.
insert :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> Updated c
insert :: forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> Updated c
insert e -> e -> Ordering
comp e
x c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall a. a -> Updated a
Updated (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
x forall t e. IsBinTree t e => t
tip forall t e. IsBinTree t e => t
tip)
    BinTree e
y c
l c
r ->
      case e -> e -> Ordering
comp e
x e
y of
        Ordering
LT ->
          case forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> Updated c
insert e -> e -> Ordering
comp e
x c
l of
            Updated c
l'   -> forall a. a -> Updated a
Updated   (forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
y c
l' c
r)
            Unchanged c
l' -> forall a. a -> Updated a
Unchanged (forall c e. IsBinTree c e => e -> c -> c -> c
bin       e
y c
l' c
r)
        Ordering
GT ->
          case forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> Updated c
insert e -> e -> Ordering
comp e
x c
r of
            Updated c
r'   -> forall a. a -> Updated a
Updated   (forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
y c
l c
r')
            Unchanged c
r' -> forall a. a -> Updated a
Unchanged (forall c e. IsBinTree c e => e -> c -> c -> c
bin       e
y c
l c
r')
        Ordering
EQ -> forall a. a -> Updated a
Unchanged (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
x c
l c
r)
{-# INLINABLE insert #-}

-- | @glue l r@ concatenates @l@ and @r@.
--
-- It assumes that @l@ and @r@ are already balanced with respect to each other.
glue :: IsBinTree c e => c -> c -> c
glue :: forall c e. IsBinTree c e => c -> c -> c
glue c
l c
r =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
l, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
r) of
    (TreeApp e c
TipTree, TreeApp e c
_) -> c
r
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
l
    (BinTree e
x c
lx c
rx, BinTree e
y c
ly c
ry)
     | forall t e. IsBinTree t e => t -> Int
size c
l forall a. Ord a => a -> a -> Bool
> forall t e. IsBinTree t e => t -> Int
size c
r ->
       case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMax e
x c
lx c
rx of
         PairS e
q c
l' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
q c
l' c
r
     | Bool
otherwise ->
       case forall c e. IsBinTree c e => e -> c -> c -> PairS e c
deleteFindMin e
y c
ly c
ry of
         PairS e
q c
r' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
q c
l c
r'
{-# INLINABLE glue #-}

delete :: IsBinTree c e
       => (e -> Ordering)
          -- ^ Predicate that returns whether the entry is less than, greater than, or equal
          -- to the key we are entry that we are looking for.
       -> c
       -> MaybeS c
delete :: forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
delete e -> Ordering
k c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall v. MaybeS v
NothingS
    BinTree e
p c
l c
r ->
      case e -> Ordering
k e
p of
        Ordering
LT -> (\c
l' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
p c
l' c
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
delete e -> Ordering
k c
l
        Ordering
GT -> (\c
r' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
p c
l c
r') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
delete e -> Ordering
k c
r
        Ordering
EQ -> forall v. v -> MaybeS v
JustS (forall c e. IsBinTree c e => c -> c -> c
glue c
l c
r)
{-# INLINABLE delete #-}

------------------------------------------------------------------------
-- filter

-- | Returns only entries that are less than predicate with respect to the ordering
-- and Nothing if no elements are discarded.
filterGt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt :: forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt e -> Ordering
k c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall v. MaybeS v
NothingS
    BinTree e
x c
l c
r ->
      case e -> Ordering
k e
x of
        Ordering
LT -> (\c
l' -> forall c e. IsBinTree c e => e -> c -> c -> c
link e
x c
l' c
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt e -> Ordering
k c
l
        Ordering
GT -> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt e -> Ordering
k c
r forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall v. v -> MaybeS v
JustS c
r
        Ordering
EQ -> forall v. v -> MaybeS v
JustS c
r
{-# INLINABLE filterGt #-}


-- | @filterLt k m@ returns submap of @m@ that only contains entries
-- that are smaller than @k@.  If no entries are deleted then return Nothing.
filterLt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt :: forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt e -> Ordering
k c
t =
  case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
    TreeApp e c
TipTree -> forall v. MaybeS v
NothingS
    BinTree e
x c
l c
r ->
      case e -> Ordering
k e
x of
        Ordering
LT -> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt e -> Ordering
k c
l forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall v. v -> MaybeS v
JustS c
l
        Ordering
GT -> (\c
r' -> forall c e. IsBinTree c e => e -> c -> c -> c
link e
x c
l c
r') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt e -> Ordering
k c
r
        Ordering
EQ -> forall v. v -> MaybeS v
JustS c
l
{-# INLINABLE filterLt #-}

------------------------------------------------------------------------
-- Union

-- | Insert a new key and value in the map if it is not already present.
-- Used by 'union'.
insertR :: forall c e . (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c
insertR :: forall c e. IsBinTree c e => (e -> e -> Ordering) -> e -> c -> c
insertR e -> e -> Ordering
comp e
e c
m = forall a. a -> MaybeS a -> a
fromMaybeS c
m (e -> c -> MaybeS c
go e
e c
m)
  where
    go :: e -> c -> MaybeS c
    go :: e -> c -> MaybeS c
go e
x c
t =
      case forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t of
        TreeApp e c
TipTree -> forall v. v -> MaybeS v
JustS (forall c e. IsBinTree c e => e -> c -> c -> c
bin e
x forall t e. IsBinTree t e => t
tip forall t e. IsBinTree t e => t
tip)
        BinTree e
y c
l c
r ->
          case e -> e -> Ordering
comp e
x e
y of
            Ordering
LT -> (\c
l' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceL e
y c
l' c
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> c -> MaybeS c
go e
x c
l
            Ordering
GT -> (\c
r' -> forall c e. IsBinTree c e => e -> c -> c -> c
balanceR e
y c
l c
r') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> c -> MaybeS c
go e
x c
r
            Ordering
EQ -> forall v. MaybeS v
NothingS
{-# INLINABLE insertR #-}

-- | Union two sets
union :: (IsBinTree c e) => (e -> e -> Ordering) -> c -> c -> c
union :: forall c e. IsBinTree c e => (e -> e -> Ordering) -> c -> c -> c
union e -> e -> Ordering
comp c
t1 c
t2 =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t1, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t2) of
    (TreeApp e c
TipTree, TreeApp e c
_) -> c
t2
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
t1
    (TreeApp e c
_, BinTree e
p (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree) (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree)) -> forall c e. IsBinTree c e => (e -> e -> Ordering) -> e -> c -> c
insertR e -> e -> Ordering
comp e
p c
t1
    (BinTree e
x c
l c
r, TreeApp e c
_) ->
      forall c e. IsBinTree c e => e -> c -> c -> c
link e
x
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_UB e -> e -> Ordering
comp e
x   c
l c
t2)
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_LB e -> e -> Ordering
comp e
x c
r   c
t2)
{-# INLINABLE union #-}

-- | Hedge union where we only add elements in second map if key is
-- strictly above a lower bound.
hedgeUnion_LB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_LB :: forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_LB e -> e -> Ordering
comp e
lo c
t1 c
t2 =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t1, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t2) of
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
t1
    (TreeApp e c
TipTree, TreeApp e c
_) -> forall a. a -> MaybeS a -> a
fromMaybeS c
t2 (forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt (e -> e -> Ordering
comp e
lo) c
t2)
    -- Prune left tree.
    (TreeApp e c
_, BinTree e
k c
_ c
r) | e -> e -> Ordering
comp e
k e
lo forall a. Ord a => a -> a -> Bool
<= Ordering
EQ -> forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_LB e -> e -> Ordering
comp e
lo c
t1 c
r
    -- Special case when t2 is a single element.
    (TreeApp e c
_, BinTree e
x (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree) (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree)) -> forall c e. IsBinTree c e => (e -> e -> Ordering) -> e -> c -> c
insertR e -> e -> Ordering
comp e
x c
t1
    -- Split on left-and-right subtrees of t1.
    (BinTree e
x c
l c
r, TreeApp e c
_) ->
      forall c e. IsBinTree c e => e -> c -> c -> c
link e
x
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
lo e
x  c
l c
t2)
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_LB    e -> e -> Ordering
comp e
x     c
r c
t2)
{-# INLINABLE hedgeUnion_LB #-}

-- | Hedge union where we only add elements in second map if key is
-- strictly below a upper bound.
hedgeUnion_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_UB :: forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_UB e -> e -> Ordering
comp e
hi c
t1 c
t2 =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t1, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t2) of
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
t1
    (TreeApp e c
TipTree, TreeApp e c
_) -> forall a. a -> MaybeS a -> a
fromMaybeS c
t2 (forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt (e -> e -> Ordering
comp e
hi) c
t2)
    -- Prune right tree.
    (TreeApp e c
_, BinTree e
x c
l c
_) | e -> e -> Ordering
comp e
x e
hi forall a. Ord a => a -> a -> Bool
>= Ordering
EQ -> forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_UB e -> e -> Ordering
comp e
hi c
t1 c
l
    -- Special case when t2 is a single element.
    (TreeApp e c
_, BinTree e
x (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree) (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree))  -> forall c e. IsBinTree c e => (e -> e -> Ordering) -> e -> c -> c
insertR e -> e -> Ordering
comp e
x c
t1
    -- Split on left-and-right subtrees of t1.
    (BinTree e
x c
l c
r, TreeApp e c
_) ->
      forall c e. IsBinTree c e => e -> c -> c -> c
link e
x
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> c -> c -> c
hedgeUnion_UB    e -> e -> Ordering
comp e
x      c
l c
t2)
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
x  e
hi  c
r c
t2)
{-# INLINABLE hedgeUnion_UB #-}

-- | Hedge union where we only add elements in second map if key is
-- strictly between a lower and upper bound.
hedgeUnion_LB_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB :: forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
lo e
hi c
t1 c
t2 =
  case (forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t1, forall t e. IsBinTree t e => t -> TreeApp e t
asBin c
t2) of
    (TreeApp e c
_, TreeApp e c
TipTree) -> c
t1
    -- Prune left tree.
    (TreeApp e c
_,   BinTree e
k c
_ c
r) | e -> e -> Ordering
comp e
k e
lo forall a. Ord a => a -> a -> Bool
<= Ordering
EQ -> forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
lo e
hi c
t1 c
r
    -- Prune right tree.
    (TreeApp e c
_,   BinTree e
k c
l c
_) | e -> e -> Ordering
comp e
k e
hi forall a. Ord a => a -> a -> Bool
>= Ordering
EQ -> forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
lo e
hi c
t1 c
l
    -- When t1 becomes empty (assumes lo <= k <= hi)
    (TreeApp e c
TipTree, BinTree e
x c
l c
r) ->
      case (forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterGt (e -> e -> Ordering
comp e
lo) c
l, forall c e. IsBinTree c e => (e -> Ordering) -> c -> MaybeS c
filterLt (e -> e -> Ordering
comp e
hi) c
r) of
        -- No variables in t2 were eliminated.
        (MaybeS c
NothingS, MaybeS c
NothingS) -> c
t2
        -- Relink t2 with filtered elements removed.
        (MaybeS c
l',MaybeS c
r') -> forall c e. IsBinTree c e => e -> c -> c -> c
link e
x (forall a. a -> MaybeS a -> a
fromMaybeS c
l MaybeS c
l') (forall a. a -> MaybeS a -> a
fromMaybeS c
r MaybeS c
r')
    -- Special case when t2 is a single element.
    (TreeApp e c
_, BinTree e
x (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree) (forall t e. IsBinTree t e => t -> TreeApp e t
asBin -> TreeApp e c
TipTree)) -> forall c e. IsBinTree c e => (e -> e -> Ordering) -> e -> c -> c
insertR e -> e -> Ordering
comp e
x c
t1
    -- Split on left-and-right subtrees of t1.
    (BinTree e
x c
l c
r, TreeApp e c
_) ->
      forall c e. IsBinTree c e => e -> c -> c -> c
link e
x
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
lo e
x  c
l c
t2)
           (forall c e.
IsBinTree c e =>
(e -> e -> Ordering) -> e -> e -> c -> c -> c
hedgeUnion_LB_UB e -> e -> Ordering
comp e
x  e
hi c
r c
t2)
{-# INLINABLE hedgeUnion_LB_UB #-}