combinat 0.2 → 0.2.1

raw patch · 5 files changed

+272/−24 lines, 5 filesdep +QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• LICENSE +10/−10
• Math/Combinat.hs +3/−0
• Math/Combinat/Helper.hs +18/−0
• Math/Combinat/Permutations.hs +228/−11
• combinat.cabal +13/−3

@@ -1,4 +1,4 @@-Copyright (c) 2008, Balazs Komuves+Copyright (c) 2008-2009, Balazs Komuves All rights reserved.  Redistribution and use in source and binary forms, with or without@@ -15,15 +15,15 @@ may be used to endorse or promote products derived from this software without specific prior written permission.  -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 

@@ -33,6 +33,8 @@   , module Math.Combinat.Permutations   , module Math.Combinat.Tableaux   , module Math.Combinat.Trees+  , binomial+  , factorial   ) where  import Math.Combinat.Sets@@ -43,3 +45,4 @@ import Math.Combinat.Tableaux import Math.Combinat.Trees +import Math.Combinat.Helper ( binomial , factorial )

@@ -1,6 +1,7 @@  module Math.Combinat.Helper where +import Control.Monad import Debug.Trace  debug :: Show a => a -> b -> b@@ -69,4 +70,21 @@ unfoldEither f y = case f y of   Left z -> (z,[])   Right (y,x) -> let (z,xs) = unfoldEither f y in (z,x:xs)+  +unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a]+unfoldM f y = do+  (x,m) <- f y+  case m of+    Nothing -> return [x]+    Just y' -> do+      xs <- unfoldM f y'+      return (x:xs)++mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])+mapAccumM _ s [] = return (s, [])+mapAccumM f s (x:xs) = do+  (s1,y) <- f s x+  (s2,ys) <- mapAccumM f s1 xs+  return (s2, y:ys)+   

