{-|
Module      : Generate arbitrary Intervals
Description : Functions for generating arbitrary intervals
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
Stability   : experimental
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Safe              #-}


module IntervalAlgebra.Arbitrary( arbitraryWithRelation ) where

import           Control.Applicative (liftA2, (<$>))
import           Control.Monad       (liftM2)
import           Data.Bool
import           Data.Fixed
import           Data.Function       (flip, ($), (.))
import           Data.Maybe          (Maybe (Just, Nothing))
import           Data.Ord
import qualified Data.Set            (Set, difference, null, singleton)
import           Data.Time           as DT (Day (ModifiedJulianDay), DiffTime,
                                            NominalDiffTime, UTCTime (..),
                                            picosecondsToDiffTime,
                                            secondsToDiffTime,
                                            secondsToNominalDiffTime,
                                            toModifiedJulianDay)
import           GHC.Float
import           GHC.Int             (Int)
import           GHC.Num
import           GHC.Real
import           IntervalAlgebra     (Interval, IntervalRelation (..),
                                      IntervalSizeable, Intervallic, beginerval,
                                      converse, duration, moment', predicate,
                                      strictWithinRelations)
import           Prelude             (Eq, (==))
import           Test.QuickCheck     (Arbitrary (arbitrary, shrink), Gen,
                                      NonNegative, arbitrarySizedNatural,
                                      elements, resize, suchThat, sized)

-- NOTE: the default size for arbitrary :: Gen Int appears to be 30
arbitrarySizedPositive :: Integral a => Gen a
arbitrarySizedPositive :: Gen a
arbitrarySizedPositive = (a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (a -> a) -> Gen a -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Integral a => Gen a
arbitrarySizedNatural

-- resize in utctDayTime is to avoid rare leap-seconds-related failure, in
-- which e.g.  1858-12-31 00:00:00 UTC /= 1858-12-30 23:59:60 UTC
maxDiffTime :: Int
maxDiffTime :: Int
maxDiffTime = Int
86399

instance Arbitrary (Interval Int) where
  arbitrary :: Gen (Interval Int)
arbitrary = (Int -> Int -> Interval Int)
-> Gen Int -> Gen Int -> Gen (Interval Int)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Int -> Interval Int
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval Gen Int
forall a. Integral a => Gen a
arbitrarySizedPositive Gen Int
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary DT.Day where
    arbitrary :: Gen Day
arbitrary = (Int -> Gen Day) -> Gen Day
forall a. (Int -> Gen a) -> Gen a
sized (\Int
s -> Integer -> Day
DT.ModifiedJulianDay (Integer -> Day) -> Gen Integer -> Gen Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
s Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
`resize` Gen Integer
forall a. Arbitrary a => Gen a
arbitrary)
    shrink :: Day -> [Day]
shrink    = (Integer -> Day
DT.ModifiedJulianDay (Integer -> Day) -> [Integer] -> [Day]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([Integer] -> [Day]) -> (Day -> [Integer]) -> Day -> [Day]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> [Integer]
forall a. Arbitrary a => a -> [a]
shrink (Integer -> [Integer]) -> (Day -> Integer) -> Day -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Integer
DT.toModifiedJulianDay

instance Arbitrary DT.NominalDiffTime where
   arbitrary :: Gen NominalDiffTime
arbitrary = (Int -> Gen NominalDiffTime) -> Gen NominalDiffTime
forall a. (Int -> Gen a) -> Gen a
sized (\Int
s -> Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Gen Integer -> Gen NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
s Int
maxDiffTime Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
`resize` Gen Integer
forall a. Integral a => Gen a
arbitrarySizedNatural))

instance Arbitrary DT.DiffTime where
   arbitrary :: Gen DiffTime
arbitrary = (Int -> Gen DiffTime) -> Gen DiffTime
forall a. (Int -> Gen a) -> Gen a
sized (\Int
s -> Integer -> DiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
s Int
maxDiffTime Int -> Gen Integer -> Gen Integer
forall a. Int -> Gen a -> Gen a
`resize` Gen Integer
forall a. Integral a => Gen a
arbitrarySizedNatural))

instance Arbitrary DT.UTCTime  where
    arbitrary :: Gen UTCTime
arbitrary = (Day -> DiffTime -> UTCTime)
-> Gen Day -> Gen DiffTime -> Gen UTCTime
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Day -> DiffTime -> UTCTime
UTCTime Gen Day
forall a. Arbitrary a => Gen a
arbitrary Gen DiffTime
forall a. Arbitrary a => Gen a
arbitrary
                  
instance Arbitrary (Interval DT.Day) where
  arbitrary :: Gen (Interval Day)
arbitrary = (Integer -> Day -> Interval Day)
-> Gen Integer -> Gen Day -> Gen (Interval Day)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Integer -> Day -> Interval Day
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Day
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary (Interval DT.UTCTime) where
  arbitrary :: Gen (Interval UTCTime)
arbitrary = (NominalDiffTime -> UTCTime -> Interval UTCTime)
-> Gen NominalDiffTime -> Gen UTCTime -> Gen (Interval UTCTime)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 NominalDiffTime -> UTCTime -> Interval UTCTime
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval Gen NominalDiffTime
forall a. Arbitrary a => Gen a
arbitrary Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary

-- | Conditional generation of intervals relative to a reference.  If the
-- reference `iv` is of 'moment' duration, it is not possible to generate
-- intervals from the strict enclose relations StartedBy, Contains, FinishedBy.
-- If `iv` and `rs` are such that no possible relations can be generated, this
-- function returns `Nothing`. Otherwise, it returns `Just` an interval that
-- satisfies at least one of the possible relations in `rs` relative to
-- `iv`.
--
-- >>> generate $ arbitraryWithRelation (beginerval 10 (0::Int)) (fromList [Before])
-- Just (20, 22)
-- >>> generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy])
-- Nothing
-- >>> generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy, Before])
-- Just (4, 13)
arbitraryWithRelation :: (IntervalSizeable a b, Intervallic i a, Arbitrary (i a)) => 
  i a -- ^ reference interval
  -> Data.Set.Set IntervalRelation -- ^ set of `IntervalRelation`s, of which at least one will hold for the generated interval relative to the reference
  -> Gen (Maybe (i a))
