diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008-2015, Balazs Komuves +Copyright (c) 2008-2016, Balazs Komuves All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Math/Combinat/Numbers.hs b/Math/Combinat/Numbers.hs --- a/Math/Combinat/Numbers.hs +++ b/Math/Combinat/Numbers.hs @@ -11,12 +11,7 @@ import Data.Array import Math.Combinat.Helper ( sum' ) - --------------------------------------------------------------------------------- - --- | @(-1)^k@ -paritySignValue :: Integral a => a -> Integer -paritySignValue k = if odd k then (-1) else 1 +import Math.Combinat.Sign -------------------------------------------------------------------------------- @@ -35,7 +30,7 @@ | odd n = product [1,3..fromIntegral n] | otherwise = product [2,4..fromIntegral n] --- | A007318. +-- | A007318. Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below. binomial :: Integral a => a -> a -> Integer binomial n k | k > n = 0 @@ -46,6 +41,26 @@ k' = fromIntegral k n' = fromIntegral n +-- | The extension of the binomial function to negative inputs. This should satisfy the following properties: +-- +-- > for n,k >=0 : signedBinomial n k == binomial n k +-- > for any n,k : signedBinomial n k == signedBinomial n (n-k) +-- > for k >= 0 : signedBinomial (-n) k == (-1)^k * signedBinomial (n+k-1) k +-- +-- Note: This is compatible with Mathematica's @Binomial@ function. +-- +signedBinomial :: Int -> Int -> Integer +signedBinomial n k + | n >= 0 = binomial n k + | k >= 0 = negateIfOdd k $ binomial (k-n-1) k + | otherwise = negateIfOdd (n+k) $ binomial (-k-1) (-n-1) + +{- +test_signed_0 = [ signedBinomial ( n) k == signedBinomial ( n) ( n-k) | n<-[-30..40] , k<-[-30..40] ] +test_signed_1 = [ signedBinomial (-n) k == signedBinomial (-n) (-n-k) | n<-[-30..40] , k<-[-30..40] ] +test_signed_2 = [ signedBinomial (-n) k == negateIfOdd k $ signedBinomial (n+k-1) k | n<-[-30..40] , k<-[0..30] ] +-} + -- | A given row of the Pascal triangle; equivalent to a sequence of binomial -- numbers, but much more efficient. You can also left-fold over it. -- @@ -129,7 +144,7 @@ | k < 1 = 0 | k > n = 0 | otherwise = sum xs `div` factorial k where - xs = [ paritySignValue (k-i) * binomial k i * (fromIntegral i)^n | i<-[0..k] ] + xs = [ negateIfOdd (k-i) $ binomial k i * (fromIntegral i)^n | i<-[0..k] ] -------------------------------------------------------------------------------- -- * Bernoulli numbers @@ -144,7 +159,7 @@ | n == 1 = -1/2 | otherwise = sum [ f k | k<-[1..n] ] where - f k = toRational (paritySignValue (n+k) * factorial k * stirling2nd n k) + f k = toRational (negateIfOdd (n+k) $ factorial k * stirling2nd n k) / toRational (k+1) -------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Set.hs b/Math/Combinat/Partitions/Set.hs --- a/Math/Combinat/Partitions/Set.hs +++ b/Math/Combinat/Partitions/Set.hs @@ -18,6 +18,7 @@ import Math.Combinat.Numbers import Math.Combinat.Helper import Math.Combinat.Classes +import Math.Combinat.Partitions.Integer -------------------------------------------------------------------------------- -- * The type of set partitions @@ -48,6 +49,15 @@ instance HasNumberOfParts SetPartition where numberOfParts (SetPartition p) = length p + +-------------------------------------------------------------------------------- +-- * Forgetting the set structure + +-- | The \"shape\" of a set partition is the partition we get when we forget the +-- set structure, keeping only the cardinalities. +-- +setPartitionShape :: SetPartition -> Partition +setPartitionShape (SetPartition pps) = mkPartition (map length pps) -------------------------------------------------------------------------------- -- * Generating set partitions diff --git a/Math/Combinat/Sets.hs b/Math/Combinat/Sets.hs --- a/Math/Combinat/Sets.hs +++ b/Math/Combinat/Sets.hs @@ -4,18 +4,19 @@ {-# LANGUAGE BangPatterns, Rank2Types #-} module Math.Combinat.Sets ( - -- * choices - choose , choose_ + -- * Choices + choose_ , choose , choose' , choose'' , chooseTagged + -- * Compositions , combine , compose - -- * tensor products + -- * Tensor products , tuplesFromList , listTensor - -- * sublists + -- * Sublists , kSublists , sublists , countKSublists , countSublists - -- * random choice + -- * Random choice , randomChoice ) where @@ -39,12 +40,6 @@ -------------------------------------------------------------------------------- -- * choices --- | All possible ways to choose @k@ elements from a list, without --- repetitions. \"Antisymmetric power\" for lists. Synonym for 'kSublists'. -choose :: Int -> [a] -> [[a]] -choose 0 _ = [[]] -choose k [] = [] -choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs -- | @choose_ k n@ returns all possible ways of choosing @k@ disjoint elements from @[1..n]@ -- @@ -57,6 +52,47 @@ then [] else choose k [1..n] +-- | All possible ways to choose @k@ elements from a list, without +-- repetitions. \"Antisymmetric power\" for lists. Synonym for 'kSublists'. +choose :: Int -> [a] -> [[a]] +choose 0 _ = [[]] +choose k [] = [] +choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs + +-- | A version of 'choose' which also returns the complementer sets. +-- +-- > choose k = map fst . choose' k +-- +choose' :: Int -> [a] -> [([a],[a])] +choose' 0 xs = [([],xs)] +choose' k [] = [] +choose' k (x:xs) = map f (choose' (k-1) xs) ++ map g (choose' k xs) where + f (as,bs) = (x:as , bs) + g (as,bs) = ( as , x:bs) + +-- | Another variation of 'choose''. This satisfies +-- +-- > choose'' k == map (\(xs,ys) -> (map fst xs, map snd ys)) . choose' k +-- +choose'' :: Int -> [(a,b)] -> [([a],[b])] +choose'' 0 xys = [([] , map snd xys)] +choose'' k [] = [] +choose'' k ((x,y):xs) = map f (choose'' (k-1) xs) ++ map g (choose'' k xs) where + f (as,bs) = (x:as , bs) + g (as,bs) = ( as , y:bs) + +-- | Another variation on 'choose' which tags the elements based on whether they are part of +-- the selected subset ('Right') or not ('Left'): +-- +-- > choose k = map rights . chooseTagged k +-- +chooseTagged :: Int -> [a] -> [[Either a a]] +chooseTagged 0 xs = [map Left xs] +chooseTagged k [] = [] +chooseTagged k (x:xs) = map f (chooseTagged (k-1) xs) ++ map g (chooseTagged k xs) where + f eis = Right x : eis + g eis = Left x : eis + -- | All possible ways to choose @k@ elements from a list, /with repetitions/. -- \"Symmetric power\" for lists. See also "Math.Combinat.Compositions". -- TODO: better name? @@ -94,7 +130,7 @@ -------------------------------------------------------------------------------- -- * sublists --- | Sublists of a list having given number of elements. +-- | Sublists of a list having given number of elements. Synonym for 'choose'. kSublists :: Int -> [a] -> [[a]] kSublists = choose diff --git a/Math/Combinat/Sign.hs b/Math/Combinat/Sign.hs --- a/Math/Combinat/Sign.hs +++ b/Math/Combinat/Sign.hs @@ -29,15 +29,44 @@ isPlus s = case s of { Plus -> True ; _ -> False } isMinus s = case s of { Minus -> True ; _ -> False } +{-# SPECIALIZE signValue :: Sign -> Int #-} +{-# SPECIALIZE signValue :: Sign -> Integer #-} + -- | @+1@ or @-1@ signValue :: Num a => Sign -> a signValue s = case s of Plus -> 1 Minus -> -1 +{-# SPECIALIZE signed :: Sign -> Int -> Int #-} +{-# SPECIALIZE signed :: Sign -> Integer -> Integer #-} + +-- | Negate the second argument if the first is 'Minus' +signed :: Num a => Sign -> a -> a +signed s y = case s of + Plus -> y + Minus -> negate y + +{-# SPECIALIZE paritySign :: Int -> Sign #-} +{-# SPECIALIZE paritySign :: Integer -> Sign #-} + -- | 'Plus' if even, 'Minus' if odd paritySign :: Integral a => a -> Sign paritySign x = if even x then Plus else Minus + +{-# SPECIALIZE paritySignValue :: Int -> Integer #-} +{-# SPECIALIZE paritySignValue :: Integer -> Integer #-} + +-- | @(-1)^k@ +paritySignValue :: Integral a => a -> Integer +paritySignValue k = if odd k then (-1) else 1 + +{-# SPECIALIZE negateIfOdd :: Int -> Int -> Int #-} +{-# SPECIALIZE negateIfOdd :: Int -> Integer -> Integer #-} + +-- | Negate the second argument if the first is odd +negateIfOdd :: (Integral a, Num b) => a -> b -> b +negateIfOdd k y = if even k then y else negate y oppositeSign :: Sign -> Sign oppositeSign s = case s of diff --git a/combinat.cabal b/combinat.cabal --- a/combinat.cabal +++ b/combinat.cabal @@ -1,5 +1,5 @@ Name: combinat -Version: 0.2.8.1 +Version: 0.2.8.2 Synopsis: Generate and manipulate various combinatorial objects. Description: A collection of functions to generate, count, manipulate and visualize all kinds of combinatorial objects like @@ -8,12 +8,12 @@ License: BSD3 License-file: LICENSE Author: Balazs Komuves -Copyright: (c) 2008-2015 Balazs Komuves +Copyright: (c) 2008-2016 Balazs Komuves Maintainer: bkomuves (plus) hackage (at) gmail (dot) com Homepage: http://code.haskell.org/~bkomuves/ Stability: Experimental Category: Math -Tested-With: GHC == 7.10.2 +Tested-With: GHC == 7.10.3 Cabal-Version: >= 1.18 Build-Type: Simple @@ -80,6 +80,16 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: TestSuite.hs + + other-modules: Tests.Braid + Tests.Common + Tests.LatticePaths + Tests.Permutations + Tests.Series + Tests.SkewTableaux + Tests.Thompson + Tests.Partitions.Integer + Tests.Partitions.Skew build-depends: base >= 4 && < 5, array >= 0.5, containers, random, transformers, combinat, diff --git a/test/Tests/Braid.hs b/test/Tests/Braid.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Braid.hs @@ -0,0 +1,278 @@ + +-- | Tests for braids. + +{-# LANGUAGE + CPP, BangPatterns, + ScopedTypeVariables, ExistentialQuantification, + DataKinds, KindSignatures, Rank2Types, + TypeOperators, TypeFamilies, + StandaloneDeriving #-} + +module Tests.Braid where + +-------------------------------------------------------------------------------- + +import Math.Combinat.Groups.Braid +import Math.Combinat.Groups.Braid.NF + +import Tests.Permutations () -- arbitrary instance +import Tests.Common + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Gen + +import Data.Proxy +import GHC.TypeLits + +import Control.Monad + +import Data.List ( mapAccumL , foldl' ) + +import Data.Array.Unboxed +import Data.Array.ST +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Unsafe +import Data.Array.Base + +import Control.Monad.ST + +import System.Random + +import Math.Combinat.Sign +import Math.Combinat.Helper +import Math.Combinat.TypeLevel +import Math.Combinat.Numbers.Series + +import Math.Combinat.Permutations ( Permutation(..) ) +import qualified Math.Combinat.Permutations as P + +-------------------------------------------------------------------------------- +-- * Types and instances + +maxBraidWordLen :: Int +maxBraidWordLen = 600 + +maxStrands :: Int +maxStrands = 18 -- normal forms are very slow for large ones + +shrinkBraid :: KnownNat n => Braid n -> [Braid n] +shrinkBraid (Braid gens) = map Braid list where + len = length gens + list = [ take i gens ++ drop (i+1) gens | i<-[0..len-1] ] + +-- someRndBraid :: Int -> (forall (n :: Nat). KnownNat n => g -> (Braid n, g)) -> g -> (SomeBraid, g) +-- someRndBraid n f = \g -> let (x,g') = f g in (someBraid n x, g') + +-- | equality as /braid words/ +(=:=) :: Braid n -> Braid n -> Bool +(=:=) (Braid gens1) (Braid gens2) = (gens1 == gens2) + +data UnreducedBraid = forall n. KnownNat n => Unreduced (Braid n) +data ReducedBraid = forall n. KnownNat n => Reduced (Braid n) +data PositiveBraid = forall n. KnownNat n => PositiveB (Braid n) +data PerturbedBraid = forall n. KnownNat n => Perturbed (Braid n) (Braid n) +data PermutationBraid = forall n. KnownNat n => PermBraid Permutation (Braid n) +data TwoBraids = forall n. KnownNat n => TwoBraids (Braid n) (Braid n) + +deriving instance Show UnreducedBraid +deriving instance Show ReducedBraid +deriving instance Show PositiveBraid +deriving instance Show PerturbedBraid +deriving instance Show PermutationBraid +deriving instance Show TwoBraids + +instance KnownNat n => Random (Braid n) where + randomR _ = random + random g0 = (b, g2) where + n = numberOfStrands b + (l,g1) = randomR (0,maxBraidWordLen) g0 + (b,g2) = randomBraidWord l g1 + +instance Random UnreducedBraid where + randomR _ = random + random = runRand $ do + n <- randChoose (2,maxStrands) + l <- randChoose (0,maxBraidWordLen) + withSelectedM Unreduced (rand $ randomBraidWord l) n + +instance Random PositiveBraid where + randomR _ = random + random = runRand $ do + n <- randChoose (2,maxStrands) + l <- randChoose (0,maxBraidWordLen) + withSelectedM PositiveB (rand $ randomPositiveBraidWord l) n + +instance Random PerturbedBraid where + randomR _ = random + random = runRand $ do + Unreduced b <- rand random + k <- randChoose (20,1000) + c <- rand $ randomPerturbBraidWord k b + return (Perturbed b c) + +instance KnownNat n => Arbitrary (Braid n) where + arbitrary = choose_ + shrink = shrinkBraid + +instance Arbitrary UnreducedBraid where + arbitrary = choose_ + shrink (Unreduced b) = map Unreduced (shrinkBraid b) + +instance Arbitrary PositiveBraid where + arbitrary = choose_ + shrink (PositiveB b) = map PositiveB (shrinkBraid b) + +instance Arbitrary ReducedBraid where + arbitrary = do + Unreduced braid <- arbitrary + return $ Reduced $ freeReduceBraidWord braid + +instance Arbitrary PerturbedBraid where + arbitrary = choose_ + shrink _ = [] + +instance Arbitrary TwoBraids where + shrink _ = [] + arbitrary = do + n <- choose (2::Int, maxStrands) + let snat = case someNatVal (fromIntegral n :: Integer) of + Just sn -> sn + Nothing -> error "TwoBraids/arbitrary: shouldn't happen" + case snat of + SomeNat pxy -> do + (braid1,braid2) <- choosePair_ + return $ TwoBraids (asProxyTypeOf1 braid1 pxy) (asProxyTypeOf1 braid2 pxy) + +mkPermBraid :: Permutation -> PermutationBraid +mkPermBraid perm = + case snat of + SomeNat pxy -> PermBraid perm (asProxyTypeOf1 (permutationBraid perm) pxy) + where + n = P.permutationSize perm + Just snat = someNatVal (fromIntegral n :: Integer) + +instance Arbitrary PermutationBraid where + arbitrary = do + perm <- arbitrary + return $ mkPermBraid perm + shrink (PermBraid x b) = [ PermBraid (braidPermutation s) s | s <- shrinkBraid b ] + +-------------------------------------------------------------------------------- +-- * test groups + +testgroup_Braid :: Test +testgroup_Braid = testGroup "Braid" + + [ testProperty "linking matrix is invariant of reduction" prop_link_reduce + , testProperty "linking matrix is invariant of perturbation" prop_link_perturb + + , testProperty "tau^2 = identity" prop_tau_square + , testProperty "tau commutes with braidPermutation" prop_permTau_1 + + , testProperty "braidPermutation . permutationBraid = identity" prop_permBraid_perm + , testProperty "permutation braid is indeed a permutation braid" prop_permBraid_valid + , testProperty "multiplication commutes with braidPermutation" prop_braidPerm_comp + + , testProperty "positive braids have positive links" prop_link_positive + , testProperty "definition of linking" prop_linking + + ] + +-------------------------------------------------------------------------------- + +testgroup_Braid_NF :: Test +testgroup_Braid_NF = testGroup "Braid/NF" + + [ testProperty "NF with naive inverse elimination == less naive inverse elimination" prop_braidnf_naive + , testProperty "NF with reduction == NF without reduction" prop_braidnf_reduce + + , testProperty "NF = NF of representative word of NF" prop_braidnf_reprs + , testProperty "NF = NF of perturbed word" prop_braidnf_perturb + + , testProperty "linking of word == linking of representative of NF" prop_braidnf_link + + , testProperty "NF of positive word is positive" prop_braidnf_pos + + , testProperty "Lemma 2.5" prop_lemma_2_5 + + , testProperty "permutationBraid and tau commutes, up to NF" prop_permTau_2 + ] + +-------------------------------------------------------------------------------- +-- * braid properties + +prop_link_reduce :: UnreducedBraid -> Bool +prop_link_reduce (Unreduced braid) = linkingMatrix braid == linkingMatrix braid' where + braid' = freeReduceBraidWord braid + +prop_link_perturb :: PerturbedBraid -> Bool +prop_link_perturb (Perturbed braid1 braid2) = linkingMatrix braid1 == linkingMatrix braid2 + +prop_tau_square :: ReducedBraid -> Bool +prop_tau_square (Reduced braid) = braidWord (tau (tau braid)) == braidWord braid + +prop_permTau_1 :: PermutationBraid -> Bool +prop_permTau_1 (PermBraid perm braid) = tauPerm perm == braidPermutation (tau braid) + +prop_permBraid_perm :: PermutationBraid -> Bool +prop_permBraid_perm (PermBraid perm braid) = (braidPermutation braid == perm) + +prop_permBraid_valid :: PermutationBraid -> Bool +prop_permBraid_valid (PermBraid perm braid) = isPermutationBraid braid + +prop_braidPerm_comp :: TwoBraids -> Bool +prop_braidPerm_comp (TwoBraids b1 b2) = (p == q) where + p = braidPermutation (compose b1 b2) + q = braidPermutation b1 `P.multiply` braidPermutation b2 + +prop_link_positive :: PositiveBraid -> Bool +prop_link_positive (PositiveB braid) = all (>=0) $ elems $ linkingMatrix braid + +prop_linking :: UnreducedBraid -> Bool +prop_linking (Unreduced braid) = (linkingMatrix braid == matrix) where + n = numberOfStrands braid + matrix = array ((1,1),(n,n)) [ ((i,j),strandLinking braid i j) | i<-[1..n], j<-[1..n] ] + +-------------------------------------------------------------------------------- + +prop_braidnf_naive :: UnreducedBraid -> Bool +prop_braidnf_naive (Unreduced braid) = (braidNormalFormNaive' braid == braidNormalForm' braid) + +prop_braidnf_reduce :: UnreducedBraid -> Bool +prop_braidnf_reduce (Unreduced braid) = (braidNormalForm' braid == braidNormalForm braid) + +prop_braidnf_reprs :: ReducedBraid -> Bool +prop_braidnf_reprs (Reduced braid) = (nf == nf') where + nf = braidNormalForm braid + nf' = braidNormalForm braid' + braid' = nfReprWord nf + +prop_braidnf_perturb :: PerturbedBraid -> Bool +prop_braidnf_perturb (Perturbed braid1 braid2) = (braidNormalForm braid1 == braidNormalForm braid2) + +prop_braidnf_link :: UnreducedBraid -> Bool +prop_braidnf_link (Unreduced braid) = (linkingMatrix braid == linkingMatrix braid') where + nf = braidNormalForm braid + braid' = nfReprWord nf + +prop_braidnf_pos :: PositiveBraid -> Bool +prop_braidnf_pos (PositiveB braid) = (_nfDeltaExp (braidNormalForm braid) >= 0) + +prop_lemma_2_5 :: Permutation -> Bool +prop_lemma_2_5 p = and [ check i | i<-[1..n-1] ] where + n = P.permutationSize p + w = _permutationBraid p + s = permWordStartingSet n w + check i = _isPermutationBraid n (i:w) == (not $ elem i s) + +prop_permTau_2 :: PermutationBraid -> Bool +prop_permTau_2 (PermBraid perm braid) = (nf1 == nf2) where + nf1 = braidNormalForm $ permutationBraid (tauPerm perm) + nf2 = braidNormalForm $ tau braid + +-------------------------------------------------------------------------------- + + diff --git a/test/Tests/Common.hs b/test/Tests/Common.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Common.hs @@ -0,0 +1,35 @@ + +-- | Helper routines for tests + +{-# LANGUAGE Rank2Types #-} +module Tests.Common where + +-------------------------------------------------------------------------------- + +import Test.QuickCheck +import Test.QuickCheck.Gen + +import System.Random + +-------------------------------------------------------------------------------- + +-- | Generates a random element. +choose_ :: Random a => Gen a +choose_ = MkGen (\r _ -> let (x,_) = random r in x) + +-- | Generates two random elements +choosePair_ :: Random a => Gen (a,a) +choosePair_ = do + x <- choose_ + y <- choose_ + return (x,y) + +-- | Generates a random element. +myMkGen :: (forall g. RandomGen g => g -> (a,g)) -> Gen a +myMkGen fun = MkGen (\r _ -> let (x,_) = fun r in x) + +-- | Generates a random element. +myMkSizedGen :: (forall g. RandomGen g => Int -> g -> (a,g)) -> Gen a +myMkSizedGen fun = MkGen (\r siz -> let (x,_) = fun siz r in x) + +-------------------------------------------------------------------------------- diff --git a/test/Tests/LatticePaths.hs b/test/Tests/LatticePaths.hs new file mode 100644 --- /dev/null +++ b/test/Tests/LatticePaths.hs @@ -0,0 +1,111 @@ + +-- | Tests for lattice paths +-- + +{-# LANGUAGE CPP, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-} +module Tests.LatticePaths where + +-------------------------------------------------------------------------------- + +import Math.Combinat.LatticePaths + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import System.Random + +import Control.Monad + +import Data.List + +import Math.Combinat.Classes +import Math.Combinat.Helper +import Math.Combinat.Sign +import Math.Combinat.Numbers ( factorial , binomial ) + +-------------------------------------------------------------------------------- +-- * instances + +-- | Half-length of a Dyck path +newtype Half = Half Int deriving (Eq,Show) + +-- | First number is (usually) less or equal than the second +data HalfPair = HalfPair Int Int deriving (Eq,Show) + +maxHalfSize :: Int +maxHalfSize = 11 -- number of paths grow exponentially + +instance Arbitrary Half where + arbitrary = liftM Half $ choose (0,maxHalfSize) + +instance Arbitrary HalfPair where + arbitrary = do + n <- choose (0,maxHalfSize) + k <- choose (0,n+1) + return (HalfPair k n) + +fi :: Int -> Integer +fi = fromIntegral + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_LatticePaths :: Test +testgroup_LatticePaths = testGroup "Lattice paths" + + [ testProperty "dyck paths are in reverse lexicographic order" prop_revlex + , testProperty "naive Dyck path algorithm = less naive algorithm" prop_dyck_naive + , testProperty "counting Dyck paths" prop_count + , testProperty "counting Lattice paths" prop_count_lattice + + , testProperty "bounded Dyck paths, def, v1" prop_bounded_1 + , testProperty "bounded Dyck paths, def, v2" prop_bounded_2 + , testProperty "bounded Dyck paths w/ high bound = all dyck paths" prop_not_bounded + + , testProperty "zero-touching Dyck paths" prop_touching + , testProperty "Dyck paths w/ k peaks" prop_peaking + + ] + +-------------------------------------------------------------------------------- +-- * test properties + +prop_revlex :: Bool +prop_revlex = and [ sort (dyckPaths m) == reverse (dyckPaths m) | m <- [0..maxHalfSize] ] + +prop_dyck_naive :: Bool +prop_dyck_naive = and [ sort (dyckPathsNaive m) == sort (dyckPaths m) | m <- [0..maxHalfSize] ] + +prop_count :: Bool +prop_count = and [ fi (length (dyckPaths m)) == countDyckPaths m | m <- [0..maxHalfSize] ] + +prop_count_lattice :: HalfPair -> Bool +prop_count_lattice (HalfPair y x) = fi (length (latticePaths (x,y))) == countLatticePaths (x,y) + +prop_bounded_1 :: HalfPair -> Bool +prop_bounded_1 (HalfPair h m) = (one == two) where + one = sort (boundedDyckPaths h m ) + two = sort [ p | p <- dyckPaths m , pathHeight p <= h ] + +prop_bounded_2 :: Half -> Half -> Bool +prop_bounded_2 (Half h) (Half m) = (one == two) where + one = sort (boundedDyckPaths h m ) + two = sort [ p | p <- dyckPaths m , pathHeight p <= h ] + +prop_not_bounded :: Bool +prop_not_bounded = and [ sort (boundedDyckPaths m m) == sort (dyckPaths m) | m <- [0..maxHalfSize] ] + +prop_touching :: HalfPair -> Bool +prop_touching (HalfPair k m) = (one == two && fi (length one) == cnt) where + one = sort (touchingDyckPaths k m) + two = sort [ p | p <- dyckPaths m , pathNumberOfZeroTouches p == k ] + cnt = countTouchingDyckPaths k m + +prop_peaking :: HalfPair -> Bool +prop_peaking (HalfPair k m) = (one == two && fi (length one) == cnt) where + one = sort (peakingDyckPaths k m) + two = sort [ p | p <- dyckPaths m , pathNumberOfPeaks p == k ] + cnt = countPeakingDyckPaths k m + +-------------------------------------------------------------------------------- + diff --git a/test/Tests/Partitions/Integer.hs b/test/Tests/Partitions/Integer.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Partitions/Integer.hs @@ -0,0 +1,107 @@ + +-- | Tests for integer partitions. + +{-# LANGUAGE CPP, BangPatterns #-} +module Tests.Partitions.Integer where + +-------------------------------------------------------------------------------- + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import Tests.Common + +import Math.Combinat.Partitions.Integer + +import Data.List +import Control.Monad + +-- import Data.Map (Map) +-- import qualified Data.Map as Map + +import Math.Combinat.Classes +import Math.Combinat.Numbers ( factorial , binomial , multinomial ) +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * Types and instances + +newtype PartitionWeight = PartitionWeight Int deriving (Eq,Show) +data PartitionWeightPair = PartitionWeightPair Int Int deriving (Eq,Show) +data PartitionIntPair = PartitionIntPair Partition Int deriving (Eq,Show) + +maxPartitionSize :: Int +maxPartitionSize = 44 + +instance Arbitrary Partition where + arbitrary = do + n <- choose (0,maxPartitionSize) + myMkGen (randomPartition n) + +instance Arbitrary PartitionWeight where + arbitrary = liftM PartitionWeight $ choose (0,maxPartitionSize) + +instance Arbitrary PartitionWeightPair where + arbitrary = do + n <- choose (0,maxPartitionSize) + k <- choose (0,n+2) + return (PartitionWeightPair n k) + +instance Arbitrary PartitionIntPair where + arbitrary = do + part <- arbitrary + k <- choose (0,partitionWeight part + 2) + return (PartitionIntPair part k) + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_IntegerPartitions :: Test +testgroup_IntegerPartitions = testGroup "Integer Partitions" + + [ testProperty "partitions in a box" prop_partitions_in_bigbox + , testProperty "partitions with k parts" prop_kparts + , testProperty "odd partitions" prop_odd_partitions + , testProperty "partitions with distinct parts" prop_distinct_partitions + , testProperty "subpartitions" prop_subparts + , testProperty "dual^2 is identity" prop_dual_dual + , testProperty "dominated partitions" prop_dominated_list + , testProperty "dominating partitions" prop_dominating_list + , testProperty "counting partitions" prop_countParts + ] + +-------------------------------------------------------------------------------- +-- * properties + +prop_partitions_in_bigbox :: PartitionWeight -> Bool +prop_partitions_in_bigbox (PartitionWeight n) = (partitions n == partitions' (n,n) n) + +prop_kparts :: PartitionWeightPair -> Bool +prop_kparts (PartitionWeightPair n k) = (partitionsWithKParts k n == [ mu | mu <- partitions n, numberOfParts mu == k ]) + +prop_odd_partitions :: PartitionWeight -> Bool +prop_odd_partitions (PartitionWeight n) = + (partitionsWithOddParts n == [ mu | mu <- partitions n, and (map odd (fromPartition mu)) ]) + +prop_distinct_partitions :: PartitionWeight -> Bool +prop_distinct_partitions (PartitionWeight n) = + (partitionsWithDistinctParts n == [ mu | mu <- partitions n, let xs = fromPartition mu, xs == nub xs ]) + +prop_subparts :: PartitionIntPair -> Bool +prop_subparts (PartitionIntPair lam d) = (subPartitions d lam) == sort [ p | p <- partitions d, isSubPartitionOf p lam ] + +prop_dual_dual :: Partition -> Bool +prop_dual_dual lam = (lam == dualPartition (dualPartition lam)) + +prop_dominated_list :: Partition -> Bool +prop_dominated_list lam = (dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ]) + +prop_dominating_list :: Partition -> Bool +prop_dominating_list mu = (dominatingPartitions mu == [ lam | lam <- partitions (weight mu ), lam `dominates` mu ]) + +prop_countParts :: Bool +prop_countParts = (take 50 partitionCountList == take 50 partitionCountListNaive) + +-------------------------------------------------------------------------------- + diff --git a/test/Tests/Partitions/Skew.hs b/test/Tests/Partitions/Skew.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Partitions/Skew.hs @@ -0,0 +1,85 @@ + +-- | Tests for skew partitions. +-- + +{-# LANGUAGE CPP, BangPatterns #-} +module Tests.Partitions.Skew where + +-------------------------------------------------------------------------------- + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import Tests.Common +import Tests.Partitions.Integer () -- Arbitrary instances + +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Skew + +import Data.List + +import Math.Combinat.Classes + +-------------------------------------------------------------------------------- +-- * instances + +instance Arbitrary SkewPartition where + arbitrary = do + p <- arbitrary + let n = partitionWeight p + d <- choose (0,n) + let qs = subPartitions d p + ln = length qs + k <- choose (0,ln-1) + let q = qs !! k + return $ mkSkewPartition (p,q) + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_SkewPartitions :: Test +testgroup_SkewPartitions = testGroup "Skew Partitions" + + [ testProperty "dual^2 = identity" prop_dual_dual + , testProperty "dual vs. inner/outer dual" prop_dual_from + , testProperty "to . from = identity" prop_from_to + , testProperty "from . to = identity" prop_to_from + , testProperty "from . to . from = from" prop_from_to_from + , testProperty "weight vs. inner/outer weight" prop_weight + ] + +-------------------------------------------------------------------------------- +-- * properties + +prop_dual_dual :: SkewPartition -> Bool +prop_dual_dual sp = (dualSkewPartition (dualSkewPartition sp) == sp) + +prop_dual_from :: SkewPartition -> Bool +prop_dual_from sp = (p == dual p' && q == dual q') where + (p,q) = fromSkewPartition sp + sp' = dualSkewPartition sp + (p',q') = fromSkewPartition sp' + +prop_from_to :: SkewPartition -> Bool +prop_from_to sp = (mkSkewPartition (fromSkewPartition sp) == sp) + +prop_to_from :: (Partition,Partition) -> Bool +prop_to_from (p,q) = + case mb of + Nothing -> True + Just sp -> fromSkewPartition sp == (p,q) + where + mb = safeSkewPartition (p,q) + +prop_from_to_from :: SkewPartition -> Bool +prop_from_to_from sp = (pq == pq') where + pq = fromSkewPartition sp + sp' = mkSkewPartition pq + pq' = fromSkewPartition sp' + +prop_weight :: SkewPartition -> Bool +prop_weight sp = (skewPartitionWeight sp == weight p - weight q) where + (p,q) = fromSkewPartition sp + +-------------------------------------------------------------------------------- diff --git a/test/Tests/Permutations.hs b/test/Tests/Permutations.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Permutations.hs @@ -0,0 +1,219 @@ + +-- | Tests for permutations. +-- + +{-# LANGUAGE CPP, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-} +module Tests.Permutations where + +-------------------------------------------------------------------------------- + +import Math.Combinat.Permutations + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import System.Random + +import Control.Monad +import Control.Monad.ST + +import Data.List hiding (permutations) + +import Data.Array (Array) +import Data.Array.ST +import Data.Array.Unboxed +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Unsafe + +import Math.Combinat.ASCII +import Math.Combinat.Classes +import Math.Combinat.Helper +import Math.Combinat.Sign +import Math.Combinat.Numbers (factorial,binomial) + +-------------------------------------------------------------------------------- +-- * generating permutations (random & arbitrary instances, spec types etc) + +minPermSize = 1 +maxPermSize = 123 + +newtype Elem = Elem Int deriving Eq +newtype Nat = Nat { fromNat :: Int } deriving (Eq,Ord,Show,Num,Random) + +naturalSet :: Permutation -> Array Int Elem +naturalSet perm = listArray (1,n) [ Elem i | i<-[1..n] ] where + n = permutationSize perm + +permInternalSet :: Permutation -> Array Int Elem +permInternalSet perm@(Permutation arr) = listArray (1,n) [ Elem (arr!i) | i<-[1..n] ] where + n = permutationSize perm + +sameSize :: Permutation -> Permutation -> Bool +sameSize perm1 perm2 = ( permutationSize perm1 == permutationSize perm2) + +newtype CyclicPermutation = Cyclic { fromCyclic :: Permutation } deriving Show + +data SameSize = SameSize Permutation Permutation deriving Show + +instance Random Permutation where + random g = randomPermutation size g1 where + (size,g1) = randomR (minPermSize,maxPermSize) g + randomR _ = random + +instance Random CyclicPermutation where + random g = (Cyclic cycl,g2) where + (size,g1) = randomR (minPermSize,maxPermSize) g + (cycl,g2) = randomCyclicPermutation size g1 + randomR _ = random + +instance Random DisjointCycles where + random g = (disjcyc,g2) where + (size,g1) = randomR (minPermSize,maxPermSize) g + (perm,g2) = randomPermutation size g1 + disjcyc = permutationToDisjointCycles perm + randomR _ = random + +instance Random SameSize where + random g = (SameSize prm1 prm2, g3) where + (size,g1) = randomR (minPermSize,maxPermSize) g + (prm1,g2) = randomPermutation size g1 + (prm2,g3) = randomPermutation size g2 + randomR _ = random + +instance Arbitrary Nat where + arbitrary = choose (Nat 0 , Nat 50) + +instance Arbitrary Permutation where arbitrary = choose undefined +instance Arbitrary CyclicPermutation where arbitrary = choose undefined +instance Arbitrary DisjointCycles where arbitrary = choose undefined +instance Arbitrary SameSize where arbitrary = choose undefined + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_Permutations :: Test +testgroup_Permutations = testGroup "Permutations" + + [ testProperty "disjoint cycles /1" prop_disjcyc_1 + , testProperty "disjoint cycles /2" prop_disjcyc_2 + + , testProperty "disjoint cycles compatibility" prop_disjcyc_Mathematica + + , testProperty "random cyclic permutation is indeed cyclic" prop_randCyclic + , testProperty "inverse^2 is identity" prop_inverse + + , testProperty "permutation action is group action" prop_mulPerm + , testProperty "left permutation action is left group action" prop_mulPermLeft + , testProperty "right permutation action is right group action" prop_mulPermRight + + , testProperty "permutation action convetion" prop_perm + , testProperty "left permutation action convention" prop_permLeft + , testProperty "right permutation action convention" prop_permRight + , testProperty "left/right permutation action convention" prop_permLeftRight + + , testProperty "cycle left" prop_cycleLeft + , testProperty "cycle right" prop_cycleRight + + , testProperty "sign of permutation is multiplicative" prop_mulSign + , testProperty "inverse is compatible with multiplication" prop_invMul + + , testProperty "parity of cyclic permutaiton" prop_cyclSign + , testProperty "random permutation is valid" prop_permIsPerm + , testProperty "definition of parity" prop_isEven + + , testProperty "bubbleSort works" prop_bubbleSort + , testProperty "bubbleSort2 works" prop_bubbleSort2 + , testProperty "number of inversions = steps in bubble sort" prop_bubble_inversions + , testProperty "number of inversions = actual number of inversions" prop_number_inversions + , testProperty "number of inversions is the same for the inverse permutation" prop_ninversions_inverse + , testProperty "merge sort algorithm = naive inversion count" prop_merge_inversions + + ] + +-------------------------------------------------------------------------------- +-- * test properties + +prop_disjcyc_1 perm = ( perm == disjointCyclesToPermutation n (permutationToDisjointCycles perm) ) + where n = permutationSize perm + +prop_disjcyc_2 k dcyc = ( dcyc == permutationToDisjointCycles (disjointCyclesToPermutation n dcyc) ) + where + n = fromNat k + m + m = case fromDisjointCycles dcyc of + [] -> 1 + xxs -> maximum (concat xxs) + +-- PermutationCycles[ { 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 } ] +-- Cycles [ {{1, 12, 18, 19, 14, 21, 23, 13, 22}, {2, 15, 8, 9, 20, 16, 10, 3, 5}, {4, 6, 7, 17}} ] +prop_disjcyc_Mathematica = (permutationToDisjointCycles perm == disjcyc) + && (disjointCyclesToPermutation n disjcyc == perm) + where + n = permutationSize perm + perm = toPermutation [ 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 ] + disjcyc = DisjointCycles [ [1, 12, 18, 19, 14, 21, 23, 13, 22], [2, 15, 8, 9, 20, 16, 10, 3, 5], [4, 6, 7, 17] ] + +xperm = toPermutation [ 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 ] +xdisjcyc = DisjointCycles [ [1, 12, 18, 19, 14, 21, 23, 13, 22], [2, 15, 8, 9, 20, 16, 10, 3, 5], [4, 6, 7, 17] ] + +prop_randCyclic cycl = ( isCyclicPermutation (fromCyclic cycl) ) + +prop_inverse perm = ( perm == inverse (inverse perm) ) + +prop_mulPerm (SameSize perm1 perm2) = + ( permute perm2 (permute perm1 set) == permute (perm1 `multiply` perm2) set ) + where + set = naturalSet perm1 + +prop_mulPermRight (SameSize perm1 perm2) = + ( permuteRight perm2 (permuteRight perm1 set) == permuteRight (perm1 `multiply` perm2) set ) + where + set = naturalSet perm1 + +prop_mulPermLeft (SameSize perm1 perm2) = + ( permuteLeft perm2 (permuteLeft perm1 set) == permuteLeft (perm2 `multiply` perm1) set ) + where + set = naturalSet perm1 + +prop_perm perm = permute perm (naturalSet perm) == permInternalSet perm +prop_permLeft perm = permuteLeft perm (permInternalSet perm) == naturalSet perm +prop_permRight perm = permuteRight perm (naturalSet perm) == permInternalSet perm +prop_permLeftRight perm = permuteLeft (inverse perm) (naturalSet perm) == permuteRight (perm) (naturalSet perm) + +prop_cycleLeft = permuteList (cycleLeft 5) "abcde" == "bcdea" +prop_cycleRight = permuteList (cycleRight 5) "abcde" == "eabcd" + +prop_mulSign (SameSize perm1 perm2) = + ( sgn perm1 * sgn perm2 == sgn (perm1 `multiply` perm2) ) + where + sgn = signValue . signOfPermutation :: Permutation -> Int + +prop_invMul (SameSize perm1 perm2) = + ( inverse perm2 `multiply` inverse perm1 == inverse (perm1 `multiply` perm2) ) + +prop_cyclSign cycl = ( isEvenPermutation perm == odd n ) where + perm = fromCyclic cycl + n = permutationSize perm + +prop_permIsPerm perm = ( isPermutation (fromPermutation perm) ) + +prop_isEven perm = ( isEvenPermutation perm == isEvenAlternative perm ) where + isEvenAlternative p = + even $ sum $ map (\x->x-1) $ map length $ fromDisjointCycles $ permutationToDisjointCycles p + +prop_bubbleSort perm = multiplyMany' n (map (adjacentTransposition n) $ bubbleSort perm) == perm where + n = permutationSize perm + +prop_bubbleSort2 perm = multiplyMany' n (map (transposition n) $ bubbleSort2 perm) == perm where + n = permutationSize perm + +prop_bubble_inversions perm = length (bubbleSort perm) == numberOfInversions perm + +prop_number_inversions perm = length (inversions perm) == numberOfInversions perm + +prop_ninversions_inverse perm = numberOfInversions perm == numberOfInversions (inverse perm) + +prop_merge_inversions perm = (numberOfInversionsMerge perm == numberOfInversionsNaive perm) + +-------------------------------------------------------------------------------- + diff --git a/test/Tests/Series.hs b/test/Tests/Series.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Series.hs @@ -0,0 +1,303 @@ + +-- | Tests for power series +-- + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +module Tests.Series where + +-------------------------------------------------------------------------------- + +import Math.Combinat.Numbers.Series + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import System.Random + +import Data.List + +import Math.Combinat.Sign +import Math.Combinat.Numbers +import Math.Combinat.Partitions.Integer +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * code used only for tests + +-- | Expansion of @1 / (1-x^k)@. Included for completeness only; +-- it equals to @coinSeries [k]@, and for example +-- for @k=4@ it is simply +-- +-- > [1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0...] +-- +pseries1 :: Int -> [Integer] +pseries1 k1 = convolveWithPSeries1 k1 unitSeries + +-- | The expansion of @1 / (1-x^k_1-x^k_2)@ +pseries2 :: Int -> Int -> [Integer] +pseries2 k1 k2 = convolveWithPSeries2 k1 k2 unitSeries + +-- | The expansion of @1 / (1-x^k_1-x^k_2-x^k_3)@ +pseries3 :: Int -> Int -> Int -> [Integer] +pseries3 k1 k2 k3 = convolveWithPSeries3 k1 k2 k3 unitSeries + +-------------------------------------------------------------------------------- + +-- | Convolve with (the expansion of) @1 / (1-x^k1)@ +convolveWithPSeries1 :: Int -> [Integer] -> [Integer] +convolveWithPSeries1 k1 series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith (+) series ( replicate k1 0 ++ xs ) + +-- | Convolve with (the expansion of) @1 / (1-x^k1-x^k2)@ +convolveWithPSeries2 :: Int -> Int -> [Integer] -> [Integer] +convolveWithPSeries2 k1 k2 series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith3 (\x y z -> x + y + z) + series + ( replicate k1 0 ++ xs ) + ( replicate k2 0 ++ xs ) + +-- | Convolve with (the expansion of) @1 / (1-x^k_1-x^k_2-x^k_3)@ +convolveWithPSeries3 :: Int -> Int -> Int -> [Integer] -> [Integer] +convolveWithPSeries3 k1 k2 k3 series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith4 (\x y z w -> x + y + z + w) + series + ( replicate k1 0 ++ xs ) + ( replicate k2 0 ++ xs ) + ( replicate k3 0 ++ xs ) + +-------------------------------------------------------------------------------- + +-- | @1 / (1 - a*x^k)@. +-- For example, for @a=3@ and @k=2@ it is just +-- +-- > [1,0,3,0,9,0,27,0,81,0,243,0,729,0,2187,0,6561,0,19683,0...] +-- +pseries1' :: Num a => (a,Int) -> [a] +pseries1' ak1 = convolveWithPSeries1' ak1 unitSeries + +-- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@ +pseries2' :: Num a => (a,Int) -> (a,Int) -> [a] +pseries2' ak1 ak2 = convolveWithPSeries2' ak1 ak2 unitSeries + +-- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@ +pseries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a] +pseries3' ak1 ak2 ak3 = convolveWithPSeries3' ak1 ak2 ak3 unitSeries + +-------------------------------------------------------------------------------- + +-- | Convolve with @1 / (1 - a*x^k)@. +convolveWithPSeries1' :: Num a => (a,Int) -> [a] -> [a] +convolveWithPSeries1' (a1,k1) series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith (+) + series + ( replicate k1 0 ++ map (*a1) xs ) + +-- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@ +convolveWithPSeries2' :: Num a => (a,Int) -> (a,Int) -> [a] -> [a] +convolveWithPSeries2' (a1,k1) (a2,k2) series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith3 (\x y z -> x + y + z) + series + ( replicate k1 0 ++ map (*a1) xs ) + ( replicate k2 0 ++ map (*a2) xs ) + +-- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@ +convolveWithPSeries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a] -> [a] +convolveWithPSeries3' (a1,k1) (a2,k2) (a3,k3) series1 = xs where + series = series1 ++ repeat 0 + xs = zipWith4 (\x y z w -> x + y + z + w) + series + ( replicate k1 0 ++ map (*a1) xs ) + ( replicate k2 0 ++ map (*a2) xs ) + ( replicate k3 0 ++ map (*a3) xs ) + +-------------------------------------------------------------------------------- +-- * Types and instances + +{- +swap :: (a,b) -> (b,a) +swap (x,y) = (y,x) +-} + +-- compare the first 500 elements of the infinite lists +(=!=) :: (Eq a, Num a) => [a] -> [a] -> Bool +(=!=) xs1 ys1 = (take m xs == take m ys) where + m = 500 + xs = xs1 ++ repeat 0 + ys = ys1 ++ repeat 0 + +infix 4 =!= + +newtype Nat = Nat { fromNat :: Int } deriving (Eq,Ord,Show,Num,Random) +newtype Ser = Ser { fromSer :: [Integer] } deriving (Eq,Ord,Show) +newtype Exp = Exp { fromExp :: Int } deriving (Eq,Ord,Show,Num,Random) +newtype Exps = Exps { fromExps :: [Int] } deriving (Eq,Ord,Show) +newtype CoeffExp = CoeffExp { fromCoeffExp :: (Integer,Int) } deriving (Eq,Ord,Show) +newtype CoeffExps = CoeffExps { fromCoeffExps :: [(Integer,Int)] } deriving (Eq,Ord,Show) + +minSerSize = 0 :: Int +maxSerSize = 1000 :: Int + +minSerValue = -10000 :: Int +maxSerValue = 10000 :: Int + +rndList :: (RandomGen g, Random a) => Int -> (a, a) -> g -> ([a], g) +rndList n minmax g = swap $ mapAccumL f g [1..n] where + f g _ = swap $ randomR minmax g + +instance Arbitrary Nat where + arbitrary = choose (Nat 0 , Nat 750) + +instance Arbitrary Exp where + arbitrary = choose (Exp 1 , Exp 32) + +instance Arbitrary CoeffExp where + arbitrary = do + coeff <- choose (minSerValue, maxSerValue) :: Gen Int + exp <- arbitrary :: Gen Exp + return $ CoeffExp (fromIntegral coeff, fromExp exp) + +instance Random Ser where + random g = (Ser $ map fi list, g2) where + (size,g1) = randomR (minSerSize,maxSerSize) g + (list,g2) = rndList size (minSerValue,maxSerValue) g1 + fi :: Int -> Integer + fi = fromIntegral + randomR _ = random + +instance Random Exps where + random g = (Exps list, g2) where + (size,g1) = randomR (0,10) g + (list,g2) = rndList size (1,32) g1 + randomR _ = random + +instance Random CoeffExps where + random g = (CoeffExps (zip (map fromIntegral list2) list1), g3) where + (size,g1) = randomR (0,10) g + (list1,g2) = rndList size (1,32) g1 + (list2,g3) = rndList size (minSerValue,maxSerValue) g2 + randomR _ = random + +instance Arbitrary Ser where + arbitrary = choose undefined + +instance Arbitrary Exps where + arbitrary = choose undefined + +instance Arbitrary CoeffExps where + arbitrary = choose undefined + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_PowerSeries :: Test +testgroup_PowerSeries = testGroup "Power series" + [ + testProperty "convPSeries1 vs generic" prop_conv1_vs_gen + , testProperty "convPSeries2 vs generic" prop_conv2_vs_gen + , testProperty "convPSeries3 vs generic" prop_conv3_vs_gen + , testProperty "convPSeries1' vs generic" prop_conv1_vs_gen' + , testProperty "convPSeries2' vs generic" prop_conv2_vs_gen' + , testProperty "convPSeries3' vs generic" prop_conv3_vs_gen' + , testProperty "convolve_pseries" prop_convolve_pseries + , testProperty "convolve_pseries'" prop_convolve_pseries' + , testProperty "coinSeries vs pseries" prop_coin_vs_pseries + , testProperty "coinSeries vs pseries'" prop_coin_vs_pseries' + + -- these are very slow, because random is slow + , testProperty "leftIdentity" prop_leftIdentity + , testProperty "rightIdentity" prop_rightIdentity + , testProperty "commutativity" prop_commutativity + , testProperty "associativity" prop_associativity + ] + +-------------------------------------------------------------------------------- +-- * properties + +prop_leftIdentity ser = ( xs =!= unitSeries `convolve` xs ) where + xs = fromSer ser + +prop_rightIdentity ser = ( unitSeries `convolve` xs =!= xs ) where + xs = fromSer ser + +prop_commutativity ser1 ser2 = ( xs `convolve` ys =!= ys `convolve` xs ) where + xs = fromSer ser1 + ys = fromSer ser2 + +prop_associativity ser1 ser2 ser3 = ( one =!= two ) where + one = (xs `convolve` ys) `convolve` zs + two = xs `convolve` (ys `convolve` zs) + xs = fromSer ser1 + ys = fromSer ser2 + zs = fromSer ser3 + +prop_conv1_vs_gen exp1 ser = ( one =!= two ) where + one = convolveWithPSeries1 k1 xs + two = convolveWithPSeries [k1] xs + k1 = fromExp exp1 + xs = fromSer ser + +prop_conv2_vs_gen exp1 exp2 ser = (one =!= two) where + one = convolveWithPSeries2 k1 k2 xs + two = convolveWithPSeries [k2,k1] xs + k1 = fromExp exp1 + k2 = fromExp exp2 + xs = fromSer ser + +prop_conv3_vs_gen exp1 exp2 exp3 ser = (one =!= two) where + one = convolveWithPSeries3 k1 k2 k3 xs + two = convolveWithPSeries [k2,k3,k1] xs + k1 = fromExp exp1 + k2 = fromExp exp2 + k3 = fromExp exp3 + xs = fromSer ser + +prop_conv1_vs_gen' exp1 ser = ( one =!= two ) where + one = convolveWithPSeries1' ak1 xs + two = convolveWithPSeries' [ak1] xs + ak1 = fromCoeffExp exp1 + xs = fromSer ser + +prop_conv2_vs_gen' exp1 exp2 ser = (one =!= two) where + one = convolveWithPSeries2' ak1 ak2 xs + two = convolveWithPSeries' [ak2,ak1] xs + ak1 = fromCoeffExp exp1 + ak2 = fromCoeffExp exp2 + xs = fromSer ser + +prop_conv3_vs_gen' exp1 exp2 exp3 ser = (one =!= two) where + one = convolveWithPSeries3' ak1 ak2 ak3 xs + two = convolveWithPSeries' [ak2,ak3,ak1] xs + ak1 = fromCoeffExp exp1 + ak2 = fromCoeffExp exp2 + ak3 = fromCoeffExp exp3 + xs = fromSer ser + +prop_convolve_pseries exps1 ser = (one =!= two) where + one = convolveWithPSeries ks1 xs + two = xs `convolve` pseries ks1 + ks1 = fromExps exps1 + xs = fromSer ser + +prop_convolve_pseries' cexps1 ser = (one =!= two) where + one = convolveWithPSeries' aks1 xs + two = xs `convolve` pseries' aks1 + aks1 = fromCoeffExps cexps1 + xs = fromSer ser + +prop_coin_vs_pseries exps1 = (one =!= two) where + one = coinSeries ks1 + two = convolveMany (map pseries1 ks1) + ks1 = fromExps exps1 + +prop_coin_vs_pseries' cexps1 = (one =!= two) where + one = coinSeries' aks1 + two = convolveMany (map pseries1' aks1) + aks1 = fromCoeffExps cexps1 + +-------------------------------------------------------------------------------- + diff --git a/test/Tests/SkewTableaux.hs b/test/Tests/SkewTableaux.hs new file mode 100644 --- /dev/null +++ b/test/Tests/SkewTableaux.hs @@ -0,0 +1,103 @@ + +-- | Tests for skew tableaux + +{-# LANGUAGE FlexibleInstances #-} +module Tests.SkewTableaux where + +-------------------------------------------------------------------------------- + +import Control.Monad + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Gen + +import Tests.Partitions.Integer () +import Tests.Partitions.Skew () -- arbitrary instances + +import Math.Combinat.Tableaux +import Math.Combinat.Tableaux.Skew +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Skew + +-------------------------------------------------------------------------------- +-- * code + +numberOfNonEmptyRows :: SkewPartition -> Int +numberOfNonEmptyRows (SkewPartition xys) = length [ True | (x,y) <- xys, y/=0 ] + +-- | Breaks a skew partition into disjoint parts +disjointParts :: SkewPartition -> [SkewPartition] +disjointParts (SkewPartition xys) = map normalizeSkewPartition list where + + list = map SkewPartition $ filter (not . isEmpty) $ break xys + + isEmpty :: [(Int,Int)] -> Bool + isEmpty xys = and [ y==0 | (x,y) <- xys ] + + break :: [(Int,Int)] -> [[(Int,Int)]] + break [] = [[]] + break [xy] = [[xy]] + break ( xy@(x,y) : rest@((x',y'):_) ) = if x >= x'+y' + then [xy] : break rest + else let ( xys : rest' ) = break rest + in ( (xy:xys) : rest' ) + + + + +-------------------------------------------------------------------------------- +-- * instances + +instance Arbitrary (SkewTableau Int) where + arbitrary = do + shape <- arbitrary + let w = skewPartitionWeight shape + content <- replicateM w $ choose (1,1000) + return $ fillSkewPartitionWithRowWord shape content + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_SkewTableaux :: Test +testgroup_SkewTableaux = testGroup "Skew tableaux" + [ testProperty "dual^2 = identity" prop_skew_dual_dual + , testProperty "fill . rowWord = identity" prop_rowWord + , testProperty "fill . columnWord = identity" prop_columnWord + , testProperty "fill respectes the shape" prop_fill_shape + , testProperty "semistandard skew tableaux are indeed semistandard" prop_semistandard + ] + +-------------------------------------------------------------------------------- +-- * properties + +prop_skew_dual_dual :: SkewTableau Int -> Bool +prop_skew_dual_dual st = (dualSkewTableau (dualSkewTableau st) == st) + +prop_rowWord :: SkewTableau Int -> Bool +prop_rowWord st = (fillSkewPartitionWithRowWord shape content == st) where + shape = skewTableauShape st + content = skewTableauRowWord st + +prop_columnWord :: SkewTableau Int -> Bool +prop_columnWord st = (fillSkewPartitionWithColumnWord shape content == st) where + shape = skewTableauShape st + content = skewTableauColumnWord st + +prop_fill_shape :: SkewPartition -> Bool +prop_fill_shape shape = (shape == shape') where + tableau = fillSkewPartitionWithColumnWord shape [1..] + shape' = skewTableauShape tableau + +prop_semistandard :: SkewPartition -> Bool +prop_semistandard shape = and + [ isSemiStandardSkewTableau st + | n <- [kk..nn] + , st <- take 500 (semiStandardSkewTableaux n shape) -- we only take the first 500 because impossibly slow otherwise + ] + where + nn = min (kk + 10) (skewPartitionWeight shape) + kk = maximum $ 0 : (map numberOfNonEmptyRows $ disjointParts shape) + +-------------------------------------------------------------------------------- diff --git a/test/Tests/Thompson.hs b/test/Tests/Thompson.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Thompson.hs @@ -0,0 +1,134 @@ + +-- | Tests for Thompson's group F +-- + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances, TypeSynonymInstances #-} +module Tests.Thompson where + +-------------------------------------------------------------------------------- + +import Prelude hiding ( (**) ) +import Control.Monad +import Data.List + +import Math.Combinat.Groups.Thompson.F +import qualified Math.Combinat.Trees.Binary as B + +import Tests.Common + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import System.Random + +import Math.Combinat.Helper + + +-------------------------------------------------------------------------------- +-- * code + +(**) :: TDiag -> TDiag -> TDiag +(**) x y = x `compose` y + +(//) :: TDiag -> TDiag -> TDiag +(//) x y = x `compose` (inverse y) + +growth_n_sphere = [1,4,12,36,108,314,906,2576,7280,20352] :: [Int] +growth_pos_n_sphere = [1,2, 4, 9, 20, 45,101, 227, 510, 1146] :: [Int] + +-------------------------------------------------------------------------------- +-- * instances + +-- | A pair of trees with the same size +data TPair = TPair !T !T deriving (Eq,Show) + +newtype Unreduced = Unreduced TDiag deriving (Eq,Show) + +instance Arbitrary T where + arbitrary = liftM fromBinTree $ myMkSizedGen B.randomBinaryTree + +instance Arbitrary TPair where + arbitrary = myMkSizedGen $ \siz -> runRand $ do + t1 <- rand (B.randomBinaryTree siz) + t2 <- rand (B.randomBinaryTree siz) + return $ TPair (fromBinTree t1) (fromBinTree t2) + +instance Arbitrary TDiag where + arbitrary = do + TPair t1 t2 <- arbitrary + return $ mkTDiag t1 t2 + +instance Arbitrary Unreduced where + arbitrary = do + TPair t1 t2 <- arbitrary + return $ Unreduced $ mkTDiagDontReduce t1 t2 + +-------------------------------------------------------------------------------- +-- * test group + +testgroup_ThompsonF :: Test +testgroup_ThompsonF = testGroup "Thompson's group F" + [ testProperty "identity element" prop_identity + , testProperty "associativity" prop_assoc + , testProperty "standard relations" prop_relations + , testProperty "quotient of positives" prop_quot_positive + , testProperty "telescopic product" prop_telescope + , testProperty "cyclic telescopic product (3)" prop_cyclic_product_3 + , testProperty "cyclic telescopic product (4)" prop_cyclic_product_4 + , testProperty "positive diagrams form a monoid" prop_positive_product + , testProperty "composition commutes with reduction" prop_reduce_composition + , testProperty "inverse commutes with reduction" prop_reduce_inverse + ] + +-------------------------------------------------------------------------------- +-- * properties + +prop_relations :: Bool +prop_relations = and [ rel k n | n<-[1..30] , k<-[0..n-1] ] where + rel k n = (inverse $ xk k) `compose` (xk n) `compose` (xk k) == xk (n+1) + +prop_quot_positive :: TPair -> Bool +prop_quot_positive (TPair t1 t2) = (mkTDiag t1 t2) == (positive t1 // positive t2) + +prop_identity :: TDiag -> Bool +prop_identity x = (x ** identity) == x && (identity ** x) == x + +prop_assoc :: TDiag -> TDiag -> TDiag -> Bool +prop_assoc a b c = (p == q) where + p = compose (compose a b) c + q = compose a (compose b c) + +prop_telescope :: TDiag -> TDiag -> TDiag -> TDiag -> Bool +prop_telescope u v w z = (a `compose` b `compose` c) == (u // z) where + a = u // v + b = v // w + c = w // z + +prop_cyclic_product_3 :: TDiag -> TDiag -> TDiag -> Bool +prop_cyclic_product_3 u v w = (a `compose` b `compose` c) == identity where + a = u // v + b = v // w + c = w // u + +prop_cyclic_product_4 :: TDiag -> TDiag -> TDiag -> TDiag -> Bool +prop_cyclic_product_4 u v w z = (a `compose` b `compose` c `compose` d) == identity where + a = u // v + b = v // w + c = w // z + d = z // u + +prop_positive_product :: T -> T -> Bool +prop_positive_product x y = isPositive (positive x `compose` positive y) + +prop_reduce_composition :: Unreduced -> Unreduced -> Bool +prop_reduce_composition (Unreduced x) (Unreduced y) = lhs == rhs where + lhs = reduce (x `composeDontReduce` y) + rhs = compose (reduce x) (reduce y) + +prop_reduce_inverse :: Unreduced -> Bool +prop_reduce_inverse (Unreduced x) = lhs == rhs where + lhs = reduce (inverse x) + rhs = inverse (reduce x) + +-------------------------------------------------------------------------------- +