{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
module Data.Interval where

import           Control.DeepSeq (NFData(..))
import           Data.Bool
import           Data.Data (Data(..))
import           Data.Eq (Eq(..))
import           Data.Foldable (concat)
import           Data.Function (($), flip)
import           Data.Functor (Functor(..))
import qualified Data.Functor as Functor
import           Data.Maybe (Maybe(..))
import           Data.Ord (Ord(..), Ordering(..))
import           Data.Tuple
import           Data.Typeable (Typeable)
import           Prelude (Bounded(..), seq)
import           Text.Show (Show(..))

-- * Type 'Limit'

data Limit x
 =   Limit
 { adherence :: Adherence
 , limit     :: x }
 deriving (Eq, Data, Show, Typeable)

instance Functor Limit where
	fmap f (Limit a x) = Limit a (f x)
instance NFData x => NFData (Limit x) where
	rnf (Limit _a l) = rnf l

data Adherence = Out | In
 deriving (Eq, Data, Show, Typeable)

-- | Return given 'Limit' with its 'adherence' set to the opposite one.
flip_limit :: Limit x -> Limit x
flip_limit (Limit a x) = Limit (case a of { In -> Out; Out -> In }) x

-- ** Comparing 'Limit's

-- | Compare two 'low' 'Limit's.
newtype LL x = LL { unLL :: x }
 deriving (Eq)
instance Ord x => Ord (LL (Limit x)) where
	compare (LL x) (LL y) =
		case compare (limit x) (limit y) of
		 EQ ->
			case (adherence x, adherence y) of
			 (Out, In ) -> GT
			 (In , Out) -> LT
			 _          -> EQ
		 o -> o

-- | Compare two 'high' 'Limit's.
newtype HH x = HH { unHH :: x }
 deriving (Eq)
instance Ord x => Ord (HH (Limit x)) where
	compare (HH x) (HH y) =
		case compare (limit x) (limit y) of
		 EQ ->
			case (adherence x, adherence y) of
			 (Out, In ) -> LT
			 (In , Out) -> GT
			 _          -> EQ
		 o -> o

-- * Type 'Interval'

newtype  Ord x
 => Interval x
 =  Interval (Limit x, Limit x)
 deriving (Eq, Show, Data, Typeable)
instance (NFData x, Ord x) => NFData (Interval x) where
	rnf (Interval (x, y)) = rnf x `seq` rnf y

low :: Ord x => Interval x -> Limit x
low (Interval t)  = fst t

high :: Ord x => Interval x -> Limit x
high (Interval t) = snd t

-- | Return 'Interval' with given 'low' then 'high' 'Limit's,
--   if they form a valid 'Interval'.
interval :: Ord x => Limit x -> Limit x -> Maybe (Interval x)
interval x y =
	case compare_without_adherence x y of
	 LT -> Just $ Interval (x, y)
	 EQ ->
		case (adherence x, adherence y) of
		 (In, In) -> Just $ Interval (x, y)
		 _        -> Nothing
	 GT -> Nothing

-- | Like 'Functor.fmap', but may return 'Nothing', if mapped 'Interval' is not valid.
fmap :: (Ord x, Ord y) => (x -> y) -> Interval x -> Maybe (Interval y)
fmap f (Interval (il, ih)) = interval (Functor.fmap f il) (Functor.fmap f ih)

-- | Like 'Functor.fmap', but only safe if given map preserves 'Ordering'.
fmap_unsafe :: (Ord x, Ord y) => (x -> y) -> Interval x -> Interval y
fmap_unsafe f (Interval (il, ih)) = Interval (Functor.fmap f il, Functor.fmap f ih)

{-
-- | Like 'Functor.fmap', but on 'Limit's,
--   and may return 'Nothing', if mapped 'Interval' is not valid.
fmap_limits :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Maybe (Interval y)
fmap_limits f (Interval (il, ih)) = interval (f il) (f ih)

-- | Like 'Functor.fmap', but on 'Limit's
--   and only safe if given map preserves 'Ordering'.
fmap_limits_unsafe :: (Ord x, Ord y) => (Limit x -> Limit y) -> Interval x -> Interval y
fmap_limits_unsafe f (Interval (il, ih)) = Interval (f il, f ih)
-}

-- | Lexicographical order, handling 'Adherence' correctly.
instance Ord x => Ord (Interval x) where
	compare (Interval (il, ih)) (Interval (jl, jh)) =
		case   compare (LL il) (LL jl) of
		 EQ -> compare (HH ih) (HH jh)
		 o  -> o

-- | Return 'limit's of given 'Interval' as a tuple.
limits :: Ord x => Interval x -> (Limit x, Limit x)
limits (Interval t) = t

-- | Return an 'Interval' spanning over a single 'limit'.
point :: Ord x => x -> Interval x
point x = Interval (Limit In x, Limit In x)

-- | Return given 'Interval' with 'flip_limit' applied to its 'limit's.
flip_limits :: Ord x => Interval x -> Interval x
flip_limits (Interval (l, h)) = Interval (flip_limit l, flip_limit h)

-- | Return 'Ordering' comparing given 'Interval's according to their 'limit's.
compare_without_adherence :: Ord x => Limit x -> Limit x -> Ordering
compare_without_adherence (Limit _ x) (Limit _ y) = compare x y

-- | Return:
--
-- * 'LT': if given value is lower  than all values in given 'Interval'.
-- * 'EQ': if given value is into the given 'Interval'.
-- * 'GT': if given value is higher than all values in given 'Interval'.
locate :: Ord x => x -> Interval x -> Ordering
locate x (Interval (l, h)) =
	case compare x (limit l) of
	 LT -> LT
	 EQ | adherence l == In -> EQ
	 EQ -> LT
	 GT ->
		case compare x (limit h) of
		 LT -> EQ
		 EQ | adherence h == In -> EQ
		 EQ -> GT
		 GT -> GT

-- | Return 'True' iif. given value is into the given 'Interval'.
within :: Ord x => x -> Interval x -> Bool
within x i = locate x i == EQ

-- | Return 'True' iif. every value of the first 'Interval' is into the second 'Interval'.
into :: Ord x => Interval x -> Interval x -> Bool
into i j =
	case position i j of
	 (Prefix  , LT) -> True
	 (Suffixed, GT) -> True
	 (Include , GT) -> True
	 (Equal   , _)  -> True
	 _              -> False

-- | Return 'True' iif. every value of the second 'Interval' is into the first 'Interval'.
onto :: Ord x => Interval x -> Interval x -> Bool
onto = flip into

infix 5 <=..<=
(<=..<=) :: Ord x => x -> x -> Maybe (Interval x)
(<=..<=) x y =
	case compare x y of
	 LT -> Just $ Interval (Limit In x, Limit In y)
	 EQ -> Just $ Interval (Limit In x, Limit In y)
	 GT -> Nothing

infix 5 <..<=
(<..<=) :: Ord x => x -> x -> Maybe (Interval x)
(<..<=) x y =
	case compare x y of
	 LT -> Just $ Interval (Limit Out x, Limit In y)
	 EQ -> Nothing
	 GT -> Nothing

infix 5 <=..<
(<=..<) :: Ord x => x -> x -> Maybe (Interval x)
(<=..<) x y =
	case compare x y of
	 LT -> Just $ Interval (Limit In x, Limit Out y)
	 EQ -> Nothing
	 GT -> Nothing

infix 5 <..<
(<..<) :: Ord x => x -> x -> Maybe (Interval x)
(<..<) x y =
	case compare x y of
	 LT -> Just $ Interval (Limit Out x, Limit Out y)
	 EQ -> Nothing
	 GT -> Nothing

-- * Type 'Position'

data Position
 = Away     -- ^ @-_|@ ('LT') or @|_-@ ('GT')
 | Adjacent -- ^ @-|@  ('LT') or @|-@  ('GT')
 | Overlap  -- ^ @-+|@ ('LT') or @|+-@ ('GT')
 | Prefix   -- ^ @+|@  ('LT') or @+-@  ('GT')
 | Suffixed -- ^ @-+@  ('LT') or @|+@  ('GT')
 | Include  -- ^ @-+-@ ('LT') or @|+|@ ('GT')
 | Equal    -- ^ @+@ ('EQ')
 deriving (Eq, Show)

position :: Ord x => Interval x -> Interval x -> (Position, Ordering)
position (Interval (il, ih)) (Interval (jl, jh)) =
	case compare (LL il) (LL jl) of
	 LT -> (, LT) $
		case compare_without_adherence ih jl of
		 LT -> Away -- PATTERN: -_|
		 EQ ->
			case (adherence ih, adherence jl) of
			 (In , In)  -> Overlap  -- PATTERN: -+|
			 (Out, Out) -> Away     -- PATTERN: -_|
			 _          -> Adjacent -- PATTERN: -|
		 GT ->
			case compare (HH ih) (HH jh) of
			 LT -> Overlap  -- PATTERN: -+|
			 EQ -> Suffixed -- PATTERN: -+
			 GT -> Include  -- PATTERN: -+-
	 EQ ->
		case compare (HH ih) (HH jh) of
		 LT -> (Prefix, LT) -- PATTERN: +|
		 EQ -> (Equal , EQ) -- PATTERN: +
		 GT -> (Prefix, GT) -- PATTERN: +-
	 GT -> (, GT) $
		case compare_without_adherence il jh of
		 LT ->
			case compare (HH ih) (HH jh) of
			 LT -> Include  -- PATTERN: |+|
			 EQ -> Suffixed -- PATTERN: |+
			 GT -> Overlap  -- PATTERN: |+-
		 EQ ->
			case (adherence il, adherence jh) of
			 (In , In)  -> Overlap  -- PATTERN: |+-
			 (Out, Out) -> Away     -- PATTERN: |_-
			 _          -> Adjacent -- PATTERN: |-
		 GT -> Away -- PATTERN: |_-

infix 4 ..<<..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT').
(..<<..) :: Ord x => Interval x -> Interval x -> Bool
(..<<..) i j = case position i j of
	 (Away, LT) -> True
	 _          -> False

infix 4 ..>>..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT').
(..>>..) :: Ord x => Interval x -> Interval x -> Bool
(..>>..) i j = case position i j of
	 (Away, GT) -> True
	 _          -> False

infix 4 ..<..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT') or ('Adjacent', 'LT').
(..<..) :: Ord x => Interval x -> Interval x -> Bool
(..<..) i j = case position i j of
	 (Away    , LT) -> True
	 (Adjacent, LT) -> True
	 _              -> False
infix 4 ..>..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT') or ('Adjacent', 'GT').
(..>..) :: Ord x => Interval x -> Interval x -> Bool
(..>..) i j = case position i j of
	 (Away    , GT) -> True
	 (Adjacent, GT) -> True
	 _              -> False

infix 4 ..<=..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'LT'), ('Adjacent', 'LT'), ('Overlap', 'LT'), ('Prefix', 'LT'), ('Suffixed', 'LT'), ('Include', 'GT'), or ('Equal', _).
(..<=..) :: Ord x => Interval x -> Interval x -> Bool
(..<=..) i j = case position i j of
	 (Away    , LT) -> True
	 (Adjacent, LT) -> True
	 (Overlap , LT) -> True
	 (Prefix  , LT) -> True
	 (Suffixed, LT) -> True
	 (Include , GT) -> True
	 (Equal   , _ ) -> True
	 _              -> False

