combinat 0.2.2 → 0.2.3

raw patch · 9 files changed

+700/−337 lines, 9 filesdep +mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mtl

API changes (from Hackage documentation)

Files

• Math/Combinat.hs +2/−0
• Math/Combinat/Graphviz.hs +102/−0
• Math/Combinat/Numbers.hs +26/−5
• Math/Combinat/Partitions.hs +111/−12
• Math/Combinat/Sets.hs +13/−4
• Math/Combinat/Trees.hs +6/−313
• Math/Combinat/Trees/Binary.hs +333/−0
• Math/Combinat/Trees/Nary.hs +101/−0
• combinat.cabal +6/−3

@@ -34,6 +34,7 @@   , module Math.Combinat.Permutations   , module Math.Combinat.Tableaux   , module Math.Combinat.Trees+  , module Math.Combinat.Graphviz   ) where  import Math.Combinat.Numbers@@ -44,3 +45,4 @@ import Math.Combinat.Permutations import Math.Combinat.Tableaux import Math.Combinat.Trees+import Math.Combinat.Graphviz

@@ -0,0 +1,102 @@++-- | Creates graphviz @.dot@ files from various structures, for example trees.++module Math.Combinat.Graphviz +  ( Dot+  , binTreeDot+  , binTree'Dot+  , treeDot+  , forestDot+  )+  where++--------------------------------------------------------------------------------++import Data.Tree++import Control.Applicative+import Control.Monad.State+import Data.Traversable (traverse)++import Math.Combinat.Trees.Binary (BinTree(..), BinTree'(..))+import Math.Combinat.Trees.Nary (addUniqueLabelsTree, addUniqueLabelsForest)++--------------------------------------------------------------------------------++type Dot = String++digraphBracket :: String -> [String] -> String   +digraphBracket name lines = +  "digraph " ++ name ++ " {\n" ++ +  concatMap (\xs -> "  "++xs++"\n") lines    +  ++ "}\n"+  +--------------------------------------------------------------------------------++binTreeDot :: Show a => String -> BinTree a -> Dot+binTreeDot graphname tree = +  digraphBracket graphname $ binTreeDot' tree++binTree'Dot :: (Show a, Show b) => String -> BinTree' a b -> Dot+binTree'Dot graphname tree = +  digraphBracket graphname $ binTree'Dot' tree+  +binTreeDot' :: Show a => BinTree a -> [String]+binTreeDot' tree = lines where+  lines = worker (0::Int) "r" tree +  name path = "node_"++path+  worker depth path (Leaf x) = +    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]+  worker depth path (Branch left right) +    = [vertex,leftedge,rightedge] ++ +      worker (depth+1) ('l':path) left ++ +      worker (depth+1) ('r':path) right+    where +      vertex = name path ++ "[shape=circle,style=filled,height=0.25,label=\"\"];"+      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"+      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"++binTree'Dot' :: (Show a, Show b) => BinTree' a b -> [String]+binTree'Dot' tree = lines where+  lines = worker (0::Int) "r" tree +  name path = "node_"++path+  worker depth path (Leaf' x) = +    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]+  worker depth path (Branch' left y right) +    = [vertex,leftedge,rightedge] ++ +      worker (depth+1) ('l':path) left ++ +      worker (depth+1) ('r':path) right+    where +      vertex = name path ++ "[shape=ellipse,label=\"" ++ show y ++ "\"];"+      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"+      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"++--------------------------------------------------------------------------------+    +-- | Generates graphviz @.dot@ file from a forest. The first argument tells whether+-- to make the individual trees clustered subgraphs; the second is the name of the+-- graph.+forestDot :: Show a => Bool -> String -> Forest a -> Dot+forestDot clustered graphname forest = digraphBracket graphname lines where+  lines = concat $ zipWith cluster [(1::Int)..] (addUniqueLabelsForest forest) +  name unique = "node_"++show unique+  cluster j tree = let treelines = worker (0::Int) tree in case clustered of+    False -> treelines+    True  -> ("subgraph cluster_"++show j++" {") : map ("  "++) treelines ++ ["}"] +  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where+    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"+    edges = map edge subtrees+    edge (Node (_,unique') _) = name unique ++ " -> " ++ name unique'   +  +-- | Generates graphviz @.dot@ file from a tree. The first argument is+-- the name of the graph.+treeDot :: Show a => String -> Tree a -> Dot+treeDot graphname tree = digraphBracket graphname lines where+  lines = worker (0::Int) (addUniqueLabelsTree tree) +  name unique = "node_"++show unique+  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where+    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"+    edges = map edge subtrees+    edge (Node (_,unique') _) = name unique ++ " -> " ++ name unique'++--------------------------------------------------------------------------------

