combinat 0.2.4.1 → 0.2.5.0
raw patch · 12 files changed
+730/−92 lines, 12 files
Files
- LICENSE +1/−1
- Math/Combinat.hs +7/−1
- Math/Combinat/Combinations.hs +0/−62
- Math/Combinat/Compositions.hs +11/−4
- Math/Combinat/FreeGroups.hs +304/−0
- Math/Combinat/Helper.hs +42/−0
- Math/Combinat/Numbers.hs +1/−1
- Math/Combinat/Partitions.hs +1/−1
- Math/Combinat/Tableaux/Kostka.hs +1/−1
- Math/Combinat/Trees/Binary.hs +58/−7
- Math/Combinat/Trees/Nary.hs +295/−6
- combinat.cabal +9/−8
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2008-2011, Balazs Komuves+Copyright (c) 2008-2014, Balazs Komuves All rights reserved. Redistribution and use in source and binary forms, with or without
Math/Combinat.hs view
@@ -1,8 +1,9 @@ -- | A collection of functions to generate combinatorial--- objects like partitions, combinations, permutations,+-- objects like partitions, compositions, permutations, -- Young tableaux, various trees, etc. --+-- -- The long-term goals are -- -- (1) to be efficient; @@ -13,6 +14,7 @@ -- The short-term goal is to generate -- many interesting structures. --+-- -- Naming conventions (subject to change): -- -- * prime suffix: additional constrains, typically more general;@@ -24,6 +26,10 @@ -- (typically with uniform distribution); -- -- * \"count\" prefix: counting functions.+--+--+-- This module re-exports the most common modules.+-- module Math.Combinat ( module Math.Combinat.Numbers
− Math/Combinat/Combinations.hs
@@ -1,62 +0,0 @@---- | Combinations.--- This module is depracated; it is equivalent to the module "Compositions", --- but it turns out that \"compositions\" is the accepted name. I will--- remove this module in the future.--module Math.Combinat.Combinations where--import Math.Combinat.Numbers (factorial,binomial)------------------------------------------------------------- | Combinations fitting into a given shape and having a given degree.--- The order is lexicographic, that is, ------ > sort cs == cs where cs = combinations' shape k----combinations' - :: [Int] -- ^ shape- -> Int -- ^ sum- -> [[Int]]-combinations' [] 0 = [[]]-combinations' [] _ = []-combinations' shape@(s:ss) n = - [ x:xs | x <- [0..min s n] , xs <- combinations' ss (n-x) ] --countCombinations' :: [Int] -> Int -> Integer-countCombinations' [] 0 = 1-countCombinations' [] _ = 0-countCombinations' shape@(s:ss) n = sum - [ countCombinations' ss (n-x) | x <- [0..min s n] ] ---- | All combinations fitting into a given shape.-allCombinations' :: [Int] -> [[[Int]]]-allCombinations' shape = map (combinations' shape) [0..d] where d = sum shape---- | Combinations of a given length.-combinations - :: Int -- ^ length- -> Int -- ^ sum- -> [[Int]]-combinations len d = combinations' (replicate len d) d---- | # = \\binom { len+d-1 } { len-1 }-countCombinations :: Int -> Int -> Integer-countCombinations len d = binomial (len+d-1) (len-1)---- | Positive combinations of a given length.-combinations1 - :: Int -- ^ length- -> Int -- ^ sum- -> [[Int]]-combinations1 len d - | len > d = []- | otherwise = map plus1 $ combinations len (d-len)- where- plus1 = map (+1)--countCombinations1 :: Int -> Int -> Integer-countCombinations1 len d = countCombinations len (d-len)---------------------------------------------------------
Math/Combinat/Compositions.hs view
@@ -1,8 +1,8 @@ -- | Compositions. --- This module is equivalent to the module "Combinations", --- but it turns out that \"compositions\" is the accepted name. I will--- remove the "Combinations" module in the future.+--+-- See eg. <http://en.wikipedia.org/wiki/Composition_%28combinatorics%29>+-- module Math.Combinat.Compositions where @@ -10,6 +10,8 @@ ------------------------------------------------------- +type Composition = [Int]+ -- | Compositions fitting into a given shape and having a given degree. -- The order is lexicographic, that is, --@@ -30,8 +32,13 @@ countCompositions' shape@(s:ss) n = sum [ countCompositions' ss (n-x) | x <- [0..min s n] ] +-- | All positive compositions of a given number (filtrated by the length). +-- Total number of these is @2^(n-1)@+allCompositions1 :: Int -> [[Composition]]+allCompositions1 n = map (\d -> compositions1 d n) [1..n] + -- | All compositions fitting into a given shape.-allCompositions' :: [Int] -> [[[Int]]]+allCompositions' :: [Int] -> [[Composition]] allCompositions' shape = map (compositions' shape) [0..d] where d = sum shape -- | Compositions of a given length.
+ Math/Combinat/FreeGroups.hs view
@@ -0,0 +1,304 @@++-- | Words in free groups (and free powers of cyclic groups) +--+{-# LANGUAGE PatternGuards #-}+module Math.Combinat.FreeGroups where++--------------------------------------------------------------------------------++import Control.Monad (liftM)++import Math.Combinat.Numbers++--------------------------------------------------------------------------------++-- | A generator of a (free) group+data Generator a + = Gen a -- @a@+ | Inv a -- @a^(-1)@+ deriving (Eq,Ord,Show,Read)++-- | A /word/, describing (non-uniquely) an element of a group.+-- The identity element is represented (among others) by the empty word.+type Word a = [Generator a] ++--------------------------------------------------------------------------------+ +instance Functor Generator where+ fmap f g = case g of + Gen x -> Gen (f x) + Inv y -> Inv (f y)+ +--------------------------------------------------------------------------------++-- | The inverse of a generator+inverseGen :: Generator a -> Generator a+inverseGen g = case g of+ Gen x -> Inv x+ Inv x -> Gen x++-- | The inverse of a word+inverseWord :: Word a -> Word a+inverseWord = map inverseGen . reverse++-- | Lists all words of the given length (total number will be @(2g)^n@).+-- The numbering of the generators is @[1..g]@.+allWords + :: Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word+ -> [Word Int]+allWords g = go where+ go 0 = [[]]+ go n = [ x:xs | xs <- go (n-1) , x <- elems ]+ elems = [ Gen a | a<-[1..g] ]+ ++ [ Inv a | a<-[1..g] ]++-- | Lists all words of the given length which do not contain inverse generators+-- (total number will be @g^n@).+-- The numbering of the generators is @[1..g]@.+allWordsNoInv + :: Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word+ -> [Word Int]+allWordsNoInv g = go where+ go 0 = [[]]+ go n = [ x:xs | xs <- go (n-1) , x <- elems ]+ elems = [ Gen a | a<-[1..g] ]+ +--------------------------------------------------------------------------------+-- * The free group on @g@ generators++-- | Multiplication of the free group (returns the reduced result). It is true+-- for any two words w1 and w2 that+--+-- > multiplyFree (reduceWordFree w1) (reduceWord w2) = multiplyFree w1 w2+--+multiplyFree :: Eq a => Word a -> Word a -> Word a+multiplyFree w1 w2 = reduceWordFree (w1++w2)++-- | Reduces a word in a free group by repeatedly removing @x*x^(-1)@ and+-- @x^(-1)*x@ pairs. The set of /reduced words/ forms the free group; the+-- multiplication is obtained by concatenation followed by reduction.+--+reduceWordFree :: Eq a => Word a -> Word a+reduceWordFree = loop where++ loop w = case reduceStep w of+ Nothing -> w+ Just w' -> loop w'+ + reduceStep :: Eq a => Word a -> Maybe (Word a)+ reduceStep = go False where + go changed w = case w of+ (Gen x : Inv y : rest) | x==y -> go True rest+ (Inv x : Gen y : rest) | x==y -> go True rest+ (this : rest) -> liftM (this:) $ go changed rest+ _ -> if changed then Just w else Nothing++--------------------------------------------------------------------------------++-- | Counts the number of words of length @n@ which reduce to the identity element.+--+-- Generating function is @Gf_g(u) = \\frac {2g-1} { g-1 + g \\sqrt{ 1 - (8g-4)u^2 } }@+--+countIdentityWordsFree+ :: Int -- ^ g = number of generators in the free group+ -> Int -- ^ n = length of the unreduced word+ -> Integer+countIdentityWordsFree g n = countWordReductionsFree g n 0+ +-- | Counts the number of words of length @n@ whose reduced form has length @k@+-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):+--+-- > countWordReductionsFree g n k == sum [ 1 | w <- allWords g n, k == length (reduceWordFree w) ]+--+countWordReductionsFree + :: Int -- ^ g = number of generators in the free group+ -> Int -- ^ n = length of the unreduced word+ -> Int -- ^ k = length of the reduced word+ -> Integer+countWordReductionsFree gens_ nn_ kk_+ | nn==0 = if k==0 then 1 else 0+ | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * gg^(i ) * (gg-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ]+ | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ]+ | otherwise = 0 + where+ g = fromIntegral gens_ :: Integer+ nn = fromIntegral nn_ :: Integer+ kk = fromIntegral kk_ :: Integer+ + gg = 2*g+ n = div nn 2+ k = div kk 2+ +--------------------------------------------------------------------------------+-- * Free powers of cyclic groups++-- | Multiplication in free products of Z2's+multiplyZ2 :: Eq a => Word a -> Word a -> Word a+multiplyZ2 w1 w2 = reduceWordZ2 (w1++w2)++-- | Multiplication in free products of Z3's+multiplyZ3 :: Eq a => Word a -> Word a -> Word a+multiplyZ3 w1 w2 = reduceWordZ3 (w1++w2)++-- | Multiplication in free products of Zm's+multiplyZm :: Eq a => Int -> Word a -> Word a -> Word a+multiplyZm k w1 w2 = reduceWordZm k (w1++w2)++--------------------------------------------------------------------------------++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@+-- (that is, free products of Z2's)+reduceWordZ2 :: Eq a => Word a -> Word a+reduceWordZ2 = loop where+ loop w = case reduceStep w of+ Nothing -> w+ Just w' -> loop w'+ + reduceStep :: Eq a => Word a -> Maybe (Word a)+ reduceStep = go False where + go changed w = case w of+ (Gen x : Gen y : rest) | x==y -> go True rest+ (Gen x : Inv y : rest) | x==y -> go True rest+ (Inv x : Gen y : rest) | x==y -> go True rest+ (Inv x : Inv y : rest) | x==y -> go True rest+ (this : rest) -> liftM (this:) $ go changed rest+ _ -> if changed then Just w else Nothing++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@+-- (that is, free products of Z3's)+reduceWordZ3 :: Eq a => Word a -> Word a+reduceWordZ3 = loop where+ loop w = case reduceStep w of+ Nothing -> w+ Just w' -> loop w'+ + reduceStep :: Eq a => Word a -> Maybe (Word a)+ reduceStep = go False where + go changed w = case w of+ (Gen x : Inv y : rest) | x==y -> go True rest+ (Inv x : Gen y : rest) | x==y -> go True rest+ (Gen x : Gen y : Gen z : rest) | x==y && y==z -> go True rest+ (Inv x : Inv y : Inv z : rest) | x==y && y==z -> go True rest+ (Gen x : Gen y : rest) | x==y -> go True (Inv x : rest) -- !!!+ (Inv x : Inv y : rest) | x==y -> go True (Gen x : rest)+ (this : rest) -> liftM (this:) $ go changed rest+ _ -> if changed then Just w else Nothing+ +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@+-- (that is, free products of Zm's)+reduceWordZm :: Eq a => Int -> Word a -> Word a+reduceWordZm m = loop where++ loop w = case reduceStep w of+ Nothing -> w+ Just w' -> loop w'++ halfm = div m 2 -- if we encounter strictly more than m/2 equal elements in a row, we replace them by the inverses+ + reduceStep :: Eq a => Word a -> Maybe (Word a)+ reduceStep = go False where + go changed w = case w of+ (Gen x : Inv y : rest) | x==y -> go True rest+ (Inv x : Gen y : rest) | x==y -> go True rest+-- something | Just rest <- dropk w -> go True rest+ something | Just (k,rest) <- dropIfMoreThanHalf w -> go True (replicate (m-k) (inverseGen (head w)) ++ rest)+ (this : rest) -> liftM (this:) $ go changed rest+ _ -> if changed then Just w else Nothing+ + dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a)+ dropIfMoreThanHalf w = + let (k,rest) = dropWhileEqual w + in if k > halfm then Just (k,rest)+ else Nothing+ + dropWhileEqual :: Eq a => Word a -> (Int, Word a) + dropWhileEqual [] = (0,[])+ dropWhileEqual (x0:rest) = go 1 rest where+ go k [] = (k,[])+ go k xxs@(x:xs) = if k==m then (m,xxs) + else if x==x0 then go (k+1) xs + else (k,xxs)++{- + dropm :: Eq a => Word a -> Maybe (Word a) + dropm [] = Nothing+ dropm (x:xs) = go (m-1) xs where+ go 0 rest = Just rest+ go j (y:ys) = if y==x + then go (j-1) ys+ else Nothing + go j [] = Nothing+-}++--------------------------------------------------------------------------------++-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^2=1@.+--+-- Generating function is @Gf_g(u) = \\frac {2g-2} { g-2 + g \\sqrt{ 1 - (4g-4)u^2 } }@+--+-- The first few @g@ cases:+--+-- > A000984 = [ countIdentityWordsZ2 2 (2*n) | n<-[0..] ] = [1,2,6,20,70,252,924,3432,12870,48620,184756...]+-- > A089022 = [ countIdentityWordsZ2 3 (2*n) | n<-[0..] ] = [1,3,15,87,543,3543,23823,163719,1143999,8099511,57959535...]+-- > A035610 = [ countIdentityWordsZ2 4 (2*n) | n<-[0..] ] = [1,4,28,232,2092,19864,195352,1970896,20275660,211823800,2240795848...]+-- > A130976 = [ countIdentityWordsZ2 5 (2*n) | n<-[0..] ] = [1,5,45,485,5725,71445,925965,12335685,167817405,2321105525,32536755565...]+--+countIdentityWordsZ2+ :: Int -- ^ g = number of generators in the free group+ -> Int -- ^ n = length of the unreduced word+ -> Integer+countIdentityWordsZ2 g n = countWordReductionsZ2 g n 0++-- | Counts the number of words (without inverse generators) of length @n@ whose +-- reduced form in the product of Z2-s (that is, for each generator @x@ we have @x^2=1@) +-- has length @k@+-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):+--+-- > countWordReductionsZ2 g n k == sum [ 1 | w <- allWordsNoInv g n, k == length (reduceWordZ2 w) ]+--+countWordReductionsZ2 + :: Int -- ^ g = number of generators in the free group+ -> Int -- ^ n = length of the unreduced word+ -> Int -- ^ k = length of the reduced word+ -> Integer+countWordReductionsZ2 gens_ nn_ kk_+ | nn==0 = if k==0 then 1 else 0+ | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * g^(i ) * (g-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ]+ | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ]+ | otherwise = 0 + where+ g = fromIntegral gens_ :: Integer+ nn = fromIntegral nn_ :: Integer+ kk = fromIntegral kk_ :: Integer+ + n = div nn 2+ k = div kk 2++-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^3=1@.+--+-- > countIdentityWordsZ3NoInv g n == sum [ 1 | w <- allWordsNoInv g n, 0 == length (reduceWordZ2 w) ]+--+-- In mathematica, the formula is: @Sum[ g^k * (g-1)^(n-k) * k/n * Binomial[3*n-k-1, n-k] , {k, 1,n} ]@+--+countIdentityWordsZ3NoInv+ :: Int -- ^ g = number of generators in the free group+ -> Int -- ^ n = length of the unreduced word+ -> Integer+countIdentityWordsZ3NoInv gens_ nn_ + | nn==0 = 1+ | mod nn 3 == 0 = sum [ ( binomial (3*n-i-1) (n-i) * g^i * (g-1)^(n-i) * i ) `div` n | i<-[1..n] ]+ | otherwise = 0+ where+ g = fromIntegral gens_ :: Integer+ nn = fromIntegral nn_ :: Integer+ + n = div nn 3+ +--------------------------------------------------------------------------------+
Math/Combinat/Helper.hs view
@@ -41,7 +41,49 @@ worker s (x:xs) | Set.member x s = worker s xs | otherwise = x : worker (Set.insert x s) xs++--------------------------------------------------------------------------------++-- | The boolean argument will @True@ only for the last element+mapWithLast :: (Bool -> a -> b) -> [a] -> [b]+mapWithLast f = go where+ go (x : []) = f True x : []+ go (x : xs) = f False x : go xs++mapWithFirst :: (Bool -> a -> b) -> [a] -> [b]+mapWithFirst f = go True where+ go b (x:xs) = f b x : go False xs + +mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b]+mapWithFirstLast f = go True where+ go b (x : []) = f b True x : []+ go b (x : xs) = f b False x : go False xs++--------------------------------------------------------------------------------+-- helpers for ASCII drawing++-- | extend lines with spaces so that they have the same line+mkLinesUniformWidth :: [String] -> [String]+mkLinesUniformWidth old = zipWith worker ls old where+ ls = map length old+ m = maximum ls+ worker l s = s ++ replicate (m-l) ' '++mkBlocksUniformHeight :: [[String]] -> [[String]]+mkBlocksUniformHeight old = zipWith worker ls old where+ ls = map length old+ m = maximum ls+ worker l s = s ++ replicate (m-l) "" +mkUniformBlocks :: [[String]] -> [[String]] +mkUniformBlocks = map mkLinesUniformWidth . mkBlocksUniformHeight+ +hConcatLines :: [[String]] -> [String]+hConcatLines = map concat . transpose . mkUniformBlocks++vConcatLines :: [[String]] -> [String] +vConcatLines = concat+ -------------------------------------------------------------------------------- -- helps testing the random rutines
Math/Combinat/Numbers.hs view
@@ -2,7 +2,7 @@ -- | A few important number sequences. -- -- See the \"On-Line Encyclopedia of Integer Sequences\",--- <http://www.research.att.com/~njas/sequences/> .+-- <https://oeis.org> . module Math.Combinat.Numbers where
Math/Combinat/Partitions.hs view
@@ -108,7 +108,7 @@ -- | Example: ----- > elements (toPartition [5,2,1]) ==+-- > elements (toPartition [5,4,1]) == -- > [ (1,1), (1,2), (1,3), (1,4), (1,5) -- > , (2,1), (2,2), (2,3), (2,4) -- > , (3,1)
Math/Combinat/Tableaux/Kostka.hs view
@@ -26,7 +26,7 @@ -- > 1, 1, 2, 12, 286, 33592, 23178480, ... -- -- OEIS:A003121, \"Strict sense ballot numbers\", --- <http://www.research.att.com/~njas/sequences/A003121>.+-- <https://oeis.org/A003121>. -- -- See -- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88.
Math/Combinat/Trees/Binary.hs view
@@ -7,6 +7,7 @@ BinTree(..) , leaf , BinTree'(..)+ , toRoseTree , toRoseTree' , forgetNodeDecorations , module Data.Tree , Paren(..)@@ -35,6 +36,9 @@ , binaryTreesNaive , randomBinaryTree , fasc4A_algorithm_R+ -- * ASCII drawing+ , printBinaryTree_+ , drawBinaryTree_ ) where @@ -84,20 +88,39 @@ forgetNodeDecorations (Leaf' decor) = Leaf decor --------------------------------------------------------------------------------+-- * conversion to Data.Tree++-- | Convert a binary tree to a rose tree (from "Data.Tree")+toRoseTree :: BinTree a -> Tree (Maybe a)+toRoseTree = go where+ go (Branch t1 t2) = Node Nothing [go t1, go t2]+ go (Leaf x) = Node (Just x) [] ++toRoseTree' :: BinTree' a b -> Tree (Either b a)+toRoseTree' = go where+ go (Branch' t1 y t2) = Node (Left y) [go t1, go t2]+ go (Leaf' x) = Node (Right x) [] +--------------------------------------------------------------------------------+-- * instances+ instance Functor BinTree where- fmap f (Branch left right) = Branch (fmap f left) (fmap f right)- fmap f (Leaf x) = Leaf (f x)+ fmap f = go where+ go (Branch left right) = Branch (go left) (go right)+ go (Leaf x) = Leaf (f x) instance Foldable BinTree where- foldMap f (Leaf x) = f x- foldMap f (Branch left right) = (foldMap f left) `mappend` (foldMap f right) + foldMap f = go where+ go (Leaf x) = f x+ go (Branch left right) = (go left) `mappend` (go right) instance Traversable BinTree where- traverse f (Leaf x) = Leaf <$> f x- traverse f (Branch left right) = Branch <$> traverse f left <*> traverse f right+ traverse f = go where + go (Leaf x) = Leaf <$> f x+ go (Branch left right) = Branch <$> go left <*> go right --------------------------------------------------------------------------------+-- * nester parentheses data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read) @@ -205,7 +228,7 @@ -- Based on \"Algorithm P\" in Knuth, but less efficient because of -- the \"idiomatic\" code. fasc4A_algorithm_P :: Int -> [[Paren]]-fasc4A_algorithm_P 0 = []+fasc4A_algorithm_P 0 = [[]] fasc4A_algorithm_P 1 = [[LeftParen,RightParen]] fasc4A_algorithm_P n = unfold next ( start , [] ) where start = concat $ replicate n [RightParen,LeftParen] -- already reversed!@@ -329,5 +352,33 @@ (k,b) = x `divMod` 2 -------------------------------------------------------------------------------- ++-- | Draws a binary tree in ASCII, ignoring node labels.+--+-- Example:+--+-- > mapM_ printBinaryTree_ $ binaryTrees 4+--+printBinaryTree_ :: BinTree a -> IO ()+printBinaryTree_ = putStrLn . drawBinaryTree_ +drawBinaryTree_ :: BinTree a -> String+drawBinaryTree_ = unlines . fst . go where + go :: BinTree a -> ([String],Int)+ go (Leaf x) = ([],0)+ go (Branch t1 t2) = ( new , j1+m ) where+ (ls1,j1) = go t1+ (ls2,j2) = go t2+ w1 = blockWidth ls1+ w2 = blockWidth ls2+ m = max 1 $ (w1-j1+j2+2) `div` 2+ s = 2*m - (w1-j1+j2)+ spaces = [replicate s ' ']+ ls = hConcatLines [ ls1 , spaces , ls2 ]+ top = [ replicate (j1+m-i) ' ' ++ "/" ++ replicate (2*(i-1)) ' ' ++ "\\" | i<-[1..m] ]+ new = mkLinesUniformWidth $ vConcatLines [ top , ls ] + + blockWidth ls = case ls of+ (l:_) -> length l+ [] -> 0
Math/Combinat/Trees/Nary.hs view
@@ -2,8 +2,36 @@ -- | N-ary trees. module Math.Combinat.Trees.Nary - ( - derivTrees+ (+ -- * regular trees + ternaryTrees+ , regularNaryTrees+ , semiRegularTrees+ , countTernaryTrees+ , countRegularNaryTrees+ -- * derivation trees+ , derivTrees+ -- * ASCII drawings+ , printTreeVertical_+ , printTreeVertical+ , printTreeVerticalLeavesOnly+ , drawTreeVertical_+ , drawTreeVertical+ , drawTreeVerticalLeavesOnly+ -- * classifying nodes+ , classifyTreeNode+ , isTreeLeaf , isTreeNode+ , isTreeLeaf_ , isTreeNode_+ , treeNodeNumberOfChildren + -- * counting nodes+ , countTreeNodes+ , countTreeLeaves+ , countTreeLabelsWith+ , countTreeNodesWith + -- * left and right spines+ , leftSpine , leftSpine_+ , rightSpine , rightSpine_+ , leftSpineLength , rightSpineLength -- * unique labels , addUniqueLabelsTree , addUniqueLabelsForest@@ -26,6 +54,7 @@ -------------------------------------------------------------------------------- import Data.Tree+import Data.List import Control.Applicative @@ -33,16 +62,276 @@ import Control.Monad.Trans.State import Data.Traversable (traverse) -import Math.Combinat.Sets (listTensor)-import Math.Combinat.Partitions (partitionMultiset)+import Math.Combinat.Sets (listTensor)+import Math.Combinat.Partitions (partitionMultiset)+import Math.Combinat.Compositions (compositions)+import Math.Combinat.Numbers (factorial,binomial) +import Math.Combinat.Helper+ -------------------------------------------------------------------------------- --- | Adds unique labels to a 'Tree'.+-- | @regularNaryTrees d n@ returns the list of (rooted) trees on @n@ nodes where each+-- node has exactly @d@ children. Note that the leaves do not count in @n@.+-- Naive algorithm.+regularNaryTrees + :: Int -- ^ degree = number of children of each node+ -> Int -- ^ number of nodes+ -> [Tree ()]+regularNaryTrees d = go where+ go 0 = [ Node () [] ]+ go n = [ Node () cs+ | is <- compositions d (n-1) + , cs <- listTensor [ go i | i<-is ] + ]+ +-- | Ternary trees on @n@ nodes (synonym for @regularNaryTrees 3@)+ternaryTrees :: Int -> [Tree ()] +ternaryTrees = regularNaryTrees 3++-- | We have +--+-- > length (regularNaryTrees d n) == countRegularNaryTrees d n == \frac {1} {(d-1)n+1} \binom {dn} {n} +--+countRegularNaryTrees :: (Integral a, Integral b) => a -> b -> Integer+countRegularNaryTrees d n = binomial (dd*nn) nn `div` ((dd-1)*nn+1) where+ dd = fromIntegral d :: Integer+ nn = fromIntegral n :: Integer ++-- | @\# = \\frac {1} {(2n+1} \\binom {3n} {n}@+countTernaryTrees :: Integral a => a -> Integer +countTernaryTrees = countRegularNaryTrees (3::Int)++--------------------------------------------------------------------------------++-- | All trees on @n@ nodes where the number of children of all nodes is+-- in element of the given set. Example:+--+-- > mapM_ printTreeVertical +-- > $ map labelNChildrenTree_ +-- > $ semiRegularTrees [2,3] n+-- >+-- > [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...]+--+-- The latter sequence is A027307 in OEIS: <https://oeis.org/A027307>+--+-- Remark: clearly, we have+--+-- > semiRegularTrees [d] n == regularNaryTrees d n+--+-- +semiRegularTrees + :: [Int] -- ^ set of allowed number of children+ -> Int -- ^ number of nodes+ -> [Tree ()]+semiRegularTrees [] n = if n==0 then [Node () []] else []+semiRegularTrees dset_ n = + if head dset >=1 + then go n+ else error "semiRegularTrees: expecting a list of positive integers"+ where+ dset = map head $ group $ sort $ dset_+ + go 0 = [ Node () [] ]+ go n = [ Node () cs+ | d <- dset+ , is <- compositions d (n-1) + , cs <- listTensor [ go i | i<-is ]+ ]+ +{- ++NOTES:++A006318 = [ length $ semiRegularTrees [1,2] n | n<-[0..] ] == [1,2,6,22,90,394,1806,8558,41586,206098,1037718.. ]+?? = [ length $ semiRegularTrees [1,3] n | n<-[0..] ] == [1,2,8,44,280,1936,14128,107088,834912,6652608 .. ]+?? = [ length $ semiRegularTrees [1,4] n | n<-[0..] ] == [1,2,10,74,642,6082,60970,635818,6826690++A027307 = [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...]+A219534 = [ length $ semiRegularTrees [2,4] n | n<-[0..] ] == [1,2,12,100,968,10208,113792,1318832 ..]+?? = [ length $ semiRegularTrees [2,5] n | n<-[0..] ] == [1,2,14,142,1690,21994,303126,4348102 ..]++A144097 = [ length $ semiRegularTrees [3,4] n | n<-[0..] ] == [1,2,14,134,1482,17818,226214,2984206,40503890..]++A107708 = [ length $ semiRegularTrees [1,2,3] n | n<-[0..] ] == [1,3,18,144,1323,13176,138348,1507977 .. ]+?? = [ length $ semiRegularTrees [1,2,3,4] n | n<-[0..] ] == [1,4,40,560,9120,161856,3036800,59242240 .. ] ++-}+ +--------------------------------------------------------------------------------++-- | Vertical ASCII drawing of a tree, without labels.+-- +-- Example:+--+-- > mapM_ printTreeVertical_ $ regularNaryTrees 2 3 +--+printTreeVertical_ :: Tree a -> IO ()+printTreeVertical_ = putStrLn . drawTreeVertical_++-- | Prints all labels.+--+-- Example: +--+-- > printTreeVertical $ addUniqueLabelsTree_ $ (regularNaryTrees 3 9) !! 666+--+printTreeVertical :: Show a => Tree a -> IO ()+printTreeVertical = putStrLn . drawTreeVertical++-- | Prints the labels for the leaves, but not for the nonempty nodes+printTreeVerticalLeavesOnly :: Show a => Tree a -> IO ()+printTreeVerticalLeavesOnly = putStrLn . drawTreeVerticalLeavesOnly++-- | Nodes are denoted by @\@@, leaves by @*@.+drawTreeVertical_ :: Tree a -> String+drawTreeVertical_ tree = unlines (go tree) where+ go :: Tree b -> [String]+ go (Node _ cs) = case cs of+ [] -> ["-*"]+ _ -> concat $ mapWithFirstLast f $ map go cs+ + f :: Bool -> Bool -> [String] -> [String] + f bf bl (l:ls) = let indent = if bl then " " else "| "+ gap = if bl then [] else ["| "]+ branch = if bl && not bf + then "\\-" + else if bf then "@-"+ else "+-"+ in (branch++l) : map (indent++) ls ++ gap++-- | Nodes are denoted by @(label)@, leaves by @label@.+drawTreeVertical :: Show a => Tree a -> String+drawTreeVertical tree = unlines (go tree) where+ go :: Show b => Tree b -> [String]+ go (Node x cs) = case cs of+ [] -> ["-- " ++ show x]+ _ -> concat $ mapWithFirstLast (f (show x)) $ map go cs+ + f :: String -> Bool -> Bool -> [String] -> [String] + f label bf bl (l:ls) =+ let spaces = (map (const ' ') label ) + dashes = (map (const '-') spaces ) + indent = if bl then " " ++spaces++" " else " |" ++ spaces ++ " "+ gap = if bl then [] else [" |" ++ spaces ++ " "]+ branch = if bl && not bf+ then " \\"++dashes++"--" + else if bf + then "-(" ++ label ++ ")-"+ else " +" ++ dashes ++ "--"+ in (branch++l) : map (indent++) ls ++ gap++-- | Nodes are denoted by @\@@, leaves by @label@.+drawTreeVerticalLeavesOnly :: Show a => Tree a -> String+drawTreeVerticalLeavesOnly tree = unlines (go tree) where+ go :: Show b => Tree b -> [String]+ go (Node x cs) = case cs of+ [] -> ["- " ++ show x]+ _ -> concat $ mapWithFirstLast f $ map go cs+ + f :: Bool -> Bool -> [String] -> [String] + f bf bl (l:ls) = let indent = if bl then " " else "| "+ gap = if bl then [] else ["| "]+ branch = if bl && not bf + then "\\-" + else if bf then "@-"+ else "+-"+ in (branch++l) : map (indent++) ls ++ gap+ +--------------------------------------------------------------------------------+ +-- | The leftmost spine (the second element of the pair is the leaf node)+leftSpine :: Tree a -> ([a],a)+leftSpine = go where+ go (Node x cs) = case cs of+ [] -> ([],x)+ _ -> let (xs,y) = go (head cs) in (x:xs,y) ++rightSpine :: Tree a -> ([a],a)+rightSpine = go where+ go (Node x cs) = case cs of+ [] -> ([],x)+ _ -> let (xs,y) = go (last cs) in (x:xs,y) ++-- | The leftmost spine without the leaf node+leftSpine_ :: Tree a -> [a]+leftSpine_ = go where+ go (Node x cs) = case cs of+ [] -> []+ _ -> x : go (head cs)++rightSpine_ :: Tree a -> [a] +rightSpine_ = go where+ go (Node x cs) = case cs of+ [] -> []+ _ -> x : go (last cs) ++-- | The length (number of edges) on the left spine +--+-- > leftSpineLength tree == length (leftSpine_ tree)+--+leftSpineLength :: Tree a -> Int +leftSpineLength = go 0 where+ go n (Node x cs) = case cs of+ [] -> n+ _ -> go (n+1) (head cs)+ +rightSpineLength :: Tree a -> Int +rightSpineLength = go 0 where+ go n (Node x cs) = case cs of+ [] -> n+ _ -> go (n+1) (last cs)++--------------------------------------------------------------------------------++-- | 'Left' is leaf, 'Right' is node+classifyTreeNode :: Tree a -> Either a a+classifyTreeNode (Node x cs) = case cs of { [] -> Left x ; _ -> Right x }++isTreeLeaf :: Tree a -> Maybe a +isTreeLeaf (Node x cs) = case cs of { [] -> Just x ; _ -> Nothing } ++isTreeNode :: Tree a -> Maybe a +isTreeNode (Node x cs) = case cs of { [] -> Nothing ; _ -> Just x } ++isTreeLeaf_ :: Tree a -> Bool +isTreeLeaf_ (Node x cs) = case cs of { [] -> True ; _ -> False } + +isTreeNode_ :: Tree a -> Bool +isTreeNode_ (Node x cs) = case cs of { [] -> False ; _ -> True } ++treeNodeNumberOfChildren :: Tree a -> Int+treeNodeNumberOfChildren (Node _ cs) = length cs++--------------------------------------------------------------------------------+-- counting++countTreeNodes :: Tree a -> Int+countTreeNodes = go where+ go (Node x cs) = case cs of+ [] -> 0+ _ -> 1 + sum (map go cs)++countTreeLeaves :: Tree a -> Int+countTreeLeaves = go where+ go (Node x cs) = case cs of+ [] -> 1+ _ -> sum (map go cs)++countTreeLabelsWith :: (a -> Bool) -> Tree a -> Int+countTreeLabelsWith f = go where+ go (Node label cs) = (if f label then 1 else 0) + sum (map go cs)++countTreeNodesWith :: (Tree a -> Bool) -> Tree a -> Int+countTreeNodesWith f = go where+ go node@(Node _ cs) = (if f node then 1 else 0) + sum (map go cs)++--------------------------------------------------------------------------------++-- | Adds unique labels to the nodes (including leaves) of a 'Tree'. addUniqueLabelsTree :: Tree a -> Tree (a,Int) addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree]) --- | Adds unique labels to a 'Forest'+-- | Adds unique labels to the nodes (including leaves) of a 'Forest' addUniqueLabelsForest :: Forest a -> Forest (a,Int) addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where globalAction tree =
combinat.cabal view
@@ -1,19 +1,20 @@ Name: combinat-Version: 0.2.4.1+Version: 0.2.5.0 Synopsis: Generation of various combinatorial objects.-Description: A collection of functions to generate combinatorial- objects like partitions, combinations, permutations,- Young tableaux, various trees, etc.+Description: A collection of functions to generate (and if there is + a formula, count) combinatorial objects like partitions, + compositions, permutations, Young tableaux, various trees, + etc. License: BSD3 License-file: LICENSE Author: Balazs Komuves-Copyright: (c) 2008-2011 Balazs Komuves+Copyright: (c) 2008-2014 Balazs Komuves Maintainer: bkomuves (plus) hackage (at) gmail (dot) com Homepage: http://code.haskell.org/~bkomuves/ Stability: Experimental Category: Math-Tested-With: GHC == 6.12.3-Cabal-Version: >= 1.2+Tested-With: GHC == 7.4.2+Cabal-Version: >= 1.6 Build-Type: Simple Flag withQuickCheck@@ -47,7 +48,6 @@ Math.Combinat.Numbers.Primes Math.Combinat.Sets Math.Combinat.Tuples - Math.Combinat.Combinations Math.Combinat.Compositions Math.Combinat.Partitions Math.Combinat.Permutations@@ -56,6 +56,7 @@ Math.Combinat.Trees Math.Combinat.Trees.Binary Math.Combinat.Trees.Nary+ Math.Combinat.FreeGroups Math.Combinat.Graphviz Other-Modules: Math.Combinat.Helper