{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Mutable.Test
( testSuite
) where
import Data.List (sort)
import Data.Vector (Vector, freeze, thaw, (!))
import qualified Data.Vector as V
import Mutable.Shuffle
import System.Random
import Test.QuickCheck.Instances.Vector ()
import Test.QuickCheck.Monadic
import Test.Tasty
import Test.Tasty.QuickCheck as QC hiding (shuffle)
testSuite :: TestTree
testSuite = testGroup ""
[ localOption (QuickCheckTests 10000) shuffleTestSuite
, localOption (QuickCheckTests 10000) maximalCycleTestSuite
, localOption (QuickCheckTests 10000) derangementTestSuite
]
shuffleTestSuite :: TestTree
shuffleTestSuite = testGroup "shuffleM"
[ QC.testProperty
"shuffleM: Shuffling preserves length and elements"
(monadicIO . isPermutationM @Int)
, QC.testProperty
"shuffle: Shuffling preserves length and elements"
(monadicIO . isPermutation @Int)
]
maximalCycleTestSuite :: TestTree
maximalCycleTestSuite = testGroup "maximalCycleM"
[ QC.testProperty
"maximalCycleM: maximal cycle does indeed produce a maximal cycle on [0..n]"
(monadicIO . isMaximalCycleM)
, QC.testProperty
"maximalCycle: maximal cycle does indeed produce a maximal cycle on [0..n]"
(monadicIO . isMaximalCycle)
]
derangementTestSuite :: TestTree
derangementTestSuite = testGroup "derangementM"
[ QC.testProperty
"derangementM: derangement does indeed produce a derangment on [0..n]."
(monadicIO . isDerangementM)
, QC.testProperty
"derangement: derangement does indeed produce a derangment on [0..n]."
(monadicIO . isDerangement)
]
isPermutationM :: forall a . (Ord a , Show a, Arbitrary a) => Vector a -> PropertyM IO Property
isPermutationM v =
do
mv <- run $ thaw v
run $ shuffleM mv
v' <- run $ freeze mv
let ls = V.toList v
let ls' = V.toList v'
pure $ sort ls === sort ls'
isPermutation
:: forall a . (Ord a , Show a, Arbitrary a)
=> Vector a -> PropertyM IO Property
isPermutation v =
do
mv <- run $ thaw v
g <- run $ getStdGen
_ <- run $ shuffle mv g
v' <- run $ freeze mv
let ls = V.toList v
let ls' = V.toList v'
pure $ sort ls === sort ls'
isMaximalCycleM :: Positive Int -> PropertyM IO Property
isMaximalCycleM (Positive n) =
do
let v = V.fromList [0..n]
mv <- run $ thaw v
run $ maximalCycleM mv
v' <- run $ freeze mv
pure $ cycleLength v' === (n + 1)
where
cycleLength :: Vector Int -> Int
cycleLength v = go (V.head v) v
go :: Int -> Vector Int -> Int
go k xs = if k == 0
then 1
else
1 + go (xs ! k) xs
isMaximalCycle :: Positive Int -> PropertyM IO Property
isMaximalCycle (Positive n) =
do
let v = V.fromList [0..n]
g <- run getStdGen
mv <- run $ thaw v
_ <- run $ maximalCycle mv g
v' <- run $ freeze mv
pure $ cycleLength v' === (n + 1)
where
cycleLength :: Vector Int -> Int
cycleLength v = go (V.head v) v
go :: Int -> Vector Int -> Int
go k xs = if k == 0
then 1
else
1 + go (xs ! k) xs
isDerangementM :: Positive Int -> PropertyM IO Property
isDerangementM (Positive n) =
do
let v = V.fromList [0..n]
mv <- run $ thaw v
run $ derangementM mv
v' <- run $ freeze mv
let perm = V.indexed v'
let unmoved = V.filter (uncurry (==)) perm
pure $ null unmoved === True
isDerangement :: Positive Int -> PropertyM IO Property
isDerangement (Positive n) =
do
let v = V.fromList [0..n]
g <- run getStdGen
mv <- run $ thaw v
_ <- run $ derangement mv g
v' <- run $ freeze mv
let perm = V.indexed v'
let unmoved = V.filter (uncurry (==)) perm
pure $ null unmoved === True