sym-0.8: tests/Properties.hs
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Copyright : (c) Anders Claesson 2012, 2013
-- License : BSD-style
-- Maintainer : Anders Claesson <anders.claesson@gmail.com>
import Data.Ord
import Data.List
import Data.Monoid
import Data.Function
import Control.Monad
import Math.Sym (StPerm, IntPerm(..), CharPerm(..))
import qualified Math.Sym as Sym
import qualified Math.Sym.D8 as D8
import qualified Math.Sym.Stat as S
import qualified Math.Sym.Class as C
import qualified Math.Sym.Bijection as B
import qualified Math.Sym.Internal as I
import qualified Data.Vector.Storable as SV
import Test.QuickCheck
check :: Testable prop => prop -> IO ()
check = quickCheck
---------------------------------------------------------------------------------
-- Generators
---------------------------------------------------------------------------------
rank :: Int -> Gen Integer
rank n = choose (0, product [1..fromIntegral n] - 1)
lenRank :: Gen (Int, Integer)
lenRank = sized $ \m -> do
n <- choose (0, m)
r <- rank n
return (n, r)
lenRank2 :: Gen (Int, Integer, Integer)
lenRank2 = do
(n, r1) <- lenRank
r2 <- rank n
return (n, r1, r2)
lenRank3 :: Gen (Int, Integer, Integer, Integer)
lenRank3 = do
(n, r1, r2) <- lenRank2
r3 <- rank n
return (n, r1, r2, r3)
-- The sub-permutation determined by a set of indices.
subperm :: Sym.Set -> StPerm -> StPerm
subperm m w = Sym.fromVector . I.st $ SV.map ((SV.!) (Sym.toVector w)) m
subperms :: Int -> StPerm -> [StPerm]
subperms k w = [ subperm m w | m <- Sym.subsets (Sym.size w) k ]
instance Arbitrary StPerm where
arbitrary = uncurry Sym.unrankPerm `liftM` lenRank
shrink w = nub $ [0 .. Sym.size w - 1] >>= \k -> subperms k w
instance Arbitrary CharPerm where
arbitrary = Sym.cast `liftM` (arbitrary :: Gen StPerm)
instance Arbitrary IntPerm where
arbitrary = Sym.cast `liftM` (arbitrary :: Gen StPerm)
perm2 :: Gen (StPerm, IntPerm)
perm2 = do
(n,r1,r2) <- lenRank2
let u = Sym.unrankPerm n r1
let v = Sym.unrankPerm n r2
return (u, v)
perm3 :: Gen (StPerm, StPerm, IntPerm)
perm3 = do
(n,r1,r2,r3) <- lenRank3
let u = Sym.unrankPerm n r1
let v = Sym.unrankPerm n r2
let w = Sym.unrankPerm n r3
return (u, v, w)
stPermsOfEqualLength :: Gen [StPerm]
stPermsOfEqualLength = sized $ \m -> do
n <- choose (0,m)
k <- choose (0,m^2)
rs <- replicateM k $ rank n
return $ nub $ map (Sym.unrankPerm n) rs
newtype Symmetry = Symmetry (StPerm -> StPerm, String)
d8Symmetries :: [Symmetry]
d8Symmetries = [ Symmetry (D8.r0, "r0")
, Symmetry (D8.r1, "r1")
, Symmetry (D8.r2, "r2")
, Symmetry (D8.r3, "r3")
, Symmetry (D8.s0, "s0")
, Symmetry (D8.s1, "s1")
, Symmetry (D8.s2, "s2")
, Symmetry (D8.s3, "s3")
]
instance Show Symmetry where
show (Symmetry (_,s)) = s
instance Arbitrary Symmetry where
arbitrary = liftM (d8Symmetries !!) $ choose (0, length d8Symmetries - 1)
---------------------------------------------------------------------------------
-- Properties for Math.Sym
---------------------------------------------------------------------------------
prop_monoid_mempty1 w = mempty <> w == (w :: StPerm)
prop_monoid_mempty2 w = w <> mempty == (w :: StPerm)
prop_monoid_associative u v w = u <> (v <> w) == (u <> v) <> (w :: StPerm)
newtype S = S {unS :: StPerm} deriving (Eq, Show)
instance Arbitrary S where
arbitrary = liftM S arbitrary
instance Monoid S where
mempty = S $ Sym.fromVector SV.empty
mappend u v = S $ (Sym.\-\) (unS u) (unS v)
prop_monoid_mempty1_S w = mempty <> w == (w :: S)
prop_monoid_mempty2_S w = w <> mempty == (w :: S)
prop_monoid_associative_S u v w = u <> (v <> w) == (u <> v) <> (w :: S)
neutralize :: Sym.Perm a => a -> a
neutralize = Sym.idperm . Sym.size
forAllPermEq f g w = f w == g (w :: IntPerm)
prop_unrankPerm_distinct =
forAll lenRank $ \(n, r) ->
let w = Sym.toList (Sym.unrankPerm n r) in nub w == w
prop_unrankPerm_injective =
forAll lenRank2 $ \(n, r1, r2) ->
(Sym.unrankPerm n r1 :: StPerm) /= Sym.unrankPerm n r2 || r1 == r2
prop_sym = and [ sort (Sym.sym n) == sort (sym' n) | n<-[0..6] ]
where
sym' n = map Sym.fromList $ Data.List.permutations [0..fromIntegral n - 1]
prop_perm =
and [ map ints (sort (Sym.perms n)) == sort (permutations [1..n]) | n<-[0..6::Int] ]
prop_st =
forAll perm2 $ \(u,v) -> Sym.st (u `Sym.act` v) == u `Sym.act` Sym.st v
prop_act_def =
forAll perm2 $ \(u,v) -> u `Sym.act` v == IntPerm (map (ints v !!) (Sym.toList u))
prop_act_id =
forAll perm2 $ \(u,v) -> neutralize u `Sym.act` v == v
prop_act_associative =
forAll perm3 $ \(u,v,w) -> (u `Sym.act` v) `Sym.act` w == u `Sym.act` (v `Sym.act` w)
prop_size = Sym.size `forAllPermEq` (Sym.size . Sym.st)
prop_neutralize = neutralize `forAllPermEq` (\u -> Sym.inverse (Sym.st u) `Sym.act` u)
prop_inverse = forAllPermEq Sym.inverse $ \v -> Sym.inverse (Sym.st v) `Sym.act` neutralize v
prop_ordiso1 =
forAll perm2 $ \(u,v) -> u `Sym.ordiso` v == (u == Sym.st v)
prop_ordiso2 =
forAll perm2 $ \(u,v) ->
u `Sym.ordiso` v == (Sym.inverse u `Sym.act` v == neutralize v)
shadow :: Ord a => [a] -> [[a]]
shadow w = nubsort . map normalize $ ptDeletions w
where
w' = sort w
normalize u = [ w'!!i | i <- st u ]
nubsort = map head . group . sort
ptDeletions [] = []
ptDeletions xs@(x:xt) = xt : map (x:) (ptDeletions xt)
prop_shadow = forAll (resize 30 arbitrary) $ \w -> Sym.shadow [w] == map IntPerm (shadow (ints w))
prop_downset_shadow =
forAll (resize 10 arbitrary) $ \w ->
[ v | v <- Sym.downset [w], 1 + Sym.size v == Sym.size w ] == Sym.shadow [w :: CharPerm]
prop_downset_orderideal =
forAll (resize 9 arbitrary) $ \w -> null [ v | v <- Sym.downset [w :: CharPerm]
, w `Sym.avoids` v
]
coshadow :: Integral a => [a] -> [[Int]]
coshadow w = nub . sort . map (map (+1) . st) $ [0..length w] >>= \i ->
ptExtensions (fromIntegral i + 0.5) (map fromIntegral w)
where
ptExtensions n [] = [[n]]
ptExtensions n xs@(x:xt) = (n:xs) : map (x:) (ptExtensions n xt)
prop_coshadow = forAll (resize 12 arbitrary) $ \w -> Sym.coshadow [w] == map IntPerm (coshadow (ints w))
prop_coeff =
forAll (resize 5 arbitrary) $ \u ->
forAll (resize 6 arbitrary) $ \v ->
Sym.coeff (Sym.stat u) (v :: CharPerm) == fromEnum (u==v)
prop_minima_antichain =
forAll (resize 14 arbitrary) $ \ws ->
let vs = Sym.minima ws in and [ (v::StPerm) `Sym.avoidsAll` (vs \\ [v]) | v <- vs ]
prop_minima_smallest =
forAll (resize 14 arbitrary) $ \ws ->
let vs = Sym.minima ws in and [ not ((w::StPerm) `Sym.avoidsAll` vs) | w <- ws ]
prop_maxima_antichain =
forAll (resize 12 arbitrary) $ \ws ->
let vs = Sym.maxima ws in and [ (v::StPerm) `Sym.avoidsAll` (vs \\ [v]) | v <- vs ]
recordIndicesAgree f g w = SV.fromList (recordIndices w) == f w
where
w' = ints w
recordIndices w = [ head $ elemIndices x w' | x <- g w' ]
prop_lMaxima = recordIndicesAgree Sym.lMaxima lMaxima
prop_lMinima = recordIndicesAgree Sym.lMinima lMinima
prop_rMaxima = recordIndicesAgree Sym.rMaxima rMaxima
prop_rMinima = recordIndicesAgree Sym.rMinima rMinima
prop_lMaxima_card = S.lmax `forAllPermEq` (SV.length . Sym.lMaxima)
prop_lMinima_card = S.lmin `forAllPermEq` (SV.length . Sym.lMinima)
prop_rMaxima_card = S.rmax `forAllPermEq` (SV.length . Sym.rMaxima)
prop_rMinima_card = S.rmin `forAllPermEq` (SV.length . Sym.rMinima)
-- The list of indices of components in a permutation
components w = lMaxima w `cap` rMinima (bubble w)
-- The list of indices of skew components in a permutation
skewComponents w = components $ map (\x -> length w - x - 1) w
prop_components = (components . st . ints) `forAllPermEq` (SV.toList . Sym.components)
prop_skewComponents = (skewComponents . st . ints) `forAllPermEq` (SV.toList . Sym.skewComponents)
prop_dsum u v = (Sym./+/) u v == Sym.inflate ("12" :: CharPerm) [u, v :: CharPerm]
prop_ssum u v = (Sym.\-\) u v == Sym.inflate ("21" :: CharPerm) [u, v :: CharPerm]
inflate :: [Int] -> [[Int]] -> [Int]
inflate w vs = sort [ (i, map (+c) u) | (i, c, u) <- zip3 w' cs us ] >>= snd
where
(_, w',us) = unzip3 . sort $ zip3 w [0..] vs
cs = scanl (\i u -> i + length u) 0 us
prop_inflate u0 u1 u2 u3 =
let us = [u0, u1, u2, u3]
in and [ IntPerm (inflate w (map ints us)) == Sym.inflate (IntPerm w) us | w <- permutations [1..4] ]
segments :: [a] -> [[a]]
segments [] = [[]]
segments (x:xs) = segments xs ++ map (x:) (inits xs)
nonEmptySegments :: [a] -> [[a]]
nonEmptySegments = drop 1 . segments
properSegments :: [a] -> [[a]]
properSegments xs = [ ys | ys@(_:_:_) <- init $ segments xs ]
properIntervals :: Ord a => [a] -> [[a]]
properIntervals xs = [ ys | ys <- yss, sort ys `elem` zss ]
where
yss = properSegments xs
zss = properSegments $ sort xs
simple :: Ord a => [a] -> Bool
simple = null . properIntervals
prop_simple = forAll (resize 40 arbitrary) $ \w -> Sym.simple w == simple (ints w)
prop_stackSort = Sym.stackSort `forAllPermEq` (IntPerm . stack . ints)
prop_stackSort_231 =
(\v -> Sym.stackSort v == neutralize v) `forAllPermEq` (`Sym.avoids` ("231" :: CharPerm))
prop_bubbleSort = Sym.bubbleSort `forAllPermEq` (IntPerm . bubble . ints)
prop_bubbleSort_231_321 = f `forAllPermEq` g
where f v = Sym.bubbleSort v == neutralize v
g v = v `Sym.avoidsAll` ["231", "321" :: CharPerm]
prop_subperm_copies p =
forAll (resize 21 arbitrary) $ \w ->
and [ subperm m (Sym.st w) == p | m <- Sym.copiesOf p (w :: CharPerm) ]
prop_copies =
forAll (resize 6 arbitrary) $ \p ->
forAll (resize 12 arbitrary) $ \w ->
sort (Sym.copiesOf p w) == sort (map I.fromList $ copies (Sym.toList p) (ints w))
prop_copies_self v = Sym.copiesOf v (v :: CharPerm) == [SV.fromList [0 .. Sym.size v - 1]]
prop_copies_d8 (Symmetry (f,_)) =
forAll (resize 6 arbitrary) $ \p ->
forAll (resize 20 arbitrary) $ \w ->
let p' = f p
w' = (Sym.unst . f . Sym.st) (w :: CharPerm)
in Sym.stat p w == Sym.stat p' (w' :: CharPerm)
prop_avoiders_avoid =
forAll (resize 20 arbitrary) $ \ws ->
forAll (resize 6 arbitrary) $ \ps ->
all (`Sym.avoidsAll` ps) $ Sym.avoiders (ps :: [StPerm]) (ws :: [StPerm])
prop_avoiders_idempotent =
forAll (resize 18 arbitrary) $ \vs ->
forAll (resize 5 arbitrary) $ \ps ->
let ws = Sym.avoiders (ps :: [StPerm]) (vs :: [StPerm])
in ws == Sym.avoiders ps ws
prop_avoiders_d8 (Symmetry (f,_)) =
forAll (choose (0, 5)) $ \n ->
forAll (resize 5 arbitrary) $ \p ->
let ws = Sym.sym n
in sort (map f $ Sym.avoiders [p] ws) == sort (Sym.avoiders [f p] ws)
prop_avoiders_d8' (Symmetry (f,_)) =
forAll (choose (0, 5)) $ \n ->
forAll (resize 5 arbitrary) $ \ps ->
let ws = Sym.sym n
in sort (map f $ Sym.avoiders ps ws) == sort (Sym.avoiders (map f ps) (map f ws))
prop_avoiders_d8'' (Symmetry (f,_)) =
forAll (resize 18 arbitrary) $ \ws ->
forAll (resize 5 arbitrary) $ \ps ->
sort (map f $ Sym.avoiders ps ws) == sort (Sym.avoiders (map f ps) (map f ws :: [StPerm]))
prop_av_cardinality =
forAll (resize 3 arbitrary) $ \p ->
let spec = [ length $ Sym.av [p :: StPerm] n | n<-[0..6] ]
in case Sym.size p of
0 -> spec == [0,0,0,0,0,0,0]
1 -> spec == [1,0,0,0,0,0,0]
2 -> spec == [1,1,1,1,1,1,1]
3 -> spec == [1,1,2,5,14,42,132]
_ -> True
binomial n k = fromIntegral $ product [n', n'-1 .. n'-k'+1] `div` product [1..k']
where
n' = toInteger n
k' = toInteger k
kSubsequences :: Int -> [a] -> [[a]]
kSubsequences 0 _ = [[]]
kSubsequences _ [] = []
kSubsequences k (x:xs) = map (x:) (kSubsequences (k-1) xs) ++ kSubsequences k xs
copies :: [Int] -> [Int] -> [[Int]]
copies p w = [ is | js <- u, let (is, q) = unzip (f js (zip [0..] w)), st q == p ]
where
k = length p
n = length w
u = kSubsequences k [0..n-1]
f s@(j:t) ((i,x):v) = if i == j then (i,x) : f t v else f s v
f _ _ = []
prop_subsets1 =
forAll (choose (0,13)) $ \n ->
forAll (choose (0,13)) $ \k ->
sort (kSubsequences k [0..n-1]) == sort (map SV.toList $ Sym.subsets n k)
prop_subsets2 =
forAll (choose (0,33)) $ \n ->
forAll (choose (0,3)) $ \k ->
sort (kSubsequences k [0..n-1]) == sort (map SV.toList $ Sym.subsets n k)
prop_subsets_singleton =
forAll (choose (0,500)) $ \n ->
let [v] = Sym.subsets n n in SV.toList v == [0..n-1]
prop_subsets_cardinality1 =
forAll (choose (0,16)) $ \n ->
forAll (choose (0,16)) $ \k ->
length (Sym.subsets n k) == binomial n k
prop_subsets_cardinality2 =
forAll (choose (0,16)) $ \n ->
forAll (choose (0,16)) $ \k ->
let cs = map SV.length (Sym.subsets n k)
in ((k > n) && null cs) || ([k] == nub cs)
testsPerm =
[ ("monoid/mempty/1", check prop_monoid_mempty1)
, ("monoid/mempty/2", check prop_monoid_mempty2)
, ("monoid/mempty/associative", check prop_monoid_associative)
, ("monoid/mempty/1/skew", check prop_monoid_mempty1_S)
, ("monoid/mempty/2/skew", check prop_monoid_mempty2_S)
, ("monoid/mempty/associative/skew", check prop_monoid_associative_S)
, ("unrankPerm/distinct", check prop_unrankPerm_distinct)
, ("unrankPerm/injective", check prop_unrankPerm_injective)
, ("sym", check prop_sym)
, ("perm", check prop_perm)
, ("st", check prop_st)
, ("act/def", check prop_act_def)
, ("act/id", check prop_act_id)
, ("act/associative", check prop_act_associative)
, ("size", check prop_size)
, ("neutralize", check prop_neutralize)
, ("inverse", check prop_inverse)
, ("ordiso/1", check prop_ordiso1)
, ("ordiso/2", check prop_ordiso2)
, ("shadow", check prop_shadow)
, ("coshadow", check prop_coshadow)
, ("coeff", check prop_coeff)
, ("downset/shadow", check prop_downset_shadow)
, ("downset/orderideal", check prop_downset_orderideal)
, ("minima/smallest", check prop_minima_smallest)
, ("minima/antichain", check prop_minima_antichain)
, ("maxima/antichain", check prop_maxima_antichain)
, ("simple", check prop_simple)
, ("lMaxima", check prop_lMaxima)
, ("lMinima", check prop_lMinima)
, ("rMaxima", check prop_rMaxima)
, ("rMinima", check prop_rMinima)
, ("lMaxima/card", check prop_lMaxima_card)
, ("lMinima/card", check prop_lMinima_card)
, ("rMaxima/card", check prop_rMaxima_card)
, ("rMinima/card", check prop_rMinima_card)
, ("components", check prop_components)
, ("dsum", check prop_dsum)
, ("ssum", check prop_ssum)
, ("inflate", check prop_inflate)
, ("skewComponents", check prop_skewComponents)
, ("stackSort", check prop_stackSort)
, ("stackSort/231", check prop_stackSort_231)
, ("bubbleSort", check prop_bubbleSort)
, ("bubbleSort/231&321", check prop_bubbleSort_231_321)
, ("subperm/copies", check prop_subperm_copies)
, ("copies", check prop_copies)
, ("copies/self", check prop_copies_self)
, ("copies/D8", check prop_copies_d8)
, ("avoiders/avoid", check prop_avoiders_avoid)
, ("avoiders/idempotent", check prop_avoiders_idempotent)
, ("avoiders/D8/0", check prop_avoiders_d8)
, ("avoiders/D8/1", check prop_avoiders_d8')
, ("avoiders/D8/2", check prop_avoiders_d8'')
, ("av/cardinality", check prop_av_cardinality)
, ("subsets/1", check prop_subsets1)
, ("subsets/2", check prop_subsets2)
, ("subsets/singleton", check prop_subsets_singleton)
, ("subsets/cardinality/1", check prop_subsets_cardinality1)
, ("subsets/cardinality/2", check prop_subsets_cardinality2)
]
---------------------------------------------------------------------------------
-- Properties for Math.Sym.D8
---------------------------------------------------------------------------------
fn (Symmetry (f,_)) = f
prop_D8_orbit fs w = all (`elem` orbD8) $ D8.orbit (map fn fs) w
where
orbD8 = D8.orbit D8.d8 (w :: StPerm)
symmetriesAgrees f g = (f . Sym.toVector) `forAllPermEq` (Sym.toVector . g)
prop_D8_reverse = symmetriesAgrees I.reverse D8.reverse
prop_D8_complement = symmetriesAgrees I.complement D8.complement
prop_D8_inverse = symmetriesAgrees I.inverse D8.inverse
prop_D8_rotate = symmetriesAgrees I.rotate D8.rotate
-- Auxilary function that partitions a list xs with respect to the
-- equivalence induced by a function f; i.e. x ~ y iff f x == f y.
-- The time complexity is the same as for sorting, O(n log n).
eqClasses :: Ord a => (b -> a) -> [b] -> [[b]]
eqClasses f xs = (map . map) snd . group' $ sort' [ (f x, x) | x <- xs ]
where
group' = groupBy ((==) `on` fst)
sort' = sortBy $ comparing fst
symmetryClasses :: (Ord a, Sym.Perm a) => [a -> a] -> [a] -> [[a]]
symmetryClasses fs xs = sort . map sort $ eqClasses (D8.orbit fs) xs
symmetryClassesByGroup fs =
forAll (resize 10 stPermsOfEqualLength) $ \ws ->
symmetryClasses fs ws == D8.symmetryClasses fs ws
prop_symmetryClasses_d8 = symmetryClassesByGroup D8.d8
prop_symmetryClasses_klein4 = symmetryClassesByGroup D8.klein4
prop_symmetryClasses_ei = symmetryClassesByGroup [D8.id, D8.inverse]
prop_symmetryClasses_er = symmetryClassesByGroup [D8.id, D8.reverse]
prop_symmetryClasses_ec = symmetryClassesByGroup [D8.id, D8.complement]
testsD8 =
[ ("D8/orbit", check prop_D8_orbit)
, ("D8/reverse", check prop_D8_reverse)
, ("D8/complement", check prop_D8_complement)
, ("D8/inverse", check prop_D8_inverse)
, ("D8/rotate", check prop_D8_rotate)
, ("D8/symmetryClasses/ei", check prop_symmetryClasses_ei)
, ("D8/symmetryClasses/er", check prop_symmetryClasses_er)
, ("D8/symmetryClasses/ec", check prop_symmetryClasses_ec)
, ("D8/symmetryClasses/d8", check prop_symmetryClasses_d8)
, ("D8/symmetryClasses/klein4", check prop_symmetryClasses_klein4)
]
---------------------------------------------------------------------------------
-- Properties for Math.Sym.Stat
---------------------------------------------------------------------------------
-- the group theoretical inverse of w
inverse :: (Ord a) => [a] -> [Int]
inverse w = map snd . sort $ zip w [0..]
-- the standardization of w
st :: (Ord a) => [a] -> [Int]
st = inverse . inverse
ascents, descents :: (Ord a) => [a] -> [(a, a)]
ascents w = filter (uncurry (<)) $ zip w (tail w)
descents w = filter (uncurry (>)) $ zip w (tail w)
peaks w = [ v | v@(x,y,z) <- zip3 w (tail w) (tail (tail w)), x < y, y > z ]
valleys w = [ v | v@(x,y,z) <- zip3 w (tail w) (tail (tail w)), x > y, y < z ]
doubleAscents w = [ v | v@(x,y,z) <- zip3 w (tail w) (tail (tail w)), x < y, y < z ]
doubleDescents w = [ v | v@(x,y,z) <- zip3 w (tail w) (tail (tail w)), x > y, y > z ]
inversions :: (Ord a) => [a] -> [(a, a)]
inversions w = init (tails w) >>= \(x:xs) -> [ (x,y) | y<-xs, x > y ]
records :: (a -> a -> Bool) -> [a] -> [a]
records f [] = []
records f (x:xs) = records' f [x] xs where
records' f recs [] = recs
records' f recs@(r:_) (x:xs) = records' f (if f r x then x:recs else recs) xs
lMinima, lMaxima, rMinima, rMaxima :: (Ord a) => [a] -> [a]
lMinima = reverse . records (>)
lMaxima = reverse . records (<)
rMinima = records (>) . reverse
rMaxima = records (<) . reverse
excedances xs = map fst . filter (\(i,a)->i < fromIntegral a) $ zip [0..] xs
fixedpoints xs = map fst . filter (\(i,a)->i == fromIntegral a) $ zip [0..] xs
orbit :: Eq a => (a -> a) -> a -> [a]
orbit f x = y:takeWhile (/=y) ys where (y:ys) = iterate f x
orbits :: Eq a => (a -> a) -> [a] -> [[a]]
orbits f [] = []
orbits f (x:xs) = ys:orbits f (xs\\ys) where ys = orbit f x
exc, fp :: [Int] -> Int
exc = length . excedances . st
fp = length . fixedpoints . st
cyc :: [Int] -> Int
cyc w = let v = st w in length $ orbits (v!!) v
runs :: Ord a => (a -> a -> Bool) -> [a] -> [a] -> [[a]]
runs _ [] [] = []
runs _ rs [] = [rs]
runs f [] (x:xs) = runs f [x] xs
runs f u@(r:_) v@(x:xs) | f r x = runs f (x:u) xs
| otherwise = u : runs f [x] xs
decruns :: Ord a => [a] -> [[a]]
decruns = runs (>) []
incruns :: Ord a => [a] -> [[a]]
incruns = runs (<) []
ldr, rdr, lir, rir :: (Ord a) => [a] -> Int
ldr [] = 0
ldr xs = length . head $ decruns xs
rdr [] = 0
rdr xs = length . last $ decruns xs
lir [] = 0
lir xs = length . head $ incruns xs
rir [] = 0
rir xs = length . last $ incruns xs
-- The stack-sort operator
stack [] = []
stack xs = stack left ++ stack right ++ [n]
where
(left, n:right) = span ( < maximum xs) xs
-- The bubble-sort operator; i.e. one pass of the classical bubble
-- sort algorithm
bubble :: Ord a => [a] -> [a]
bubble = bub []
where
bub xs [] = reverse xs
bub [] (y:ys) = bub [y] ys
bub (x:xs) (y:ys)
| x < y = bub (y:x:xs) ys
| otherwise = bub (x:y:xs) ys
-- Like Data.List.intersect, but by assuming that the lists are sorted
-- uses a faster algorithm
cap :: Ord a => [a] -> [a] -> [a]
cap [] ys = []
cap xs [] = []
cap xs@(x:xt) ys@(y:yt) = case compare x y of
EQ -> x : cap xt yt
LT -> cap xt ys
GT -> cap xs yt
-- The number of components in a permutation
comp = length . components
-- The number of skew components in a permutation
scomp = length . skewComponents
-- rank a la Elizalde
ep = fst . last . filter (\(k,ys) -> all (k<=) ys) . zip [0..] . inits . st
des, asc, inv, lmin, lmax, rmin, rmax, peak, vall :: [Int] -> Int
dasc, ddes, maj, comp, ep, dim :: [Int] -> Int
dim w = maximum $ 0 : [ i | (i,x) <- zip [0..] (st w), i /= x ]
maj w = sum [ i | (i,x,y) <- zip3 [1..] w (tail w), x > y ]
comaj w = sum [ n-i | (i,x,y) <- zip3 [1..] w (tail w), x > y ] where n = length w
asc0 w = sum [ 1 | (x,y) <- ascents $ st w, y-x == 1 ]
des0 w = sum [ 1 | (x,y) <- descents $ st w, x-y == 1 ]
asc = length . ascents
des = length . descents
inv = length . inversions
lmin = length . lMinima
lmax = length . lMaxima
rmin = length . rMinima
rmax = length . rMaxima
peak = length . peaks
vall = length . valleys
dasc = length . doubleAscents
ddes = length . doubleDescents
shad = length . shadow
prop_asc = forAllPermEq (asc . ints) S.asc
prop_des = forAllPermEq (des . ints) S.des
prop_exc = forAllPermEq (exc . ints) S.exc
prop_fp = forAllPermEq (fp . ints) S.fp
prop_cyc = forAllPermEq (cyc . ints) S.cyc
prop_inv = forAllPermEq (inv . ints) S.inv
prop_maj = forAllPermEq (maj . ints) S.maj
prop_comaj = forAllPermEq (comaj . ints) S.comaj
prop_lmin = forAllPermEq (lmin . ints) S.lmin
prop_lmax = forAllPermEq (lmax . ints) S.lmax
prop_rmin = forAllPermEq (rmin . ints) S.rmin
prop_rmax = forAllPermEq (rmax . ints) S.rmax
prop_head w = (w /= Sym.empty) ==> head (ints w) == 1 + S.head w
prop_last w = (w /= Sym.empty) ==> last (ints w) == 1 + S.last w
prop_peak = forAllPermEq (peak . ints) S.peak
prop_vall = forAllPermEq (vall . ints) S.vall
prop_dasc = forAllPermEq (dasc . ints) S.dasc
prop_ddes = forAllPermEq (ddes . ints) S.ddes
prop_ep = forAllPermEq (ep . ints) S.ep
prop_lir = forAllPermEq (lir . ints) S.lir
prop_ldr = forAllPermEq (ldr . ints) S.ldr
prop_rir = forAllPermEq (rir . ints) S.rir
prop_rdr = forAllPermEq (rdr . ints) S.rdr
prop_comp = forAllPermEq (comp . ints) S.comp
prop_scomp = forAllPermEq (scomp . ints) S.scomp
prop_dim = forAllPermEq (dim . ints) S.dim
prop_asc0 = forAllPermEq (asc0 . ints) S.asc0
prop_des0 = forAllPermEq (des0 . ints) S.des0
prop_shad = forAllPermEq (shad . ints) S.shad
prop_inv_21 = forAll (resize 30 arbitrary) $ \w -> S.inv (w :: IntPerm) == Sym.stat ("21" :: CharPerm) w
testsStat =
[ ("asc", check prop_asc)
, ("des", check prop_des)
, ("exc", check prop_exc)
, ("fp", check prop_fp)
, ("cyc", check prop_cyc)
, ("inv", check prop_inv)
, ("maj", check prop_maj)
, ("comaj", check prop_comaj)
, ("lmin", check prop_lmin)
, ("lmax", check prop_lmax)
, ("rmin", check prop_rmin)
, ("rmax", check prop_rmax)
, ("head", check prop_head)
, ("last", check prop_last)
, ("peak", check prop_peak)
, ("vall", check prop_vall)
, ("dasc", check prop_dasc)
, ("ddes", check prop_ddes)
, ("ep", check prop_ep)
, ("lir", check prop_lir)
, ("ldr", check prop_ldr)
, ("rir", check prop_rir)
, ("rdr", check prop_rdr)
, ("comp", check prop_comp)
, ("scomp", check prop_scomp)
, ("dim", check prop_dim)
, ("asc0", check prop_asc0)
, ("des0", check prop_des0)
, ("shad", check prop_shad)
, ("inv/21", check prop_inv_21)
]
---------------------------------------------------------------------------------
-- Properties for Math.Sym.Class
---------------------------------------------------------------------------------
agreesWithBasis bs cls m =
and [ sort (Sym.av (map Sym.st bs) n) == sort (cls n) | n<-[0..m] ]
prop_av231 = agreesWithBasis ["231" :: CharPerm] C.av231 7
prop_vee = agreesWithBasis ["132", "231" :: CharPerm] C.vee 7
prop_caret = agreesWithBasis ["213", "312" :: CharPerm] C.caret 7
prop_gt = agreesWithBasis ["132", "312" :: CharPerm] C.gt 7
prop_lt = agreesWithBasis ["213", "231" :: CharPerm] C.lt 7
prop_separables = agreesWithBasis ["2413", "3142" :: CharPerm] C.separables 7
testsClass =
[ ("av231", check prop_av231)
, ("vee", check prop_vee)
, ("caret", check prop_caret)
, ("gt", check prop_gt)
, ("lt", check prop_lt)
, ("separables", check prop_separables)
]
---------------------------------------------------------------------------------
-- Properties for Math.Sym.Bijection
---------------------------------------------------------------------------------
prop_simionSchmidt_avoid =
forAll (resize 15 arbitrary) $ \w ->
(w :: CharPerm) `Sym.avoids` ("123" :: CharPerm) ==> B.simionSchmidt w `Sym.avoids` ("132" :: CharPerm)
prop_simionSchmidt_avoid' =
forAll (resize 15 arbitrary) $ \w ->
(w :: CharPerm) `Sym.avoids` ("132" :: CharPerm) ==> B.simionSchmidt' w `Sym.avoids` ("123" :: CharPerm)
prop_simionSchmidt_id =
forAll (resize 15 arbitrary) $ \w ->
(w :: CharPerm) `Sym.avoids` ("123" :: CharPerm) ==> B.simionSchmidt' (B.simionSchmidt w) == w
prop_simionSchmidt_id' =
forAll (resize 15 arbitrary) $ \w ->
(w :: CharPerm) `Sym.avoids` ("132" :: CharPerm) ==> B.simionSchmidt (B.simionSchmidt' w) == w
testsBijection =
[ ("simionSchmidt/avoid", check prop_simionSchmidt_avoid)
, ("simionSchmidt'/avoid", check prop_simionSchmidt_avoid')
, ("simionSchmidt/id", check prop_simionSchmidt_id)
, ("simionSchmidt'/id", check prop_simionSchmidt_id')
]
---------------------------------------------------------------------------------
-- Main
---------------------------------------------------------------------------------
tests = testsPerm ++ testsD8 ++ testsStat ++ testsClass ++ testsBijection
runTests = mapM_ (\(name, t) -> putStr (name ++ ":\t") >> t)
main = runTests tests