{-|
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
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 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) = 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 = 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 = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval b a
x forall a. Ord a => a -> a -> Bool
<= 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 = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval b a
x forall a. Ord a => a -> a -> Bool
< 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
"{" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval b a
x) forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval forall a. Monoid a => a
mempty) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval b a
x forall (i :: * -> *) a.
IntervalCombinable i a =>
i a -> i a -> Maybe (i 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 forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
`before` PairedInterval b a
y = forall (f :: * -> *) a. Applicative f => a -> f a
pure PairedInterval b a
x forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure PairedInterval b a
y
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x forall a. Semigroup a => a -> a -> a
<> forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
y) (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 = 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 = forall b a. PairedInterval b a -> b
getPairData PairedInterval b a
x forall a. Eq a => a -> a -> Bool
== 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
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
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
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 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval forall a. Arbitrary a => Gen a
arbitrary forall a. Arbitrary a => Gen a
arbitrary