{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
module IntervalAlgebra.IntervalUtilitiesSpec (spec) where
import Control.Monad (liftM2)
import Data.List (sort)
import Data.Maybe (fromJust, isJust, isNothing)
import Data.Set (Set, difference, fromList,
member, toList)
import qualified Data.Set (null)
import Data.Time (Day, UTCTime)
import IntervalAlgebra (Interval,
IntervalCombinable (..),
IntervalRelation (..),
IntervalSizeable,
Intervallic (..),
beginerval, complement,
converse, disjointRelations,
duration, intervalRelations,
moment', predicate, starts,
strictWithinRelations,
withinRelations)
import IntervalAlgebra.Arbitrary (arbitraryWithRelation)
import IntervalAlgebra.IntervalUtilities (clip, combineIntervals,
durations, filterAfter,
filterBefore, filterConcur,
filterContains,
filterDisjoint,
filterDuring, filterEnclose,
filterEnclosedBy,
filterEquals,
filterFinishedBy,
filterFinishes, filterMeets,
filterMetBy,
filterNotDisjoint,
filterOverlappedBy,
filterOverlaps,
filterStartedBy,
filterStarts, filterWithin,
foldMeetingSafe,
formMeetingSequence, gaps,
gapsL, gapsWithin,
intersect, nothingIfAll,
nothingIfAny, nothingIfNone,
relationsL)
import IntervalAlgebra.PairedInterval (PairedInterval, getPairData,
makePairedInterval,
trivialize)
import Test.Hspec (Spec, describe, it,
shouldBe)
import Test.Hspec.QuickCheck (modifyMaxDiscardRatio,
modifyMaxSuccess)
import Test.QuickCheck (Arbitrary (arbitrary, shrink),
Arbitrary1 (liftArbitrary),
Property,
Testable (property),
elements, listOf,
orderedList, resize,
sublistOf, suchThat, (===),
(==>))
import Witherable (Filterable)
-- Types for testing
-- SmallInterval is just to test properties for which events of interest are so
-- rare QuickCheck gives up, e.g. filterEquals
newtype SmallInterval
= SmallInterval { unSmall :: Interval Int }
deriving (Eq, Show)
instance Arbitrary SmallInterval where
arbitrary = SmallInterval . beginerval 0 <$> elements [0..10]
-- A "state" here is just used test formMeetingSequence
newtype Events a
= Events { getEvents :: [PairedInterval State a] }
deriving (Eq, Ord, Show)
newtype State
= State [Bool]
deriving (Eq, Show)
instance Semigroup State where
State x <> State y = State $ zipWith (||) x y
instance Monoid State where
mempty = State [False, False, False]
type StateEvent a = PairedInterval State a
-- Type for checking arbitraryWithRelation
-- A target and reference pair, where targetInterval satisfies at least one of
-- refRelations relative to refInterval
data IntervalReferenced
= IntervalReferenced
{ refInterval :: Interval Int
, refRelations :: Set IntervalRelation
, targetInterval :: Maybe (Interval Int)
}
deriving (Eq, Show)
readInterval :: IntervalSizeable a a => (a, a) -> Interval a
readInterval (b, e) = beginerval (e - b) b
mkEv :: IntervalSizeable a a => (a, a) -> b -> PairedInterval b a
mkEv i s = makePairedInterval s (readInterval i)
instance Arbitrary State where
arbitrary = State <$> suchThat (listOf arbitrary) (\x -> length x == 3)
-- SmallInterval again to address issue of generating from too large a possible
-- range of intervals
instance Arbitrary (PairedInterval State Int) where
arbitrary = liftM2 makePairedInterval arbitrary (unSmall <$> arbitrary)
instance Arbitrary (Events Int) where
arbitrary = Events <$> orderedList
-- restricted refIv to decrease rareness causing quickcheck to quit
instance Arbitrary IntervalReferenced where
arbitrary = do
refIv <- liftM2 beginerval (elements [1..3]) (elements [0..3])
rels <- fromList <$> sublistOf (toList intervalRelations)
iv <- arbitraryWithRelation refIv rels
return $ IntervalReferenced refIv rels iv
-- Testing functions
checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool
checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x)
-- Creation functions
iv :: Int -> Int -> Interval Int
iv = beginerval
evpi :: Int -> Int -> [Bool] -> StateEvent Int
evpi i j s = makePairedInterval (State s) (beginerval i j)
-- Test cases
containmentInt :: Interval Int
containmentInt = iv (10 :: Int) (0 :: Int)
noncontainmentInt :: Interval Int
noncontainmentInt = iv 6 4
anotherInt :: Interval Int
anotherInt = iv 5 (15 :: Int)
gapInt :: Interval Int
gapInt = iv 5 (10 :: Int)
meets1 :: [Interval Int]
meets1 = [iv 2 0, iv 2 2]
meets2 :: [Interval Int]
meets2 = [iv 2 0, iv 2 2, iv 10 4, iv 2 14]
meets3 :: [PairedInterval Int Int]
meets3 = map (uncurry makePairedInterval) [
(5, iv 2 0)
, (5, iv 2 2)
, (9, iv 10 4)
, (10, iv 2 14)]
meets3eq :: [PairedInterval Int Int]
meets3eq = map (uncurry makePairedInterval) [
(5, iv 4 0)
, (9, iv 10 4)
, (10, iv 2 14)]
c0in :: [StateEvent Int]
c0in =
[ evpi 9 1 [True, False, False]
, evpi 8 2 [True, False, False]
, evpi 3 5 [False, True, False]
, evpi 3 6 [False, True, False]]
c0out :: [StateEvent Int]
c0out =
[ evpi 4 1 [True, False, False]
, evpi 4 5 [True, True, False]
, evpi 1 9 [True, False, False]]
c1in :: [StateEvent Int]
c1in =
[ evpi 4 1 [True, False, False ]
, evpi 4 6 [False, True, False ]]
c1out :: [StateEvent Int]
c1out =
[ evpi 4 1 [True, False, False]
, evpi 1 5 [False, False, False]
, evpi 4 6 [False, True, False]]
c2in :: [StateEvent Int]
c2in =
[ evpi 4 1 [True, False, False ]
, evpi 5 5 [False, True, False ]]
c2out :: [StateEvent Int]
c2out =
[ evpi 4 1 [True, False, False]
, evpi 5 5 [False, True, False]]
c3in :: [StateEvent Int]
c3in =
[ evpi 4 1 [True, False, False ]
, evpi 6 4 [False, True, False ]]
c3out :: [StateEvent Int]
c3out =
[ evpi 3 1 [True, False, False]
, evpi 1 4 [True, True, False]
, evpi 5 5 [False, True, False]]
c4in :: [StateEvent Int]
c4in =
[ evpi 1 (-1) [True, True, False ]
, evpi 1 3 [True, False, True ]
, evpi 1 3 [False, False, False]]
c4out :: [StateEvent Int]
c4out =
[ evpi 1 (-1) [True, True, False ]
, evpi 3 0 [False, False, False]
, evpi 1 3 [True, False, True ]]
c5in :: [StateEvent Int]
c5in = [
mkEv (-63, 21) (State [False,True,True])
, mkEv (-56, 20) (State [True,True,True])
, mkEv (1, 41) (State [False,True,False])
, mkEv (11, 34) (State [True,False,True])
, mkEv (27, 28) (State [False,True,True])
]
c5out :: [StateEvent Int]
c5out = [
mkEv (-63, -56) (State [False,True,True])
, mkEv (-56, 34) (State [True,True,True])
, mkEv (34, 41) (State [False,True,False])
]
-- Properties
-- arbitraryWithRelation props
-- 'tautology' because this repeats the logic of arbitraryWithRelation
prop_withRelation_tautology :: IntervalReferenced -> Bool
prop_withRelation_tautology ir
| isEnclose && isMom = isNothing iv
| otherwise = isJust iv && predicate rels refIv (fromJust iv)
where
refIv = refInterval ir
iv = targetInterval ir
rels = refRelations ir
isEnclose = Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations)
isMom = duration refIv == moment' refIv
-- Check that the only relation remaining after applying a function is Before
prop_before:: (Ord a)=>
([Interval a] -> [Interval a])
-> [Interval a]
-> Property
prop_before f x = relationsL ci === replicate (length ci - 1) Before
where ci = f (sort x)
prop_combineIntervals1:: (Ord a, Show a, Eq a)=>
[Interval a]
-> Property
prop_combineIntervals1 = prop_before combineIntervals
prop_gaps1:: (Ord a)=>
[Interval a]
-> Property
prop_gaps1 = prop_before gapsL
-- In the case that that the input is not null, then
-- * all relationsL should be `Meets` after formMeetingSequence
prop_formMeetingSequence0::
Events Int
-> Property
prop_formMeetingSequence0 x =
not (null es) ==> all (== Meets) (relationsL $ formMeetingSequence es) === True
where es = getEvents x
-- In the case that the input has
-- * at least one Before relation between consequent pairs
-- * AND does not have any empty states
--
-- THEN the number empty states in the output should smaller than or equal to
-- the number before relationsL in the output
prop_formMeetingSequence1::
Events Int
-> Property
prop_formMeetingSequence1 x =
( beforeCount > 0 &&
not (any (\x -> getPairData x == State [False, False, False]) (getEvents x))
) ==> beforeCount >= emptyCount
where res = formMeetingSequence (getEvents x)
beforeCount = lengthWhen (== Before) (relationsL (getEvents x))
emptyCount = lengthWhen (\x -> getPairData x == mempty ) res
lengthWhen f = length . filter f
-- Check that formMeetingSequence doesn't return an empty list unless input is
-- empty.
prop_formMeetingSequence2::
Events Int
-> Property
prop_formMeetingSequence2 x = not (null $ getEvents x) ==> not $ null res
where res = formMeetingSequence (getEvents x)
class ( Ord a ) => FiltrationProperties a where
prop_filtration ::
(Interval a -> [Interval a] -> [Interval a])
-> Set IntervalRelation
-> Interval a
-> [Interval a]
-> Property
prop_filtration fltr s x l =
not (null res) ==> and (fmap (predicate s x) res) === True
where res = fltr x l
prop_filterOverlaps :: Interval a
-> [Interval a]
-> Property
prop_filterOverlaps = prop_filtration filterOverlaps (fromList [Overlaps])
prop_filterOverlappedBy :: Interval a
-> [Interval a]
-> Property
prop_filterOverlappedBy = prop_filtration filterOverlappedBy (fromList [OverlappedBy])
prop_filterBefore :: Interval a
-> [Interval a]
-> Property
prop_filterBefore = prop_filtration filterBefore (fromList [Before])
prop_filterAfter :: Interval a
-> [Interval a]
-> Property
prop_filterAfter = prop_filtration filterAfter (fromList [After])
prop_filterStarts :: Interval a
-> [Interval a]
-> Property
prop_filterStarts = prop_filtration filterStarts (fromList [Starts])
prop_filterStartedBy :: Interval a
-> [Interval a]
-> Property
prop_filterStartedBy = prop_filtration filterStartedBy (fromList [StartedBy])
prop_filterFinishes :: Interval a
-> [Interval a]
-> Property
prop_filterFinishes = prop_filtration filterFinishes (fromList [Finishes])
prop_filterFinishedBy :: Interval a
-> [Interval a]
-> Property
prop_filterFinishedBy = prop_filtration filterFinishedBy (fromList [FinishedBy])
prop_filterMeets :: Interval a
-> [Interval a]
-> Property
prop_filterMeets = prop_filtration filterMeets (fromList [Meets])
prop_filterMetBy :: Interval a
-> [Interval a]
-> Property
prop_filterMetBy = prop_filtration filterMetBy (fromList [MetBy])
prop_filterDuring :: Interval a
-> [Interval a]
-> Property
prop_filterDuring = prop_filtration filterDuring (fromList [During])
prop_filterContains :: Interval a
-> [Interval a]
-> Property
prop_filterContains = prop_filtration filterContains (fromList [Contains])
prop_filterEquals :: Interval a
-> [Interval a]
-> Property
prop_filterEquals = prop_filtration filterEquals (fromList [Equals])
prop_filterDisjoint :: Interval a
-> [Interval a]
-> Property
prop_filterDisjoint = prop_filtration filterDisjoint disjointRelations
prop_filterNotDisjoint :: Interval a
-> [Interval a]
-> Property
prop_filterNotDisjoint = prop_filtration filterNotDisjoint (complement disjointRelations)
prop_filterWithin :: Interval a
-> [Interval a]
-> Property
prop_filterWithin = prop_filtration filterWithin withinRelations
prop_filterEnclosedBy :: Interval a
-> [Interval a]
-> Property
prop_filterEnclosedBy = prop_filtration filterEnclosedBy withinRelations
prop_filterEnclose :: Interval a
-> [Interval a]
-> Property
prop_filterEnclose = prop_filtration filterEnclose (converse withinRelations)
prop_filterConcur :: Interval a
-> [Interval a]
-> Property
prop_filterConcur = prop_filtration filterConcur (complement disjointRelations)
instance FiltrationProperties Int
prop_clip_intersect :: (Show a, Ord a, IntervalSizeable a b) =>
Interval a -> Interval a -> Property
prop_clip_intersect x y =
clip x y === intersect (min x y) (max x y)
-- NOTE: use this instead of prop_filterEquals
prop_small_filterEquals :: SmallInterval -> [SmallInterval] -> Property
prop_small_filterEquals x l =
not (null res) ==> and (fmap (predicate s i) res) === True
where
i = unSmall x
li = map unSmall l
res = filterEquals i li
s = fromList [Equals]
-- RUNNER
spec :: Spec
spec = do
describe "gaps tests" $
modifyMaxSuccess (*10) $
do
it "no gaps in containmentInt and noncontainmentInt" $
gapsL [containmentInt, noncontainmentInt] `shouldBe` []
it "no gaps in containmentInt" $
gapsL [containmentInt] `shouldBe` []
it "single gap between containmentInt and anotherInt" $
gapsL [containmentInt, anotherInt] `shouldBe` [gapInt]
it "after gaps, only relation should be Before" $
property (prop_gaps1 @Int)
describe "durations unit tests" $
do
it "durations of containmentInt is 10" $
durations [containmentInt] `shouldBe` [10]
it "durations of empty list is empty list" $
durations ([] :: [Interval Int]) `shouldBe` []
it "durations of [containmentInt, anotherInt] is [10, 5]" $
durations [containmentInt, anotherInt] `shouldBe` [10, 5]
describe "clip tests" $
do
it "clip disjoint should be Nothing" $
clip containmentInt gapInt `shouldBe` Nothing
it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)" $
clip noncontainmentInt containmentInt `shouldBe`
Just (iv 6 4)
it "clip x y === intersect sort x y " $
property (prop_clip_intersect @Int)
describe "relationsL tests" $
do
it "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $
relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe`
[FinishedBy, Meets, Meets]
it "relationsL of [] shouldBe []" $
relationsL ([] :: [Interval Int]) `shouldBe` []
it "relationsL of singleton shouldBe []" $
relationsL [containmentInt] `shouldBe` []
it "length of relationsL result should be 1 less then length of input" $
property (\x -> not (null x) ==> length (relationsL x) === length (x :: [Interval Int]) - 1 )
describe "gapsWithin tests" $
do
it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]" $
gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12]
`shouldBe` Just [iv 2 5, iv 1 9]
it "gapsWithin (1, 10) [(-1, 0), (12,15)] should be [(5,7), (9,10)]" $
gapsWithin (iv 9 1) [iv 1 (-1), iv 3 12]
`shouldBe` Nothing
it "gapsWithin (0, 455) [(0, 730), (731, 762), (763, 793)]" $
gapsWithin (readInterval (0 :: Int, 455))
(fmap readInterval [(0, 730), (731, 762), (763, 793)])
`shouldBe` Just []
it "gapsWithin (1, 10) [] should be []" $
gapsWithin (iv 9 1) ([] :: [Interval a]) `shouldBe` Nothing
describe "emptyIf tests" $
do
it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty" $
nothingIfNone (starts (iv 2 3)) [iv 1 3, iv 1 5]
`shouldBe` Nothing
it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input" $
nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5]
`shouldBe` Just [ iv 3 3, iv 1 5]
describe "filtration tests" $
modifyMaxDiscardRatio (*2) $
do
it "disjoint filter should filter out noncontainment" $
filterDisjoint containmentInt [noncontainmentInt, anotherInt]
`shouldBe` [anotherInt]
it "notDisjoint filter should keep noncontainment" $
filterNotDisjoint containmentInt [noncontainmentInt, anotherInt]
`shouldBe` [noncontainmentInt]
it "filterBefore property" $ property (prop_filterBefore @Int)
it "filterAfter property" $ property (prop_filterAfter @Int)
it "filterOverlaps property" $ property (prop_filterOverlaps @Int)
it "filterOverlappedBy property" $ property (prop_filterOverlappedBy @Int)
it "filterStarts property" $ property (prop_filterStarts @Int)
it "filterStartedBy property" $ property (prop_filterStartedBy @Int)
it "filterFinishes property" $ property (prop_filterFinishes @Int)
it "filterFinishedBy property" $ property (prop_filterFinishedBy @Int)
it "filterMeets property" $ property (prop_filterMeets @Int)
it "filterMetBy property" $ property (prop_filterMetBy @Int)
it "filterDuring property" $ property (prop_filterDuring @Int)
it "filterContains property" $ property (prop_filterContains @Int)
it "filterEquals property" $ property prop_small_filterEquals
it "filterDisjoint property" $ property (prop_filterDisjoint @Int)
it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int)
it "filterWithin property" $ property (prop_filterWithin @Int)
it "filterConcur property" $ property (prop_filterConcur @Int)
it "filterEnclose property" $ property (prop_filterEnclose @Int)
it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int)
describe "nothingIf unit tests" $
do
it "nothing from nothingIfAll" $
nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] `shouldBe` Nothing
it "something from nothingIfAll" $
nothingIfAll (starts (iv 2 3)) [iv 3 0, iv 4 3] `shouldBe` Just [iv 3 0, iv 4 3]
it "nothing from nothingIfAny" $
nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] `shouldBe` Nothing
it "something from nothingIfAny" $
nothingIfAny (starts (iv 2 3)) [iv 3 1, iv 1 5] `shouldBe` Just [iv 3 1, iv 1 5]
describe "intersection tests" $
do
it "intersection of (0, 2) (2, 4) should be Nothing" $
intersect (iv 2 0) (iv 2 2) `shouldBe` Nothing
it "intersection of (0, 2) (3, 4) should be Nothing" $
intersect (iv 2 0) (iv 1 3) `shouldBe` Nothing
it "intersection of (2, 4) (0, 2) should be Nothing" $
intersect (iv 2 2) (iv 2 0) `shouldBe` Nothing
describe "intersection tests" $
do
it "intersection of (0, 2) (2, 4) should be Nothing" $
intersect (iv 2 0) (iv 2 2) `shouldBe` Nothing
it "intersection of (0, 2) (3, 4) should be Nothing" $
intersect (iv 2 0) (iv 1 3) `shouldBe` Nothing
it "intersection of (2, 4) (0, 2) should be Nothing" $
intersect (iv 2 2) (iv 2 0) `shouldBe` Nothing
it "intersection of (0, 2) (1, 3) should be Just (1, 2)" $
intersect (iv 2 0) (iv 2 1) `shouldBe` Just (iv 1 1)
it "intersection of (0, 2) (-1, 3) should be Just (0, 2)" $
intersect (iv 2 0) (iv 4 (-1)) `shouldBe` Just (iv 2 0)
it "intersection of (0, 2) (0, 2) should be Just (0, 2)" $
intersect (iv 2 0) (iv 2 0) `shouldBe` Just (iv 2 0)
it "intersection of (0, 2) (-1, 1) should be Just (0, 1)" $
intersect (iv 2 0) (iv 2 (-1)) `shouldBe` Just (iv 1 0)
it "intersection of (0, 3) (1, 2) should be Just (1, 2)" $
intersect (iv 3 0) (iv 1 1) `shouldBe` Just (iv 1 1)
describe "combineIntervals unit tests" $
do
it "noncontainmentInt combined into containmentInt" $
combineIntervals [containmentInt, noncontainmentInt]
`shouldBe` [containmentInt]
it "noncontainmentInt combined into containmentInt; anotherInt unchanged" $
combineIntervals [containmentInt, noncontainmentInt, anotherInt]
`shouldBe` [containmentInt, anotherInt]
it "idempotency of containmentInt" $
combineIntervals [containmentInt] `shouldBe` [containmentInt]
it "idempotency of noncontainmentInt" $
combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt]
it "combineIntervals [] should be []" $
combineIntervals ([] :: [Interval Int]) `shouldBe` []
it "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]" $
combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]
`shouldBe` [iv 12 0, iv 2 13]
describe "combineIntervals property tests" $
modifyMaxSuccess (*10) $
do
it "after combining, only relation should be Before" $
property ( prop_combineIntervals1 @Int)
it "after combining, only relation should be Before" $
property ( prop_combineIntervals1 @Day)
it "after combining, only relation should be Before" $
property ( prop_combineIntervals1 @UTCTime)
describe "foldMeets unit tests" $
do
it "foldMeetingSafe meets1" $
foldMeetingSafe (trivialize meets1) `shouldBe`
trivialize [iv 4 0]
it "foldMeetingSafe meets2" $
foldMeetingSafe (trivialize meets2) `shouldBe`
trivialize [iv 16 0]
it "foldMeetingSafe meets3" $
foldMeetingSafe meets3 `shouldBe` meets3eq
describe "formMeetingSequence unit tests" $
do
it "formMeetingSequence unit test 0" $
formMeetingSequence c0in `shouldBe` c0out
it "formMeetingSequence unit test 1"$
formMeetingSequence c1in `shouldBe` c1out
it "formMeetingSequence unit test 2"$
formMeetingSequence c2in `shouldBe` c2out
it "formMeetingSequence unit test 3"$
formMeetingSequence c3in `shouldBe` c3out
it "formMeetingSequence unit test 4"$
formMeetingSequence c4in `shouldBe` c4out
it "formMeetingSequence unit test 5"$
formMeetingSequence c5in `shouldBe` c5out
it "formMeetingSequence unit test 6"$
formMeetingSequence ([] :: [StateEvent Int]) `shouldBe` []
describe "formMeetingSequence property tests" $
modifyMaxSuccess (*50) $
do
it "prop_formMeetingSequence0" $
property prop_formMeetingSequence0
it "prop_formMeetingSequence1" $
property prop_formMeetingSequence1
it "prop_formMeetingSequence2" $
property prop_formMeetingSequence2
describe "arbitraryWithRelation property tests" $
do
it "prop_withRelation_tautology" $
property prop_withRelation_tautology