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
interval :: Ord a => (a, Bool) -> (a, Bool) -> Interval a
interval s e = Interval (Just s) (Just e)
infix 5 <=..<=
(<=..<=) :: Ord a => a -> a -> Interval a
(<=..<=) s e = interval (s, True) (e, True)
infix 5 <..<=
(<..<=) :: Ord a => a -> a -> Interval a
(<..<=) s e = interval (s, False) (e, True)
infix 5 <=..<
(<=..<) :: Ord a => a -> a -> Interval a
(<=..<) s e = interval (s, True) (e, False)
infix 5 <..<
(<..<) :: Ord a => a -> a -> Interval a
(<..<) s e = interval (s, False) (e, False)
singleton :: Ord a => a -> Interval a
singleton a = Interval (Just (a, True)) (Just (a, True))
empty :: Ord a => Interval a
empty = Interval Nothing Nothing
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
intervalHead :: Interval a -> Maybe a
intervalHead (Interval Nothing Nothing) = Nothing
intervalHead (Interval (Just (s, _)) _) = Just s
intervalHead (Interval Nothing (Just (e, _))) = Just e
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)
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))
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)