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

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.Binary          (Binary)
import safe           GHC.Generics         (Generic)
import safe           IntervalAlgebra.Core (ComparativePredicateOf1, Interval,
                                            IntervalCombinable (..),
                                            IntervalSizeable, 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 Intervallic (PairedInterval b) where
  getInterval :: forall a. 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 :: forall a b. PairedInterval b a -> Interval b -> PairedInterval b b
setInterval (PairedInterval (Interval a
x, b
y)) Interval b
i = (Interval b, b) -> PairedInterval b b
forall b a. (Interval a, b) -> PairedInterval b a
PairedInterval (Interval b
i, b
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 => 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 => 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 => 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 => 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 => 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 => 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 => i a -> Interval a
getInterval PairedInterval b a
y)

  <+> :: forall (f :: * -> *).
(Semigroup (f (PairedInterval b a)), Applicative f) =>
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 a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
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 a (i :: * -> *).
(Ord a, Intervallic i) =>
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 :: forall b a. 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 :: forall b a. 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 :: forall b a. Eq b => 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 :: forall a (f :: * -> *) b.
(Ord a, Functor f) =>
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 => 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
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

-- | 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 :: forall a. 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 :: forall (f :: * -> *) a.
Functor f =>
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