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