infix 4 ..>=..
-- | Return 'True' iif. 'Position' of given 'Interval's is ('Away', 'GT'), ('Adjacent', 'GT'), ('Overlap', 'GT'), ('Prefix', 'GT'), ('Suffixed', 'GT'), ('Include', 'LT'), or ('Equal', _).
(..>=..) :: Ord x => Interval x -> Interval x -> Bool
(..>=..) i j = case position i j of
	 (Away    , GT) -> True
	 (Adjacent, GT) -> True
	 (Overlap , GT) -> True
	 (Prefix  , GT) -> True
	 (Suffixed, GT) -> True
	 (Include , LT) -> True
	 (Equal   , _ ) -> True
	 _              -> False

-- * Merge

union :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
union i j =
	case position i j of
	 (Away, _) -> -- PATTERN: -_| or |_-
		Nothing
	 (Adjacent, o) ->
		case o of
		 LT -> Just $ Interval (low i, high j) -- PATTERN: -|
		 EQ -> Nothing
		 GT -> Just $ Interval (low j, high i) -- PATTERN: |-
	 (Overlap, o) ->
		case o of
		 LT -> Just $ Interval (low i, high j) -- PATTERN: -+|
		 EQ -> Nothing
		 GT -> Just $ Interval (low j, high i) -- PATTERN: |+-
	 (Prefix, o) ->
		case o of
		 LT -> Just j -- PATTERN: +|
		 EQ -> Nothing
		 GT -> Just i -- PATTERN: +-
	 (Suffixed, o) ->
		case o of
		 LT -> Just i -- PATTERN: -+
		 EQ -> Nothing
		 GT -> Just j -- PATTERN: |+
	 (Include, o) ->
		case o of
		 LT -> Just i -- PATTERN: -+-
		 EQ -> Nothing
		 GT -> Just j -- PATTERN: |+|
	 (Equal, _) ->  -- PATTERN: +
		Just i

