{-# LANGUAGE NoImplicitPrelude #-}
{- | Representation of an interval on a single dimension -}
module LuminescentDreams.Data.Interval
( interval
, (<=..<=), (<..<=), (<=..<), (<..<)
, singleton, empty
, fromList, intervalHead
, null, member
, Interval(..)
) where
import Prelude (
Bool(..), Maybe(..), Ord, Show
, ($)
, (==), (>), (>=), (<), (<=)
, (&&), (||)
, otherwise
)
import Data.Functor
import qualified Data.List as L
import Data.Monoid
{- | Build an interval -}
interval :: Ord a => (a, Bool) -> (a, Bool) -> Interval a
interval s e = Interval (Just s) (Just e)
{- | make a closed interval [l,u] -}
infix 5 <=..<=
(<=..<=) :: Ord a => a -> a -> Interval a
(<=..<=) s e = interval (s, True) (e, True)
{- | make a left-open, right-closed interval (l,u] -}
infix 5 <..<=
(<..<=) :: Ord a => a -> a -> Interval a
(<..<=) s e = interval (s, False) (e, True)
{- | make a left-closed, right-open interval [l, u) -}
infix 5 <=..<
(<=..<) :: Ord a => a -> a -> Interval a
(<=..<) s e = interval (s, True) (e, False)
{- | make an open interval (l, u) -}
infix 5 <..<
(<..<) :: Ord a => a -> a -> Interval a
(<..<) s e = interval (s, False) (e, False)
{- | make an interval consisting of precisely one element -}
singleton :: Ord a => a -> Interval a
singleton a = Interval (Just (a, True)) (Just (a, True))
{- | make an empty interval -}
empty :: Ord a => Interval a
empty = Interval Nothing Nothing
{- | make an interval from a list
Making an interval from a single value [15] yields the singleton interval.
Making an interval from a longer list of values [a, b, c, ..., d] will build a closed interval containing all of the values in the list.
-}
fromList :: Ord a => [a] -> Interval a
fromList [] = Interval Nothing Nothing
fromList [x] = singleton x
fromList lst =
let sortedList = L.sort lst in
L.head sortedList <=..<= L.last sortedList
{- | return the "head" of an interval. If the interval is empty, return Nothing. Return the starting element if that is present, and the ending element otherwise. -}
intervalHead :: Interval a -> Maybe a
intervalHead (Interval Nothing Nothing) = Nothing
intervalHead (Interval (Just (s, _)) _) = Just s
intervalHead (Interval Nothing (Just (e, _))) = Just e
{- | Is this an empty or self-contradictory interval? -}
null :: Ord a => Interval a -> Bool
null (Interval Nothing Nothing) = True
null (Interval (Just (s, False)) (Just (e, False))) = s == e
null (Interval (Just (s, True)) (Just (e, True))) = s > e
null (Interval (Just (s, True)) (Just (e, False))) = s >= e
null (Interval (Just (s, False)) (Just (e, True))) = s > e
null (Interval (Just (_, True)) Nothing) = False
null (Interval Nothing (Just (_, True))) = False
null _ = False
member :: Ord a => a -> Interval a -> Bool
member _ (Interval Nothing Nothing) = False
member val (Interval (Just (s, False)) Nothing) = val > s
member val (Interval (Just (s, True)) Nothing) = val >= s
member val (Interval Nothing (Just (e, False))) = val < e
member val (Interval Nothing (Just (e, True))) = val <= e
member val (Interval s e) =
member val (Interval s Nothing) && member val (Interval Nothing e)
{- | A representation of a bounded interval. This covers all of the possible interval types, including one that starts but has no end, one that ends but has no start, one that is bounded, and one that is exact. Inclusiveness flags are included for both the start and the end. -}
data Interval a = Interval { start :: Maybe (a, Bool), end :: Maybe (a, Bool) }
deriving Show
instance Functor Interval where
_ `fmap` (Interval Nothing Nothing) = Interval Nothing Nothing
f `fmap` (Interval (Just (s, si)) Nothing) = Interval (Just (f s, si)) Nothing
f `fmap` (Interval Nothing (Just (e, ei))) = Interval Nothing (Just (f e, ei))
f `fmap` (Interval (Just (s, si)) (Just (e, ei))) = Interval (Just (f s, si)) (Just (f e, ei))
{- | This monoid instance defines the rules for combining two different intervals, and it handles all interval combination types. The end result follows these rules:
* If either interval is completely empty (mempty), it the one that is not will be returned unchanged.
* If both have a start time, the resulting start time will be the lowest.
* If both have an end time, the resulting end time will be the latest.
* If one does not have a start time, the resulting start time will be the other ones. If neither has a start time, there will be no start time. Similar rules for the end time.
* For both start and end times, the inclusivity flag for the chosen time will be the one returned. If the two times are the same, the inclusive flag will True if either inclusive flag is True.
-}
instance Ord a => Monoid (Interval a) where
mempty = Interval Nothing Nothing
mappend (Interval Nothing Nothing) (Interval Nothing Nothing) = mempty
mappend l@(Interval Nothing (Just _)) (Interval Nothing Nothing) = l
mappend l@(Interval (Just _) Nothing) (Interval Nothing Nothing) = l
mappend l@(Interval (Just _) (Just _)) (Interval Nothing Nothing) = l
mappend (Interval Nothing Nothing) r@(Interval Nothing (Just _)) = r
mappend (Interval Nothing Nothing) r@(Interval (Just _) Nothing) = r
mappend (Interval Nothing Nothing) r@(Interval (Just _) (Just _)) = r
mappend (Interval lStart lEnd) (Interval rStart rEnd) = Interval (m start_ lStart rStart) (m end_ lEnd rEnd)
where
m func (Just l) (Just r) = Just $ func l r
m _ Nothing (Just r) = Just r
m _ (Just l) Nothing = Just l
m _ Nothing Nothing = Nothing
start_ (st1, inc1) (st2, inc2)
| st1 < st2 = (st1, inc1)
| st1 > st2 = (st2, inc2)
| otherwise = (st1, inc1 || inc2)
end_ (st1, inc1) (st2, inc2)
| st1 < st2 = (st2, inc2)
| st1 > st2 = (st1, inc1)
| otherwise = (st1, inc1 || inc2)