@@ -1,7 +1,7 @@  -- | A few important number sequences.  --  --- See the "On-Line Encyclopedia of Integer Sequences",+-- See the \"On-Line Encyclopedia of Integer Sequences\", -- <http://www.research.att.com/~njas/sequences/> .  module Math.Combinat.Numbers where@@ -42,6 +42,11 @@     k' = fromIntegral k     n' = fromIntegral n +multinomial :: Integral a => [a] -> Integer+multinomial xs = div+  (factorial (sum xs))+  (product [ factorial x | x<-xs ])  +   -------------------------------------------------------------------------------- -- * Catalan numbers @@ -82,7 +87,7 @@           | otherwise = prev ! j           -- | (Signed) Stirling numbers of the first kind. OEIS:A008275.--- This function uses "signedStirling1stArray", so it shouldn't be used+-- This function uses 'signedStirling1stArray', so it shouldn't be used -- to compute /many/ Stirling numbers. signedStirling1st :: Integral a => a -> a -> Integer signedStirling1st n k @@ -90,9 +95,7 @@   | k > n     = 0   | otherwise = signedStirling1stArray n ! (fromIntegral k) --- | (Unsigned) Stirling numbers of the first kind. OEIS:A008275.--- This function uses "signedStirling1stArray", so it shouldn't be used--- to compute /many/ Stirling numbers.+-- | (Unsigned) Stirling numbers of the first kind. See 'signedStirling1st'. unsignedStirling1st :: Integral a => a -> a -> Integer unsignedStirling1st n k = abs (signedStirling1st n k) @@ -121,6 +124,24 @@     f k = toRational (paritySign (n+k) * factorial k * stirling2nd n k)          / toRational (k+1) +--------------------------------------------------------------------------------+-- * Power series++-- | Power series expansion of +-- +-- > @1 / ( (1-x^a_1) * (1-x^a_2) * ... * (1-x^a_n) )@+--+-- Example:+--+-- @(coinSeries [2,3,5]) !! k@ is the number of ways +-- to pay @k@ dollars with coins of two, three and five dollars.+--+-- TODO: better name?+coinSeries :: [Int] -> [Integer]+coinSeries []  = 1 : repeat 0+coinSeries (k:ks) = xs where+  xs = zipWith (+) (coinSeries ks) (replicate k 0 ++ xs) +   --------------------------------------------------------------------------------   

@@ -1,5 +1,8 @@  -- | Partitions. Partitions are nonincreasing sequences of positive integers.+--+-- See also +--   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B.  module Math.Combinat.Partitions   ( -- * Type and basic stuff@@ -13,35 +16,45 @@   , width   , heightWidth   , weight-  , _dualPartition   , dualPartition-  , _elements+  , _dualPartition   , elements+  , _elements+  , countAutomorphisms+  , _countAutomorphisms     -- * Generation-  , _partitions'    , partitions'  +  , _partitions'    , countPartitions'-  , _partitions   , partitions+  , _partitions   , countPartitions   , allPartitions'     , allPartitions    , countAllPartitions'   , countAllPartitions+    -- * Paritions of multisets, vector partitions+  , partitionMultiset+  , IntVector+  , vectorPartitions+  , _vectorPartitions+  , fasc3B_algorithm_M   )    where  import Data.List+import Data.Array.Unboxed+ import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial)+import Math.Combinat.Numbers (factorial,binomial,multinomial) --------------------------------------------------------+--------------------------------------------------------------------------------  -- | The additional invariant enforced here is that partitions  --   are monotone decreasing sequences of positive integers. newtype Partition = Partition [Int] deriving (Eq,Ord,Show,Read) --- | Sorts the input.+-- | Sorts the input, and cuts the nonpositive elements. mkPartition :: [Int] -> Partition mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs @@ -49,12 +62,15 @@ toPartitionUnsafe :: [Int] -> Partition toPartitionUnsafe = Partition --- | Checks whether the input is a partition.+-- | Checks whether the input is a partition. See the note at 'isPartition'! toPartition :: [Int] -> Partition toPartition xs = if isPartition xs   then toPartitionUnsafe xs   else error "toPartition: not a partition"   +-- | Note: we only check that the sequence is ordered, but we /do not/ check for+-- negative elements. This can be useful when working with symmetric functions.+-- It may also change in the future... isPartition :: [Int] -> Bool isPartition []  = True isPartition [_] = True@@ -90,7 +106,7 @@ _dualPartition [] = [] _dualPartition xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ] --- Example:+-- | Example: -- -- > elements (toPartition [5,2,1]) == -- > [ (1,1), (1,2), (1,3), (1,4), (1,5)@@ -102,9 +118,16 @@  _elements :: [Int] -> [(Int,Int)] _elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] -  -------------------------------------------------------- +-- | Computes the number of \"automorphisms\" of a given partition.+countAutomorphisms :: Partition -> Integer  +countAutomorphisms = _countAutomorphisms . fromPartition++_countAutomorphisms :: [Int] -> Integer+_countAutomorphisms = multinomial . map length . group+ +---------------------------------------------------------------------------------+ -- | Partitions of d, fitting into a given rectangle, as lists. _partitions'    :: (Int,Int)     -- ^ (height,width)@@ -160,5 +183,81 @@ countAllPartitions :: Int -> Integer countAllPartitions d = sum [ countPartitions i | i <- [0..d] ] --------------------------------------------------------+-------------------------------------------------------------------------------- +-- | Partitions of a multiset.+partitionMultiset :: (Eq a, Ord a) => [a] -> [[[a]]]+partitionMultiset xs = parts where+  parts = (map . map) (f . elems) temp+  f ns = concat (zipWith replicate ns zs)+  temp = fasc3B_algorithm_M counts+  counts = map length ys+  ys = group (sort xs) +  zs = map head ys++-- | Integer vectors. The indexing starts from 1.+type IntVector = UArray Int Int++-- | Vector partitions. Basically a synonym for 'fasc3B_algorithm_M'.+vectorPartitions :: IntVector -> [[IntVector]]+vectorPartitions = fasc3B_algorithm_M . elems++_vectorPartitions :: [Int] -> [[[Int]]]+_vectorPartitions = map (map elems) . fasc3B_algorithm_M++-- | Generates all vector partitions +--   (\"algorithm M\" in Knuth). +--   The order is decreasing lexicographic.  +fasc3B_algorithm_M :: [Int] -> [[IntVector]] +{- note to self: Knuth's descriptions of algorithms are still totally unreadable -}+fasc3B_algorithm_M xs = worker [start] where++  -- n = sum xs+  m = length xs++  start = [ (j,x,x) | (j,x) <- zip [1..] xs ]  +  +  worker stack@(last:_) = +    case decrease stack' of+      Nothing -> [visited]+      Just stack'' -> visited : worker stack''+    where+      stack'  = subtract_rec stack+      visited = map to_vector stack'+      +  decrease (last:rest) = +    case span (\(_,_,v) -> v==0) (reverse last) of+      ( _ , [(_,_,1)] ) -> case rest of+        [] -> Nothing+        _  -> decrease rest+      ( second , (c,u,v):first ) -> Just (modified:rest) where +        modified =   +          reverse first ++ +          (c,u,v-1) :  +          [ (c,u,u) | (c,u,_) <- reverse second ] +      _ -> error "should not happen"+        +  to_vector cuvs = +    accumArray (flip const) 0 (1,m)+      [ (c,v) | (c,_,v) <- cuvs ] ++  subtract_rec all@(last:_) = +    case subtract last of +      []  -> all+      new -> subtract_rec (new:all) ++  subtract [] = []+  subtract full@((c,u,v):rest) = +    if w >= v +      then (c,w,v) : subtract   rest+      else           subtract_b full+    where w = u - v+    +  subtract_b [] = []+  subtract_b ((c,u,v):rest) = +    if w /= 0 +      then (c,w,w) : subtract_b rest+      else           subtract_b rest+    where w = u - v++--------------------------------------------------------------------------------