arbitraryWithRelation :: i a -> Set IntervalRelation -> Gen (Maybe (i a))
arbitraryWithRelation i a
iv Set IntervalRelation
rs
  | Set IntervalRelation
rs Set IntervalRelation -> Set IntervalRelation -> Bool
forall a. Eq a => a -> a -> Bool
== IntervalRelation -> Set IntervalRelation
forall a. a -> Set a
Data.Set.singleton IntervalRelation
Equals = [Maybe (i a)] -> Gen (Maybe (i a))
forall a. [a] -> Gen a
elements [i a -> Maybe (i a)
forall a. a -> Maybe a
Just i a
iv]
  | Bool
isEnclose Bool -> Bool -> Bool
&& Bool
isMom = [Maybe (i a)] -> Gen (Maybe (i a))
forall a. [a] -> Gen a
elements [Maybe (i a)
forall a. Maybe a
Nothing]
  | Bool
isMom = i a -> Maybe (i a)
forall a. a -> Maybe a
Just (i a -> Maybe (i a)) -> Gen (i a) -> Gen (Maybe (i a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (i a)
forall a. Arbitrary a => Gen a
arbitrary Gen (i a) -> (i a -> Bool) -> Gen (i a)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Set IntervalRelation -> ComparativePredicateOf2 (i a) (i a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
Set IntervalRelation -> ComparativePredicateOf2 (i0 a) (i1 a)
predicate Set IntervalRelation
notStrictEnclose i a
iv
  | Bool
otherwise = i a -> Maybe (i a)
forall a. a -> Maybe a
Just (i a -> Maybe (i a)) -> Gen (i a) -> Gen (Maybe (i a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (i a)
forall a. Arbitrary a => Gen a
arbitrary Gen (i a) -> (i a -> Bool) -> Gen (i a)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Set IntervalRelation -> ComparativePredicateOf2 (i a) (i a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
Set IntervalRelation -> ComparativePredicateOf2 (i0 a) (i1 a)
predicate Set IntervalRelation
rs i a
iv
  where
    notStrictEnclose :: Set IntervalRelation
notStrictEnclose = Set IntervalRelation
-> Set IntervalRelation -> Set IntervalRelation
forall a. Ord a => Set a -> Set a -> Set a
Data.Set.difference Set IntervalRelation
rs (Set IntervalRelation -> Set IntervalRelation
converse Set IntervalRelation
strictWithinRelations)
    isEnclose :: Bool
isEnclose = Set IntervalRelation -> Bool
forall a. Set a -> Bool
Data.Set.null Set IntervalRelation
notStrictEnclose
    isMom :: Bool
isMom = i a -> b
forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i a) =>
i a -> b
duration i a
iv b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== i a -> b
forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i a) =>
i a -> b
moment' i a
iv