@@ -3,15 +3,26 @@ --   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B. -- {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module Math.Combinat.Permutations    ( -- * Types     Permutation+  , DisjointCycles   , fromPermutation+  , permutationArray   , toPermutationUnsafe   , isPermutation   , toPermutation   , permutationSize+    -- * Disjoint cycles+  , fromDisjointCycles+  , disjointCyclesUnsafe+  , permutationToDisjointCycles+  , disjointCyclesToPermutation+  , isEvenPermutation+  , isOddPermutation+  , signOfPermutation+  , isCyclicPermutation     -- * Permutation groups   , permute   , permuteList@@ -48,20 +59,25 @@  import System.Random --------------------------------------------------------+#ifdef QUICKCHECK+import Test.QuickCheck+#endif++-------------------------------------------------------------------------------- -- * Types  -- | Standard notation for permutations. Internally it is an array of the integers @[1..n]@.  newtype Permutation = Permutation (Array Int Int) deriving (Eq,Ord,Show,Read) -{---- | Disjoint cycle notation for permutations-newtype DisjCycles  = DisjCycles [[Int]] deriving (Eq,Ord,Show,Read)--}+-- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@.+newtype DisjointCycles = DisjointCycles [[Int]] deriving (Eq,Ord,Show,Read)  fromPermutation :: Permutation -> [Int] fromPermutation (Permutation ar) = elems ar +permutationArray :: Permutation -> Array Int Int+permutationArray (Permutation ar) = ar+ -- | Assumes that the input is a permutation of the numbers @[1..n]@. toPermutationUnsafe :: [Int] -> Permutation toPermutationUnsafe xs = Permutation perm where@@ -87,7 +103,114 @@ permutationSize :: Permutation -> Int permutationSize (Permutation ar) = snd $ bounds ar --------------------------------------------------------+--------------------------------------------------------------------------------+-- * Disjoint cycles++fromDisjointCycles :: DisjointCycles -> [[Int]]+fromDisjointCycles (DisjointCycles cycles) = cycles++disjointCyclesUnsafe :: [[Int]] -> DisjointCycles +disjointCyclesUnsafe = DisjointCycles+  +disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation+disjointCyclesToPermutation n (DisjointCycles cycles) = Permutation perm where+  pairs :: [Int] -> [(Int,Int)]+  pairs xs@(x:_) = worker (xs++[x]) where+    worker (x:xs@(y:_)) = (x,y):worker xs+    worker _ = [] +  perm = runST $ do+    ar <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray ar i i +    forM_ cycles $ \cyc -> forM_ (pairs cyc) $ \(i,j) -> writeArray ar i j+    freeze ar+  +-- | This is compatible with Maple's @convert(perm,\'disjcyc\')@.  +permutationToDisjointCycles :: Permutation -> DisjointCycles+permutationToDisjointCycles (Permutation perm) = res where++  (1,n) = bounds perm++  -- we don't want trivial cycles+  f :: [Int] -> Bool+  f [_] = False+  f _ = True+  +  res = runST $ do+    tag <- newArray (1,n) False +    cycles <- unfoldM (step tag) 1 +    return (DisjointCycles $ filter f cycles)+    +  step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int)+  step tag k = do+    cyc <- worker tag k k [k] +    m <- next tag (k+1)+    return (reverse cyc,m)+    +  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)+  next tag k = if k > n+    then return Nothing+    else readArray tag k >>= \b -> if b +      then next tag (k+1)  +      else return (Just k)+       +  worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]+  worker tag k l cyc = do+    writeArray tag l True+    let m = perm ! l+    if m == k +      then return cyc+      else worker tag k m (m:cyc)      ++isEvenPermutation :: Permutation -> Bool+isEvenPermutation (Permutation perm) = res where++  (1,n) = bounds perm+  res = runST $ do+    tag <- newArray (1,n) False +    cycles <- unfoldM (step tag) 1 +    return $ even (sum cycles)+    +  step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int)+  step tag k = do+    cyclen <- worker tag k k 0+    m <- next tag (k+1)+    return (cyclen,m)+    +  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)+  next tag k = if k > n+    then return Nothing+    else readArray tag k >>= \b -> if b +      then next tag (k+1)  +      else return (Just k)+      +  worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int+  worker tag k l cyclen = do+    writeArray tag l True+    let m = perm ! l+    if m == k +      then return cyclen+      else worker tag k m (1+cyclen)      ++isOddPermutation :: Permutation -> Bool+isOddPermutation = not . isEvenPermutation++-- | Plus 1 or minus 1.+signOfPermutation :: Num a => Permutation -> a+signOfPermutation perm = case isEvenPermutation perm of+  True  ->   1+  False -> (-1)+  +isCyclicPermutation :: Permutation -> Bool+isCyclicPermutation perm = +  case cycles of+    []    -> True+    [cyc] -> (length cyc == n)+    _     -> False+  where +    n = permutationSize perm+    DisjointCycles cycles = permutationToDisjointCycles perm+   +-------------------------------------------------------------------------------- -- * Permutation groups      -- | Action of a permutation on a set. If our permutation is @@ -140,7 +263,7 @@     result = array (1,n) $ map swap $ assocs perm1     (_,n) = bounds perm1 --------------------------------------------------------+-------------------------------------------------------------------------------- -- * Permutations of distinct elements  -- | A synonym for 'permutationsNaive'@@ -167,7 +290,7 @@ countPermutations :: Int -> Integer countPermutations = factorial --------------------------------------------------------+-------------------------------------------------------------------------------- -- * Random permutations  -- | A synonym for 'randomPermutationDurstenfeld'.@@ -217,7 +340,7 @@           writeArray ar k z         worker (n-1) (m-1) rnd' ar  --------------------------------------------------------+-------------------------------------------------------------------------------- -- * Permutations of a multiset  -- | Generates all permutations of a multiset.  @@ -257,4 +380,98 @@     else reverse (x:us)  ++ reverse (u:yys) ++ xs   inc _ _ ( [] , _ ) = error "permute: should not happen"       --------------------------------------------------------+--------------------------------------------------------------------------------++#ifdef QUICKCHECK++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++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++prop_disjcyc1 perm = ( perm == disjointCyclesToPermutation n (permutationToDisjointCycles perm) )+  where n = permutationSize perm+prop_disjcyc2 k dcyc = ( dcyc == permutationToDisjointCycles (disjointCyclesToPermutation n dcyc) )+  where +    n = fromNat k + m +    m = case fromDisjointCycles dcyc of+      [] -> 1+      xxs -> maximum (concat xxs)++prop_randCyclic cycl = ( isCyclicPermutation (fromCyclic cycl) )++prop_inverse perm = ( perm == inverse (inverse perm) ) ++prop_mulPerm (SameSize perm1 perm2) = +    ( permute perm1 (permute perm2 set) == permute (perm1 `multiply` perm2) set ) +  where +    set = naturalSet perm1++prop_mulSign (SameSize perm1 perm2) = +    ( sgn perm1 * sgn perm2 == sgn (perm1 `multiply` perm2) ) +  where +    sgn = 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+++#endif++--------------------------------------------------------------------------------+

@@ -1,5 +1,5 @@ Name:                combinat-Version:             0.2+Version:             0.2.1 Synopsis:            Generation of various combinatorial objects. Description:         A collection of functions to generate combinatorial                      objects like partitions, combinations, permutations,@@ -7,8 +7,9 @@ License:             BSD3 License-file:        LICENSE Author:              Balazs Komuves-Copyright:           (c) 2008 Balazs Komuves+Copyright:           (c) 2008-2009 Balazs Komuves Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com+Homepage:            http://code.haskell.org/~bkomuves/ Stability:           Experimental Category:            Math Tested-With:         GHC == 6.10.1@@ -18,12 +19,18 @@ Flag splitBase   Description: Choose the new smaller, split-up base package. +Flag withQuickCheck+  Description: Compile with the QuickCheck tests. +   Library   if flag(splitBase)     Build-Depends:       base >= 3, array, containers, random+    if flag(withQuickCheck)+      Build-Depends:       QuickCheck   else     Build-Depends:       base <  3 +   Exposed-Modules:     Math.Combinat,                         Math.Combinat.Sets,                        Math.Combinat.Tuples, @@ -35,9 +42,12 @@      Other-Modules:       Math.Combinat.Helper -  Extensions:          MultiParamTypeClasses, ScopedTypeVariables+  Extensions:          MultiParamTypeClasses, ScopedTypeVariables, CPP    Hs-Source-Dirs:      .++  if flag(withQuickCheck)+    cpp-options:         -DQUICKCHECK    ghc-options:         -Wall -fno-warn-unused-matches