IntervalTree.hs

module IntervalTree (interval, toList, delete, deleteRange)
where 

data IntervalTree = Empty | Range Int Int | Split Int Int Int IntervalTree IntervalTree deriving Show

interval :: Int -> Int -> IntervalTree
interval x y | y < x = Empty
interval x y = Range x y

toList :: IntervalTree -> [Int]
toList Empty = []
toList (Range x y) = [x..y]
toList (Split _ _ _ x y) = toList x ++ toList y

delete :: Int -> IntervalTree -> IntervalTree
delete i x | not (x `couldPossiblyContain` i) = x
delete i (Range x y) | i == x = interval (x + 1) y
delete i (Range x y) | i == y = interval x (y - 1)
delete i (Range x y) = delete i (newsplit  x y)
delete i (Split m _ _ x y) | i <= m = join m (delete i x) y
delete i (Split m _ _ x y) = join m x (delete i y)

deleteRange :: Int -> Int -> IntervalTree -> IntervalTree
deleteRange _ _ Empty = Empty
deleteRange _ y t | y < lowerBound t = t
deleteRange x _ t | x > upperBound t = t
deleteRange x y t | x <= lowerBound t && y >= upperBound t = Empty
deleteRange x y (Range m n) | x <= m = interval (y + 1) n
deleteRange x y (Range m n) | y >= n = interval m (x - 1)
deleteRange x y (Range m n) = deleteRange x y (newsplit m n)
deleteRange x y (Split k _ _ l r) = join k (deleteRange x y l) (deleteRange x y r)

newsplit :: Int -> Int -> IntervalTree
newsplit x y = Split m x y (interval x m) (interval (m + 1) y)
  where m = (x + y) `div` 2

join :: Int -> IntervalTree -> IntervalTree -> IntervalTree
join m Empty y = y
join m x Empty = x
join m x y = Split m (lowerBound x) (upperBound y) x y

couldPossiblyContain :: IntervalTree -> Int -> Bool
couldPossiblyContain Empty _ = False
couldPossiblyContain x i = (lowerBound x <= i) && (upperBound x >= i)

lowerBound :: IntervalTree -> Int
lowerBound (Range x _) = x
lowerBound (Split _ lb _ _ _) = lb

upperBound :: IntervalTree -> Int
upperBound (Range _ y) = y
upperBound (Split _ _ ub _ _) = ub