intersection :: Ord x => Interval x -> Interval x -> Maybe (Interval x)
intersection i j =
	case position i j of
	 (Away, _) -> -- PATTERN: -_| or |_-
		Nothing
	 (Adjacent, _) -> -- PATTERN: -| or |-
		Nothing
	 (Overlap, o) ->
		case o of
		 LT -> Just $ Interval (low j, high i) -- PATTERN: -+|
		 EQ -> Nothing
		 GT -> Just $ Interval (low i, high j) -- PATTERN: |+-
	 (Prefix, o) ->
		case o of
		 LT -> Just i -- PATTERN: +|
		 EQ -> Nothing
		 GT -> Just j -- PATTERN: +-
	 (Suffixed, o) ->
		case o of
		 LT -> Just j -- PATTERN: -+
		 EQ -> Nothing
		 GT -> Just i -- PATTERN: |+
	 (Include, o) ->
		case o of
		 LT -> Just j -- PATTERN: -+-
		 EQ -> Nothing
		 GT -> Just i -- PATTERN: |+|
	 (Equal, _) ->  -- PATTERN: +
		Just i

span :: Ord x => Interval x -> Interval x -> Interval x
span i j =
	Interval
	 ( unLL (min (LL $ low  i) (LL $ low  j))
	 , unHH (max (HH $ high i) (HH $ high j))
	 )

