diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2008, Balazs Komuves +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither names of the copyright holders nor the names of the contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Math/Combinat.hs b/Math/Combinat.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat.hs @@ -0,0 +1,40 @@ + +-- | A collection of functions to generate combinatorial +-- objects like partitions, combinations, permutations, +-- Young tableaux, various trees, etc. +-- +-- The long-term goals are +-- +-- (1) to be efficient; +-- +-- (2) to be able to enumerate the structures +-- with constant memory usage. +-- +-- The short-term goal is to generate +-- many interesting structures. +-- +-- Naming conventions (subject to change): +-- +-- * prime suffix: additional constrains, typically more general; +-- +-- * underscore prefix: use plain lists instead of other types with +-- enforced invariants; +-- +-- * \"count\" prefix: counting functions. + +module Math.Combinat + ( module Math.Combinat.Tuples + , module Math.Combinat.Combinations + , module Math.Combinat.Partitions + , module Math.Combinat.Permutations + , module Math.Combinat.Tableaux + , module Math.Combinat.Trees + ) where + +import Math.Combinat.Tuples +import Math.Combinat.Combinations +import Math.Combinat.Partitions +import Math.Combinat.Permutations +import Math.Combinat.Tableaux +import Math.Combinat.Trees + diff --git a/Math/Combinat/Combinations.hs b/Math/Combinat/Combinations.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Combinations.hs @@ -0,0 +1,59 @@ + +-- | Combinations + +module Math.Combinat.Combinations where + +import Math.Combinat.Helper + +------------------------------------------------------- + +-- | 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/Helper.hs b/Math/Combinat/Helper.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Helper.hs @@ -0,0 +1,63 @@ + +module Math.Combinat.Helper where + +import Debug.Trace + +debug :: Show a => a -> b -> b +debug x y = trace (show x) y + +fromJust :: Maybe a -> a +fromJust (Just x) = x +fromJust Nothing = error "fromJust: Nothing" + +-- iterated function application +nest :: Int -> (a -> a) -> a -> a +nest 0 _ x = x +nest n f x = nest (n-1) f (f x) + +reverseOrdering :: Ordering -> Ordering +reverseOrdering LT = GT +reverseOrdering GT = LT +reverseOrdering EQ = EQ + +reverseCompare :: Ord a => a -> a -> Ordering +reverseCompare x y = reverseOrdering $ compare x y + +factorial :: Int -> Integer +factorial 0 = 1 +factorial n = product [1..fromIntegral n] + +binomial :: Int -> Int -> Integer +binomial n k + | k > n = 0 + | k < 0 = 0 + | k > (n `div` 2) = binomial n (n-k) + | otherwise = (product [n'-k'+1 .. n']) `div` (product [1..k']) + where + k' = fromIntegral k + n' = fromIntegral n + +intToBool :: Int -> Bool +intToBool 0 = False +intToBool 1 = True +intToBool _ = error "intToBool" + +boolToInt :: Bool -> Int +boolToInt False = 0 +boolToInt True = 1 + +unfold1 :: (a -> Maybe a) -> a -> [a] +unfold1 f x = case f x of + Nothing -> [x] + Just y -> x : unfold1 f y + +unfold :: (b -> (a,Maybe b)) -> b -> [a] +unfold f y = let (x,m) = f y in case m of + Nothing -> [x] + Just y' -> x : unfold f y' + +unfoldEither :: (b -> Either c (b,a)) -> b -> (c,[a]) +unfoldEither f y = case f y of + Left z -> (z,[]) + Right (y,x) -> let (z,xs) = unfoldEither f y in (z,x:xs) + diff --git a/Math/Combinat/Partitions.hs b/Math/Combinat/Partitions.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Partitions.hs @@ -0,0 +1,148 @@ + +-- | Partitions. Partitions are nonincreasing sequences of positive integers. + +module Math.Combinat.Partitions + ( -- * Type and basic stuff + Partition + , toPartition + , toPartitionUnsafe + , mkPartition + , isPartition + , fromPartition + , height + , width + , heightWidth + , weight + , _dualPartition + , dualPartition + -- * Generation + , _partitions' + , partitions' + , countPartitions' + , _partitions + , partitions + , countPartitions + , allPartitions' + , allPartitions + , countAllPartitions' + , countAllPartitions + ) + where + +import Data.List +import Math.Combinat.Helper + +------------------------------------------------------- + +-- | 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. +mkPartition :: [Int] -> Partition +mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs + +-- | Assumes that the input is decreasing. +toPartitionUnsafe :: [Int] -> Partition +toPartitionUnsafe = Partition + +-- | Checks whether the input is a partition. +toPartition :: [Int] -> Partition +toPartition xs = if isPartition xs + then toPartitionUnsafe xs + else error "toPartition: not a partition" + +isPartition :: [Int] -> Bool +isPartition [] = True +isPartition [_] = True +isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs + +fromPartition :: Partition -> [Int] +fromPartition (Partition part) = part + +-- | The first element of the sequence. +height :: Partition -> Int +height (Partition part) = case part of + (p:_) -> p + [] -> 0 + +-- | The length of the sequence. +width :: Partition -> Int +width (Partition part) = length part + +heightWidth :: Partition -> (Int,Int) +heightWidth part = (height part, width part) + +-- | The weight of the partition +-- (that is, the sum of the corresponding sequence). +weight :: Partition -> Int +weight (Partition part) = sum part + +-- | The dual (or conjugate) partition. +dualPartition :: Partition -> Partition +dualPartition (Partition part) = Partition (_dualPartition part) + +-- (we could be more efficient, but it hardly matters) +_dualPartition :: [Int] -> [Int] +_dualPartition [] = [] +_dualPartition xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ] + +------------------------------------------------------- + +-- | Partitions of d, fitting into a given rectangle, as lists. +_partitions' + :: (Int,Int) -- ^ (height,width) + -> Int -- ^ d + -> [[Int]] +_partitions' _ 0 = [[]] +_partitions' (0,_) d = if d==0 then [[]] else [] +_partitions' (_,0) d = if d==0 then [[]] else [] +_partitions' (h,w) d = + [ i:xs | i <- [1..min d h] , xs <- _partitions' (i,w-1) (d-i) ] + +-- | Partitions of d, fitting into a given rectangle. The order is again lexicographic. +partitions' + :: (Int,Int) -- ^ (height,width) + -> Int -- ^ d + -> [Partition] +partitions' hw d = map toPartitionUnsafe $ _partitions' hw d + +countPartitions' :: (Int,Int) -> Int -> Integer +countPartitions' _ 0 = 1 +countPartitions' (0,_) d = if d==0 then 1 else 0 +countPartitions' (_,0) d = if d==0 then 1 else 0 +countPartitions' (h,w) d = sum + [ countPartitions' (i,w-1) (d-i) | i <- [1..min d h] ] + +-- | Partitions of d, as lists +_partitions :: Int -> [[Int]] +_partitions d = _partitions' (d,d) d + +-- | Partitions of d. +partitions :: Int -> [Partition] +partitions d = partitions' (d,d) d + +countPartitions :: Int -> Integer +countPartitions d = countPartitions' (d,d) d + +-- | All partitions fitting into a given rectangle. +allPartitions' + :: (Int,Int) -- ^ (height,width) + -> [[Partition]] +allPartitions' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w + +-- | All partitions up to a given degree. +allPartitions :: Int -> [[Partition]] +allPartitions d = [ partitions i | i <- [0..d] ] + +-- | # = \\binom { h+w } { h } +countAllPartitions' :: (Int,Int) -> Integer +countAllPartitions' (h,w) = + binomial (h+w) (min h w) + --sum [ countPartitions' (h,w) i | i <- [0..d] ] where d = h*w + +countAllPartitions :: Int -> Integer +countAllPartitions d = sum [ countPartitions i | i <- [0..d] ] + +------------------------------------------------------- + diff --git a/Math/Combinat/Permutations.hs b/Math/Combinat/Permutations.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Permutations.hs @@ -0,0 +1,86 @@ + +-- | Permutations. See: +-- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B. +-- +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Math.Combinat.Permutations where + +import Data.List +import Data.Array + +import Math.Combinat.Helper + +------------------------------------------------------- +{- +-- * Types + +-- | Standard notation for permutations +newtype Permutation = Permutation (Array Int Int) deriving (Eq,Ord,Show,Read) + +-- | Disjoint cycle notation for permutations +newtype DisjCycles = DisjCycles [[Int]] deriving (Eq,Ord,Show,Read) +-} + +------------------------------------------------------- +-- * Permutations of distinct elements + +-- | Permutations of [1..n] in lexicographic order, naive algorithm. +_permutations :: Int -> [[Int]] +_permutations 0 = [[]] +_permutations 1 = [[1]] +_permutations n = helper [1..n] where + helper [] = [[]] + helper xs = [ i : ys | i <- xs , ys <- helper (xs `minus` i) ] + minus [] _ = [] + minus (x:xs) i = if x < i then x : minus xs i else xs + +{- +permutations :: Int -> [Permutation] +permutations n = map toPermutationUnsafe $ _permutations n +-} + +-- | # = n! +countPermutations :: Int -> Integer +countPermutations = factorial + +------------------------------------------------------- +-- * Permutations of a multiset + +-- | Generates all permutations of a multiset. +-- The order is lexicographic. +permute :: (Eq a, Ord a) => [a] -> [[a]] +permute = fasc2B_algorithm_L + +-- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) } +countPermute :: (Eq a, Ord a) => [a] -> Integer +countPermute xs = factorial n `div` product [ factorial (length z) | z <- group ys ] + where + ys = sort xs + n = length xs + +-- | Generates all permutations of a multiset +-- (based on \"algorithm L\" in Knuth; somewhat less efficient). +-- The order is lexicographic. +fasc2B_algorithm_L :: (Eq a, Ord a) => [a] -> [[a]] +fasc2B_algorithm_L xs = unfold1 next (sort xs) where + -- next :: [a] -> Maybe [a] + next xs = case findj (reverse xs,[]) of + Nothing -> Nothing + Just ( (l:ls) , rs) -> Just $ inc l ls (reverse rs,[]) + Just ( [] , _ ) -> error "permute: should not happen" + + -- we use simple list zippers: (left,right) + -- findj :: ([a],[a]) -> Maybe ([a],[a]) + findj ( xxs@(x:xs) , yys@(y:_) ) = if x >= y + then findj ( xs , x : yys ) + else Just ( xxs , yys ) + findj ( x:xs , [] ) = findj ( xs , [x] ) + findj ( [] , _ ) = Nothing + + -- inc :: a -> [a] -> ([a],[a]) -> [a] + inc u us ( (x:xs) , yys ) = if u >= x + then inc u us ( xs , x : yys ) + else reverse (x:us) ++ reverse (u:yys) ++ xs + inc _ _ ( [] , _ ) = error "permute: should not happen" + +------------------------------------------------------- diff --git a/Math/Combinat/Tableaux.hs b/Math/Combinat/Tableaux.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Tableaux.hs @@ -0,0 +1,118 @@ + +-- | Young tableaux and similar gadgets. +-- See e.g. William Fulton: Young Tableaux, with Applications to +-- Representation theory and Geometry (CUP 1997). +-- +-- The convention is that we use +-- the English notation, and we store the tableaux as lists of the rows. +-- +-- That is, the following standard tableau of shape [5,4,1] +-- +-- > 1 3 4 6 7 +-- > 2 5 8 10 +-- > 9 +-- +-- is encoded conveniently as +-- +-- > [ [ 1 , 3 , 4 , 6 , 7 ] +-- > , [ 2 , 5 , 8 ,10 ] +-- > , [ 9 ] +-- > ] +-- + +module Math.Combinat.Tableaux where + +import Data.List + +import Math.Combinat.Helper +import Math.Combinat.Partitions + +------------------------------------------------------- +-- * Basic stuff + +type Tableau a = [[a]] + +_shape :: Tableau a -> [Int] +_shape t = map length t + +shape :: Tableau a -> Partition +shape t = toPartition (_shape t) + +dualTableau :: Tableau a -> Tableau a +dualTableau = transpose + +hooks :: Partition -> Tableau Int +hooks part = zipWith f p [1..] where + p = fromPartition part + q = _dualPartition p + f l i = zipWith (\x y -> x+y-i) q [l,l-1..1] + +------------------------------------------------------- +-- * Row and column words + +rowWord :: Tableau a -> [a] +rowWord = concat . reverse + +rowWordToTableau :: Ord a => [a] -> Tableau a +rowWordToTableau xs = reverse rows where + rows = break xs + break [] = [[]] + break [x] = [[x]] + break (x:xs@(y:_)) = if x>y + then [x] : break xs + else let (h:t) = break xs in (x:h):t + +columnWord :: Tableau a -> [a] +columnWord = rowWord . transpose + +columnWordToTableau :: Ord a => [a] -> Tableau a +columnWordToTableau = transpose . rowWordToTableau + +------------------------------------------------------- +-- * Standard Young tableaux + +-- | Standard Young tableaux of a given shape. +-- Adapted from John Stembridge, +-- . +standardYoungTableaux :: Partition -> [Tableau Int] +standardYoungTableaux shape' = map rev $ tableaux shape where + shape = fromPartition shape' + rev = reverse . map reverse + tableaux :: [Int] -> [Tableau Int] + tableaux p = + case p of + [] -> [[]] + [n] -> [[[n,n-1..1]]] + _ -> worker (n,k) 0 [] p + where + n = sum p + k = length p + worker :: (Int,Int) -> Int -> [Int] -> [Int] -> [Tableau Int] + worker _ _ _ [] = [] + worker nk i ls (x:rs) = case rs of + (y:_) -> if x==y + then worker nk (i+1) (x:ls) rs + else worker2 nk i ls x rs + [] -> worker2 nk i ls x rs + worker2 :: (Int,Int) -> Int -> [Int] -> Int -> [Int] -> [Tableau Int] + worker2 nk@(n,k) i ls x rs = new ++ worker nk (i+1) (x:ls) rs where + old = if x>1 + then tableaux $ reverse ls ++ (x-1) : rs + else map ([]:) $ tableaux $ reverse ls ++ rs + a = k-1-i + new = {- debug ( i , a , head old , f a (head old) ) $ -} + map (f a) old + f :: Int -> Tableau Int -> Tableau Int + f _ [] = [] + f 0 (t:ts) = (n:t) : f (-1) ts + f j (t:ts) = t : f (j-1) ts + +-- | hook-length formula +countStandardYoungTableaux :: Partition -> Integer +countStandardYoungTableaux part = {- debug (hooks part) $ -} + factorial n `div` h where + h = product $ map fromIntegral $ concat $ hooks part + n = weight part + +------------------------------------------------------- + diff --git a/Math/Combinat/Trees.hs b/Math/Combinat/Trees.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Trees.hs @@ -0,0 +1,259 @@ + +-- | Trees, forests, etc. See: +-- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A. + +module Math.Combinat.Trees + ( -- * Types + BinTree(..) + , leaf + , module Data.Tree + , Paren(..) + , parenthesesToString + , stringToParentheses + -- * Bijections + , forestToNestedParentheses + , forestToBinaryTree + , nestedParenthesesToForest + , nestedParenthesesToForestUnsafe + , nestedParenthesesToBinaryTree + , nestedParenthesesToBinaryTreeUnsafe + , binaryTreeToForest + , binaryTreeToNestedParentheses + -- * Nested parentheses + , nestedParentheses + , fasc4A_algorithm_P + -- * Binary trees + , binaryTrees + , countBinaryTrees + , binaryTreesNaive + ) + where + +import Data.List +import Data.Tree (Tree(..),Forest(..)) + +import Math.Combinat.Helper + +------------------------------------------------------- +-- * Types + +data BinTree a + = Branch (BinTree a) (BinTree a) + | Leaf a + deriving (Eq,Ord,Show,Read) + +leaf :: BinTree () +leaf = Leaf () + +------------------------------------------------------- + +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 + +-- | 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 , [] ) + + +------------------------------------------------------- +-- * Binary trees + +-- | Generates all binary trees with n nodes. +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) + ] + +----- binary tree zipper + +data Ctx a + = Top + | L (Ctx a) (BinTree a) + | R (BinTree a) (Ctx a) + +type Loc a = (BinTree a, Ctx a) + +left :: Loc a -> Loc a +left (Branch l r , c) = (l , L c r) +left (Leaf _ , _) = error "left: Leaf" + +right :: Loc a -> Loc a +right (Branch l r , c) = (r , R l c) +right (Leaf _ , _) = error "right: Leaf" + +top :: BinTree a -> Loc a +top t = (t, Top) + +up :: Loc a -> Loc a +up (t, L c r) = (Branch t r, c) +up (t, R l c) = (Branch l t, c) +up (t, Top ) = error "up: top" + +upmost :: Loc a -> Loc a +upmost l@(t, Top) = l +upmost l = upmost (up l) + +modify :: (BinTree a -> BinTree a) -> Loc a -> Loc a +modify f (t, c) = (f t, c) + +----- + +{- +-- | Generates all binary trees with n nodes. +-- Based on \"Algorithm B\" in Knuth, uses tree zippers. +fasc4A_algorithm_B :: Int -> [BinTree ()] +fasc4A_algorithm_B 0 = [ leaf ] +fasc4A_algorithm_B n = unfold1 next start where + start = nest n (\t -> Branch t leaf) leaf + + killLeft (Branch _ r) = Branch leaf r + killRight (Branch l _) = Branch l leaf + + next t = case findj (top t) of + Nothing -> Nothing + Just locj@(s,c) -> case findk (top s) of + lock@(u,Top) -> Just $ promote (modify killLeft locj ) lock + lock@(u,_ ) -> Just $ promote locj (modify killRight lock) + + findj :: Loc () -> Maybe (Loc ()) + findj (Branch (Leaf _) t , c) = case t of + Branch l r -> findj $ left (Branch t leaf , c) + Leaf _ -> Nothing + findj loc@(Leaf _ , c) = Just loc + + findk :: Loc () -> Loc () + findk loc@( Branch l (Leaf _) , _) = loc + findk loc@( Branch l r , _) = findk (right loc) + + promote :: Loc () -> Loc () -> BinTree () + promote locj lock = undefined +-} diff --git a/Math/Combinat/Tuples.hs b/Math/Combinat/Tuples.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Tuples.hs @@ -0,0 +1,61 @@ + +-- | Tuples. + +module Math.Combinat.Tuples where + +import Math.Combinat.Helper + +------------------------------------------------------- +-- Tuples + +-- | \"Tuples\" fitting into a give shape. The order is lexicographic, that is, +-- +-- > sort ts == ts where ts = tuples' shape +-- +-- Example: +-- +-- > tuples' [2,3] = +-- > [[0,0],[0,1],[0,2],[0,3],[1,0],[1,1],[1,2],[1,3],[2,0],[2,1],[2,2],[2,3]] +-- +tuples' :: [Int] -> [[Int]] +tuples' [] = [[]] +tuples' (s:ss) = [ x:xs | x <- [0..s] , xs <- tuples' ss ] + +-- | positive \"tuples\" fitting into a give shape. +tuples1' :: [Int] -> [[Int]] +tuples1' [] = [[]] +tuples1' (s:ss) = [ x:xs | x <- [1..s] , xs <- tuples1' ss ] + +-- | # = \\prod_i (m_i + 1) +countTuples' :: [Int] -> Integer +countTuples' shape = product $ map f shape where + f k = 1 + fromIntegral k + +-- | # = \\prod_i m_i +countTuples1' :: [Int] -> Integer +countTuples1' shape = product $ map fromIntegral shape + +tuples + :: Int -- ^ length (width) + -> Int -- ^ maximum (height) + -> [[Int]] +tuples len k = tuples' (replicate len k) + +tuples1 + :: Int -- ^ length (width) + -> Int -- ^ maximum (height) + -> [[Int]] +tuples1 len k = tuples1' (replicate len k) + +-- | # = (m+1) ^ len +countTuples :: Int -> Int -> Integer +countTuples len k = (1 + fromIntegral k) ^ len + +-- | # = m ^ len +countTuples1 :: Int -> Int -> Integer +countTuples1 len k = fromIntegral k ^ len + +binaryTuples :: Int -> [[Bool]] +binaryTuples len = map (map intToBool) (tuples len 1) + +------------------------------------------------------- diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/combinat.cabal b/combinat.cabal new file mode 100644 --- /dev/null +++ b/combinat.cabal @@ -0,0 +1,41 @@ +Name: combinat +Version: 0.1 +Synopsis: Generation of various combinatorial objects. +Description: A collection of functions to generate combinatorial + objects like partitions, combinations, permutations, + Young tableaux, various trees, etc. +License: BSD3 +License-file: LICENSE +Author: Balazs Komuves +Copyright: (c) 2008 Balazs Komuves +Maintainer: bkomuves (plus) hackage (at) gmail (dot) com +Stability: Unstable +--Portability: Portable +Category: Math +Tested-With: GHC == 6.8.3 +Cabal-Version: >= 1.2 +Build-Type: Simple + +Flag splitBase + Description: Choose the new smaller, split-up base package. + +Library + if flag(splitBase) + Build-Depends: base >= 3, array, containers + else + Build-Depends: base < 3 + + Exposed-Modules: Math.Combinat, + Math.Combinat.Tuples, + Math.Combinat.Combinations, + Math.Combinat.Partitions, + Math.Combinat.Permutations, + Math.Combinat.Tableaux, + Math.Combinat.Trees + + Other-Modules: Math.Combinat.Helper + + Hs-Source-Dirs: . + + ghc-options: -Wall -fno-warn-unused-matches +