Util.hs

{-# LANGUAGE Safe #-}

-- | Internal utility functions shared across the range library.
-- This module is in @other-modules@ and is not part of the public API.
--
-- Functions are grouped by the layer that consumes them:
--   * "Used by Ranges\/Ord" — consumed by the semi-public modules
--   * "Used by Spans\/RangeInternal" — consumed only by the strictly-internal layer
--   * "Util-internal" — building blocks used only within this module
module Data.Range.Util
  ( -- * Used by Ranges and Ord
    compareLower
  , compareHigher
  , invertBound
  , boundsOverlapType
  , pointJoinType
  , boundIsBetween
  , againstLowerBound
  , againstUpperBound
  , takeEvenly
    -- * Used by Spans and RangeInternal
  , compareUpperToLower
  , minBounds
  , maxBounds
  , minBoundsIntersection
  , maxBoundsIntersection
  , insertionSort
  , isEmptySpan
  , removeEmptySpans
  , boundCmp
  , lowestValueInLowerBound
  , highestValueInUpperBound
  ) where

import Data.List (transpose)

import Data.Range.Data

compareLower :: Ord a => Bound a -> Bound a -> Ordering
compareLower ab@(Bound a aType) bb@(Bound b _)
   | ab == bb     = EQ
   | a == b       = if aType == Inclusive then LT else GT
   | a < b        = LT
   | otherwise    = GT

compareHigher :: Ord a => Bound a -> Bound a -> Ordering
compareHigher ab@(Bound a aType) bb@(Bound b _)
   | ab == bb     = EQ
   | a == b       = if aType == Inclusive then GT else LT
   | a < b        = LT
   | otherwise    = GT

-- | Util-internal: used only by 'minBoundsIntersection'.
compareLowerIntersection :: Ord a => Bound a -> Bound a -> Ordering
compareLowerIntersection ab@(Bound a aType) bb@(Bound b _)
   | ab == bb     = EQ
   | a == b       = if aType == Exclusive then LT else GT
   | a < b        = LT
   | otherwise    = GT

-- | Util-internal: used only by 'maxBoundsIntersection'.
compareHigherIntersection :: Ord a => Bound a -> Bound a -> Ordering
compareHigherIntersection ab@(Bound a aType) bb@(Bound b _)
   | ab == bb     = EQ
   | a == b       = if aType == Exclusive then GT else LT
   | a < b        = LT
   | otherwise    = GT

compareUpperToLower :: Ord a => Bound a -> Bound a -> Ordering
compareUpperToLower (Bound upper upperType) (Bound lower lowerType)
   | upper == lower  = if upperType == Inclusive || lowerType == Inclusive then EQ else LT
   | upper < lower   = LT
   | otherwise       = GT

minBounds :: Ord a => Bound a -> Bound a -> Bound a
minBounds ao bo = if compareLower ao bo == LT then ao else bo

maxBounds :: Ord a => Bound a -> Bound a -> Bound a
maxBounds ao bo = if compareHigher ao bo == GT then ao else bo

minBoundsIntersection :: Ord a => Bound a -> Bound a -> Bound a
minBoundsIntersection ao bo = if compareLowerIntersection ao bo == LT then ao else bo

maxBoundsIntersection :: Ord a => Bound a -> Bound a -> Bound a
maxBoundsIntersection ao bo = if compareHigherIntersection ao bo == GT then ao else bo

insertionSort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
insertionSort comp xs ys = go xs ys
   where
      go (f : fs) (s : ss) = case comp f s of
         LT -> f : go fs (s : ss)
         EQ -> f : s : go fs ss
         GT -> s : go (f : fs) ss
      go [] z = z
      go z [] = z

invertBound :: Bound a -> Bound a
invertBound (Bound x Inclusive) = Bound x Exclusive
invertBound (Bound x Exclusive) = Bound x Inclusive

isEmptySpan :: Eq a => (Bound a, Bound a) -> Bool
isEmptySpan (Bound a aType, Bound b bType) = a == b && (aType == Exclusive || bType == Exclusive)

removeEmptySpans :: Eq a => [(Bound a, Bound a)] -> [(Bound a, Bound a)]
removeEmptySpans = filter (not . isEmptySpan)

boundsOverlapType :: Ord a => (Bound a, Bound a) -> (Bound a, Bound a) -> OverlapType
boundsOverlapType l@(ab@(Bound a _), bb@(Bound b _)) r@(xb@(Bound x _), yb@(Bound y _))
   | isEmptySpan l || isEmptySpan r    = Separate
   | a == x                            = Overlap
   | b == y                            = Overlap
   | otherwise = (ab `boundIsBetween` (xb, yb)) `orOverlapType` (xb `boundIsBetween` (ab, bb))

-- | Util-internal: used only by 'boundsOverlapType'.
orOverlapType :: OverlapType -> OverlapType -> OverlapType
orOverlapType Overlap _ = Overlap
orOverlapType _ Overlap = Overlap
orOverlapType Adjoin _ = Adjoin
orOverlapType _ Adjoin = Adjoin
orOverlapType _ _ = Separate

pointJoinType :: BoundType -> BoundType -> OverlapType
pointJoinType Inclusive Inclusive = Overlap
pointJoinType Exclusive Exclusive = Separate
pointJoinType _ _ = Adjoin

-- | This function assumes that the bound on the left is a lower bound and
-- that the range is in @(lower, upper)@ bound order.
boundCmp :: (Ord a) => Bound a -> (Bound a, Bound a) -> Ordering
boundCmp ab@(Bound a _) (xb@(Bound x _), yb)
   | boundIsBetween ab (xb, yb) /= Separate = EQ
   | a <= x = LT
   | otherwise = GT

-- | Tests whether a single 'Bound' falls within the span @(lower, upper)@,
-- returning the 'OverlapType' at that point.
--
-- This is the point-in-span primitive. 'boundsOverlapType' is built on top
-- of it and handles the span-vs-span case. Replacing call sites of this
-- function with 'boundsOverlapType' would require constructing a degenerate
-- span @(b, b)@ for each point — see @ai-planning/boundIsBetween-todo.md@
-- for the full analysis.
boundIsBetween :: (Ord a) => Bound a -> (Bound a, Bound a) -> OverlapType
boundIsBetween (Bound a aType) (Bound x xType, Bound y yType)
   | x > a     = Separate
   | x == a    = pointJoinType aType xType
   | a < y     = Overlap
   | a == y    = pointJoinType aType yType
   | otherwise = Separate

againstLowerBound :: Ord a => Bound a -> Bound a -> OverlapType
againstLowerBound (Bound a aType) (Bound lower lowerType)
   | lower == a   = pointJoinType aType lowerType
   | lower < a    = Overlap
   | otherwise    = Separate

againstUpperBound :: Ord a => Bound a -> Bound a -> OverlapType
againstUpperBound (Bound a aType) (Bound upper upperType)
   | upper == a   = pointJoinType aType upperType
   | a < upper    = Overlap
   | otherwise    = Separate

takeEvenly :: [[a]] -> [a]
takeEvenly = concat . transpose

lowestValueInLowerBound :: Enum a => Bound a -> a
lowestValueInLowerBound (Bound a Inclusive) = a
lowestValueInLowerBound (Bound a Exclusive) = succ a

highestValueInUpperBound :: Enum a => Bound a -> a
highestValueInUpperBound (Bound a Inclusive) = a
highestValueInUpperBound (Bound a Exclusive) = pred a