diff --git a/Math/Combinat.hs b/Math/Combinat.hs --- a/Math/Combinat.hs +++ b/Math/Combinat.hs @@ -3,7 +3,12 @@ -- objects like partitions, compositions, permutations, -- Young tableaux, various trees, etc etc. -- +-- +-- See also the @combinat-diagrams@ library for generating +-- graphical representations of these structure using +-- the @diagrams@ library (). -- +-- -- The long-term goals are -- -- (1) generate most of the standard structures; @@ -48,7 +53,7 @@ , module Math.Combinat.Tableaux , module Math.Combinat.Trees , module Math.Combinat.LatticePaths - , module Math.Combinat.Graphviz + , module Math.Combinat.ASCII ) where import Math.Combinat.Numbers @@ -60,4 +65,4 @@ import Math.Combinat.Tableaux import Math.Combinat.Trees import Math.Combinat.LatticePaths -import Math.Combinat.Graphviz +import Math.Combinat.ASCII diff --git a/Math/Combinat/ASCII.hs b/Math/Combinat/ASCII.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/ASCII.hs @@ -0,0 +1,296 @@ + +-- | A mini-DSL for ASCII drawing of structures. +-- +-- +-- From some structures there is also Graphviz and\/or @diagrams@ +-- () visualization support +-- (the latter in the separate libray @combinat-diagrams@). +-- + +module Math.Combinat.ASCII where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * The basic type + +-- | The type of a (rectangular) ASCII figure. +-- Internally it is a list of lines of the same length plus the size. +-- +-- Note: The Show instance is pretty-printing, so that it\'s convenient in ghci. +-- +data ASCII = ASCII + { asciiSize :: (Int,Int) + , asciiLines :: [String] + } + +instance Show ASCII where + show = asciiString + +-- | An empty (0x0) rectangle +emptyRect :: ASCII +emptyRect = ASCII (0,0) [] + +asciiXSize, asciiYSize :: ASCII -> Int +asciiXSize = fst . asciiSize +asciiYSize = snd . asciiSize + +asciiString :: ASCII -> String +asciiString (ASCII sz ls) = unlines ls + +printASCII :: ASCII -> IO () +printASCII = putStrLn . asciiString + +asciiFromLines :: [String] -> ASCII +asciiFromLines ls = ASCII (x,y) (map f ls) where + y = length ls + x = maximum (map length ls) + f l = l ++ replicate (x - length l) ' ' + +asciiFromString :: String -> ASCII +asciiFromString = asciiFromLines . lines + +-------------------------------------------------------------------------------- +-- * Alignment + +-- | Horizontal alignment +data HAlign + = HLeft + | HCenter + | HRight + deriving (Eq,Show) + +-- | Vertical alignment +data VAlign + = VTop + | VCenter + | VBottom + deriving (Eq,Show) + +data Alignment = Align HAlign VAlign + +-------------------------------------------------------------------------------- +-- * Extension + +-- | Extends an ASCII figure with spaces horizontally to the given width +hExtendTo :: HAlign -> Int -> ASCII -> ASCII +hExtendTo halign n0 rect@(ASCII (x,y) ls) = hExtendWith halign (max n0 x - x) rect + +-- | Extends an ASCII figure with spaces vertically to the given height +vExtendTo :: VAlign -> Int -> ASCII -> ASCII +vExtendTo valign n0 rect@(ASCII (x,y) ls) = vExtendWith valign (max n0 y - y) rect + +-- | Extend horizontally with the given number of spaces +hExtendWith :: HAlign -> Int -> ASCII -> ASCII +hExtendWith alignment d (ASCII (x,y) ls) = ASCII (x+d,y) (map f ls) where + f l = case alignment of + HLeft -> l ++ replicate d ' ' + HRight -> replicate d ' ' ++ l + HCenter -> replicate a ' ' ++ l ++ replicate (d-a) ' ' + a = div d 2 + +-- | Extend vertically with the given number of empty lines +vExtendWith :: VAlign -> Int -> ASCII -> ASCII +vExtendWith valign d (ASCII (x,y) ls) = ASCII (x,y+d) (f ls) where + f ls = case valign of + VTop -> ls ++ replicate d emptyline + VBottom -> replicate d emptyline ++ ls + VCenter -> replicate a emptyline ++ ls ++ replicate (d-a) emptyline + a = div d 2 + emptyline = replicate x ' ' + +-- | Horizontal indentation +hIndent :: Int -> ASCII -> ASCII +hIndent d = hExtendWith HRight d + +-- | Vertical indentation +vIndent :: Int -> ASCII -> ASCII +vIndent d = vExtendWith VBottom d + +-------------------------------------------------------------------------------- +-- * Separators + +-- | Horizontal separator +data HSep + = HSepEmpty -- ^ empty separator + | HSepSpaces Int -- ^ @n@ spaces + | HSepString String -- ^ some custom string, eg. @\" | \"@ + deriving Show + +hSepSize :: HSep -> Int +hSepSize hsep = case hsep of + HSepEmpty -> 0 + HSepSpaces k -> k + HSepString s -> length s + +hSepString :: HSep -> String +hSepString hsep = case hsep of + HSepEmpty -> "" + HSepSpaces k -> replicate k ' ' + HSepString s -> s + +-- | Vertical separator +data VSep + = VSepEmpty -- ^ empty separator + | VSepSpaces Int -- ^ @n@ spaces + | VSepString [Char] -- ^ some custom list of characters, eg. @\" - \"@ (the characters are interpreted as below each other) + deriving Show + +vSepSize :: VSep -> Int +vSepSize vsep = case vsep of + VSepEmpty -> 0 + VSepSpaces k -> k + VSepString s -> length s + +vSepString :: VSep -> [Char] +vSepString vsep = case vsep of + VSepEmpty -> [] + VSepSpaces k -> replicate k ' ' + VSepString s -> s + +-------------------------------------------------------------------------------- +-- * Padding + +-- | Horizontally pads with the given number of spaces, on both sides +hPad :: Int -> ASCII -> ASCII +hPad k (ASCII (x,y) ls) = ASCII (x+2*k,y) (map f ls) where + f l = pad ++ l ++ pad + pad = replicate k ' ' + +-- | Vertically pads with the given number of empty lines, on both sides +vPad :: Int -> ASCII -> ASCII +vPad k (ASCII (x,y) ls) = ASCII (x,y+2*k) (pad ++ ls ++ pad) where + pad = replicate k (replicate x ' ') + +-- | Pads by single empty lines vertically and two spaces horizontally +pad :: ASCII -> ASCII +pad = vPad 1 . hPad 2 + +-------------------------------------------------------------------------------- +-- * Concatenation + +-- | Horizontal concatenation +hCatWith :: VAlign -> HSep -> [ASCII] -> ASCII +hCatWith valign hsep rects = ASCII (x',maxy) final where + n = length rects + maxy = maximum [ y | ASCII (_,y) _ <- rects ] + xsz = [ x | ASCII (x,_) _ <- rects ] + sep = hSepString hsep + sepx = length sep + rects1 = map (vExtendTo valign maxy) rects + x' = sum' xsz + (n-1)*sepx + final = map (intercalate sep) $ transpose (map asciiLines rects1) + +-- | Vertical concatenation +vCatWith :: HAlign -> VSep -> [ASCII] -> ASCII +vCatWith halign vsep rects = ASCII (maxx,y') final where + n = length rects + maxx = maximum [ x | ASCII (x,_) _ <- rects ] + ysz = [ y | ASCII (_,y) _ <- rects ] + sepy = vSepSize vsep + fullsep = transpose (replicate maxx $ vSepString vsep) :: [String] + rects1 = map (hExtendTo halign maxx) rects + y' = sum' ysz + (n-1)*sepy + final = intercalate fullsep $ map asciiLines rects1 + +-------------------------------------------------------------------------------- +-- * Tabulate + +tabulate :: (HAlign,VAlign) -> (HSep,VSep) -> [[ASCII]] -> ASCII +tabulate (halign,valign) (hsep,vsep) rects0 = final where + n = length rects0 + m = maximum (map length rects0) + rects1 = map (\rs -> rs ++ replicate (m - length rs) emptyRect) rects0 + ys = map (\rs -> maximum (map asciiYSize rs)) rects1 + xs = map (\rs -> maximum (map asciiXSize rs)) (transpose rects1) + rects2 = map (\rs -> [ hExtendTo halign x r | (x,r ) <- zip xs rs ]) rects1 + rects3 = [ map (vExtendTo valign y) rs | (y,rs) <- zip ys rects2 ] + final = vCatWith HLeft vsep + $ map (hCatWith VTop hsep) rects3 + +-- | Order of elements in a matrix +data MatrixOrder + = RowMajor + | ColMajor + deriving (Eq,Ord,Show,Read) + +-- | Automatically tabulates ASCII rectangles. +-- +autoTabulate + :: MatrixOrder -- ^ whether to use row-major or column-major ordering of the elements + -> Either Int Int -- ^ @(Right x)@ creates x columns, while @(Left y)$ creates y rows + -> [ASCII] -- ^ list of ASCII rectangles + -> ASCII +autoTabulate mtxorder ei list = final where + + final = tabulate (HLeft,VBottom) (HSepSpaces 2,VSepSpaces 1) rects + + n = length list + + rects = case ei of + + Left y -> case mtxorder of + ColMajor -> transpose (parts y list) + RowMajor -> invparts y list + + Right x -> case mtxorder of + ColMajor -> transpose (invparts x list) + RowMajor -> parts x list + + transposeIf b = if b then transpose else id + + -- chops into parts (the last one can be smaller) + parts d = go where + go [] = [] + go xs = take d xs : go (drop d xs) + + invparts d xs = parts' ds xs where + (q,r) = divMod n d + ds = replicate r (q+1) ++ replicate (d-r) q + + parts' ds xs = go ds xs where + go _ [] = [] + go [] _ = [] + go (d:ds) xs = take d xs : go ds (drop d xs) + +-------------------------------------------------------------------------------- +-- * Captions + +-- | Adds a caption to the bottom, with default settings. +caption :: String -> ASCII -> ASCII +caption = caption' False HLeft + +-- | Adds a caption to the bottom. The @Bool@ flag specifies whether to add an empty between +-- the caption and the figure +caption' :: Bool -> HAlign -> String -> ASCII -> ASCII +caption' emptyline halign str rect = vCatWith halign sep [rect,capt] where + sep = if emptyline then VSepSpaces 1 else VSepEmpty + capt = asciiFromString str + +-------------------------------------------------------------------------------- +-- * Testing \/ miscellanea + +-- | An ASCII box of the given size +asciiBox :: (Int,Int) -> ASCII +asciiBox (x,y) = ASCII (max x 2, max y 2) (h : replicate (y-2) m ++ [h]) where + h = "+" ++ replicate (x-2) '-' ++ "+" + m = "|" ++ replicate (x-2) ' ' ++ "|" + +-- | An \"rounded\" ASCII box of the given size +roundedAsciiBox :: (Int,Int) -> ASCII +roundedAsciiBox (x,y) = ASCII (max x 2, max y 2) (a : replicate (y-2) m ++ [b]) where + a = "/" ++ replicate (x-2) '-' ++ "\\" + m = "|" ++ replicate (x-2) ' ' ++ "|" + b = "\\" ++ replicate (x-2) '-' ++ "/" + +asciiNumber :: Int -> ASCII +asciiNumber = asciiShow + +asciiShow :: Show a => a -> ASCII +asciiShow = asciiFromLines . (:[]) . show + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Graphviz.hs b/Math/Combinat/Graphviz.hs deleted file mode 100644 --- a/Math/Combinat/Graphviz.hs +++ /dev/null @@ -1,115 +0,0 @@ - --- | 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 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 -- ^ make the individual trees clustered subgraphs - -> Bool -- ^ reverse the direction of the arrows - -> String -- ^ name of the graph - -> Forest a - -> Dot -forestDot clustered revarrows 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') _) = if not revarrows - then name unique ++ " -> " ++ name unique' - else name unique' ++ " -> " ++ name unique - --- | Generates graphviz @.dot@ file from a tree. The first argument is --- the name of the graph. -treeDot - :: Show a - => Bool -- ^ reverse the direction of the arrow - -> String -- ^ name of the graph - -> Tree a - -> Dot -treeDot revarrows 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') _) = if not revarrows - then name unique ++ " -> " ++ name unique' - else name unique' ++ " -> " ++ name unique - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Helper.hs b/Math/Combinat/Helper.hs --- a/Math/Combinat/Helper.hs +++ b/Math/Combinat/Helper.hs @@ -93,7 +93,7 @@ go b (x : xs) = f b False x : go False xs -------------------------------------------------------------------------------- --- * helpers for ASCII drawing +-- * older helpers for ASCII drawing -- | extend lines with spaces so that they have the same line mkLinesUniformWidth :: [String] -> [String] diff --git a/Math/Combinat/LatticePaths.hs b/Math/Combinat/LatticePaths.hs --- a/Math/Combinat/LatticePaths.hs +++ b/Math/Combinat/LatticePaths.hs @@ -1,15 +1,23 @@ -- | Dyck paths, lattice paths, etc +-- +-- For example, the following figure represents a Dyck path of height 5 with 3 zero-touches (not counting the starting point, +-- but counting the endpoint) and 7 peaks: +-- +-- <> +-- {-# LANGUAGE BangPatterns #-} module Math.Combinat.LatticePaths where -------------------------------------------------------------------------------- +import Data.List import System.Random import Math.Combinat.Numbers import Math.Combinat.Trees.Binary +import Math.Combinat.ASCII as ASCII -------------------------------------------------------------------------------- -- * Types @@ -29,7 +37,30 @@ type LatticePath = [Step] -------------------------------------------------------------------------------- +-- * ascii drawing of paths +-- | Draws the path into a list of lines. For example try: +-- +-- > autotabulate RowMajor (Right 5) (map asciiPath $ dyckPaths 4) +-- +asciiPath :: LatticePath -> ASCII +asciiPath p = asciiFromLines $ transpose (go 0 p) where + + go !h [] = [] + go !h (x:xs) = case x of + UpStep -> ee h x : go (h+1) xs + DownStep -> ee (h-1) x : go (h-1) xs + + maxh = pathHeight p + + ee h x = replicate (maxh-h-1) ' ' ++ [ch x] ++ replicate h ' ' + ch x = case x of + UpStep -> '/' + DownStep -> '\\' + +-------------------------------------------------------------------------------- +-- * elementary queries + -- | A lattice path is called \"valid\", if it never goes below the @y=0@ line. isValidPath :: LatticePath -> Bool isValidPath = go 0 where @@ -71,6 +102,25 @@ y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } in (x',y') : go x' y' ts +-- | Counts the up-steps +pathNumberOfUpSteps :: LatticePath -> Int +pathNumberOfUpSteps = fst . pathNumberOfUpDownSteps + +-- | Counts the down-steps +pathNumberOfDownSteps :: LatticePath -> Int +pathNumberOfDownSteps = snd . pathNumberOfUpDownSteps + +-- | Counts both the up-steps and down-steps +pathNumberOfUpDownSteps :: LatticePath -> (Int,Int) +pathNumberOfUpDownSteps = go 0 0 where + go !u !d (p:ps) = case p of + UpStep -> go (u+1) d ps + DownStep -> go u (d+1) ps + go !u !d [] = (u,d) + +-------------------------------------------------------------------------------- +-- * path-specific queries + -- | Number of peaks of a path (excluding the endpoint) pathNumberOfPeaks :: LatticePath -> Int pathNumberOfPeaks = go 0 where @@ -94,7 +144,6 @@ cnt' = if y'==h then cnt+1 else cnt in go cnt' (x+1) y' ts - -------------------------------------------------------------------------------- -- * Dyck paths @@ -204,6 +253,12 @@ as = [ UpStep : p | p <- worker (x-1) (y-1) ] bs = [ bracket p ++ q | k <- [1..(div x 2)] , p <- dyckPaths (k-1) , q <- worker (x-2*k) y ] +-- | Lattice paths are counted by the numbers in the Catalan triangle. +countLatticePaths :: (Int,Int) -> Integer +countLatticePaths (x,y) + | even (x+y) = catalanTriangle (div (x+y) 2) (div (x-y) 2) + | otherwise = 0 + -------------------------------------------------------------------------------- -- * Zero-level touches @@ -211,7 +266,7 @@ -- zero level line @y=0@ exactly @k@ times (excluding the starting point, but including the endpoint; -- thus, @k@ should be positive). Synonym for 'touchingDyckPathsNaive'. touchingDyckPaths - :: Int -- ^ @k@ = number of touches + :: Int -- ^ @k@ = number of zero-touches -> Int -- ^ @m@ = half-length -> [LatticePath] touchingDyckPaths = touchingDyckPathsNaive @@ -226,7 +281,7 @@ -- Naive recursive algorithm, resulting order is pretty ad-hoc. -- touchingDyckPathsNaive - :: Int -- ^ @k@ = number of touches + :: Int -- ^ @k@ = number of zero-touches -> Int -- ^ @m@ = half-length -> [LatticePath] touchingDyckPathsNaive = worker where @@ -238,6 +293,18 @@ | otherwise = [ bracket p ++ q | l <- [1..m-1] , p <- dyckPaths (l-1) , q <- worker (k-1) (m-l) ] where bracket p = UpStep : p ++ [DownStep] + + +-- | There is a bijection from the set of non-empty Dyck paths of length @2n@ which touch the zero lines @t@ times, +-- to lattice paths from @(0,0)@ to @(2n-t-1,t-1)@ (just remove all the down-steps just before touching +-- the zero line, and also the very first up-step). This gives us a counting formula. +countTouchingDyckPaths + :: Int -- ^ @k@ = number of zero-touches + -> Int -- ^ @m@ = half-length + -> Integer +countTouchingDyckPaths t n + | t==0 && n==0 = 1 + | otherwise = countLatticePaths (2*n-t-1,t-1) -------------------------------------------------------------------------------- -- * Dyck paths with given number of peaks diff --git a/Math/Combinat/Numbers.hs b/Math/Combinat/Numbers.hs --- a/Math/Combinat/Numbers.hs +++ b/Math/Combinat/Numbers.hs @@ -81,7 +81,7 @@ catalanTriangle n k | k > n = 0 | k < 0 = 0 - | otherwise = binomial (n+k) n * fromIntegral (n-k+1) `div` fromIntegral (n+1) + | otherwise = (binomial (n+k) n * fromIntegral (n-k+1)) `div` fromIntegral (n+1) -------------------------------------------------------------------------------- -- * Stirling numbers diff --git a/Math/Combinat/Partitions.hs b/Math/Combinat/Partitions.hs --- a/Math/Combinat/Partitions.hs +++ b/Math/Combinat/Partitions.hs @@ -11,340 +11,12 @@ {-# LANGUAGE BangPatterns #-} module Math.Combinat.Partitions - ( -- * Type and basic stuff - Partition - , toPartition - , toPartitionUnsafe - , mkPartition - , isPartition - , fromPartition - , height - , width - , heightWidth - , weight - , dualPartition - , _dualPartition - , elements - , _elements - , countAutomorphisms - , _countAutomorphisms - , HasNumberOfParts(..) - -- * Generation - , partitions' - , _partitions' - , countPartitions' - , partitions - , _partitions - , countPartitions - , partitionsWithKParts - , allPartitions' - , allPartitions - , countAllPartitions' - , countAllPartitions - , countPartitionsWithKParts - -- * Ferrer diagrams - , printFerrerDiagram - , ferrerDiagram - , ferrerDiagramEnglishNotation - , ferrerDiagramFrenchNotation - , ferrerDiagramEnglishNotation' - , ferrerDiagramFrenchNotation' - -- * Paritions of multisets, vector partitions - , partitionMultiset - , IntVector - , vectorPartitions - , _vectorPartitions - , fasc3B_algorithm_M - ) + ( module Math.Combinat.Partitions.Integer + ) where -import Data.List -import Data.Array.Unboxed - -import Math.Combinat.Helper -import Math.Combinat.Numbers (factorial,binomial,multinomial) - -------------------------------------------------------------------------------- --- | A partition of an integer. 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, and cuts the nonpositive elements. -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 an integer 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 -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] ] - --- | Example: --- --- > 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) --- > ] -elements :: Partition -> [(Int,Int)] -elements (Partition part) = _elements part - -_elements :: [Int] -> [(Int,Int)] -_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] - --- | Computes the number of \"automorphisms\" of a given integer partition. -countAutomorphisms :: Partition -> Integer -countAutomorphisms = _countAutomorphisms . fromPartition - -_countAutomorphisms :: [Int] -> Integer -_countAutomorphisms = multinomial . map length . group - ---------------------------------------------------------------------------------- - -class HasNumberOfParts p where - numberOfParts :: p -> Int - -instance HasNumberOfParts Partition where - numberOfParts (Partition p) = length p - ---------------------------------------------------------------------------------- - --- | Integer 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 integer 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 integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@) -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] ] - --------------------------------------------------------------------------------- --- partitions with given number of parts - --- | Lists partitions of @n@ into @k@ parts. --- --- > sort (partitionsWithKParts k n) == sort [ p | p <- partitions n , numberOfParts p == k ] --- --- Naive recursive algorithm. --- -partitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = the integer we partition - -> [Partition] -partitionsWithKParts k n = map Partition $ go n k n where -{- - h = max height - k = number of parts - n = integer --} - go !h !k !n - | k < 0 = [] - | k == 0 = if h>=0 && n==0 then [[] ] else [] - | k == 1 = if h>=n && n>=1 then [[n]] else [] - | otherwise = [ a:p | a <- [1..(min h (n-k+1))] , p <- go a (k-1) (n-a) ] - -countPartitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = the integer we partition - -> Integer -countPartitionsWithKParts k n = go n k n where - go !h !k !n - | k < 0 = 0 - | k == 0 = if h>=0 && n==0 then 1 else 0 - | k == 1 = if h>=n && n>=1 then 1 else 0 - | otherwise = sum' [ go a (k-1) (n-a) | a<-[1..(min h (n-k+1))] ] - - --------------------------------------------------------------------------------- --- * Ferrer diagrams - -printFerrerDiagram :: Partition -> IO () -printFerrerDiagram = putStrLn . ferrerDiagram - --- | Synonym for 'ferrerDiagramEnglishNotation' -ferrerDiagram :: Partition -> String -ferrerDiagram = ferrerDiagramEnglishNotation - -ferrerDiagramEnglishNotation :: Partition -> String -ferrerDiagramEnglishNotation = ferrerDiagramEnglishNotation' '@' - -ferrerDiagramFrenchNotation :: Partition -> String -ferrerDiagramFrenchNotation = ferrerDiagramFrenchNotation' '@' - -ferrerDiagramEnglishNotation' :: Char -> Partition -> String -ferrerDiagramEnglishNotation' ch part = unlines (map f ys) where - ys = fromPartition part - f n = replicate n ch - -ferrerDiagramFrenchNotation' :: Char -> Partition -> String -ferrerDiagramFrenchNotation' ch part = unlines (map f ys) where - ys = reverse $ fromPartition $ dualPartition part - f n = replicate n ch - --------------------------------------------------------------------------------- - --- | 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 "fasc3B_algorithm_M: 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 +import Math.Combinat.Partitions.Integer -------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Integer.hs b/Math/Combinat/Partitions/Integer.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Partitions/Integer.hs @@ -0,0 +1,334 @@ + +-- | Partitions of integers. +-- Integer partitions are nonincreasing sequences of positive integers. +-- +-- See: +-- +-- * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B. +-- +-- * +-- +-- For example the partition +-- +-- > Partition [8,6,3,3,1] +-- +-- can be represented by the (English notation) Ferrers diagram: +-- +-- <> +-- + +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Partitions.Integer where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Helper +import Math.Combinat.ASCII as ASCII +import Math.Combinat.Numbers (factorial,binomial,multinomial) + +-------------------------------------------------------------------------------- +-- * Type and basic stuff + +-- | A partition of an integer. The additional invariant enforced here is that partitions +-- are monotone decreasing sequences of positive integers. The @Ord@ instance is lexicographical. +newtype Partition = Partition [Int] deriving (Eq,Ord,Show,Read) + +--------------------------------------------------------------------------------- + +class HasNumberOfParts p where + numberOfParts :: p -> Int + +instance HasNumberOfParts Partition where + numberOfParts (Partition p) = length p + +--------------------------------------------------------------------------------- + +-- | Sorts the input, and cuts the nonpositive elements. +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 an integer 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 +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] ] + +-- | Example: +-- +-- > 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) +-- > ] +-- +elements :: Partition -> [(Int,Int)] +elements (Partition part) = _elements part + +_elements :: [Int] -> [(Int,Int)] +_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] + +--------------------------------------------------------------------------------- +-- * Automorphisms + +-- | Computes the number of \"automorphisms\" of a given integer partition. +countAutomorphisms :: Partition -> Integer +countAutomorphisms = _countAutomorphisms . fromPartition + +_countAutomorphisms :: [Int] -> Integer +_countAutomorphisms = multinomial . map length . group + +--------------------------------------------------------------------------------- +-- * Dominance order + +-- | @q \`dominates\` p@ returns @True@ if @q >= p@ in the dominance order of partitions +-- (this is partial ordering on the set of partitions of @n@). +-- +-- See +-- +dominates :: Partition -> Partition -> Bool +dominates (Partition qs) (Partition ps) + = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) + where + sums = scanl (+) 0 + +--------------------------------------------------------------------------------- +-- * Generating partitions + +-- | Integer 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 integer 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 integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@) +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] ] + +-------------------------------------------------------------------------------- +-- * Partitions with given number of parts + +-- | Lists partitions of @n@ into @k@ parts. +-- +-- > sort (partitionsWithKParts k n) == sort [ p | p <- partitions n , numberOfParts p == k ] +-- +-- Naive recursive algorithm. +-- +partitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = the integer we partition + -> [Partition] +partitionsWithKParts k n = map Partition $ go n k n where +{- + h = max height + k = number of parts + n = integer +-} + go !h !k !n + | k < 0 = [] + | k == 0 = if h>=0 && n==0 then [[] ] else [] + | k == 1 = if h>=n && n>=1 then [[n]] else [] + | otherwise = [ a:p | a <- [1..(min h (n-k+1))] , p <- go a (k-1) (n-a) ] + +countPartitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = the integer we partition + -> Integer +countPartitionsWithKParts k n = go n k n where + go !h !k !n + | k < 0 = 0 + | k == 0 = if h>=0 && n==0 then 1 else 0 + | k == 1 = if h>=n && n>=1 then 1 else 0 + | otherwise = sum' [ go a (k-1) (n-a) | a<-[1..(min h (n-k+1))] ] + + +-------------------------------------------------------------------------------- +-- * Sub-partitions of a given partition + +-- | Returns @True@ of the first partition is a subpartition (that is, fit inside) of the second. +-- This includes equality +isSubPartitionOf :: Partition -> Partition -> Bool +isSubPartitionOf (Partition ps) (Partition qs) = and $ zipWith (<=) ps (qs ++ repeat 0) + +---------------------------------------- + +-- | Sub-partitions of a given partition with the given weight: +-- +-- > sort (subPartitions d q) == sort [ p | p <- partitions d, isSubPartitionOf p q ] +-- +subPartitions :: Int -> Partition -> [Partition] +subPartitions d (Partition ps) = map Partition (_subPartitions d ps) + +_subPartitions :: Int -> [Int] -> [[Int]] +_subPartitions d big + | null big = if d==0 then [[]] else [] + | d > sum' big = [] + | d < 0 = [] + | otherwise = go d (head big) big + where + go :: Int -> Int -> [Int] -> [[Int]] + go !k !h [] = if k==0 then [[]] else [] + go !k !h (b:bs) + | k<0 || h<0 = [] + | k==0 = [[]] + | h==0 = [] + | otherwise = [ this:rest | this <- [1..min h b] , rest <- go (k-this) this bs ] + +---------------------------------------- + +-- | All sub-partitions of a given partition +allSubPartitions :: Partition -> [Partition] +allSubPartitions (Partition ps) = map Partition (_allSubPartitions ps) + +_allSubPartitions :: [Int] -> [[Int]] +_allSubPartitions big + | null big = [[]] + | otherwise = go (head big) big + where + go _ [] = [[]] + go !h (b:bs) + | h==0 = [] + | otherwise = [] : [ this:rest | this <- [1..min h b] , rest <- go this bs ] + +-------------------------------------------------------------------------------- +-- * ASCII Ferrers diagrams + +-- | Which orientation to draw the Ferrers diagrams. +-- For example, the partition [5,4,1] corrsponds to: +-- +-- In standard English notation: +-- +-- > @@@@@ +-- > @@@@ +-- > @ +-- +-- +-- In English notation rotated by 90 degrees counter-clockwise: +-- +-- > @ +-- > @@ +-- > @@ +-- > @@ +-- > @@@ +-- +-- +-- And in French notation: +-- +-- +-- > @ +-- > @@@@ +-- > @@@@@ +-- +-- +data PartitionConvention + = EnglishNotation -- ^ English notation + | EnglishNotationCCW -- ^ English notation rotated by 90 degrees counterclockwise + | FrenchNotation -- ^ French notation (mirror of English notation to the x axis) + deriving (Eq,Show) + +-- | Synonym for @asciiFerrersDiagram\' EnglishNotation \'\@\'@ +-- +-- Try for example: +-- +-- > autoTabulate RowMajor (Right 8) (map asciiFerrersDiagram $ partitions 9) +-- +asciiFerrersDiagram :: Partition -> ASCII +asciiFerrersDiagram = asciiFerrersDiagram' EnglishNotation '@' + +asciiFerrersDiagram' :: PartitionConvention -> Char -> Partition -> ASCII +asciiFerrersDiagram' conv ch part = ASCII.asciiFromLines (map f ys) where + f n = replicate n ch + ys = case conv of + EnglishNotation -> fromPartition part + EnglishNotationCCW -> reverse $ fromPartition $ dualPartition part + FrenchNotation -> reverse $ fromPartition $ part + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Multiset.hs b/Math/Combinat/Partitions/Multiset.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Partitions/Multiset.hs @@ -0,0 +1,24 @@ + +-- | Partitions of a multiset +module Math.Combinat.Partitions.Multiset where + +-------------------------------------------------------------------------------- + +import Data.Array.Unboxed +import Data.List + +import Math.Combinat.Partitions.Vector + +-------------------------------------------------------------------------------- + +-- | Partitions of a multiset. Internally, this uses the vector partition algorithm +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 + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/NonCrossing.hs b/Math/Combinat/Partitions/NonCrossing.hs --- a/Math/Combinat/Partitions/NonCrossing.hs +++ b/Math/Combinat/Partitions/NonCrossing.hs @@ -3,6 +3,16 @@ -- -- See eg. -- +-- Non-crossing partitions of the set @[1..n]@ are encoded as lists of lists +-- in standard form: Entries decreasing in each block and blocks listed in increasing order of their first entries. +-- For example the partition in the diagram +-- +-- <> +-- +-- is represented as +-- +-- > NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] +-- {-# LANGUAGE BangPatterns #-} module Math.Combinat.Partitions.NonCrossing where diff --git a/Math/Combinat/Partitions/Plane.hs b/Math/Combinat/Partitions/Plane.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Partitions/Plane.hs @@ -0,0 +1,116 @@ + +-- | Plane partitions. See eg. +-- +-- Plane partitions are encoded as lists of lists of Z heights. For example the plane +-- partition in the picture +-- +-- <> +-- +-- is encoded as +-- +-- > PlanePart [ [5,4,3,3,1] +-- > , [4,4,2,1] +-- > , [3,2] +-- > , [2,1] +-- > , [1] +-- > , [1] +-- > ] +-- +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Partitions.Plane where + +-------------------------------------------------------------------------------- + +import Data.List +import Data.Array + +import Math.Combinat.Partitions +import Math.Combinat.Tableaux as Tableaux +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * the type of plane partitions + +-- | A plane partition encoded as a tablaeu (the \"Z\" heights are the numbers) +newtype PlanePart = PlanePart [[Int]] deriving (Eq,Ord,Show) + +fromPlanePart :: PlanePart -> [[Int]] +fromPlanePart (PlanePart xs) = xs + +isValidPlanePart :: [[Int]] -> Bool +isValidPlanePart pps = + and [ table!(i,j) >= table!(i ,j+1) && + table!(i,j) >= table!(i+1,j ) + | i<-[0..y-1] , j<-[0..x-1] + ] + where + table :: Array (Int,Int) Int + table = accumArray const 0 ((0,0),(y,x)) [ ((i,j),k) | (i,ps) <- zip [0..] pps , (j,k) <- zip [0..] ps ] + y = length pps + x = maximum (map length pps) + +-- | Throws an exception if the input is not a plane partition +toPlanePart :: [[Int]] -> PlanePart +toPlanePart pps = if isValidPlanePart pps + then PlanePart $ filter (not . null) $ map (filter (>0)) $ pps + else error "toPlanePart: not a plane partition" + +-- | The XY projected shape of a plane partition, as an integer partition +planePartShape :: PlanePart -> Partition +planePartShape = Tableaux.shape . fromPlanePart + +-- | The Z height of a plane partition +planePartZHeight :: PlanePart -> Int +planePartZHeight (PlanePart xs) = + case xs of + ((h:_):_) -> h + _ -> 0 + +planePartWeight :: PlanePart -> Int +planePartWeight (PlanePart xs) = sum' (map sum' xs) + +-------------------------------------------------------------------------------- +-- * constructing plane partitions + +singleLayer :: Partition -> PlanePart +singleLayer = PlanePart . map (\k -> replicate k 1) . fromPartition + +-- | Stacks layers of partitions into a plane partition. +-- Throws an exception if they do not form a plane partition. +stackLayers :: [Partition] -> PlanePart +stackLayers layers = if and [ isSubPartitionOf p q | (q,p) <- pairs layers ] + then unsafeStackLayers layers + else error "stackLayers: the layers do not form a plane partition" + +-- | Stacks layers of partitions into a plane partition. +-- This is unsafe in the sense that we don't check that the partitions fit on the top of each other. +unsafeStackLayers :: [Partition] -> PlanePart +unsafeStackLayers [] = PlanePart [] +unsafeStackLayers (bottom:rest) = PlanePart $ foldl addLayer (fromPlanePart $ singleLayer bottom) rest where + addLayer :: [[Int]] -> Partition -> [[Int]] + addLayer xxs (Partition ps) = [ zipWith (+) xs (replicate p 1 ++ repeat 0) | (xs,p) <- zip xxs (ps ++ repeat 0) ] + +-- | The \"layers\" of a plane partition (in direction @Z@). We should have +-- +-- > unsafeStackLayers (planePartLayers pp) == pp +-- +planePartLayers :: PlanePart -> [Partition] +planePartLayers pp@(PlanePart xs) = [ layer h | h<-[1..planePartZHeight pp] ] where + layer h = Partition $ filter (>0) $ map sum' $ (map . map) (f h) xs + f h = \k -> if k>=h then 1 else 0 + +-------------------------------------------------------------------------------- +-- * generating plane partitions + +-- | Plane partitions of a given weight +planePartitions :: Int -> [PlanePart] +planePartitions d + | d < 0 = [] + | d == 0 = [PlanePart []] + | otherwise = concat [ go (d-n) [p] | n<-[1..d] , p<-partitions n ] + where + go :: Int -> [Partition] -> [PlanePart] + go 0 acc = [unsafeStackLayers (reverse acc)] + go !rem acc@(h:_) = concat [ go (rem-k) (this:acc) | k<-[1..rem] , this <- subPartitions k h ] + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Vector.hs b/Math/Combinat/Partitions/Vector.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Partitions/Vector.hs @@ -0,0 +1,82 @@ + +-- | Vector partitions. See: +-- +-- * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B. +-- + +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Partitions.Vector where + +-------------------------------------------------------------------------------- + +import Data.Array.Unboxed +import Data.List + +-------------------------------------------------------------------------------- + +-- | 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 "fasc3B_algorithm_M: 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 + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Tableaux.hs b/Math/Combinat/Tableaux.hs --- a/Math/Combinat/Tableaux.hs +++ b/Math/Combinat/Tableaux.hs @@ -6,11 +6,13 @@ -- 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] +-- That is, the following standard Young tableau of shape [5,4,1] -- -- > 1 3 4 6 7 -- > 2 5 8 10 -- > 9 +-- +-- <> -- -- is encoded conveniently as -- 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 @@ -1,27 +1,24 @@ -- | Binary trees, forests, etc. See: -- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A. +-- +-- For example, here are all the binary trees on 4 nodes: +-- +-- <> +-- module Math.Combinat.Trees.Binary ( -- * Types BinTree(..) , leaf , BinTree'(..) - , toRoseTree , toRoseTree' , forgetNodeDecorations - , module Data.Tree , Paren(..) , parenthesesToString , stringToParentheses - -- * Bijections - , forestToNestedParentheses - , forestToBinaryTree - , nestedParenthesesToForest - , nestedParenthesesToForestUnsafe - , nestedParenthesesToBinaryTree - , nestedParenthesesToBinaryTreeUnsafe - , binaryTreeToForest - , binaryTreeToNestedParentheses + -- * Conversion to rose trees (@Data.Tree@) + , toRoseTree , toRoseTree' + , module Data.Tree -- * Nested parentheses , nestedParentheses , randomNestedParentheses @@ -30,15 +27,29 @@ , fasc4A_algorithm_P , fasc4A_algorithm_W , fasc4A_algorithm_U - -- * Binary trees + -- * Generating binary trees , binaryTrees , countBinaryTrees , binaryTreesNaive , randomBinaryTree , fasc4A_algorithm_R -- * ASCII drawing - , printBinaryTree_ - , drawBinaryTree_ + , asciiBinaryTree_ + -- * Graphviz drawing + , Dot + , graphvizDotBinTree + , graphvizDotBinTree' + , graphvizDotForest + , graphvizDotTree + -- * Bijections + , forestToNestedParentheses + , forestToBinaryTree + , nestedParenthesesToForest + , nestedParenthesesToForestUnsafe + , nestedParenthesesToBinaryTree + , nestedParenthesesToBinaryTreeUnsafe + , binaryTreeToForest + , binaryTreeToNestedParentheses ) where @@ -61,9 +72,17 @@ import System.Random -import Math.Combinat.Helper import Math.Combinat.Numbers (factorial,binomial) +import Math.Combinat.Trees.Graphviz + ( Dot + , graphvizDotBinTree , graphvizDotBinTree' + , graphvizDotForest , graphvizDotTree + ) + +import Math.Combinat.Helper +import Math.Combinat.ASCII as ASCII + -------------------------------------------------------------------------------- -- * Types @@ -89,7 +108,7 @@ forgetNodeDecorations (Leaf' decor) = Leaf decor -------------------------------------------------------------------------------- --- * conversion to Data.Tree +-- * conversion to 'Data.Tree' -- | Convert a binary tree to a rose tree (from "Data.Tree") toRoseTree :: BinTree a -> Tree (Maybe a) @@ -103,7 +122,7 @@ go (Leaf' x) = Node (Right x) [] -------------------------------------------------------------------------------- --- * instances +-- instances instance Functor BinTree where fmap f = go where @@ -121,9 +140,12 @@ go (Branch left right) = Branch <$> go left <*> go right -------------------------------------------------------------------------------- --- * nester parentheses +-- * Nested parentheses -data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read) +data Paren + = LeftParen + | RightParen + deriving (Eq,Ord,Show,Read) parenToChar :: Paren -> Char parenToChar LeftParen = '(' @@ -299,7 +321,7 @@ c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1)) -------------------------------------------------------------------------------- --- * Binary trees +-- * Generating binary trees -- | Generates all binary trees with n nodes. -- At the moment just a synonym for 'binaryTreesNaive'. @@ -359,18 +381,16 @@ (k,b) = x `divMod` 2 -------------------------------------------------------------------------------- +-- * ASCII drawing -- | Draws a binary tree in ASCII, ignoring node labels. -- -- Example: -- --- > mapM_ printBinaryTree_ $ binaryTrees 4 +-- > autoTabulate RowMajor (Right 5) $ map asciiBinaryTree_ $ binaryTrees 4 -- -printBinaryTree_ :: BinTree a -> IO () -printBinaryTree_ = putStrLn . drawBinaryTree_ - -drawBinaryTree_ :: BinTree a -> String -drawBinaryTree_ = unlines . fst . go where +asciiBinaryTree_ :: BinTree a -> ASCII +asciiBinaryTree_ = ASCII.asciiFromLines . fst . go where go :: BinTree a -> ([String],Int) go (Leaf x) = ([],0) @@ -389,3 +409,5 @@ blockWidth ls = case ls of (l:_) -> length l [] -> 0 + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Trees/Binary.hs-boot b/Math/Combinat/Trees/Binary.hs-boot new file mode 100644 --- /dev/null +++ b/Math/Combinat/Trees/Binary.hs-boot @@ -0,0 +1,22 @@ + + +module Math.Combinat.Trees.Binary where + +-------------------------------------------------------------------------------- + +import Data.Tree ( Tree(..) , Forest(..) ) + +-------------------------------------------------------------------------------- + +-- | A binary tree with leaves decorated with type @a@. +data BinTree a + = Branch (BinTree a) (BinTree a) + | Leaf a + +-- | 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 + +-------------------------------------------------------------------------------- diff --git a/Math/Combinat/Trees/Graphviz.hs b/Math/Combinat/Trees/Graphviz.hs new file mode 100644 --- /dev/null +++ b/Math/Combinat/Trees/Graphviz.hs @@ -0,0 +1,115 @@ + +-- | Creates graphviz @.dot@ files from trees. + +module Math.Combinat.Trees.Graphviz + ( Dot + , graphvizDotBinTree + , graphvizDotBinTree' + , graphvizDotForest + , graphvizDotTree + ) + where + +-------------------------------------------------------------------------------- + +import Data.Tree + +import Control.Applicative + +import {-# SOURCE #-} Math.Combinat.Trees.Binary ( BinTree(..) , BinTree'(..) ) +import {-# SOURCE #-} 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" + +-------------------------------------------------------------------------------- + +graphvizDotBinTree :: Show a => String -> BinTree a -> Dot +graphvizDotBinTree graphname tree = + digraphBracket graphname $ binTreeDot' tree + +graphvizDotBinTree' :: (Show a, Show b) => String -> BinTree' a b -> Dot +graphvizDotBinTree' 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. +graphvizDotForest + :: Show a + => Bool -- ^ make the individual trees clustered subgraphs + -> Bool -- ^ reverse the direction of the arrows + -> String -- ^ name of the graph + -> Forest a + -> Dot +graphvizDotForest clustered revarrows 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') _) = if not revarrows + then name unique ++ " -> " ++ name unique' + else name unique' ++ " -> " ++ name unique + +-- | Generates graphviz @.dot@ file from a tree. The first argument is +-- the name of the graph. +graphvizDotTree + :: Show a + => Bool -- ^ reverse the direction of the arrow + -> String -- ^ name of the graph + -> Tree a + -> Dot +graphvizDotTree revarrows 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') _) = if not revarrows + then name unique ++ " -> " ++ name unique' + else name unique' ++ " -> " ++ name unique + +-------------------------------------------------------------------------------- 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,47 +2,48 @@ -- | N-ary trees. module Math.Combinat.Trees.Nary - ( - -- * regular trees + ( + -- * Regular trees ternaryTrees , regularNaryTrees , semiRegularTrees , countTernaryTrees , countRegularNaryTrees - -- * derivation trees + -- * \"derivation trees\" , derivTrees -- * ASCII drawings - , printTreeVertical_ - , printTreeVertical - , printTreeVerticalLeavesOnly - , drawTreeVertical_ - , drawTreeVertical - , drawTreeVerticalLeavesOnly - -- * classifying nodes + , asciiTreeVertical_ + , asciiTreeVertical + , asciiTreeVerticalLeavesOnly + -- * Graphviz drawing + , Dot + , graphvizDotTree + , graphvizDotForest + -- * Classifying nodes , classifyTreeNode , isTreeLeaf , isTreeNode , isTreeLeaf_ , isTreeNode_ , treeNodeNumberOfChildren - -- * counting nodes + -- * Counting nodes , countTreeNodes , countTreeLeaves , countTreeLabelsWith , countTreeNodesWith - -- * left and right spines + -- * Left and right spines , leftSpine , leftSpine_ , rightSpine , rightSpine_ , leftSpineLength , rightSpineLength - -- * unique labels + -- * Unique labels , addUniqueLabelsTree , addUniqueLabelsForest , addUniqueLabelsTree_ , addUniqueLabelsForest_ - -- * labelling by depth + -- * Labelling by depth , labelDepthTree , labelDepthForest , labelDepthTree_ , labelDepthForest_ - -- * labelling by number of children + -- * Labelling by number of children , labelNChildrenTree , labelNChildrenForest , labelNChildrenTree_ @@ -62,11 +63,14 @@ import Control.Monad.Trans.State import Data.Traversable (traverse) -import Math.Combinat.Sets (listTensor) -import Math.Combinat.Partitions (partitionMultiset) -import Math.Combinat.Compositions (compositions) -import Math.Combinat.Numbers (factorial,binomial) +import Math.Combinat.Sets ( listTensor ) +import Math.Combinat.Partitions.Multiset ( partitionMultiset ) +import Math.Combinat.Compositions ( compositions ) +import Math.Combinat.Numbers ( factorial, binomial ) +import Math.Combinat.Trees.Graphviz ( Dot , graphvizDotForest , graphvizDotTree ) + +import Math.Combinat.ASCII as ASCII import Math.Combinat.Helper -------------------------------------------------------------------------------- @@ -107,9 +111,9 @@ -- | 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 +-- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical +-- > $ map labelNChildrenTree_ +-- > $ semiRegularTrees [2,3] 2 -- > -- > [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...] -- @@ -160,31 +164,14 @@ -------------------------------------------------------------------------------- --- | Vertical ASCII drawing of a tree, without labels. --- --- Example: --- --- > mapM_ printTreeVertical_ $ regularNaryTrees 2 3 --- -printTreeVertical_ :: Tree a -> IO () -printTreeVertical_ = putStrLn . drawTreeVertical_ - --- | Prints all labels. +-- | Vertical ASCII drawing of a tree, without labels. Example: -- --- Example: +-- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical_ $ regularNaryTrees 2 4 -- --- > printTreeVertical $ addUniqueLabelsTree_ $ (regularNaryTrees 3 9) !! 666 +-- Nodes are denoted by @\@@, leaves by @*@. -- -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 +asciiTreeVertical_ :: Tree a -> ASCII +asciiTreeVertical_ tree = ASCII.asciiFromLines (go tree) where go :: Tree b -> [String] go (Node _ cs) = case cs of [] -> ["-*"] @@ -199,9 +186,14 @@ 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 +-- | Prints all labels. Example: +-- +-- > asciiTreeVertical $ addUniqueLabelsTree_ $ (regularNaryTrees 3 9) !! 666 +-- +-- Nodes are denoted by @(label)@, leaves by @label@. +-- +asciiTreeVertical :: Show a => Tree a -> ASCII +asciiTreeVertical tree = ASCII.asciiFromLines (go tree) where go :: Show b => Tree b -> [String] go (Node x cs) = case cs of [] -> ["-- " ++ show x] @@ -220,9 +212,9 @@ 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 +-- | Prints the labels for the leaves, but not for the nodes. +asciiTreeVerticalLeavesOnly :: Show a => Tree a -> ASCII +asciiTreeVerticalLeavesOnly tree = ASCII.asciiFromLines (go tree) where go :: Show b => Tree b -> [String] go (Node x cs) = case cs of [] -> ["- " ++ show x] diff --git a/Math/Combinat/Trees/Nary.hs-boot b/Math/Combinat/Trees/Nary.hs-boot new file mode 100644 --- /dev/null +++ b/Math/Combinat/Trees/Nary.hs-boot @@ -0,0 +1,16 @@ + +module Math.Combinat.Trees.Nary where + +-------------------------------------------------------------------------------- + +import Data.Tree + +-------------------------------------------------------------------------------- + +addUniqueLabelsTree :: Tree a -> Tree (a,Int) +addUniqueLabelsForest :: Forest a -> Forest (a,Int) + +addUniqueLabelsTree_ :: Tree a -> Tree Int +addUniqueLabelsForest_ :: Forest a -> Forest Int + +-------------------------------------------------------------------------------- diff --git a/combinat.cabal b/combinat.cabal --- a/combinat.cabal +++ b/combinat.cabal @@ -1,5 +1,5 @@ Name: combinat -Version: 0.2.6.2 +Version: 0.2.7.0 Synopsis: Generation of various combinatorial objects. Description: A collection of functions to generate (and if there is a formula, count) combinatorial objects like partitions, @@ -14,9 +14,14 @@ Stability: Experimental Category: Math Tested-With: GHC == 7.8.3 -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.18 Build-Type: Simple +extra-doc-files: svg/*.svg + +extra-source-files: svg/*.svg + svg/src/gen_figures.hs + Flag withQuickCheck Description: Compile with the QuickCheck tests. default: False @@ -36,7 +41,6 @@ if flag(withQuickCheck) Build-Depends: QuickCheck - Exposed-Modules: Math.Combinat Math.Combinat.Numbers Math.Combinat.Numbers.Series @@ -45,21 +49,29 @@ Math.Combinat.Tuples Math.Combinat.Compositions Math.Combinat.Partitions + Math.Combinat.Partitions.Integer Math.Combinat.Partitions.Set Math.Combinat.Partitions.NonCrossing + Math.Combinat.Partitions.Plane + Math.Combinat.Partitions.Multiset + Math.Combinat.Partitions.Vector Math.Combinat.Permutations Math.Combinat.Tableaux Math.Combinat.Tableaux.Kostka Math.Combinat.Trees Math.Combinat.Trees.Binary Math.Combinat.Trees.Nary + Math.Combinat.Trees.Graphviz Math.Combinat.LatticePaths Math.Combinat.FreeGroups - Math.Combinat.Graphviz + Math.Combinat.ASCII Math.Combinat.Helper - Extensions: CPP, MultiParamTypeClasses, ScopedTypeVariables, + Default-Extensions: CPP, BangPatterns + Other-Extensions: MultiParamTypeClasses, ScopedTypeVariables, GeneralizedNewtypeDeriving, BangPatterns + + Default-Language: Haskell2010 Hs-Source-Dirs: . diff --git a/svg/bintrees.svg b/svg/bintrees.svg new file mode 100644 --- /dev/null +++ b/svg/bintrees.svg @@ -0,0 +1,4 @@ + + + diff --git a/svg/dyck_path.svg b/svg/dyck_path.svg new file mode 100644 --- /dev/null +++ b/svg/dyck_path.svg @@ -0,0 +1,4 @@ + + + diff --git a/svg/ferrers.svg b/svg/ferrers.svg new file mode 100644 --- /dev/null +++ b/svg/ferrers.svg @@ -0,0 +1,4 @@ + + + diff --git a/svg/noncrossing.svg b/svg/noncrossing.svg new file mode 100644 --- /dev/null +++ b/svg/noncrossing.svg @@ -0,0 +1,4 @@ + + +987654321 diff --git a/svg/plane_partition.svg b/svg/plane_partition.svg new file mode 100644 --- /dev/null +++ b/svg/plane_partition.svg @@ -0,0 +1,4 @@ + + + diff --git a/svg/src/gen_figures.hs b/svg/src/gen_figures.hs new file mode 100644 --- /dev/null +++ b/svg/src/gen_figures.hs @@ -0,0 +1,66 @@ + +-- | A script to generate the SVG figures in the documentation. +-- We use the @combinat-diagrams@ library for that. + +module Main where + +-------------------------------------------------------------------------------- + +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Plane +import Math.Combinat.Partitions.NonCrossing +import Math.Combinat.Tableaux +import Math.Combinat.LatticePaths +import Math.Combinat.Trees.Binary + +import Math.Combinat.Diagrams.Partitions.Integer +import Math.Combinat.Diagrams.Partitions.Plane +import Math.Combinat.Diagrams.Partitions.NonCrossing +import Math.Combinat.Diagrams.Tableaux +import Math.Combinat.Diagrams.LatticePaths +import Math.Combinat.Diagrams.Trees.Binary + +import Diagrams.Core +import Diagrams.Prelude +import Diagrams.Backend.SVG + +-------------------------------------------------------------------------------- + +export fpath size what = renderSVG fpath size $ pad 1.10 what + +vcatSep = vcat' (with & sep .~ 1) +hcatSep = hcat' (with & sep .~ 1) + +boxSep m xs = pad 1.05 $ vcatSep $ map hcatSep $ yys where + yys = go xs where + go [] = [] + go zs = take m zs : go (drop m zs) + +-------------------------------------------------------------------------------- + +main = do + + export "plane_partition.svg" (Width 320) $ drawPlanePartition3D $ + PlanePart [[5,4,3,3,1],[4,4,2,1],[3,2],[2,1],[1],[1]] + + export "noncrossing.svg" (Width 256) $ pad 1.10 $ drawNonCrossingCircleDiagram' orange True $ + NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] + + export "young_tableau.svg" (Width 256) $ drawTableau $ + [ [ 1 , 3 , 4 , 6 , 7 ] + , [ 2 , 5 , 8 ,10 ] + , [ 9 ] + ] + + let u = UpStep + d = DownStep + path = [ u,u,d,u,u,u,d,u,d,d,u,d,u,u,u,d,d,d,d,d,u,d,u,u,d,d ] + export "dyck_path.svg" (Width 500) $ drawLatticePath $ path + -- print (pathHeight path, pathNumberOfZeroTouches path, pathNumberOfPeaks path) + + export "ferrers.svg" (Width 256) $ drawFerrersDiagram' EnglishNotation red True $ + Partition [8,6,3,3,1] + + export "bintrees.svg" (Width 750) $ boxSep 7 $ map drawBinTree_ (binaryTrees 4) + +-------------------------------------------------------------------------------- diff --git a/svg/young_tableau.svg b/svg/young_tableau.svg new file mode 100644 --- /dev/null +++ b/svg/young_tableau.svg @@ -0,0 +1,4 @@ + + +91085276431