{-# 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)