@@ -6,7 +6,8 @@     choose   , combine   , tuplesFromList-  +  , listTensor+    --    , kSublists   , sublists   , countKSublists@@ -14,7 +15,7 @@   )    where -import Math.Combinat.Numbers (factorial,binomial)+import Math.Combinat.Numbers (binomial)  -------------------------------------------------------------------------------- @@ -33,13 +34,21 @@ combine k [] = [] combine k xxs@(x:xs) = map (x:) (combine (k-1) xxs) ++ combine k xs   --- | \"Tensor power\" for lists.+-- | \"Tensor power\" for lists. Special case of 'listTensor':+--+-- > tuplesFromList k xs == listTensor (replicate k xs)+--  -- See also "Math.Combinat.Tuples". -- TODO: better name? tuplesFromList :: Int -> [a] -> [[a]] tuplesFromList 0 _  = [[]] tuplesFromList k xs = [ (y:ys) | y <- xs, ys <- tuplesFromList (k-1) xs ]  +-- | \"Tensor product\" for lists.+listTensor :: [[a]] -> [[a]]+listTensor [] = [[]]+listTensor (xs:xss) = [ y:ys | y <- xs, ys <- listTensor xss ]+ --------------------------------------------------------------------------------  -- | Sublists of a list having given number of elements.@@ -48,7 +57,7 @@  -- | @# = \binom { n } { k }@. countKSublists :: Int -> Int -> Integer-countKSublists k n = binomial (fromIntegral n) (fromIntegral k)+countKSublists k n = binomial n k   -- | All sublists of a list. sublists :: [a] -> [[a]]

