{-|
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 #-}
{-# LANGUAGE DeriveGeneric #-}

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

import safe      Control.Applicative            ( liftA2 )
import safe      Control.DeepSeq                ( NFData )
import safe      Data.Bifunctor                 ( Bifunctor(bimap) )
import safe      Data.Binary                    ( Binary )
import safe      GHC.Generics                   ( Generic )
import safe      IntervalAlgebra.Core           ( ComparativePredicateOf1
                                                , Interval
                                                , IntervalCombinable(..)
                                                , Intervallic(..)
                                                , before
                                                , extenterval
                                                )
import safe      Test.QuickCheck                ( Arbitrary(..) )
import safe      Witherable                     ( Filterable(filter) )

-- | 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, (forall x. PairedInterval b a -> Rep (PairedInterval b a) x)
-> (forall x. Rep (PairedInterval b a) x -> PairedInterval b a)
-> Generic (PairedInterval b a)
forall x. Rep (PairedInterval b a) x -> PairedInterval b a
forall x. PairedInterval b a -> Rep (PairedInterval b a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b a x. Rep (PairedInterval b a) x -> PairedInterval b a
forall b a x. PairedInterval b a -> Rep (PairedInterval b a) x
$cto :: forall b a x. Rep (PairedInterval b a) x -> PairedInterval b a
$cfrom :: forall b a x. PairedInterval b a -> Rep (PairedInterval b a) x
Generic)

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 Functor (PairedInterval b) where
  fmap :: (a -> b) -> PairedInterval b a -> PairedInterval b b
fmap a -> b
f (PairedInterval (Interval a
x, b
y)) = (Interval b, b) -> PairedInterval b b
forall b a. (Interval a, b) -> PairedInterval b a
PairedInterval ((a -> b) -> Interval a -> Interval b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Interval a
x, 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)

instance (NFData a, NFData b) => NFData (PairedInterval b a)
instance (Binary a, Binary b) => Binary (PairedInterval b a)

-- | 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, 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, Functor f) => f (PairedInterval b a) -> f (Interval a)
intervals :: f (PairedInterval b a) -> f (Interval a)
intervals = (PairedInterval b a -> Interval a)
-> f (PairedInterval b a) -> f (Interval a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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


-- Arbitrary instance
instance (Arbitrary b, Ord a, Arbitrary a) => Arbitrary (PairedInterval b a) where
  arbitrary :: Gen (PairedInterval b a)
arbitrary = (b -> Interval a -> PairedInterval b a)
-> Gen b -> Gen (Interval a) -> Gen (PairedInterval b a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> Interval a -> PairedInterval b a
forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval Gen b
forall a. Arbitrary a => Gen a
arbitrary Gen (Interval a)
forall a. Arbitrary a => Gen a
arbitrary