radix-tree-1.0.0.2: src/Data/Zebra/Word/Internal.hs
{-# LANGUAGE BangPatterns
, PatternSynonyms
, ViewPatterns
, UnboxedTuples
, UnboxedSums #-}
module Data.Zebra.Word.Internal
( Color (..)
, Zebra (Mono, ..)
, Data.Zebra.Word.Internal.lookup
, lookupL
, findL
, lookupR
, findR
, Range (..)
, monoL
, monoR
, monoRange
, unsafeMonoRange
, size
, sizeL
, sizeR
, sizeRange
, unsafeSize
, unsafeSizeL
, unsafeSizeR
, unsafeSizeRange
, fillL
, fillR
, fillRange
, unsafeFillL
, unsafeFillRange
, Data.Zebra.Word.Internal.foldl
, foldlL
, foldlR
, foldlRange
, unsafeFoldlRange
, Data.Zebra.Word.Internal.foldr
, foldrL
, foldrR
, foldrRange
, unsafeFoldrRange
, Data.Zebra.Word.Internal.foldl'
, foldlL'
, foldlR'
, foldlRange'
, unsafeFoldlRange'
, Data.Zebra.Word.Internal.foldr'
, foldrL'
, foldrR'
, foldrRange'
, unsafeFoldrRange'
, Data.Zebra.Word.Internal.complement
, union
, disjoint
, intersection
, difference
, symmetricDifference
, Data.Zebra.Word.Internal.compare
) where
import Radix.Common (PartialOrdering (..), order)
import Radix.Word.Common
import Radix.Word.Foundation
import Data.Bits
import Numeric.Natural
-- | Space partition colors.
data Color = Black
| White
deriving (Show, Eq)
invert :: Color -> (# Color #)
invert Black = (# White #)
invert White = (# Black #)
-- | Fully-strict one-dimensional space partitioning tree.
data Zebra = Bin
{-# UNPACK #-} !Prefix
!Zebra -- ^ Masked bit is @0@.
!Zebra -- ^ Masked bit is not @0@.
| Bla
-- | Invariant: can only be @0@ as the root of the tree.
{-# UNPACK #-} !Key
| Whi
-- | Invariant: can only be @0@ as the root of the tree.
{-# UNPACK #-} !Key
| Nil -- ^ Invariant: unreachable state.
{-# UNPACK #-} !Color
-- | Tree is represented as a list of closed intervals of all 'White' keys.
instance Show Zebra where
showsPrec _ =
let f (UnsafeRange kL kR) c z =
case c of
Black -> z
White -> (kL, kR) : z
in showList . Data.Zebra.Word.Internal.foldr f []
instance Eq Zebra where
(==) = go
where
go l r =
case l of
Bin p xl xr ->
case r of
Bin q yl yr -> p == q && go xl yl && go xr yr
_ -> False
Bla kA ->
case r of
Bla kB -> kA == kB
_ -> False
Whi kA ->
case r of
Whi kB -> kA == kB
_ -> False
Nil _ -> False
-- | \(\mathcal{O}(1)\).
-- All keys are the same color.
pattern Mono :: Color -> Zebra
pattern Mono c <- ( ( \z -> case z of
Bla 0 -> Just Black
Whi 0 -> Just White
_ -> Nothing
)
-> Just c
)
where
Mono Black = Bla 0
Mono White = Whi 0
{-# INLINE join #-}
-- | Knowing that the prefices of two non-'Nil' trees disagree, construct a 'Bin'.
join :: Prefix -> Zebra -> Prefix -> Zebra -> Zebra
join p0 t0 p1 t1 =
let m = branchingBit p0 p1
p = mask p0 m .|. m
in if zeroBit p0 m
then Bin p t0 t1
else Bin p t1 t0
{-# INLINE rebin #-}
-- | Reconstruct a 'Bin' knowing that either of the sides may now be a 'Nil'.
rebin :: Prefix -> Zebra -> Zebra -> Zebra
rebin p l r =
case l of
Nil _ -> r
_ ->
case r of
Nil _ -> l
_ -> Bin p l r
{-# INLINE rebinL #-}
-- | Reconstruct a 'Bin' knowing that the left side may now be a 'Nil'.
rebinL :: Prefix -> Zebra -> Zebra -> Zebra
rebinL p l r =
case l of
Nil _ -> r
_ -> Bin p l r
{-# INLINE rebinR #-}
-- | Reconstruct a 'Bin' knowing that the right side may now be a 'Nil'.
rebinR :: Prefix -> Zebra -> Zebra -> Zebra
rebinR p l r =
case r of
Nil _ -> l
_ -> Bin p l r
{-# INLINE tip #-}
tip :: Key -> Color -> Zebra
tip k Black = Bla k
tip k White = Whi k
-- | \(\mathcal{O}(\min(n,W))\).
-- Check whether all keys smaller than or equal to the given key are of the same color.
monoL :: Word -> Zebra -> Maybe Color
monoL !w = go
where
go t =
case t of
Bin p l _ ->
if w < p
then if w >= lower p
then go l
else let !(# cR #) = colorL l
!(# cL #) = invert cR
in Just cL
else Nothing
Bla k -> goTip Black k
Whi k -> goTip White k
Nil _ -> Nothing
goTip c k
| k == 0 = Just c
| w < k = let !(# x #) = invert c
in Just x
| otherwise = Nothing
-- | \(\mathcal{O}(\min(n,W))\).
-- Check whether all keys greater than or equal to the given key are of the same color.
monoR :: Word -> Zebra -> Maybe Color
monoR !w = go
where
go t =
case t of
Bin p _ r ->
if w < p
then Nothing
else if w <= upper p
then go r
else let !(# cR #) = colorR r
in Just cR
Bla k -> goTip Black k
Whi k -> goTip White k
Nil _ -> Nothing
goTip c k
| w >= k = Just c
| otherwise = Nothing
-- | \(\mathcal{O}(\min(n,W))\).
-- Check whether all keys in the range are of the same color.
monoRange :: Range -> Zebra -> Maybe Color
monoRange (UnsafeRange kL kR)
| kR == maxBound = monoR kL
| otherwise = unsafeMonoRange kL (kR + 1)
-- | \(\mathcal{O}(\min(n,W))\).
-- Check whether all keys in the range are of the same color.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeMonoRange
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> Zebra
-> Maybe Color
unsafeMonoRange !wL !wR = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !mcL = monoR wL l
!mcR = monoL wR r
in if mcL == mcR
then mcL
else Nothing
LT | pM <= upper p -> go r
| p >= lower pM -> if wL >= p
then monoR wL r
else Nothing
| otherwise -> let !(# cR #) = colorR r
in Just cR
GT | p <= upper pM -> if wR <= p
then monoL wR l
else Nothing
| pM >= lower p -> go l
| otherwise -> let !(# cR #) = colorL l
!(# cL #) = invert cR
in Just cL
Bla k -> goTip Black k
Whi k -> goTip White k
Nil _ -> Nothing
goTip c k
| wL >= k = Just c
| wR <= k = let !(# x #) = invert c
in Just x
| otherwise = Nothing
-- | \(\mathcal{O}(n)\).
-- Calculate the number of keys of the given color.
-- The returned number is guaranteed to be in the \([0, 2^W]\) interval.
size :: Color -> Zebra -> Natural
size !x t =
case t of
Bla 0 -> goZero Black
Whi 0 -> goZero White
_ -> fromIntegral $ unsafeSize x t
where
goZero c
| x == c = fromIntegral (maxBound :: Word) + 1
| otherwise = 0
-- | \(\mathcal{O}(n)\).
-- Calculate the number of keys of the given color.
--
-- The tree __must not__ be 'Mono'.
unsafeSize :: Color -> Zebra -> Word
unsafeSize !x = size_ x 0 0
size_ :: Color -> Word -> Word -> Zebra -> Word
size_ !x = go
where
go !kL !kR t =
case t of
Bin p l r ->
let !nL = go kL p l
!nR = go p kR r
in nL + nR
Bla k -> goTip kL kR k Black
Whi k -> goTip kL kR k White
Nil _ -> 0
goTip !kL !kR k c
| x == c = kR - k
| otherwise = k - kL
-- | \(\mathcal{O}(\min(n,W) + n_L)\).
-- Calculate the number of keys of the given color that are smaller than
-- or equal to the given key.
-- The returned number is guaranteed to be in the \([0, 2^W]\) interval.
sizeL :: Color -> Word -> Zebra -> Natural
sizeL x w
| w == maxBound = size x
| otherwise = fromIntegral . unsafeSizeL x (w + 1)
-- | \(\mathcal{O}(\min(n,W) + n_L)\).
-- Calculate the number of keys of the given color that are smaller than the given key.
--
-- The given key __must not__ be equal to @'Data.Bits.maxBound'@.
unsafeSizeL :: Color -> Word -> Zebra -> Word
unsafeSizeL x w = sizeL_ x 0 w
sizeL_ :: Color -> Word -> Word -> Zebra -> Word
sizeL_ !x !kL0 !w = go kL0
where
go !kL t =
case t of
Bin p l r ->
if w < p
then go kL l
else
let !nL = size_ x kL p l
!nR = go p r
in nL + nR
Bla k -> goTip kL k Black
Whi k -> goTip kL k White
Nil _ -> 0
goTip !kL k c
| x == c = if w > k
then w - k
else 0
| otherwise = let i | w > k = k
| otherwise = w
in i - kL
-- | \(\mathcal{O}(\min(n,W) + n_R)\).
-- Calculate the number of keys of the given color that are greater than
-- or equal to the given key.
-- The returned number is guaranteed to be in the \([0, 2^W]\) interval.
sizeR :: Color -> Word -> Zebra -> Natural
sizeR x w
| w == 0 = size x
| otherwise = fromIntegral . unsafeSizeR x w
-- | \(\mathcal{O}(\min(n,W) + n_R)\).
-- Calculate the number of keys of the given color that are greater than
-- or equal to the given key.
--
-- The given key __must not__ be @0@.
unsafeSizeR :: Color -> Word -> Zebra -> Word
unsafeSizeR x w = sizeR_ x w 0
sizeR_ :: Color -> Word -> Word -> Zebra -> Word
sizeR_ !x !w = go
where
go !kR t =
case t of
Bin p l r ->
if w < p
then let !nL = go p l
!nR = size_ x p kR r
in nL + nR
else go kR r
Bla k -> goTip kR k Black
Whi k -> goTip kR k White
Nil _ -> 0
goTip kR k c
| x == c = kR - if w > k
then w
else k
| otherwise = if w < k
then k - w
else 0
-- | \(\mathcal{O}(\min(n,W) + n_I)\).
-- Calculate the number of keys of the given color in the range.
sizeRange :: Color -> Range -> Zebra -> Natural
sizeRange x (UnsafeRange kL kR)
| kR == maxBound = sizeR x kL
| otherwise = fromIntegral . unsafeSizeRange x kL (kR + 1)
-- | \(\mathcal{O}(\min(n,W) + n_I)\).
-- Calculate the number of keys of the given color in the \([k_L, k_R)\) interval.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeSizeRange
:: Color
-> Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> Zebra
-> Word
unsafeSizeRange !x !wL !wR = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !n = sizeR_ x wL p l
!m = sizeL_ x p wR r
in n + m
LT | pM <= upper p -> go r
| p >= lower pM -> if wL < p
then let !n = sizeR_ x wL p l
!m = size_ x p wR r
in n + m
else sizeR_ x wL wR r
| otherwise -> let !(# cR #) = colorR r
in if cR == x
then wR - wL
else 0
GT | p <= upper pM -> if wR >= p
then let !n = size_ x wL p l
!m = sizeL_ x p wR r
in n + m
else sizeL_ x wL wR l
| pM >= lower p -> go l
| otherwise -> let !(# cR #) = colorL l
in if cR == x
then 0
else wR - wL
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> 0
goTip k c
| x == c = if wR >= k
then wR - if wL > k
then wL
else k
else 0
| otherwise = if wL <= k
then let i | wR > k = k
| otherwise = wR
in i - wL
else 0
-- | \(\mathcal{O}(n_R)\).
-- Fold left-to-right over the ranges.
foldl :: (a -> Range -> Color -> a) -> a -> Zebra -> a
foldl f = \z t ->
case t of
Bin _ l r -> let !(# w', x', z' #) = foldl_L 0 f z l
in foldl_R maxBound f w' x' z' r
Bla k -> tipM z k Black
Whi k -> tipM z k White
Nil _ -> z
where
tipM z k c
| k == 0 = let !r = UnsafeRange 0 maxBound
in f z r c
| otherwise = let z' = let !k' = k - 1
!(# x #) = invert c
in f z (UnsafeRange 0 k') x
in f z' (UnsafeRange k maxBound) c
foldl_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #)
foldl_L !wL f = go
where
go z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go z l
in foldl_M f w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c = (# k, c, if k == 0
then z
else let !k' = k - 1
!(# x #) = invert c
in f z (UnsafeRange wL k') x
#)
foldl_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a
foldl_R !wR f = go
where
go !w !x z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = foldl_M f w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c = let z' = let !k' = k - 1
in f z (UnsafeRange w k') x
!r' = UnsafeRange k wR
in f z' r' c
foldl_M :: (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #)
foldl_M f = go
where
go w x z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# w, x, z #)
where
goTip k c = (# k, c, let !k' = k - 1
in f z (UnsafeRange w k') x
#)
-- | \(\mathcal{O}(n_R)\).
-- Fold left-to-right over the ranges of all the keys smaller than
-- or equal to the given one.
foldlL :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlL = foldlL_ 0
foldlL_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlL_ !wL !wR f = go
where
go z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = foldl_L wL f z l
in foldlL_R wR f w' x' z' r
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| k == 0 = let !r = UnsafeRange wL wR
in f z r c
| otherwise =
let !(# x #) = invert c
in if wR < k
then f z (UnsafeRange wL wR) x
else let z' = let !k' = k - 1
in f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
foldlL_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a
foldlL_R !wR f = go
where
go !w !x z t =
case t of
Bin p l r ->
if wR < p
then go w x z l
else let !(# w', x', z' #) = foldl_M f w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| wR < k = let !r = UnsafeRange w wR
in f z r x
| otherwise = let z' = let !k' = k - 1
in f z (UnsafeRange w k') x
in f z' (UnsafeRange k wR) c
-- | \(\mathcal{O}(n_R)\).
-- Fold left-to-right over the ranges of all the keys greater than
-- or equal to the given one.
foldlR :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlR wL = foldlR_ wL maxBound
foldlR_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlR_ !wL !wR f = go
where
go z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldlR_L wL f z l
in foldl_R wR f w' x' z' r
else go z r
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f z (UnsafeRange wL wR) c
| otherwise = let !k' = k - 1
!(# x #) = invert c
z' = f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
foldlR_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #)
foldlR_L !wL f = go
where
go z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = go z l
in foldl_M f w' x' z' r
else go z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c
| wL >= k = (# wL, c, z #)
| otherwise = let !k' = k - 1
!(# x #) = invert c
in (# k, c, f z (UnsafeRange wL k') x #)
-- | \(\mathcal{O}(\min(n,W) + n_{I_R})\).
-- Fold left-to-right over the ranges of all the keys in the given range.
foldlRange :: Range -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlRange (UnsafeRange wL wR) f z
| wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t
in f z (UnsafeRange wL wR) c
| otherwise = unsafeFoldlRange wL wR f z
-- | \(\mathcal{O}(n)\).
-- Fold left-to-right over the ranges of all the keys
-- in the \([k_L, k_R)\) interval.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeFoldlRange
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> (a -> Range -> Color -> a)
-> a
-> Zebra
-> a
unsafeFoldlRange !wL !wR f = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go z t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !(# w', x', z' #) = foldlR_L wL f z l
in foldlL_R wR f w' x' z' r
LT | pM <= upper p -> go z r
| p >= lower pM -> if wL < p
then let !(# w', x', z' #) = foldlR_L wL f z l
in foldl_R wR f w' x' z' r
else foldlR_ wL wR f z r
| otherwise -> let !(# cR #) = colorR r
in f z (UnsafeRange wL wR) cR
GT | p <= upper pM -> if wR >= p
then let !(# w', x', z' #) = foldl_L wL f z l
in foldlL_R wR f w' x' z' r
else foldlL_ wL wR f z l
| pM >= lower p -> go z l
| otherwise -> let !(# cR #) = colorL l
!(# cL #) = invert cR
in f z (UnsafeRange wL wR) cL
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f z (UnsafeRange wL wR) c
| otherwise =
let !(# x #) = invert c
in if wR < k
then f z (UnsafeRange wL wR) x
else let !k' = k - 1
z' = f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
-- | \(\mathcal{O}(n_L)\).
-- Fold right-to-left over the ranges.
foldr :: (Range -> Color -> a -> a) -> a -> Zebra -> a
foldr f = \z t ->
case t of
Bin _ l r -> let !(# w', x', z' #) = foldr_R maxBound f z r
in foldr_L 0 f w' x' z' l
Bla k -> goTip z k Black
Whi k -> goTip z k White
Nil _ -> z
where
goTip z k c
| k == 0 = f (UnsafeRange 0 maxBound) c z
| otherwise = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange 0 k') x $ f (UnsafeRange k maxBound) c z
foldr_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #)
foldr_R !wR f = go
where
go z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go z r
in foldr_M f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c = let !k' = k - 1
in (# k', c, f (UnsafeRange k wR) c z #)
foldr_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a
foldr_L !wL f = go
where
go !w !x z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = foldr_M f w x z r
in go w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL w) c z
| otherwise = let !k' = k - 1
in f (UnsafeRange wL k') x $ f (UnsafeRange k w) c z
foldr_M
:: (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #)
foldr_M f = go
where
go w x z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go w x z r
in go w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# w, x, z #)
where
goTip k c = let !k' = k - 1
in (# k', c, f (UnsafeRange k w) c z #)
-- | \(\mathcal{O}(n_L)\).
-- Fold right-to-left over the ranges of all the keys greater than
-- or equal to the given one.
foldrR :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrR wL = foldrR_ wL maxBound
foldrR_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrR_ !wL !wR f = go
where
go z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldr_R wR f z r
in foldrR_L wL f w' x' z' l
else go z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL wR) c z
| wL < k = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z
| otherwise = f (UnsafeRange wL wR) c z
foldrR_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a
foldrR_L !wL f = go
where
go !w !x z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldr_M f w x z r
in go w' x' z' l
else go w x z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| wL < k = let !k' = k - 1
in f (UnsafeRange wL k') x $ f (UnsafeRange k w) c z
| otherwise = f (UnsafeRange wL w) c z
-- | \(\mathcal{O}(n_L)\).
-- Fold right-to-left over the ranges of all the keys smaller than
-- or equal to the given one.
foldrL :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrL = foldrL_ 0
foldrL_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrL_ !wL !wR f = go
where
go z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = foldrL_R wR f z r
in foldr_L wL f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL wR) c z
| wR >= k = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z
| otherwise = let !(# x #) = invert c
in f (UnsafeRange wL wR) x z
foldrL_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #)
foldrL_R !wR f = go
where
go z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = go z r
in foldr_M f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c
| wR >= k = let !k' = k - 1
in (# k', c, f (UnsafeRange k wR) c z #)
| otherwise = (# wR, c, z #)
-- | \(\mathcal{O}(\min(n,W) + n_{I_L})\).
-- Fold right-to-left over the ranges of all the keys in the given range.
foldrRange :: Range -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrRange (UnsafeRange wL wR) f z
| wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t
in f (UnsafeRange wL wR) c z
| otherwise = unsafeFoldrRange wL wR f z
-- | \(\mathcal{O}(\min(n,W) + n_{I_L})\).
-- Fold right-to-left over the ranges of all the keys
-- in the \([k_L, k_R)\) interval.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeFoldrRange
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> (Range -> Color -> a -> a)
-> a
-> Zebra
-> a
unsafeFoldrRange !wL !wR f = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go z t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !(# w', x', z' #) = foldrL_R wR f z r
in foldrR_L wL f w' x' z' l
LT | pM <= upper p -> go z r
| p >= lower pM -> if wL < p
then let !(# w', x', z' #) = foldrL_R wR f z r
in foldr_L wL f w' x' z' l
else foldrR_ wL wR f z r
| otherwise -> let !(# cR #) = colorR r
in f (UnsafeRange wL wR) cR z
GT | p <= upper pM -> if wR >= p
then let !(# w', x', z' #) = foldr_R wR f z r
in foldrR_L wL f w' x' z' l
else foldrL_ wL wR f z l
| pM >= lower p -> go z l
| otherwise -> let !(# cR #) = colorL l
!(# cL #) = invert cR
in f (UnsafeRange wL wR) cL z
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f (UnsafeRange wL wR) c z
| otherwise =
let !(# x #) = invert c
in if wR < k
then f (UnsafeRange wL wR) x z
else let !k' = k - 1
in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z
-- | \(\mathcal{O}(n)\).
-- Fold left-to-right over the ranges with a strict accumulator.
foldl' :: (a -> Range -> Color -> a) -> a -> Zebra -> a
foldl' f = \ !z t ->
case t of
Bin _ l r -> let !(# w', x', z' #) = foldl'_L 0 f z l
in foldl'_R maxBound f w' x' z' r
Bla k -> goTip z k Black
Whi k -> goTip z k White
Nil _ -> z
where
goTip z k c
| k == 0 = f z (UnsafeRange 0 maxBound) c
| otherwise = let !z' = let !k' = k - 1
!(# x #) = invert c
in f z (UnsafeRange 0 k') x
in f z' (UnsafeRange k maxBound) c
foldl'_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #)
foldl'_L !wL f = go
where
go !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go z l
in foldl'_M f w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c = let !k' = k - 1
!(# x #) = invert c
in (# k, c, if k == 0
then z
else f z (UnsafeRange wL k') x #)
foldl'_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a
foldl'_R !wR f = go
where
go !w !x !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = foldl'_M f w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c = let !z' = f z (UnsafeRange w (k - 1)) x
in f z' (UnsafeRange k wR) c
foldl'_M
:: (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #)
foldl'_M f = go
where
go w x !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# w, x, z #)
where
goTip k c = (# k, c, f z (UnsafeRange w (k - 1)) x #)
-- | \(\mathcal{O}(n)\).
-- Fold left-to-right over the ranges of all the keys smaller than
-- or equal to the given one.
foldlL' :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlL' = foldlL'_ 0
foldlL'_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlL'_ !wL !wR f = go
where
go !z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = foldl'_L wL f z l
in foldlL'_R wR f w' x' z' r
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| k == 0 = f z (UnsafeRange wL wR) c
| wR < k = let !(# x #) = invert c
in f z (UnsafeRange wL wR) x
| otherwise = let !z' = let !k' = k - 1
!(# x #) = invert c
in f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
foldlL'_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a
foldlL'_R !wR f = go
where
go !w !x !z t =
case t of
Bin p l r ->
if wR < p
then go w x z l
else let !(# w', x', z' #) = foldl'_M f w x z l
in go w' x' z' r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| wR < k = f z (UnsafeRange w wR) x
| otherwise = let z' = f z (UnsafeRange w (k - 1)) x
in f z' (UnsafeRange k wR) c
-- | \(\mathcal{O}(n)\).
-- Fold left-to-right over the ranges of all the keys greater than
-- or equal to the given one.
foldlR' :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlR' wL = foldlR'_ wL maxBound
foldlR'_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlR'_ !wL !wR f = go
where
go !z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldlR'_L wL f z l
in foldl'_R wR f w' x' z' r
else go z r
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f z (UnsafeRange wL wR) c
| otherwise = let !z' = let !k' = k - 1
!(# x #) = invert c
in f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
foldlR'_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #)
foldlR'_L !wL f = go
where
go !z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = go z l
in foldl'_M f w' x' z' r
else go z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c
| wL >= k = (# wL, c, z #)
| otherwise = let !k' = k - 1
!(# x #) = invert c
in (# k, c, f z (UnsafeRange wL k') x #)
-- | \(\mathcal{O}(\min(n,W) + n_I)\).
-- Fold left-to-right over the ranges of all the keys in the given range.
foldlRange' :: Range -> (a -> Range -> Color -> a) -> a -> Zebra -> a
foldlRange' (UnsafeRange wL wR) f z
| wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t
in f z (UnsafeRange wL wR) c
| otherwise = unsafeFoldlRange' wL wR f z
-- | \(\mathcal{O}(n)\).
-- Fold left-to-right over the ranges of all the keys
-- in the \([k_L, k_R)\) interval.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeFoldlRange'
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> (a -> Range -> Color -> a)
-> a
-> Zebra
-> a
unsafeFoldlRange' !wL !wR f = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go z t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !(# w', x', z' #) = foldlR'_L wL f z l
in foldlL'_R wR f w' x' z' r
LT | pM <= upper p -> go z r
| p >= lower pM -> if wL < p
then let !(# w', x', z' #) = foldlR'_L wL f z l
in foldl'_R wR f w' x' z' r
else foldlR'_ wL wR f z r
| otherwise -> let !(# cR #) = colorR r
in f z (UnsafeRange wL wR) cR
GT | p <= upper pM -> if wR >= p
then let !(# w', x', z' #) = foldl'_L wL f z l
in foldlL'_R wR f w' x' z' r
else foldlL'_ wL wR f z l
| pM >= lower p -> go z l
| otherwise -> let !(# cR #) = colorL l
!(# cL #) = invert cR
in f z (UnsafeRange wL wR) cL
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f z (UnsafeRange wL wR) c
| otherwise =
let !(# x #) = invert c
in if wR < k
then f z (UnsafeRange wL wR) x
else let !k' = k - 1
z' = f z (UnsafeRange wL k') x
in f z' (UnsafeRange k wR) c
-- | \(\mathcal{O}(n)\).
-- Fold right-to-left over the ranges.
foldr' :: (Range -> Color -> a -> a) -> a -> Zebra -> a
foldr' f = \ !z t ->
case t of
Bin _ l r -> let !(# w', x', z' #) = foldr'_R maxBound f z r
in foldr'_L 0 f w' x' z' l
Bla k -> goTip z k Black
Whi k -> goTip z k White
Nil _ -> z
where
goTip z k c
| k == 0 = f (UnsafeRange 0 maxBound) c z
| otherwise = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange 0 k') x $! f (UnsafeRange k maxBound) c z
foldr'_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #)
foldr'_R !wR f = go
where
go !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go z r
in foldr'_M f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c = let !k' = k - 1
in (# k', c, f (UnsafeRange k wR) c z #)
foldr'_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a
foldr'_L !wL f = go
where
go !w !x !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = foldr'_M f w x z r
in go w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL w) c z
| otherwise = let !k' = k - 1
in f (UnsafeRange wL k') x $! f (UnsafeRange k w) c z
foldr'_M
:: (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #)
foldr'_M f = go
where
go w x !z t =
case t of
Bin _ l r -> let !(# w', x', z' #) = go w x z r
in go w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# w, x, z #)
where
goTip k c = let !k' = k - 1
in (# k', c, f (UnsafeRange k w) c z #)
-- | \(\mathcal{O}(n)\).
-- Fold right-to-left over the ranges of all the keys greater than
-- or equal to the given one.
foldrR' :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrR' wL = foldrR'_ wL maxBound
foldrR'_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrR'_ !wL !wR f = go
where
go !z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldr'_R wR f z r
in foldrR'_L wL f w' x' z' l
else go z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL wR) c z
| wL < k = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z
| otherwise = f (UnsafeRange wL wR) c z
foldrR'_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a
foldrR'_L !wL f = go
where
go !w !x !z t =
case t of
Bin p l r ->
if wL < p
then let !(# w', x', z' #) = foldr'_M f w x z r
in go w' x' z' l
else go w x z r
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| wL < k = let !k' = k - 1
in f (UnsafeRange wL k') x $! f (UnsafeRange k w) c z
| otherwise = f (UnsafeRange wL w) c z
-- | \(\mathcal{O}(n)\).
-- Fold right-to-left over the ranges of all the keys smaller than
-- or equal to the given one.
foldrL' :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrL' = foldrL'_ 0
foldrL'_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrL'_ !wL !wR f = go
where
go !z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = foldrL'_R wR f z r
in foldr'_L wL f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> z
where
goTip k c
| k == 0 = f (UnsafeRange wL wR) c z
| wR >= k = let !k' = k - 1
!(# x #) = invert c
in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z
| otherwise = let !(# x #) = invert c
in f (UnsafeRange wL wR) x z
foldrL'_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #)
foldrL'_R !wR f = go
where
go !z t =
case t of
Bin p l r ->
if wR < p
then go z l
else let !(# w', x', z' #) = go z r
in foldr'_M f w' x' z' l
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> (# 0, Black, z #)
where
goTip k c
| wR >= k = let !k' = k - 1
in (# k', c, f (UnsafeRange k wR) c z #)
| otherwise = (# wR, c, z #)
-- | \(\mathcal{O}(\min(n,W) + n_I)\).
-- Fold right-to-left with a strict accumulator over the ranges of all the keys
-- in the given range.
foldrRange' :: Range -> (Range -> Color -> a -> a) -> a -> Zebra -> a
foldrRange' (UnsafeRange wL wR) f !z
| wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t
in f (UnsafeRange wL wR) c z
| otherwise = unsafeFoldrRange' wL wR f z
-- | \(\mathcal{O}(\min(n,W) + n_I)\).
-- Fold right-to-left with a strict accumulator over the ranges of all the keys
-- in the \([k_L, k_R)\) interval.
--
-- \(k_R\) __must__ be greater than \(k_L\).
unsafeFoldrRange'
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> (Range -> Color -> a -> a)
-> a
-> Zebra
-> a
unsafeFoldrRange' !wL !wR f = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
go !z t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> let !(# w', x', z' #) = foldrL'_R wR f z r
in foldrR'_L wL f w' x' z' l
LT | pM <= upper p -> go z r
| p >= lower pM -> if wL < p
then let !(# w', x', z' #) = foldrL'_R wR f z r
in foldr'_L wL f w' x' z' l
else foldrR'_ wL wR f z r
| otherwise -> let !(# cR #) = colorR r
in f (UnsafeRange wL wR) cR z
GT | p <= upper pM -> if wR >= p
then let !(# w', x', z' #) = foldr'_R wR f z r
in foldrR'_L wL f w' x' z' l
else foldrL'_ wL wR f z l
| pM >= lower p -> go z l
| otherwise -> let !(# cR #) = colorL l
!(# cL #) = invert cR
in f (UnsafeRange wL wR) cL z
Bla k -> tipM k Black
Whi k -> tipM k White
Nil _ -> z
where
tipM k c
| wL >= k = f (UnsafeRange wL wR) c z
| otherwise =
let !(# x #) = invert c
in if wR < k
then f (UnsafeRange wL wR) x z
else let !k' = k - 1
in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z
-- | \(\mathcal{O}(\min(n,W))\).
-- Look up the color of the key.
lookup :: Word -> Zebra -> Color
lookup !w = go
where
go t =
case t of
Bin p l r ->
if w < p
then if w >= lower p
then go l
else let !(# cR #) = colorL l
!(# cL #) = invert cR
in cL
else if w <= upper p
then go r
else let !(# cR #) = colorR r
in cR
Bla k -> goTip k Black
Whi k -> goTip k White
Nil _ -> Black
goTip k c
| w < k = let !(# cL #) = invert c
in cL
| otherwise = c
-- | \(\mathcal{O}(\min(n,W))\).
-- Look up the key of the given color that is smaller than or equal to the given key.
lookupL :: Color -> Word -> Zebra -> Maybe Word
lookupL !x !w = go (Nil Black)
where
go !v t =
case t of
Bin p l r
| w < p -> go v l
| otherwise -> go l r
Bla k -> goTip Black k v
Whi k -> goTip White k v
Nil _ -> Nothing
goTip c k v =
case w >= k of
True
| k == 0 -> if c == x
then Just w
else Nothing
| otherwise -> Just $! if c == x
then w
else k - 1
False
| c == x -> case v of
Nil _ -> Nothing
_ -> let !(# kL #) = keyR v
in Just $! kL - 1
| otherwise -> Just w
-- | \(\mathcal{O}(\min(n,W))\).
-- Look up the key of the given color that is smaller than or equal to the given key,
-- falling back to the default value if no such key exists.
findL
:: Word -- ^ Default value
-> Color
-> Word -- ^ Key
-> Zebra
-> Word
findL d !x !w = go (Nil Black)
where
go !v t =
case t of
Bin p l r
| w < p -> go v l
| otherwise -> go l r
Bla k -> goTip Black k v
Whi k -> goTip White k v
Nil _ -> d
goTip c k v =
case w >= k of
True
| k == 0 -> if c == x
then w
else d
| c == x -> w
| otherwise -> k - 1
False
| c == x -> case v of
Nil _ -> d
_ -> let !(# kL #) = keyR v
in kL - 1
| otherwise -> w
-- | \(\mathcal{O}(\min(n,W))\).
-- Look up the key of the given color that is greater than or equal to the given key.
lookupR :: Color -> Word -> Zebra -> Maybe Word
lookupR !x !w = go (Nil Black)
where
go !v t =
case t of
Bin p l r
| w < p -> go r l
| otherwise -> go v r
Bla k -> goTip Black k v
Whi k -> goTip White k v
Nil _ -> Nothing
goTip c k v =
case w < k of
True -> Just $! if c == x
then k
else w
False
| c == x -> Just w
| otherwise -> case v of
Nil _ -> Nothing
_ -> let !(# kR #) = keyL v
in Just kR
-- | \(\mathcal{O}(\min(n,W))\).
-- Look up the key of the given color that is greater than or equal to the given key,
-- falling back to the default value if no such key exists.
findR
:: Word -- ^ Default value
-> Color
-> Word -- ^ Key
-> Zebra
-> Word
findR d !x !w = go (Nil Black)
where
go !v t =
case t of
Bin p l r
| w < p -> go r l
| otherwise -> go v r
Bla k -> goTip Black k v
Whi k -> goTip White k v
Nil _ -> d
goTip c k v =
case w < k of
True
| c == x -> k
| otherwise -> w
False
| c == x -> w
| otherwise -> case v of
Nil _ -> d
_ -> let !(# kR #) = keyL v
in kR
-- | \(\mathcal{O}(\min(n,W))\).
-- Set every key smaller than or equal to the given one to the given color.
fillL :: Word -> Color -> Zebra -> Zebra
fillL w x
| w == maxBound = \_ -> Mono x
| otherwise = unsafeFillL (w + 1) x
-- | \(\mathcal{O}(\min(n,W))\).
-- Set every key smaller than the given one to the given color.
--
-- The given key __must not__ be @0@.
unsafeFillL :: Word -> Color -> Zebra -> Zebra
unsafeFillL w x = \t ->
case fillL_ w x t of
Nil _ -> Mono x
t' -> t'
fillL_ :: Word -> Color -> Zebra -> Zebra
fillL_ !w !x = go
where
go t =
case t of
Bin p l r ->
if w < p
then if w >= lower p
then rebinL p (go l) r
else let !(# cR #) = colorL l
in if cR == x
then let !(# cL #) = invert cR
in join w (tip w cL) p t
else t
else if w <= upper p
then go r
else let !(# cR #) = colorR r
in if cR == x
then Nil Black
else tip w cR
Bla k -> goTip Black k t
Whi k -> goTip White k t
Nil _ -> t
goTip c k t
| w >= k = if c == x
then Nil Black
else if w == k
then t
else tip w c
| otherwise = if c == x
then let !(# cL #) = invert x
in join w (tip w cL) k t
else t
-- | \(\mathcal{O}(\min(n,W))\).
-- Set every key greater than or equal to the given one to the given color.
fillR :: Word -> Color -> Zebra -> Zebra
fillR w x = \t ->
case fillR_ w x t of
Nil _ -> Mono x
t' -> t'
fillR_ :: Word -> Color -> Zebra -> Zebra
fillR_ !w !x = go
where
go t =
case t of
Bin p l r ->
if w < p
then if w >= lower p
then go l
else let !(# cR #) = colorL l
in if cR == x
then tip w x
else Nil Black
else if w <= upper p
then rebinR p l (go r)
else let !(# cR #) = colorR r
in if cR == x
then t
else join w (tip w x) p t
Bla k -> goTip Black k t
Whi k -> goTip White k t
Nil _ -> t
goTip c k t
| w <= k = if c == x
then if w == k
then t
else tip w c
else Nil Black
| otherwise = if c == x
then t
else if k == 0
then tip w x
else join w (tip w x) k t
-- | \(\mathcal{O}(\min(n,W))\).
-- Set every key in the range to the given color.
fillRange :: Range -> Color -> Zebra -> Zebra
fillRange (UnsafeRange wL wR) x
| wL == 0 = fillL wR x
| wR == maxBound = fillR wL x
| otherwise = unsafeFillRange wL (wR + 1) x
-- | \(\mathcal{O}(\min(n,W) + n_L)\).
-- Set every key in the \([k_L, k_R)\) interval to the given color.
--
-- \(k_L\) __must not__ be @0@. \(k_R\) __must__ be greater than \(k_L\).
unsafeFillRange
:: Word -- ^ \(k_L\)
-> Word -- ^ \(k_R\)
-> Color
-> Zebra
-> Zebra
unsafeFillRange wL wR x t =
case fillRange_ x wL wR t of
Nil _ -> Mono x
t' -> t'
fillRange_ :: Color -> Word -> Word -> Zebra -> Zebra
fillRange_ !x !wL !wR = go
where
!mM = branchingBit wL wR
!pM = mask wL mM .|. mM
binM = let !(# c #) = invert x
in Bin pM (tip wL x) (tip wR c)
go t =
case t of
Bin p l r ->
case Prelude.compare p pM of
EQ -> rebin p (fillR_ wL x l) (fillL_ wR x r)
LT | pM <= upper p -> rebinR p l (go r)
| p >= lower pM -> let l' = if wL < p
then fillR_ wL x l
else rebinR p l (fillR_ wL x r)
!(# cR #) = colorR r
in if cR == x
then l'
else join p l' pM (tip wR cR)
| otherwise ->
let !(# cR #) = colorR r
in if cR == x
then t
else join p t pM binM
GT | p <= upper pM -> let r' = if wR >= p
then fillL_ wR x r
else rebinL p (fillL_ wR x l) r
!(# cR #) = colorL l
in if cR == x
then join pM (tip wL x) p r'
else r'
| pM >= lower p -> rebinL p (go l) r
| otherwise ->
let !(# cR #) = colorL l
in if cR == x
then join p t pM binM
else t
Bla k -> goTip k Black t
Whi k -> goTip k White t
Nil _ -> t
goTip k c t
| wR < k = if c == x
then if xor wL wR < xor wR k
then join k t pM binM
else let !(# o #) = invert x
!mJ = branchingBit wR k
!pJ = mask wR mJ .|. mJ
in join
wL (tip wL x)
pJ (Bin pJ (tip wR o) t)
else t
| k < wL = if c == x
then t
else if xor k wL > xor wL wR
then join k t pM binM
else let !mJ = branchingBit k wL
!pJ = mask k mJ .|. mJ
in join
pJ (Bin pJ t (tip wL x))
wR (tip wR c)
| otherwise =
let w = if c == x
then wL
else wR
in tip w c
colorL :: Zebra -> (# Color #)
colorL t =
case t of
Bin _ l _ -> colorL l
Bla _ -> (# Black #)
_ -> (# White #)
colorR :: Zebra -> (# Color #)
colorR t =
case t of
Bin _ _ r -> colorR r
Bla _ -> (# Black #)
_ -> (# White #)
keyL :: Zebra -> (# Word #)
keyL t =
case t of
Bin _ l _ -> keyL l
Bla k -> (# k #)
Whi k -> (# k #)
Nil _ -> (# 0 #)
keyR :: Zebra -> (# Word #)
keyR t =
case t of
Bin _ _ r -> keyR r
Bla k -> (# k #)
Whi k -> (# k #)
Nil _ -> (# 0 #)
-- | \(\mathcal{O}(n)\).
-- Invert the colors of all keys.
complement :: Zebra -> Zebra
complement t =
case t of
Bin p l r -> Bin p (Data.Zebra.Word.Internal.complement l)
(Data.Zebra.Word.Internal.complement r)
Bla k -> Whi k
Whi k -> Bla k
Nil _ -> t
-- | \(\mathcal{O}(n_A + n_B)\).
-- Union of two trees over the given color.
union :: Color -> Zebra -> Zebra -> Zebra
union x l r =
case l of
Mono c | c == x -> l
| otherwise -> r
_ ->
case r of
Mono c | c == x -> r
| otherwise -> l
_ ->
case anyAny l r of
Nil _ -> Mono x
t -> t
where
anyAny tA tB =
case tA of
Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB
Bla kA -> tipAny (# kA, Black #) tA tB
Whi kA -> tipAny (# kA, White #) tA tB
Nil _ -> tA
tipAny uA@(# kA, cA #) tA tB =
case tB of
Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> tB
where
goTip kB cB
| cA == cB = if (cA == x) == (kA < kB)
then tA
else tB
| otherwise = if kA == kB || ((cA == x) == (kA < kB))
then Nil Black
else join kA tA kB tB
binAny uA tA tB =
case tB of
Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB
Bla kB -> tipBin (# kB, Black #) tB uA tA
Whi kB -> tipBin (# kB, White #) tB uA tA
Nil _ -> tB
tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) tB =
if kA < pB
then if kA >= lower pB
then if cA == x
then tipAny uA tA lB
else rebinL pB (tipAny uA tA lB) rB
else let !(# cB #) = colorL lB
in if cA == cB
then if cA == x
then tA
else tB
else if cA == x
then Nil Black
else join kA tA pB tB
else if kA <= upper pB
then if cA == x
then rebinR pB lB (tipAny uA tA rB)
else tipAny uA tA rB
else let !(# cB #) = colorR rB
in if cA == cB
then if cA == x
then tB
else tA
else if cA == x
then join kA tA pB tB
else Nil Black
binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB =
case Prelude.compare pA pB of
EQ -> rebin pA (anyAny lA lB) (anyAny rA rB)
LT | pB <= upper pA -> let !(# cR #) = colorL lB
in if cR == x
then rebinR pA lA (binAny uB tB rA)
else binAny uB tB rA
| pA >= lower pB -> let !(# cL #) = colorR rA
in if cL == x
then binAny uA tA lB
else rebinL pB (binAny uA tA lB) rB
| otherwise ->
let !(# cA #) = colorR rA
!(# cB #) = colorL lB
in if cA == cB
then if cA == x
then tA
else tB
else if cA == x
then Nil Black
else join pA tA pB tB
GT | pA <= upper pB -> let !(# cR #) = colorL lA
in if cR == x
then rebinR pB lB (binAny uA tA rB)
else binAny uA tA rB
| pB >= lower pA -> let !(# cL #) = colorR rB
in if cL == x
then binAny uB tB lA
else rebinL pA (binAny uB tB lA) rA
| otherwise ->
let !(# cB #) = colorR rB
!(# cA #) = colorL lA
in if cA == cB
then if cA == x
then tB
else tA
else if cA == x
then join pA tA pB tB
else Nil Black
-- | \(\mathcal{O}(n_A + n_B)\).
-- Intersection of two trees over the given color.
intersection :: Color -> Zebra -> Zebra -> Zebra
intersection x =
let !(# c #) = invert x
in union c
-- | \(\mathcal{O}(n_A + n_B)\).
-- Determine whether two trees are disjoint over the given color.
disjoint :: Color -> Zebra -> Zebra -> Bool
disjoint x l r =
case l of
Mono c -> c /= x
_ ->
case r of
Mono c -> c /= x
_ -> anyAny l r
where
anyAny tA tB =
case tA of
Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB
Bla kA -> tipAny (# kA, Black #) tA tB
Whi kA -> tipAny (# kA, White #) tA tB
Nil _ -> False
tipAny uA@(# kA, cA #) tA tB =
case tB of
Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #)
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> False
where
goTip kB cB
| cA == cB = False
| otherwise = kA == kB || ((cA == x) == (kA < kB))
binAny uA tA tB =
case tB of
Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB
Bla kB -> tipBin (# kB, Black #) tB uA
Whi kB -> tipBin (# kB, White #) tB uA
Nil _ -> False
tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) =
if kA < pB
then if kA >= lower pB
then cA == x && tipAny uA tA lB
else let !(# cB #) = colorL lB
in cA /= cB && cA == x
else if kA <= upper pB
then cA /= x && tipAny uA tA rB
else let !(# cB #) = colorR rB
in cA /= cB && cB == x
binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB =
case Prelude.compare pA pB of
EQ -> anyAny lA lB && anyAny rA rB
LT | pB <= upper pA -> let !(# cR #) = colorL lB
in cR /= x && binAny uB tB rA
| pA >= lower pB -> let !(# cL #) = colorR rA
in cL == x && binAny uA tA lB
| otherwise ->
let !(# cA #) = colorR rA
!(# cB #) = colorL lB
in cA /= cB && cA == x
GT | pA <= upper pB -> let !(# cR #) = colorL lA
in cR /= x && binAny uA tA rB
| pB >= lower pA -> let !(# cL #) = colorR rB
in cL == x && binAny uB tB lA
| otherwise ->
let !(# cB #) = colorR rB
!(# cA #) = colorL lA
in cA /= cB && cB == x
-- | \(\mathcal{O}(n_A + n_B)\).
-- Difference of two trees over the given color.
difference :: Color -> Zebra -> Zebra -> Zebra
difference x l r =
case l of
Mono c | c == x -> Data.Zebra.Word.Internal.complement r
| otherwise -> l
_ ->
case r of
Mono c | c == x -> let !(# x' #) = invert x
in Mono x'
| otherwise -> l
_ ->
case anyAny L l r of
Nil _ -> let !(# c #) = invert x
in Mono c
t -> t
where
anyAny s tA tB =
case tA of
Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB
Bla kA -> tipAny s (# kA, Black #) tA tB
Whi kA -> tipAny s (# kA, White #) tA tB
Nil _ -> tA
tipAny s uA@(# kA, cA #) tA tB =
case tB of
Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> tB
where
goTip kB cB =
case s of
L -> goTipL kA cA tA kB cB
R -> goTipL kB cB tB kA cA
goTipL kL cL tL kR cR =
case Prelude.compare kL kR of
EQ -> if cL == cR
then Nil Black
else tL
LT -> if cL == cR
then if cL == x
then let !(# c #) = invert x
in join kL tL kR (tip kR c)
else Nil Black
else if cL == x
then tip kR x
else tL
GT -> if cL == cR
then if cL == x
then Nil Black
else join kL tL kR (tip kR x)
else if cL == x
then tL
else tip kR cL
binAny s uA tA tB =
case tB of
Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> tB
where
goTip kB cB =
let !(# s' #) = other s
in tipBin s' (# kB, cB #) tB uA tA
tipBin s uA@(# kA, cA #) tA (# pB, lB, rB #) tB =
case s of
L -> if kA < pB
then if kA >= lower pB
then if cA == x
then rebinL pB (tipAny s uA tA lB)
(Data.Zebra.Word.Internal.complement rB)
else tipAny s uA tA lB
else let !(# cR #) = colorL lB
in if cA == cR
then if cA == x
then join kA tA
pB $ Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else Nil Black
else if cA == x
then Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else tA
else if kA <= upper pB
then if cA == x
then tipAny s uA tA rB
else rebinR pB (Data.Zebra.Word.Internal.complement lB)
(tipAny s uA tA rB)
else let !(# cL #) = colorR rB
in if cA == cL
then if cA == x
then Nil Black
else join kA tA
pB $ Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else if cA == x
then tA
else Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
R -> if kA < pB
then if kA >= lower pB
then if cA == x
then tipAny s uA tA lB
else rebinL pB (tipAny s uA tA lB) rB
else let !(# cR #) = colorL lB
in if cA == cR
then if cA == x
then Nil Black
else join kA (tip kA x) pB tB
else if cA == x
then tip kA cR
else tB
else if kA <= upper pB
then if cA == x
then rebinR pB lB (tipAny s uA tA rB)
else tipAny s uA tA rB
else let !(# cL #) = colorR rB
in if cA == cL
then if cA == x
then let !(# c #) = invert x
in join kA (tip kA c) pB tB
else Nil Black
else if cA == x
then tB
else tip kA cL
binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB =
case Prelude.compare pA pB of
EQ -> rebin pB (anyAny s lA lB) (anyAny s rA rB)
LT | pB <= upper pA -> let !(# s' #) = other s
!(# cR #) = colorL lB
in case s of
L -> if cR == x
then rebinR pA lA (binAny s' uB tB rA)
else binAny s' uB tB rA
R -> if cR == x
then binAny s' uB tB rA
else rebinR pA (Data.Zebra.Word.Internal.complement lA)
(binAny s' uB tB rA)
| pA >= lower pB -> let !(# cL #) = colorR rA
in case s of
L -> if cL == x
then rebinL pB (binAny s uA tA lB)
(Data.Zebra.Word.Internal.complement rB)
else binAny s uA tA lB
R -> if cL == x
then binAny s uA tA lB
else rebinL pB (binAny s uA tA lB) rB
| otherwise ->
let !(# cA #) = colorR rA
!(# cB #) = colorL lB
in case s of
L -> if cA == cB
then if cA == x
then join pA tA
pB $ Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else Nil Black
else if cA == x
then Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else tA
R -> if cA == cB
then if cA == x
then Nil Black
else join pB tB
pA $ Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
else if cA == x
then Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
else tB
GT | pA <= upper pB -> let !(# cR #) = colorL lA
in case s of
L -> if cR == x
then binAny s uA tA rB
else rebinR pB
(Data.Zebra.Word.Internal.complement lB)
(binAny s uA tA rB)
R -> if cR == x
then rebinR pB lB (binAny s uA tA rB)
else binAny s uA tA rB
| pB >= lower pA -> let !(# s' #) = other s
!(# cL #) = colorR rB
in case s of
L -> if cL == x
then binAny s' uB tB lA
else rebinL pA (binAny s' uB tB lA) rA
R -> if cL == x
then rebinL pA (binAny s' uB tB lA)
(Data.Zebra.Word.Internal.complement rA)
else binAny s' uB tB lA
| otherwise ->
let !(# cB #) = colorR rB
!(# cA #) = colorL lA
in case s of
L -> if cA == cB
then if cA == x
then Nil Black
else join pA tA
pB $ Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
else if cA == x
then tA
else Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
R -> if cA == cB
then if cA == x
then join pB tB
pA $ Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
else Nil Black
else if cA == x
then tB
else Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
-- | \(\mathcal{O}(n_A + n_B)\).
-- Symmetric difference of two trees over the given color.
symmetricDifference :: Color -> Zebra -> Zebra -> Zebra
symmetricDifference xFG l r =
case l of
Mono c | c == xFG -> Data.Zebra.Word.Internal.complement r
| otherwise -> r
_ ->
case r of
Mono c | c == xFG -> Data.Zebra.Word.Internal.complement l
| otherwise -> l
_ ->
case anyAny l r of
Nil c -> Mono c
t -> t
where
anyAny tA tB =
case tA of
Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB
Bla kA -> tipAny (# kA, Black #) tA tB
Whi kA -> tipAny (# kA, White #) tA tB
Nil _ -> tA
tipAny uA@(# kA, cA #) tA tB =
case tB of
Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> tB
where
goTip kB cB
| kA == kB = Nil $ if cA == cB
then let !(# xBG #) = invert xFG
in xBG
else xFG
| otherwise = let nA | (cB == xFG) == (kA < kB) = tA
| otherwise = let !(# c #) = invert cA
in tip kA c
nB | (cA == xFG) == (kA < kB) = let !(# c #) = invert cB
in tip kB c
| otherwise = tB
in join kA nA kB nB
binAny uA tA tB =
case tB of
Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB
Bla kB -> tipBin (# kB, Black #) tB uA tA
Whi kB -> tipBin (# kB, White #) tB uA tA
Nil _ -> tB
tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) tB =
if kA < pB
then if kA >= lower pB
then let r' | cA == xFG = Data.Zebra.Word.Internal.complement rB
| otherwise = rB
in rebinL pB (tipAny uA tA lB) r'
else let !(# cL #) = colorL lB
nA | cL == xFG = tA
| otherwise = let !(# c #) = invert cA
in tip kA c
nB | cA == xFG = Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
| otherwise = tB
in join kA nA pB nB
else if kA <= upper pB
then let l' | cA == xFG = lB
| otherwise = Data.Zebra.Word.Internal.complement lB
in rebinR pB l' (tipAny uA tA rB)
else let !(# cR #) = colorR rB
nA | cR == xFG = let !(# c #) = invert cA
in tip kA c
| otherwise = tA
nB | cA == xFG = tB
| otherwise = Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
in join kA nA pB nB
binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB =
case Prelude.compare pA pB of
EQ -> rebin pA (anyAny lA lB) (anyAny rA rB)
LT | pB <= upper pA -> let !(# cR #) = colorL lB
l' | cR == xFG = lA
| otherwise = Data.Zebra.Word.Internal.complement lA
in rebinR pA l' (binAny uB tB rA)
| pA >= lower pB -> let !(# cL #) = colorR rA
r' | cL == xFG = Data.Zebra.Word.Internal.complement rB
| otherwise = rB
in rebinL pB (binAny uA tA lB) r'
| otherwise ->
let !(# cA #) = colorR rA
!(# cB #) = colorL lB
nA | cB == xFG = tA
| otherwise = Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
nB | cA == xFG = Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
| otherwise = tB
in join pA nA pB nB
GT | pA <= upper pB -> let !(# cR #) = colorL lA
l' | cR == xFG = lB
| otherwise = Data.Zebra.Word.Internal.complement lB
in rebinR pB l' (binAny uA tA rB)
| pB >= lower pA -> let !(# cL #) = colorR rB
r' | cL == xFG = Data.Zebra.Word.Internal.complement rA
| otherwise = rA
in rebinL pA (binAny uB tB lA) r'
| otherwise ->
let !(# cB #) = colorR rB
!(# cA #) = colorL lA
nA | cB == xFG = Bin pA (Data.Zebra.Word.Internal.complement lA)
(Data.Zebra.Word.Internal.complement rA)
| otherwise = tA
nB | cA == xFG = tB
| otherwise = Bin pB (Data.Zebra.Word.Internal.complement lB)
(Data.Zebra.Word.Internal.complement rB)
in join pA nA pB nB
data S = L | R
deriving Show
other :: S -> (# S #)
other L = (# R #)
other R = (# L #)
-- | \(\mathcal{O}(n_A + n_B)\).
-- Compare two trees with respect to set inclusion over the given color.
compare :: Color -> Zebra -> Zebra -> PartialOrdering
compare x l r =
case l of
Mono cA ->
case r of
Mono cB | cA == cB -> Equal
| cA == x -> Superset
| otherwise -> Subset
_ | cA == x -> Superset
| otherwise -> Subset
_ ->
case r of
Mono cB | cB == x -> Subset
| otherwise -> Superset
_ -> anyAny L l r
where
anyAny s tA tB =
case tA of
Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB
Bla kA -> tipAny s (# kA, Black #) tA tB
Whi kA -> tipAny s (# kA, White #) tA tB
Nil _ -> Incomparable
tipAny s uA@(# kA, cA #) tA tB =
case tB of
Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #)
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> Incomparable
where
goTip kB cB
| cA == cB = if kA == kB
then Equal
else if (cA == x) == (kA < kB)
then case s of
L -> Superset
R -> Subset
else case s of
L -> Subset
R -> Superset
| otherwise = Incomparable
binAny s uA tA tB =
case tB of
Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB
Bla kB -> goTip kB Black
Whi kB -> goTip kB White
Nil _ -> Incomparable
where
goTip kB cB = let !(# s' #) = other s
in tipBin s' (# kB, cB #) tB uA
tipBin s uA@(# kA, cA #) tA (# pB, lB, rB #) =
if kA < pB
then if kA >= lower pB
then let !(# o #) = if cA == x
then case s of
L -> (# Superset #)
R -> (# Subset #)
else case s of
L -> (# Subset #)
R -> (# Superset #)
in order o (tipAny s uA tA lB)
else let !(# cR #) = colorL lB
in if cA == cR
then if cA == x
then case s of
L -> Superset
R -> Subset
else case s of
L -> Subset
R -> Superset
else Incomparable
else if kA <= upper pB
then let !(# o #) = if cA == x
then case s of
L -> (# Subset #)
R -> (# Superset #)
else case s of
L -> (# Superset #)
R -> (# Subset #)
in order o (tipAny s uA tA rB)
else let !(# cL #) = colorR rB
in if cA == cL
then if cA == x
then case s of
L -> Subset
R -> Superset
else case s of
L -> Superset
R -> Subset
else Incomparable
binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB =
case Prelude.compare pA pB of
EQ -> order (anyAny s lA lB) (anyAny s rA rB)
LT | pB <= upper pA -> let !(# s' #) = other s
!(# cR #) = colorL lB
!(# o #) = if cR == x
then case s of
L -> (# Superset #)
R -> (# Subset #)
else case s of
L -> (# Subset #)
R -> (# Superset #)
in order o (binAny s' uB tB rA)
| pA >= lower pB -> let !(# cL #) = colorR rA
!(# o #) = if cL == x
then case s of
L -> (# Superset #)
R -> (# Subset #)
else case s of
L -> (# Subset #)
R -> (# Superset #)
in order o (binAny s uA tA lB)
| otherwise -> let !(# cL #) = colorR rA
!(# cR #) = colorL lB
in if cL == cR
then if cL == x
then case s of
L -> Superset
R -> Subset
else case s of
L -> Subset
R -> Superset
else Incomparable
GT | pA <= upper pB -> let !(# cR #) = colorL lA
!(# o #) = if cR == x
then case s of
L -> (# Subset #)
R -> (# Superset #)
else case s of
L -> (# Superset #)
R -> (# Subset #)
in order o (binAny s uA tA rB)
| pB >= lower pA -> let !(# s' #) = other s
!(# cL #) = colorR rB
!(# o #) = if cL == x
then case s of
L -> (# Subset #)
R -> (# Superset #)
else case s of
L -> (# Superset #)
R -> (# Subset #)
in order o (binAny s' uB tB lA)
| otherwise -> let !(# cL #) = colorR rB
!(# cR #) = colorL lA
in if cL == cR
then if cL == x
then case s of
L -> Subset
R -> Superset
else case s of
L -> Superset
R -> Subset
else Incomparable