-- * Type 'Unlimitable'

data Unlimitable x
 = Unlimited_low
 | Limited { limited :: x }
 | Unlimited_high
 deriving (Eq, Ord, Show)
instance Functor Unlimitable where
	fmap _f Unlimited_low  = Unlimited_low
	fmap _f Unlimited_high = Unlimited_high
	fmap f (Limited x)    = Limited (f x)
instance Bounded (Unlimitable x) where
	minBound = Unlimited_low
	maxBound = Unlimited_high
instance Bounded (Limit (Unlimitable x)) where
	minBound = Limit In Unlimited_low
	maxBound = Limit In Unlimited_high

unlimited :: Ord x => Interval (Unlimitable x)
unlimited = Interval ( Limit In Unlimited_low
                     , Limit In Unlimited_high )

unlimit :: Ord x => Interval x -> Interval (Unlimitable x)
unlimit = fmap_unsafe Limited

(<..) :: Ord x => x -> Interval (Unlimitable x)
(<..) x = Interval (Limit Out (Limited x), Limit In Unlimited_high)

(<=..) :: Ord x => x -> Interval (Unlimitable x)
(<=..) x = Interval (Limit In (Limited x), Limit In Unlimited_high)

(..<) :: Ord x => x -> Interval (Unlimitable x)
(..<) x = Interval (Limit In Unlimited_low, Limit Out (Limited x))

(..<=) :: Ord x => x -> Interval (Unlimitable x)
(..<=) x = Interval (Limit In Unlimited_low, Limit In (Limited x))

-- * Type 'Pretty'

newtype Pretty x = Pretty x
 deriving (Eq, Ord)
instance (Ord x, Show x) => Show (Pretty (Interval x)) where
	show (Pretty i) =
		concat
		 [ case adherence (low i) of
			 In  -> "["
			 Out -> "]"
		 , show (limit $ low i)
		 , ".."
		 , show (limit $ high i)
		 , case adherence (high i) of
			 In  -> "]"
			 Out -> "["
		 ]
instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
	show (Pretty x) =
		case x of
		 Unlimited_low  -> "-oo"
		 Limited l      -> show l
		 Unlimited_high -> "+oo"