{-# LANGUAGE Safe #-}
module Data.Range.RangeInternal where
import Data.Maybe (catMaybes)
import Data.Range.Data
import Data.Range.Spans
import Data.Range.Util
import Control.Monad (guard)
data RangeMerge a = RM
{ largestLowerBound :: Maybe (Bound a)
, largestUpperBound :: Maybe (Bound a)
, spanRanges :: [(Bound a, Bound a)]
}
| IRM
deriving (Show, Eq)
emptyRangeMerge :: RangeMerge a
emptyRangeMerge = RM Nothing Nothing []
storeRange :: (Ord a) => Range a -> RangeMerge a
storeRange InfiniteRange = IRM
storeRange (LowerBoundRange lower) = emptyRangeMerge { largestLowerBound = Just lower }
storeRange (UpperBoundRange upper) = emptyRangeMerge { largestUpperBound = Just upper }
storeRange (SpanRange x@(Bound xValue xType) y@(Bound yValue yType))
| xValue == yValue && pointJoinType xType yType == Separate = emptyRangeMerge
| otherwise = emptyRangeMerge { spanRanges = [(minBounds x y, maxBounds x y)] }
storeRange (SingletonRange x) = emptyRangeMerge { spanRanges = [(Bound x Inclusive, Bound x Inclusive)] }
storeRanges :: (Ord a) => RangeMerge a -> [Range a] -> RangeMerge a
storeRanges start ranges = foldr unionRangeMerges start (map storeRange ranges)
loadRanges :: (Ord a) => [Range a] -> RangeMerge a
loadRanges = storeRanges emptyRangeMerge
{-# INLINE[0] loadRanges #-}
exportRangeMerge :: (Eq a) => RangeMerge a -> [Range a]
exportRangeMerge IRM = [InfiniteRange]
exportRangeMerge (RM lb up spans) = putUpperBound up ++ putSpans spans ++ putLowerBound lb
where
putLowerBound :: Maybe (Bound a) -> [Range a]
putLowerBound = maybe [] (return . LowerBoundRange)
putUpperBound :: Maybe (Bound a) -> [Range a]
putUpperBound = maybe [] (return . UpperBoundRange)
putSpans = map simplifySpan
simplifySpan (x@(Bound xv xType), y@(Bound _ yType)) = if (x == y) && (pointJoinType xType yType /= Separate)
then SingletonRange xv
else SpanRange x y
{-# RULES "load/export" [1] forall x. loadRanges (exportRangeMerge x) = x #-}
intersectSpansRM :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a
intersectSpansRM one two = RM Nothing Nothing newSpans
where
newSpans = intersectSpans (spanRanges one) (spanRanges two)
intersectWith :: (Ord a) => (Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)) -> Maybe (Bound a) -> [(Bound a, Bound a)] -> [(Bound a, Bound a)]
intersectWith _ Nothing _ = []
intersectWith fix (Just lower) xs = catMaybes $ fmap (fix lower) xs
fixLower :: (Ord a) => Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)
fixLower lower@(Bound lowerValue _) (x, y@(Bound yValue _)) = do
guard (lowerValue <= yValue)
return (maxBoundsIntersection lower x, y)
fixUpper :: (Ord a) => Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)
fixUpper upper@(Bound upperValue _) (x@(Bound xValue _), y) = do
guard (xValue <= upperValue)
return (x, minBoundsIntersection y upper)
intersectionRangeMerges :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a
intersectionRangeMerges IRM two = two
intersectionRangeMerges one IRM = one
intersectionRangeMerges one two = RM
{ largestLowerBound = newLowerBound
, largestUpperBound = newUpperBound
, spanRanges = unionSpans sortedResults
}
where
lowerOneSpans = intersectWith fixLower (largestLowerBound one) (spanRanges two)
lowerTwoSpans = intersectWith fixLower (largestLowerBound two) (spanRanges one)
upperOneSpans = intersectWith fixUpper (largestUpperBound one) (spanRanges two)
upperTwoSpans = intersectWith fixUpper (largestUpperBound two) (spanRanges one)
intersectedSpans = intersectSpans (spanRanges one) (spanRanges two)
sortedResults = removeEmptySpans $ foldr1 insertionSortSpans
[ lowerOneSpans
, lowerTwoSpans
, upperOneSpans
, upperTwoSpans
, intersectedSpans
, calculateBoundOverlap one two
]
newLowerBound = calculateNewBound largestLowerBound maxBoundsIntersection one two
newUpperBound = calculateNewBound largestUpperBound minBoundsIntersection one two
calculateNewBound
:: (Ord a)
=> (RangeMerge a -> Maybe (Bound a))
-> (Bound a -> Bound a -> Bound a)
-> RangeMerge a -> RangeMerge a -> Maybe (Bound a)
calculateNewBound ext comp one' two' = case (ext one', ext two') of
(Just x, Just y) -> Just $ comp x y
(_, Nothing) -> Nothing
(Nothing, _) -> Nothing
calculateBoundOverlap :: (Ord a) => RangeMerge a -> RangeMerge a -> [(Bound a, Bound a)]
calculateBoundOverlap one two = catMaybes [oneWay, secondWay]
where
oneWay = do
x <- largestLowerBound one
y <- largestUpperBound two
guard (compareLower y x /= LT)
return (x, y)
secondWay = do
x <- largestLowerBound two
y <- largestUpperBound one
guard (compareLower y x /= LT)
return (x, y)
unionRangeMerges :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a
unionRangeMerges IRM _ = IRM
unionRangeMerges _ IRM = IRM
unionRangeMerges one two = infiniteCheck filterTwo
where
filterOne = foldr filterLowerBound boundedRM (unionSpans sortedSpans)
filterTwo = foldr filterUpperBound (filterOne { spanRanges = [] }) (spanRanges filterOne)
infiniteCheck :: (Ord a) => RangeMerge a -> RangeMerge a
infiniteCheck IRM = IRM
infiniteCheck rm@(RM (Just lower) (Just upper) _) = if compareUpperToLower upper lower /= LT
then IRM
else rm
infiniteCheck rm = rm
newLowerBound = calculateNewBound largestLowerBound minBounds one two
newUpperBound = calculateNewBound largestUpperBound maxBounds one two
sortedSpans = insertionSortSpans (spanRanges one) (spanRanges two)
boundedRM = RM
{ largestLowerBound = newLowerBound
, largestUpperBound = newUpperBound
, spanRanges = []
}
calculateNewBound
:: (Ord a)
=> (RangeMerge a -> Maybe (Bound a))
-> (Bound a -> Bound a -> Bound a)
-> RangeMerge a -> RangeMerge a -> Maybe (Bound a)
calculateNewBound ext comp one' two' = case (ext one', ext two') of
(Just x, Just y) -> Just $ comp x y
(z, Nothing) -> z
(Nothing, z) -> z
filterLowerBound :: (Ord a) => (Bound a, Bound a) -> RangeMerge a -> RangeMerge a
filterLowerBound _ IRM = IRM
filterLowerBound a rm@(RM Nothing _ _) = rm { spanRanges = a : spanRanges rm }
filterLowerBound s@(lower, _) rm@(RM (Just lowestBound) _ _) =
case boundCmp lowestBound s of
GT -> rm { spanRanges = s : spanRanges rm }
LT -> rm
EQ -> rm { largestLowerBound = Just $ minBounds lowestBound lower }
filterUpperBound :: (Ord a) => (Bound a, Bound a) -> RangeMerge a -> RangeMerge a
filterUpperBound _ IRM = IRM
filterUpperBound a rm@(RM _ Nothing _) = rm { spanRanges = a : spanRanges rm }
filterUpperBound s@(_, upper) rm@(RM _ (Just upperBound) _) =
case boundCmp upperBound s of
LT -> rm { spanRanges = s : spanRanges rm }
GT -> rm
EQ -> rm { largestUpperBound = Just $ maxBounds upperBound upper }
invertRM :: (Ord a) => RangeMerge a -> RangeMerge a
invertRM IRM = emptyRangeMerge
invertRM (RM Nothing Nothing []) = IRM
invertRM (RM (Just lower) Nothing []) = RM Nothing (Just . invertBound $ lower) []
invertRM (RM Nothing (Just upper) []) = RM (Just . invertBound $ upper) Nothing []
invertRM (RM (Just lower) (Just upper) []) = RM Nothing Nothing [(invertBound upper, invertBound lower)]
invertRM rm = RM
{ largestUpperBound = newUpperBound
, largestLowerBound = newLowerBound
, spanRanges = upperSpan ++ betweenSpans ++ lowerSpan
}
where
newLowerValue = invertBound . snd . last . spanRanges $ rm
newUpperValue = invertBound . fst . head . spanRanges $ rm
newUpperBound = case largestUpperBound rm of
Just _ -> Nothing
Nothing -> Just newUpperValue
newLowerBound = case largestLowerBound rm of
Just _ -> Nothing
Nothing -> Just newLowerValue
upperSpan = case largestUpperBound rm of
Nothing -> []
Just upper -> [(invertBound upper, newUpperValue)]
lowerSpan = case largestLowerBound rm of
Nothing -> []
Just lower -> [(newLowerValue, invertBound lower)]
betweenSpans = invertSpans . spanRanges $ rm
joinRM :: (Eq a, Enum a) => RangeMerge a -> RangeMerge a
joinRM o@(RM _ _ []) = o
joinRM rm = RM lower higher spansAfterHigher
where
joinedSpans = joinSpans . spanRanges $ rm
(lower, spansAfterLower) =
case (largestLowerBound rm, reverse joinedSpans) of
o@(Just l, ((xl, xh) : xs)) ->
if (succ . highestValueInUpperBound $ xh) == lowestValueInLowerBound l
then (Just xl, reverse xs)
else o
x -> x
(higher, spansAfterHigher) =
case (largestUpperBound rm, spansAfterLower) of
o@(Just h, ((xl, xh) : xs)) ->
if highestValueInUpperBound h == (pred . lowestValueInLowerBound $ xl)
then (Just xh, xs)
else o
x -> x
updateBound :: Bound a -> a -> Bound a
updateBound (Bound _ aType) b = Bound b aType
unmergeRM :: RangeMerge a -> [RangeMerge a]
unmergeRM IRM = [IRM]
unmergeRM (RM lower upper spans) =
(maybe [] (\x -> [RM Nothing (Just x) []]) upper) ++
fmap (\x -> RM Nothing Nothing [x]) spans ++
(maybe [] (\x -> [RM (Just x) Nothing []]) lower)