{-|
Module      : Paired interval 
Description : Extends the Interval Algebra to an interval paired with some data.
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
Stability   : experimental
-}
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module IntervalAlgebra.PairedInterval (
      PairedInterval
    , Empty
    , makePairedInterval
    , getPairData
    , intervals
    , equalPairData
    , toTrivialPair
    , trivialize
) where

import IntervalAlgebra  ( Interval
                        , Intervallic(..)
                        , before
                        , IntervalCombinable(..)
                        , ComparativePredicateOf1
                        , extenterval )
import Witherable       ( Filterable(filter) )
import Data.Bifunctor   ( Bifunctor(bimap) )

-- | An @Interval a@ paired with some other data of type @b@.
newtype PairedInterval b a = PairedInterval (Interval a, b)
    deriving (PairedInterval b a -> PairedInterval b a -> Bool
(PairedInterval b a -> PairedInterval b a -> Bool)
-> (PairedInterval b a -> PairedInterval b a -> Bool)
-> Eq (PairedInterval b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall b a.
(Eq a, Eq b) =>
PairedInterval b a -> PairedInterval b a -> Bool
/= :: PairedInterval b a -> PairedInterval b a -> Bool
$c/= :: forall b a.
(Eq a, Eq b) =>
PairedInterval b a -> PairedInterval b a -> Bool
== :: PairedInterval b a -> PairedInterval b a -> Bool
$c== :: forall b a.
(Eq a, Eq b) =>
PairedInterval b a -> PairedInterval b a -> Bool
Eq)

instance (Ord a) => Intervallic (PairedInterval b) a where
    getInterval :: PairedInterval b a -> Interval a
getInterval (PairedInterval (Interval a, b)
x)        = (Interval a, b) -> Interval a
forall a b. (a, b) -> a
fst (Interval a, b)
x
    setInterval :: PairedInterval b a -> Interval a -> PairedInterval b a
setInterval (PairedInterval (Interval a
x, b
y)) Interval a
i = (Interval a, b) -> PairedInterval b a
forall b a. (Interval a, b) -> PairedInterval b a
PairedInterval (Interval a
i, b
y)

instance Bifunctor PairedInterval where
    bimap :: (a -> b) -> (c -> d) -> PairedInterval a c -> PairedInterval b d
bimap a -> b
f c -> d
g (PairedInterval (Interval c
x, a
y)) = (Interval d, b) -> PairedInterval b d
forall b a. (Interval a, b) -> PairedInterval b a
PairedInterval ((c -> d) -> Interval c -> Interval d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Interval c
x, a -> b
f a
y)

-- | Defines A total ordering on 'PairedInterval b a' based on the 'Interval a'
--   part.
instance (Eq a, Eq b, Ord a) => Ord (PairedInterval b a) where
  <= :: PairedInterval b a -> PairedInterval b a -> Bool
(<=) PairedInterval b a
x PairedInterval b a
y = PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
x Interval a -> Interval a -> Bool
forall a. Ord a => a -> a -> Bool
<= PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
y
  < :: PairedInterval b a -> PairedInterval b a -> Bool
(<) PairedInterval b a
x PairedInterval b a
y  = PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
x Interval a -> Interval a -> Bool
forall a. Ord a => a -> a -> Bool
<  PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
y

instance (Show b, Show a, Ord a) => Show (PairedInterval b a) where
    show :: PairedInterval b a -> String
show PairedInterval b a
x = String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Interval a -> String
forall a. Show a => a -> String
show (PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show (PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

instance (Ord a, Show a, Eq b, Monoid b) => 
          IntervalCombinable (PairedInterval b) a where
    >< :: PairedInterval b a
-> PairedInterval b a -> Maybe (PairedInterval b a)
(><) PairedInterval b a
x PairedInterval b a
y = (Interval a -> PairedInterval b a)
-> Maybe (Interval a) -> Maybe (PairedInterval b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Interval a -> PairedInterval b a
forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval b
forall a. Monoid a => a
mempty) (PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
x Interval a -> Interval a -> Maybe (Interval a)
forall (i :: * -> *) a.
IntervalCombinable i a =>
i a -> i a -> Maybe (i a)
>< PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval PairedInterval b a
y)

    <+> :: PairedInterval b a -> PairedInterval b a -> f (PairedInterval b a)
(<+>) PairedInterval b a
x PairedInterval b a
y
        | PairedInterval b a
x ComparativePredicateOf2 (PairedInterval b a) (PairedInterval b a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
`before` PairedInterval b a
y = PairedInterval b a -> f (PairedInterval b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairedInterval b a
x f (PairedInterval b a)
-> f (PairedInterval b a) -> f (PairedInterval b a)
forall a. Semigroup a => a -> a -> a
<> PairedInterval b a -> f (PairedInterval b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PairedInterval b a
y
        | Bool
otherwise    = PairedInterval b a -> f (PairedInterval b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PairedInterval b a -> f (PairedInterval b a))
-> PairedInterval b a -> f (PairedInterval b a)
forall a b. (a -> b) -> a -> b
$ b -> Interval a -> PairedInterval b a
forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x b -> b -> b
forall a. Semigroup a => a -> a -> a
<> PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
y)
                                                 (PairedInterval b a -> PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> i a -> Interval a
extenterval PairedInterval b a
x PairedInterval b a
y) 


-- | Make a paired interval. 
makePairedInterval :: b -> Interval a -> PairedInterval b a
makePairedInterval :: b -> Interval a -> PairedInterval b a
makePairedInterval b
d Interval a
i = (Interval a, b) -> PairedInterval b a
forall b a. (Interval a, b) -> PairedInterval b a
PairedInterval (Interval a
i, b
d)

-- | Gets the data (i.e. non-interval) part of a @PairedInterval@.
getPairData :: PairedInterval b a -> b
getPairData :: PairedInterval b a -> b
getPairData (PairedInterval (Interval a
_, b
y)) = b
y

-- | Tests for equality of the data in a @PairedInterval@.
equalPairData :: (Eq b) => ComparativePredicateOf1 (PairedInterval b a)
equalPairData :: ComparativePredicateOf1 (PairedInterval b a)
equalPairData PairedInterval b a
x PairedInterval b a
y = PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== PairedInterval b a -> b
forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
y

-- | Gets the intervals from a list of paired intervals.
intervals :: (Ord a, Show a) => [PairedInterval b a] -> [Interval a]
intervals :: [PairedInterval b a] -> [Interval a]
intervals = (PairedInterval b a -> Interval a)
-> [PairedInterval b a] -> [Interval a]
forall a b. (a -> b) -> [a] -> [b]
map PairedInterval b a -> Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Interval a
getInterval

-- | Empty is used to trivially lift an @Interval a@ into a @PairedInterval@.
data Empty = Empty deriving (Empty -> Empty -> Bool
(Empty -> Empty -> Bool) -> (Empty -> Empty -> Bool) -> Eq Empty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Empty -> Empty -> Bool
$c/= :: Empty -> Empty -> Bool
== :: Empty -> Empty -> Bool
$c== :: Empty -> Empty -> Bool
Eq, Eq Empty
Eq Empty
-> (Empty -> Empty -> Ordering)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Bool)
-> (Empty -> Empty -> Empty)
-> (Empty -> Empty -> Empty)
-> Ord Empty
Empty -> Empty -> Bool
Empty -> Empty -> Ordering
Empty -> Empty -> Empty
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Empty -> Empty -> Empty
$cmin :: Empty -> Empty -> Empty
max :: Empty -> Empty -> Empty
$cmax :: Empty -> Empty -> Empty
>= :: Empty -> Empty -> Bool
$c>= :: Empty -> Empty -> Bool
> :: Empty -> Empty -> Bool
$c> :: Empty -> Empty -> Bool
<= :: Empty -> Empty -> Bool
$c<= :: Empty -> Empty -> Bool
< :: Empty -> Empty -> Bool
$c< :: Empty -> Empty -> Bool
compare :: Empty -> Empty -> Ordering
$ccompare :: Empty -> Empty -> Ordering
$cp1Ord :: Eq Empty
Ord, Int -> Empty -> ShowS
[Empty] -> ShowS
Empty -> String
(Int -> Empty -> ShowS)
-> (Empty -> String) -> ([Empty] -> ShowS) -> Show Empty
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Empty] -> ShowS
$cshowList :: [Empty] -> ShowS
show :: Empty -> String
$cshow :: Empty -> String
showsPrec :: Int -> Empty -> ShowS
$cshowsPrec :: Int -> Empty -> ShowS
Show)
instance Semigroup Empty where 
    Empty
x <> :: Empty -> Empty -> Empty
<> Empty
y = Empty
Empty
instance Monoid Empty where
    mempty :: Empty
mempty = Empty
Empty
    mappend :: Empty -> Empty -> Empty
mappend Empty
x Empty
y = Empty
x Empty -> Empty -> Empty
forall a. Semigroup a => a -> a -> a
<> Empty
y

-- | Lifts an @Interval a@ into a @PairedInterval Empty a@, where @Empty@ is a
--   trivial type that contains no data.
toTrivialPair :: Interval a -> PairedInterval Empty a
toTrivialPair :: Interval a -> PairedInterval Empty a
toTrivialPair = Empty -> Interval a -> PairedInterval Empty a
forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval Empty
Empty

-- | Lifts a @Functor@ containing @Interval a@(s) into a @Functor@ containing
--   @PairedInterval Empty a@(s).
trivialize :: Functor f => f (Interval a) -> f (PairedInterval Empty a)
trivialize :: f (Interval a) -> f (PairedInterval Empty a)
trivialize = (Interval a -> PairedInterval Empty a)
-> f (Interval a) -> f (PairedInterval Empty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Interval a -> PairedInterval Empty a
forall a. Interval a -> PairedInterval Empty a
toTrivialPair