module IntMap (intMapProps) where
import Test.Tasty
import Test.Tasty.QuickCheck as QC
import qualified Data.Set as Set
import Data.RangeSet.IntMap (RIntSet)
import qualified Data.RangeSet.IntMap as RSet
import Control.Applicative
import Data.Semigroup
import SetAction
toRSet :: SetAction Int -> RIntSet
toRSet AEmpty = RSet.empty
toRSet (ASingleton a) = RSet.singleton a
toRSet (AFromList l) = RSet.fromList l
toRSet (AInsert a set) = RSet.insert a $ toRSet set
toRSet (ADelete a set) = RSet.delete a $ toRSet set
toRSet (AUnion a b) = RSet.union (toRSet a) (toRSet b)
toRSet (ADifference a b) = RSet.difference (toRSet a) (toRSet b)
toRSet (AIntersection a b) = RSet.intersection (toRSet a) (toRSet b)
elementsProp :: SetAction Int -> Property
elementsProp seta = Set.elems (toSet seta) === RSet.elems (toRSet seta)
sizeProp :: SetAction Int -> Property
sizeProp seta = Set.size (toSet seta) === RSet.size (toRSet seta)
nullProp :: SetAction Int -> Property
nullProp seta = Set.null (toSet seta) === RSet.null (toRSet seta)
memberProp :: Int -> SetAction Int -> Property
memberProp x seta = Set.member x (toSet seta) === RSet.member x (toRSet seta)
notMemberProp :: Int -> RSetAction Int -> Property
notMemberProp x seta = Set.notMember x (rangeToSet seta) === RSet.notMember x (rangeToRSet seta)
lookupLTProp :: Int -> RSetAction Int -> Property
lookupLTProp x seta = Set.lookupLT x (rangeToSet seta) === RSet.lookupLT x (rangeToRSet seta)
lookupGTProp :: Int -> SetAction Int -> Property
lookupGTProp x seta = Set.lookupGT x (toSet seta) === RSet.lookupGT x (toRSet seta)
lookupLEProp :: Int -> SetAction Int -> Property
lookupLEProp x seta = Set.lookupLE x (toSet seta) === RSet.lookupLE x (toRSet seta)
lookupGEProp :: Int -> RSetAction Int -> Property
lookupGEProp x seta = Set.lookupGE x (rangeToSet seta) === RSet.lookupGE x (rangeToRSet seta)
isSubsetProp :: SetAction Int -> RSetAction Int -> Property
isSubsetProp seta setb = Set.isSubsetOf (toSet seta) (rangeToSet setb) === RSet.isSubsetOf (toRSet seta) (rangeToRSet setb)
splitProp :: Int -> RSetAction Int -> Property
splitProp x seta = Set.elems sl === RSet.elems rl .&&. sm === rm .&&. Set.elems su === RSet.elems ru where
(sl, sm, su) = Set.splitMember x (rangeToSet seta)
(rl, rm, ru) = RSet.splitMember x (rangeToRSet seta)
rangeToRSet :: RSetAction Int -> RIntSet
rangeToRSet RAEmpty = RSet.empty
rangeToRSet (RASingleton a) = RSet.singletonRange a
rangeToRSet (RAFromList l) = RSet.fromRangeList l
rangeToRSet (RAInsert a set) = RSet.insertRange a $ rangeToRSet set
rangeToRSet (RADelete a set) = RSet.deleteRange a $ rangeToRSet set
rangeToRSet (RAUnion a b) = RSet.union (rangeToRSet a) (rangeToRSet b)
rangeToRSet (RADifference a b) = RSet.difference (rangeToRSet a) (rangeToRSet b)
rangeToRSet (RAIntersection a b) = RSet.intersection (rangeToRSet a) (rangeToRSet b)
rangeProp :: RSetAction Int -> Property
rangeProp seta = Set.elems (rangeToSet seta) === RSet.elems (rangeToRSet seta)
ordered :: Ord a => [(a,a)] -> Bool
ordered rs = all lt $ zip rs (tail rs)
where
lt :: Ord a => ((a,a),(a,a)) -> Bool
lt ((_,y),(u,_)) = y < u
pairOrdered :: Ord a => [(a, a)] -> Bool
pairOrdered = all (uncurry (<=))
orderedProp :: RSetAction Int -> Bool
orderedProp setAction = ordered rs && pairOrdered rs
where rs = RSet.toRangeList $ rangeToRSet $ setAction
ascListProp :: RSetAction Int -> Property
ascListProp setAction = RSet.fromAscList (RSet.toAscList rs) === rs
where rs = rangeToRSet setAction
-- Complement laws
complementProps :: TestTree
complementProps = testGroup "complement"
[ QC.testProperty "definition" (\a e -> RSet.member e (rs a) === RSet.notMember e (RSet.complement (rs a)))
, QC.testProperty "involutive" (\a -> rs a === RSet.complement (RSet.complement (rs a)))
, QC.testProperty "(full \\\\)" (\a -> RSet.complement (rs a) === RSet.full RSet.\\ (rs a))
]
where rs = rangeToRSet :: RSetAction Int -> RIntSet
-- Min/Max laws
findMinProp :: RSetAction Int -> Property
findMinProp seta
| Set.null s = label "trivial" $ property True
| otherwise = Set.findMin s === RSet.findMin rs
where s = rangeToSet seta
rs = rangeToRSet seta
findMaxProp :: RSetAction Int -> Property
findMaxProp seta
| Set.null s = label "trivial" $ property True
| otherwise = Set.findMax s === RSet.findMax rs
where s = rangeToSet seta
rs = rangeToRSet seta
minMaxProps :: TestTree
minMaxProps = testGroup "Min/Max properties"
[ QC.testProperty "findMin" findMinProp
, QC.testProperty "findMax" findMaxProp
]
-- Monoid laws
monoidLaws :: TestTree
monoidLaws = testGroup "Monoid laws"
[ QC.testProperty "left identity" (\a -> rs a === mempty <> rs a)
, QC.testProperty "right identity" (\a -> rs a === rs a <> mempty)
, QC.testProperty "associativity" (\a b c -> rs a <> (rs b <> rs c) === (rs a <> rs b) <> rs c)
]
where rs = rangeToRSet :: RSetAction Int -> RIntSet
validProp :: SetAction Int -> Property
validProp s = RSet.valid (toRSet s) === True
validRProp :: RSetAction Int -> Property
validRProp s = RSet.valid (rangeToRSet s) === True
invalidProp :: Property
invalidProp = RSet.valid (RSet.fromNormalizedRangeList [(-10,-1),(1,0),(2,3 :: Int)]) === False
-- All QuickCheck properties
intMapProps :: TestTree
intMapProps = testGroup "QuickCheck IntMap properties"
[ QC.testProperty "element operations are similar" elementsProp
, QC.testProperty "size is consistent" sizeProp
, QC.testProperty "null operation is similar" nullProp
, QC.testProperty "member operation is similar" memberProp
, QC.testProperty "notMember operation is similar" notMemberProp
, QC.testProperty "lookupLT operation is similar" lookupLTProp
, QC.testProperty "lookupGT operation is similar" lookupGTProp
, QC.testProperty "lookupLE operation is similar" lookupLEProp
, QC.testProperty "lookupGE operation is similar" lookupGEProp
, QC.testProperty "isSubset operation is similar" isSubsetProp
, QC.testProperty "split operation is similar" splitProp
, QC.testProperty "range operations is similar" rangeProp
, QC.testProperty "ranges remain is ordered" orderedProp
, QC.testProperty "fromAscList . toAscList === id" ascListProp
, complementProps
, minMaxProps
, monoidLaws
, QC.testProperty "item sets valid" validProp
, QC.testProperty "range sets valid" validRProp
, QC.testProperty "fromNormalizedRangeList invalid" invalidProp
]