module Pinchot.Intervals where
import qualified Control.Lens as Lens
import Control.Monad (join)
import Data.Data (Data)
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.Sequence (Seq, ViewL(EmptyL, (:<)), viewl, (<|))
import qualified Data.Sequence as Seq
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Show.Pretty (PrettyVal)
import qualified Text.Show.Pretty as Pretty
import Pinchot.Pretty
data Intervals a = Intervals
{ _included :: Seq (a, a)
, _excluded :: Seq (a, a)
} deriving (Eq, Ord, Show, Data)
Lens.makeLenses ''Intervals
instance PrettyVal a => PrettyVal (Intervals a) where
prettyVal (Intervals inc exc)
= Pretty.Rec "Pinchot.Intervals.Intervals"
[ ("_included", prettySeq Pretty.prettyVal inc)
, ("_excluded", prettySeq Pretty.prettyVal exc)
]
instance Functor Intervals where
fmap f (Intervals a b) = Intervals (fmap g a) (fmap g b)
where
g (x, y) = (f x, f y)
instance Monoid (Intervals a) where
mempty = Intervals mempty mempty
(Intervals x1 y1) `mappend` (Intervals x2 y2)
= Intervals (x1 <> x2) (y1 <> y2)
include :: a -> a -> Intervals a
include l h = Intervals [(l, h)] []
exclude :: a -> a -> Intervals a
exclude l h = Intervals [] [(l, h)]
solo :: a -> Intervals a
solo x = Intervals [(x, x)] []
pariah :: a -> Intervals a
pariah x = Intervals [] [(x, x)]
endLeft :: Ord a => (a, a) -> a
endLeft (a, b) = min a b
endRight :: Ord a => (a, a) -> a
endRight (a, b) = max a b
inInterval :: Ord a => a -> (a, a) -> Bool
inInterval x i = x >= endLeft i && x <= endRight i
members :: (Ord a, Enum a) => (a, a) -> Seq a
members i = Seq.fromList [endLeft i .. endRight i]
sortIntervalSeq :: Ord a => Seq (a, a) -> Seq (a, a)
sortIntervalSeq = Seq.sortBy (comparing endLeft <> comparing endRight)
standardizeInterval :: Ord a => (a, a) -> (a, a)
standardizeInterval (a, b) = (min a b, max a b)
standardizeIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)
standardizeIntervalSeq = flattenIntervalSeq . sortIntervalSeq
flattenIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)
flattenIntervalSeq = fmap standardizeInterval . go Nothing
where
go mayCurr sq = case (mayCurr, viewl sq) of
(Nothing, EmptyL) -> []
(Just i, EmptyL) -> [i]
(Nothing, x :< xs) -> go (Just x) xs
(Just curr, x :< xs)
| endRight curr < endLeft x
&& endRight curr < pred (endLeft x) -> curr <| go (Just x) xs
| otherwise -> go (Just (endLeft curr,
max (endRight curr) (endRight x))) xs
removeExcludes
:: (Ord a, Enum a)
=> Seq (a, a)
-> Seq (a, a)
-> Seq (a, a)
removeExcludes inc = foldr remover inc
remover
:: (Ord a, Enum a)
=> (a, a)
-> Seq (a, a)
-> Seq (a, a)
remover ivl = join . fmap squash . fmap (removeInterval ivl)
where
squash (Nothing, Nothing) = Seq.empty
squash (Just x, Nothing) = Seq.singleton x
squash (Nothing, Just x) = Seq.singleton x
squash (Just x, Just y) = x <| y <| Seq.empty
removeInterval
:: (Ord a, Enum a)
=> (a, a)
-> (a, a)
-> (Maybe (a, a), Maybe (a, a))
removeInterval ivl oldIvl = (onLeft, onRight)
where
onLeft
| endLeft ivl > endLeft oldIvl =
Just ( endLeft oldIvl
, min (pred (endLeft ivl)) (endRight oldIvl))
| otherwise = Nothing
onRight
| endRight ivl < endRight oldIvl =
Just ( max (succ (endRight ivl)) (endLeft oldIvl)
, endRight oldIvl)
| otherwise = Nothing
standardizeIntervals
:: (Ord a, Enum a)
=> Intervals a
-> Intervals a
standardizeIntervals (Intervals i e)
= Intervals (standardizeIntervalSeq i) (standardizeIntervalSeq e)
splitIntervals
:: (Ord a, Enum a)
=> Intervals a
-> Seq (a, a)
splitIntervals (Intervals is es)
= removeExcludes (standardizeIntervalSeq is) es
inIntervals :: (Enum a, Ord a) => Intervals a -> a -> Bool
inIntervals ivls a = any (inInterval a) . splitIntervals $ ivls
liftSeq :: Lift a => Seq a -> ExpQ
liftSeq sq = case viewl sq of
EmptyL -> varE 'Seq.empty
x :< xs -> uInfixE (lift x) (varE '(<|)) (liftSeq xs)
instance Lift a => Lift (Intervals a) where
lift (Intervals inc exc) = [| Intervals $sqInc $sqExc |]
where
sqInc = liftSeq inc
sqExc = liftSeq exc