diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,5 +1,15 @@ # Change log for the `combinatorial` package +## 0.1 + +* added explicit export lists, + thus hide some helper functions and alternative implementations + +* use alternative implementations in tests + +* `chooseToIndex` -> `chooseRank`, + `chooseFromIndex -> chooseUnrank` + ## 0.0 * Tests: replaced `(==>)` and custom cardinal types by `QC.forAll`. diff --git a/combinatorial.cabal b/combinatorial.cabal --- a/combinatorial.cabal +++ b/combinatorial.cabal @@ -1,5 +1,5 @@ Name: combinatorial -Version: 0.0 +Version: 0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -30,7 +30,7 @@ Changes.md Source-Repository this - Tag: 0.0 + Tag: 0.1 Type: darcs Location: http://hub.darcs.net/thielema/combinatorial/ @@ -62,16 +62,20 @@ Combinatorics.Permutation.WithoutSomeFixpoints Other-Modules: Combinatorics.Utility + Combinatorics.Private PowerSeries Polynomial Test-Suite combinatorial-test Type: exitcode-stdio-1.0 Build-Depends: - combinatorial, QuickCheck >=2.5 && <3.0, + containers, + array, + transformers, utility-ht, base - Main-Is: test/Test.hs + Main-Is: Test.hs + Hs-Source-Dirs: src, test GHC-Options: -Wall Default-Language: Haskell98 diff --git a/src/Combinatorics.hs b/src/Combinatorics.hs --- a/src/Combinatorics.hs +++ b/src/Combinatorics.hs @@ -6,26 +6,17 @@ permute, permuteFast, permuteShare, - permuteMSL, - runPermuteRep, permuteRep, - permuteRepM, choose, - chooseMSL, variateRep, - variateRepMSL, variate, - variateMSL, tuples, - tuplesMSL, - tuplesRec, partitions, rectifications, setPartitions, - chooseFromIndex, - chooseFromIndexList, - chooseFromIndexMaybe, - chooseToIndex, + chooseUnrank, + chooseUnrankMaybe, + chooseRank, factorial, binomial, binomialSeq, @@ -38,30 +29,24 @@ catalanNumbers, derangementNumber, derangementNumbers, - derangementNumbersAlt, - derangementNumbersInclExcl, setPartitionNumbers, surjectiveMappingNumber, surjectiveMappingNumbers, - surjectiveMappingNumbersStirling, fibonacciNumber, fibonacciNumbers, ) where import qualified PowerSeries -import Combinatorics.Utility (scalarProduct, ) +import qualified Combinatorics.Private as Comb import Data.Function.HT (nest, ) import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (mapMaybe, catMaybes, ) import Data.Tuple.HT (mapFst, ) import qualified Data.List.Match as Match -import Data.List.HT (tails, partition, mapAdjacent, removeEach, splitEverywhere, viewL, ) -import Data.List (mapAccumL, intersperse, genericIndex, genericReplicate, genericTake, ) +import Data.List.HT (mapAdjacent, removeEach, ) +import Data.List (genericIndex, ) -import qualified Control.Monad.Trans.Class as MT -import qualified Control.Monad.Trans.State as MS -import Control.Monad (liftM, liftM2, replicateM, forM, guard, ) +import Control.Monad (liftM2, ) {-* Generate compositions from a list of elements. -} @@ -74,10 +59,7 @@ The list is sorted lexicographically. -} permute :: [a] -> [[a]] -permute [] = [[]] -permute x = - concatMap (\(y, ys) -> map (y:) (permute ys)) - (removeEach x) +permute = Comb.permuteRec {- | Generate list of all permutations of the input list. @@ -113,79 +95,13 @@ (mapFst (:perm)) (removeEach todo) -permuteMSL :: [a] -> [[a]] -permuteMSL xs = - flip MS.evalStateT xs $ replicateM (length xs) $ - MS.StateT removeEach - - - -runPermuteRep :: ([(a,Int)] -> [[a]]) -> [(a,Int)] -> [[a]] -runPermuteRep f xs = - let (ps,ns) = partition ((>0) . snd) xs - in if any ((<0) . snd) ns - then [] - else f ps - permuteRep :: [(a,Int)] -> [[a]] -permuteRep = runPermuteRep permuteRepAux - -permuteRepAux :: [(a,Int)] -> [[a]] -permuteRepAux [] = [[]] -permuteRepAux xs = - concatMap (\(ys,(a,n),zs) -> - let m = pred n - in map (a:) (permuteRepAux (ys ++ (m>0, (a, m)) ?: zs))) $ - filter (\(_,(_,n),_) -> n>0) $ - splitEverywhere xs - -permuteRepM :: [(a,Int)] -> [[a]] -permuteRepM = runPermuteRep permuteRepMAux - -permuteRepMAux :: [(a,Int)] -> [[a]] -permuteRepMAux [] = [[]] -permuteRepMAux xs = - do (ys,(a,n),zs) <- splitEverywhere xs - let m = pred n - liftM (a:) - (permuteRepMAux (ys ++ (m>0, (a, m)) ?: zs)) - - -infixr 5 ?: - -(?:) :: (Bool, a) -> [a] -> [a] -(True,a) ?: xs = a:xs -(False,_) ?: xs = xs +permuteRep = Comb.permuteRep choose :: Int -> Int -> [[Bool]] -choose n k = - if k<0 || k>n - then [] - else - if n==0 - then [[]] - else - map (False:) (choose (pred n) k) ++ - map (True:) (choose (pred n) (pred k)) - -chooseMSL :: Int -> Int -> [[Bool]] -chooseMSL n0 k0 = - flip MS.evalStateT k0 $ fmap catMaybes $ sequence $ - intersperse (MS.StateT $ \k -> [(Just False, k), (Just True, pred k)]) $ - flip map [n0,n0-1..0] $ \n -> - MS.gets (\k -> 0<=k && k<=n) >>= guard >> return Nothing - -_chooseMSL :: Int -> Int -> [[Bool]] -_chooseMSL n0 k0 = - flip MS.evalStateT k0 $ do - count <- - forM [n0,n0-1..1] $ \n -> - MS.StateT $ \k -> - guard (0<=k && k<=n) >> [(False, k), (True, pred k)] - MS.gets (0==) >>= guard - return count +choose = Comb.chooseRec {- | @@ -194,10 +110,7 @@ but I like it more than \"k-permutation\". -} variateRep :: Int -> [a] -> [[a]] -variateRep n x = nest n (\y -> concatMap (\z -> map (z:) y) x) [[]] - -variateRepMSL :: Int -> [a] -> [[a]] -variateRepMSL = replicateM +variateRep = Comb.variateRep {- | @@ -206,15 +119,7 @@ @ variate (length xs) xs == permute xs @ -} variate :: Int -> [a] -> [[a]] -variate 0 _ = [[]] -variate n x = - concatMap (\(y, ys) -> map (y:) (variate (n-1) ys)) - (removeEach x) - -variateMSL :: Int -> [a] -> [[a]] -variateMSL n xs = - flip MS.evalStateT xs $ replicateM n $ - MS.StateT removeEach +variate = Comb.variateRec {- | @@ -222,35 +127,7 @@ respecting the order in x and without repetitions. -} tuples :: Int -> [a] -> [[a]] -tuples 0 _ = [[]] -tuples r xs = - concatMap (\(y:ys) -> map (y:) (tuples (r-1) ys)) - (init (tails xs)) - -tuplesMSL :: Int -> [a] -> [[a]] -tuplesMSL n xs = - flip MS.evalStateT xs $ replicateM n $ - MS.StateT $ mapMaybe viewL . tails - -_tuplesMSL :: Int -> [a] -> [[a]] -_tuplesMSL n xs = - flip MS.evalStateT xs $ - replicateM n $ do - yl <- MS.get - (y:ys) <- MT.lift $ tails yl - MS.put ys - return y - -tuplesRec :: Int -> [a] -> [[a]] -tuplesRec k xt = - if k<0 - then [] - else - case xt of - [] -> guard (k==0) >> [[]] - x:xs -> - tuplesRec k xs ++ - map (x:) (tuplesRec (pred k) xs) +tuples = Comb.tuplesRec partitions :: [a] -> [([a],[a])] @@ -316,49 +193,27 @@ return ((x:choosen) : part) -{-* Compute the number of certain compositions from a number of elements. -} +{-* Rank and unrank combinatorial objects. -} {- | -@chooseFromIndex n k i == choose n k !! i@ +@chooseUnrank n k i == choose n k !! i@ -} -chooseFromIndex :: Integral a => a -> a -> a -> [Bool] -chooseFromIndex n 0 _ = genericReplicate n False -chooseFromIndex n k i = - let n1 = pred n - p = binomial n1 k - b = i>=p - in b : - if b - then chooseFromIndex n1 (pred k) (i-p) - else chooseFromIndex n1 k i - -chooseFromIndexList :: Integral a => a -> a -> a -> [Bool] -chooseFromIndexList n k0 i0 = --- (\((0,0), xs) -> xs) $ - snd $ - mapAccumL - (\(k,i) bins -> - let p = genericIndex (bins++[0]) k - b = i>=p - in (if b - then (pred k, i-p) - else (k, i), - b)) - (k0,i0) $ - reverse $ - genericTake n binomials - +chooseUnrank :: Integral a => a -> a -> a -> [Bool] +chooseUnrank = Comb.chooseUnrankRec -chooseFromIndexMaybe :: Int -> Int -> Int -> Maybe [Bool] -chooseFromIndexMaybe n k i = +chooseUnrankMaybe :: Int -> Int -> Int -> Maybe [Bool] +chooseUnrankMaybe n k i = toMaybe (0 <= i && i < binomial n k) - (chooseFromIndex n k i) --- error ("chooseFromIndex: out of range " ++ show (n, k, i)) + (chooseUnrank n k i) +-- error ("chooseUnrank: out of range " ++ show (n, k, i)) -chooseToIndex :: Integral a => [Bool] -> (a, a, a) -chooseToIndex = +{- | + +-} +chooseRank :: Integral a => [Bool] -> (a, a, a) +chooseRank = foldl (\(n,k0,i0) (bins,b) -> let (k1,i1) = if b then (succ k0, i0 + genericIndex (bins++[0]) k1) else (k0,i0) @@ -375,22 +230,10 @@ {-| Pascal's triangle containing the binomial coefficients. -} binomial :: Integral a => a -> a -> a -binomial n k = - let bino n' k' = - if k'<0 - then 0 - else genericIndex (binomialSeq n') k' - in if n<2*k - then bino n (n-k) - else bino n k +binomial = Comb.binomial binomialSeq :: Integral a => a -> [a] -binomialSeq n = - {- this does not work because the corresponding numbers are not always divisible - product (zipWith div [n', pred n' ..] [1..k']) - -} - scanl (\acc (num,den) -> div (acc*num) den) 1 - (zip [n, pred n ..] [1..n]) +binomialSeq = Comb.binomialSeq binomialGen :: (Integral a, Fractional b) => b -> a -> b @@ -410,7 +253,7 @@ {-* Generate complete lists of factorial numbers. -} factorials :: Num a => [a] -factorials = scanl (*) 1 (iterate (+1) 1) +factorials = Comb.factorials {-| Pascal's triangle containing the binomial coefficients. @@ -419,9 +262,7 @@ or even particular elements. -} binomials :: Num a => [[a]] -binomials = - let conv11 x = zipWith (+) ([0]++x) (x++[0]) - in iterate conv11 [1] +binomials = Comb.binomials {- | @@ -455,28 +296,7 @@ -} derangementNumbers :: Num a => [a] -derangementNumbers = - -- OEIS-A166: a(n) = n·a(n-1)+(-1)^n - -- y(x) = 1/(1+x) + x · (t -> y(t)·t)'(x) - let xs = PowerSeries.add - (cycle [1,-1]) - (0 : PowerSeries.differentiate (0 : xs)) - in xs - -derangementNumbersAlt :: Num a => [a] -derangementNumbersAlt = - -- OEIS-A166: a(n) = (n-1)·(a(n-1)+a(n-2)) - -- y(x) = 1 + x^2 · (t -> y(t)·(1+t))'(x) - let xs = - 1 : 0 : - PowerSeries.differentiate - (PowerSeries.add xs (0 : xs)) - in xs - -derangementNumbersInclExcl :: Num a => [a] -derangementNumbersInclExcl = - let xs = zipWith (-) factorials (map (scalarProduct xs . init) binomials) - in xs +derangementNumbers = Comb.derangementNumbersPS0 -- generation of all possibilities and computation of their number should be in different modules @@ -486,9 +306,7 @@ Known as Stirling numbers . -} setPartitionNumbers :: Num a => [[a]] -setPartitionNumbers = - -- s_{n+1,k} = s_{n,k-1} + k·s_{n,k} - iterate (\x -> 0 : PowerSeries.add x (PowerSeries.differentiate x)) [1] +setPartitionNumbers = Comb.setPartitionNumbers {- | @@ -505,14 +323,7 @@ (binomialSeq k) surjectiveMappingNumbers :: Num a => [[a]] -surjectiveMappingNumbers = - iterate - (\x -> 0 : PowerSeries.differentiate - (PowerSeries.add x (0 : x))) [1] - -surjectiveMappingNumbersStirling :: Num a => [[a]] -surjectiveMappingNumbersStirling = - map (zipWith (*) factorials) setPartitionNumbers +surjectiveMappingNumbers = Comb.surjectiveMappingNumbersPS {- | diff --git a/src/Combinatorics/CardPairs.hs b/src/Combinatorics/CardPairs.hs --- a/src/Combinatorics/CardPairs.hs +++ b/src/Combinatorics/CardPairs.hs @@ -2,7 +2,29 @@ Compute how often it happens that a Queen and a King are adjacent in a randomly ordered card set. -} -module Combinatorics.CardPairs where +module Combinatorics.CardPairs ( + -- * general + Card(..), CardCount(..), + charFromCard, + allPossibilities, + numberOfAllPossibilities, + possibilitiesCardsNaive, + possibilitiesCardsDynamic, + possibilitiesCardsBorderNaive, + possibilitiesCardsBorderDynamic, + possibilitiesCardsBorder2Dynamic, + -- * examples + cardSetSizeSkat, numberOfPossibilitiesSkat, probabilitySkat, + cardSetSizeRummy, numberOfPossibilitiesRummy, probabilityRummy, + cardSetSizeRummyJK, numberOfPossibilitiesRummyJK, probabilityRummyJK, + -- * tests + testCardsBorderDynamic, + exampleOutput, + adjacentCouplesSmall, + allPossibilitiesSmall, + allPossibilitiesMedium, + allPossibilitiesSkat, + ) where import qualified Combinatorics as Comb diff --git a/src/Combinatorics/MaxNim.hs b/src/Combinatorics/MaxNim.hs --- a/src/Combinatorics/MaxNim.hs +++ b/src/Combinatorics/MaxNim.hs @@ -9,7 +9,7 @@ E-Mail by Daniel Beer from 2011-10-24. -} -module Combinatorics.MaxNim where +module Combinatorics.MaxNim (numberOfPossibilities) where import qualified Data.Set as Set diff --git a/src/Combinatorics/PaperStripGame.hs b/src/Combinatorics/PaperStripGame.hs --- a/src/Combinatorics/PaperStripGame.hs +++ b/src/Combinatorics/PaperStripGame.hs @@ -2,7 +2,11 @@ Number of possible games as described in . -} -module Combinatorics.PaperStripGame where +module Combinatorics.PaperStripGame ( + numbersOfGames, + numbersOfGamesSeries, + treeOfGames, + ) where import qualified Combinatorics as Combi import qualified PowerSeries as PS @@ -17,8 +21,8 @@ representation: store the original position of every box -} -cutEverywhere0 :: [Int] -> [[Int]] -cutEverywhere0 xs = do +_cutEverywhere0 :: [Int] -> [[Int]] +_cutEverywhere0 xs = do (ys, z0:z1:zs) <- zip (inits xs) (tails xs) guard $ succ z0 == z1 return $ ys++zs diff --git a/src/Combinatorics/Permutation/WithoutSomeFixpoints.hs b/src/Combinatorics/Permutation/WithoutSomeFixpoints.hs --- a/src/Combinatorics/Permutation/WithoutSomeFixpoints.hs +++ b/src/Combinatorics/Permutation/WithoutSomeFixpoints.hs @@ -4,8 +4,10 @@ {- | @enumerate n xs@ list all permutations of @xs@ -where the first @n@ elements do not keep there position +where the first @n@ elements do not keep their position (i.e. are no fixpoints). + +This is a generalization of derangement. Naive but comprehensible implementation. -} diff --git a/src/Combinatorics/Private.hs b/src/Combinatorics/Private.hs new file mode 100644 --- /dev/null +++ b/src/Combinatorics/Private.hs @@ -0,0 +1,254 @@ +module Combinatorics.Private where + +import qualified PowerSeries +import Combinatorics.Utility (scalarProduct, ) + +import Data.Function.HT (nest, ) +import Data.Maybe (mapMaybe, catMaybes, ) +import Data.List.HT (tails, partition, removeEach, splitEverywhere, viewL, ) +import Data.List + (mapAccumL, intersperse, genericIndex, genericReplicate, genericTake, ) + +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.HT as Monad +import Control.Monad (MonadPlus, liftM, forM, guard, ) + + +replicateM :: (MonadPlus m) => Int -> m a -> m [a] +replicateM n m = guard (n>=0) >> Monad.replicate n m + + +permuteRec :: [a] -> [[a]] +permuteRec = + let go [] = [[]] + go x = concatMap (\(y, ys) -> map (y:) (go ys)) (removeEach x) + in go + +permuteMSL :: [a] -> [[a]] +permuteMSL xs = variateMSL (length xs) xs + + + +runPermuteRep :: ([(a,Int)] -> [[a]]) -> [(a,Int)] -> [[a]] +runPermuteRep f xs = + let (ps,ns) = partition ((>0) . snd) xs + in if any ((<0) . snd) ns + then [] + else f ps + +permuteRep :: [(a,Int)] -> [[a]] +permuteRep = + let go [] = [[]] + go xs = + concatMap (\(ys,(a,n),zs) -> + let m = pred n + in map (a:) (go (ys ++ (m>0, (a, m)) ?: zs))) $ + filter (\(_,(_,n),_) -> n>0) $ + splitEverywhere xs + in runPermuteRep go + +permuteRepM :: [(a,Int)] -> [[a]] +permuteRepM = + let go [] = [[]] + go xs = + do (ys,(a,n),zs) <- splitEverywhere xs + let m = pred n + liftM (a:) (go (ys ++ (m>0, (a, m)) ?: zs)) + in runPermuteRep go + + +infixr 5 ?: + +(?:) :: (Bool, a) -> [a] -> [a] +(True,a) ?: xs = a:xs +(False,_) ?: xs = xs + + +chooseRec :: Int -> Int -> [[Bool]] +chooseRec = + let go n k = + if k<0 || k>n + then [] + else + if n==0 + then [[]] + else + map (False:) (go (pred n) k) ++ + map (True:) (go (pred n) (pred k)) + in go + +chooseMSL :: Int -> Int -> [[Bool]] +chooseMSL n0 k0 = + flip MS.evalStateT k0 $ fmap catMaybes $ sequence $ + intersperse (MS.StateT $ \k -> [(Just False, k), (Just True, pred k)]) $ + flip map [n0,n0-1..0] $ \n -> + MS.gets (\k -> 0<=k && k<=n) >>= guard >> return Nothing + +chooseMSL0 :: Int -> Int -> [[Bool]] +chooseMSL0 n0 k0 = + flip MS.evalStateT k0 $ do + count <- + forM [n0,n0-1..1] $ \n -> + MS.StateT $ \k -> + guard (0<=k && k<=n) >> [(False, k), (True, pred k)] + MS.gets (0==) >>= guard + return count + + +variateRep :: Int -> [a] -> [[a]] +variateRep n x = + if n<0 then [] else nest n (\y -> concatMap (\z -> map (z:) y) x) [[]] + +variateRepM :: Int -> [a] -> [[a]] +variateRepM = replicateM + + +variateRec :: Int -> [a] -> [[a]] +variateRec = + let go n = + case compare n 0 of + LT -> const [] + EQ -> const [[]] + GT -> concatMap (\(y, ys) -> map (y:) (go (n-1) ys)) . removeEach + in go + +variateMSL :: Int -> [a] -> [[a]] +variateMSL n = MS.evalStateT $ replicateM n $ MS.StateT removeEach + + +tuplesRec :: Int -> [a] -> [[a]] +tuplesRec = + let go r = + case compare r 0 of + LT -> const [] + EQ -> const [[]] + GT -> concatMap (\(y:ys) -> map (y:) (go (r-1) ys)) . init . tails + in go + +tuplesRec0 :: Int -> [a] -> [[a]] +tuplesRec0 = + let go k = + if k<0 + then const [] + else + \ xt -> + case xt of + [] -> guard (k==0) >> [[]] + x:xs -> map (x:) (go (pred k) xs) ++ go k xs + in go + +tuplesMSL :: Int -> [a] -> [[a]] +tuplesMSL n xs = + flip MS.evalStateT xs $ replicateM n $ + MS.StateT $ mapMaybe viewL . tails + +tuplesMSL0 :: Int -> [a] -> [[a]] +tuplesMSL0 n xs = + flip MS.evalStateT xs $ + replicateM n $ do + yl <- MS.get + (y:ys) <- MT.lift $ tails yl + MS.put ys + return y + + +chooseUnrankRec :: Integral a => a -> a -> a -> [Bool] +chooseUnrankRec = + let go n 0 _ = genericReplicate n False + go n k i = + let n1 = pred n + p = binomial n1 k + b = i>=p + (k1,i1) = if b then (pred k, i-p) else (k,i) + in b : go n1 k1 i1 + in go + +chooseUnrankList :: Integral a => a -> a -> a -> [Bool] +chooseUnrankList n k0 i0 = +-- (\((0,0), xs) -> xs) $ + snd $ + mapAccumL + (\(k,i) bins -> + let p = genericIndex (bins++[0]) k + b = i>=p + in (if b + then (pred k, i-p) + else (k, i), + b)) + (k0,i0) $ + reverse $ + genericTake n binomials + + +binomial :: Integral a => a -> a -> a +binomial n k = + let bino n' k' = + if k'<0 + then 0 + else genericIndex (binomialSeq n') k' + in if n<2*k + then bino n (n-k) + else bino n k + +binomialSeq :: Integral a => a -> [a] +binomialSeq n = + {- this does not work because the corresponding numbers are not always divisible + product (zipWith div [n', pred n' ..] [1..k']) + -} + scanl (\acc (num,den) -> div (acc*num) den) 1 + (zip [n, pred n ..] [1..n]) + + +factorials :: Num a => [a] +factorials = scanl (*) 1 (iterate (+1) 1) + +{-| +Pascal's triangle containing the binomial coefficients. +Only efficient if a prefix of all rows is required. +It is not efficient for picking particular rows +or even particular elements. +-} +binomials :: Num a => [[a]] +binomials = + let conv11 x = zipWith (+) ([0]++x) (x++[0]) + in iterate conv11 [1] + + +derangementNumbersPS0 :: Num a => [a] +derangementNumbersPS0 = + -- OEIS-A166: a(n) = n·a(n-1)+(-1)^n + -- y(x) = 1/(1+x) + x · (t -> y(t)·t)'(x) + let xs = PowerSeries.add + (cycle [1,-1]) + (0 : PowerSeries.differentiate (0 : xs)) + in xs + +derangementNumbersPS1 :: Num a => [a] +derangementNumbersPS1 = + -- OEIS-A166: a(n) = (n-1)·(a(n-1)+a(n-2)) + -- y(x) = 1 + x^2 · (t -> y(t)·(1+t))'(x) + let xs = 1 : 0 : PowerSeries.differentiate (PowerSeries.add xs (0 : xs)) + in xs + +derangementNumbersInclExcl :: Num a => [a] +derangementNumbersInclExcl = + let xs = zipWith (-) factorials (map (scalarProduct xs . init) binomials) + in xs + + +setPartitionNumbers :: Num a => [[a]] +setPartitionNumbers = + -- s_{n+1,k} = s_{n,k-1} + k·s_{n,k} + iterate (\x -> 0 : PowerSeries.add x (PowerSeries.differentiate x)) [1] + + +surjectiveMappingNumbersPS :: Num a => [[a]] +surjectiveMappingNumbersPS = + iterate + (\x -> 0 : PowerSeries.differentiate (PowerSeries.add x (0 : x))) + [1] + +surjectiveMappingNumbersStirling :: Num a => [[a]] +surjectiveMappingNumbersStirling = + map (zipWith (*) factorials) setPartitionNumbers diff --git a/src/Combinatorics/TreeDepth.hs b/src/Combinatorics/TreeDepth.hs --- a/src/Combinatorics/TreeDepth.hs +++ b/src/Combinatorics/TreeDepth.hs @@ -1,4 +1,10 @@ -module Combinatorics.TreeDepth where +module Combinatorics.TreeDepth ( + treeDepth, + treeDepthSeq, + nodeDepth, + nodeDegreeProb, + nodeDegreeExpect, + ) where {- Date: Mon, 18 Apr 2005 18:00:22 +0200 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -2,19 +2,23 @@ import qualified Combinatorics.Permutation.WithoutSomeFixpoints as PermWOFP import qualified Combinatorics.Mastermind as Mastermind +import qualified Combinatorics.CardPairs as CardPairs import qualified Combinatorics.Partitions as Parts import qualified Combinatorics.BellNumbers as Bell +import qualified Combinatorics.Private as CombPriv import qualified Combinatorics as Comb import qualified Test.QuickCheck as QC import Test.QuickCheck (Testable, quickCheck, ) -import Control.Monad (liftM2, replicateM, ) +import Control.Monad (liftM2, liftM3, ) import Control.Applicative ((<$>), ) import qualified Data.List.Match as Match import qualified Data.List.Key as Key import qualified Data.List as List +import qualified Data.Set as Set +import Data.Array ((!), ) import Data.Tuple.HT (uncurry3, ) import Data.List.HT (allEqual, isAscending, ) import Data.List (sort, nub, ) @@ -36,21 +40,28 @@ Comb.permuteShare : [] +permuteAlt :: Eq a => [a] -> Bool +permuteAlt xs = CombPriv.permuteRec xs == CombPriv.permuteMSL xs -genPermuteRep :: QC.Gen [(Char, Int)] -genPermuteRep = do - xns <- QC.listOf $ liftM2 (,) QC.arbitrary $ QC.choose (0,10) - return $ Match.take (takeWhile (<=10) $ scanl1 (+) $ map snd xns) xns +genPermuteRep :: Int -> QC.Gen [(Char, Int)] +genPermuteRep n = do + xns <- QC.listOf $ liftM2 (,) QC.arbitrary $ QC.choose (0,n) + return $ Match.take (takeWhile (<=n) $ scanl1 (+) $ map snd xns) xns + permuteRepM :: Eq a => [(a, Int)] -> Bool -permuteRepM xs = Comb.permuteRep xs == Comb.permuteRepM xs +permuteRepM xs = CombPriv.permuteRep xs == CombPriv.permuteRepM xs permuteRepNub :: Eq a => [(a, Int)] -> Bool -permuteRepNub xs' = - let xs = Key.nub fst xs' - perms = Comb.permuteRep xs +permuteRepNub xs = + let perms = Comb.permuteRep $ Key.nub fst xs in perms == nub perms +permuteRepNubBig :: Ord a => [(a, Int)] -> Bool +permuteRepNubBig xs = + let perms = Comb.permuteRep $ Key.nub fst xs + in List.sort perms == Set.toList (Set.fromList perms) + permuteRepMonotony :: Ord a => [(a, Int)] -> Bool permuteRepMonotony = isAscending . Comb.permuteRep . Key.nub fst . sort @@ -65,6 +76,20 @@ (Comb.choose n k) +genChoose :: QC.Gen (Int, Int) +genChoose = do + n <- QC.choose (0,15) + k <- QC.choose (-2,n) + return (n,k) + +choose :: Int -> Int -> Bool +choose n k = + allEqual $ + CombPriv.chooseRec n k : + CombPriv.chooseMSL n k : + CombPriv.chooseMSL0 n k : + [] + genChooseIndex :: QC.Gen (Integer, Integer, Integer) genChooseIndex = do n <- QC.choose (0,25) @@ -72,23 +97,23 @@ i <- QC.choose (0, Comb.binomial n k - 1) return (n,k,i) -chooseFromIndex :: Integer -> Integer -> Integer -> Bool -chooseFromIndex n k i = - Comb.chooseFromIndex n k i == Comb.chooseFromIndexList n k i +chooseUnrank :: Integer -> Integer -> Integer -> Bool +chooseUnrank n k i = + CombPriv.chooseUnrankRec n k i == CombPriv.chooseUnrankList n k i -chooseFromIndexSequence :: Int -> Int -> Bool -chooseFromIndexSequence n k = - map (Comb.chooseFromIndex n k) [0 .. Comb.binomial n k - 1] +chooseUnrankSequence :: Int -> Int -> Bool +chooseUnrankSequence n k = + map (Comb.chooseUnrank n k) [0 .. Comb.binomial n k - 1] == Comb.choose n k -chooseToFromIndex :: Integer -> Integer -> Integer -> Bool -chooseToFromIndex n k i = - Comb.chooseToIndex (Comb.chooseFromIndex n k i) == (n, k, i) +chooseRankUnrank :: Integer -> Integer -> Integer -> Bool +chooseRankUnrank n k i = + Comb.chooseRank (Comb.chooseUnrank n k i) == (n, k, i) -chooseFromToIndex :: [Bool] -> Bool -chooseFromToIndex bs = - uncurry3 Comb.chooseFromIndex - (Comb.chooseToIndex bs :: (Integer, Integer, Integer)) +chooseUnrankRank :: [Bool] -> Bool +chooseUnrankRank bs = + uncurry3 Comb.chooseUnrank + (Comb.chooseRank bs :: (Integer, Integer, Integer)) == bs @@ -96,10 +121,14 @@ genVariate :: QC.Gen [Char] genVariate = take 7 <$> QC.arbitrary -variateRepMonad :: Eq a => Int -> [a] -> Bool -variateRepMonad n xs = - Comb.variateRep n xs == replicateM n xs +variate :: Eq a => Int -> [a] -> Bool +variate n xs = + CombPriv.variateRec n xs == CombPriv.variateMSL n xs +variateRep :: Eq a => Int -> [a] -> Bool +variateRep n xs = + CombPriv.variateRep n xs == CombPriv.variateRepM n xs + variatePermute :: Eq a => [a] -> Bool variatePermute xs = Comb.variate (length xs) xs == Comb.permute xs @@ -108,6 +137,24 @@ variatePermuteClip n xs = equating (take n) (Comb.variate (length xs) xs) (Comb.permute xs) + + +genTuples :: QC.Gen (Int, [Char]) +genTuples = do + xs <- take 16 <$> QC.arbitrary + n <- QC.choose (-1, length xs + 1) + return (n,xs) + +tuples :: Eq a => Int -> [a] -> Bool +tuples n xs = + allEqual $ + CombPriv.tuplesRec n xs : + CombPriv.tuplesRec0 n xs : + CombPriv.tuplesMSL n xs : + CombPriv.tuplesMSL0 n xs : + [] + + _setPartitionsMonotony :: Ord a => Int -> [a] -> Bool _setPartitionsMonotony k = isAscending . Comb.setPartitions k . nub . sort @@ -173,8 +220,8 @@ surjectiveMappingNumbers :: Int -> Bool surjectiveMappingNumbers n = allEqual $ map (take n) $ ( - Comb.surjectiveMappingNumbers : - Comb.surjectiveMappingNumbersStirling : + CombPriv.surjectiveMappingNumbersPS : + CombPriv.surjectiveMappingNumbersStirling : [] :: [[[Integer]]]) @@ -204,9 +251,9 @@ derangementNumbers :: Int -> Bool derangementNumbers n = allEqual $ map (take n) $ ( - Comb.derangementNumbers : - Comb.derangementNumbersAlt : - Comb.derangementNumbersInclExcl : + CombPriv.derangementNumbersPS0 : + CombPriv.derangementNumbersPS1 : + CombPriv.derangementNumbersInclExcl : [] :: [[Integer]]) @@ -236,6 +283,24 @@ Comb.derangementNumber (toInteger k) == PermWOFP.numbers !! k !! k +cardPairs1 :: Bool +cardPairs1 = + case CardPairs.testCardsBorderDynamic of + (x,y,z) -> x == y && y == z + +genCardCount :: QC.Gen (CardPairs.CardCount Int) +genCardCount = + liftM3 CardPairs.CardCount + (QC.choose (0,5)) (QC.choose (0,5)) (QC.choose (0,5)) + +cardPairs :: CardPairs.CardCount Int -> Bool +cardPairs cc = + let x = CardPairs.possibilitiesCardsBorderNaive cc + y = CardPairs.possibilitiesCardsBorderDynamic cc ! cc + z = CardPairs.possibilitiesCardsBorder2Dynamic cc ! cc + in x == y && y == z + + genMastermindDistinct :: QC.Gen (Int, Int, Int, Int) genMastermindDistinct = do n <- QC.choose (0,12) @@ -265,33 +330,43 @@ (QC.forAll (take 6 <$> QC.arbitrary) permuteSum) : testUnit "permutations" (QC.forAll (take 6 <$> QC.arbitrary :: QC.Gen [Int]) permute) : + testUnit "permuteAlt" + (QC.forAll (take 6 <$> QC.arbitrary :: QC.Gen [Int]) permuteAlt) : testUnit "permuteRepM" - (QC.forAll genPermuteRep permuteRepM) : + (QC.forAll (genPermuteRep 10) permuteRepM) : testUnit "permuteRepNub" - (QC.forAll genPermuteRep permuteRepNub) : + (QC.forAll (genPermuteRep 7) permuteRepNub) : + testUnit "permuteRepNubBig" + (QC.forAll (genPermuteRep 10) permuteRepNubBig) : testUnit "permuteRepMonotony" - (QC.forAll genPermuteRep permuteRepMonotony) : + (QC.forAll (genPermuteRep 10) permuteRepMonotony) : testUnit "permuteRepChoose" (QC.forAll (QC.choose (0,10)) permuteRepChoose) : + testUnit "choose" + (QC.forAll genChoose (uncurry choose)) : testUnit "chooseLength" (QC.forAll (QC.choose (0,10)) chooseLength) : - testUnit "chooseFromIndex" - (QC.forAll genChooseIndex $ uncurry3 chooseFromIndex) : - testUnit "chooseFromIndexSequence" - (QC.forAll (QC.choose (0,10)) chooseFromIndexSequence) : - testUnit "chooseToFromIndex" - (QC.forAll genChooseIndex $ uncurry3 chooseToFromIndex) : - testUnit "chooseFromToIndex" chooseFromToIndex : + testUnit "chooseUnrank" + (QC.forAll genChooseIndex $ uncurry3 chooseUnrank) : + testUnit "chooseUnrankSequence" + (QC.forAll (QC.choose (0,10)) chooseUnrankSequence) : + testUnit "chooseRankUnrank" + (QC.forAll genChooseIndex $ uncurry3 chooseRankUnrank) : + testUnit "chooseUnrankRank" chooseUnrankRank : + testUnit "variation without repetitions with list monad" + (QC.forAll (QC.choose (-1,7)) $ \n -> + QC.forAll genVariate $ variate n) : testUnit "variation with repetitions with list monad" - (QC.forAll (QC.choose (0,6)) $ \n -> - QC.forAll genVariate $ variateRepMonad n) : + (QC.forAll (QC.choose (-1,7)) $ \n -> + QC.forAll genVariate $ variateRep n) : testUnit "variatePermute" (QC.forAll genVariate variatePermute) : + testUnit "tuples" (QC.forAll genTuples (uncurry tuples)) : testUnit "permute expressed by variate" (variatePermuteClip 1000 :: String -> Bool) : testUnit "binomial vs. choose" (QC.forAll (QC.choose (0,12)) binomialChoose) : testUnit "multinomial vs. permutation with repetitions" - (QC.forAll genPermuteRep multinomialPermuteRep) : + (QC.forAll (genPermuteRep 10) multinomialPermuteRep) : testUnit "multinomial commutative" (QC.forAll (QC.listOf $ QC.choose (0,300)) multinomialCommutative) : testUnit "factorial vs. permute" @@ -335,6 +410,8 @@ (QC.forAll (QC.choose (1,10)) $ \k -> QC.forAll (QC.choose (0,50)) $ \n -> Parts.propPartitions k n) : testUnit "partitions count" (Parts.propNumPartitions 30) : + testUnit "card pairs" cardPairs1 : + testUnit "card pairs many" (QC.forAll genCardCount cardPairs) : testUnit "mastermind with distinct symbols" (QC.forAll genMastermindDistinct $ \(n,k,b,w) -> mastermindDistinct n k b w) :