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

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

-- * 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 'Data.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 (Data.Functor.fmap f il) (Data.Functor.fmap f ih)

-- | Like 'Data.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 (Data.Functor.fmap f il, Data.Functor.fmap f ih)

{-
-- | Like 'Data.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 'Data.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"