interval-algebra-2.1.0: src/IntervalAlgebra/Arbitrary.hs
{-|
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 #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
, PairedInterval
, beginerval
, converse
, duration
, makePairedInterval
, moment
, predicate
, strictWithinRelations
)
import Prelude ( (==)
, Eq
)
import Test.QuickCheck ( Arbitrary(arbitrary, shrink)
, Gen
, NonNegative
, arbitrarySizedNatural
, elements
, resize
, sized
, suchThat
)
-- NOTE: the default size for arbitrary :: Gen Int appears to be 30
arbitrarySizedPositive :: Integral a => Gen a
arbitrarySizedPositive = (+ 1) <$> 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 = 86399
instance Arbitrary DT.Day where
arbitrary = sized (\s -> DT.ModifiedJulianDay <$> s `resize` arbitrary)
shrink = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay
instance Arbitrary DT.NominalDiffTime where
arbitrary = sized
(\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))
instance Arbitrary DT.DiffTime where
arbitrary = sized
(\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))
instance Arbitrary DT.UTCTime where
arbitrary = liftA2 UTCTime arbitrary 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@.
--
-- @
-- > import Test.QuickCheck (generate)
-- > import Data.Set (fromList)
-- > isJust $ 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
:: forall i a b
. (IntervalSizeable a b, Intervallic i, 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 iv rs
| rs == Data.Set.singleton Equals = elements [Just iv]
| isEnclose && isMom = elements [Nothing]
| isMom = Just <$> arbitrary `suchThat` predicate notStrictEnclose iv
| otherwise = Just <$> arbitrary `suchThat` predicate rs iv
where
notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations)
isEnclose = Data.Set.null notStrictEnclose
isMom = duration iv == moment @a