diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Math/Combinat.hs b/Math/Combinat.hs --- a/Math/Combinat.hs +++ b/Math/Combinat.hs @@ -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 diff --git a/Math/Combinat/Combinations.hs b/Math/Combinat/Combinations.hs deleted file mode 100644 --- a/Math/Combinat/Combinations.hs +++ /dev/null @@ -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) - -------------------------------------------------------- diff --git a/Math/Combinat/Compositions.hs b/Math/Combinat/Compositions.hs --- a/Math/Combinat/Compositions.hs +++ b/Math/Combinat/Compositions.hs @@ -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. +-- 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. diff --git a/Math/Combinat/FreeGroups.hs b/Math/Combinat/FreeGroups.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/FreeGroups.hs @@ -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 + +-------------------------------------------------------------------------------- + diff --git a/Math/Combinat/Helper.hs b/Math/Combinat/Helper.hs --- a/Math/Combinat/Helper.hs +++ b/Math/Combinat/Helper.hs @@ -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 diff --git a/Math/Combinat/Numbers.hs b/Math/Combinat/Numbers.hs --- a/Math/Combinat/Numbers.hs +++ b/Math/Combinat/Numbers.hs @@ -2,7 +2,7 @@ -- | A few important number sequences. -- -- See the \"On-Line Encyclopedia of Integer Sequences\", --- . +-- . module Math.Combinat.Numbers where diff --git a/Math/Combinat/Partitions.hs b/Math/Combinat/Partitions.hs --- a/Math/Combinat/Partitions.hs +++ b/Math/Combinat/Partitions.hs @@ -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) diff --git a/Math/Combinat/Tableaux/Kostka.hs b/Math/Combinat/Tableaux/Kostka.hs --- a/Math/Combinat/Tableaux/Kostka.hs +++ b/Math/Combinat/Tableaux/Kostka.hs @@ -26,7 +26,7 @@ -- > 1, 1, 2, 12, 286, 33592, 23178480, ... -- -- OEIS:A003121, \"Strict sense ballot numbers\", --- . +-- . -- -- See -- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88. diff --git a/Math/Combinat/Trees/Binary.hs b/Math/Combinat/Trees/Binary.hs --- a/Math/Combinat/Trees/Binary.hs +++ b/Math/Combinat/Trees/Binary.hs @@ -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 diff --git a/Math/Combinat/Trees/Nary.hs b/Math/Combinat/Trees/Nary.hs --- a/Math/Combinat/Trees/Nary.hs +++ b/Math/Combinat/Trees/Nary.hs @@ -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: +-- +-- 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 = diff --git a/combinat.cabal b/combinat.cabal --- a/combinat.cabal +++ b/combinat.cabal @@ -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