{-# OPTIONS_GHC -fglasgow-exts #-}
module Permute (
tests_Permute
) where
import Control.Monad.ST
import Data.Array.ST
import Data.List( foldl' )
import qualified Data.List as List
import Data.Maybe( fromJust )
import qualified Data.Set as Set
import Data.Permute
import Driver
import Test.QuickCheck
import Test.Permute()
import qualified Test.Permute as Test
prop_size_permute (Nat n) =
size (permute n) == n
prop_elems_permute (Nat n) =
elems (permute n) == [0..(n-1)]
prop_size_listPermute (ListPermute n is) =
size (listPermute n is) == n
prop_elems_listPermute (ListPermute n is) =
elems (listPermute n is) == is
prop_size_swapsPermute (SwapsPermute n ss) =
size (swapsPermute n ss) == n
prop_elems_swapsPermute (SwapsPermute n ss) =
elems (swapsPermute n ss) == map at [0..(n-1)]
where
at i = foldl' doSwap i $ reverse ss
doSwap k (i,j) | k == i = j
| k == j = i
| otherwise = k
prop_size_cyclesPermute (CyclesPermute n cs) =
size (cyclesPermute n cs) == n
prop_elems_cyclesPermute (CyclesPermute n cs) =
elems (cyclesPermute n cs) == map at [0..(n-1)]
where
at i = foldl' doCycle i cs
doCycle k cyc = case List.findIndex (k==) cyc of
Nothing -> k
Just ind -> cycle cyc !! (ind + 1)
prop_at = prop_at_help at
prop_unsafeAt = prop_at_help unsafeAt
prop_at_help a =
forAll arbitrary $ \(Index n i) ->
forAll (Test.permute n) $ \p ->
a p i == (elems p) !! i
prop_size_inverse (p :: Permute) =
size (inverse p) == size p
prop_elems_inverse (p :: Permute) =
all (\i -> is' !! (at p i) == i) [0..(n-1)]
where
n = size p
is' = elems (inverse p)
prop_swaps (Nat n) =
forAll (Test.permute n) $ \p ->
forAll (vector n) $ \xs ->
let xs' = applySwaps (swaps p) xs
in all (\i -> xs' !! i == xs !! (at p i)) [0..(n-1)]
prop_invSwaps (Nat n) =
forAll (Test.permute n) $ \p ->
forAll (vector n) $ \xs ->
let xs' = applySwaps (invSwaps p) xs
in all (\i -> xs' !! (at p i) == xs !! i) [0..(n-1)]
prop_swaps_inverse (Nat n) =
forAll (Test.permute n) $ \p ->
forAll (vector n) $ \xs ->
applySwaps (swaps $ inverse p) xs == (applySwaps (invSwaps p) xs)
prop_invSwaps_inverse (Nat n) =
forAll (Test.permute n) $ \p ->
forAll (vector n) $ \xs ->
applySwaps (invSwaps $ inverse p) xs == (applySwaps (swaps p) xs)
prop_prev_permute (Nat n) =
prev (permute n) == Nothing
prop_next_last (Nat n) =
next (listPermute n $ reverse [0..(n-1)]) == Nothing
prop_next_prev (p :: Permute) =
case prev p of
Just p' -> p == (fromJust $ next p')
Nothing -> p == permute n
where
n = size p
prop_prev_next (p :: Permute) =
case next p of
Just p' -> p == (fromJust $ prev p')
Nothing -> p == (listPermute n $ reverse [0..(n-1)])
where
n = size p
prop_fst_sort (Sort n xs) = let
ys = take n xs
in (fst . sort n) xs == (List.sort ys)
prop_snd_sort (Sort n xs) = let
ys = take n xs
in applySwaps (swaps $ snd $ sort n xs) ys == (List.sort ys)
prop_fst_sortBy (SortBy cmp n xs) = let
ys = take n xs
in (fst . sortBy cmp n) xs == (List.sortBy cmp ys)
prop_snd_sortBy (SortBy cmp n xs) = let
ys = take n xs
in applySwaps (swaps $ snd $ sortBy cmp n xs) ys == (List.sortBy cmp ys)
prop_order (Sort n xs) = let
ys = take n xs
in applySwaps (swaps $ order n xs) ys == (List.sort ys)
prop_orderBy (SortBy cmp n xs) = let
ys = take n xs
in applySwaps (swaps $ orderBy cmp n xs) ys == (List.sortBy cmp ys)
prop_rank (Sort n xs) = let
ys = take n xs
in applySwaps (invSwaps $ rank n xs) ys == (List.sort ys)
prop_rankBy (SortBy cmp n xs) = let
ys = take n xs
in applySwaps (invSwaps $ rankBy cmp n xs) ys == (List.sortBy cmp ys)
prop_swapsPermute_swaps (p :: Permute) =
swapsPermute (size p) (swaps p) == p
prop_isEven_permute (Nat n) =
isEven (permute n)
prop_isEven_swaps (p :: Permute) =
isEven p == even (length (swaps p))
prop_cyclesPermute_cycles (p :: Permute) =
cyclesPermute (size p) (cycles p) == p
prop_cycles_cycleFrom (p :: Permute) =
let n = size p
cycles1 = Set.fromList (map Set.fromList (cycles p))
cycles2 = Set.fromList [Set.fromList (cycleFrom p i) | i <- [0..(n-1)]]
in cycles1 == cycles2
prop_cycles_wholerange (p :: Permute) =
let n = size p
in List.sort (concat (cycles p)) == [0..(n-1)]
prop_period_permute (Nat n) =
period (permute n) == 1
prop_period_onecycle (Nat n) =
n >= 1 ==> period (listPermute n $ [1..(n-1)] ++ [0]) == toInteger n
tests_Permute =
[ ("size . permute" , mytest prop_size_permute)
, ("elems . permute" , mytest prop_elems_permute)
, ("size . listPermute" , mytest prop_size_listPermute)
, ("elems . listPermute" , mytest prop_elems_listPermute)
, ("size . swapsPermute" , mytest prop_size_swapsPermute)
, ("elems . swapsPermute" , mytest prop_elems_swapsPermute)
, ("size . cyclesPermute" , mytest prop_size_cyclesPermute)
, ("elems . cyclesPermute" , mytest prop_elems_cyclesPermute)
, ("at" , mytest prop_at)
, ("unsafeAt" , mytest prop_unsafeAt)
, ("size . inverse" , mytest prop_size_inverse)
, ("elems . inverse" , mytest prop_elems_inverse)
, ("swaps" , mytest prop_swaps)
, ("invSwaps" , mytest prop_invSwaps)
, ("swaps . inverse" , mytest prop_swaps_inverse)
, ("invSwaps . inverse" , mytest prop_invSwaps_inverse)
, ("prev . permute" , mytest prop_prev_permute)
, ("next (last permutation)" , mytest prop_next_last)
, ("next . prev" , mytest prop_next_prev)
, ("prev . next" , mytest prop_prev_next)
, ("fst . sort" , mytest prop_fst_sort)
, ("snd . sort" , mytest prop_snd_sort)
, ("fst . sortBy" , mytest prop_fst_sortBy)
, ("snd . sortBy" , mytest prop_snd_sortBy)
, ("order" , mytest prop_order)
, ("orderBy" , mytest prop_orderBy)
, ("rank" , mytest prop_rank)
, ("rankBy" , mytest prop_rankBy)
, ("swapsPermute . swaps" , mytest prop_swapsPermute_swaps)
, ("isEven . permute" , mytest prop_isEven_permute)
, ("isEven == even . swaps" , mytest prop_isEven_swaps)
, ("cyclesPermute . cycles" , mytest prop_cyclesPermute_cycles)
, ("cycles == all cycleFrom" , mytest prop_cycles_cycleFrom)
, ("concat . cycles == [0..n]" , mytest prop_cycles_wholerange)
, ("period . permute" , mytest prop_period_permute)
, ("period [1..n,0] == n" , mytest prop_period_onecycle)
]
applySwaps :: [(Int,Int)] -> [Int] -> [Int]
applySwaps ss xs = runST $ do
arr <- newListArray (0,length xs - 1) xs :: ST s (STUArray s Int Int)
mapM_ (swap arr) ss
getElems arr
where
swap arr (i,j) = do
i' <- readArray arr i
j' <- readArray arr j
writeArray arr j i'
writeArray arr i j'