@@ -1,316 +1,9 @@ --- | Trees, forests, etc. See:---   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A.--module Math.Combinat.Trees -  ( -- * Types-    BinTree(..)-  , leaf-  , BinTree'(..)-  , forgetNodeDecorations-  , module Data.Tree -  , Paren(..)-  , parenthesesToString-  , stringToParentheses-    -- * Bijections-  , forestToNestedParentheses-  , forestToBinaryTree-  , nestedParenthesesToForest-  , nestedParenthesesToForestUnsafe-  , nestedParenthesesToBinaryTree-  , nestedParenthesesToBinaryTreeUnsafe-  , binaryTreeToForest-  , binaryTreeToNestedParentheses-    -- * Nested parentheses-  , nestedParentheses -  , randomNestedParentheses-  , nthNestedParentheses-  , countNestedParentheses-  , fasc4A_algorithm_P-  , fasc4A_algorithm_W-  , fasc4A_algorithm_U-    -- * Binary trees-  , binaryTrees-  , countBinaryTrees-  , binaryTreesNaive-  , randomBinaryTree-  , fasc4A_algorithm_R-  ) -  where--import Control.Monad-import Control.Monad.ST--import Data.Array-import Data.Array.ST--import Data.List-import Data.Tree (Tree(..),Forest(..))--import System.Random--import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial)------------------------------------------------------------ * Types---- | A binary tree with leaves decorated with type @a@.-data BinTree a-  = Branch (BinTree a) (BinTree a)-  | Leaf a-  deriving (Eq,Ord,Show,Read)--leaf :: BinTree ()-leaf = Leaf ()---- | A binary tree with leaves and internal nodes decorated --- with types @a@ and @b@, respectively.-data BinTree' a b-  = Branch' (BinTree' a b) b (BinTree' a b)-  | Leaf' a-  deriving (Eq,Ord,Show,Read)--forgetNodeDecorations :: BinTree' a b -> BinTree a-forgetNodeDecorations (Branch' left _ right) = -  Branch (forgetNodeDecorations left) (forgetNodeDecorations right)-forgetNodeDecorations (Leaf' decor) = Leaf decor -  -instance Functor BinTree where-  fmap f (Branch left right) = Branch (fmap f left) (fmap f right)-  fmap f (Leaf x) = Leaf (f x)-    ----------------------------------------------------------data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read)--parenToChar :: Paren -> Char-parenToChar LeftParen = '('-parenToChar RightParen = ')'--parenthesesToString :: [Paren] -> String-parenthesesToString = map parenToChar--stringToParentheses :: String -> [Paren]-stringToParentheses [] = []-stringToParentheses (x:xs) = p : stringToParentheses xs where-  p = case x of-    '(' -> LeftParen-    ')' -> RightParen-    _ -> error "stringToParentheses: invalid character"------------------------------------------------------------ * Bijections--forestToNestedParentheses :: Forest a -> [Paren]-forestToNestedParentheses = forest where-  -- forest :: Forest a -> [Paren]-  forest = concatMap tree -  -- tree :: Tree a -> [Paren]-  tree (Node _ sf) = LeftParen : forest sf ++ [RightParen]--forestToBinaryTree :: Forest a -> BinTree ()-forestToBinaryTree = forest where-  -- forest :: Forest a -> BinTree ()-  forest = foldr Branch leaf . map tree -  -- tree :: Tree a -> BinTree ()-  tree (Node _ sf) = case sf of-    [] -> leaf-    _  -> forest sf -   -nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())-nestedParenthesesToForest ps = -  case parseForest ps of -    (rest,forest) -> case rest of-      [] -> Just forest-      _  -> Nothing-  where  -    parseForest :: [Paren] -> ( [Paren] , Forest () )-    parseForest ps = unfoldEither parseTree ps-    parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )  -    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of-      (RightParen:qs) -> Right (qs, Node () ts)-      _ -> Left orig-    parseTree qs = Left qs--nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()-nestedParenthesesToForestUnsafe = fromJust . nestedParenthesesToForest--nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())-nestedParenthesesToBinaryTree ps = -  case parseForest ps of -    (rest,forest) -> case rest of-      [] -> Just forest-      _  -> Nothing-  where  -    parseForest :: [Paren] -> ( [Paren] , BinTree () )-    parseForest ps = let (rest,ts) = unfoldEither parseTree ps in (rest , foldr Branch leaf ts)-    parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )  -    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of-      (RightParen:qs) -> Right (qs, ts)-      _ -> Left orig-    parseTree qs = Left qs-    -nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()-nestedParenthesesToBinaryTreeUnsafe = fromJust . nestedParenthesesToBinaryTree--binaryTreeToNestedParentheses :: BinTree a -> [Paren]-binaryTreeToNestedParentheses = worker where-  worker (Branch l r) = LeftParen : worker l ++ RightParen : worker r-  worker (Leaf _) = []--binaryTreeToForest :: BinTree a -> Forest ()-binaryTreeToForest = worker where-  worker (Branch l r) = Node () (worker l) : worker r-  worker (Leaf _) = []------------------------------------------------------------ * Nested parentheses---- | Synonym for 'fasc4A_algorithm_P'.-nestedParentheses :: Int -> [[Paren]]-nestedParentheses = fasc4A_algorithm_P---- | Synonym for 'fasc4A_algorithm_W'.-randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)-randomNestedParentheses = fasc4A_algorithm_W---- | Synonym for 'fasc4A_algorithm_U'.-nthNestedParentheses :: Int -> Integer -> [Paren]-nthNestedParentheses = fasc4A_algorithm_U--countNestedParentheses :: Int -> Integer-countNestedParentheses = countBinaryTrees---- | Generates all sequences of nested parentheses of length 2n.--- Order is lexigraphic (when right parentheses are considered --- smaller then left ones).--- 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 1 = [[LeftParen,RightParen]]-fasc4A_algorithm_P n = unfold next ( start , [] ) where -  start = concat $ replicate n [RightParen,LeftParen]  -- already reversed!-   -  next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )-  next ( (a:b:ls) , [] ) = next ( ls , b:a:[] )-  next ( lls@(l:ls) , rrs@(r:rs) ) = ( visit , new ) where-    visit = reverse lls ++ rrs-    new = -      {- debug (reverse ls,l,r,rs) $ -} -      case l of -	      RightParen -> Just ( ls , LeftParen:RightParen:rs )-	      LeftParen  -> -	        {- debug ("---",reverse ls,l,r,rs) $ -}-	        findj ( lls , [] ) ( reverse (RightParen:rs) , [] ) --  findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])-  findj ( [] , _ ) _ = Nothing-  findj ( lls@(l:ls) , rs) ( xs , ys ) = -    {- debug ((reverse ls,l,rs),(reverse xs,ys)) $ -}-    case l of-	    LeftParen  -> case xs of-	      (a:_:as) -> findj ( ls, RightParen:rs ) ( as , LeftParen:a:ys )-	      _ -> findj ( lls, [] ) ( reverse rs ++ xs , ys) -	    RightParen -> Just ( reverse ys ++ xs ++ reverse (LeftParen:rs) ++ ls , [] )-    --- | Generates a uniformly random sequence of nested parentheses of length 2n.    --- Based on \"Algorithm W\" in Knuth.-fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)-fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where-  n = fromIntegral n' :: Integer  -  -- the numbers we use are of order n^2, so for n >> 2^16 -  -- on a 32 bit machine, we need big integers.-  worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)-  worker (rnd,_,0,parens) = (parens,rnd)-  worker (rnd,p,q,parens) = -    if x<(q+1)*(q-p) -      then worker (rnd' , p   , q-1 , LeftParen :parens)-      else worker (rnd' , p-1 , q   , RightParen:parens)-    where -      (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd---- | Nth sequence of nested parentheses of length 2n. --- The order is the same as in 'fasc4A_algorithm_P'.--- Based on \"Algorithm U\" in Knuth.-fasc4A_algorithm_U -  :: Int               -- ^ n-  -> Integer           -- ^ N; should satisfy 1 <= N <= C(n) -  -> [Paren]-fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where-  n = fromIntegral n' :: Integer-  c0 = foldl f 1 [2..n]  -  f c p = ((4*p-2)*c) `div` (p+1) -  worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]-  worker (_   ,_,_,0,parens) = parens-  worker (bign,c,p,q,parens) = -    if bign <= c' -      then worker (bign    , c'   , p   , q-1 , RightParen:parens)-      else worker (bign-c' , c-c' , p-1 , q   , LeftParen :parens)-    where-      c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1))-  ----------------------------------------------------------- * Binary trees---- | Generates all binary trees with n nodes. ---   At the moment just a synonym for 'binaryTreesNaive'.-binaryTrees :: Int -> [BinTree ()]-binaryTrees = binaryTreesNaive---- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }.------ This is also the counting function for forests and nested parentheses.-countBinaryTrees :: Int -> Integer-countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n)-    --- | Generates all binary trees with n nodes. The naive algorithm.-binaryTreesNaive :: Int -> [BinTree ()]-binaryTreesNaive 0 = [ leaf ]-binaryTreesNaive n = -  [ Branch l r -  | i <- [0..n-1] -  , l <- binaryTreesNaive i -  , r <- binaryTreesNaive (n-1-i) -  ]---- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'.-randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)-randomBinaryTree n rnd = (tree,rnd') where-  (decorated,rnd') = fasc4A_algorithm_R n rnd      -  tree = fmap (const ()) $ forgetNodeDecorations decorated+module Math.Combinat.Trees+  ( module Math.Combinat.Trees.Binary+  , module Math.Combinat.Trees.Nary+  ) where --- | Grows a uniformly random binary tree. --- \"Algorithm R\" (Remy's procudere) in Knuth.--- Nodes are decorated with odd numbers, leaves with even numbers (from the--- set @[0..2n]@). Uses mutable arrays internally.-fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)-fasc4A_algorithm_R n0 rnd = res where-  res = runST $ do-    ar <- newArray (0,2*n0) 0-    rnd' <- worker rnd 1 ar-    links <- unsafeFreeze ar-    return (toTree links, rnd')-  toTree links = f (links!0) where-    f i = if odd i -      then Branch' (f $ links!i) i (f $ links!(i+1)) -      else Leaf' i  -  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g-  worker rnd n ar = do -    if n > n0-      then return rnd-      else do-        writeArray ar (n2-b)   n2-        lk <- readArray ar k-        writeArray ar (n2-1+b) lk-        writeArray ar k        (n2-1)-        worker rnd' (n+1) ar      -    where  -      n2 = n+n-      (x,rnd') = randomR (0,4*n-3) rnd-      (k,b) = x `divMod` 2-      --------------------------------------------------------      -  +import Math.Combinat.Trees.Binary+import Math.Combinat.Trees.Nary 

@@ -0,0 +1,333 @@++-- | Binary trees, forests, etc. See:+--   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A.++module Math.Combinat.Trees.Binary +  ( -- * Types+    BinTree(..)+  , leaf+  , BinTree'(..)+  , forgetNodeDecorations+  , module Data.Tree +  , Paren(..)+  , parenthesesToString+  , stringToParentheses+    -- * Bijections+  , forestToNestedParentheses+  , forestToBinaryTree+  , nestedParenthesesToForest+  , nestedParenthesesToForestUnsafe+  , nestedParenthesesToBinaryTree+  , nestedParenthesesToBinaryTreeUnsafe+  , binaryTreeToForest+  , binaryTreeToNestedParentheses+    -- * Nested parentheses+  , nestedParentheses +  , randomNestedParentheses+  , nthNestedParentheses+  , countNestedParentheses+  , fasc4A_algorithm_P+  , fasc4A_algorithm_W+  , fasc4A_algorithm_U+    -- * Binary trees+  , binaryTrees+  , countBinaryTrees+  , binaryTreesNaive+  , randomBinaryTree+  , fasc4A_algorithm_R+  ) +  where++--------------------------------------------------------------------------------++import Control.Applicative+import Control.Monad+import Control.Monad.ST++import Data.Array+import Data.Array.ST++import Data.List+import Data.Tree (Tree(..),Forest(..))++import Data.Monoid+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++import System.Random++import Math.Combinat.Helper+import Math.Combinat.Numbers (factorial,binomial)++--------------------------------------------------------------------------------+-- * Types++-- | A binary tree with leaves decorated with type @a@.+data BinTree a+  = Branch (BinTree a) (BinTree a)+  | Leaf a+  deriving (Eq,Ord,Show,Read)++leaf :: BinTree ()+leaf = Leaf ()++-- | A binary tree with leaves and internal nodes decorated +-- with types @a@ and @b@, respectively.+data BinTree' a b+  = Branch' (BinTree' a b) b (BinTree' a b)+  | Leaf' a+  deriving (Eq,Ord,Show,Read)++forgetNodeDecorations :: BinTree' a b -> BinTree a+forgetNodeDecorations (Branch' left _ right) = +  Branch (forgetNodeDecorations left) (forgetNodeDecorations right)+forgetNodeDecorations (Leaf' decor) = Leaf decor ++--------------------------------------------------------------------------------+  +instance Functor BinTree where+  fmap f (Branch left right) = Branch (fmap f left) (fmap f right)+  fmap f (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)  ++instance Traversable BinTree where+  traverse f (Leaf x) = Leaf <$> f x+  traverse f (Branch left right) = Branch <$> traverse f left <*> traverse f right++--------------------------------------------------------------------------------++data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read)++parenToChar :: Paren -> Char+parenToChar LeftParen = '('+parenToChar RightParen = ')'++parenthesesToString :: [Paren] -> String+parenthesesToString = map parenToChar++stringToParentheses :: String -> [Paren]+stringToParentheses [] = []+stringToParentheses (x:xs) = p : stringToParentheses xs where+  p = case x of+    '(' -> LeftParen+    ')' -> RightParen+    _ -> error "stringToParentheses: invalid character"++--------------------------------------------------------------------------------+-- * Bijections++forestToNestedParentheses :: Forest a -> [Paren]+forestToNestedParentheses = forest where+  -- forest :: Forest a -> [Paren]+  forest = concatMap tree +  -- tree :: Tree a -> [Paren]+  tree (Node _ sf) = LeftParen : forest sf ++ [RightParen]++forestToBinaryTree :: Forest a -> BinTree ()+forestToBinaryTree = forest where+  -- forest :: Forest a -> BinTree ()+  forest = foldr Branch leaf . map tree +  -- tree :: Tree a -> BinTree ()+  tree (Node _ sf) = case sf of+    [] -> leaf+    _  -> forest sf +   +nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())+nestedParenthesesToForest ps = +  case parseForest ps of +    (rest,forest) -> case rest of+      [] -> Just forest+      _  -> Nothing+  where  +    parseForest :: [Paren] -> ( [Paren] , Forest () )+    parseForest ps = unfoldEither parseTree ps+    parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )  +    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of+      (RightParen:qs) -> Right (qs, Node () ts)+      _ -> Left orig+    parseTree qs = Left qs++nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()+nestedParenthesesToForestUnsafe = fromJust . nestedParenthesesToForest++nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())+nestedParenthesesToBinaryTree ps = +  case parseForest ps of +    (rest,forest) -> case rest of+      [] -> Just forest+      _  -> Nothing+  where  +    parseForest :: [Paren] -> ( [Paren] , BinTree () )+    parseForest ps = let (rest,ts) = unfoldEither parseTree ps in (rest , foldr Branch leaf ts)+    parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )  +    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of+      (RightParen:qs) -> Right (qs, ts)+      _ -> Left orig+    parseTree qs = Left qs+    +nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()+nestedParenthesesToBinaryTreeUnsafe = fromJust . nestedParenthesesToBinaryTree++binaryTreeToNestedParentheses :: BinTree a -> [Paren]+binaryTreeToNestedParentheses = worker where+  worker (Branch l r) = LeftParen : worker l ++ RightParen : worker r+  worker (Leaf _) = []++binaryTreeToForest :: BinTree a -> Forest ()+binaryTreeToForest = worker where+  worker (Branch l r) = Node () (worker l) : worker r+  worker (Leaf _) = []++--------------------------------------------------------------------------------+-- * Nested parentheses++-- | Synonym for 'fasc4A_algorithm_P'.+nestedParentheses :: Int -> [[Paren]]+nestedParentheses = fasc4A_algorithm_P++-- | Synonym for 'fasc4A_algorithm_W'.+randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)+randomNestedParentheses = fasc4A_algorithm_W++-- | Synonym for 'fasc4A_algorithm_U'.+nthNestedParentheses :: Int -> Integer -> [Paren]+nthNestedParentheses = fasc4A_algorithm_U++countNestedParentheses :: Int -> Integer+countNestedParentheses = countBinaryTrees++-- | Generates all sequences of nested parentheses of length 2n.+-- Order is lexigraphic (when right parentheses are considered +-- smaller then left ones).+-- 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 1 = [[LeftParen,RightParen]]+fasc4A_algorithm_P n = unfold next ( start , [] ) where +  start = concat $ replicate n [RightParen,LeftParen]  -- already reversed!+   +  next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )+  next ( (a:b:ls) , [] ) = next ( ls , b:a:[] )+  next ( lls@(l:ls) , rrs@(r:rs) ) = ( visit , new ) where+    visit = reverse lls ++ rrs+    new = +      {- debug (reverse ls,l,r,rs) $ -} +      case l of +	      RightParen -> Just ( ls , LeftParen:RightParen:rs )+	      LeftParen  -> +	        {- debug ("---",reverse ls,l,r,rs) $ -}+	        findj ( lls , [] ) ( reverse (RightParen:rs) , [] ) ++  findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])+  findj ( [] , _ ) _ = Nothing+  findj ( lls@(l:ls) , rs) ( xs , ys ) = +    {- debug ((reverse ls,l,rs),(reverse xs,ys)) $ -}+    case l of+	    LeftParen  -> case xs of+	      (a:_:as) -> findj ( ls, RightParen:rs ) ( as , LeftParen:a:ys )+	      _ -> findj ( lls, [] ) ( reverse rs ++ xs , ys) +	    RightParen -> Just ( reverse ys ++ xs ++ reverse (LeftParen:rs) ++ ls , [] )+    +-- | Generates a uniformly random sequence of nested parentheses of length 2n.    +-- Based on \"Algorithm W\" in Knuth.+fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)+fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where+  n = fromIntegral n' :: Integer  +  -- the numbers we use are of order n^2, so for n >> 2^16 +  -- on a 32 bit machine, we need big integers.+  worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)+  worker (rnd,_,0,parens) = (parens,rnd)+  worker (rnd,p,q,parens) = +    if x<(q+1)*(q-p) +      then worker (rnd' , p   , q-1 , LeftParen :parens)+      else worker (rnd' , p-1 , q   , RightParen:parens)+    where +      (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd++-- | Nth sequence of nested parentheses of length 2n. +-- The order is the same as in 'fasc4A_algorithm_P'.+-- Based on \"Algorithm U\" in Knuth.+fasc4A_algorithm_U +  :: Int               -- ^ n+  -> Integer           -- ^ N; should satisfy 1 <= N <= C(n) +  -> [Paren]+fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where+  n = fromIntegral n' :: Integer+  c0 = foldl f 1 [2..n]  +  f c p = ((4*p-2)*c) `div` (p+1) +  worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]+  worker (_   ,_,_,0,parens) = parens+  worker (bign,c,p,q,parens) = +    if bign <= c' +      then worker (bign    , c'   , p   , q-1 , RightParen:parens)+      else worker (bign-c' , c-c' , p-1 , q   , LeftParen :parens)+    where+      c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1))+  +--------------------------------------------------------------------------------+-- * Binary trees++-- | Generates all binary trees with n nodes. +--   At the moment just a synonym for 'binaryTreesNaive'.+binaryTrees :: Int -> [BinTree ()]+binaryTrees = binaryTreesNaive++-- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }.+--+-- This is also the counting function for forests and nested parentheses.+countBinaryTrees :: Int -> Integer+countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n)+    +-- | Generates all binary trees with n nodes. The naive algorithm.+binaryTreesNaive :: Int -> [BinTree ()]+binaryTreesNaive 0 = [ leaf ]+binaryTreesNaive n = +  [ Branch l r +  | i <- [0..n-1] +  , l <- binaryTreesNaive i +  , r <- binaryTreesNaive (n-1-i) +  ]++-- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'.+randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)+randomBinaryTree n rnd = (tree,rnd') where+  (decorated,rnd') = fasc4A_algorithm_R n rnd      +  tree = fmap (const ()) $ forgetNodeDecorations decorated++-- | Grows a uniformly random binary tree. +-- \"Algorithm R\" (Remy's procudere) in Knuth.+-- Nodes are decorated with odd numbers, leaves with even numbers (from the+-- set @[0..2n]@). Uses mutable arrays internally.+fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)+fasc4A_algorithm_R n0 rnd = res where+  res = runST $ do+    ar <- newArray (0,2*n0) 0+    rnd' <- worker rnd 1 ar+    links <- unsafeFreeze ar+    return (toTree links, rnd')+  toTree links = f (links!0) where+    f i = if odd i +      then Branch' (f $ links!i) i (f $ links!(i+1)) +      else Leaf' i  +  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g+  worker rnd n ar = do +    if n > n0+      then return rnd+      else do+        writeArray ar (n2-b)   n2+        lk <- readArray ar k+        writeArray ar (n2-1+b) lk+        writeArray ar k        (n2-1)+        worker rnd' (n+1) ar      +    where  +      n2 = n+n+      (x,rnd') = randomR (0,4*n-3) rnd+      (k,b) = x `divMod` 2+      +--------------------------------------------------------------------------------      +  +

@@ -0,0 +1,101 @@++-- | N-ary trees.++module Math.Combinat.Trees.Nary +  ( +    derivTrees+    -- * unique labels+  , addUniqueLabelsTree+  , addUniqueLabelsForest+  , addUniqueLabelsTree_+  , addUniqueLabelsForest_+    -- * labelling by depth+  , labelDepthTree+  , labelDepthForest+  , labelDepthTree_+  , labelDepthForest_+  ) where+++--------------------------------------------------------------------------------++import Data.Tree++import Control.Applicative+import Control.Monad.State+import Data.Traversable (traverse)++import Math.Combinat.Sets (listTensor)+import Math.Combinat.Partitions (partitionMultiset)++--------------------------------------------------------------------------------++-- | Adds unique labels to a 'Tree'.+addUniqueLabelsTree :: Tree a -> Tree (a,Int) +addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree])++-- | Adds unique labels to a 'Forest'+addUniqueLabelsForest :: Forest a -> Forest (a,Int) +addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where+  globalAction tree = +    unwrapMonad $ traverse localAction tree +  localAction x = WrapMonad $ do+    i <- get+    put (i+1)+    return (x,i)++addUniqueLabelsTree_ :: Tree a -> Tree Int+addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree  ++addUniqueLabelsForest_ :: Forest a -> Forest Int+addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest+    +-- | Attaches the depth to each node. The depth of the root is 0. +labelDepthTree :: Tree a -> Tree (a,Int) +labelDepthTree tree = worker 0 tree where+  worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees)++labelDepthForest :: Forest a -> Forest (a,Int) +labelDepthForest forest = map labelDepthTree forest+    +labelDepthTree_ :: Tree a -> Tree Int+labelDepthTree_ = fmap snd . labelDepthTree++labelDepthForest_ :: Forest a -> Forest Int +labelDepthForest_ = map (fmap snd) . labelDepthForest+    +--------------------------------------------------------------------------------++-- | Computes the set of equivalence classes of trees (in the +-- sense that the leaves of a node are /unordered/) +-- with @n = length ks@ leaves where the set of heights of +-- the leaves matches the given set of numbers. +-- The height is defined as the number of /edges/ from the leaf to the root. +--+-- TODO: better name?+derivTrees :: [Int] -> [Tree ()]+derivTrees xs = derivTrees' (map (+1) xs)++derivTrees' :: [Int] -> [Tree ()]+derivTrees' [] = []+derivTrees' [n] = +  if n>=1 +    then [unfoldTree f 1] +    else [] +  where +    f k = if k<n then ((),[k+1]) else ((),[])+derivTrees' ks = +  if and (map (>0) ks)+    then+      [ Node () sub +      | part <- parts+      , let subtrees = map g part+      , sub <- listTensor subtrees +      ] +    else []+  where+    parts = partitionMultiset ks+    g xs = derivTrees' (map (\x->x-1) xs)++--------------------------------------------------------------------------------+    

@@ -1,5 +1,5 @@ Name:                combinat-Version:             0.2.2+Version:             0.2.3 Synopsis:            Generation of various combinatorial objects. Description:         A collection of functions to generate combinatorial                      objects like partitions, combinations, permutations,@@ -29,10 +29,10 @@ Library   if flag(splitBase)     if flag(base4)-      Build-Depends:       base >= 4 && < 5, array, containers, random+      Build-Depends:       base >= 4 && < 5, array, containers, random, mtl       cpp-options:         -DBASE_VERSION=4     else -      Build-Depends:       base >= 3 && < 4, array, containers, random+      Build-Depends:       base >= 3 && < 4, array, containers, random, mtl       cpp-options:         -DBASE_VERSION=3     if flag(withQuickCheck)       Build-Depends:       QuickCheck@@ -51,6 +51,9 @@                        Math.Combinat.Tableaux,                        Math.Combinat.Tableaux.Kostka,                        Math.Combinat.Trees+                       Math.Combinat.Trees.Binary+                       Math.Combinat.Trees.Nary+                       Math.Combinat.Graphviz      Other-Modules:       Math.Combinat.Helper