diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008-2018, Balazs Komuves +Copyright (c) 2008-2023, Balazs Komuves All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Math/Combinat.hs b/Math/Combinat.hs deleted file mode 100644 --- a/Math/Combinat.hs +++ /dev/null @@ -1,76 +0,0 @@ - --- | A collection of functions to generate, manipulate, --- visualize and count combinatorial objects like partitions, --- compositions, permutations, braids, Young tableaux, --- lattice paths, various tree structures, etc etc. --- --- --- See also the @combinat-diagrams@ library for generating --- graphical representations of (some of) these structure using --- the @diagrams@ library (). --- --- --- The long-term goals are --- --- (1) generate most of the standard structures; --- --- (2) manipulate these structures; --- --- (3) visualize these structures; --- --- (4) the generation should be efficient; --- --- (5) to be able to enumerate the structures --- with constant memory usage; --- --- (6) to be able to randomly sample from them; --- --- (7) finally, to be a repository of algorithms. --- --- --- The short-term goal is simply to generate --- and manipulate 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; --- --- * \"random\" prefix: generates random objects --- (typically with uniform distribution); --- --- * \"count\" prefix: counting functions. --- --- --- This module re-exports the most commonly used modules. --- - -module Math.Combinat - ( module Math.Combinat.Numbers - , module Math.Combinat.Sign - , module Math.Combinat.Sets - , module Math.Combinat.Tuples - , module Math.Combinat.Compositions - , module Math.Combinat.Partitions - , module Math.Combinat.Permutations - , module Math.Combinat.Tableaux - , module Math.Combinat.Trees - , module Math.Combinat.LatticePaths - , module Math.Combinat.ASCII - ) - where - -import Math.Combinat.Numbers -import Math.Combinat.Sign -import Math.Combinat.Sets -import Math.Combinat.Tuples -import Math.Combinat.Compositions -import Math.Combinat.Partitions -import Math.Combinat.Permutations -import Math.Combinat.Tableaux -import Math.Combinat.Trees -import Math.Combinat.LatticePaths -import Math.Combinat.ASCII diff --git a/Math/Combinat/ASCII.hs b/Math/Combinat/ASCII.hs deleted file mode 100644 --- a/Math/Combinat/ASCII.hs +++ /dev/null @@ -1,438 +0,0 @@ - --- | 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.Char ( isSpace ) -import Data.List ( transpose , intercalate ) - -import Math.Combinat.Helper - --------------------------------------------------------------------------------- --- * The basic ASCII 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] - } - --- | A type class to have a simple way to draw things -class DrawASCII a where - ascii :: a -> ASCII - -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 - --------------------------------------------------------------------------------- --- * 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 - --------------------------------------------------------------------------------- --- * Concatenation - --- | Horizontal append, centrally aligned, no separation. -(|||) :: ASCII -> ASCII -> ASCII -(|||) p q = hCatWith VCenter HSepEmpty [p,q] - --- | Vertical append, centrally aligned, no separation. -(===) :: ASCII -> ASCII -> ASCII -(===) p q = vCatWith HCenter VSepEmpty [p,q] - --- | Horizontal concatenation, top-aligned, no separation -hCatTop :: [ASCII] -> ASCII -hCatTop = hCatWith VTop HSepEmpty - --- | Horizontal concatenation, bottom-aligned, no separation -hCatBot :: [ASCII] -> ASCII -hCatBot = hCatWith VBottom HSepEmpty - --- | Vertical concatenation, left-aligned, no separation -vCatLeft :: [ASCII] -> ASCII -vCatLeft = vCatWith HLeft VSepEmpty - --- | Vertical concatenation, right-aligned, no separation -vCatRight :: [ASCII] -> ASCII -vCatRight = vCatWith HRight VSepEmpty - --- | General 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) - --- | General 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 - --------------------------------------------------------------------------------- --- * 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 - --------------------------------------------------------------------------------- --- * Extension - --- | Extends an ASCII figure with spaces horizontally to the given width. --- Note: the alignment is the alignment of the original picture in the new bigger picture! -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. --- Note: the alignment is the alignment of the original picture in the new bigger picture! -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 - --------------------------------------------------------------------------------- --- * Cutting - --- | Cuts the given number of columns from the picture. --- The alignment is the alignment of the /picture/, not the cuts. --- --- This should be the (left) inverse of 'hExtendWith'. -hCut :: HAlign -> Int -> ASCII -> ASCII -hCut halign k (ASCII (x,y) ls) = ASCII (x',y) (map f ls) where - x' = max 0 (x-k) - f = case halign of - HLeft -> reverse . drop k . reverse - HCenter -> reverse . drop (k-a) . reverse . drop a - HRight -> drop k - a = div k 2 - --- | Cuts the given number of rows from the picture. --- The alignment is the alignment of the /picture/, not the cuts. --- --- This should be the (left) inverse of 'vExtendWith'. -vCut :: VAlign -> Int -> ASCII -> ASCII -vCut valign k (ASCII (x,y) ls) = ASCII (x,y') (g ls) where - y' = max 0 (y-k) - g = case valign of - VTop -> reverse . drop k . reverse - VCenter -> reverse . drop (k-a) . reverse . drop a - VBottom -> drop k - a = div k 2 - --------------------------------------------------------------------------------- --- * Pasting - --- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension --- (that is, overlapping parts of the first one are ignored). --- The offset is relative to the top-left corner of the second picture. --- Spaces at treated as transparent. --- --- Example: --- --- > tabulate (HCenter,VCenter) (HSepSpaces 2, VSepSpaces 1) --- > [ [ caption (show (x,y)) $ --- > pasteOnto (x,y) (filledBox '@' (4,3)) (asciiBox (7,5)) --- > | x <- [-4..7] ] --- > | y <- [-3..5] ] --- -pasteOnto :: (Int,Int) -> ASCII -> ASCII -> ASCII -pasteOnto = pasteOnto' isSpace - --- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension. --- The first argument specifies the transparency condition (on the first picture). --- The offset is relative to the top-left corner of the second picture. --- -pasteOnto' - :: (Char -> Bool) -- ^ transparency condition - -> (Int,Int) -- ^ offset relative to the top-left corner of the second picture - -> ASCII -- ^ picture to paste - -> ASCII -- ^ picture to paste onto - -> ASCII -pasteOnto' transparent (xpos,ypos) small big = new where - new = ASCII (xbig,ybig) lines' - (xbig,ybig) = asciiSize big - bigLines = asciiLines big - small' = (if (ypos>=0) then vExtendWith VBottom ypos else vCut VBottom (-ypos)) - $ (if (xpos>=0) then hExtendWith HRight xpos else hCut HRight (-xpos)) - $ small - smallLines = asciiLines small' - lines' = zipWith f bigLines (smallLines ++ repeat "") - f bl sl = zipWith g bl (sl ++ repeat ' ') - g b s = if transparent s then b else s - --- | A version of 'pasteOnto' where we can specify the corner of the second picture --- to which the offset is relative: --- --- > pasteOntoRel (HLeft,VTop) == pasteOnto --- -pasteOntoRel :: (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII -pasteOntoRel = pasteOntoRel' isSpace - -pasteOntoRel' :: (Char -> Bool) -> (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII -pasteOntoRel' transparent (halign,valign) (xpos,ypos) small big = new where - new = pasteOnto' transparent (xpos',ypos') small big - (xsize,ysize) = asciiSize big - xpos' = case halign of - HLeft -> xpos - HCenter -> xpos + div xsize 2 - HRight -> xpos + xsize - ypos' = case valign of - VTop -> ypos - VCenter -> ypos + div ysize 2 - VBottom -> ypos + ysize - --------------------------------------------------------------------------------- --- * Tabulate - --- | Tabulates the given matrix of pictures. Example: --- --- > tabulate (HCenter, VCenter) (HSepSpaces 2, VSepSpaces 1) --- > [ [ asciiFromLines [ "x=" ++ show x , "y=" ++ show y ] | x<-[7..13] ] --- > | y<-[98..102] ] --- -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 - --------------------------------------------------------------------------------- --- * Ready-made boxes - --- | An ASCII border 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 border 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) '-' ++ "/" - --- | A box simply filled with the given character -filledBox :: Char -> (Int,Int) -> ASCII -filledBox c (x0,y0) = asciiFromLines $ replicate y (replicate x c) where - x = max 0 x0 - y = max 0 y0 - --- | A box of spaces -transparentBox :: (Int,Int) -> ASCII -transparentBox = filledBox ' ' - --------------------------------------------------------------------------------- --- * Testing \/ miscellanea - --- | An integer -asciiNumber :: Int -> ASCII -asciiNumber = asciiShow - -asciiShow :: Show a => a -> ASCII -asciiShow = asciiFromLines . (:[]) . show - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Classes.hs b/Math/Combinat/Classes.hs deleted file mode 100644 --- a/Math/Combinat/Classes.hs +++ /dev/null @@ -1,66 +0,0 @@ - --- | Type classes for some common properties shared by different objects - -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -module Math.Combinat.Classes where - --------------------------------------------------------------------------------- - --- | Emptyness -class CanBeEmpty a where - isEmpty :: a -> Bool - empty :: a - --------------------------------------------------------------------------------- --- * Partitions - --- | Number of parts -class HasNumberOfParts a where - numberOfParts :: a -> Int - --------------------------------------------------------------------------------- - -class HasWidth a where - width :: a -> Int - -class HasHeight a where - height :: a -> Int - --------------------------------------------------------------------------------- - --- | Weight (of partitions, tableaux, etc) -class HasWeight a where - weight :: a -> Int - --------------------------------------------------------------------------------- - --- | Duality (of partitions, tableaux, etc) -class HasDuality a where - dual :: a -> a - --------------------------------------------------------------------------------- --- * Tableau - --- | Shape (of tableaux, skew tableaux) -class HasShape a s | a -> s where - shape :: a -> s - --------------------------------------------------------------------------------- --- * Trees - --- | Number of nodes (of trees) -class HasNumberOfNodes t where - numberOfNodes :: t -> Int - --- | Number of leaves (of trees) -class HasNumberOfLeaves t where - numberOfLeaves :: t -> Int - --------------------------------------------------------------------------------- --- * Permutations - --- | Number of cycles (of partitions) -class HasNumberOfCycles p where - numberOfCycles :: p -> Int - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Compositions.hs b/Math/Combinat/Compositions.hs deleted file mode 100644 --- a/Math/Combinat/Compositions.hs +++ /dev/null @@ -1,109 +0,0 @@ - --- | Compositions. --- --- See eg. --- - -module Math.Combinat.Compositions where - --------------------------------------------------------------------------------- - -import System.Random - -import Math.Combinat.Sets ( randomChoice ) -import Math.Combinat.Numbers ( factorial , binomial ) -import Math.Combinat.Helper - --------------------------------------------------------------------------------- --- * generating all compositions - --- | A /composition/ of an integer @n@ into @k@ parts is an ordered @k@-tuple of nonnegative (sometimes positive) integers --- whose sum is @n@. -type Composition = [Int] - --- | Compositions fitting into a given shape and having a given degree. --- The order is lexicographic, that is, --- --- > sort cs == cs where cs = compositions' shape k --- -compositions' - :: [Int] -- ^ shape - -> Int -- ^ sum - -> [[Int]] -compositions' [] 0 = [[]] -compositions' [] _ = [] -compositions' shape@(s:ss) n = - [ x:xs | x <- [0..min s n] , xs <- compositions' ss (n-x) ] - -countCompositions' :: [Int] -> Int -> Integer -countCompositions' [] 0 = 1 -countCompositions' [] _ = 0 -countCompositions' shape@(s:ss) n = sum - [ countCompositions' ss (n-x) | x <- [0..min s n] ] - --- | All positive compositions of a given number (filtrated by the length). --- Total number of these is @2^(n-1)@ -allCompositions1 :: Int -> [[Composition]] -allCompositions1 n = map (\d -> compositions1 d n) [1..n] - --- | All compositions fitting into a given shape. -allCompositions' :: [Int] -> [[Composition]] -allCompositions' shape = map (compositions' shape) [0..d] where d = sum shape - --- | Nonnegative compositions of a given length. -compositions - :: Integral a - => a -- ^ length - -> a -- ^ sum - -> [[Int]] -compositions len' d' = compositions' (replicate len d) d where - len = fromIntegral len' - d = fromIntegral d' - --- | # = \\binom { len+d-1 } { len-1 } -countCompositions :: Integral a => a -> a -> Integer -countCompositions len d = binomial (len+d-1) (len-1) - --- | Positive compositions of a given length. -compositions1 - :: Integral a - => a -- ^ length - -> a -- ^ sum - -> [[Int]] -compositions1 len d - | len > d = [] - | otherwise = map plus1 $ compositions len (d-len) - where - plus1 = map (+1) - -- len = fromIntegral len' - -- d = fromIntegral d' - -countCompositions1 :: Integral a => a -> a -> Integer -countCompositions1 len d = countCompositions len (d-len) - --------------------------------------------------------------------------------- --- * random compositions - --- | @randomComposition k n@ returns a uniformly random composition --- of the number @n@ as an (ordered) sum of @k@ /nonnegative/ numbers -randomComposition :: RandomGen g => Int -> Int -> g -> ([Int],g) -randomComposition k n g0 = - if k<1 || n<0 - then error "randomComposition: k should be positive, and n should be nonnegative" - else (comp, g1) - where - (cs,g1) = randomChoice (k-1) (n+k-1) g0 - comp = pairsWith (\x y -> y-x-1) (0 : cs ++ [n+k]) - --- | @randomComposition1 k n@ returns a uniformly random composition --- of the number @n@ as an (ordered) sum of @k@ /positive/ numbers -randomComposition1 :: RandomGen g => Int -> Int -> g -> ([Int],g) -randomComposition1 k n g0 = - if k<1 || n --- --- --- Based on: --- --- * Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY --- --- --- --- Note: This module GHC 7.8, since we use type-level naturals --- to parametrize the 'Braid' type. --- - - -{-# LANGUAGE - CPP, BangPatterns, - ScopedTypeVariables, ExistentialQuantification, - DataKinds, KindSignatures, Rank2Types, - TypeOperators, TypeFamilies, - StandaloneDeriving #-} - -module Math.Combinat.Groups.Braid where - --------------------------------------------------------------------------------- - -import Data.Proxy -import GHC.TypeLits - -import Control.Monad - -import Data.List ( mapAccumL , foldl' ) - -import Data.Array.Unboxed -import Data.Array.ST -import Data.Array.IArray -import Data.Array.MArray -import Data.Array.Unsafe -import Data.Array.Base - -import Control.Monad.ST - -import System.Random - -import Math.Combinat.ASCII -import Math.Combinat.Sign -import Math.Combinat.Helper -import Math.Combinat.TypeLevel -import Math.Combinat.Numbers.Series - -import Math.Combinat.Permutations ( Permutation(..) , (!!!) ) -import qualified Math.Combinat.Permutations as P - --------------------------------------------------------------------------------- --- * Artin generators - --- | A standard Artin generator of a braid: @Sigma i@ represents twisting --- the neighbour strands @i@ and @(i+1)@, such that strand @i@ goes /under/ strand @(i+1)@. --- --- Note: The strands are numbered @1..n@. -data BrGen - = Sigma !Int -- ^ @i@ goes under @(i+1)@ - | SigmaInv !Int -- ^ @i@ goes above @(i+1)@ - deriving (Eq,Ord,Show) - --- | The strand (more precisely, the first of the two strands) the generator twistes -brGenIdx :: BrGen -> Int -brGenIdx g = case g of - Sigma i -> i - SigmaInv i -> i - -brGenSign :: BrGen -> Sign -brGenSign g = case g of - Sigma _ -> Plus - SigmaInv _ -> Minus - -brGenSignIdx :: BrGen -> (Sign,Int) -brGenSignIdx g = case g of - Sigma i -> (Plus ,i) - SigmaInv i -> (Minus,i) - --- | The inverse of a braid generator -invBrGen :: BrGen -> BrGen -invBrGen g = case g of - Sigma i -> SigmaInv i - SigmaInv i -> Sigma i - --------------------------------------------------------------------------------- --- * The braid type - --- | The braid group @B_n@ on @n@ strands. --- The number @n@ is encoded as a type level natural in the type parameter. --- --- Braids are represented as words in the standard generators and their --- inverses. -newtype Braid (n :: Nat) = Braid [BrGen] deriving (Show) - --- | The number of strands in the braid -numberOfStrands :: KnownNat n => Braid n -> Int -numberOfStrands = fromInteger . natVal . braidProxy where - braidProxy :: Braid n -> Proxy n - braidProxy _ = Proxy - --- | Sometimes we want to hide the type-level parameter @n@, for example when --- dynamically creating braids whose size is known only at runtime. -data SomeBraid = forall n. KnownNat n => SomeBraid (Braid n) - -someBraid :: Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid -someBraid n polyBraid = - case snat of - SomeNat pxy -> SomeBraid (asProxyTypeOf1 polyBraid pxy) - where - snat = case someNatVal (fromIntegral n :: Integer) of - Just sn -> sn - Nothing -> error "someBraid: input is not a natural number" - -withSomeBraid :: SomeBraid -> (forall n. KnownNat n => Braid n -> a) -> a -withSomeBraid sbraid f = case sbraid of SomeBraid braid -> f braid - -mkBraid :: (forall n. KnownNat n => Braid n -> a) -> Int -> [BrGen] -> a -mkBraid f n w = y where - sb = someBraid n (Braid w) - y = withSomeBraid sb f - -withBraid - :: Int - -> (forall (n :: Nat). KnownNat n => Braid n) - -> (forall (n :: Nat). KnownNat n => Braid n -> a) - -> a -withBraid n polyBraid f = - case snat of - SomeNat pxy -> f (asProxyTypeOf1 polyBraid pxy) - where - snat = case someNatVal (fromIntegral n :: Integer) of - Just sn -> sn - Nothing -> error "withBraid: input is not a natural number" - --------------------------------------------------------------------------------- - -braidWord :: Braid n -> [BrGen] -braidWord (Braid gs) = gs - -braidWordLength :: Braid n -> Int -braidWordLength (Braid gs) = length gs - --- | Embeds a smaller braid group into a bigger braid group -extend :: (n1 <= n2) => Braid n1 -> Braid n2 -extend (Braid gs) = Braid gs - --- | Apply \"free reduction\" to the word, that is, iteratively remove @sigma_i sigma_i^-1@ pairs. --- The resulting braid is clearly equivalent to the original. -freeReduceBraidWord :: Braid n -> Braid n -freeReduceBraidWord (Braid orig) = Braid (loop orig) where - - loop w = case reduceStep w of - Nothing -> w - Just w' -> loop w' - - reduceStep :: [BrGen] -> Maybe [BrGen] - reduceStep = go False where - go !changed w = case w of - (Sigma x : SigmaInv y : rest) | x==y -> go True rest - (SigmaInv x : Sigma y : rest) | x==y -> go True rest - (this : rest) -> liftM (this:) $ go changed rest - _ -> if changed then Just w else Nothing - --------------------------------------------------------------------------------- --- * Some specific braids - --- | The braid generator @sigma_i@ as a braid -sigma :: KnownNat n => Int -> Braid (n :: Nat) -sigma k = braid where - braid = if k > 0 && k < numberOfStrands braid - then Braid [Sigma k] - else error "sigma: braid generator index out of range" - --- | The braid generator @sigma_i^(-1)@ as a braid -sigmaInv :: KnownNat n => Int -> Braid (n :: Nat) -sigmaInv k = braid where - braid = if k > 0 && k < numberOfStrands braid - then Braid [SigmaInv k] - else error "sigma: braid generator index out of range" - --- | @doubleSigma s t@ (for s Int -> Int -> Braid (n :: Nat) -doubleSigma s t = braid where - n = numberOfStrands braid - braid - | s < 1 || s > n = error "doubleSigma: s index out of range" - | t < 1 || t > n = error "doubleSigma: t index out of range" - | s >= t = error "doubleSigma: s >= t" - | otherwise = Braid $ - [ Sigma i | i<-[t-1,t-2..s] ] ++ [ SigmaInv i | i<-[s+1..t-1] ] - --- | @positiveWord [2,5,1]@ is shorthand for the word @sigma_2*sigma_5*sigma_1@. -positiveWord :: KnownNat n => [Int] -> Braid (n :: Nat) -positiveWord idxs = braid where - braid = Braid (map gen idxs) - n = numberOfStrands braid - gen i = if i>0 && i Braid n -halfTwist = braid where - braid = Braid $ map Sigma $ _halfTwist n - n = numberOfStrands braid - --- | The untyped version of 'halfTwist' -_halfTwist :: Int -> [Int] -_halfTwist n = gens where - gens = concat [ sub k | k<-[1..n-1] ] - sub k = [ j | j<-[n-1,n-2..k] ] - --- | Synonym for 'halfTwist' -theGarsideBraid :: KnownNat n => Braid n -theGarsideBraid = halfTwist - --- | The inner automorphism defined by @tau(X) = Delta^-1 X Delta@, --- where @Delta@ is the positive half-twist. --- --- This sends each generator @sigma_j@ to @sigma_(n-j)@. --- -tau :: KnownNat n => Braid n -> Braid n -tau braid@(Braid gens) = Braid (map f gens) where - n = numberOfStrands braid - f (Sigma i) = Sigma (n-i) - f (SigmaInv i) = SigmaInv (n-i) - - --- | The involution @tau@ on permutations (permutation braids) --- -tauPerm :: Permutation -> Permutation -tauPerm perm = P.toPermutationUnsafeN n [ (n+1) - perm !!! (n-i) | i<-[0..n-1] ] where - n = P.permutationSize perm - --------------------------------------------------------------------------------- --- * Group operations - --- | The trivial braid -identity :: Braid n -identity = Braid [] - --- | The inverse of a braid. Note: we do not perform reduction here, --- as a word is reduced if and only if its inverse is reduced. -inverse :: Braid n -> Braid n -inverse = Braid . reverse . map invBrGen . braidWord - --- | Composes two braids, doing free reduction on the result --- (that is, removing @(sigma_k * sigma_k^-1)@ pairs@) -compose :: Braid n -> Braid n -> Braid n -compose (Braid gs) (Braid hs) = freeReduceBraidWord $ Braid (gs++hs) - -composeMany :: [Braid n] -> Braid n -composeMany = freeReduceBraidWord . Braid . concat . map braidWord - --- | Composes two braids without doing any reduction. -composeDontReduce :: Braid n -> Braid n -> Braid n -composeDontReduce (Braid gs) (Braid hs) = Braid (gs++hs) - --------------------------------------------------------------------------------- --- * Braid permutations - --- | A braid is pure if its permutation is trivial -isPureBraid :: KnownNat n => Braid n -> Bool -isPureBraid braid = (braidPermutation braid == P.identityPermutation n) where - n = numberOfStrands braid - --- | Returns the left-to-right permutation associated to the braid. --- We follow the strands /from the left to the right/ (or from the top to the --- bottom), and return the permutation taking the left side to the right side. --- --- This is compatible with /right/ (standard) action of the permutations: --- @permuteRight (braidPermutationRight b1)@ corresponds to the left-to-right --- permutation of the strands; also: --- --- > (braidPermutation b1) `multiply` (braidPermutation b2) == braidPermutation (b1 `compose` b2) --- --- Writing the right numbering of the strands below the left numbering, --- we got the two-line notation of the permutation. --- -braidPermutation :: KnownNat n => Braid n -> Permutation -braidPermutation braid@(Braid gens) = perm where - n = numberOfStrands braid - perm = _braidPermutation n (map brGenIdx gens) - --- | This is an untyped version of 'braidPermutation' -_braidPermutation :: Int -> [Int] -> Permutation -_braidPermutation n idxs = P.uarrayToPermutationUnsafe (runSTUArray action) where - - action :: forall s. ST s (STUArray s Int Int) - action = do - arr <- newArray_ (1,n) - forM_ [1..n] $ \i -> writeArray arr i i - worker arr idxs - return arr - - worker arr = go where - go [] = return arr - go (i:is) = do - a <- readArray arr i - b <- readArray arr (i+1) - writeArray arr i b - writeArray arr (i+1) a - go is - --------------------------------------------------------------------------------- --- * Permutation braids - --- | A positive braid word contains only positive (@Sigma@) generators. -isPositiveBraidWord :: KnownNat n => Braid n -> Bool -isPositiveBraidWord (Braid gs) = all (isPlus . brGenSign) gs - --- | A /permutation braid/ is a positive braid where any two strands cross --- at most one, and /positively/. --- -isPermutationBraid :: KnownNat n => Braid n -> Bool -isPermutationBraid braid = isPositiveBraidWord braid && crosses where - crosses = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] - check i j = zeroOrOne (lkMatrix ! (i,j)) - zeroOrOne a = (a==1 || a==0) - lkMatrix = linkingMatrix braid - n = numberOfStrands braid - --- | Untyped version of 'isPermutationBraid' for positive words. -_isPermutationBraid :: Int -> [Int] -> Bool -_isPermutationBraid n gens = crosses where - crosses = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] - check i j = zeroOrOne (lkMatrix ! (i,j)) - zeroOrOne a = (a==1 || a==0) - lkMatrix = _linkingMatrix n $ map Sigma gens - --- | For any permutation this functions returns a /permutation braid/ realizing --- that permutation. Note that this is not unique, so we make an arbitrary choice --- (except for the permutation @[n,n-1..1]@ reversing the order, in which case --- the result must be the half-twist braid). --- --- The resulting braid word will have a length at most @choose n 2@ (and will have --- that length only for the permutation @[n,n-1..1]@) --- --- > braidPermutationRight (permutationBraid perm) == perm --- > isPermutationBraid (permutationBraid perm) == True --- -permutationBraid :: KnownNat n => Permutation -> Braid n -permutationBraid perm = braid where - n1 = numberOfStrands braid - n2 = P.permutationSize perm - braid = if n1 == n2 - then Braid (map Sigma $ _permutationBraid perm) - else error $ "permutationBraid: incompatible n: " ++ show n1 ++ " vs. " ++ show n2 - --- | Untyped version of 'permutationBraid' -_permutationBraid :: Permutation -> [Int] -_permutationBraid = concat . _permutationBraid' - --- | Returns the individual \"phases\" of the a permutation braid realizing the --- given permutation. -_permutationBraid' :: Permutation -> [[Int]] -_permutationBraid' perm = runST action where - n = P.permutationSize perm - - action :: forall s. ST s [[Int]] - action = do - - -- cfwd = the current state of strands : cfwd!j = where is strand #j now? - -- cinv = the inverse of that permutation : cinv!i = which strand is on the #i position now? - - cfwd <- newArray_ (1,n) :: ST s (STUArray s Int Int) - cinv <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \j -> do - writeArray cfwd j j - writeArray cinv j j - - let doSwap i = do - a <- readArray cinv i - b <- readArray cinv (i+1) - writeArray cinv i b - writeArray cinv (i+1) a - - u <- readArray cfwd a - v <- readArray cfwd b - writeArray cfwd a v - writeArray cfwd b u - - -- at the k-th phase, we move the (inv!k)-th strand, which is the k-th strand /on the RHS/, to correct position. - let worker phase - | phase >= n = return [] - | otherwise = do - let tgt = P.lookupPermutation perm phase -- (arr ! phase) - src <- readArray cfwd tgt - let this = [src-1,src-2..phase] - mapM_ doSwap $ this - rest <- worker (phase+1) - return (this:rest) - - worker 1 - - --- | We compute the linking numbers between all pairs of strands: --- --- > linkingMatrix braid ! (i,j) == strandLinking braid i j --- -linkingMatrix :: KnownNat n => Braid n -> UArray (Int,Int) Int -linkingMatrix braid@(Braid gens) = _linkingMatrix (numberOfStrands braid) gens where - --- | Untyped version of 'linkingMatrix' -_linkingMatrix :: Int -> [BrGen] -> UArray (Int,Int) Int -_linkingMatrix n gens = runSTUArray action where - - action :: forall s. ST s (STUArray s (Int,Int) Int) - action = do - perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \i -> writeArray perm i i - let doSwap :: Int -> ST s () - doSwap i = do - a <- readArray perm i - b <- readArray perm (i+1) - writeArray perm i b - writeArray perm (i+1) a - - mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int) - let doAdd :: Int -> Int -> Int -> ST s () - doAdd i j pm1 = do - x <- readArray mat (i,j) - writeArray mat (i,j) (x+pm1) - writeArray mat (j,i) (x+pm1) - - forM_ gens $ \g -> do - let (sgn,k) = brGenSignIdx g - u <- readArray perm k - v <- readArray perm (k+1) - doAdd u v (signValue sgn) - doSwap k - - return mat - - --- | The linking number between two strands numbered @i@ and @j@ --- (numbered such on the /left/ side). -strandLinking :: KnownNat n => Braid n -> Int -> Int -> Int -strandLinking braid@(Braid gens) i0 j0 - | i0 < 1 || i0 > n = error $ "strandLinkingNumber: invalid strand index i: " ++ show i0 - | j0 < 1 || j0 > n = error $ "strandLinkingNumber: invalid strand index j: " ++ show j0 - | i0 == j0 = 0 - | otherwise = go i0 j0 gens - where - n = numberOfStrands braid - - go !i !j [] = 0 - go !i !j (g:gs) - | i == k && j == k+1 = s + go (i+1) (j-1) gs - | j == k && i == k+1 = s + go (i-1) (j+1) gs - | i == k = go (i+1) j gs - | i == k+1 = go (i-1) j gs - | j == k = go i (j+1) gs - | j == k+1 = go i (j-1) gs - | otherwise = go i j gs - where - (sgn,k) = brGenSignIdx g - s = signValue sgn - --------------------------------------------------------------------------------- --- * Growth - --- | Bronfman's recursive formula for the reciprocial of the growth function --- of /positive/ braids. It was already known (by Deligne) that these generating functions --- are reciprocials of polynomials; Bronfman [1] gave a recursive formula for them. --- --- > let count n l = length $ nub $ [ braidNormalForm w | w <- allPositiveBraidWords n l ] --- > let convertPoly (1:cs) = zip (map negate cs) [1..] --- > pseries' (convertPoly $ bronfmanH n) == expandBronfmanH n == [ count n l | l <- [0..] ] --- --- * [1] Aaron Bronfman: Growth functions of a class of monoids. Preprint, 2001 --- -bronfmanH :: Int -> [Int] -bronfmanH n = bronfmanHsList !! n - --- | An infinite list containing the Bronfman polynomials: --- --- > bronfmanH n = bronfmanHsList !! n --- -bronfmanHsList :: [[Int]] -bronfmanHsList = list where - list = map go [0..] - go 0 = [1] - go n = sumSeries [ sgn i $ replicate (choose2 i) 0 ++ list !! (n-i) | i<-[1..n] ] - sgn i = if odd i then id else map negate - choose2 k = div (k*(k-1)) 2 - --- | Expands the reciprocial of @H(n)@ into an infinite power series, --- giving the growth function of the positive braids on @n@ strands. -expandBronfmanH :: Int -> [Int] -expandBronfmanH n = pseries' (convertPoly $ bronfmanH n) where - convertPoly (1:cs) = zip (map negate cs) [1..] - --------------------------------------------------------------------------------- --- * ASCII diagram - -instance KnownNat n => DrawASCII (Braid n) where - ascii = horizBraidASCII - --- | Horizontal braid diagram, drawn from left to right, --- with strands numbered from the bottom to the top -horizBraidASCII :: KnownNat n => Braid n -> ASCII -horizBraidASCII = horizBraidASCII' True - --- | Horizontal braid diagram, drawn from left to right. --- The boolean flag indicates whether to flip the strands --- vertically ('True' means bottom-to-top, 'False' means top-to-bottom) -horizBraidASCII' :: KnownNat n => Bool -> Braid n -> ASCII -horizBraidASCII' flipped braid@(Braid gens) = final where - - n = numberOfStrands braid - - final = vExtendWith VTop 1 $ hCatTop allBlocks - allBlocks = prelude ++ middleBlocks ++ epilogue - prelude = [ numberBlock , spaceBlock , beginEndBlock ] - epilogue = [ beginEndBlock , spaceBlock , numberBlock' ] - middleBlocks = map block gens - - block g = case g of - Sigma i -> block' i $ if flipped then over else under - SigmaInv i -> block' i $ if flipped then under else over - - block' i middle = asciiFromLines $ drop 2 $ concat - $ replicate a horiz ++ [space3, middle] ++ replicate b horiz - where - (a,b) = if flipped then (n-i-1,i-1) else (i-1,n-i-1) - - -- cycleN :: Int -> [a] -> [a] - -- cycleN n = concat . replicate n - - spaceBlock = transparentBox (1,n*3-2) - beginEndBlock = asciiFromLines $ drop 2 $ concat $ replicate n horiz - numberBlock = mkNumbers [1..n] - numberBlock' = mkNumbers $ P.fromPermutation $ braidPermutation braid - - mkNumbers :: [Int] -> ASCII - mkNumbers list = vCatWith HRight (VSepSpaces 2) $ map asciiShow - $ (if flipped then reverse else id) $ list - - under = [ "\\ /" , " / " , "/ \\" ] - over = [ "\\ /" , " \\ " , "/ \\" ] - horiz = [ " " , " " , "___" ] - space3 = [ " " , " " , " " ] - --------------------------------------------------------------------------------- - -{- this is unusably ugly and vertically loooong - --- | Vertical braid diagram, drawn from the top to the bottom. --- Strands are numbered from the left to the right. --- --- Writing down the strand numbers from the top and and the bottom --- gives the two-line notation of the permutation realized by the braid. --- -verticalBraidASCII :: KnownNat n => Braid n -> ASCII -verticalBraidASCII braid@(Braid gens) = final where - - n = numberOfStrands braid - - final = hExtendWith HLeft 1 $ vCatLeft allBlocks - allBlocks = prelude ++ middleBlocks ++ epilogue - prelude = [ numberBlock , spaceBlock , beginEndBlock ] - epilogue = [ beginEndBlock , spaceBlock , numberBlock' ] - middleBlocks = map block gens - - block g = case g of - Sigma i -> block' i under - SigmaInv i -> block' i over - - block' i middle = asciiFromLines (map f middle) where - f xs = drop 1 $ concat $ h (i-1) ++ [" ",xs] ++ h (n-i-1) - h k = replicate k " |" - - spaceBlock = transparentBox (n*3-2,1) - beginEndBlock = asciiFromLines $ replicate 3 $ drop 1 $ concat (replicate n " |") - numberBlock = mkNumbers [1..n] - numberBlock' = mkNumbers $ P.fromPermutation $ braidPermutation braid - - mkNumbers :: [Int] -> ASCII - mkNumbers list = asciiFromString (drop 1 $ concatMap show3 list) - show3 k = let s = show k - in replicate (3-length s) ' ' ++ s - - under = [ "\\ /" , " / " , "/ \\" ] - over = [ "\\ /" , " \\ " , "/ \\" ] - --} - --------------------------------------------------------------------------------- --- * List of all words - --- | All positive braid words of the given length -allPositiveBraidWords :: KnownNat n => Int -> [Braid n] -allPositiveBraidWords l = braids where - n = numberOfStrands (head braids) - braids = map Braid $ _allPositiveBraidWords n l - --- | All braid words of the given length -allBraidWords :: KnownNat n => Int -> [Braid n] -allBraidWords l = braids where - n = numberOfStrands (head braids) - braids = map Braid $ _allBraidWords n l - --- | Untyped version of 'allPositiveBraidWords' -_allPositiveBraidWords :: Int -> Int -> [[BrGen]] -_allPositiveBraidWords n = go where - go 0 = [[]] - go k = [ Sigma i : rest | i<-[1..n-1] , rest <- go (k-1) ] - --- | Untyped version of 'allBraidWords' -_allBraidWords :: Int -> Int -> [[BrGen]] -_allBraidWords n = go where - go 0 = [[]] - go k = [ gen : rest | gen <- gens , rest <- go (k-1) ] - gens = concat [ [ Sigma i , SigmaInv i ] | i<-[1..n-1] ] - --------------------------------------------------------------------------------- --- * Random braids - --- | Random braid word of the given length -randomBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g) -randomBraidWord len g = (braid, g') where - braid = Braid w - n = numberOfStrands braid - (w,g') = _randomBraidWord n len g - --- | Random /positive/ braid word of the given length -randomPositiveBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g) -randomPositiveBraidWord len g = (braid, g') where - braid = Braid w - n = numberOfStrands braid - (w,g') = _randomPositiveBraidWord n len g - --------------------------------------------------------------------------------- - --- | Given a braid word, we perturb it randomly @m@ times using the braid relations, --- so that the resulting new braid word is equivalent to the original. --- --- Useful for testing. --- -randomPerturbBraidWord :: forall n g. (RandomGen g, KnownNat n) => Int -> Braid n -> g -> (Braid n, g) -randomPerturbBraidWord m braid@(Braid xs) g = (Braid word' , g') where - - (word',g') = go m (length xs) xs g - - n = numberOfStrands braid - - -- | A random pair cancelling each other - rndE :: g -> ([BrGen],g) - rndE g = (e1,g'') where - (i , g' ) = randomR (1,n-1) g - (b , g'' ) = random g' - e0 = [SigmaInv i, Sigma i] - e1 = if b then reverse e0 else e0 - - brg s i = case s of { Plus -> Sigma i ; Minus -> SigmaInv i } - brginv s i = case s of { Plus -> SigmaInv i ; Minus -> Sigma i } - - go :: Int -> Int -> [BrGen] -> g -> ([BrGen], g) - go !cnt !len !word !g - - | cnt <= 0 = (word, g) - - | len < 2 = let w' = if b1 then (e++word) else (word++e) -- if it is short, we just add a trivial pair somewhere - in continue g4 (len+2) w' - - | abs (i-j) >= 2 = continue g4 len (as ++ v:u:bs) -- they commute, so we just commute them - - | i == j && s/=t = continue g4 (len-2) (as ++ bs ) -- they are inverse of each other, so we kill them - - | abs (i-j) == 1 && s == t = let mid = if b1 - then [ brg s j , brg s i , brg s j , brginv s i ] -- insert pair and - else [ brginv s j , brg s i , brg s j , brg s i ] -- apply ternary relation - in continue g4 (len+2) (as ++ mid ++ bs) - - | otherwise = let mid = if b1 - then (u : e ++ [v]) - else if b2 - then [u,v] ++ e - else e ++ [u,v] - in continue g4 (len+2) (as++(u:e)++[v]++bs) -- otherwise we just insert an trivial pair - - where - - (pos , g1 ) = randomR (0,len-2) g - (b1 :: Bool , g2 ) = random g1 - (b2 :: Bool , g3 ) = random g2 - (e , g4 ) = rndE g3 - (as,u:v:bs) = splitAt pos word - (s,i) = brGenSignIdx u - (t,j) = brGenSignIdx v - - continue g' len' word' = go (cnt-1) len' word' g' - --------------------------------------------------------------------------------- - --- | This version of 'randomBraidWord' may be convenient to avoid the type level stuff -withRandomBraidWord - :: RandomGen g - => (forall n. KnownNat n => Braid n -> a) - -> Int -- ^ number of strands - -> Int -- ^ length of the random word - -> g -> (a, g) -withRandomBraidWord f n len = runRand $ do - withSelectedM f (rand $ randomBraidWord len) n - --- | This version of 'randomPositiveBraidWord' may be convenient to avoid the type level stuff -withRandomPositiveBraidWord - :: RandomGen g - => (forall n. KnownNat n => Braid n -> a) - -> Int -- ^ number of strands - -> Int -- ^ length of the random word - -> g -> (a, g) -withRandomPositiveBraidWord f n len = runRand $ do - withSelectedM f (rand $ randomPositiveBraidWord len) n - --- | Untyped version of 'randomBraidWord' -_randomBraidWord - :: (RandomGen g) - => Int -- ^ number of strands - -> Int -- ^ length of the random word - -> g -> ([BrGen], g) -_randomBraidWord n len = runRand $ replicateM len $ do - k <- randChoose (1,n-1) - s <- randRoll - return $ case s of - Plus -> Sigma k - Minus -> SigmaInv k - --- | Untyped version of 'randomPositiveBraidWord' -_randomPositiveBraidWord - :: (RandomGen g) - => Int -- ^ number of strands - -> Int -- ^ length of the random word - -> g -> ([BrGen], g) -_randomPositiveBraidWord n len = runRand $ replicateM len $ do - liftM Sigma $ randChoose (1,n-1) - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Groups/Braid/NF.hs b/Math/Combinat/Groups/Braid/NF.hs deleted file mode 100644 --- a/Math/Combinat/Groups/Braid/NF.hs +++ /dev/null @@ -1,534 +0,0 @@ - --- | Normal form of braids, take 1. --- --- We implement the Adyan-Thurston-ElRifai-Morton solution to the word problem in braid groups. --- --- --- Based on: --- --- * [1] Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY --- (chapter 5.1) --- --- * [2] Elsayed A. Elrifai, Hugh R. Morton: Algorithms for positive braids --- - -{-# LANGUAGE - CPP, BangPatterns, - ScopedTypeVariables, ExistentialQuantification, - DataKinds, KindSignatures, Rank2Types #-} - -module Math.Combinat.Groups.Braid.NF - ( -- * Normal form - BraidNF (..) - , nfReprWord - , braidNormalForm - , braidNormalForm' - , braidNormalFormNaive' - -- * Starting and finishing sets - , permWordStartingSet - , permWordFinishingSet - , permutationStartingSet - , permutationFinishingSet - ) - where - --------------------------------------------------------------------------------- - -import Data.Proxy -import GHC.TypeLits - -import Control.Monad - -import Data.List ( mapAccumL , foldl' , (\\) ) - -import Data.Array.Unboxed -import Data.Array.ST -import Data.Array.IArray -import Data.Array.MArray -import Data.Array.Unsafe -import Data.Array.Base - -import Control.Monad.ST - -import Math.Combinat.Helper -import Math.Combinat.Sign - -import Math.Combinat.Permutations ( Permutation(..) , (!!!) , isIdentityPermutation , isReversePermutation ) -import qualified Math.Combinat.Permutations as P - -import Math.Combinat.Groups.Braid - --------------------------------------------------------------------------------- - --- | A unique normal form for braids, called the /left-greedy normal form/. --- It looks like @Delta^i*P@, where @Delta@ is the positive half-twist, @i@ is an integer, --- and @P@ is a positive word, which can be further decomposed into non-@Delta@ /permutation words/; --- these words themselves are not unique, but the permutations they realize /are/ unique. --- --- This will solve the word problem relatively fast, --- though it is not the fastest known algorithm. --- -data BraidNF (n :: Nat) = BraidNF - { _nfDeltaExp :: !Int -- ^ the exponent of @Delta@ - , _nfPerms :: [Permutation] -- ^ the permutations - } - deriving (Eq,Ord,Show) - --- | A braid word representing the given normal form -nfReprWord :: KnownNat n => BraidNF n -> Braid n -nfReprWord (BraidNF k perms) = freeReduceBraidWord $ composeMany (deltas ++ rest) where - - deltas - | k > 0 = replicate k halfTwist - | k < 0 = replicate (-k) (inverse halfTwist) - | otherwise = [] - - rest = map permutationBraid perms - --------------------------------------------------------------------------------- - --- | Computes the normal form of a braid. We apply free reduction first, it should be faster that way. -braidNormalForm :: KnownNat n => Braid n -> BraidNF n -braidNormalForm = braidNormalForm' . freeReduceBraidWord - --- | This function does not apply free reduction before computing the normal form -braidNormalForm' :: KnownNat n => Braid n -> BraidNF n -braidNormalForm' braid@(Braid gens) = BraidNF (dexp+pexp) perms where - n = numberOfStrands braid - invless = replaceInverses n gens - (dexp,posxword) = moveDeltasLeft n invless - factors = leftGreedyFactors n $ expandPosXWord n posxword - (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors - --- | This one uses the naive inverse replacement method. Probably somewhat slower than 'braidNormalForm''. -braidNormalFormNaive' :: KnownNat n => Braid n -> BraidNF n -braidNormalFormNaive' braid@(Braid gens) = BraidNF (dexp+pexp) perms where - n = numberOfStrands braid - invless = replaceInversesNaive gens - (dexp,posxword) = moveDeltasLeft n invless - factors = leftGreedyFactors n $ expandPosXWord n posxword - (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors - --------------------------------------------------------------------------------- - --- | Replaces groups of @sigma_i^-1@ generators by @(Delta^-1 * P)@, --- where @P@ is a positive word. --- --- This should be more clever (resulting in shorter words) than the naive version below --- -replaceInverses :: Int -> [BrGen] -> [XGen] -replaceInverses n gens = worker gens where - - worker [] = [] - worker xs = replaceNegs neg ++ map (XSigma . brGenIdx) pos ++ worker rest where - (neg,tmp ) = span (isMinus . brGenSign) xs - (pos,rest) = span (isPlus . brGenSign) tmp - - replaceNegs gs = concatMap replaceFac facs where - facs = leftGreedyFactors n $ map brGenIdx gs - - replaceFac idxs = XDelta (-1) : map XSigma (_permutationBraid perm) where - perm = (P.reversePermutation n) `P.multiplyPermutation` (P.adjacentTranspositions n idxs) - - --- | Replaces @sigma_i^-1@ generators by @(Delta^-1 * L_i)@. -replaceInversesNaive :: [BrGen] -> [XGen] -replaceInversesNaive gens = concatMap f gens where - f (Sigma i) = [ XSigma i ] - f (SigmaInv i) = [ XDelta (-1) , XL i ] - --------------------------------------------------------------------------------- - --- | Temporary data structure to be used during the normal form computation -data XGen - = XDelta !Int -- ^ @Delta^k@ - | XSigma !Int -- ^ @Sigma_j@ - | XL !Int -- ^ @L_j = Delta * sigma_j^-1@ - | XTauL !Int -- ^ @tau(L_j)@ - deriving (Eq,Show) - -isXDelta :: XGen -> Bool -isXDelta x = case x of { XDelta {} -> True ; _ -> False } - --- | We move the all @Delta@'s to the left -moveDeltasLeft :: Int -> [XGen] -> (Int,[XGen]) -moveDeltasLeft n input = (finalExp, finalPosWord) where - - (XDelta finalExp : finalPosWord) = reverse $ worker 0 (reverse input) - - -- we start from the right end, and work towards the left end - worker dexp [] = [ XDelta dexp ] - worker !dexp xs = this' ++ worker dexp' rest where - (delta,notdelta) = span isXDelta xs - (this ,rest ) = span (not . isXDelta) notdelta - dexp' = dexp + sumDeltas delta - this' = if even dexp' - then this - else map xtau this - - sumDeltas :: [XGen] -> Int - sumDeltas xs = foldl' (+) 0 [ k | XDelta k <- xs ] - - -- | The @X -> Delta^-1 * X * Delta@ inner automorphism - xtau :: XGen -> XGen - xtau (XSigma j) = XSigma (n-j) - xtau (XDelta k) = XDelta k - xtau (XL k) = XTauL k - xtau (XTauL k) = XL k - --------------------------------------------------------------------------------- - --- | Expands a /positive/ \"X-word\" into a positive braid word -expandPosXWord :: Int -> [XGen] -> [Int] -expandPosXWord n = concatMap f where - - posHalfTwist = _halfTwist n - - jtau :: Int -> Int - jtau j = n-j - - posLTable = listArray (1,n-1) [ _permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int [Int] - posTauLTable = amap (map jtau) posLTable - - -- posRTable = listArray (1,n-1) [ _permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int [Int] - - f x = case x of - XSigma i -> [i] - XL i -> posLTable ! i - XTauL i -> posTauLTable ! i - XDelta i - | i > 0 -> concat (replicate i posHalfTwist) - | i < 0 -> error "expandPosXWord: negative delta power" - | otherwise -> [] - - -- word :: Braid n -> [Int] - -- word (Braid gens) = map brGenIdx gens - - --- | Expands an \"X-word\" into a braid word. Useful for debugging. -expandAnyXWord :: forall n. KnownNat n => [XGen] -> Braid n -expandAnyXWord xgens = braid where - n = numberOfStrands braid - - braid = composeMany (map f xgens) - - posHalfTwist = halfTwist :: Braid n - negHalfTwist = inverse posHalfTwist :: Braid n - - posLTable = listArray (1,n-1) [ permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n) - posTauLTable = amap tau posLTable - - -- posRTable = listArray (1,n-1) [ permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n) - - f :: XGen -> Braid n - f x = case x of - XSigma i -> sigma i - XL i -> posLTable ! i - XTauL i -> posTauLTable ! i - XDelta i - | i > 0 -> composeMany (replicate i posHalfTwist) - | i < 0 -> composeMany (replicate (-i) negHalfTwist) - | otherwise -> identity - --------------------------------------------------------------------------------- - --- | @posL k@ (denoted as @L_k@) is a /positive word/ which --- satisfies @Delta = L_k * sigma_k@, or: --- --- > (inverse halfTwist) `compose` (posL k) ~=~ sigmaInv k@ --- --- Thus we can replace any word with a positive word plus some @Delta^-1@\'s --- -posL :: KnownNat n => Int -> Braid n -posL k = braid where - n = numberOfStrands braid - braid = permutationBraid (posLPerm n k) - --- | @posR k n@ (denoted as @R_k@) is a /permutation braid/ which --- satisfies @Delta = sigma_k * R_k@ --- --- > (posR k) `compose` (inverse halfTwist) ~=~ sigmaInv k@ --- --- Thus we can replace any word with a positive word plus some @Delta^-1@'s --- -posR :: KnownNat n => Int -> Braid n -posR k = braid where - n = numberOfStrands braid - braid = permutationBraid (posRPerm n k) - --- | The permutation @posL k :: Braid n@ is realizing -posLPerm :: Int -> Int -> Permutation -posLPerm n k - | k>0 && k Int -> Permutation -posRPerm n k - | k>0 && k [[Int]] -> (Int, [[Int]]) -filterDeltaFactors n facs = (exp',facs'') where - - (exp',facs') = go 0 (reverse facs) - - jtau j = n-j - facs'' = reverse facs' - maxlen = div (n*(n-1)) 2 - - go !e [] = (e,[]) - go !e (xs:xxs) - | null xs = go e xxs - | length xs == maxlen = go (e+1) xxs - | otherwise = - if even e - then let (e',yys) = go e xxs in (e' , xs : yys) - else let (e',yys) = go e xxs in (e' , map jtau xs : yys) - --------------------------------------------------------------------------------- - --- | The /starting set/ of a positive braid P is the subset of @[1..n-1]@ defined by --- --- > S(P) = [ i | P = sigma_i * Q , Q is positive ] = [ i | (sigma_i^-1 * P) is positive ] --- --- This function returns the starting set a positive word, assuming it --- is a /permutation braid/ (see Lemma 2.4 in [2]) --- -permWordStartingSet :: Int -> [Int] -> [Int] -permWordStartingSet n xs = permWordFinishingSet n (reverse xs) - --- | The /finishing set/ of a positive braid P is the subset of @[1..n-1]@ defined by --- --- > F(P) = [ i | P = Q * sigma_i , Q is positive ] = [ i | (P * sigma_i^-1) is positive ] --- --- This function returns the finishing set, assuming the input is a /permutation braid/ --- -permWordFinishingSet :: Int -> [Int] -> [Int] -permWordFinishingSet n input = runST action where - - action :: forall s. ST s [Int] - action = do - perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \i -> writeArray perm i i - forM_ input $ \i -> do - a <- readArray perm i - b <- readArray perm (i+1) - writeArray perm i b - writeArray perm (i+1) a - flip filterM [1..n-1] $ \i -> do - a <- readArray perm i - b <- readArray perm (i+1) - return (b permutationStartingSet p == permWordStartingSet n (_permutationBraid p) --- -permutationStartingSet :: Permutation -> [Int] -permutationStartingSet = permutationFinishingSet . P.inversePermutation - --- | This satisfies --- --- > permutationFinishingSet p == permWordFinishingSet n (_permutationBraid p) --- -permutationFinishingSet :: Permutation -> [Int] -permutationFinishingSet perm - = [ i | i<-[1..n-1] , perm !!! i > perm !!! (i+1) ] where n = P.permutationSize perm - --- | Returns the list of permutations failing Lemma 2.5 in [2] --- (so an empty list means the implementaton is correct) -fails_lemmma_2_5 :: Int -> [Permutation] -fails_lemmma_2_5 n = [ p | p <- P.permutations n , not (test p) ] where - test p = and [ check i | i<-[1..n-1] ] where - w = _permutationBraid p - s = permWordStartingSet n w - check i = _isPermutationBraid n (i:w) == (not $ elem i s) - --------------------------------------------------------------------------------- - --- | Given factors defined as permutation braids, we normalize them --- to /left-canonical form/ by ensuring that --- --- * for each consecutive pair @(P,Q)@ the finishing set F(P) contains the starting set S(Q) --- --- * all @Delta@-s (corresponding to the reverse permutation) are moved to the left --- --- * all trivial factors are filtered out --- --- Unfortunately, it seems that we may need multiple sweeps to do that... --- -normalizePermFactors :: Int -> [Permutation] -> (Int,[Permutation]) -normalizePermFactors n = go 0 where - go !acc input = - if (exp==0 && input == output) - then (acc,input) - else go (acc+exp) output - where - (exp,output) = normalizePermFactors1 n input - --- | Does 1 sweep of the above normalization process. --- Unfortunately, it seems that we may need to do this multiple times... --- -normalizePermFactors1 :: Int -> [Permutation] -> (Int,[Permutation]) -normalizePermFactors1 n input = (exp, reverse output) where - (exp, output) = worker 0 (reverse input) - - -- Notes: We work in reverse order, from the right to the left. - -- We maintain the number of Delta-s pushed through; the tau involutions - -- are implicit in the parity of this number - -- - worker :: Int -> [Permutation] -> (Int,[Permutation]) - worker = worker' 0 0 - - -- We also maintain additional 0/1 flip flags for the first two permutations - -- this is a little bit of hack but it should work nicely - -- - worker' :: Int -> Int -> Int -> [Permutation] -> (Int,[Permutation]) - worker' !ep !eq !e (!p : rest@(!q : rest')) - - -- check if the very first element is identity or Delta - -- (note: these are tau-invariants) - - | isIdentityPermutation p = worker' eq 0 e rest - | isReversePermutation p = worker' eq 0 (e+1) rest - - -- check if the second element is identity or Delta - -- this is necessary since we "fatten" the second element and it can possibly - -- become Delta after a while (?) - - | isIdentityPermutation q = worker' ep 0 e (p : rest') - | isReversePermutation q = worker' (ep-1) 0 (e+1) (p : rest') - - -- ok so we have something like "... : Q : P" - -- if F(Q) contains S(P) then we can move on; - -- otherwise there is an element j in S(P) \\ F(Q), so we can - -- replace it by "... : Qj : jP" - - | otherwise = - case permutationStartingSet preal \\ permutationFinishingSet qreal of - [] -> let (e',rs) = worker' eq 0 e rest in (e', preal : rs) - (j:_) -> worker' (-e) (-e) e (p':q':rest') where - s = P.adjacentTransposition n j - p' = P.multiplyPermutation s preal - q' = P.multiplyPermutation qreal s - where - preal = oddTau (e+ep) p -- the "real" p - qreal = oddTau (e+eq) q -- the "real" q - - worker' _ _ !e [ ] = (e,[]) - worker' !ep _ !e [p] - | isIdentityPermutation p = (e , []) - | isReversePermutation p = (e+1 , []) - | otherwise = (e , [oddTau (e+ep) p] ) - - oddTau :: Int -> Permutation -> Permutation - oddTau !e p = if even e then p else tauPerm p - -{- - checkDelta :: Int -> Permutation -> [Permutation] -> (Int,[Permutation]) - checkDelta !e !p !rest - | P.isIdentityPermutation p = worker e rest - | isReversePermutation p = worker (e+1) rest - | otherwise = let (e',rs) = worker e rest in (e', oddTau e p : rs) --} - --------------------------------------------------------------------------------- - --- | Given a /positive/ word, we apply left-greedy factorization of --- that word into subwords representing /permutation braids/. --- --- Example 5.1 from the above handbook: --- --- > leftGreedyFactors 7 [1,3,2,2,1,3,3,2,3,2] == [[1,3,2],[2,1,3],[3,2,3],[2]] --- -leftGreedyFactors :: Int -> [Int] -> [[Int]] -leftGreedyFactors n input = filter (not . null) $ runST (action input) where - - action :: forall s. [Int] -> ST s [[Int]] - action input = do - - perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \i -> writeArray perm i i - let doSwap :: Int -> ST s () - doSwap i = do - a <- readArray perm i - b <- readArray perm (i+1) - writeArray perm i b - writeArray perm (i+1) a - - mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int) - let clearMat = forM_ [1..n] $ \i -> - forM_ [1..n] $ \j -> writeArray mat (i,j) 0 - - let doAdd1 :: Int -> Int -> ST s Int - doAdd1 i j = do - x <- readArray mat (i,j) - let y = x+1 - writeArray mat (i,j) y - writeArray mat (j,i) y - return y - - let worker :: [Int] -> ST s [[Int]] - worker [] = return [[]] - worker (p:ps) = do - u <- readArray perm p - v <- readArray perm (p+1) - c <- doAdd1 u v - doSwap p - if c<=1 - then do - (f:fs) <- worker ps - return ((p:f):fs) - else do - clearMat - fs <- worker (p:ps) - return ([]:fs) - - worker input - --------------------------------------------------------------------------------- - -{- - --- | Finds ternary braid relations, and returns them as a list of indices, decorated --- with a flag specifying which side of the relation we found, a sign specifying --- whether it is a relation between positive or negative generators. --- -findTernaryBraidRelations :: Braid n -> [(Int,Bool,Sign)] -findTernaryBraidRelations (Braid gens) = go 0 gens where - go !k (Sigma a : rest@(Sigma b : Sigma c : _)) - | a==c && b==a+1 = (k,True ,Plus) : go (k+1) rest - | a==c && b==a-1 = (k,False,Plus) : go (k+1) rest - | otherwise = go (k+1) rest - go !k (SigmaInv a : rest@(SigmaInv b : SigmaInv c : _)) - | a==c && b==a+1 = (k,True ,Minus) : go (k+1) rest - | a==c && b==a-1 = (k,False,Minus) : go (k+1) rest - | otherwise = go (k+1) rest - go !k (x:xs) = go (k+1) xs - go _ [] = [] - --- | Finds subsequences like @(i,i+1,i)@ and @(i+1,i,i+1)@, and returns them --- and a list of indices, plus a flag specifying which one we found (the first --- one is 'True', second one is 'False') --- -_findTernaryBraidRelations :: [Int] -> [(Int,Bool)] -_findTernaryBraidRelations = go 0 where - go !k (a:rest@(b:c:_)) - | a==c && b==a+1 = (k,True ) : go (k+1) rest - | a==c && b==a-1 = (k,False) : go (k+1) rest - | otherwise = go (k+1) rest - go !k (x:xs) = go (k+1) xs - go _ [] = [] - --} - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Groups/Free.hs b/Math/Combinat/Groups/Free.hs deleted file mode 100644 --- a/Math/Combinat/Groups/Free.hs +++ /dev/null @@ -1,523 +0,0 @@ - --- | Words in free groups (and free powers of cyclic groups). --- --- This module is not re-exported by "Math.Combinat" --- -{-# LANGUAGE CPP, BangPatterns, PatternGuards #-} -module Math.Combinat.Groups.Free where - --------------------------------------------------------------------------------- - --- new Base exports "Word" from Data.Word... -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,7,1) -import Prelude hiding ( Word ) -#endif -#elif __GLASGOW_HASKELL__ >= 709 -import Prelude hiding ( Word ) -#endif - -import Data.Char ( chr ) -import Data.List ( mapAccumL , groupBy ) - -import Control.Monad ( liftM ) -import System.Random - -import Math.Combinat.Numbers -import Math.Combinat.Sign -import Math.Combinat.Helper - --------------------------------------------------------------------------------- --- * Words - --- | A generator of a (free) group, indexed by which \"copy\" of the group we are dealing with. -data Generator idx - = Gen !idx -- @a@ - | Inv !idx -- @a^(-1)@ - deriving (Eq,Ord,Show,Read) - --- | The index of a generator -genIdx :: Generator idx -> idx -genIdx g = case g of - Gen x -> x - Inv x -> x - --- | The sign of the (exponent of the) generator (that is, the generator is 'Plus', the inverse is 'Minus') -genSign :: Generator idx -> Sign -genSign g = case g of { Gen _ -> Plus ; Inv _ -> Minus } - -genSignValue :: Generator idx -> Int -genSignValue g = case g of { Gen _ -> (1::Int) ; Inv _ -> (-1::Int) } - --- | keep the index, but return always the 'Gen' one. -absGen :: Generator idx -> Generator idx -absGen g = case g of - Gen x -> Gen x - Inv x -> Gen x - --- | A /word/, describing (non-uniquely) an element of a group. --- The identity element is represented (among others) by the empty word. -type Word idx = [Generator idx] - --------------------------------------------------------------------------------- - --- | Generators are shown as small letters: @a@, @b@, @c@, ... --- and their inverses are shown as capital letters, so @A=a^-1@, @B=b^-1@, etc. -showGen :: Generator Int -> Char -showGen (Gen i) = chr (96+i) -showGen (Inv i) = chr (64+i) - -showWord :: Word Int -> String -showWord = map showGen - --------------------------------------------------------------------------------- - -instance Functor Generator where - fmap f g = case g of - Gen x -> Gen (f x) - Inv y -> Inv (f y) - --------------------------------------------------------------------------------- - --- | The inverse of a generator -inverseGen :: Generator a -> Generator a -inverseGen g = case g of - Gen x -> Inv x - Inv x -> Gen x - --- | The inverse of a word -inverseWord :: Word a -> Word a -inverseWord = map inverseGen . reverse - --- | Lists all words of the given length (total number will be @(2g)^n@). --- The numbering of the generators is @[1..g]@. -allWords - :: Int -- ^ @g@ = number of generators - -> Int -- ^ @n@ = length of the word - -> [Word Int] -allWords g = go where - go !0 = [[]] - go !n = [ x:xs | xs <- go (n-1) , x <- elems ] - elems = [ Gen a | a<-[1..g] ] - ++ [ Inv a | a<-[1..g] ] - --- | Lists all words of the given length which do not contain inverse generators --- (total number will be @g^n@). --- The numbering of the generators is @[1..g]@. -allWordsNoInv - :: Int -- ^ @g@ = number of generators - -> Int -- ^ @n@ = length of the word - -> [Word Int] -allWordsNoInv g = go where - go !0 = [[]] - go !n = [ x:xs | xs <- go (n-1) , x <- elems ] - elems = [ Gen a | a<-[1..g] ] - --------------------------------------------------------------------------------- --- * Random words - --- | A random group generator (or its inverse) between @1@ and @g@ -randomGenerator - :: RandomGen g - => Int -- ^ @g@ = number of generators - -> g -> (Generator Int, g) -randomGenerator !d !g0 = (gen, g2) where - (b, !g1) = random g0 - (k, !g2) = randomR (1,d) g1 - gen = if b then Gen k else Inv k - --- | A random group generator (but never its inverse) between @1@ and @g@ -randomGeneratorNoInv - :: RandomGen g - => Int -- ^ @g@ = number of generators - -> g -> (Generator Int, g) -randomGeneratorNoInv !d !g0 = (Gen k, g1) where - (!k, !g1) = randomR (1,d) g0 - --- | A random word of length @n@ using @g@ generators (or their inverses) -randomWord - :: RandomGen g - => Int -- ^ @g@ = number of generators - -> Int -- ^ @n@ = length of the word - -> g -> (Word Int, g) -randomWord !d !n !g0 = (word,g1) where - (g1,word) = mapAccumL (\g _ -> swap (randomGenerator d g)) g0 [1..n] - --- | A random word of length @n@ using @g@ generators (but not their inverses) -randomWordNoInv - :: RandomGen g - => Int -- ^ @g@ = number of generators - -> Int -- ^ @n@ = length of the word - -> g -> (Word Int, g) -randomWordNoInv !d !n !g0 = (word,g1) where - (g1,word) = mapAccumL (\g _ -> swap (randomGeneratorNoInv d g)) g0 [1..n] - --------------------------------------------------------------------------------- --- * The free group on @g@ generators - -{-# SPECIALIZE multiplyFree :: Word Int -> Word Int -> Word Int #-} -{-# SPECIALIZE equivalentFree :: Word Int -> Word Int -> Bool #-} -{-# SPECIALIZE reduceWordFree :: Word Int -> Word Int #-} -{-# SPECIALIZE reduceWordFreeNaive :: Word Int -> Word Int #-} - --- | Multiplication of the free group (returns the reduced result). It is true --- for any two words w1 and w2 that --- --- > multiplyFree (reduceWordFree w1) (reduceWord w2) = multiplyFree w1 w2 --- -multiplyFree :: Eq idx => Word idx -> Word idx -> Word idx -multiplyFree w1 w2 = reduceWordFree (w1 ++ w2) - --- | Decides whether two words represent the same group element in the free group -equivalentFree :: Eq idx => Word idx -> Word idx -> Bool -equivalentFree w1 w2 = null $ reduceWordFree $ w1 ++ inverseWord w2 - --- | Reduces a word in a free group by repeatedly removing @x*x^(-1)@ and --- @x^(-1)*x@ pairs. The set of /reduced words/ forms the free group; the --- multiplication is obtained by concatenation followed by reduction. --- -reduceWordFree :: Eq idx => Word idx -> Word idx -reduceWordFree = loop where - - loop w = case reduceStep w of - Nothing -> w - Just w' -> loop w' - - reduceStep :: Eq a => Word a -> Maybe (Word a) - reduceStep = go False where - go !changed w = case w of - (Gen x : Inv y : rest) | x==y -> go True rest - (Inv x : Gen y : rest) | x==y -> go True rest - (this : rest) -> liftM (this:) $ go changed rest - _ -> if changed then Just w else Nothing - - --- | Naive (but canonical) reduction algorithm for the free groups -reduceWordFreeNaive :: Eq idx => Word idx -> Word idx -reduceWordFreeNaive = loop where - loop w = let w' = step w in if w/=w' then loop w' else w - step = concatMap worker . groupBy (equating genIdx) where - worker gs - | s>0 = replicate s (Gen i) - | s<0 = replicate (abs s) (Inv i) - | otherwise = [] - where - i = genIdx (head gs) - s = sum' (map genSignValue gs) - --------------------------------------------------------------------------------- - --- | Counts the number of words of length @n@ which reduce to the identity element. --- --- Generating function is @Gf_g(u) = \\frac {2g-1} { g-1 + g \\sqrt{ 1 - (8g-4)u^2 } }@ --- -countIdentityWordsFree - :: Int -- ^ g = number of generators in the free group - -> Int -- ^ n = length of the unreduced word - -> Integer -countIdentityWordsFree g n = countWordReductionsFree g n 0 - --- | Counts the number of words of length @n@ whose reduced form has length @k@ --- (clearly @n@ and @k@ must have the same parity for this to be nonzero): --- --- > countWordReductionsFree g n k == sum [ 1 | w <- allWords g n, k == length (reduceWordFree w) ] --- -countWordReductionsFree - :: Int -- ^ g = number of generators in the free group - -> Int -- ^ n = length of the unreduced word - -> Int -- ^ k = length of the reduced word - -> Integer -countWordReductionsFree gens_ nn_ kk_ - | nn==0 = if k==0 then 1 else 0 - | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * gg^(i ) * (gg-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ] - | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] - | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] - | otherwise = 0 - where - g = fromIntegral gens_ :: Integer - nn = fromIntegral nn_ :: Integer - kk = fromIntegral kk_ :: Integer - - gg = 2*g - n = div nn 2 - k = div kk 2 - --------------------------------------------------------------------------------- --- * Free powers of cyclic groups - -{-# SPECIALIZE multiplyZ2 :: Word Int -> Word Int -> Word Int #-} -{-# SPECIALIZE multiplyZ3 :: Word Int -> Word Int -> Word Int #-} -{-# SPECIALIZE multiplyZm :: Int -> Word Int -> Word Int -> Word Int #-} - --- | Multiplication in free products of Z2's -multiplyZ2 :: Eq idx => Word idx -> Word idx -> Word idx -multiplyZ2 w1 w2 = reduceWordZ2 (w1 ++ w2) - --- | Multiplication in free products of Z3's -multiplyZ3 :: Eq idx => Word idx -> Word idx -> Word idx -multiplyZ3 w1 w2 = reduceWordZ3 (w1 ++ w2) - --- | Multiplication in free products of Zm's -multiplyZm :: Eq idx => Int -> Word idx -> Word idx -> Word idx -multiplyZm k w1 w2 = reduceWordZm k (w1 ++ w2) - --------------------------------------------------------------------------------- - -{-# SPECIALIZE equivalentZ2 :: Word Int -> Word Int -> Bool #-} -{-# SPECIALIZE equivalentZ3 :: Word Int -> Word Int -> Bool #-} -{-# SPECIALIZE equivalentZm :: Int -> Word Int -> Word Int -> Bool #-} - --- | Decides whether two words represent the same group element in free products of Z2 -equivalentZ2 :: Eq idx => Word idx -> Word idx -> Bool -equivalentZ2 w1 w2 = null $ reduceWordZ2 $ w1 ++ inverseWord w2 - --- | Decides whether two words represent the same group element in free products of Z3 -equivalentZ3 :: Eq idx => Word idx -> Word idx -> Bool -equivalentZ3 w1 w2 = null $ reduceWordZ3 $ w1 ++ inverseWord w2 - --- | Decides whether two words represent the same group element in free products of Zm -equivalentZm :: Eq idx => Int -> Word idx -> Word idx -> Bool -equivalentZm m w1 w2 = null $ reduceWordZm m $ w1 ++ inverseWord w2 - --------------------------------------------------------------------------------- - -{-# SPECIALIZE reduceWordZ2 :: Word Int -> Word Int #-} -{-# SPECIALIZE reduceWordZ3 :: Word Int -> Word Int #-} -{-# SPECIALIZE reduceWordZm :: Int -> Word Int -> Word Int #-} - --------------------------------------------------------------------------------- - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@ --- (that is, free products of Z2's) -reduceWordZ2 :: Eq idx => Word idx -> Word idx -reduceWordZ2 = loop where - loop w = case reduceStep w of - Nothing -> w - Just w' -> loop w' - - reduceStep :: Eq a => Word a -> Maybe (Word a) - reduceStep = go False where - go !changed w = case w of - (Gen x : Gen y : rest) | x==y -> go True rest - (Gen x : Inv y : rest) | x==y -> go True rest - (Inv x : Gen y : rest) | x==y -> go True rest - (Inv x : Inv y : rest) | x==y -> go True rest - (this : rest) -> liftM (absGen this:) $ go changed rest - _ -> if changed then Just w else Nothing - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@ --- (that is, free products of Z3's) -reduceWordZ3 :: Eq idx => Word idx -> Word idx -reduceWordZ3 = loop where - loop w = case reduceStep w of - Nothing -> w - Just w' -> loop w' - - reduceStep :: Eq a => Word a -> Maybe (Word a) - reduceStep = go False where - go !changed w = case w of - (Gen x : Inv y : rest) | x==y -> go True rest - (Inv x : Gen y : rest) | x==y -> go True rest - (Gen x : Gen y : Gen z : rest) | x==y && y==z -> go True rest - (Inv x : Inv y : Inv z : rest) | x==y && y==z -> go True rest - (Gen x : Gen y : rest) | x==y -> go True (Inv x : rest) -- !!! - (Inv x : Inv y : rest) | x==y -> go True (Gen x : rest) - (this : rest) -> liftM (this:) $ go changed rest - _ -> if changed then Just w else Nothing - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@ --- (that is, free products of Zm's) -reduceWordZm :: Eq idx => Int -> Word idx -> Word idx -reduceWordZm m = loop where - - loop w = case reduceStep w of - Nothing -> w - Just w' -> loop w' - - halfm = div m 2 -- if we encounter strictly more than m/2 equal elements in a row, we replace them by the inverses - - -- reduceStep :: Eq a => Word a -> Maybe (Word a) - reduceStep = go False where - go !changed w = case w of - (Gen x : Inv y : rest) | x==y -> go True rest - (Inv x : Gen y : rest) | x==y -> go True rest - something | Just (k,rest) <- dropIfMoreThanHalf w -> go True (replicate (m-k) (inverseGen (head w)) ++ rest) - (this : rest) -> liftM (this:) $ go changed rest - _ -> if changed then Just w else Nothing - - -- dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a) - dropIfMoreThanHalf w = - let (!k,rest) = dropWhileEqual w - in if k > halfm then Just (k,rest) - else Nothing - - -- dropWhileEqual :: Eq a => Word a -> (Int, Word a) - dropWhileEqual [] = (0,[]) - dropWhileEqual (x0:rest) = go 1 rest where - go !k [] = (k,[]) - go !k xxs@(x:xs) = if k==m then (m,xxs) - else if x==x0 then go (k+1) xs - else (k,xxs) - -{- - dropm :: Eq a => Word a -> Maybe (Word a) - dropm [] = Nothing - dropm (x:xs) = go (m-1) xs where - go 0 rest = Just rest - go j (y:ys) = if y==x - then go (j-1) ys - else Nothing - go j [] = Nothing --} - --------------------------------------------------------------------------------- - -{-# SPECIALIZE reduceWordZ2Naive :: Word Int -> Word Int #-} -{-# SPECIALIZE reduceWordZ3Naive :: Word Int -> Word Int #-} -{-# SPECIALIZE reduceWordZmNaive :: Int -> Word Int -> Word Int #-} - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@ --- (that is, free products of Z2's). Naive (but canonical) algorithm. -reduceWordZ2Naive :: Eq idx => Word idx -> Word idx -reduceWordZ2Naive = loop where - loop w = let w' = step w in if w/=w' then loop w' else w - step = concatMap worker . groupBy (equating genIdx) where - worker gs = - case mod s 2 of - 1 -> [Gen i] - 0 -> [] - _ -> error "reduceWordZ2: fatal error, shouldn't happen" - where - i = genIdx (head gs) - s = sum' (map genSignValue gs) - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@ --- (that is, free products of Z3's). Naive (but canonical) algorithm. -reduceWordZ3Naive :: Eq idx => Word idx -> Word idx -reduceWordZ3Naive = loop where - loop w = let w' = step w in if w/=w' then loop w' else w - step = concatMap worker . groupBy (equating genIdx) where - worker gs = - case mod s 3 of - 0 -> [] - 1 -> [Gen i] - 2 -> [Inv i] - _ -> error "reduceWordZ3: fatal error, shouldn't happen" - where - i = genIdx (head gs) - s = sum' (map genSignValue gs) - --- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@ --- (that is, free products of Zm's). Naive (but canonical) algorithm. -reduceWordZmNaive :: Eq idx => Int -> Word idx -> Word idx -reduceWordZmNaive m = loop where - loop w = let w' = step w in if w/=w' then loop w' else w - step = concatMap worker . groupBy (equating genIdx) where - halfm1 = div (m+1) 2 - worker gs - | mods <= halfm1 = replicate mods (Gen i) - | otherwise = replicate (m-mods) (Inv i) - where - i = genIdx (head gs) - s = sum' (map genSignValue gs) - mods = mod s m - --------------------------------------------------------------------------------- - --- | Counts the number of words (without inverse generators) of length @n@ --- which reduce to the identity element, using the relations @x^2=1@. --- --- Generating function is @Gf_g(u) = \\frac {2g-2} { g-2 + g \\sqrt{ 1 - (4g-4)u^2 } }@ --- --- The first few @g@ cases: --- --- > A000984 = [ countIdentityWordsZ2 2 (2*n) | n<-[0..] ] = [1,2,6,20,70,252,924,3432,12870,48620,184756...] --- > A089022 = [ countIdentityWordsZ2 3 (2*n) | n<-[0..] ] = [1,3,15,87,543,3543,23823,163719,1143999,8099511,57959535...] --- > A035610 = [ countIdentityWordsZ2 4 (2*n) | n<-[0..] ] = [1,4,28,232,2092,19864,195352,1970896,20275660,211823800,2240795848...] --- > A130976 = [ countIdentityWordsZ2 5 (2*n) | n<-[0..] ] = [1,5,45,485,5725,71445,925965,12335685,167817405,2321105525,32536755565...] --- -countIdentityWordsZ2 - :: Int -- ^ g = number of generators in the free group - -> Int -- ^ n = length of the unreduced word - -> Integer -countIdentityWordsZ2 g n = countWordReductionsZ2 g n 0 - --- | Counts the number of words (without inverse generators) of length @n@ whose --- reduced form in the product of Z2-s (that is, for each generator @x@ we have @x^2=1@) --- has length @k@ --- (clearly @n@ and @k@ must have the same parity for this to be nonzero): --- --- > countWordReductionsZ2 g n k == sum [ 1 | w <- allWordsNoInv g n, k == length (reduceWordZ2 w) ] --- -countWordReductionsZ2 - :: Int -- ^ g = number of generators in the free group - -> Int -- ^ n = length of the unreduced word - -> Int -- ^ k = length of the reduced word - -> Integer -countWordReductionsZ2 gens_ nn_ kk_ - | nn==0 = if k==0 then 1 else 0 - | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * g^(i ) * (g-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ] - | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] - | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] - | otherwise = 0 - where - g = fromIntegral gens_ :: Integer - nn = fromIntegral nn_ :: Integer - kk = fromIntegral kk_ :: Integer - - n = div nn 2 - k = div kk 2 - --- | Counts the number of words (without inverse generators) of length @n@ --- which reduce to the identity element, using the relations @x^3=1@. --- --- > countIdentityWordsZ3NoInv g n == sum [ 1 | w <- allWordsNoInv g n, 0 == length (reduceWordZ2 w) ] --- --- In mathematica, the formula is: @Sum[ g^k * (g-1)^(n-k) * k/n * Binomial[3*n-k-1, n-k] , {k, 1,n} ]@ --- -countIdentityWordsZ3NoInv - :: Int -- ^ g = number of generators in the free group - -> Int -- ^ n = length of the unreduced word - -> Integer -countIdentityWordsZ3NoInv gens_ nn_ - | nn==0 = 1 - | mod nn 3 == 0 = sum [ ( binomial (3*n-i-1) (n-i) * g^i * (g-1)^(n-i) * i ) `div` n | i<-[1..n] ] - | otherwise = 0 - where - g = fromIntegral gens_ :: Integer - nn = fromIntegral nn_ :: Integer - - n = div nn 3 - --------------------------------------------------------------------------------- - -{- - --- some basic testing. TODO: real tests - -import Math.Combinat.Helper -import Math.Combinat.Groups.Free - -g = 3 :: Int -maxn = 8 :: Int - -bad_free = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordFree w `equivalentFree` reduceWordFreeNaive w) ] -bad_z2 = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ2 w `equivalentZ2` reduceWordZ2Naive w) ] -bad_z3 = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ3 w `equivalentZ3` reduceWordZ3Naive w) ] -bad_zm m = [ w | n<-[0..maxn] , w <- allWords g n , not (equivalentZm m (reduceWordZm m w) (reduceWordZmNaive m w)) ] - -speed_free = sum' [ length (reduceWordFree w) | n<-[0..maxn] , w <- allWords g n ] -speed_z2 = sum' [ length (reduceWordZ2 w) | n<-[0..maxn] , w <- allWords g n ] -speed_z3 = sum' [ length (reduceWordZ3 w) | n<-[0..maxn] , w <- allWords g n ] -speed_zm m = sum' [ length (reduceWordZm m w) | n<-[0..maxn] , w <- allWords g n ] - -naive_speed_free = sum' [ length (reduceWordFreeNaive w) | n<-[0..maxn] , w <- allWords g n ] -naive_speed_z2 = sum' [ length (reduceWordZ2Naive w) | n<-[0..maxn] , w <- allWords g n ] -naive_speed_z3 = sum' [ length (reduceWordZ3Naive w) | n<-[0..maxn] , w <- allWords g n ] -naive_speed_zm m = sum' [ length (reduceWordZmNaive m w) | n<-[0..maxn] , w <- allWords g n ] - --} - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Groups/Thompson/F.hs b/Math/Combinat/Groups/Thompson/F.hs deleted file mode 100644 --- a/Math/Combinat/Groups/Thompson/F.hs +++ /dev/null @@ -1,404 +0,0 @@ - --- | Thompson's group F. --- --- See eg. --- --- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; --- see --- - -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} -module Math.Combinat.Groups.Thompson.F where - --------------------------------------------------------------------------------- - -import Data.List - -import Math.Combinat.Classes -import Math.Combinat.ASCII - -import Math.Combinat.Trees.Binary ( BinTree ) -import qualified Math.Combinat.Trees.Binary as B - --------------------------------------------------------------------------------- --- * Tree diagrams - --- | A tree diagram, consisting of two binary trees with the same number of leaves, --- representing an element of the group F. -data TDiag = TDiag - { _width :: !Int -- ^ the width is the number of leaves, minus 1, of both diagrams - , _domain :: !T -- ^ the top diagram correspond to the /domain/ - , _range :: !T -- ^ the bottom diagram corresponds to the /range/ - } - deriving (Eq,Ord,Show) - -instance DrawASCII TDiag where - ascii = asciiTDiag - -instance HasWidth TDiag where - width = _width - --- | Creates a tree diagram from two trees -mkTDiag :: T -> T -> TDiag -mkTDiag d1 d2 = reduce $ mkTDiagDontReduce d1 d2 - --- | Creates a tree diagram, but does not reduce it. -mkTDiagDontReduce :: T -> T -> TDiag -mkTDiagDontReduce top bot = - if w1 == w2 - then TDiag w1 top bot - else error "mkTDiag: widths do not match" - where - w1 = treeWidth top - w2 = treeWidth bot - - -isValidTDiag :: TDiag -> Bool -isValidTDiag (TDiag w top bot) = (treeWidth top == w && treeWidth bot == w) - -isPositive :: TDiag -> Bool -isPositive (TDiag w top bot) = (bot == rightVine w) - -isReduced :: TDiag -> Bool -isReduced diag = (reduce diag == diag) - --- | The generator x0 -x0 :: TDiag -x0 = TDiag 2 top bot where - top = branch caret leaf - bot = branch leaf caret - --- | The generator x1 -x1 :: TDiag -x1 = xk 1 - --- | The generators x0, x1, x2 ... -xk :: Int -> TDiag -xk = go where - go k | k< 0 = error "xk: negative indexed generator" - | k==0 = x0 - | otherwise = let TDiag _ t b = go (k-1) - in TDiag (k+2) (branch leaf t) (branch leaf b) - --- | The identity element in the group F -identity :: TDiag -identity = TDiag 0 Lf Lf - --- | A /positive diagram/ is a diagram whose bottom tree (the range) is a right vine. -positive :: T -> TDiag -positive t = TDiag w t (rightVine w) where w = treeWidth t - --- | Swaps the top and bottom of a tree diagram. This is the inverse in the group F. --- (Note: we don't do reduction here, as this operation keeps the reducedness) -inverse :: TDiag -> TDiag -inverse (TDiag w top bot) = TDiag w bot top - --- | Decides whether two (possibly unreduced) tree diagrams represents the same group element in F. -equivalent :: TDiag -> TDiag -> Bool -equivalent diag1 diag2 = (identity == reduce (compose diag1 (inverse diag2))) - --------------------------------------------------------------------------------- --- * Reduction of tree diagrams - --- | Reduces a diagram. The result is a normal form of an element in the group F. -reduce :: TDiag -> TDiag -reduce = worker where - - worker :: TDiag -> TDiag - worker diag = case step diag of - Nothing -> diag - Just diag' -> worker diag' - - step :: TDiag -> Maybe TDiag - step (TDiag w top bot) = - if null idxs - then Nothing - else Just $ TDiag w' top' bot' - where - cs1 = treeCaretList top - cs2 = treeCaretList bot - idxs = sortedIntersect cs1 cs2 - w' = w - length idxs - top' = removeCarets idxs top - bot' = removeCarets idxs bot - - -- | Intersects sorted lists - sortedIntersect :: [Int] -> [Int] -> [Int] - sortedIntersect = go where - go [] _ = [] - go _ [] = [] - go xxs@(x:xs) yys@(y:ys) = case compare x y of - LT -> go xs yys - EQ -> x : go xs ys - GT -> go xxs ys - --- | List of carets at the bottom of the tree, indexed by their left edge position -treeCaretList :: T -> [Int] -treeCaretList = snd . go 0 where - go !x t = case t of - Lf -> (x+1 , [] ) - Ct -> (x+2 , [x] ) - Br t1 t2 -> (x2 , cs1++cs2) where - (x1 , cs1) = go x t1 - (x2 , cs2) = go x1 t2 - --- | Remove the carets with the given indices --- (throws an error if there is no caret at the given index) -removeCarets :: [Int] -> T -> T -removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where - - (_,rem,final) = go 0 idxs tree where - - go :: Int -> [Int] -> T -> (Int,[Int],T) - go !x [] t = (x + treeWidth t , [] , t) - go !x iis@(i:is) t = case t of - Lf -> (x+1 , iis , t) - Ct -> if x==i then (x+2 , is , Lf) else (x+2 , iis , Ct) - Br t1 t2 -> (x2 , iis2 , Br t1' t2') where - (x1 , iis1 , t1') = go x iis t1 - (x2 , iis2 , t2') = go x1 iis1 t2 - --------------------------------------------------------------------------------- --- * Composition of tree diagrams - --- | If @diag1@ corresponds to the PL function @f@, and @diag2@ to @g@, then @compose diag1 diag2@ --- will correspond to @(g.f)@ (note that the order is opposite than normal function composition!) --- --- This is the multiplication in the group F. --- -compose :: TDiag -> TDiag -> TDiag -compose d1 d2 = reduce (composeDontReduce d1 d2) - --- | Compose two tree diagrams without reducing the result -composeDontReduce :: TDiag -> TDiag -> TDiag -composeDontReduce (TDiag w1 top1 bot1) (TDiag w2 top2 bot2) = new where - new = mkTDiagDontReduce top' bot' - (list1,list2) = extensionToCommonTree bot1 top2 - top' = listGraft list1 top1 - bot' = listGraft list2 bot2 - --- | Given two binary trees, we return a pair of list of subtrees which, grafted the to leaves of --- the first (resp. the second) tree, results in the same extended tree. -extensionToCommonTree :: T -> T -> ([T],[T]) -extensionToCommonTree t1 t2 = snd $ go (0,0) (t1,t2) where - go (!x1,!x2) (!t1,!t2) = - case (t1,t2) of - ( Lf , Lf ) -> ( (x1+n1 , x2+n2 ) , ( [Lf] , [Lf] ) ) - ( Lf , Br _ _ ) -> ( (x1+n1 , x2+n2 ) , ( [t2] , replicate n2 Lf ) ) - ( Br _ _ , Lf ) -> ( (x1+n1 , x2+n2 ) , ( replicate n1 Lf , [t1] ) ) - ( Br l1 r1 , Br l2 r2 ) - -> let ( (x1' ,x2' ) , (ps1,ps2) ) = go (x1 ,x2 ) (l1,l2) - ( (x1'',x2'') , (qs1,qs2) ) = go (x1',x2') (r1,r2) - in ( (x1'',x2'') , (ps1++qs1, ps2++qs2) ) - where - n1 = numberOfLeaves t1 - n2 = numberOfLeaves t2 - --------------------------------------------------------------------------------- --- * Subdivions - --- | Returns the list of dyadic subdivision points -subdivision1 :: T -> [Rational] -subdivision1 = go 0 1 where - go !a !b t = case t of - Leaf _ -> [a,b] - Branch l r -> go a c l ++ tail (go c b r) where c = (a+b)/2 - --- | Returns the list of dyadic intervals -subdivision2 :: T -> [(Rational,Rational)] -subdivision2 = go 0 1 where - go !a !b t = case t of - Leaf _ -> [(a,b)] - Branch l r -> go a c l ++ go c b r where c = (a+b)/2 - - --------------------------------------------------------------------------------- --- * Binary trees - --- | A (strict) binary tree with labelled leaves (but unlabelled nodes) -data Tree a - = Branch !(Tree a) !(Tree a) - | Leaf !a - deriving (Eq,Ord,Show,Functor) - --- | The monadic join operation of binary trees -graft :: Tree (Tree a) -> Tree a -graft = go where - go (Branch l r) = Branch (go l) (go r) - go (Leaf t ) = t - --- | A list version of 'graft' -listGraft :: [Tree a] -> Tree b -> Tree a -listGraft subs big = snd $ go subs big where - go ggs@(g:gs) t = case t of - Leaf _ -> (gs,g) - Branch l r -> (gs2, Branch l' r') where - (gs1,l') = go ggs l - (gs2,r') = go gs1 r - --- | A completely unlabelled binary tree -type T = Tree () - -instance DrawASCII T where - ascii = asciiT - -instance HasNumberOfLeaves (Tree a) where - numberOfLeaves = treeNumberOfLeaves - -instance HasWidth (Tree a) where - width = treeWidth - -leaf :: T -leaf = Leaf () - -branch :: T -> T -> T -branch = Branch - -caret :: T -caret = branch leaf leaf - -treeNumberOfLeaves :: Tree a -> Int -treeNumberOfLeaves = go where - go (Branch l r) = go l + go r - go (Leaf _ ) = 1 - --- | The width of the tree is the number of leaves minus 1. -treeWidth :: Tree a -> Int -treeWidth t = numberOfLeaves t - 1 - --- | Enumerates the leaves a tree, starting from 0 -enumerate_ :: Tree a -> Tree Int -enumerate_ = snd . enumerate - --- | Enumerates the leaves a tree, and also returns the number of leaves -enumerate :: Tree a -> (Int, Tree Int) -enumerate = go 0 where - go !k t = case t of - Leaf _ -> (k+1 , Leaf k) - Branch l r -> let (k' ,l') = go k l - (k'',r') = go k' r - in (k'', Branch l' r') - --- | \"Right vine\" of the given width -rightVine :: Int -> T -rightVine k - | k< 0 = error "rightVine: negative width" - | k==0 = leaf - | otherwise = branch leaf (rightVine (k-1)) - --- | \"Left vine\" of the given width -leftVine :: Int -> T -leftVine k - | k< 0 = error "leftVine: negative width" - | k==0 = leaf - | otherwise = branch (leftVine (k-1)) leaf - --- | Flips each node of a binary tree -flipTree :: Tree a -> Tree a -flipTree = go where - go t = case t of - Leaf _ -> t - Branch l r -> Branch (go r) (go l) - --------------------------------------------------------------------------------- --- * Conversion to\/from BinTree - --- | 'Tree' and 'BinTree' are the same type, except that 'Tree' is strict. --- --- TODO: maybe unify these two types? Until that, you can convert between the two --- with these functions if necessary. --- -toBinTree :: Tree a -> B.BinTree a -toBinTree = go where - go (Branch l r) = B.Branch (go l) (go r) - go (Leaf y ) = B.Leaf y - -fromBinTree :: B.BinTree a -> Tree a -fromBinTree = go where - go (B.Branch l r) = Branch (go l) (go r) - go (B.Leaf y ) = Leaf y - --------------------------------------------------------------------------------- --- * Pattern synonyms - -pattern Lf = Leaf () -pattern Br l r = Branch l r -pattern Ct = Br Lf Lf -pattern X0 = TDiag 2 (Br Ct Lf) (Br Lf Ct) -pattern X1 = TDiag 3 (Br Lf (Br Ct Lf)) (Br Lf (Br Lf Ct)) - --------------------------------------------------------------------------------- --- * ASCII - --- | Draws a binary tree, with all leaves at the same (bottom) row -asciiT :: T -> ASCII -asciiT = asciiT' False - --- | Draws a binary tree; when the boolean flag is @True@, we draw upside down -asciiT' :: Bool -> T -> ASCII -asciiT' inv = go where - - go t = case t of - Leaf _ -> emptyRect - Branch l r -> - if yl >= yr - then pasteOnto (yl+yr+1,if inv then yr else 0) (rs $ yl+1) $ - vcat HCenter - (bc $ yr+1) - (hcat bot al ar) - else pasteOnto (yl, if inv then yl else 0) (ls $ yr+1) $ - vcat HCenter - (bc $ yl+1) - (hcat bot al ar) - where - al = go l - ar = go r - yl = asciiYSize al - yr = asciiYSize ar - - bot = if inv then VTop else VBottom - hcat align p q = hCatWith align (HSepString " ") [p,q] - vcat align p q = vCatWith align VSepEmpty $ if inv then [q,p] else [p,q] - bc = if inv then asciiBigInvCaret else asciiBigCaret - ls = if inv then asciiBigRightSlope else asciiBigLeftSlope - rs = if inv then asciiBigLeftSlope else asciiBigRightSlope - - asciiBigCaret :: Int -> ASCII - asciiBigCaret k = hCatWith VTop HSepEmpty [ asciiBigLeftSlope k , asciiBigRightSlope k ] - - asciiBigInvCaret :: Int -> ASCII - asciiBigInvCaret k = hCatWith VTop HSepEmpty [ asciiBigRightSlope k , asciiBigLeftSlope k ] - - asciiBigLeftSlope :: Int -> ASCII - asciiBigLeftSlope k = if k>0 - then asciiFromLines [ replicate l ' ' ++ "/" | l<-[k-1,k-2..0] ] - else emptyRect - - asciiBigRightSlope :: Int -> ASCII - asciiBigRightSlope k = if k>0 - then asciiFromLines [ replicate l ' ' ++ "\\" | l<-[0..k-1] ] - else emptyRect - --- | Draws a binary tree, with all leaves at the same (bottom) row, and labelling --- the leaves starting with 0 (continuing with letters after 9) -asciiTLabels :: T -> ASCII -asciiTLabels = asciiTLabels' False - --- | When the flag is true, we draw upside down -asciiTLabels' :: Bool -> T -> ASCII -asciiTLabels' inv t = - if inv - then vCatWith HLeft VSepEmpty [ labels , asciiT' inv t ] - else vCatWith HLeft VSepEmpty [ asciiT' inv t , labels ] - where - w = treeWidth t - labels = asciiFromString $ intersperse ' ' $ take (w+1) allLabels - allLabels = ['0'..'9'] ++ ['a'..'z'] - --- | Draws a tree diagram -asciiTDiag :: TDiag -> ASCII -asciiTDiag (TDiag _ top bot) = vCatWith HLeft (VSepString " ") [asciiT' False top , asciiT' True bot] - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Helper.hs b/Math/Combinat/Helper.hs deleted file mode 100644 --- a/Math/Combinat/Helper.hs +++ /dev/null @@ -1,329 +0,0 @@ - --- | Miscellaneous helper functions used internally - -{-# LANGUAGE BangPatterns, PolyKinds, GeneralizedNewtypeDeriving #-} -module Math.Combinat.Helper where - --------------------------------------------------------------------------------- - -import Control.Monad -import Control.Applicative ( Applicative(..) ) -- required before AMP (before GHC 7.10) -import Data.Functor.Identity - -import Data.List -import Data.Ord -import Data.Proxy - -import Data.Set (Set) ; import qualified Data.Set as Set -import Data.Map (Map) ; import qualified Data.Map as Map - -import Debug.Trace - -import System.Random -import Control.Monad.Trans.State - --------------------------------------------------------------------------------- --- * debugging - -debug :: Show a => a -> b -> b -debug x y = trace ("-- " ++ show x ++ "\n") y - --------------------------------------------------------------------------------- --- * pairs - -swap :: (a,b) -> (b,a) -swap (x,y) = (y,x) - -pairs :: [a] -> [(a,a)] -pairs = go where - go (x:xs@(y:_)) = (x,y) : go xs - go _ = [] - -pairsWith :: (a -> a -> b) -> [a] -> [b] -pairsWith f = go where - go (x:xs@(y:_)) = f x y : go xs - go _ = [] - --------------------------------------------------------------------------------- --- * lists - -{-# SPECIALIZE sum' :: [Int] -> Int #-} -{-# SPECIALIZE sum' :: [Integer] -> Integer #-} -sum' :: Num a => [a] -> a -sum' = foldl' (+) 0 - -interleave :: [a] -> [a] -> [a] -interleave (x:xs) (y:ys) = x : y : interleave xs ys -interleave [x] [] = x : [] -interleave [] [] = [] -interleave _ _ = error "interleave: shouldn't happen" - -evens, odds :: [a] -> [a] -evens (x:xs) = x : odds xs -evens [] = [] -odds (x:xs) = evens xs -odds [] = [] - --------------------------------------------------------------------------------- --- * multiplication - --- | Product of list of integers, but in interleaved order (for a list of big numbers, --- it should be faster than the linear order) -productInterleaved :: [Integer] -> Integer -productInterleaved = go where - go [] = 1 - go [x] = x - go [x,y] = x*y - go list = go (evens list) * go (odds list) - --- | Faster implementation of @product [ i | i <- [a+1..b] ]@ -productFromTo :: Integral a => a -> a -> Integer -productFromTo = go where - go !a !b - | dif < 1 = 1 - | dif < 5 = product [ fromIntegral i | i<-[a+1..b] ] - | otherwise = go a half * go half b - where - dif = b - a - half = div (a+b+1) 2 - --- | Faster implementation of product @[ i | i <- [a+1,a+3,..b] ]@ -productFromToStride2 :: Integral a => a -> a -> Integer -productFromToStride2 = go where - go !a !b - | dif < 1 = 1 - | dif < 9 = product [ fromIntegral i | i<-[a+1,a+3..b] ] - | otherwise = go a half * go half b - where - dif = b - a - half = a + 2*(div dif 4) - --------------------------------------------------------------------------------- --- * equality and ordering - -equating :: Eq b => (a -> b) -> a -> a -> Bool -equating f x y = (f x == f y) - -reverseOrdering :: Ordering -> Ordering -reverseOrdering LT = GT -reverseOrdering GT = LT -reverseOrdering EQ = EQ - -reverseComparing :: Ord b => (a -> b) -> a -> a -> Ordering -reverseComparing f x y = compare (f y) (f x) - -reverseCompare :: Ord a => a -> a -> Ordering -reverseCompare x y = compare y x -- reverseOrdering $ compare x y - -reverseSort :: Ord a => [a] -> [a] -reverseSort = sortBy reverseCompare - -groupSortBy :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]] -groupSortBy f = groupBy (equating f) . sortBy (comparing f) - -nubOrd :: Ord a => [a] -> [a] -nubOrd = worker Set.empty where - worker _ [] = [] - worker s (x:xs) - | Set.member x s = worker s xs - | otherwise = x : worker (Set.insert x s) xs - --------------------------------------------------------------------------------- --- * increasing \/ decreasing sequences - -{-# SPECIALIZE isWeaklyIncreasing :: [Int] -> Bool #-} -isWeaklyIncreasing :: Ord a => [a] -> Bool -isWeaklyIncreasing = go where - go xs = case xs of - (a:rest@(b:_)) -> a <= b && go rest - [_] -> True - [] -> True - -{-# SPECIALIZE isStrictlyIncreasing :: [Int] -> Bool #-} -isStrictlyIncreasing :: Ord a => [a] -> Bool -isStrictlyIncreasing = go where - go xs = case xs of - (a:rest@(b:_)) -> a < b && go rest - [_] -> True - [] -> True - -{-# SPECIALIZE isWeaklyDecreasing :: [Int] -> Bool #-} -isWeaklyDecreasing :: Ord a => [a] -> Bool -isWeaklyDecreasing = go where - go xs = case xs of - (a:rest@(b:_)) -> a >= b && go rest - [_] -> True - [] -> True - -{-# SPECIALIZE isStrictlyDecreasing :: [Int] -> Bool #-} -isStrictlyDecreasing :: Ord a => [a] -> Bool -isStrictlyDecreasing = go where - go xs = case xs of - (a:rest@(b:_)) -> a > b && go rest - [_] -> True - [] -> True - --------------------------------------------------------------------------------- --- * first \/ last - --- | The boolean argument will @True@ only for the last element -mapWithLast :: (Bool -> a -> b) -> [a] -> [b] -mapWithLast f = go where - go (x : []) = f True x : [] - go (x : xs) = f False x : go xs - -mapWithFirst :: (Bool -> a -> b) -> [a] -> [b] -mapWithFirst f = go True where - go b (x:xs) = f b x : go False xs - -mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b] -mapWithFirstLast f = go True where - go b (x : []) = f b True x : [] - go b (x : xs) = f b False x : go False xs - --------------------------------------------------------------------------------- --- * older helpers for ASCII drawing - --- | extend lines with spaces so that they have the same line -mkLinesUniformWidth :: [String] -> [String] -mkLinesUniformWidth old = zipWith worker ls old where - ls = map length old - m = maximum ls - worker l s = s ++ replicate (m-l) ' ' - -mkBlocksUniformHeight :: [[String]] -> [[String]] -mkBlocksUniformHeight old = zipWith worker ls old where - ls = map length old - m = maximum ls - worker l s = s ++ replicate (m-l) "" - -mkUniformBlocks :: [[String]] -> [[String]] -mkUniformBlocks = map mkLinesUniformWidth . mkBlocksUniformHeight - -hConcatLines :: [[String]] -> [String] -hConcatLines = map concat . transpose . mkUniformBlocks - -vConcatLines :: [[String]] -> [String] -vConcatLines = concat - --------------------------------------------------------------------------------- --- * counting - --- helps testing the random rutines -count :: Eq a => a -> [a] -> Int -count x xs = length $ filter (==x) xs - -histogram :: (Eq a, Ord a) => [a] -> [(a,Int)] -histogram xs = Map.toList table where - table = Map.fromListWith (+) [ (x,1) | x<-xs ] - --------------------------------------------------------------------------------- --- * maybe - -fromJust :: Maybe a -> a -fromJust (Just x) = x -fromJust Nothing = error "fromJust: Nothing" - --------------------------------------------------------------------------------- --- * bool - -intToBool :: Int -> Bool -intToBool 0 = False -intToBool 1 = True -intToBool _ = error "intToBool" - -boolToInt :: Bool -> Int -boolToInt False = 0 -boolToInt True = 1 - --------------------------------------------------------------------------------- --- * iteration - --- iterated function application -nest :: Int -> (a -> a) -> a -> a -nest !0 _ x = x -nest !n f x = nest (n-1) f (f x) - -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) - -unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a] -unfoldM f y = do - (x,m) <- f y - case m of - Nothing -> return [x] - Just y' -> do - xs <- unfoldM f y' - return (x:xs) - -mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) -mapAccumM _ s [] = return (s, []) -mapAccumM f s (x:xs) = do - (s1,y) <- f s x - (s2,ys) <- mapAccumM f s1 xs - return (s2, y:ys) - --------------------------------------------------------------------------------- --- * long zipwith - -longZipWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c] -longZipWith a0 b0 f = go where - go (x:xs) (y:ys) = f x y : go xs ys - go [] ys = [ f a0 y | y<-ys ] - go xs [] = [ f x b0 | x<-xs ] - -{- -longZipWithZero :: (Num a, Num b) => (a -> b -> c) -> [a] -> [b] -> [c] -longZipWithZero = longZipWith 0 0 --} - --------------------------------------------------------------------------------- --- * random - --- | A simple random monad to make life suck less -type Rand g = RandT g Identity - -runRand :: Rand g a -> g -> (a,g) -runRand action g = runIdentity (runRandT action g) - -flipRunRand :: Rand s a -> s -> (s,a) -flipRunRand action g = runIdentity (flipRunRandT action g) - - --- | The Rand monad transformer -newtype RandT g m a = RandT (StateT g m a) deriving (Functor,Applicative,Monad) - -runRandT :: RandT g m a -> g -> m (a,g) -runRandT (RandT stuff) = runStateT stuff - --- | This may be occasionally useful -flipRunRandT :: Monad m => RandT s m a -> s -> m (s,a) -flipRunRandT action ini = liftM swap $ runRandT action ini - - --- | Puts a standard-conforming random function into the monad -rand :: (g -> (a,g)) -> Rand g a -rand user = RandT (state user) - -randRoll :: (RandomGen g, Random a) => Rand g a -randRoll = rand random - -randChoose :: (RandomGen g, Random a) => (a,a) -> Rand g a -randChoose uv = rand (randomR uv) - -randProxy1 :: Rand g (f n) -> Proxy n -> Rand g (f n) -randProxy1 action _ = action - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/LatticePaths.hs b/Math/Combinat/LatticePaths.hs deleted file mode 100644 --- a/Math/Combinat/LatticePaths.hs +++ /dev/null @@ -1,386 +0,0 @@ - --- | 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, FlexibleInstances, TypeSynonymInstances #-} -module Math.Combinat.LatticePaths where - --------------------------------------------------------------------------------- - -import Data.List -import System.Random - -import Math.Combinat.Classes -import Math.Combinat.Numbers -import Math.Combinat.Trees.Binary -import Math.Combinat.ASCII as ASCII - --------------------------------------------------------------------------------- --- * Types - --- | A step in a lattice path -data Step - = UpStep -- ^ the step @(1,1)@ - | DownStep -- ^ the step @(1,-1)@ - deriving (Eq,Ord,Show) - --- | A lattice path is a path using only the allowed steps, never going below the zero level line @y=0@. --- --- Note that if you rotate such a path by 45 degrees counterclockwise, --- you get a path which uses only the steps @(1,0)@ and @(0,1)@, and stays --- above the main diagonal (hence the name, we just use a different convention). --- -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 -> '\\' - -instance DrawASCII LatticePath where - ascii = asciiPath - --------------------------------------------------------------------------------- --- * elementary queries - --- | A lattice path is called \"valid\", if it never goes below the @y=0@ line. -isValidPath :: LatticePath -> Bool -isValidPath = go 0 where - go :: Int -> LatticePath -> Bool - go !y [] = y>=0 - go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } - in if y'<0 then False - else go y' ts - --- | A Dyck path is a lattice path whose last point lies on the @y=0@ line -isDyckPath :: LatticePath -> Bool -isDyckPath = go 0 where - go :: Int -> LatticePath -> Bool - go !y [] = y==0 - go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } - in if y'<0 then False - else go y' ts - --- | Maximal height of a lattice path -pathHeight :: LatticePath -> Int -pathHeight = go 0 0 where - go :: Int -> Int -> LatticePath -> Int - go !h !y [] = h - go !h !y (t:ts) = case t of - UpStep -> go (max h (y+1)) (y+1) ts - DownStep -> go h (y-1) ts - -instance HasHeight LatticePath where - height = pathHeight - -instance HasWidth LatticePath where - width = length - --- | Endpoint of a lattice path, which starts from @(0,0)@. -pathEndpoint :: LatticePath -> (Int,Int) -pathEndpoint = go 0 0 where - go :: Int -> Int -> LatticePath -> (Int,Int) - go !x !y [] = (x,y) - go !x !y (t:ts) = case t of - UpStep -> go (x+1) (y+1) ts - DownStep -> go (x+1) (y-1) ts - --- | Returns the coordinates of the path (excluding the starting point @(0,0)@, but including --- the endpoint) -pathCoordinates :: LatticePath -> [(Int,Int)] -pathCoordinates = go 0 0 where - go :: Int -> Int -> LatticePath -> [(Int,Int)] - go _ _ [] = [] - go !x !y (t:ts) = let x' = x + 1 - 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 :: Int -> Int -> LatticePath -> (Int,Int) - 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 - go :: Int -> LatticePath -> Int - go !k (x:xs@(y:_)) = go (if x==UpStep && y==DownStep then k+1 else k) xs - go !k [x] = k - go !k [ ] = k - --- | Number of points on the path which touch the @y=0@ zero level line --- (excluding the starting point @(0,0)@, but including the endpoint; that is, for Dyck paths it this is always positive!). -pathNumberOfZeroTouches :: LatticePath -> Int -pathNumberOfZeroTouches = pathNumberOfTouches' 0 - --- | Number of points on the path which touch the level line at height @h@ --- (excluding the starting point @(0,0)@, but including the endpoint). -pathNumberOfTouches' - :: Int -- ^ @h@ = the touch level - -> LatticePath -> Int -pathNumberOfTouches' h = go 0 0 0 where - go :: Int -> Int -> Int -> LatticePath -> Int - go !cnt _ _ [] = cnt - go !cnt !x !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } - cnt' = if y'==h then cnt+1 else cnt - in go cnt' (x+1) y' ts - --------------------------------------------------------------------------------- --- * Dyck paths - --- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. --- --- Remark: Dyck paths are obviously in bijection with nested parentheses, and thus --- also with binary trees. --- --- Order is reverse lexicographical: --- --- > sort (dyckPaths m) == reverse (dyckPaths m) --- -dyckPaths :: Int -> [LatticePath] -dyckPaths = map nestedParensToDyckPath . nestedParentheses - --- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. --- --- > sort (dyckPathsNaive m) == sort (dyckPaths m) --- --- Naive recursive algorithm, order is ad-hoc --- -dyckPathsNaive :: Int -> [LatticePath] -dyckPathsNaive = worker where - worker 0 = [[]] - worker m = as ++ bs where - as = [ bracket p | p <- worker (m-1) ] - bs = [ bracket p ++ q | k <- [1..m-1] , p <- worker (k-1) , q <- worker (m-k) ] - bracket p = UpStep : p ++ [DownStep] - --- | The number of Dyck paths from @(0,0)@ to @(2m,0)@ is simply the m\'th Catalan number. -countDyckPaths :: Int -> Integer -countDyckPaths m = catalan m - --- | The trivial bijection -nestedParensToDyckPath :: [Paren] -> LatticePath -nestedParensToDyckPath = map f where - f p = case p of { LeftParen -> UpStep ; RightParen -> DownStep } - --- | The trivial bijection in the other direction -dyckPathToNestedParens :: LatticePath -> [Paren] -dyckPathToNestedParens = map g where - g s = case s of { UpStep -> LeftParen ; DownStep -> RightParen } - --------------------------------------------------------------------------------- --- * Bounded Dyck paths - --- | @boundedDyckPaths h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@. --- Synonym for 'boundedDyckPathsNaive'. --- -boundedDyckPaths - :: Int -- ^ @h@ = maximum height - -> Int -- ^ @m@ = half-length - -> [LatticePath] -boundedDyckPaths = boundedDyckPathsNaive - --- | @boundedDyckPathsNaive h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@. --- --- > sort (boundedDyckPaths h m) == sort [ p | p <- dyckPaths m , pathHeight p <= h ] --- > sort (boundedDyckPaths m m) == sort (dyckPaths m) --- --- Naive recursive algorithm, resulting order is pretty ad-hoc. --- -boundedDyckPathsNaive - :: Int -- ^ @h@ = maximum height - -> Int -- ^ @m@ = half-length - -> [LatticePath] -boundedDyckPathsNaive = worker where - worker !h !m - | h<0 = [] - | m<0 = [] - | m==0 = [[]] - | h<=0 = [] - | otherwise = as ++ bs - where - bracket p = UpStep : p ++ [DownStep] - as = [ bracket p | p <- boundedDyckPaths (h-1) (m-1) ] - bs = [ bracket p ++ q | k <- [1..m-1] , p <- boundedDyckPaths (h-1) (k-1) , q <- boundedDyckPaths h (m-k) ] - --------------------------------------------------------------------------------- --- * More general lattice paths - --- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even. --- Synonym for 'latticePathsNaive' --- -latticePaths :: (Int,Int) -> [LatticePath] -latticePaths = latticePathsNaive - --- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even. --- --- Note that --- --- > sort (dyckPaths n) == sort (latticePaths (0,2*n)) --- --- Naive recursive algorithm, resulting order is pretty ad-hoc. --- -latticePathsNaive :: (Int,Int) -> [LatticePath] -latticePathsNaive (x,y) = worker x y where - worker !x !y - | odd (x-y) = [] - | x<0 = [] - | y<0 = [] - | y==0 = dyckPaths (div x 2) - | x==1 && y==1 = [[UpStep]] - | otherwise = as ++ bs - where - bracket p = UpStep : p ++ [DownStep] - 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 - --- | @touchingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the --- 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 zero-touches - -> Int -- ^ @m@ = half-length - -> [LatticePath] -touchingDyckPaths = touchingDyckPathsNaive - - --- | @touchingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the --- zero level line @y=0@ exactly @k@ times (excluding the starting point, but including the endpoint; --- thus, @k@ should be positive). --- --- > sort (touchingDyckPathsNaive k m) == sort [ p | p <- dyckPaths m , pathNumberOfZeroTouches p == k ] --- --- Naive recursive algorithm, resulting order is pretty ad-hoc. --- -touchingDyckPathsNaive - :: Int -- ^ @k@ = number of zero-touches - -> Int -- ^ @m@ = half-length - -> [LatticePath] -touchingDyckPathsNaive = worker where - worker !k !m - | m == 0 = if k==0 then [[]] else [] - | k <= 0 = [] - | m < 0 = [] - | k == 1 = [ bracket p | p <- dyckPaths (m-1) ] - | 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 - --- | @peakingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks. --- --- Synonym for 'peakingDyckPathsNaive' --- -peakingDyckPaths - :: Int -- ^ @k@ = number of peaks - -> Int -- ^ @m@ = half-length - -> [LatticePath] -peakingDyckPaths = peakingDyckPathsNaive - --- | @peakingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks. --- --- > sort (peakingDyckPathsNaive k m) = sort [ p | p <- dyckPaths m , pathNumberOfPeaks p == k ] --- --- Naive recursive algorithm, resulting order is pretty ad-hoc. --- -peakingDyckPathsNaive - :: Int -- ^ @k@ = number of peaks - -> Int -- ^ @m@ = half-length - -> [LatticePath] -peakingDyckPathsNaive = worker where - worker !k !m - | m == 0 = if k==0 then [[]] else [] - | k <= 0 = [] - | m < 0 = [] - | k == 1 = [ singlePeak m ] - | otherwise = as ++ bs ++ cs - where - as = [ bracket p | p <- worker k (m-1) ] - bs = [ smallHill ++ q | q <- worker (k-1) (m-1) ] - cs = [ bracket p ++ q | l <- [2..m-1] , a <- [1..k-1] , p <- worker a (l-1) , q <- worker (k-a) (m-l) ] - smallHill = [ UpStep , DownStep ] - singlePeak !m = replicate m UpStep ++ replicate m DownStep - bracket p = UpStep : p ++ [DownStep] - --- | Dyck paths of length @2m@ with @k@ peaks are counted by the Narayana numbers @N(m,k) = \binom{m}{k} \binom{m}{k-1} / m@ -countPeakingDyckPaths - :: Int -- ^ @k@ = number of peaks - -> Int -- ^ @m@ = half-length - -> Integer -countPeakingDyckPaths k m - | m == 0 = if k==0 then 1 else 0 - | k <= 0 = 0 - | m < 0 = 0 - | k == 1 = 1 - | otherwise = div (binomial m k * binomial m (k-1)) (fromIntegral m) - --------------------------------------------------------------------------------- --- * Random lattice paths - --- | A uniformly random Dyck path of length @2m@ -randomDyckPath :: RandomGen g => Int -> g -> (LatticePath,g) -randomDyckPath m g0 = (nestedParensToDyckPath parens, g1) where - (parens,g1) = randomNestedParentheses m g0 - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Numbers.hs b/Math/Combinat/Numbers.hs deleted file mode 100644 --- a/Math/Combinat/Numbers.hs +++ /dev/null @@ -1,12 +0,0 @@ - -module Math.Combinat.Numbers - ( module Math.Combinat.Numbers.Integers - , module Math.Combinat.Numbers.Primes - , module Math.Combinat.Numbers.Sequences - ) - where - -import Math.Combinat.Numbers.Integers -import Math.Combinat.Numbers.Primes -import Math.Combinat.Numbers.Sequences - diff --git a/Math/Combinat/Numbers/Integers.hs b/Math/Combinat/Numbers/Integers.hs deleted file mode 100644 --- a/Math/Combinat/Numbers/Integers.hs +++ /dev/null @@ -1,113 +0,0 @@ - --- | Operations on integers - -module Math.Combinat.Numbers.Integers - ( -- * Integer logarithm - integerLog2 - , ceilingLog2 - -- * Integer square root - , isSquare - , integerSquareRoot - , ceilingSquareRoot - , integerSquareRoot' - , integerSquareRootNewton' - ) - where - --------------------------------------------------------------------------------- - --- import Math.Combinat.Numbers - -import Data.List ( group , sort ) -import Data.Bits - -import System.Random - --------------------------------------------------------------------------------- --- Integer logarithm - --- | Largest integer @k@ such that @2^k@ is smaller or equal to @n@ -integerLog2 :: Integer -> Integer -integerLog2 n = go n where - go 0 = -1 - go k = 1 + go (shiftR k 1) - --- | Smallest integer @k@ such that @2^k@ is larger or equal to @n@ -ceilingLog2 :: Integer -> Integer -ceilingLog2 0 = 0 -ceilingLog2 n = 1 + go (n-1) where - go 0 = -1 - go k = 1 + go (shiftR k 1) - --------------------------------------------------------------------------------- --- Integer square root - -isSquare :: Integer -> Bool -isSquare n = - if (fromIntegral $ mod n 32) `elem` rs - then snd (integerSquareRoot' n) == 0 - else False - where - rs = [0,1,4,9,16,17,25] :: [Int] - --- | Integer square root (largest integer whose square is smaller or equal to the input) --- using Newton's method, with a faster (for large numbers) inital guess based on bit shifts. -integerSquareRoot :: Integer -> Integer -integerSquareRoot = fst . integerSquareRoot' - --- | Smallest integer whose square is larger or equal to the input -ceilingSquareRoot :: Integer -> Integer -ceilingSquareRoot n = (if r>0 then u+1 else u) where (u,r) = integerSquareRoot' n - --- | We also return the excess residue; that is --- --- > (a,r) = integerSquareRoot' n --- --- means that --- --- > a*a + r = n --- > a*a <= n < (a+1)*(a+1) -integerSquareRoot' :: Integer -> (Integer,Integer) -integerSquareRoot' n - | n<0 = error "integerSquareRoot: negative input" - | n<2 = (n,0) - | otherwise = go firstGuess - where - k = integerLog2 n - firstGuess = 2^(div (k+2) 2) -- !! note that (div (k+1) 2) is NOT enough !! - go a = - if m < a - then go a' - else (a, r + a*(m-a)) - where - (m,r) = divMod n a - a' = div (m + a) 2 - --- | Newton's method without an initial guess. For very small numbers (<10^10) it --- is somewhat faster than the above version. -integerSquareRootNewton' :: Integer -> (Integer,Integer) -integerSquareRootNewton' n - | n<0 = error "integerSquareRootNewton: negative input" - | n<2 = (n,0) - | otherwise = go (div n 2) - where - go a = - if m < a - then go a' - else (a, r + a*(m-a)) - where - (m,r) = divMod n a - a' = div (m + a) 2 - -{- --- brute force test of integer square root -isqrt_test n1 n2 = - [ k - | k<-[n1..n2] - , let (a,r) = integerSquareRoot' k - , (a*a+r/=k) || (a*a>k) || (a+1)*(a+1)<=k - ] --} - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Numbers/Primes.hs b/Math/Combinat/Numbers/Primes.hs deleted file mode 100644 --- a/Math/Combinat/Numbers/Primes.hs +++ /dev/null @@ -1,361 +0,0 @@ - --- | Prime numbers and related number theoretical stuff. - -module Math.Combinat.Numbers.Primes - ( -- * Elementary number theory - divides - , divisors, squareFreeDivisors, squareFreeDivisors_ - , divisorSum , divisorSum' - , moebiusMu , eulerTotient , liouvilleLambda - -- * List of prime numbers - , primes - , primesSimple - , primesTMWE - -- * Prime factorization - , factorize, factorizeNaive - , productOfFactors - , integerFactorsTrialDivision - , groupIntegerFactors - -- * Modulo @m@ arithmetic - , powerMod - -- * Prime testing - , millerRabinPrimalityTest - , isProbablyPrime - , isVeryProbablyPrime - ) - where - --------------------------------------------------------------------------------- - -import Data.List ( group , sort , foldl' ) - -import Math.Combinat.Sign -import Math.Combinat.Helper -import Math.Combinat.Numbers.Integers - --- import Math.Combinat.Sets ( sublists ) -- cyclic dependency... -import Math.Combinat.Tuples ( tuples' ) - -import Data.Bits - -import System.Random - --------------------------------------------------------------------------------- - --- | @d `divides` n@ -divides :: Integer -> Integer -> Bool -divides d n = (mod n d == 0) - -{-# SPECIALIZE moebiusMu :: Int -> Int #-} -{-# SPECIALIZE moebiusMu :: Integer -> Integer #-} --- | The Moebius mu function -moebiusMu :: (Integral a, Num b) => a -> b -moebiusMu n - | any (>1) expos = 0 - | even (length primes) = 1 - | otherwise = -1 - where - factors = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n - (primes,expos) = unzip factors - -{-# SPECIALIZE liouvilleLambda :: Int -> Int #-} -{-# SPECIALIZE liouvilleLambda :: Integer -> Integer #-} --- | The Liouville lambda function -liouvilleLambda :: (Integral a, Num b) => a -> b -liouvilleLambda n = - if odd (foldl' (+) 0 $ map snd grps) - then -1 - else 1 - where - grps = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n - --- | Sum ofthe of the divisors -divisorSum :: Integer -> Integer -divisorSum n = foldl' (+) 0 [ d | d <- divisors n] - --- | Sum of @k@-th powers of the divisors -divisorSum' :: Int -> Integer -> Integer -divisorSum' k n = foldl' (+) 0 [ d^k | d <- divisors n] - --- | Euler's totient function -eulerTotient :: Integer -> Integer -eulerTotient n = div n prodp * prodp1 where - grps = groupIntegerFactors $ integerFactorsTrialDivision n - ps = map fst grps - prodp = foldl' (*) 1 [ p | p <- ps ] - prodp1 = foldl' (*) 1 [ p-1 | p <- ps ] - --- | Divisors of @n@ (note: the result is /not/ ordered!) -divisors :: Integer -> [Integer] -divisors n = [ f tup | tup <- tuples' expos ] where - grps = groupIntegerFactors $ integerFactorsTrialDivision n - (ps,expos) = unzip grps - f es = foldl' (*) 1 $ zipWith (^) ps es - --- | List of square-free divisors together with their Mobius mu value --- (note: the result is /not/ ordered!) -squareFreeDivisors :: Integer -> [(Integer,Sign)] -squareFreeDivisors n = map f (sublists primes) where - grps = groupIntegerFactors $ integerFactorsTrialDivision n - primes = map fst grps - f ps = ( foldl' (*) 1 ps , if even (length ps) then Plus else Minus) - --- | List of square-free divisors --- (note: the result is /not/ ordered!) -squareFreeDivisors_ :: Integer -> [Integer] -squareFreeDivisors_ n = map f (sublists primes) where - grps = groupIntegerFactors $ integerFactorsTrialDivision n - primes = map fst grps - f ps = foldl' (*) 1 ps - --- | To avoid cyclic dependencies, I made a local copy of this... -sublists :: [a] -> [[a]] -sublists [] = [[]] -sublists (x:xs) = sublists xs ++ map (x:) (sublists xs) - --------------------------------------------------------------------------------- --- List of prime numbers - --- | Infinite list of primes, using the TMWE algorithm. -primes :: [Integer] -primes = primesTMWE - --- | A relatively simple but still quite fast implementation of list of primes. --- By Will Ness -primesSimple :: [Integer] -primesSimple = 2 : 3 : sieve 0 primes' 5 where - primes' = tail primesSimple - sieve k (p:ps) x = noDivs k h ++ sieve (k+1) ps (t+2) where - t = p*p - h = [x,x+2..t-2] - noDivs k = filter (\x -> all (\y -> rem x y /= 0) (take k primes')) - --- | List of primes, using tree merge with wheel. Code by Will Ness. -primesTMWE :: [Integer] -primesTMWE = 2:3:5:7: gaps 11 wheel (fold3t $ roll 11 wheel primes') where - - primes' = 11: gaps 13 (tail wheel) (fold3t $ roll 11 wheel primes') - fold3t ((x:xs): ~(ys:zs:t)) - = x : union xs (union ys zs) `union` fold3t (pairs t) - pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t - wheel = 2:4:2:4:6:2:6:4:2:4:6:6:2:6:4:2:6:4:6:8:4:2:4:2: - 4:8:6:4:6:2:4:6:2:6:6:4:2:4:6:2:6:4:2:4:2:10:2:10:wheel - gaps k ws@(w:t) cs@(~(c:u)) - | k==c = gaps (k+w) t u - | True = k : gaps (k+w) t cs - roll k ws@(w:t) ps@(~(p:u)) - | k==p = scanl (\c d->c+p*d) (p*p) ws : roll (k+w) t u - | True = roll (k+w) t ps - - minus xxs@(x:xs) yys@(y:ys) = case compare x y of - LT -> x : minus xs yys - EQ -> minus xs ys - GT -> minus xxs ys - minus xs [] = xs - minus [] _ = [] - - union xxs@(x:xs) yys@(y:ys) = case compare x y of - LT -> x : union xs yys - EQ -> x : union xs ys - GT -> y : union xxs ys - union xs [] = xs - union [] ys =ys - --------------------------------------------------------------------------------- --- Prime factorization - -factorize :: Integer -> [(Integer,Int)] -factorize = factorizeNaive - -factorizeNaive :: Integer -> [(Integer,Int)] -factorizeNaive = groupIntegerFactors . integerFactorsTrialDivision - -productOfFactors :: [(Integer,Int)] -> Integer -productOfFactors = productInterleaved . map (uncurry pow) where - pow _ 0 = 1 - pow p 1 = p - pow 2 n = shiftL 1 n - pow p 2 = p*p - pow p n = if even n - then (pow p (shiftR n 1))^2 - else p * (pow p (shiftR n 1))^2 - --- | Groups integer factors. Example: from [2,2,2,3,3,5] we produce [(2,3),(3,2),(5,1)] -groupIntegerFactors :: [Integer] -> [(Integer,Int)] -groupIntegerFactors = map f . group . sort where - f xs = (head xs, length xs) - --- | The naive trial division algorithm. -integerFactorsTrialDivision :: Integer -> [Integer] -integerFactorsTrialDivision n - | n<1 = error "integerFactorsTrialDivision: n should be at least 1" - | otherwise = go primes n - where - go _ 1 = [] - go rs k = sub ps k where - sub [] k = [k] - sub qqs@(q:qs) k = case mod k q of - 0 -> q : go qqs (div k q) - _ -> sub qs k - ps = takeWhile (\p -> p*p <= k) rs -{- - go 1 = [] - go k = sub ps k where - sub [] k = [k] - sub (q:qs) k = case mod k q of - 0 -> q : go (div k q) - _ -> sub qs k - ps = takeWhile (\p -> p*p <= k) primes --} - -{- --- brute force testing of factors -ifactorsTest :: (Integer -> [Integer]) -> Integer -> Bool -ifactorsTest alg n = and [ product (alg k) == k | k<-[1..n] ] --} - --------------------------------------------------------------------------------- --- Modulo @m@ arithmetic - --- | Efficient powers modulo m. --- --- > powerMod a k m == (a^k) `mod` m -powerMod :: Integer -> Integer -> Integer -> Integer -powerMod a' k m = {- debug bs $ -} go a bs where - - bs = bin k - - bin 0 = [] - bin x = (x .&. 1 /= 0) : bin (shiftR x 1) - - a = mod a' m - - go _ [] = 1 - go x (b:bs) = -- debug (x,b) $ - if b - then mod (x*rest) m - else rest - where - rest = go (mod (x*x) m) bs - --------------------------------------------------------------------------------- --- Prime testing - --- | Miller-Rabin Primality Test (taken from Haskell wiki). --- We test the primality of the first argument @n@ by using the second argument @a@ as a candidate witness. --- If it returs @False@, then @n@ is composite. If it returns @True@, then @n@ is either prime or composite. --- --- A random choice between @2@ and @(n-2)@ is a good choice for @a@. -millerRabinPrimalityTest :: Integer -> Integer -> Bool -millerRabinPrimalityTest n a - | a <= 1 || a >= n-1 = - error $ "millerRabinPrimalityTest: a out of range (" ++ show a ++ " for "++ show n ++ ")" - | n < 2 = False - | even n = False - | b0 == 1 || b0 == n' = True - | otherwise = iter (tail b) - where - n' = n-1 - (k,m) = find2km n' - b0 = powMod n a m - b = take (fromIntegral k) $ iterate (squareMod n) b0 - iter [] = False - iter (x:xs) - | x == 1 = False - | x == n' = True - | otherwise = iter xs - - -{-# SPECIALIZE find2km :: Integer -> (Integer,Integer) #-} -find2km :: Integral a => a -> (a,a) -find2km n = f 0 n where - f k m - | r == 1 = (k,m) - | otherwise = f (k+1) q - where (q,r) = quotRem m 2 - -{-# SPECIALIZE pow' :: (Integer -> Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer -> Integer #-} -pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a -pow' _ _ _ 0 = 1 -pow' mul sq x' n' = f x' n' 1 where - f x n y - | n == 1 = x `mul` y - | r == 0 = f x2 q y - | otherwise = f x2 q (x `mul` y) - where - (q,r) = quotRem n 2 - x2 = sq x - -{-# SPECIALIZE mulMod :: Integer -> Integer -> Integer -> Integer #-} -mulMod :: Integral a => a -> a -> a -> a -mulMod a b c = (b * c) `mod` a - -{-# SPECIALIZE squareMod :: Integer -> Integer -> Integer #-} -squareMod :: Integral a => a -> a -> a -squareMod a b = (b * b) `rem` a - -{-# SPECIALIZE powMod :: Integer -> Integer -> Integer -> Integer #-} -powMod :: Integral a => a -> a -> a -> a -powMod m = pow' (mulMod m) (squareMod m) - --------------------------------------------------------------------------------- - --- | For very small numbers, we use trial division, for larger numbers, we apply the --- Miller-Rabin primality test @log4(n)@ times, with candidate witnesses derived --- deterministically from @n@ using a pseudo-random sequence --- (which /should be/ based on a cryptographic hash function, but isn\'t, yet). --- --- Thus the candidate witnesses should behave essentially like random, but the --- resulting function is still a deterministic, pure function. --- --- TODO: implement the hash sequence, at the moment we use 'System.Random' instead... --- -isProbablyPrime :: Integer -> Bool -isProbablyPrime n - | n < 2 = False - | even n = (n==2) - | n < 1000 = length (integerFactorsTrialDivision n) == 1 - | otherwise = and [ millerRabinPrimalityTest n a | a <- witnessList ] - where - log2n = integerLog2 n - nchecks = 1 + fromInteger (div log2n 2) :: Int - witnessList = take nchecks pseudoRnds - pseudoRnds = 2 : [ a | a <- integerRndSequence n , a > 1 && a < (n-1) ] - --- | A more exhaustive version of 'isProbablyPrime', this one tests candidate --- witnesses both the first log4(n) prime numbers and then log4(n) pseudo-random --- numbers -isVeryProbablyPrime :: Integer -> Bool -isVeryProbablyPrime n - | n < 2 = False - | even n = (n==2) - | n < 1000 = length (integerFactorsTrialDivision n) == 1 - | otherwise = and [ millerRabinPrimalityTest n a | a <- witnessList ] - where - log2n = integerLog2 n - nchecks = 1 + fromInteger (div log2n 2) :: Int - witnessList = take nchecks primes ++ take nchecks pseudoRnds - pseudoRnds = [ a | a <- integerRndSequence (n+3) , a > 1 && a < (n-1) ] - --------------------------------------------------------------------------------- - -{- --- | Given an integer @n@, we return an infinite sequence of pseudo-random integers --- between @0..n-1@, generated using a crypographic hash function. --- -integerHashSequence :: Integer -> [Integer] -integerHashSequence = error "integerHashSequence: not implemented yet" --} - --- | Given an integer @n@, we initialize a system random generator with using a --- seed derived from @n@ (note that this uses at most 32 or 64 bits), and generate --- an infinite sequence of pseudo-random integers between @0..n-1@, generated by --- that random generator. --- --- Note that this is not really a preferred way of generating such sequences! --- -integerRndSequence :: Integer -> [Integer] -integerRndSequence n = randomRs (0,n-1) gen where - gen = mkStdGen $ fromInteger (n + 17 * integerLog2 n) - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Numbers/Sequences.hs b/Math/Combinat/Numbers/Sequences.hs deleted file mode 100644 --- a/Math/Combinat/Numbers/Sequences.hs +++ /dev/null @@ -1,307 +0,0 @@ - --- | Some important number sequences. --- --- See the \"On-Line Encyclopedia of Integer Sequences\", --- . - -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Numbers.Sequences where - --------------------------------------------------------------------------------- - -import Data.Array -import Data.Bits ( shiftL , shiftR , (.&.) ) - -import Math.Combinat.Helper -import Math.Combinat.Sign - -import Math.Combinat.Numbers.Primes ( primes , factorize , productOfFactors ) - -import qualified Data.Map.Strict as Map -- used for factorialPrimeExponentsNaive - --------------------------------------------------------------------------------- --- * Factorial - --- | The factorial function (A000142). -factorial :: Integral a => a -> Integer -factorial = factorialSplit - --- | Faster implementation of the factorial function -factorialSplit :: Integral a => a -> Integer -factorialSplit n = productFromTo 1 n - --- | Naive implementation of factorial -factorialNaive :: Integral a => a -> Integer -factorialNaive n - | n < 0 = error "factorialNaive: input should be nonnegative" - | n == 0 = 1 - | otherwise = product [1..fromIntegral n] - --- | \"Swing factorial\" algorithm -factorialSwing :: Integral a => a -> Integer -factorialSwing n = productOfFactors (factorialPrimeExponents $ fromIntegral n) where - --------------------------------------------------------------------------------- - --- | Prime factorization of the factorial (using the \"swing factorial\" algorithm) -factorialPrimeExponents :: Int -> [(Integer,Int)] -factorialPrimeExponents n = filter cond $ zip primes (factorialPrimeExponents_ n) where - cond (_,!e) = e > 0 - -factorialPrimeExponentsNaive :: forall a. Integral a => a -> [(Integer,Int)] -factorialPrimeExponentsNaive n = result where - fi = fromIntegral :: a -> Integer - result = Map.toList - $ Map.unionsWith (+) - $ map Map.fromList - $ map factorize - $ map fi [1..n] - -factorialPrimeExponents_ :: Int -> [Int] -factorialPrimeExponents_ = go where - go 0 = [] - go 1 = [] - go 2 = [1] - go !n = longAdd half swing where - half = map (flip shiftL 1) $ go (shiftR n 1) - swing = swingFactorialExponents_ n - - longAdd :: [Int] -> [Int] -> [Int] - longAdd xs [] = xs - longAdd [] ys = ys - longAdd (!x:xs) (!y:ys) = (x+y) : longAdd xs ys - --- | Prime factorizaiton of the \"swing factorial\" function) -swingFactorialExponents_ :: Int -> [Int] -swingFactorialExponents_ = go where - go 0 = [] - go 1 = [] - go 2 = [1] - go n = expo2 : map expo (tail ps) where - - nn = fromIntegral n :: Integer - - ps :: [Integer] - ps = takeWhile (<=nn) primes - - expo2 :: Int - expo2 = go 0 (shiftR n 1) where - go :: Int -> Int -> Int - go !acc !r - | r < 1 = acc - | otherwise = go acc' r' - where - acc' = acc + (r .&. 1) - r' = shiftR r 1 - - expo :: Integer -> Int - expo pp = go 0 (div n p) where - p = fromInteger pp :: Int - go :: Int -> Int -> Int - go !acc !r - | r < 1 = acc - | otherwise = go acc' r' - where - acc' = acc + (r .&. 1) - r' = div r p - --------------------------------------------------------------------------------- - --- | The double factorial -doubleFactorial :: Integral a => a -> Integer -doubleFactorial = doubleFactorialSplit - --- | Faster implementation of the double factorial function -doubleFactorialSplit :: Integral a => a -> Integer -doubleFactorialSplit n - | n < 0 = error "doubleFactorialSplit: input should be nonnegative" - | n == 0 = 1 - | odd n = productFromToStride2 2 n - | otherwise = let halfn = div n 2 - in shiftL (factorialSplit halfn) (fromIntegral halfn) - --- | Naive implementation of the double factorial (A006882). -doubleFactorialNaive :: Integral a => a -> Integer -doubleFactorialNaive n - | n < 0 = error "doubleFactorialNaive: input should be nonnegative" - | n == 0 = 1 - | odd n = product [1,3..fromIntegral n] - | otherwise = product [2,4..fromIntegral n] - --------------------------------------------------------------------------------- --- * Binomial and multinomial - --- | Binomial numbers (A007318). Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below. -binomial :: Integral a => a -> a -> Integer -binomial = binomialSplit - --- | Faster implementation of binomial -binomialSplit :: Integral a => a -> a -> Integer -binomialSplit n k - | k > n = 0 - | k < 0 = 0 - | k > (n `div` 2) = binomialSplit n (n-k) - | otherwise = (productFromTo (n-k) n) `div` (productFromTo 1 k) - --- | A007318. Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below. -binomialNaive :: Integral a => a -> a -> Integer -binomialNaive 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 - --- | The extension of the binomial function to negative inputs. This should satisfy the following properties: --- --- > for n,k >=0 : signedBinomial n k == binomial n k --- > for any n,k : signedBinomial n k == signedBinomial n (n-k) --- > for k >= 0 : signedBinomial (-n) k == (-1)^k * signedBinomial (n+k-1) k --- --- Note: This is compatible with Mathematica's @Binomial@ function. --- -signedBinomial :: Int -> Int -> Integer -signedBinomial n k - | n >= 0 = binomial n k - | k >= 0 = negateIfOdd k $ binomial (k-n-1) k - | otherwise = negateIfOdd (n+k) $ binomial (-k-1) (-n-1) - -{- -test_signed_0 = [ signedBinomial ( n) k == signedBinomial ( n) ( n-k) | n<-[-30..40] , k<-[-30..40] ] -test_signed_1 = [ signedBinomial (-n) k == signedBinomial (-n) (-n-k) | n<-[-30..40] , k<-[-30..40] ] -test_signed_2 = [ signedBinomial (-n) k == negateIfOdd k $ signedBinomial (n+k-1) k | n<-[-30..40] , k<-[0..30] ] --} - --- | A given row of the Pascal triangle; equivalent to a sequence of binomial --- numbers, but much more efficient. You can also left-fold over it. --- --- > pascalRow n == [ binomial n k | k<-[0..n] ] -pascalRow :: Integral a => a -> [Integer] -pascalRow n' = worker 0 1 where - n = fromIntegral n' - worker j x - | j>n = [] - | True = let j'=j+1 in x : worker j' (div (x*(n-j)) j') - -multinomial :: Integral a => [a] -> Integer -multinomial xs = div - (factorial (sum xs)) - (product [ factorial x | x<-xs ]) - --------------------------------------------------------------------------------- --- * Catalan numbers - --- | Catalan numbers. OEIS:A000108. -catalan :: Integral a => a -> Integer -catalan n - | n < 0 = 0 - | otherwise = binomial (n+n) n `div` fromIntegral (n+1) - --- | Catalan's triangle. OEIS:A009766. --- Note: --- --- > catalanTriangle n n == catalan n --- > catalanTriangle n k == countStandardYoungTableaux (toPartition [n,k]) --- -catalanTriangle :: Integral a => a -> a -> Integer -catalanTriangle n k - | k > n = 0 - | k < 0 = 0 - | otherwise = (binomial (n+k) n * fromIntegral (n-k+1)) `div` fromIntegral (n+1) - --------------------------------------------------------------------------------- --- * Stirling numbers - --- | Rows of (signed) Stirling numbers of the first kind. OEIS:A008275. --- Coefficients of the polinomial @(x-1)*(x-2)*...*(x-n+1)@. --- This function uses the recursion formula. -signedStirling1stArray :: Integral a => a -> Array Int Integer -signedStirling1stArray n - | n < 1 = error "stirling1stArray: n should be at least 1" - | n == 1 = listArray (1,1 ) [1] - | otherwise = listArray (1,n') [ lkp (k-1) - fromIntegral (n-1) * lkp k | k<-[1..n'] ] - where - prev = signedStirling1stArray (n-1) - n' = fromIntegral n :: Int - lkp j | j < 1 = 0 - | j >= n' = 0 - | otherwise = prev ! j - --- | (Signed) Stirling numbers of the first kind. OEIS:A008275. --- This function uses 'signedStirling1stArray', so it shouldn't be used --- to compute /many/ Stirling numbers. --- --- Argument order: @signedStirling1st n k@ --- -signedStirling1st :: Integral a => a -> a -> Integer -signedStirling1st n k - | k==0 && n==0 = 1 - | k < 1 = 0 - | k > n = 0 - | otherwise = signedStirling1stArray n ! (fromIntegral k) - --- | (Unsigned) Stirling numbers of the first kind. See 'signedStirling1st'. -unsignedStirling1st :: Integral a => a -> a -> Integer -unsignedStirling1st n k = abs (signedStirling1st n k) - --- | Stirling numbers of the second kind. OEIS:A008277. --- This function uses an explicit formula. --- --- Argument order: @stirling2nd n k@ --- -stirling2nd :: Integral a => a -> a -> Integer -stirling2nd n k - | k==0 && n==0 = 1 - | k < 1 = 0 - | k > n = 0 - | otherwise = sum xs `div` factorial k where - xs = [ negateIfOdd (k-i) $ binomial k i * (fromIntegral i)^n | i<-[0..k] ] - --------------------------------------------------------------------------------- --- * Bernoulli numbers - --- | Bernoulli numbers. @bernoulli 1 == -1%2@ and @bernoulli k == 0@ for --- k>2 and /odd/. This function uses the formula involving Stirling numbers --- of the second kind. Numerators: A027641, denominators: A027642. -bernoulli :: Integral a => a -> Rational -bernoulli n - | n < 0 = error "bernoulli: n should be nonnegative" - | n == 0 = 1 - | n == 1 = -1/2 - | otherwise = sum [ f k | k<-[1..n] ] - where - f k = toRational (negateIfOdd (n+k) $ factorial k * stirling2nd n k) - / toRational (k+1) - --------------------------------------------------------------------------------- --- * Bell numbers - --- | Bell numbers (Sloane's A000110) from B(0) up to B(n). B(0)=B(1)=1, B(2)=2, etc. --- --- The Bell numbers count the number of /set partitions/ of a set of size @n@ --- --- See --- -bellNumbersArray :: Integral a => a -> Array Int Integer -bellNumbersArray nn = arr where - arr = array (0::Int,n) kvs - n = fromIntegral nn :: Int - kvs = (0,1) : [ (k, f k) | k<-[1..n] ] - f n = sum' [ binomial (n-1) k * arr ! k | k<-[0..n-1] ] - --- | The n-th Bell number B(n), using the Stirling numbers of the second kind. --- This may be slower than using 'bellNumbersArray'. -bellNumber :: Integral a => a -> Integer -bellNumber nn - | n < 0 = error "bellNumber: expecting a nonnegative index" - | n == 0 = 1 - | otherwise = sum' [ stirling2nd n k | k<-[1..n] ] - where - n = fromIntegral nn :: Int - --------------------------------------------------------------------------------- - - - diff --git a/Math/Combinat/Numbers/Series.hs b/Math/Combinat/Numbers/Series.hs deleted file mode 100644 --- a/Math/Combinat/Numbers/Series.hs +++ /dev/null @@ -1,434 +0,0 @@ - --- | Some basic univariate power series expansions. --- This module is not re-exported by "Math.Combinat". --- --- Note: the \"@convolveWithXXX@\" functions are much faster than the equivalent --- @(XXX \`convolve\`)@! --- --- TODO: better names for these functions. --- - -{-# LANGUAGE CPP, BangPatterns, GeneralizedNewtypeDeriving #-} -module Math.Combinat.Numbers.Series where - --------------------------------------------------------------------------------- - -import Data.List - -import Math.Combinat.Sign -import Math.Combinat.Numbers -import Math.Combinat.Partitions.Integer -import Math.Combinat.Helper - --------------------------------------------------------------------------------- --- * Trivial series - --- | The series [1,0,0,0,0,...], which is the neutral element for the convolution. -{-# SPECIALIZE unitSeries :: [Integer] #-} -unitSeries :: Num a => [a] -unitSeries = 1 : repeat 0 - --- | Constant zero series -zeroSeries :: Num a => [a] -zeroSeries = repeat 0 - --- | Power series representing a constant function -constSeries :: Num a => a -> [a] -constSeries x = x : repeat 0 - --- | The power series representation of the identity function @x@ -idSeries :: Num a => [a] -idSeries = 0 : 1 : repeat 0 - --- | The power series representation of @x^n@ -powerTerm :: Num a => Int -> [a] -powerTerm n = replicate n 0 ++ (1 : repeat 0) - --------------------------------------------------------------------------------- --- * Basic operations on power series - -addSeries :: Num a => [a] -> [a] -> [a] -addSeries xs ys = longZipWith 0 0 (+) xs ys - -sumSeries :: Num a => [[a]] -> [a] -sumSeries [] = [0] -sumSeries xs = foldl1' addSeries xs - -subSeries :: Num a => [a] -> [a] -> [a] -subSeries xs ys = longZipWith 0 0 (-) xs ys - -negateSeries :: Num a => [a] -> [a] -negateSeries = map negate - -scaleSeries :: Num a => a -> [a] -> [a] -scaleSeries s = map (*s) - --- | A different implementation, taken from: --- --- M. Douglas McIlroy: Power Series, Power Serious -mulSeries :: Num a => [a] -> [a] -> [a] -mulSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where - go (f:fs) ggs@(g:gs) = f*g : (scaleSeries f gs) `addSeries` go fs ggs - --- | Multiplication of power series. This implementation is a synonym for 'convolve' -mulSeriesNaive :: Num a => [a] -> [a] -> [a] -mulSeriesNaive = convolve - -productOfSeries :: Num a => [[a]] -> [a] -productOfSeries = convolveMany - --------------------------------------------------------------------------------- --- * Convolution (product) - --- | Convolution of series (that is, multiplication of power series). --- The result is always an infinite list. Warning: This is slow! -convolve :: Num a => [a] -> [a] -> [a] -convolve xs1 ys1 = res where - res = [ foldl' (+) 0 (zipWith (*) xs (reverse (take n ys))) - | n<-[1..] - ] - xs = xs1 ++ repeat 0 - ys = ys1 ++ repeat 0 - --- | Convolution (= product) of many series. Still slow! -convolveMany :: Num a => [[a]] -> [a] -convolveMany [] = 1 : repeat 0 -convolveMany xss = foldl1 convolve xss - --------------------------------------------------------------------------------- --- * Reciprocals of general power series - --- | Division of series. --- --- Taken from: M. Douglas McIlroy: Power Series, Power Serious -divSeries :: (Eq a, Fractional a) => [a] -> [a] -> [a] -divSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where - go (0:fs) (0:gs) = go fs gs - go (f:fs) ggs@(g:gs) = let q = f/g in q : go (fs `subSeries` scaleSeries q gs) ggs - --- | Given a power series, we iteratively compute its multiplicative inverse -reciprocalSeries :: (Eq a, Fractional a) => [a] -> [a] -reciprocalSeries series = case series of - [] -> error "reciprocalSeries: empty input series (const 0 function does not have an inverse)" - (a:as) -> case a of - 0 -> error "reciprocalSeries: input series has constant term 0" - _ -> map (/a) $ integralReciprocalSeries $ map (/a) series - --- | Given a power series starting with @1@, we can compute its multiplicative inverse --- without divisions. --- -{-# SPECIALIZE integralReciprocalSeries :: [Int] -> [Int] #-} -{-# SPECIALIZE integralReciprocalSeries :: [Integer] -> [Integer] #-} -integralReciprocalSeries :: (Eq a, Num a) => [a] -> [a] -integralReciprocalSeries series = case series of - [] -> error "integralReciprocalSeries: empty input series (const 0 function does not have an inverse)" - (a:as) -> case a of - 1 -> 1 : worker [1] - _ -> error "integralReciprocalSeries: input series must start with 1" - where - worker bs = let b' = - sum (zipWith (*) (tail series) bs) - in b' : worker (b':bs) - --------------------------------------------------------------------------------- --- * Composition of formal power series - --- | @g \`composeSeries\` f@ is the power series expansion of @g(f(x))@. --- This is a synonym for @flip substitute@. --- --- This implementation is taken from --- --- M. Douglas McIlroy: Power Series, Power Serious -composeSeries :: (Eq a, Num a) => [a] -> [a] -> [a] -composeSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where - go (f:fs) (0:gs) = f : mulSeries gs (go fs (0:gs)) - go (f:fs) (_:gs) = error "PowerSeries/composeSeries: we expect the the constant term of the inner series to be zero" - --- | @substitute f g@ is the power series corresponding to @g(f(x))@. --- Equivalently, this is the composition of univariate functions (in the \"wrong\" order). --- --- Note: for this to be meaningful in general (not depending on convergence properties), --- we need that the constant term of @f@ is zero. -substitute :: (Eq a, Num a) => [a] -> [a] -> [a] -substitute f g = composeSeries g f - --- | Naive implementation of 'composeSeries' (via 'substituteNaive') -composeSeriesNaive :: (Eq a, Num a) => [a] -> [a] -> [a] -composeSeriesNaive g f = substituteNaive f g - --- | Naive implementation of 'substitute' -substituteNaive :: (Eq a, Num a) => [a] -> [a] -> [a] -substituteNaive as_ bs_ = - case head as of - 0 -> [ f n | n<-[0..] ] - _ -> error "PowerSeries/substituteNaive: we expect the the constant term of the inner series to be zero" - where - as = as_ ++ repeat 0 - bs = bs_ ++ repeat 0 - a i = as !! i - b j = bs !! j - f n = sum - [ b m * product [ (a i)^j | (i,j)<-es ] * fromInteger (multinomial (map snd es)) - | p <- partitions n - , let es = toExponentialForm p - , let m = partitionWidth p - ] - --------------------------------------------------------------------------------- --- * Lagrange inversions - --- | We expect the input series to match @(0:a1:_)@. with a1 nonzero The following is true for the result (at least with exact arithmetic): --- --- > substitute f (lagrangeInversion f) == (0 : 1 : repeat 0) --- > substitute (lagrangeInversion f) f == (0 : 1 : repeat 0) --- --- This implementation is taken from: --- --- M. Douglas McIlroy: Power Series, Power Serious -lagrangeInversion :: (Eq a, Fractional a) => [a] -> [a] -lagrangeInversion xs = go (xs ++ repeat 0) where - go (0:fs) = rs where rs = 0 : divSeries unitSeries (composeSeries fs rs) - go (_:fs) = error "lagrangeInversion: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero" - --- | Coefficients of the Lagrange inversion -lagrangeCoeff :: Partition -> Integer -lagrangeCoeff p = div numer denom where - numer = (-1)^m * product (map fromIntegral [n+1..n+m]) - denom = fromIntegral (n+1) * product (map (factorial . snd) es) - m = partitionWidth p - n = partitionWeight p - es = toExponentialForm p - --- | We expect the input series to match @(0:1:_)@. The following is true for the result (at least with exact arithmetic): --- --- > substitute f (integralLagrangeInversion f) == (0 : 1 : repeat 0) --- > substitute (integralLagrangeInversion f) f == (0 : 1 : repeat 0) --- -integralLagrangeInversionNaive :: (Eq a, Num a) => [a] -> [a] -integralLagrangeInversionNaive series_ = - case series of - (0:1:rest) -> 0 : 1 : [ f n | n<-[1..] ] - _ -> error "integralLagrangeInversionNaive: the series should start with (0 + x + a2*x^2 + ...)" - where - series = series_ ++ repeat 0 - as = tail series - a i = as !! i - f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ] - | p <- partitions n - ] - --- | Naive implementation of 'lagrangeInversion' -lagrangeInversionNaive :: (Eq a, Fractional a) => [a] -> [a] -lagrangeInversionNaive series_ = - case series of - (0:a1:rest) -> if a1 ==0 - then err - else 0 : (1/a1) : [ f n / a1^(n+1) | n<-[1..] ] - _ -> err - where - err = error "lagrangeInversionNaive: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero" - series = series_ ++ repeat 0 - a1 = series !! 1 - as = map (/a1) (tail series) - a i = as !! i - f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ] - | p <- partitions n - ] - - --------------------------------------------------------------------------------- --- * Differentiation and integration - -differentiateSeries :: Num a => [a] -> [a] -differentiateSeries (y:ys) = go (1::Int) ys where - go !n (x:xs) = fromIntegral n * x : go (n+1) xs - go _ [] = [] - -integrateSeries :: Fractional a => [a] -> [a] -integrateSeries ys = 0 : go (1::Int) ys where - go !n (x:xs) = x / (fromIntegral n) : go (n+1) xs - go _ [] = [] - --------------------------------------------------------------------------------- --- * Power series expansions of elementary functions - --- | Power series expansion of @exp(x)@ -expSeries :: Fractional a => [a] -expSeries = go 0 1 where - go i e = e : go (i+1) (e / (i+1)) - --- | Power series expansion of @cos(x)@ -cosSeries :: Fractional a => [a] -cosSeries = go 0 1 where - go i e = e : 0 : go (i+2) (-e / ((i+1)*(i+2))) - --- | Power series expansion of @sin(x)@ -sinSeries :: Fractional a => [a] -sinSeries = go 1 1 where - go i e = 0 : e : go (i+2) (-e / ((i+1)*(i+2))) - --- | Alternative implementation using differential equations. --- --- Taken from: M. Douglas McIlroy: Power Series, Power Serious -cosSeries2, sinSeries2 :: Fractional a => [a] -cosSeries2 = unitSeries `subSeries` integrateSeries sinSeries2 -sinSeries2 = integrateSeries cosSeries2 - --- | Power series expansion of @cosh(x)@ -coshSeries :: Fractional a => [a] -coshSeries = go 0 1 where - go i e = e : 0 : go (i+2) (e / ((i+1)*(i+2))) - --- | Power series expansion of @sinh(x)@ -sinhSeries :: Fractional a => [a] -sinhSeries = go 1 1 where - go i e = 0 : e : go (i+2) (e / ((i+1)*(i+2))) - --- | Power series expansion of @log(1+x)@ -log1Series :: Fractional a => [a] -log1Series = 0 : go 1 1 where - go i e = (e/i) : go (i+1) (-e) - --- | Power series expansion of @(1-Sqrt[1-4x])/(2x)@ (the coefficients are the Catalan numbers) -dyckSeries :: Num a => [a] -dyckSeries = [ fromInteger (catalan i) | i<-[(0::Int)..] ] - --------------------------------------------------------------------------------- --- * \"Coin\" series - --- | Power series expansion of --- --- > 1 / ( (1-x^k_1) * (1-x^k_2) * ... * (1-x^k_n) ) --- --- Example: --- --- @(coinSeries [2,3,5])!!k@ is the number of ways --- to pay @k@ dollars with coins of two, three and five dollars. --- --- TODO: better name? -coinSeries :: [Int] -> [Integer] -coinSeries [] = 1 : repeat 0 -coinSeries (k:ks) = xs where - xs = zipWith (+) (coinSeries ks) (replicate k 0 ++ xs) - --- | Generalization of the above to include coefficients: expansion of --- --- > 1 / ( (1-a_1*x^k_1) * (1-a_2*x^k_2) * ... * (1-a_n*x^k_n) ) --- -coinSeries' :: Num a => [(a,Int)] -> [a] -coinSeries' [] = 1 : repeat 0 -coinSeries' ((a,k):aks) = xs where - xs = zipWith (+) (coinSeries' aks) (replicate k 0 ++ map (*a) xs) - -convolveWithCoinSeries :: [Int] -> [Integer] -> [Integer] -convolveWithCoinSeries ks series1 = worker ks where - series = series1 ++ repeat 0 - worker [] = series - worker (k:ks) = xs where - xs = zipWith (+) (worker ks) (replicate k 0 ++ xs) - -convolveWithCoinSeries' :: Num a => [(a,Int)] -> [a] -> [a] -convolveWithCoinSeries' ks series1 = worker ks where - series = series1 ++ repeat 0 - worker [] = series - worker ((a,k):aks) = xs where - xs = zipWith (+) (worker aks) (replicate k 0 ++ map (*a) xs) - --------------------------------------------------------------------------------- --- * Reciprocals of products of polynomials - --- | Convolution of many 'pseries', that is, the expansion of the reciprocal --- of a product of polynomials -productPSeries :: [[Int]] -> [Integer] -productPSeries = foldl (flip convolveWithPSeries) unitSeries - --- | The same, with coefficients. -productPSeries' :: Num a => [[(a,Int)]] -> [a] -productPSeries' = foldl (flip convolveWithPSeries') unitSeries - -convolveWithProductPSeries :: [[Int]] -> [Integer] -> [Integer] -convolveWithProductPSeries kss ser = foldl (flip convolveWithPSeries) ser kss - --- | This is the most general function in this module; all the others --- are special cases of this one. -convolveWithProductPSeries' :: Num a => [[(a,Int)]] -> [a] -> [a] -convolveWithProductPSeries' akss ser = foldl (flip convolveWithPSeries') ser akss - --------------------------------------------------------------------------------- --- * Reciprocals of polynomials - --- Reciprocals of polynomials, without coefficients - --- | The power series expansion of --- --- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n) --- -pseries :: [Int] -> [Integer] -pseries ks = convolveWithPSeries ks unitSeries - --- | Convolve with (the expansion of) --- --- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n) --- -convolveWithPSeries :: [Int] -> [Integer] -> [Integer] -convolveWithPSeries ks series1 = ys where - series = series1 ++ repeat 0 - ys = worker ks ys - worker [] _ = series - worker (k:ks) ys = xs where - xs = zipWith (+) (replicate k 0 ++ ys) (worker ks ys) - --------------------------------------------------------------------------------- --- Reciprocals of polynomials, with coefficients - --- | The expansion of --- --- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n) --- -pseries' :: Num a => [(a,Int)] -> [a] -pseries' aks = convolveWithPSeries' aks unitSeries - --- | Convolve with (the expansion of) --- --- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n) --- -convolveWithPSeries' :: Num a => [(a,Int)] -> [a] -> [a] -convolveWithPSeries' aks series1 = ys where - series = series1 ++ repeat 0 - ys = worker aks ys - worker [] _ = series - worker ((a,k):aks) ys = xs where - xs = zipWith (+) (replicate k 0 ++ map (*a) ys) (worker aks ys) - -{- -data Sign = Plus | Minus deriving (Eq,Show) - -signValue :: Num a => Sign -> a -signValue Plus = 1 -signValue Minus = -1 --} - -signedPSeries :: [(Sign,Int)] -> [Integer] -signedPSeries aks = convolveWithSignedPSeries aks unitSeries - --- | Convolve with (the expansion of) --- --- > 1 / (1 +- x^k_1 +- x^k_2 +- x^k_3 +- ... +- x^k_n) --- --- Should be faster than using `convolveWithPSeries'`. --- Note: 'Plus' corresponds to the coefficient @-1@ in `pseries'` (since --- there is a minus sign in the definition there)! -convolveWithSignedPSeries :: [(Sign,Int)] -> [Integer] -> [Integer] -convolveWithSignedPSeries aks series1 = ys where - series = series1 ++ repeat 0 - ys = worker aks ys - worker [] _ = series - worker ((a,k):aks) ys = xs where - xs = case a of - Minus -> zipWith (+) one two - Plus -> zipWith (-) one two - one = worker aks ys - two = replicate k 0 ++ ys - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Partitions.hs b/Math/Combinat/Partitions.hs deleted file mode 100644 --- a/Math/Combinat/Partitions.hs +++ /dev/null @@ -1,22 +0,0 @@ - --- | Partitions of integers and multisets. --- Integer partitions are nonincreasing sequences of positive integers. --- --- See: --- --- * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B. --- --- * --- - -{-# LANGUAGE BangPatterns #-} -module Math.Combinat.Partitions - ( module Math.Combinat.Partitions.Integer - ) - where - --------------------------------------------------------------------------------- - -import Math.Combinat.Partitions.Integer - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Integer.hs b/Math/Combinat/Partitions/Integer.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Integer.hs +++ /dev/null @@ -1,459 +0,0 @@ - --- | 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 CPP, BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Partitions.Integer - ( -- module Math.Combinat.Partitions.Integer.Count - module Math.Combinat.Partitions.Integer.Naive - -- * Types and basic stuff - , Partition - -- * Conversion to\/from lists - , fromPartition - , mkPartition - , toPartition - , toPartitionUnsafe - , isPartition - -- * Conversion to\/from exponent vectors - , toExponentVector - , fromExponentVector - , dropTailingZeros - -- * Union and sum - , unionOfPartitions - , sumOfPartitions - -- * Generating partitions - , partitions - , partitions' - , allPartitions - , allPartitionsGrouped - , allPartitions' - , allPartitionsGrouped' - -- * Counting partitions - , countPartitions - , countPartitions' - , countAllPartitions - , countAllPartitions' - , countPartitionsWithKParts - -- * Random partitions - , randomPartition - , randomPartitions - -- * Dominating \/ dominated partitions - , dominanceCompare - , dominatedPartitions - , dominatingPartitions - -- * Conjugate lexicographic ordering - , conjugateLexicographicCompare - , ConjLex (..) , fromConjLex - -- * Partitions with given number of parts - , partitionsWithKParts - -- * Partitions with only odd\/distinct parts - , partitionsWithOddParts - , partitionsWithDistinctParts - -- * Sub- and super-partitions of a given partition - , subPartitions - , allSubPartitions - , superPartitions - -- * ASCII Ferrers diagrams - , PartitionConvention(..) - , asciiFerrersDiagram - , asciiFerrersDiagram' - ) - where - --------------------------------------------------------------------------------- - -import Data.List -import Control.Monad ( liftM , replicateM ) - --- import Data.Map (Map) --- import qualified Data.Map as Map - -import Math.Combinat.Classes -import Math.Combinat.ASCII as ASCII -import Math.Combinat.Numbers (factorial,binomial,multinomial) -import Math.Combinat.Helper - -import Data.Array -import System.Random - -import Math.Combinat.Partitions.Integer.Naive hiding () -- this is for haddock! -import Math.Combinat.Partitions.Integer.IntList -import Math.Combinat.Partitions.Integer.Count - ---------------------------------------------------------------------------------- --- * Conversion to\/from lists - -fromPartition :: Partition -> [Int] -fromPartition (Partition_ part) = part - --- | Sorts the input, and cuts the nonpositive elements. -mkPartition :: [Int] -> Partition -mkPartition xs = toPartitionUnsafe $ sortBy (reverseCompare) $ filter (>0) xs - --- | 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" - --- | Assumes that the input is decreasing. -toPartitionUnsafe :: [Int] -> Partition -toPartitionUnsafe = Partition_ - --- | This returns @True@ if the input is non-increasing sequence of --- /positive/ integers (possibly empty); @False@ otherwise. --- -isPartition :: [Int] -> Bool -isPartition [] = True -isPartition [x] = x > 0 -isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs - --------------------------------------------------------------------------------- --- * Conversion to\/from exponent vectors - --- | Converts a partition to an exponent vector. --- --- For example, --- --- > toExponentVector (Partition [4,4,2,2,2,1]) == [1,3,0,2] --- --- meaning @(1^1,2^3,3^0,4^2)@. --- -toExponentVector :: Partition -> [Int] -toExponentVector part = fun 1 $ reverse $ group (fromPartition part) where - fun _ [] = [] - fun !k gs@(this@(i:_):rest) - | k < i = replicate (i-k) 0 ++ fun i gs - | otherwise = length this : fun (k+1) rest - -fromExponentVector :: [Int] -> Partition -fromExponentVector expos = Partition $ concat $ reverse $ zipWith f [1..] expos where - f !i !e = replicate e i - -dropTailingZeros :: [Int] -> [Int] -dropTailingZeros = reverse . dropWhile (==0) . reverse - -{- --- alternative implementation -toExponentialVector2 :: Partition -> [Int] -toExponentialVector2 p = go 1 (toExponentialForm p) where - go _ [] = [] - go !i ef@((j,e):rest) = if i Partition [4,2,1] `unionOfPartitions` Partition [4,3,1] == Partition [4,4,3,2,1,1] --- --- Note: This is the dual of pointwise sum, 'sumOfPartitions' --- -unionOfPartitions :: Partition -> Partition -> Partition -unionOfPartitions (Partition_ xs) (Partition_ ys) = mkPartition (xs ++ ys) - --- | Pointwise sum of the parts. For example: --- --- > Partition [3,2,1,1] `sumOfPartitions` Partition [4,3,1] == Partition [7,5,2,1] --- --- Note: This is the dual of 'unionOfPartitions' --- -sumOfPartitions :: Partition -> Partition -> Partition -sumOfPartitions (Partition_ xs) (Partition_ ys) = Partition_ (longZipWith 0 0 (+) xs ys) - --------------------------------------------------------------------------------- --- * Generating partitions - --- | Partitions of @d@. -partitions :: Int -> [Partition] -partitions = map toPartitionUnsafe . _partitions - --- | 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 - --------------------------------------------------------------------------------- - --- | 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 = concat [ partitions i | i <- [0..d] ] - --- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@), --- grouped by weight -allPartitionsGrouped :: Int -> [[Partition]] -allPartitionsGrouped d = [ partitions i | i <- [0..d] ] - --- | All integer partitions fitting into a given rectangle. -allPartitions' - :: (Int,Int) -- ^ (height,width) - -> [Partition] -allPartitions' (h,w) = concat [ partitions' (h,w) i | i <- [0..d] ] where d = h*w - --- | All integer partitions fitting into a given rectangle, grouped by weight. -allPartitionsGrouped' - :: (Int,Int) -- ^ (height,width) - -> [[Partition]] -allPartitionsGrouped' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w - - ---------------------------------------------------------------------------------- --- * Random partitions - --- | Uniformly random partition of the given weight. --- --- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely), --- and the first time it is executed may be slower (as it needs to build the table of partitions counts first) --- --- Algorithm of Nijenhuis and Wilf (1975); see --- --- * Knuth Vol 4A, pre-fascicle 3B, exercise 47; --- --- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10 --- -randomPartition :: RandomGen g => Int -> g -> (Partition, g) -randomPartition n g = (p, g') where - ([p], g') = randomPartitions 1 n g - --- | Generates several uniformly random partitions of @n@ at the same time. --- Should be a little bit faster then generating them individually. --- -randomPartitions - :: forall g. RandomGen g - => Int -- ^ number of partitions to generate - -> Int -- ^ the weight of the partitions - -> g -> ([Partition], g) -randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where - - cnt = countPartitions - - finish :: [(Int,Int)] -> Partition - finish = mkPartition . concatMap f where f (j,d) = replicate j d - - fi :: Int -> Integer - fi = fromIntegral - - find_jd :: Int -> Integer -> (Int,Int) - find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where - go :: Integer -> [(Int,Int)] -> (Int,Int) - go !s [] = (1,1) -- ?? - go !s [jd] = jd -- ?? - go !s (jd@(j,d):rest) = - if s' > capm - then jd - else go s' rest - where - s' = s + fi d * cnt (m - j*d) - - worker :: Int -> [(Int,Int)] -> Rand g Partition - worker 0 acc = return $ finish acc - worker !m acc = do - capm <- randChoose (0, (fi m) * cnt m - 1) - let jd@(!j,!d) = find_jd m capm - worker (m - j*d) (jd:acc) - --------------------------------------------------------------------------------- --- * Dominating \/ dominated partitions - --- | Dominance partial ordering as a partial ordering. -dominanceCompare :: Partition -> Partition -> Maybe Ordering -dominanceCompare p q - | p==q = Just EQ - | p `dominates` q = Just GT - | q `dominates` p = Just LT - | otherwise = Nothing - --- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@ --- (that is, all partial sums are less or equal): --- --- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ] --- -dominatedPartitions :: Partition -> [Partition] -dominatedPartitions (Partition_ lambda) = map Partition_ (_dominatedPartitions lambda) - --- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@ --- (that is, all partial sums are greater or equal): --- --- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ] --- -dominatingPartitions :: Partition -> [Partition] -dominatingPartitions (Partition_ mu) = map Partition_ (_dominatingPartitions mu) - --------------------------------------------------------------------------------- --- * Conjugate lexicographic ordering - -conjugateLexicographicCompare :: Partition -> Partition -> Ordering -conjugateLexicographicCompare p q = compare (dualPartition q) (dualPartition p) - -newtype ConjLex = ConjLex Partition deriving (Eq,Show) - -fromConjLex :: ConjLex -> Partition -fromConjLex (ConjLex p) = p - -instance Ord ConjLex where - compare (ConjLex p) (ConjLex q) = conjugateLexicographicCompare p q - --- {- CONJUGATE LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -} --- let test n = [ ConjLex p >= ConjLex q | p <- partitions n , q <-partitions n , p `dominates` q ] --- and (test 20) - --- {- LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -} --- let test n = [ p >= q | p <- partitions n , q <-partitions n , p `dominates` q ] --- and (test 20) - --------------------------------------------------------------------------------- --- * 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) ] - --------------------------------------------------------------------------------- --- * Partitions with only odd\/distinct parts - --- | Partitions of @n@ with only odd parts -partitionsWithOddParts :: Int -> [Partition] -partitionsWithOddParts d = map Partition_ (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] - -{- --- | Partitions of @n@ with only even parts --- --- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@ --- -partitionsWithEvenParts :: Int -> [Partition] -partitionsWithEvenParts d = map Partition (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ] --} - --- | Partitions of @n@ with distinct parts. --- --- Note: --- --- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) --- -partitionsWithDistinctParts :: Int -> [Partition] -partitionsWithDistinctParts d = map Partition_ (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] - --------------------------------------------------------------------------------- --- * Sub- and super-partitions of a given partition - --- | 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) - --- | All sub-partitions of a given partition -allSubPartitions :: Partition -> [Partition] -allSubPartitions (Partition_ ps) = map Partition_ (_allSubPartitions ps) - --- | Super-partitions of a given partition with the given weight: --- --- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ] --- -superPartitions :: Int -> Partition -> [Partition] -superPartitions d (Partition_ ps) = map toPartitionUnsafe (_superPartitions d ps) - - --------------------------------------------------------------------------------- --- * 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 - -instance DrawASCII Partition where - ascii = asciiFerrersDiagram - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Partitions/Integer/Compact.hs b/Math/Combinat/Partitions/Integer/Compact.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Integer/Compact.hs +++ /dev/null @@ -1,355 +0,0 @@ - -{- | Compact representation of integer partitions. - -Partitions are conceptually nonincreasing sequences of /positive/ integers. - -This implementation uses the @compact-word-vectors@ library internally to provide -a much more memory-efficient Partition type that the naive lists of integer. -This is very helpful when building large tables indexed by partitions, for example; -and hopefully quite a bit faster, too. - -Note: This is an internal module, you are not supposed to import it directly. -It is also not fully ready to be used yet... - --} - -{-# LANGUAGE BangPatterns, PatternSynonyms, ViewPatterns #-} -module Math.Combinat.Partitions.Integer.Compact where - --------------------------------------------------------------------------------- - -import Data.Bits -import Data.Word -import Data.Ord -import Data.List ( intercalate , group , sort , sortBy , foldl' , scanl' ) - -import Data.Vector.Compact.WordVec ( WordVec , Shape(..) ) -import qualified Data.Vector.Compact.WordVec as V - -import Math.Combinat.Compositions ( compositions' ) - --------------------------------------------------------------------------------- --- * The compact partition data type - -newtype Partition - = Partition WordVec - deriving Eq - -instance Show Partition where - showsPrec = showsPrecPartition - -showsPrecPartition :: Int -> Partition -> ShowS -showsPrecPartition prec (Partition vec) - = showParen (prec > 10) - $ showString "Partition" - . showChar ' ' - . shows (V.toList vec) - -instance Ord Partition where - compare = cmpLexico - --------------------------------------------------------------------------------- --- * Pattern synonyms - --- | Pattern sysnonyms allows us to use existing code with minimal modifications -pattern Nil :: Partition -pattern Nil <- (isEmpty -> True) where - Nil = empty - -pattern Cons :: Int -> Partition -> Partition -pattern Cons x xs <- (uncons -> Just (x,xs)) where - Cons x xs = cons x xs - --- | Simulated newtype constructor -pattern Partition_ :: [Int] -> Partition -pattern Partition_ xs <- (toList -> xs) where - Partition_ xs = fromDescList xs - -pattern Head :: Int -> Partition -pattern Head h <- (height -> h) - -pattern Tail :: Partition -> Partition -pattern Tail xs <- (partitionTail -> xs) - -pattern Length :: Int -> Partition -pattern Length n <- (width -> n) - --------------------------------------------------------------------------------- --- * Lexicographic comparison - --- | The lexicographic ordering -cmpLexico :: Partition -> Partition -> Ordering -cmpLexico (Partition vec1) (Partition vec2) = compare (V.toList vec1) (V.toList vec2) - --------------------------------------------------------------------------------- --- * Basic (de)constructrion - -empty :: Partition -empty = Partition (V.empty) - -isEmpty :: Partition -> Bool -isEmpty (Partition vec) = V.null vec - --------------------------------------------------------------------------------- - -singleton :: Int -> Partition -singleton x - | x > 0 = Partition (V.singleton $ i2w x) - | x == 0 = empty - | otherwise = error "Parittion/singleton: negative input" - --------------------------------------------------------------------------------- - -uncons :: Partition -> Maybe (Int,Partition) -uncons (Partition vec) = case V.uncons vec of - Nothing -> Nothing - Just (h,tl) -> Just (w2i h, Partition tl) - --- | @partitionTail p == snd (uncons p)@ -partitionTail :: Partition -> Partition -partitionTail (Partition vec) = Partition (V.tail vec) - -------------------------------------------------------------------------------- - --- | We assume that @x >= partitionHeight p@! -cons :: Int -> Partition -> Partition -cons !x (Partition !vec) - | V.null vec = Partition (if x > 0 then V.singleton y else V.empty) - | y >= h = Partition (V.cons y vec) - | otherwise = error "Partition/cons: invalid element to cons" - where - y = i2w x - h = V.head vec - --------------------------------------------------------------------------------- - --- | We assume that the element is not bigger than the last element! -snoc :: Partition -> Int -> Partition -snoc (Partition !vec) !x - | x == 0 = Partition vec - | V.null vec = Partition (V.singleton y) - | y <= V.last vec = Partition (V.snoc vec y) - | otherwise = error "Partition/snoc: invalid element to snoc" - where - y = i2w x - --------------------------------------------------------------------------------- --- * exponential form - -toExponentialForm :: Partition -> [(Int,Int)] -toExponentialForm = map (\xs -> (head xs,length xs)) . group . toAscList - -fromExponentialForm :: [(Int,Int)] -> Partition -fromExponentialForm = fromDescList . concatMap f . sortBy g where - f (!i,!e) = replicate e i - g (!i, _) (!j,_) = compare j i - --------------------------------------------------------------------------------- --- * Width and height of the bounding rectangle - --- | Width, or the number of parts -width :: Partition -> Int -width (Partition vec) = V.vecLen vec - --- | Height, or the first (that is, the largest) element -height :: Partition -> Int -height (Partition vec) = w2i (V.head vec) - --- | Width and height -widthHeight :: Partition -> (Int,Int) -widthHeight (Partition vec) = (V.vecLen vec , w2i (V.head vec)) - --------------------------------------------------------------------------------- --- * Differential sequence - --- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the sequence of differences --- @[a1-a2,a2-a3,...,an-0]@ -diffSequence :: Partition -> [Int] -diffSequence = go . toDescList where - go (x:ys@(y:_)) = (x-y) : go ys - go [x] = [x] - go [] = [] - ----------------------------------------- - --- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the reversed sequence of differences --- @[ a[n]-0 , a[n-1]-a[n] , ... , a[2]-a[3] , a[1]-a[2] ] @ -reverseDiffSequence :: Partition -> [Int] -reverseDiffSequence p = go (0 : toAscList p) where - go (x:ys@(y:_)) = (y-x) : go ys - go [x] = [] - go [] = [] - --------------------------------------------------------------------------------- --- * Dual partition - -dualPartition :: Partition -> Partition -dualPartition compact@(Partition vec) - | V.null vec = Partition V.empty - | otherwise = Partition (V.fromList' shape $ map i2w dual) - where - height = V.head vec - len = V.vecLen vec - shape = Shape (w2i height) (V.bitsNeededFor $ i2w len) - dual = concat - [ replicate d j - | (j,d) <- zip (descendToOne len) (reverseDiffSequence compact) - ] - --------------------------------------------------------------------------------- --- * Conversion to list - -toList :: Partition -> [Int] -toList = toDescList - --- | returns a descending (non-increasing) list -toDescList :: Partition -> [Int] -toDescList (Partition vec) = map w2i (V.toList vec) - --- | Returns a reversed (ascending; non-decreasing) list -toAscList :: Partition -> [Int] -toAscList (Partition vec) = map w2i (V.toRevList vec) - --------------------------------------------------------------------------------- --- * Conversion from list - -fromDescList :: [Int] -> Partition -fromDescList list = fromDescList' (length list) list - --- | We assume that the input is a non-increasing list of /positive/ integers! -fromDescList' - :: Int -- ^ length - -> [Int] -- ^ the list - -> Partition -fromDescList' !len !list = Partition (V.fromList' (Shape len bits) $ map i2w list) where - bits = case list of - [] -> 4 - (x:xs) -> V.bitsNeededFor (i2w x) - --------------------------------------------------------------------------------- --- * Partial orderings - --- @ |p `isSubPartitionOf` q@ -isSubPartitionOf :: Partition -> Partition -> Bool -isSubPartitionOf p q = and $ zipWith (<=) (toList p) (toList q ++ repeat 0) - --- | @q `dominates` p@ -dominates :: Partition -> Partition -> Bool -dominates (Partition vec_q) (Partition vec_p) = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) where - sums = tail . scanl' (+) 0 - ps = V.toList vec_p - qs = V.toList vec_q - --------------------------------------------------------------------------------- --- * Pieri rule - --- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See -pieriRule :: Partition -> Int -> [Partition] -pieriRule = error "Partitions/Integer/Compact: pieriRule not implemented yet" - -{- --- | Expands to product @s[lambda]*h[1] = s[lambda]*e[1]@ as a sum of @s[mu]@-s. See -pieriRuleSingleBox :: Partition -> [Partition] -pieriRuleSingleBox !compact = case compact of - - Nibble 0 -> [ singleton 1 ] - - Nibble w | h < 15 -> - [ Nibble (w + shiftL 1 (60-4*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ] - - Medium1 w | h < 255 -> - [ Medium1 (w + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ] - - Medium2 w1 w2 | h < 255 -> - let (diffs1a,diffs1b) = splitAt 8 diffs1 - in [ Medium2 (w1 + shiftL 1 (56-8*i)) w2 | (i,d)<-zip [0..7 ] diffs1a , d>0 ] ++ - [ Medium2 w1 (w2 + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-9] diffs1b , d>0 ] ++ - [ snoc compact 1 ] - - Medium3 w1 w2 w3 | h < 255 -> - let (diffs1a,tmp ) = splitAt 8 diffs1 - (diffs1b,diffs1c) = splitAt 8 tmp - in [ Medium3 (w1 + shiftL 1 (56-8*i)) w2 w3 | (i,d)<-zip [0..7 ] diffs1a , d>0 ] ++ - [ Medium3 w1 (w2 + shiftL 1 (56-8*i)) w3 | (i,d)<-zip [0..7 ] diffs1b , d>0 ] ++ - [ Medium3 w1 w2 (w3 + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-17] diffs1c , d>0 ] ++ - [ snoc compact 1 ] - - _ -> genericSingleBox - - where - (n,h) = widthHeight compact - list = toDescList compact - diffs1 = 1 : diffSequence compact - - genericSingleBox :: [Partition] - genericSingleBox = map (fromDescList' n) (go list diffs1) ++ [ fromDescList' (n+1) (list ++ [1]) ] where - go :: [Int] -> [Int] -> [[Int]] - go (a:as) (d:ds) = if d > 0 then ((a+1):as) : map (a:) (go as ds) - else map (a:) (go as ds) - go [] _ = [] - --- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See -pieriRule :: Partition -> Int -> [Partition] -pieriRule !compact !k - | k < 0 = [] - | k == 0 = [ compact ] - | k == 1 = pieriRuleSingleBox compact - | h == 0 = [ singleton k ] - | h + k <= 15 && n < 15 = case compact of { Nibble w -> - [ Nibble (w + encode c) | c <- comps ] } - | otherwise = [ fromDescList' (n+b) xs | c <- comps , let (b,xs) = add c ] - - where - (n,h) = widthHeight compact - list = toDescList compact - bounds = k : {- map (min k) -} (diffSequence compact) - comps = compositions' bounds k - - add clist = go list clist where - go (!p:ps) (!c:cs) = let (b,rest) = go ps cs in (b, (p+c):rest) - go [] [c] = if c>0 then (1,[c]) else (0,[]) - go _ _ = error "Compact/pieriRule/add: shouldn't happen" - - encode :: [Int] -> Word64 - encode = go 60 where - go !k [c] = if c==0 then 0 else shiftL (i2w c) k + 1 - go !k (c:cs) = shiftL (i2w c) k + go (k-4) cs - go !k [] = error "Compact/pieriRule/encode: shouldn't happen" --} - --------------------------------------------------------------------------------- --- * local (internally used) utility functions - -{-# INLINE i2w #-} -i2w :: Int -> Word -i2w = fromIntegral - -{-# INLINE w2i #-} -w2i :: Word -> Int -w2i = fromIntegral - -{-# INLINE sum' #-} -sum' :: [Word] -> Word -sum' = foldl' (+) 0 - -{-# INLINE safeTail #-} -safeTail :: [Int] -> [Int] -safeTail xs = case xs of { [] -> [] ; _ -> tail xs } - -{-# INLINE descendToZero #-} -descendToZero :: Int -> [Int] -descendToZero !n - | n > 0 = n : descendToZero (n-1) - | n == 0 = [0] - | n < 0 = [] - -{-# INLINE descendToOne #-} -descendToOne :: Int -> [Int] -descendToOne !n - | n > 1 = n : descendToOne (n-1) - | n == 1 = [1] - | n < 1 = [] - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Partitions/Integer/Count.hs b/Math/Combinat/Partitions/Integer/Count.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Integer/Count.hs +++ /dev/null @@ -1,215 +0,0 @@ - --- | Counting partitions of integers. - -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Partitions.Integer.Count where - --------------------------------------------------------------------------------- - -import Data.List -import Control.Monad ( liftM , replicateM ) - --- import Data.Map (Map) --- import qualified Data.Map as Map - -import Math.Combinat.Numbers ( factorial , binomial , multinomial ) -import Math.Combinat.Numbers.Integers -- Primes -import Math.Combinat.Helper - -import Data.Array -import System.Random - --------------------------------------------------------------------------------- --- * Infinite tables of integers - --- | A data structure which is essentially an infinite list of @Integer@-s, --- but fast lookup (for reasonable small inputs) -newtype TableOfIntegers = TableOfIntegers [Array Int Integer] - -lookupInteger :: TableOfIntegers -> Int -> Integer -lookupInteger (TableOfIntegers table) !n - | n >= 0 = (table !! k) ! r - | n < 0 = 0 - where - (k,r) = divMod n 1024 - -makeTableOfIntegers - :: ((Int -> Integer) -> (Int -> Integer)) - -> TableOfIntegers -makeTableOfIntegers user = table where - calc = user lkp - lkp = lookupInteger table - table = TableOfIntegers - [ listArray (0,1023) (map calc [a..b]) - | k<-[0..] - , let a = 1024*k - , let b = 1024*(k+1) - 1 - ] - --------------------------------------------------------------------------------- --- * Counting partitions - --- | Number of partitions of @n@ (looking up a table built using Euler's algorithm) -countPartitions :: Int -> Integer -countPartitions = lookupInteger partitionCountTable - --- | This uses the power series expansion of the infinite product. It is slower than the above. -countPartitionsInfiniteProduct :: Int -> Integer -countPartitionsInfiniteProduct k = partitionCountListInfiniteProduct !! k - --- | This uses 'countPartitions'', and is (very) slow -countPartitionsNaive :: Int -> Integer -countPartitionsNaive d = countPartitions' (d,d) d - --------------------------------------------------------------------------------- - --- | This uses Euler's algorithm to compute p(n) --- --- See eg.: --- NEIL CALKIN, JIMENA DAVIS, KEVIN JAMES, ELIZABETH PEREZ, AND CHARLES SWANNACK --- COMPUTING THE INTEGER PARTITION FUNCTION --- --- -partitionCountTable :: TableOfIntegers -partitionCountTable = table where - - table = makeTableOfIntegers fun - - fun lkp !n - | n > 1 = foldl' (+) 0 - [ (if even k then negate else id) - ( lkp (n - div (k*(3*k+1)) 2) - + lkp (n - div (k*(3*k-1)) 2) - ) - | k <- [1..limit n] - ] - | n < 0 = 0 - | n == 0 = 1 - | n == 1 = 1 - - limit :: Int -> Int - limit !n = fromInteger $ ceilingSquareRoot (1 + div (nn+nn+1) 3) where - nn = fromIntegral n :: Integer - --- | An infinite list containing all @p(n)@, starting from @p(0)@. -partitionCountList :: [Integer] -partitionCountList = map countPartitions [0..] - --------------------------------------------------------------------------------- - --- | Infinite list of number of partitions of @0,1,2,...@ --- --- This uses the infinite product formula the generating function of partitions, --- recursively expanding it; it is reasonably fast for small numbers. --- --- > partitionCountListInfiniteProduct == map countPartitions [0..] --- -partitionCountListInfiniteProduct :: [Integer] -partitionCountListInfiniteProduct = final where - - final = go 1 (1:repeat 0) - - go !k (x:xs) = x : go (k+1) ys where - ys = zipWith (+) xs (take k final ++ ys) - -- explanation: - -- xs == drop k $ f (k-1) - -- ys == drop k $ f (k ) - -{- - -Full explanation of 'partitionCountList': -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -let f k = productPSeries $ map (:[]) [1..k] - -f 0 = [1,0,0,0,0,0,0,0...] -f 1 = [1,1,1,1,1,1,1,1...] -f 2 = [1,1,2,2,3,3,4,4...] -f 3 = [1,1,2,3,4,5,7,8...] - -observe: - -* take (k+1) (f k) == take (k+1) partitionCountList -* f (k+1) == zipWith (+) (f k) (replicate (k+1) 0 ++ f (k+1)) - -now apply (drop (k+1)) to the second one : - -* drop (k+1) (f (k+1)) == zipWith (+) (drop (k+1) $ f k) (f (k+1)) -* f (k+1) = take (k+1) final ++ drop (k+1) (f (k+1)) - --} - --------------------------------------------------------------------------------- - --- | Naive infinite list of number of partitions of @0,1,2,...@ --- --- > partitionCountListNaive == map countPartitionsNaive [0..] --- --- This is very slow. --- -partitionCountListNaive :: [Integer] -partitionCountListNaive = map countPartitionsNaive [0..] - --------------------------------------------------------------------------------- --- * Counting all partitions - -countAllPartitions :: Int -> Integer -countAllPartitions d = sum' [ countPartitions i | i <- [0..d] ] - --- | Count all partitions fitting into a rectangle. --- # = \\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 - --------------------------------------------------------------------------------- --- * Counting fitting into a rectangle - --- | Number of of d, fitting into a given rectangle. Naive recursive algorithm. -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 with given number of parts - --- | Count partitions of @n@ into @k@ parts. --- --- Naive recursive algorithm. --- -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))] ] - --------------------------------------------------------------------------------- --- Partitions with only odd\/distinct parts - -{- --- | Partitions of @n@ with only odd parts -partitionsWithOddParts :: Int -> [Partition] -partitionsWithOddParts d = map Partition (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] --} - -{- --- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) --- -partitionsWithDistinctParts :: Int -> [Partition] -partitionsWithDistinctParts d = map Partition (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] --} - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Integer/IntList.hs b/Math/Combinat/Partitions/Integer/IntList.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Integer/IntList.hs +++ /dev/null @@ -1,398 +0,0 @@ - --- | Partition functions working on lists of integers. --- --- It's not recommended to use this module directly. - -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Partitions.Integer.IntList where - --------------------------------------------------------------------------------- - -import Data.List -import Control.Monad ( liftM , replicateM ) - -import Math.Combinat.Numbers ( factorial , binomial , multinomial ) -import Math.Combinat.Helper - -import Data.Array -import System.Random - -import Math.Combinat.Partitions.Integer.Count ( countPartitions ) - --------------------------------------------------------------------------------- --- * Type and basic stuff - --- | Sorts the input, and cuts the nonpositive elements. -_mkPartition :: [Int] -> [Int] -_mkPartition xs = sortBy (reverseCompare) $ filter (>0) xs - --- | This returns @True@ if the input is non-increasing sequence of --- /positive/ integers (possibly empty); @False@ otherwise. --- -_isPartition :: [Int] -> Bool -_isPartition [] = True -_isPartition [x] = x > 0 -_isPartition (x:xs@(y:_)) = (x >= y) && _isPartition xs - - -_dualPartition :: [Int] -> [Int] -_dualPartition [] = [] -_dualPartition xs = go 0 (_diffSequence xs) [] where - go !i (d:ds) acc = go (i+1) ds (d:acc) - go n [] acc = finish n acc - finish !j (k:ks) = replicate k j ++ finish (j-1) ks - finish _ [] = [] - --------------------------------------------------------------------------------- - -{- --- more variations: - -_dualPartition_b :: [Int] -> [Int] -_dualPartition_b [] = [] -_dualPartition_b xs = go 1 (diffSequence xs) [] where - go !i (d:ds) acc = go (i+1) ds ((d,i):acc) - go _ [] acc = concatMap (\(d,i) -> replicate d i) acc - -_dualPartition_c :: [Int] -> [Int] -_dualPartition_c [] = [] -_dualPartition_c xs = reverse $ concat $ zipWith f [1..] (diffSequence xs) where - f _ 0 = [] - f k d = replicate d k --} - --- | A simpler, but bit slower (about twice?) implementation of dual partition -_dualPartitionNaive :: [Int] -> [Int] -_dualPartitionNaive [] = [] -_dualPartitionNaive xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ] - --- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences --- @[a1-a2,a2-a3,...,an-0]@ -_diffSequence :: [Int] -> [Int] -_diffSequence = go where - go (x:ys@(y:_)) = (x-y) : go ys - go [x] = [x] - go [] = [] - --- | Example: --- --- > _elements [5,4,1] == --- > [ (1,1), (1,2), (1,3), (1,4), (1,5) --- > , (2,1), (2,2), (2,3), (2,4) --- > , (3,1) --- > ] --- - -_elements :: [Int] -> [(Int,Int)] -_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] - ---------------------------------------------------------------------------------- --- * Exponential form - --- | We convert a partition to exponential form. --- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example: --- --- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)] --- -_toExponentialForm :: [Int] -> [(Int,Int)] -_toExponentialForm = reverse . map (\xs -> (head xs,length xs)) . group - -_fromExponentialForm :: [(Int,Int)] -> [Int] -_fromExponentialForm = sortBy reverseCompare . go where - go ((j,e):rest) = replicate e j ++ go rest - go [] = [] - ---------------------------------------------------------------------------------- --- * Generating partitions - --- | Partitions of @d@, as lists -_partitions :: Int -> [[Int]] -_partitions d = go d d where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1..min n h], as <- go a (n-a) ] - --- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@) -_allPartitions :: Int -> [[Int]] -_allPartitions d = concat [ _partitions i | i <- [0..d] ] - --- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@), --- grouped by weight -_allPartitionsGrouped :: Int -> [[[Int]]] -_allPartitionsGrouped d = [ _partitions i | i <- [0..d] ] - ---------------------------------------------------------------------------------- - --- | 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) ] - ---------------------------------------------------------------------------------- --- * Random partitions - --- | Uniformly random partition of the given weight. --- --- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely), --- and the first time it is executed may be slower (as it needs to build the table 'partitionCountList' first) --- --- Algorithm of Nijenhuis and Wilf (1975); see --- --- * Knuth Vol 4A, pre-fascicle 3B, exercise 47; --- --- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10 --- -_randomPartition :: RandomGen g => Int -> g -> ([Int], g) -_randomPartition n g = (p, g') where - ([p], g') = _randomPartitions 1 n g - --- | Generates several uniformly random partitions of @n@ at the same time. --- Should be a little bit faster then generating them individually. --- -_randomPartitions - :: forall g. RandomGen g - => Int -- ^ number of partitions to generate - -> Int -- ^ the weight of the partitions - -> g -> ([[Int]], g) -_randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where - - cnt = countPartitions - - finish :: [(Int,Int)] -> [Int] - finish = _mkPartition . concatMap f where f (j,d) = replicate j d - - fi :: Int -> Integer - fi = fromIntegral - - find_jd :: Int -> Integer -> (Int,Int) - find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where - go :: Integer -> [(Int,Int)] -> (Int,Int) - go !s [] = (1,1) -- ?? - go !s [jd] = jd -- ?? - go !s (jd@(j,d):rest) = - if s' > capm - then jd - else go s' rest - where - s' = s + fi d * cnt (m - j*d) - - worker :: Int -> [(Int,Int)] -> Rand g [Int] - worker 0 acc = return $ finish acc - worker !m acc = do - capm <- randChoose (0, (fi m) * cnt m - 1) - let jd@(!j,!d) = find_jd m capm - worker (m - j*d) (jd:acc) - - ---------------------------------------------------------------------------------- --- * 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 :: [Int] -> [Int] -> Bool -_dominates qs ps - = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) - where - sums = scanl (+) 0 - --- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@ --- (that is, all partial sums are less or equal): --- --- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ] --- -_dominatedPartitions :: [Int] -> [[Int]] -_dominatedPartitions [] = [[]] -_dominatedPartitions lambda = go (head lambda) w dsums 0 where - - n = length lambda - w = sum lambda - dsums = scanl1 (+) (lambda ++ repeat 0) - - go _ 0 _ _ = [[]] - go !h !w (!d:ds) !e - | w > 0 = [ (a:as) | a <- [1..min h (d-e)] , as <- go a (w-a) ds (e+a) ] - | w == 0 = [[]] - | w < 0 = error "_dominatedPartitions: fatal error; shouldn't happen" - --- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@ --- (that is, all partial sums are greater or equal): --- --- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ] --- -_dominatingPartitions :: [Int] -> [[Int]] -_dominatingPartitions [] = [[]] -_dominatingPartitions mu = go w w dsums 0 where - - n = length mu - w = sum mu - dsums = scanl1 (+) (mu ++ repeat 0) - - go _ 0 _ _ = [[]] - go !h !w (!d:ds) !e - | w > 0 = [ (a:as) | a <- [max 0 (d-e)..min h w] , as <- go a (w-a) ds (e+a) ] - | w == 0 = [[]] - | w < 0 = error "_dominatingPartitions: fatal error; shouldn't happen" - --------------------------------------------------------------------------------- --- * 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 - -> [[Int]] -_partitionsWithKParts k n = 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) ] - --------------------------------------------------------------------------------- --- * Partitions with only odd\/distinct parts - --- | Partitions of @n@ with only odd parts -_partitionsWithOddParts :: Int -> [[Int]] -_partitionsWithOddParts d = (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] - -{- --- | Partitions of @n@ with only even parts --- --- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@ --- -_partitionsWithEvenParts :: Int -> [[Int]] -_partitionsWithEvenParts d = (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ] --} - --- | Partitions of @n@ with distinct parts. --- --- Note: --- --- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) --- -_partitionsWithDistinctParts :: Int -> [[Int]] -_partitionsWithDistinctParts d = (go d d) where - go _ 0 = [[]] - go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] - --------------------------------------------------------------------------------- --- * Sub- and super-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 :: [Int] -> [Int] -> Bool -_isSubPartitionOf ps qs = and $ zipWith (<=) ps (qs ++ repeat 0) - --- | This is provided for convenience\/completeness only, as: --- --- > isSuperPartitionOf q p == isSubPartitionOf p q --- -_isSuperPartitionOf :: [Int] -> [Int] -> Bool -_isSuperPartitionOf qs ps = 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 -> [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 :: [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 ] - ----------------------------------------- - --- | Super-partitions of a given partition with the given weight: --- --- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ] --- -_superPartitions :: Int -> [Int] -> [[Int]] -_superPartitions dd small - | dd < w0 = [] - | null small = _partitions dd - | otherwise = go dd w1 dd (small ++ repeat 0) - where - w0 = sum' small - w1 = w0 - head small - -- d = remaining weight of the outer partition we are constructing - -- w = remaining weight of the inner partition (we need to reserve at least this amount) - -- h = max height (decreasing) - go !d !w !h (!a:as@(b:_)) - | d < 0 = [] - | d == 0 = if a == 0 then [[]] else [] - | otherwise = [ this:rest | this <- [max 1 a .. min h (d-w)] , rest <- go (d-this) (w-b) this as ] - --------------------------------------------------------------------------------- --- * The Pieri rule - --- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1). --- --- See for example --- --- | We assume here that @lambda@ is a partition (non-increasing sequence of /positive/ integers)! -_pieriRule :: [Int] -> Int -> [[Int]] -_pieriRule lambda n - | n == 0 = [lambda] - | n < 0 = [] - | otherwise = go n diffs dsums (lambda++[0]) - where - diffs = n : _diffSequence lambda -- maximum we can add to a given row - dsums = reverse $ scanl1 (+) (reverse diffs) -- partial sums of remaining total we can add - go !k (d:ds) (p:ps@(q:_)) (l:ls) - | k > p = [] - | otherwise = [ h:tl | a <- [ max 0 (k-q) .. min d k ] , let h = l+a , tl <- go (k-a) ds ps ls ] - go !k [d] _ [l] = if k <= d - then if l+k>0 then [[l+k]] else [[]] - else [] - go !k [] _ _ = if k==0 then [[]] else [] - --- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1) -_dualPieriRule :: [Int] -> Int -> [[Int]] -_dualPieriRule lam n = map _dualPartition $ _pieriRule (_dualPartition lam) n - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Integer/Naive.hs b/Math/Combinat/Partitions/Integer/Naive.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Integer/Naive.hs +++ /dev/null @@ -1,214 +0,0 @@ - --- | Naive implementation of partitions of integers, encoded as list of @Int@-s. --- --- Integer partitions are nonincreasing sequences of positive integers. --- --- This is an internal module, you are not supposed to import it directly. --- - - -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, PatternSynonyms, ViewPatterns #-} -module Math.Combinat.Partitions.Integer.Naive where - --------------------------------------------------------------------------------- - -import Data.List -import Control.Monad ( liftM , replicateM ) - --- import Data.Map (Map) --- import qualified Data.Map as Map - -import Math.Combinat.Classes -import Math.Combinat.ASCII as ASCII -import Math.Combinat.Numbers (factorial,binomial,multinomial) -import Math.Combinat.Helper - -import Data.Array -import System.Random - -import Math.Combinat.Partitions.Integer.IntList -import Math.Combinat.Partitions.Integer.Count ( countPartitions ) - --------------------------------------------------------------------------------- --- * 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) - -instance HasNumberOfParts Partition where - numberOfParts (Partition p) = length p - ---------------------------------------------------------------------------------- - -toList :: Partition -> [Int] -toList (Partition xs) = xs - -fromList :: [Int] -> Partition -fromList = mkPartition where - mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs - -fromListUnsafe :: [Int] -> Partition -fromListUnsafe = Partition - ---------------------------------------------------------------------------------- - -isEmptyPartition :: Partition -> Bool -isEmptyPartition (Partition p) = null p - -emptyPartition :: Partition -emptyPartition = Partition [] - -instance CanBeEmpty Partition where - empty = emptyPartition - isEmpty = isEmptyPartition - --- | The first element of the sequence. -partitionHeight :: Partition -> Int -partitionHeight (Partition part) = case part of - (p:_) -> p - [] -> 0 - --- | The length of the sequence (that is, the number of parts). -partitionWidth :: Partition -> Int -partitionWidth (Partition part) = length part - -instance HasHeight Partition where - height = partitionHeight - -instance HasWidth Partition where - width = partitionWidth - -heightWidth :: Partition -> (Int,Int) -heightWidth part = (height part, width part) - --- | The weight of the partition --- (that is, the sum of the corresponding sequence). -partitionWeight :: Partition -> Int -partitionWeight (Partition part) = sum' part - -instance HasWeight Partition where - weight = partitionWeight - --- | The dual (or conjugate) partition. -dualPartition :: Partition -> Partition -dualPartition (Partition part) = Partition (_dualPartition part) - -instance HasDuality Partition where - dual = dualPartition - --- | 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 - --------------------------------------------------------------------------------- --- * Pattern synonyms - --- | Pattern sysnonyms allows us to use existing code with minimal modifications -pattern Nil :: Partition -pattern Nil <- (isEmpty -> True) where - Nil = empty - -pattern Cons :: Int -> Partition -> Partition -pattern Cons x xs <- (unconsPartition -> Just (x,xs)) where - Cons x (Partition xs) = Partition (x:xs) - --- | Simulated newtype constructor -pattern Partition_ :: [Int] -> Partition -pattern Partition_ xs = Partition xs - -pattern Head :: Int -> Partition -pattern Head h <- (head . toDescList -> h) - -pattern Tail :: Partition -> Partition -pattern Tail xs <- (Partition . tail . toDescList -> xs) - -pattern Length :: Int -> Partition -pattern Length n <- (partitionWidth -> n) - ---------------------------------------------------------------------------------- --- * Exponential form - --- | We convert a partition to exponential form. --- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example: --- --- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)] --- -toExponentialForm :: Partition -> [(Int,Int)] -toExponentialForm = _toExponentialForm . toDescList - -fromExponentialForm :: [(Int,Int)] -> Partition -fromExponentialForm = Partition . _fromExponentialForm where - --------------------------------------------------------------------------------- --- * List-like operations - --- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences --- @[a1-a2,a2-a3,...,an-0]@ -diffSequence :: Partition -> [Int] -diffSequence = go . toDescList where - go (x:ys@(y:_)) = (x-y) : go ys - go [x] = [x] - go [] = [] - -unconsPartition :: Partition -> Maybe (Int,Partition) -unconsPartition (Partition xs) = case xs of - (y:ys) -> Just (y, Partition ys) - [] -> Nothing - -toDescList :: Partition -> [Int] -toDescList (Partition xs) = xs - ---------------------------------------------------------------------------------- --- * 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 - --------------------------------------------------------------------------------- --- * Containment partial ordering - --- | 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) - --- | This is provided for convenience\/completeness only, as: --- --- > isSuperPartitionOf q p == isSubPartitionOf p q --- -isSuperPartitionOf :: Partition -> Partition -> Bool -isSuperPartitionOf (Partition qs) (Partition ps) = and $ zipWith (<=) ps (qs ++ repeat 0) - --------------------------------------------------------------------------------- --- * The Pieri rule - --- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1). --- --- See for example --- -pieriRule :: Partition -> Int -> [Partition] -pieriRule (Partition lambda) n = map Partition (_pieriRule lambda n) where - --- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1) -dualPieriRule :: Partition -> Int -> [Partition] -dualPieriRule lam n = map dualPartition $ pieriRule (dualPartition lam) n - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Partitions/Multiset.hs b/Math/Combinat/Partitions/Multiset.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Multiset.hs +++ /dev/null @@ -1,24 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/Math/Combinat/Partitions/NonCrossing.hs +++ /dev/null @@ -1,205 +0,0 @@ - --- | Non-crossing partitions. --- --- 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 - --------------------------------------------------------------------------------- - -import Control.Applicative - -import Data.List -import Data.Ord - -import System.Random - -import Math.Combinat.Numbers -import Math.Combinat.LatticePaths -import Math.Combinat.Helper -import Math.Combinat.Partitions.Set -import Math.Combinat.Classes - --------------------------------------------------------------------------------- --- * The type of non-crossing partitions - --- | A non-crossing partition of the set @[1..n]@ in standard form: --- entries decreasing in each block and blocks listed in increasing order of their first entries. -newtype NonCrossing = NonCrossing [[Int]] deriving (Eq,Ord,Show,Read) - --- | Checks whether a set partition is noncrossing. --- --- Implementation method: we convert to a Dyck path and then back again, and finally compare. --- Probably not very efficient, but should be better than a naive check for crosses...) --- -_isNonCrossing :: [[Int]] -> Bool -_isNonCrossing zzs0 = _isNonCrossingUnsafe (_standardizeNonCrossing zzs0) - --- | Warning: This function assumes the standard ordering! -_isNonCrossingUnsafe :: [[Int]] -> Bool -_isNonCrossingUnsafe zzs = - case _nonCrossingPartitionToDyckPathMaybe zzs of - Nothing -> False - Just dyck -> case dyckPathToNonCrossingPartitionMaybe dyck of - Nothing -> False - Just (NonCrossing yys) -> yys == zzs - --- | Convert to standard form: entries decreasing in each block --- and blocks listed in increasing order of their first entries. -_standardizeNonCrossing :: [[Int]] -> [[Int]] -_standardizeNonCrossing = sortBy (comparing myhead) . map reverseSort where - myhead xs = case xs of - (x:xs) -> x - [] -> error "_standardizeNonCrossing: empty subset" - -fromNonCrossing :: NonCrossing -> [[Int]] -fromNonCrossing (NonCrossing xs) = xs - -toNonCrossingUnsafe :: [[Int]] -> NonCrossing -toNonCrossingUnsafe = NonCrossing - --- | Throws an error if the input is not a non-crossing partition -toNonCrossing :: [[Int]] -> NonCrossing -toNonCrossing xxs = case toNonCrossingMaybe xxs of - Just nc -> nc - Nothing -> error "toNonCrossing: not a non-crossing partition" - -toNonCrossingMaybe :: [[Int]] -> Maybe NonCrossing -toNonCrossingMaybe xxs0 = - if _isNonCrossingUnsafe xxs - then Just $ NonCrossing xxs - else Nothing - where - xxs = _standardizeNonCrossing xxs0 - --- | If a set partition is actually non-crossing, then we can convert it -setPartitionToNonCrossing :: SetPartition -> Maybe NonCrossing -setPartitionToNonCrossing (SetPartition zzs0) = - if _isNonCrossingUnsafe zzs - then Just $ NonCrossing zzs - else Nothing - where - zzs = _standardizeNonCrossing zzs0 - -instance HasNumberOfParts NonCrossing where - numberOfParts (NonCrossing p) = length p - --------------------------------------------------------------------------------- --- * Bijection to Dyck paths - --- | Bijection between Dyck paths and noncrossing partitions --- --- Based on: David Callan: /Sets, Lists and Noncrossing Partitions/ --- --- Fails if the input is not a Dyck path. -dyckPathToNonCrossingPartition :: LatticePath -> NonCrossing -dyckPathToNonCrossingPartition = NonCrossing . go 0 [] [] [] where - go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]] - go !cnt stack small big path = - case path of - (x:xs) -> case x of - UpStep -> let cnt' = cnt + 1 in case xs of - (y:ys) -> case y of - UpStep -> go cnt' (cnt':stack) small big xs - DownStep -> go cnt' (cnt':stack) [] (reverse small : big) xs - [] -> error "dyckPathToNonCrossingPartition: last step is an UpStep (thus input was not a Dyck path)" - DownStep -> case stack of - (k:ks) -> go cnt ks (k:small) big xs - [] -> error "dyckPathToNonCrossingPartition: empty stack, shouldn't happen (thus input was not a Dyck path)" - [] -> tail $ reverse (reverse small : big) - --- | Safe version of 'dyckPathToNonCrossingPartition' -dyckPathToNonCrossingPartitionMaybe :: LatticePath -> Maybe NonCrossing -dyckPathToNonCrossingPartitionMaybe = fmap NonCrossing . go 0 [] [] [] where - go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]] - go !cnt stack small big path = - case path of - (x:xs) -> case x of - UpStep -> let cnt' = cnt + 1 in case xs of - (y:ys) -> case y of - UpStep -> go cnt' (cnt':stack) small big xs - DownStep -> go cnt' (cnt':stack) [] (reverse small : big) xs - [] -> Nothing - DownStep -> case stack of - (k:ks) -> go cnt ks (k:small) big xs - [] -> Nothing - [] -> Just $ tail $ reverse (reverse small : big) - --- | The inverse bijection (should never fail proper 'NonCrossing'-s) -nonCrossingPartitionToDyckPath :: NonCrossing -> LatticePath -nonCrossingPartitionToDyckPath (NonCrossing zzs) = go 0 zzs where - go !k (ys@(y:_):yys) = replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ go y yys - go !k [] = [] - go _ _ = error "nonCrossingPartitionToDyckPath: shouldnt't happen" - --- | Safe version 'nonCrossingPartitionToDyckPath' -_nonCrossingPartitionToDyckPathMaybe :: [[Int]] -> Maybe LatticePath -_nonCrossingPartitionToDyckPathMaybe = go 0 where - go !k (ys@(y:_):yys) = fmap (\zs -> replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ zs) (go y yys) - go !k [] = Just [] - go _ _ = Nothing - --------------------------------------------------------------------------------- - -{- --- this should be mapped to NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] -testpath = [u,u,u,d,u,u,d,d,d,u,u,d,d,d,u,u,d,d] where - u = UpStep - d = DownStep - -testnc = NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] --} - --------------------------------------------------------------------------------- --- * Generating non-crossing partitions - --- | Lists all non-crossing partitions of @[1..n]@ --- --- Equivalent to (but orders of magnitude faster than) filtering out the non-crossing ones: --- --- > (sort $ catMaybes $ map setPartitionToNonCrossing $ setPartitions n) == sort (nonCrossingPartitions n) --- -nonCrossingPartitions :: Int -> [NonCrossing] -nonCrossingPartitions = map dyckPathToNonCrossingPartition . dyckPaths - --- | Lists all non-crossing partitions of @[1..n]@ into @k@ parts. --- --- > sort (nonCrossingPartitionsWithKParts k n) == sort [ p | p <- nonCrossingPartitions n , numberOfParts p == k ] --- -nonCrossingPartitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = size of the set - -> [NonCrossing] -nonCrossingPartitionsWithKParts k n = map dyckPathToNonCrossingPartition $ peakingDyckPaths k n - --- | Non-crossing partitions are counted by the Catalan numbers -countNonCrossingPartitions :: Int -> Integer -countNonCrossingPartitions = countDyckPaths - --- | Non-crossing partitions with @k@ parts are counted by the Naranaya numbers -countNonCrossingPartitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = size of the set - -> Integer -countNonCrossingPartitionsWithKParts = countPeakingDyckPaths - --------------------------------------------------------------------------------- - --- | Uniformly random non-crossing partition -randomNonCrossingPartition :: RandomGen g => Int -> g -> (NonCrossing,g) -randomNonCrossingPartition n g0 = (dyckPathToNonCrossingPartition dyck, g1) where - (dyck,g1) = randomDyckPath n g0 - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Plane.hs b/Math/Combinat/Partitions/Plane.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Plane.hs +++ /dev/null @@ -1,124 +0,0 @@ - --- | 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.Classes -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) - -instance CanBeEmpty PlanePart where - isEmpty = null . fromPlanePart - empty = PlanePart [] - --- | 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.tableauShape . 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) - -instance HasWeight PlanePart where - weight = planePartWeight - --------------------------------------------------------------------------------- --- * 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/Set.hs b/Math/Combinat/Partitions/Set.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Set.hs +++ /dev/null @@ -1,109 +0,0 @@ - --- | Set partitions. --- --- See eg. --- - -{-# LANGUAGE BangPatterns #-} -module Math.Combinat.Partitions.Set where - --------------------------------------------------------------------------------- - -import Data.List -import Data.Ord - -import System.Random - -import Math.Combinat.Sets -import Math.Combinat.Numbers -import Math.Combinat.Helper -import Math.Combinat.Classes -import Math.Combinat.Partitions.Integer - --------------------------------------------------------------------------------- --- * The type of set partitions - --- | A partition of the set @[1..n]@ (in standard order) -newtype SetPartition = SetPartition [[Int]] deriving (Eq,Ord,Show,Read) - -_standardizeSetPartition :: [[Int]] -> [[Int]] -_standardizeSetPartition = sortBy (comparing myhead) . map sort where - myhead xs = case xs of - (x:xs) -> x - [] -> error "_standardizeSetPartition: empty subset" - -fromSetPartition :: SetPartition -> [[Int]] -fromSetPartition (SetPartition zzs) = zzs - -toSetPartitionUnsafe :: [[Int]] -> SetPartition -toSetPartitionUnsafe = SetPartition - -toSetPartition :: [[Int]] -> SetPartition -toSetPartition zzs = if _isSetPartition zzs - then SetPartition (_standardizeSetPartition zzs) - else error "toSetPartition: not a set partition" - -_isSetPartition :: [[Int]] -> Bool -_isSetPartition zzs = sort (concat zzs) == [1..n] where - n = sum' (map length zzs) - -instance HasNumberOfParts SetPartition where - numberOfParts (SetPartition p) = length p - --------------------------------------------------------------------------------- --- * Forgetting the set structure - --- | The \"shape\" of a set partition is the partition we get when we forget the --- set structure, keeping only the cardinalities. --- -setPartitionShape :: SetPartition -> Partition -setPartitionShape (SetPartition pps) = mkPartition (map length pps) - --------------------------------------------------------------------------------- --- * Generating set partitions - --- | Synonym for 'setPartitionsNaive' -setPartitions :: Int -> [SetPartition] -setPartitions = setPartitionsNaive - --- | Synonym for 'setPartitionsWithKPartsNaive' --- --- > sort (setPartitionsWithKParts k n) == sort [ p | p <- setPartitions n , numberOfParts p == k ] --- -setPartitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = size of the set - -> [SetPartition] -setPartitionsWithKParts = setPartitionsWithKPartsNaive - --- | List all set partitions of @[1..n]@, naive algorithm -setPartitionsNaive :: Int -> [SetPartition] -setPartitionsNaive n = map (SetPartition . _standardizeSetPartition) $ go [1..n] where - go :: [Int] -> [[[Int]]] - go [] = [[]] - go (z:zs) = [ s : rest | k <- [1..n] , s0 <- choose (k-1) zs , let s = z:s0 , rest <- go (zs \\ s) ] - --- | Set partitions of the set @[1..n]@ into @k@ parts -setPartitionsWithKPartsNaive - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = size of the set - -> [SetPartition] -setPartitionsWithKPartsNaive k n = map (SetPartition . _standardizeSetPartition) $ go k [1..n] where - go :: Int -> [Int] -> [[[Int]]] - go !k [] = if k==0 then [[]] else [] - go 1 zs = [[zs]] - go !k (z:zs) = [ s : rest | l <- [1..n] , s0 <- choose (l-1) zs , let s = z:s0 , rest <- go (k-1) (zs \\ s) ] - - --- | Set partitions are counted by the Bell numbers -countSetPartitions :: Int -> Integer -countSetPartitions = bellNumber - --- | Set partitions of size @k@ are counted by the Stirling numbers of second kind -countSetPartitionsWithKParts - :: Int -- ^ @k@ = number of parts - -> Int -- ^ @n@ = size of the set - -> Integer -countSetPartitionsWithKParts k n = stirling2nd n k - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Skew.hs b/Math/Combinat/Partitions/Skew.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Skew.hs +++ /dev/null @@ -1,153 +0,0 @@ - --- | Skew partitions. --- --- Skew partitions are the difference of two integer partitions, denoted by @lambda/mu@. --- --- For example --- --- > mkSkewPartition (Partition [9,7,3,2,2,1] , Partition [5,3,2,1]) --- --- creates the skew partition @(9,7,3,2,2,1) / (5,3,2,1)@, which looks like --- --- <> --- - -{-# LANGUAGE CPP, BangPatterns #-} -module Math.Combinat.Partitions.Skew where - --------------------------------------------------------------------------------- - -import Data.List - -import Math.Combinat.Classes -import Math.Combinat.Partitions.Integer -import Math.Combinat.ASCII - --------------------------------------------------------------------------------- --- * Basics - --- | A skew partition @lambda/mu@ is internally represented by the list @[ (mu_i , lambda_i-mu_i) | i<-[1..n] ]@ -newtype SkewPartition = SkewPartition [(Int,Int)] deriving (Eq,Ord,Show) - --- | @mkSkewPartition (lambda,mu)@ creates the skew partition @lambda/mu@. --- Throws an error if @mu@ is not a sub-partition of @lambda@. -mkSkewPartition :: (Partition,Partition) -> SkewPartition -mkSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam - then SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0) - else error "mkSkewPartition: mu should be a subpartition of lambda!" - --- | Returns 'Nothing' if @mu@ is not a sub-partition of @lambda@. -safeSkewPartition :: (Partition,Partition) -> Maybe SkewPartition -safeSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam - then Just $ SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0) - else Nothing - --- | The weight of a skew partition is the weight of the outer partition minus the --- the weight of the inner partition (that is, the number of boxes present). -skewPartitionWeight :: SkewPartition -> Int -skewPartitionWeight (SkewPartition abs) = foldl' (+) 0 (map snd abs) - -instance HasWeight SkewPartition where - weight = skewPartitionWeight - --- | This function \"cuts off\" the \"uninteresting parts\" of a skew partition -normalizeSkewPartition :: SkewPartition -> SkewPartition -normalizeSkewPartition (SkewPartition abs) = SkewPartition abs' where - (as,bs) = unzip abs - a0 = minimum as - k = length (takeWhile (==0) bs) - abs' = zip [ a-a0 | a <- drop k as ] (drop k bs) - --- | Returns the outer and inner partition of a skew partition, respectively: --- --- > mkSkewPartition . fromSkewPartition == id --- -fromSkewPartition :: SkewPartition -> (Partition,Partition) -fromSkewPartition (SkewPartition list) = (toPartition (zipWith (+) as bs) , toPartition (filter (>0) as)) where - (as,bs) = unzip list - --- | The @lambda@ part of @lambda/mu@ -outerPartition :: SkewPartition -> Partition -outerPartition = fst . fromSkewPartition - --- | The @mu@ part of @lambda/mu@ -innerPartition :: SkewPartition -> Partition -innerPartition = snd . fromSkewPartition - --- | The dual skew partition (that is, the mirror image to the main diagonal) -dualSkewPartition :: SkewPartition -> SkewPartition -dualSkewPartition = mkSkewPartition . f . fromSkewPartition where - f (lam,mu) = (dualPartition lam, dualPartition mu) - -instance HasDuality SkewPartition where - dual = dualSkewPartition - --- | See "partitionElements" -skewPartitionElements :: SkewPartition -> [(Int, Int)] -skewPartitionElements (SkewPartition abs) = concat - [ [ (i,j) | j <- [a+1 .. a+b] ] - | (i,(a,b)) <- zip [1..] abs - ] - --------------------------------------------------------------------------------- --- * Listing skew partitions - --- | Lists all skew partitions with the given outer shape and given (skew) weight -skewPartitionsWithOuterShape :: Partition -> Int -> [SkewPartition] -skewPartitionsWithOuterShape outer skewWeight - | innerWeight < 0 || innerWeight > outerWeight = [] - | otherwise = [ mkSkewPartition (outer,inner) | inner <- subPartitions innerWeight outer ] - where - outerWeight = weight outer - innerWeight = outerWeight - skewWeight - --- | Lists all skew partitions with the given outer shape and any (skew) weight -allSkewPartitionsWithOuterShape :: Partition -> [SkewPartition] -allSkewPartitionsWithOuterShape outer - = concat [ skewPartitionsWithOuterShape outer w | w<-[0..outerWeight] ] - where - outerWeight = weight outer - --- | Lists all skew partitions with the given inner shape and given (skew) weight -skewPartitionsWithInnerShape :: Partition -> Int -> [SkewPartition] -skewPartitionsWithInnerShape inner skewWeight - | innerWeight > outerWeight = [] - | otherwise = [ mkSkewPartition (outer,inner) | outer <- superPartitions outerWeight inner ] - where - outerWeight = innerWeight + skewWeight - innerWeight = weight inner - --------------------------------------------------------------------------------- --- connected components - -{- -connectedComponents :: SkewPartition -> [((Int,Int),SkewPartition)] -connectedComponents = error "connectedComponents: not implemented yet" - -isConnectedSkewPartition :: SkewPartition -> Bool -isConnectedSkewPartition skewp = length (connectedComponents skewp) == 1 --} - --------------------------------------------------------------------------------- --- * ASCII - -asciiSkewFerrersDiagram :: SkewPartition -> ASCII -asciiSkewFerrersDiagram = asciiSkewFerrersDiagram' ('@','.') EnglishNotation - -asciiSkewFerrersDiagram' - :: (Char,Char) - -> PartitionConvention -- Orientation - -> SkewPartition - -> ASCII -asciiSkewFerrersDiagram' (outer,inner) orient (SkewPartition abs) = asciiFromLines stuff where - stuff = case orient of - EnglishNotation -> ls - EnglishNotationCCW -> reverse (transpose ls) - FrenchNotation -> reverse ls - ls = [ replicate a inner ++ replicate b outer | (a,b) <- abs ] - -instance DrawASCII SkewPartition where - ascii = asciiSkewFerrersDiagram - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Partitions/Skew/Ribbon.hs b/Math/Combinat/Partitions/Skew/Ribbon.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Skew/Ribbon.hs +++ /dev/null @@ -1,364 +0,0 @@ - --- | Ribbons (also called border strips, skew hooks, skew rim hooks, etc...). --- --- Ribbons are skew partitions that are 1) connected, 2) do not contain --- 2x2 blocks. Intuitively, they are 1-box wide continuous strips on --- the boundary. --- --- An alternative definition that they are skew partitions whose projection --- to the diagonal line is a continuous segment of width 1. - -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Partitions.Skew.Ribbon where - --------------------------------------------------------------------------------- - -import Data.Array -import Data.List -import Data.Maybe - -import qualified Data.Map as Map - -import Math.Combinat.Sets -import Math.Combinat.Partitions.Integer -import Math.Combinat.Partitions.Integer.IntList ( _diffSequence ) -import Math.Combinat.Partitions.Skew -import Math.Combinat.Tableaux -import Math.Combinat.Tableaux.LittlewoodRichardson -import Math.Combinat.Tableaux.GelfandTsetlin -import Math.Combinat.Helper - --------------------------------------------------------------------------------- --- * Corners (TODO: move to Partitions - but we also want to refactor that) - --- | The coordinates of the outer corners -outerCorners :: Partition -> [(Int,Int)] -outerCorners = outerCornerBoxes - --- | The coordinates of the inner corners, including the two on the two coordinate --- axes. For the partition @[5,4,1]@ the result should be @[(0,5),(1,4),(2,1),(3,0)]@ -extendedInnerCorners:: Partition -> [(Int,Int)] -extendedInnerCorners (Partition_ ps) = (0, head ps') : catMaybes mbCorners where - ps' = ps ++ [0] - mbCorners = zipWith3 f [1..] (tail ps') (_diffSequence ps') - f !y !x !k = if k > 0 then Just (y,x) else Nothing - --- | Sequence of all the (extended) corners -extendedCornerSequence :: Partition -> [(Int,Int)] -extendedCornerSequence (Partition_ ps) = {- if null ps then [(0,0)] else -} interleave inner outer where - inner = (0, head ps') : [ (y,x) | (y,x,k) <- zip3 [1..] (tail ps') diff , k>0 ] - outer = [ (y,x) | (y,x,k) <- zip3 [1..] ps' diff , k>0 ] - diff = _diffSequence ps' - ps' = ps ++ [0] - --- | The inner corner /boxes/ of the partition. Coordinates are counted from 1 --- (cf.the 'elements' function), and the first coordinate is the row, the second --- the column (in English notation). --- --- For the partition @[5,4,1]@ the result should be @[(1,4),(2,1)]@ --- --- > innerCornerBoxes lambda == (tail $ init $ extendedInnerCorners lambda) --- -innerCornerBoxes :: Partition -> [(Int,Int)] -innerCornerBoxes (Partition_ ps) = - case ps of - [] -> [] - _ -> catMaybes mbCorners - where - mbCorners = zipWith3 f [1..] (tail ps) (_diffSequence ps) - f !y !x !k = if k > 0 then Just (y,x) else Nothing - --- | The outer corner /boxes/ of the partition. Coordinates are counted from 1 --- (cf.the 'elements' function), and the first coordinate is the row, the second --- the column (in English notation). --- --- For the partition @[5,4,1]@ the result should be @[(1,5),(2,4),(3,1)]@ -outerCornerBoxes :: Partition -> [(Int,Int)] -outerCornerBoxes (Partition_ ps) = catMaybes mbCorners where - mbCorners = zipWith3 f [1..] ps (_diffSequence ps) - f !y !x !k = if k > 0 then Just (y,x) else Nothing - --- | The outer and inner corner boxes interleaved, so together they form --- the turning points of the full border strip -cornerBoxSequence :: Partition -> [(Int,Int)] -cornerBoxSequence (Partition_ ps) = if null ps then [] else interleave outer inner where - inner = [ (y,x) | (y,x,k) <- zip3 [1..] tailps diff , k>0 ] - outer = [ (y,x) | (y,x,k) <- zip3 [1..] ps diff , k>0 ] - diff = _diffSequence ps - tailps = case ps of { [] -> [] ; _-> tail ps } - --------------------------------------------------------------------------------- - --- | Naive (and very slow) implementation of @innerCornerBoxes@, for testing purposes -innerCornerBoxesNaive :: Partition -> [(Int,Int)] -innerCornerBoxesNaive part = filter f boxes where - boxes = elements part - f (y,x) = elem (y+1,x ) boxes - && elem (y ,x+1) boxes - && not (elem (y+1,x+1) boxes) - --- | Naive (and very slow) implementation of @outerCornerBoxes@, for testing purposes -outerCornerBoxesNaive :: Partition -> [(Int,Int)] -outerCornerBoxesNaive part = filter f boxes where - boxes = elements part - f (y,x) = not (elem (y+1,x ) boxes) - && not (elem (y ,x+1) boxes) - && not (elem (y+1,x+1) boxes) - --------------------------------------------------------------------------------- --- * Ribbon - --- | A skew partition is a a ribbon (or border strip) if and only if projected --- to the diagonals the result is an interval. -isRibbon :: SkewPartition -> Bool -isRibbon skewp = go Nothing proj where - proj = Map.toList - $ Map.fromListWith (+) [ (x-y , 1) | (y,x) <- skewPartitionElements skewp ] - go Nothing [] = False - go (Just _) [] = True - go Nothing ((a,h):rest) = (h == 1) && go (Just a) rest - go (Just b) ((a,h):rest) = (h == 1) && (a == b+1) && go (Just a) rest - -{- --- | Naive (and slow) reference implementation of "isRibbon" -isRibbonNaive :: SkewPartition -> Bool -isRibbonNaive skewp = isConnectedSkewPartition skewp && no2x2 where - boxes = skewPartitionElements skewp - no2x2 = and - [ not ( elem (y+1,x ) boxes && - elem (y ,x+1) boxes && - elem (y+1,x+1) boxes ) -- no 2x2 blocks - | (y,x) <- boxes - ] --} - -toRibbon :: SkewPartition -> Maybe Ribbon -toRibbon skew = - if not (isRibbon skew) - then Nothing - else Just ribbon - where - ribbon = Ribbon - { rbShape = skew - , rbLength = skewPartitionWeight skew - , rbHeight = height - , rbWidth = width - } - elems = skewPartitionElements skew - height = (length $ group $ sort $ map fst elems) - 1 -- TODO: optimize these - width = (length $ group $ sort $ map snd elems) - 1 - --- | Border strips (or ribbons) are defined to be skew partitions which are --- connected and do not contain 2x2 blocks. --- --- The /length/ of a border strip is the number of boxes it contains, --- and its /height/ is defined to be one less than the number of rows --- (in English notation) it occupies. The /width/ is defined symmetrically to --- be one less than the number of columns it occupies. --- -data Ribbon = Ribbon - { rbShape :: SkewPartition - , rbLength :: Int - , rbHeight :: Int - , rbWidth :: Int - } - deriving (Eq,Ord,Show) - --------------------------------------------------------------------------------- --- * Inner border strips - --- | Ribbons (or border strips) are defined to be skew partitions which are --- connected and do not contain 2x2 blocks. This function returns the --- border strips whose outer partition is the given one. -innerRibbons :: Partition -> [Ribbon] -innerRibbons part@(Partition ps) = if null ps then [] else strips where - - strips = [ mkStrip i j - | i<-[1..n] , _canStartStrip (annArr!i) - , j<-[i..n] , _canEndStrip (annArr!j) - ] - - n = length annList - annList = annotatedInnerBorderStrip part - annArr = listArray (1,n) annList - - mkStrip !i1 !i2 = Ribbon shape len height width where - ps' = ps ++ [0] - shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] - indent !i !p !q - | i < y1 = 0 - | i > y2 = 0 - | i == y2 = p - x2 + 1 -- the order is important here !!! - | otherwise = p - q + 1 -- because of the case y1 == y2 == i - - len = i2 - i1 + 1 - height = y2 - y1 - width = x1 - x2 - BorderBox _ _ y1 x1 = annArr ! i1 - BorderBox _ _ y2 x2 = annArr ! i2 - --- | Inner border strips (or ribbons) of the given length -innerRibbonsOfLength :: Partition -> Int -> [Ribbon] -innerRibbonsOfLength part@(Partition ps) givenLength = if null ps then [] else strips where - - strips = [ mkStrip i j - | i<-[1..n] , _canStartStrip (annArr!i) - , j<-[i..n] , _canEndStrip (annArr!j) - , j-i+1 == givenLength - ] - - n = length annList - annList = annotatedInnerBorderStrip part - annArr = listArray (1,n) annList - - mkStrip !i1 !i2 = Ribbon shape givenLength height width where - ps' = ps ++ [0] - shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] - indent !i !p !q - | i < y1 = 0 - | i > y2 = 0 - | i == y2 = p - x2 + 1 -- the order is important here !!! - | otherwise = p - q + 1 -- because of the case y1 == y2 == i - - height = y2 - y1 - width = x1 - x2 - BorderBox _ _ y1 x1 = annArr ! i1 - BorderBox _ _ y2 x2 = annArr ! i2 - - --------------------------------------------------------------------------------- --- * Outer border strips - --- | Hooks of length @n@ (TODO: move to the partition module) -listHooks :: Int -> [Partition] -listHooks 0 = [] -listHooks 1 = [ Partition [1] ] -listHooks n = [ Partition (k : replicate (n-k) 1) | k<-[1..n] ] - --- | Outer border strips (or ribbons) of the given length -outerRibbonsOfLength :: Partition -> Int -> [Ribbon] -outerRibbonsOfLength part@(Partition ps) givenLength = result where - - result = if null ps - then [ Ribbon shape givenLength ht wd - | p <- listHooks givenLength - , let shape = mkSkewPartition (p,part) - , let ht = partitionWidth p - 1 -- pretty inconsistent names here :((( - , let wd = partitionHeight p - 1 - ] - else strips - - strips = [ mkStrip i j - | i<-[1..n] , _canStartStrip (annArr!i) - , j<-[i..n] , _canEndStrip (annArr!j) - , j-i+1 == givenLength - ] - - ysize = partitionWidth part - xsize = partitionHeight part - - annList = [ BorderBox True False 1 x | x <- reverse [xsize+2 .. xsize+givenLength ] ] - ++ annList0 - ++ [ BorderBox False True y 1 | y <- [ysize+2 .. ysize+givenLength ] ] - - n = length annList - annList0 = annotatedOuterBorderStrip part - annArr = listArray (1,n) annList - - mkStrip !i1 !i2 = Ribbon shape len height width where - ps' = (-666) : ps ++ replicate (givenLength) 0 - shape = SkewPartition [ (p,k) | (i,p,q) <- zip3 [1..max ysize y2] (tail ps') ps' , let k = indent i p q ] - indent !i !p !q - | i < y1 = 0 - | i > y2 = 0 - | i == y1 = x1 - p -- the order is important here !!! --- | i == y2 = x2 - p - | otherwise = q - p + 1 - - len = i2 - i1 + 1 - height = y2 - y1 - width = x1 - x2 - BorderBox _ _ y1 x1 = annArr ! i1 - BorderBox _ _ y2 x2 = annArr ! i2 - --------------------------------------------------------------------------------- --- * Naive implementations (for testing) - --- | Naive (and slow) implementation listing all inner border strips -innerRibbonsNaive :: Partition -> [Ribbon] -innerRibbonsNaive outer = list where - list = [ Ribbon skew (len skew) (ht skew) (wt skew) - | skew <- allSkewPartitionsWithOuterShape outer - , isRibbon skew - ] - len skew = length (skewPartitionElements skew) - ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 - wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 - - --- | Naive (and slow) implementation listing all inner border strips of the given length -innerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon] -innerRibbonsOfLengthNaive outer givenLength = list where - pweight = partitionWeight outer - list = [ Ribbon skew (len skew) (ht skew) (wt skew) - | skew <- skewPartitionsWithOuterShape outer givenLength - , isRibbon skew - ] - len skew = length (skewPartitionElements skew) - ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 - wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 - --- | Naive (and slow) implementation listing all outer border strips of the given length -outerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon] -outerRibbonsOfLengthNaive inner givenLength = list where - pweight = partitionWeight inner - list = [ Ribbon skew (len skew) (ht skew) (wt skew) - | skew <- skewPartitionsWithInnerShape inner givenLength - , isRibbon skew - ] - len skew = length (skewPartitionElements skew) - ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 - wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 - --------------------------------------------------------------------------------- --- * Annotated borders - --- | A box on the border of a partition -data BorderBox = BorderBox - { _canStartStrip :: !Bool - , _canEndStrip :: !Bool - , _yCoord :: !Int - , _xCoord :: !Int - } - deriving Show - --- | The boxes of the full inner border strip, annotated with whether a border strip --- can start or end there. -annotatedInnerBorderStrip :: Partition -> [BorderBox] -annotatedInnerBorderStrip partition = if isEmptyPartition partition then [] else list where - list = goVert (head corners) (tail corners) - corners = extendedCornerSequence partition - - goVert (y1,x ) ((y2,_ ):rest) = [ BorderBox True (y==y2) y x | y<-[y1+1..y2] ] ++ goHoriz (y2,x) rest - goVert _ [] = [] - - goHoriz (y ,x1) ((_, x2):rest) = case rest of - [] -> [ BorderBox False True y x | x<-[x1-1,x1-2..x2+1] ] - _ -> [ BorderBox False (x/=x2) y x | x<-[x1-1,x1-2..x2 ] ] ++ goVert (y,x2) rest - --- | The boxes of the full outer border strip, annotated with whether a border strip --- can start or end there. -annotatedOuterBorderStrip :: Partition -> [BorderBox] -annotatedOuterBorderStrip partition = if isEmptyPartition partition then [] else list where - list = goVert (head corners) (tail corners) - corners = extendedCornerSequence partition - - goVert (y1,x ) ((y2,_ ):rest) = [ BorderBox (y==y1) (y/=y2) (y+1) (x+1) | y<-[y1..y2] ] ++ goHoriz (y2,x) rest - goVert _ [] = [] - - goHoriz (y ,x1) ((_, x2):rest) = case rest of - [] -> [ BorderBox True (x==0) (y+1) (x+1) | x<-[x1-1,x1-2..x2 ] ] - _ -> [ BorderBox True False (y+1) (x+1) | x<-[x1-1,x1-2..x2+1] ] ++ goVert (y,x2) rest - - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Partitions/Vector.hs b/Math/Combinat/Partitions/Vector.hs deleted file mode 100644 --- a/Math/Combinat/Partitions/Vector.hs +++ /dev/null @@ -1,82 +0,0 @@ - --- | 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/Permutations.hs b/Math/Combinat/Permutations.hs deleted file mode 100644 --- a/Math/Combinat/Permutations.hs +++ /dev/null @@ -1,969 +0,0 @@ - --- | Permutations. --- --- See eg.: --- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B. --- --- WARNING: As of version 0.2.8.0, I changed the convention of how permutations --- are represented internally. Also now they act on the /right/ by default! --- - -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-} -module Math.Combinat.Permutations - ( -- * The Permutation type - Permutation (..) - , fromPermutation - , lookupPermutation , (!!!) - , permutationArray - , permutationUArray - , uarrayToPermutationUnsafe - , isPermutation - , maybePermutation - , toPermutation - , toPermutationUnsafe - , toPermutationUnsafeN - , permutationSize - -- * Disjoint cycles - , DisjointCycles (..) - , fromDisjointCycles - , disjointCyclesUnsafe - , permutationToDisjointCycles - , disjointCyclesToPermutation - , numberOfCycles - , concatPermutations - -- * Queries - , isIdentityPermutation - , isReversePermutation - , isEvenPermutation - , isOddPermutation - , signOfPermutation - , signValueOfPermutation - , module Math.Combinat.Sign -- , Sign(..) - , isCyclicPermutation - -- * Some concrete permutations - , transposition - , transpositions - , adjacentTransposition - , adjacentTranspositions - , cycleLeft - , cycleRight - , reversePermutation - -- * Inversions - , inversions - , numberOfInversions - , numberOfInversionsNaive - , numberOfInversionsMerge - , bubbleSort2 - , bubbleSort - -- * Permutation groups - , identityPermutation - , inversePermutation - , multiplyPermutation - , productOfPermutations - , productOfPermutations' - -- * Action of the permutation group - , permuteArray - , permuteList - , permuteArrayLeft , permuteArrayRight - , permuteListLeft , permuteListRight - -- * Sorting - , sortingPermutationAsc - , sortingPermutationDesc - -- * ASCII drawing - , asciiPermutation - , asciiDisjointCycles - , twoLineNotation - , inverseTwoLineNotation - , genericTwoLineNotation - -- * List of permutations - , permutations - , _permutations - , permutationsNaive - , _permutationsNaive - , countPermutations - -- * Random permutations - , randomPermutation - , _randomPermutation - , randomCyclicPermutation - , _randomCyclicPermutation - , randomPermutationDurstenfeld - , randomCyclicPermutationSattolo - -- * Multisets - , permuteMultiset - , countPermuteMultiset - , fasc2B_algorithm_L - ) - where - --------------------------------------------------------------------------------- - -import Control.Monad -import Control.Monad.ST - -import Data.List hiding ( permutations ) -import Data.Ord ( comparing ) - -import Data.Array (Array) -import Data.Array.ST -import Data.Array.Unboxed -import Data.Array.IArray -import Data.Array.MArray -import Data.Array.Unsafe - -import Data.Vector.Compact.WordVec ( WordVec ) -import qualified Data.Vector.Compact.WordVec as V - -import Math.Combinat.ASCII -import Math.Combinat.Classes -import Math.Combinat.Helper -import Math.Combinat.Sign -import Math.Combinat.Numbers ( factorial , binomial ) - -import System.Random - --------------------------------------------------------------------------------- --- WordVec helpers - -toUArray :: WordVec -> UArray Int Int -toUArray vec = listArray (1,n) (map fromIntegral $ V.toList vec) where n = V.vecLen vec - -fromUArray :: UArray Int Int -> WordVec -fromUArray arr = fromPermListN n (map fromIntegral $ elems arr) where - (1,n) = bounds arr - --- | maximum = length -fromPermListN :: Int -> [Int] -> WordVec -fromPermListN n perm = V.fromList' shape (map fromIntegral perm) where - shape = V.Shape n bits - bits = V.bitsNeededFor (fromIntegral n :: Word) - -fromPermList :: [Int] -> WordVec -fromPermList perm = V.fromList (map fromIntegral perm) - -(.!) :: WordVec -> Int -> Int -(.!) vec idx = fromIntegral (V.unsafeIndex (idx-1) vec) - -_elems :: WordVec -> [Int] -_elems = map fromIntegral . V.toList - -_assocs :: WordVec -> [(Int,Int)] -_assocs vec = zip [1..] (_elems vec) - -_bound :: WordVec -> Int -_bound = V.vecLen - -{- --- the old internal representation (UArray Int Int) - -_elems :: UArray Int Int -> [Int] -_elems = elems - -_assocs :: UArray Int Int -> [(Int,Int)] -_assocs = elems - -_bound :: UArray Int Int -> Int -_bound = snd . bounds --} - - -toPermN :: Int -> [Int] -> Permutation -toPermN n xs = Permutation (fromPermListN n xs) - --------------------------------------------------------------------------------- --- * Types - --- | A permutation. Internally it is an (compact) vector --- of the integers @[1..n]@. --- --- If this array of integers is @[p1,p2,...,pn]@, then in two-line --- notations, that represents the permutation --- --- > ( 1 2 3 ... n ) --- > ( p1 p2 p3 ... pn ) --- --- That is, it is the permutation @sigma@ whose (right) action on the set @[1..n]@ is --- --- > sigma(1) = p1 --- > sigma(2) = p2 --- > ... --- --- (NOTE: this changed at version 0.2.8.0!) --- -newtype Permutation = Permutation WordVec deriving (Eq,Ord) -- ,Show,Read) - -instance Show Permutation where - showsPrec d (Permutation arr) - = showParen (d > 10) - $ showString "toPermutation " . showsPrec 11 (_elems arr) -- app_prec = 10 - -instance Read Permutation where - readsPrec d r = readParen (d > 10) fun r where - fun r = [ (toPermutation p,t) - | ("toPermutation",s) <- lex r - , (p,t) <- readsPrec 11 s -- app_prec = 10 - ] - -instance DrawASCII Permutation where - ascii = asciiPermutation - --- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@. --- --- The cycles are to be understood as follows: a cycle @[c1,c2,...,ck]@ means --- the permutation --- --- > ( c1 c2 c3 ... ck ) --- > ( c2 c3 c4 ... c1 ) --- -newtype DisjointCycles = DisjointCycles [[Int]] deriving (Eq,Ord,Show,Read) - -fromPermutation :: Permutation -> [Int] -fromPermutation (Permutation ar) = _elems ar - -permutationUArray :: Permutation -> UArray Int Int -permutationUArray (Permutation ar) = toUArray ar - -permutationArray :: Permutation -> Array Int Int -permutationArray (Permutation ar) = listArray (1,n) (_elems ar) where - n = _bound ar - --- | Assumes that the input is a permutation of the numbers @[1..n]@. -toPermutationUnsafe :: [Int] -> Permutation -toPermutationUnsafe xs = Permutation (fromPermList xs) - --- | This is faster than 'toPermutationUnsafe', but you need to supply @n@. -toPermutationUnsafeN :: Int -> [Int] -> Permutation -toPermutationUnsafeN n xs = Permutation (fromPermListN n xs) - --- | Note: Indexing starts from 1. -uarrayToPermutationUnsafe :: UArray Int Int -> Permutation -uarrayToPermutationUnsafe = Permutation . fromUArray - --- | Checks whether the input is a permutation of the numbers @[1..n]@. -isPermutation :: [Int] -> Bool -isPermutation xs = (ar!0 == 0) && and [ ar!j == 1 | j<-[1..n] ] where - n = length xs - -- the zero index is an unidiomatic hack - ar = (accumArray (+) 0 (0,n) $ map f xs) :: UArray Int Int - f :: Int -> (Int,Int) - f !j = if j<1 || j>n then (0,1) else (j,1) - --- | Checks whether the input is a permutation of the numbers @[1..n]@. -maybePermutation :: [Int] -> Maybe Permutation -maybePermutation input = runST action where - n = length input - action :: forall s. ST s (Maybe Permutation) - action = do - ar <- newArray (1,n) 0 :: ST s (STUArray s Int Int) - let go [] = return $ Just (toPermutationUnsafe input) - go (j:js) = if j<1 || j>n - then return Nothing - else do - z <- readArray ar j - writeArray ar j (z+1) - if z==0 then go js - else return Nothing - go input - --- | Checks the input. -toPermutation :: [Int] -> Permutation -toPermutation xs = case maybePermutation xs of - Just p -> p - Nothing -> error "toPermutation: not a permutation" - --- | Returns @n@, where the input is a permutation of the numbers @[1..n]@ -permutationSize :: Permutation -> Int -permutationSize (Permutation ar) = _bound ar - --- | Returns the image @sigma(k)@ of @k@ under the permutation @sigma@. --- --- Note: we don't check the bounds! It may even crash if you index out of bounds! -lookupPermutation :: Permutation -> Int -> Int -lookupPermutation (Permutation ar) idx = ar .! idx - --- infix 8 !!! - --- | Infix version of 'lookupPermutation' -(!!!) :: Permutation -> Int -> Int -(!!!) (Permutation ar) idx = ar .! idx - -instance HasWidth Permutation where - width = permutationSize - --- | Checks whether the permutation is the identity permutation -isIdentityPermutation :: Permutation -> Bool -isIdentityPermutation (Permutation ar) = (_elems ar == [1..n]) where - n = _bound ar - --- | Given a permutation of @n@ and a permutation of @m@, we return --- a permutation of @n+m@ resulting by putting them next to each other. --- This should satisfy --- --- > permuteList p1 xs ++ permuteList p2 ys == permuteList (concatPermutations p1 p2) (xs++ys) --- -concatPermutations :: Permutation -> Permutation -> Permutation -concatPermutations perm1 perm2 = toPermutationUnsafe list where - n = permutationSize perm1 - list = fromPermutation perm1 ++ map (+n) (fromPermutation perm2) - --------------------------------------------------------------------------------- --- * ASCII - --- | Synonym for 'twoLineNotation' -asciiPermutation :: Permutation -> ASCII -asciiPermutation = twoLineNotation - -asciiDisjointCycles :: DisjointCycles -> ASCII -asciiDisjointCycles (DisjointCycles cycles) = final where - final = hCatWith VTop (HSepSpaces 1) boxes - boxes = [ genericTwoLineNotation (f cyc) | cyc <- cycles ] - f cyc = pairs (cyc ++ [head cyc]) - --- | The standard two-line notation, moving the element indexed by the top row into --- the place indexed by the corresponding element in the bottom row. -twoLineNotation :: Permutation -> ASCII -twoLineNotation (Permutation arr) = genericTwoLineNotation $ zip [1..] (_elems arr) - --- | The inverse two-line notation, where the it\'s the bottom line --- which is in standard order. The columns of this are a permutation --- of the columns 'twoLineNotation'. --- --- Remark: the top row of @inverseTwoLineNotation perm@ is the same --- as the bottom row of @twoLineNotation (inversePermutation perm)@. --- -inverseTwoLineNotation :: Permutation -> ASCII -inverseTwoLineNotation (Permutation arr) = - genericTwoLineNotation $ sortBy (comparing snd) $ zip [1..] (_elems arr) - --- | Two-line notation for any set of numbers -genericTwoLineNotation :: [(Int,Int)] -> ASCII -genericTwoLineNotation xys = asciiFromLines [ topLine, botLine ] where - topLine = "( " ++ intercalate " " us ++ " )" - botLine = "( " ++ intercalate " " vs ++ " )" - pairs = [ (show x, show y) | (x,y) <- xys ] - (us,vs) = unzip (map f pairs) - f (s,t) = (s',t') where - a = length s - b = length t - c = max a b - s' = replicate (c-a) ' ' ++ s - t' = replicate (c-b) ' ' ++ t - --------------------------------------------------------------------------------- --- * Disjoint cycles - -fromDisjointCycles :: DisjointCycles -> [[Int]] -fromDisjointCycles (DisjointCycles cycles) = cycles - -disjointCyclesUnsafe :: [[Int]] -> DisjointCycles -disjointCyclesUnsafe = DisjointCycles - -instance DrawASCII DisjointCycles where - ascii = asciiDisjointCycles - -instance HasNumberOfCycles DisjointCycles where - numberOfCycles (DisjointCycles cycles) = length cycles - -instance HasNumberOfCycles Permutation where - numberOfCycles = numberOfCycles . permutationToDisjointCycles - -disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation -disjointCyclesToPermutation n (DisjointCycles cycles) = Permutation $ fromUArray perm where - - pairs :: [Int] -> [(Int,Int)] - pairs xs@(x:_) = worker (xs++[x]) where - worker (x:xs@(y:_)) = (x,y):worker xs - worker _ = [] - pairs [] = error "disjointCyclesToPermutation: empty cycle" - - perm = runSTUArray $ do - ar <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \i -> writeArray ar i i - forM_ cycles $ \cyc -> forM_ (pairs cyc) $ \(i,j) -> writeArray ar i j - return ar -- freeze ar - --- | Convert to disjoint cycle notation. --- --- This is compatible with Maple's @convert(perm,\'disjcyc\')@ --- and also with Mathematica's @PermutationCycles[perm]@ --- --- Note however, that for example Mathematica uses the --- /top row/ to represent a permutation, while we use the --- /bottom row/ - thus even though this function looks --- identical, the /meaning/ of both the input and output --- is different! --- -permutationToDisjointCycles :: Permutation -> DisjointCycles -permutationToDisjointCycles (Permutation perm) = res where - - n = _bound perm - - -- we don't want trivial cycles - f :: [Int] -> Bool - f [_] = False - f _ = True - - res = runST $ do - tag <- newArray (1,n) False - cycles <- unfoldM (step tag) 1 - return (DisjointCycles $ filter f cycles) - - step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int) - step tag k = do - cyc <- worker tag k k [k] - m <- next tag (k+1) - return (reverse cyc, m) - - next :: STUArray s Int Bool -> Int -> ST s (Maybe Int) - next tag k = if k > n - then return Nothing - else readArray tag k >>= \b -> if b - then next tag (k+1) - else return (Just k) - - worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int] - worker tag k l cyc = do - writeArray tag l True - let m = perm .! l - if m == k - then return cyc - else worker tag k m (m:cyc) - -isEvenPermutation :: Permutation -> Bool -isEvenPermutation (Permutation perm) = res where - - n = _bound perm - res = runST $ do - tag <- newArray (1,n) False - cycles <- unfoldM (step tag) 1 - return $ even (sum cycles) - - step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int) - step tag k = do - cyclen <- worker tag k k 0 - m <- next tag (k+1) - return (cyclen,m) - - next :: STUArray s Int Bool -> Int -> ST s (Maybe Int) - next tag k = if k > n - then return Nothing - else readArray tag k >>= \b -> if b - then next tag (k+1) - else return (Just k) - - worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int - worker tag k l cyclen = do - writeArray tag l True - let m = perm .! l - if m == k - then return cyclen - else worker tag k m (1+cyclen) - -isOddPermutation :: Permutation -> Bool -isOddPermutation = not . isEvenPermutation - -signOfPermutation :: Permutation -> Sign -signOfPermutation perm = case isEvenPermutation perm of - True -> Plus - False -> Minus - --- | Plus 1 or minus 1. -{-# SPECIALIZE signValueOfPermutation :: Permutation -> Int #-} -{-# SPECIALIZE signValueOfPermutation :: Permutation -> Integer #-} -signValueOfPermutation :: Num a => Permutation -> a -signValueOfPermutation = signValue . signOfPermutation - -isCyclicPermutation :: Permutation -> Bool -isCyclicPermutation perm = - case cycles of - [] -> True - [cyc] -> (length cyc == n) - _ -> False - where - n = permutationSize perm - DisjointCycles cycles = permutationToDisjointCycles perm - --------------------------------------------------------------------------------- --- * Inversions - --- | An /inversion/ of a permutation @sigma@ is a pair @(i,j)@ such that --- @i sigma(j)@. --- --- This functions returns the inversion of a permutation. --- -inversions :: Permutation -> [(Int,Int)] -inversions (Permutation arr) = list where - n = _bound arr - list = [ (i,j) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ] - --- | Returns the number of inversions: --- --- > numberOfInversions perm = length (inversions perm) --- --- Synonym for 'numberOfInversionsMerge' --- -numberOfInversions :: Permutation -> Int -numberOfInversions = numberOfInversionsMerge - --- | Returns the number of inversions, using the merge-sort algorithm. --- This should be @O(n*log(n))@ --- -numberOfInversionsMerge :: Permutation -> Int -numberOfInversionsMerge (Permutation arr) = fst (sortCnt n $ _elems arr) where - n = _bound arr - - -- | First argument is length of the list. - -- Returns also the inversion count. - sortCnt :: Int -> [Int] -> (Int,[Int]) - sortCnt 0 _ = (0,[] ) - sortCnt 1 [x] = (0,[x]) - sortCnt 2 [x,y] = if x>y then (1,[y,x]) else (0,[x,y]) - sortCnt n xs = mergeCnt (sortCnt k us) (sortCnt l vs) where - k = div n 2 - l = n - k - (us,vs) = splitAt k xs - - mergeCnt :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int]) - mergeCnt (!c,us) (!d,vs) = (c+d+e,ws) where - - (e,ws) = go 0 us vs - - go !k xs [] = ( k*length xs , xs ) - go _ [] ys = ( 0 , ys) - go !k xxs@(x:xs) yys@(y:ys) = if x < y - then let (a,zs) = go k xs yys in (a+k, x:zs) - else let (a,zs) = go (k+1) xxs ys in (a , y:zs) - --- | Returns the number of inversions, using the definition, thus it's @O(n^2)@. --- -numberOfInversionsNaive :: Permutation -> Int -numberOfInversionsNaive (Permutation arr) = length list where - n = _bound arr - list = [ (0::Int) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ] - --- | Bubble sorts breaks a permutation into the product of adjacent transpositions: --- --- > multiplyMany' n (map (transposition n) $ bubbleSort2 perm) == perm --- --- Note that while this is not unique, the number of transpositions --- equals the number of inversions. --- -bubbleSort2 :: Permutation -> [(Int,Int)] -bubbleSort2 = map f . bubbleSort where f i = (i,i+1) - --- | Another version of bubble sort. An entry @i@ in the return sequence means --- the transposition @(i,i+1)@: --- --- > multiplyMany' n (map (adjacentTransposition n) $ bubbleSort perm) == perm --- -bubbleSort :: Permutation -> [Int] -bubbleSort perm@(Permutation tgt) = runST action where - n = _bound tgt - - action :: forall s. ST s [Int] - action = do - fwd <- newArray_ (1,n) :: ST s (STUArray s Int Int) - inv <- newArray_ (1,n) :: ST s (STUArray s Int Int) - forM_ [1..n] $ \i -> writeArray fwd i i - forM_ [1..n] $ \i -> writeArray inv i i - - list <- forM [1..n] $ \x -> do - - let k = tgt .! x -- we take the number which will be at the @x@-th position at the end - i <- readArray inv k -- number @k@ is at the moment at position @i@ - let j = x -- but the final place is at @x@ - - let swaps = move i j - forM_ swaps $ \y -> do - - a <- readArray fwd y - b <- readArray fwd (y+1) - writeArray fwd (y+1) a - writeArray fwd y b - - u <- readArray inv a - v <- readArray inv b - writeArray inv b u - writeArray inv a v - - return swaps - - return (concat list) - - move :: Int -> Int -> [Int] - move !i !j - | j == i = [] - | j > i = [i..j-1] - | j < i = [i-1,i-2..j] - --------------------------------------------------------------------------------- --- * Some concrete permutations - --- | The permutation @[n,n-1,n-2,...,2,1]@. Note that it is the inverse of itself. -reversePermutation :: Int -> Permutation -reversePermutation n = Permutation $ fromPermListN n [n,n-1..1] - --- | Checks whether the permutation is the reverse permutation @[n,n-1,n-2,...,2,1]. -isReversePermutation :: Permutation -> Bool -isReversePermutation (Permutation arr) = _elems arr == [n,n-1..1] where n = _bound arr - --- | A transposition (swapping two elements). --- --- @transposition n (i,j)@ is the permutation of size @n@ which swaps @i@\'th and @j@'th elements. --- -transposition :: Int -> (Int,Int) -> Permutation -transposition n (i,j) = - if i>=1 && j>=1 && i<=n && j<=n - then Permutation $ fromPermListN n [ f k | k<-[1..n] ] - else error "transposition: index out of range" - where - f k | k == i = j - | k == j = i - | otherwise = k - --- | Product of transpositions. --- --- > transpositions n list == multiplyMany [ transposition n pair | pair <- list ] --- -transpositions :: Int -> [(Int,Int)] -> Permutation -transpositions n list = Permutation (fromUArray $ runSTUArray action) where - - action :: ST s (STUArray s Int Int) - action = do - arr <- newArray_ (1,n) - forM_ [1..n] $ \i -> writeArray arr i i - let doSwap (i,j) = do - u <- readArray arr i - v <- readArray arr j - writeArray arr i v - writeArray arr j u - mapM_ doSwap list - return arr - --- | @adjacentTransposition n k@ swaps the elements @k@ and @(k+1)@. -adjacentTransposition :: Int -> Int -> Permutation -adjacentTransposition n k - | k>0 && k adjacentTranspositions n list == multiplyMany [ adjacentTransposition n idx | idx <- list ] --- -adjacentTranspositions :: Int -> [Int] -> Permutation -adjacentTranspositions n list = Permutation (fromUArray $ runSTUArray action) where - - action :: ST s (STUArray s Int Int) - action = do - arr <- newArray_ (1,n) - forM_ [1..n] $ \i -> writeArray arr i i - let doSwap i - | i<0 || i>=n = error "adjacentTranspositions: index out of range" - | otherwise = do - u <- readArray arr i - v <- readArray arr (i+1) - writeArray arr i v - writeArray arr (i+1) u - mapM_ doSwap list - return arr - --- | The permutation which cycles a list left by one step: --- --- > permuteList (cycleLeft 5) "abcde" == "bcdea" --- --- Or in two-line notation: --- --- > ( 1 2 3 4 5 ) --- > ( 2 3 4 5 1 ) --- -cycleLeft :: Int -> Permutation -cycleLeft n = Permutation $ fromPermListN n ([2..n] ++ [1]) - --- | The permutation which cycles a list right by one step: --- --- > permuteList (cycleRight 5) "abcde" == "eabcd" --- --- Or in two-line notation: --- --- > ( 1 2 3 4 5 ) --- > ( 5 1 2 3 4 ) --- -cycleRight :: Int -> Permutation -cycleRight n = Permutation $ fromPermListN n (n : [1..n-1]) - --------------------------------------------------------------------------------- --- * Permutation groups - --- | Multiplies two permutations together: @p `multiplyPermutation` q@ --- means the permutation when we first apply @p@, and then @q@ --- (that is, the natural action is the /right/ action) --- --- See also 'permuteArray' for our conventions. --- -multiplyPermutation :: Permutation -> Permutation -> Permutation -multiplyPermutation pi1@(Permutation perm1) pi2@(Permutation perm2) = - if (n==m) - then Permutation $ fromUArray result - else error "multiplyPermutation: permutations of different sets" - where - n = _bound perm1 - m = _bound perm2 - result = permuteArray pi2 (toUArray perm1) - -infixr 7 `multiplyPermutation` - --- | The inverse permutation. -inversePermutation :: Permutation -> Permutation -inversePermutation (Permutation perm1) = Permutation $ fromUArray result - where - result = array (1,n) $ map swap $ _assocs perm1 - n = _bound perm1 - --- | The identity (or trivial) permutation. -identityPermutation :: Int -> Permutation -identityPermutation n = Permutation $ fromPermListN n [1..n] - --- | Multiply together a /non-empty/ list of permutations (the reason for requiring the list to --- be non-empty is that we don\'t know the size of the result). See also 'multiplyMany''. -productOfPermutations :: [Permutation] -> Permutation -productOfPermutations [] = error "productOfPermutations: empty list, we don't know size of the result" -productOfPermutations ps = foldl1' multiplyPermutation ps - --- | Multiply together a (possibly empty) list of permutations, all of which has size @n@ -productOfPermutations' :: Int -> [Permutation] -> Permutation -productOfPermutations' n [] = identityPermutation n -productOfPermutations' n ps@(p:_) = if n == permutationSize p - then foldl1' multiplyPermutation ps - else error "productOfPermutations': incompatible permutation size(s)" - --------------------------------------------------------------------------------- --- * Action of the permutation group - --- | /Right/ action of a permutation on a set. If our permutation is --- encoded with the sequence @[p1,p2,...,pn]@, then in the --- two-line notation we have --- --- > ( 1 2 3 ... n ) --- > ( p1 p2 p3 ... pn ) --- --- We adopt the convention that permutations act /on the right/ --- (as in Knuth): --- --- > permuteArray pi2 (permuteArray pi1 set) == permuteArray (pi1 `multiplyPermutation` pi2) set --- --- Synonym to 'permuteArrayRight' --- -{-# SPECIALIZE permuteArray :: Permutation -> Array Int b -> Array Int b #-} -{-# SPECIALIZE permuteArray :: Permutation -> UArray Int Int -> UArray Int Int #-} -permuteArray :: IArray arr b => Permutation -> arr Int b -> arr Int b -permuteArray = permuteArrayRight - --- | Right action on lists. Synonym to 'permuteListRight' --- -permuteList :: Permutation -> [a] -> [a] -permuteList = permuteListRight - --- | The right (standard) action of permutations on sets. --- --- > permuteArrayRight pi2 (permuteArrayRight pi1 set) == permuteArrayRight (pi1 `multiplyPermutation` pi2) set --- --- The second argument should be an array with bounds @(1,n)@. --- The function checks the array bounds. --- -{-# SPECIALIZE permuteArrayRight :: Permutation -> Array Int b -> Array Int b #-} -{-# SPECIALIZE permuteArrayRight :: Permutation -> UArray Int Int -> UArray Int Int #-} -permuteArrayRight :: IArray arr b => Permutation -> arr Int b -> arr Int b -permuteArrayRight pi@(Permutation perm) ar = - if (a==1) && (b==n) - then listArray (1,n) [ ar!(perm.!i) | i <- [1..n] ] - else error "permuteArrayRight: array bounds do not match" - where - n = _bound perm - (a,b) = bounds ar - --- | The right (standard) action on a list. The list should be of length @n@. --- --- > fromPermutation perm == permuteListRight perm [1..n] --- -permuteListRight :: forall a . Permutation -> [a] -> [a] -permuteListRight perm xs = elems $ permuteArrayRight perm $ arr where - arr = listArray (1,n) xs :: Array Int a - n = permutationSize perm - --- | The left (opposite) action of the permutation group. --- --- > permuteArrayLeft pi2 (permuteArrayLeft pi1 set) == permuteArrayLeft (pi2 `multiplyPermutation` pi1) set --- --- It is related to 'permuteLeftArray' via: --- --- > permuteArrayLeft pi arr == permuteArrayRight (inversePermutation pi) arr --- > permuteArrayRight pi arr == permuteArrayLeft (inversePermutation pi) arr --- -{-# SPECIALIZE permuteArrayLeft :: Permutation -> Array Int b -> Array Int b #-} -{-# SPECIALIZE permuteArrayLeft :: Permutation -> UArray Int Int -> UArray Int Int #-} -permuteArrayLeft :: IArray arr b => Permutation -> arr Int b -> arr Int b -permuteArrayLeft pi@(Permutation perm) ar = - -- permuteRight (inverse pi) ar - if (a==1) && (b==n) - then array (1,n) [ ( perm.!i , ar!i ) | i <- [1..n] ] - else error "permuteArrayLeft: array bounds do not match" - where - n = _bound perm - (a,b) = bounds ar - --- | The left (opposite) action on a list. The list should be of length @n@. --- --- > permuteListLeft perm set == permuteList (inversePermutation perm) set --- > fromPermutation (inversePermutation perm) == permuteListLeft perm [1..n] --- -permuteListLeft :: forall a. Permutation -> [a] -> [a] -permuteListLeft perm xs = elems $ permuteArrayLeft perm $ arr where - arr = listArray (1,n) xs :: Array Int a - n = permutationSize perm - --------------------------------------------------------------------------------- - --- | Given a list of things, we return a permutation which sorts them into --- ascending order, that is: --- --- > permuteList (sortingPermutationAsc xs) xs == sort xs --- --- Note: if the things are not unique, then the sorting permutations is not --- unique either; we just return one of them. --- -sortingPermutationAsc :: Ord a => [a] -> Permutation -sortingPermutationAsc xs = toPermutation (map fst sorted) where - sorted = sortBy (comparing snd) $ zip [1..] xs - --- | Given a list of things, we return a permutation which sorts them into --- descending order, that is: --- --- > permuteList (sortingPermutationDesc xs) xs == reverse (sort xs) --- --- Note: if the things are not unique, then the sorting permutations is not --- unique either; we just return one of them. --- -sortingPermutationDesc :: Ord a => [a] -> Permutation -sortingPermutationDesc xs = toPermutation (map fst sorted) where - sorted = sortBy (reverseComparing snd) $ zip [1..] xs - --------------------------------------------------------------------------------- --- * Permutations of distinct elements - --- | A synonym for 'permutationsNaive' -permutations :: Int -> [Permutation] -permutations = permutationsNaive - -_permutations :: Int -> [[Int]] -_permutations = _permutationsNaive - --- | All permutations of @[1..n]@ in lexicographic order, naive algorithm. -permutationsNaive :: Int -> [Permutation] -permutationsNaive n = map toPermutationUnsafe $ _permutations n - -_permutationsNaive :: Int -> [[Int]] -_permutationsNaive 0 = [[]] -_permutationsNaive 1 = [[1]] -_permutationsNaive 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 - --- | # = n! -countPermutations :: Int -> Integer -countPermutations = factorial - --------------------------------------------------------------------------------- --- * Random permutations - --- | A synonym for 'randomPermutationDurstenfeld'. -randomPermutation :: RandomGen g => Int -> g -> (Permutation,g) -randomPermutation = randomPermutationDurstenfeld - -_randomPermutation :: RandomGen g => Int -> g -> ([Int],g) -_randomPermutation n rndgen = (fromPermutation perm, rndgen') where - (perm, rndgen') = randomPermutationDurstenfeld n rndgen - --- | A synonym for 'randomCyclicPermutationSattolo'. -randomCyclicPermutation :: RandomGen g => Int -> g -> (Permutation,g) -randomCyclicPermutation = randomCyclicPermutationSattolo - -_randomCyclicPermutation :: RandomGen g => Int -> g -> ([Int],g) -_randomCyclicPermutation n rndgen = (fromPermutation perm, rndgen') where - (perm, rndgen') = randomCyclicPermutationSattolo n rndgen - --- | Generates a uniformly random permutation of @[1..n]@. --- Durstenfeld's algorithm (see ). -randomPermutationDurstenfeld :: RandomGen g => Int -> g -> (Permutation,g) -randomPermutationDurstenfeld = randomPermutationDurstenfeldSattolo False - --- | Generates a uniformly random /cyclic/ permutation of @[1..n]@. --- Sattolo's algorithm (see ). -randomCyclicPermutationSattolo :: RandomGen g => Int -> g -> (Permutation,g) -randomCyclicPermutationSattolo = randomPermutationDurstenfeldSattolo True - -randomPermutationDurstenfeldSattolo :: RandomGen g => Bool -> Int -> g -> (Permutation,g) -randomPermutationDurstenfeldSattolo isSattolo n rnd = res where - res = runST $ do - ar <- newArray_ (1,n) - forM_ [1..n] $ \i -> writeArray ar i i - rnd' <- worker n (if isSattolo then n-1 else n) rnd ar - perm <- Data.Array.Unsafe.unsafeFreeze ar - return (Permutation (fromUArray perm), rnd') - worker :: RandomGen g => Int -> Int -> g -> STUArray s Int Int -> ST s g - worker n m rnd ar = - if n==1 - then return rnd - else do - let (k,rnd') = randomR (1,m) rnd - when (k /= n) $ do - y <- readArray ar k - z <- readArray ar n - writeArray ar n y - writeArray ar k z - worker (n-1) (m-1) rnd' ar - --------------------------------------------------------------------------------- --- * Permutations of a multiset - --- | Generates all permutations of a multiset. --- The order is lexicographic. A synonym for 'fasc2B_algorithm_L' -permuteMultiset :: (Eq a, Ord a) => [a] -> [[a]] -permuteMultiset = fasc2B_algorithm_L - --- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) } -countPermuteMultiset :: (Eq a, Ord a) => [a] -> Integer -countPermuteMultiset 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/RootSystems.hs b/Math/Combinat/RootSystems.hs deleted file mode 100644 --- a/Math/Combinat/RootSystems.hs +++ /dev/null @@ -1,319 +0,0 @@ - --- | Naive (very inefficient) algorithm to generate the irreducible (Dynkin) root systems --- --- Based on - -{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} -module Math.Combinat.RootSystems where - --------------------------------------------------------------------------------- - -import Control.Monad - -import Data.Array - -import Data.Set (Set) -import qualified Data.Set as Set - -import Data.List -import Data.Ord - -import Math.Combinat.Numbers.Primes -import Math.Combinat.Sets - --------------------------------------------------------------------------------- --- * Half-integers - --- | The type of half-integers (internally represented by their double) --- --- TODO: refactor this into its own module -newtype HalfInt - = HalfInt Int - deriving (Eq,Ord) - -half :: HalfInt -half = HalfInt 1 - -divByTwo :: Int -> HalfInt -divByTwo n = HalfInt n - -mulByTwo :: HalfInt -> Int -mulByTwo (HalfInt n) = n - -scaleBy :: Int -> HalfInt -> HalfInt -scaleBy k (HalfInt n) = HalfInt (k*n) - -instance Show HalfInt where - show (HalfInt n) = case divMod n 2 of - (k,0) -> show k - (_,1) -> show n ++ "/2" - -instance Num HalfInt where - fromInteger = HalfInt . (*2) . fromInteger - a + b = divByTwo $ mulByTwo a + mulByTwo b - a - b = divByTwo $ mulByTwo a - mulByTwo b - a * b = case divMod (mulByTwo a * mulByTwo b) 4 of - (k,0) -> HalfInt (2*k) - (k,2) -> HalfInt (2*k+1) - _ -> error "the result of multiplication is not a half-integer" - negate = divByTwo . negate . mulByTwo - signum = divByTwo . signum . mulByTwo - abs = divByTwo . abs . mulByTwo - --------------------------------------------------------------------------------- --- * Vectors of half-integers - -type HalfVec = [HalfInt] - -instance Num HalfVec where - fromInteger = error "HalfVec/fromInteger" - (+) = safeZip (+) - (-) = safeZip (-) - (*) = safeZip (*) - negate = map negate - abs = map abs - signum = map signum - -scaleVec :: Int -> HalfVec -> HalfVec -scaleVec k = map (scaleBy k) - -negateVec :: HalfVec -> HalfVec -negateVec = map negate - --- dotProd :: HalfVec -> HalfVec --- dotProd xs ys = foldl' (+) 0 $ safeZip (*) xs ys - -safeZip :: (a -> b -> c) -> [a] -> [b] -> [c] -safeZip f = go where - go (x:xs) (y:ys) = f x y : go xs ys - go [] [] = [] - go _ _ = error "safeZip: the lists do not have equal length" - --------------------------------------------------------------------------------- --- * Dynkin diagrams - -data Dynkin - = A !Int - | B !Int - | C !Int - | D !Int - | E6 | E7 | E8 - | F4 - | G2 - deriving (Eq,Show) - --------------------------------------------------------------------------------- --- * The roots of root systems - --- | The ambient dimension of (our representation of the) system (length of the vector) -ambientDim :: Dynkin -> Int -ambientDim d = case d of - A n -> n+1 -- it's an n dimensional subspace of (n+1) dimensions - B n -> n - C n -> n - D n -> n - E6 -> 6 - E7 -> 8 -- sublattice of E8 ? - E8 -> 8 - F4 -> 4 - G2 -> 3 -- it's a 2 dimensional subspace of 3 dimensions - -simpleRootsOf :: Dynkin -> [HalfVec] -simpleRootsOf d = - - case d of - - A n -> [ e i - e (i+1) | i <- [1..n] ] - - B n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e n] - - C n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [scaleVec 2 (e n)] - - D n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e (n-1) + e n] - - E6 -> simpleRootsE6_123 - E7 -> simpleRootsE7_12 - E8 -> simpleRootsE8_even - - F4 -> [ [ 1,-1, 0, 0] - , [ 0, 1,-1, 0] - , [ 0, 0, 1, 0] - , [-h,-h,-h,-h] - ] - - G2 -> [ [ 1,-1, 0] - , [-1, 2,-1] - ] - - where - h = half - n = ambientDim d - - e :: Int -> HalfVec - e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 - -positiveRootsOf :: Dynkin -> Set HalfVec -positiveRootsOf = positiveRoots . simpleRootsOf - -negativeRootsOf :: Dynkin -> Set HalfVec -negativeRootsOf = Set.map negate . positiveRootsOf - -allRootsOf :: Dynkin -> Set HalfVec -allRootsOf dynkin = Set.unions [ pos , neg ] where - simple = simpleRootsOf dynkin - pos = positiveRoots simple - neg = Set.map negate pos - --------------------------------------------------------------------------------- --- * Positive roots - --- | Finds a vector, which is hopefully not orthognal to any root --- (generated by the given simple roots), and has positive dot product with each of them. -findPositiveHyperplane :: [HalfVec] -> [Double] -findPositiveHyperplane vs = w where - n = length (head vs) - w0 = map (fromIntegral . mulByTwo) (foldl1 (+) vs) :: [Double] - w = zipWith (+) w0 perturb - perturb = map small $ map fromIntegral $ take n primes - small :: Double -> Double - small x = x / (10**10) - -positiveRoots :: [HalfVec] -> Set HalfVec -positiveRoots simples = Set.fromList pos where - roots = mirrorClosure simples - w = findPositiveHyperplane simples - pos = [ r | r <- Set.toList roots , dot4 r > 0 ] where - - dot4 :: HalfVec -> Double - dot4 a = foldl' (+) 0 $ safeZip (*) w $ map (fromIntegral . mulByTwo) a - -basisOfPositives :: Set HalfVec -> [HalfVec] -basisOfPositives set = Set.toList (Set.difference set set2) where - set2 = Set.fromList [ a + b | [a,b] <- choose 2 (Set.toList set) ] - - --------------------------------------------------------------------------------- --- * Operations on half-integer vectors - --- | bracket b a = (a,b)/(a,a) -bracket :: HalfVec -> HalfVec -> HalfInt -bracket b a = - case divMod (2*a_dot_b) (a_dot_a) of - (n,0) -> divByTwo n - _ -> error "bracket: result is not a half-integer" - where - a_dot_b = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo b) - a_dot_a = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo a) - --- | mirror b a = b - 2*(a,b)/(a,a) * a -mirror :: HalfVec -> HalfVec -> HalfVec -mirror b a = b - scaleVec (mulByTwo $ bracket b a) a - --- | Cartan matrix of a list of (simple) roots -cartanMatrix :: [HalfVec] -> Array (Int,Int) Int -cartanMatrix list = array ((1,1),(n,n)) [ ((i,j), f i j) | i<-[1..n] , j<-[1..n] ] where - n = length list - arr = listArray (1,n) list - f !i !j = mulByTwo $ bracket (arr!j) (arr!i) - -printMatrix :: Show a => Array (Int,Int) a -> IO () -printMatrix arr = do - let ((1,1),(n,m)) = bounds arr - arr' = fmap show arr - let ks = [ 1 + maximum [ length (arr'!(i,j)) | i<-[1..n] ] | j<-[1..m] ] - forM_ [1..n] $ \i -> do - putStrLn $ flip concatMap [1..m] $ \j -> extendTo (ks!!(j-1)) $ arr' ! (i,j) - where - extendTo n s = replicate (n-length s) ' ' ++ s - --------------------------------------------------------------------------------- --- * Mirroring - --- | We mirror stuff until there is no more things happening --- (very naive algorithm, but seems to work) -mirrorClosure :: [HalfVec] -> Set HalfVec -mirrorClosure = go . Set.fromList where - - go set - | n' > n = go set' - | n'' > n = go set'' - | otherwise = set - where - n = Set.size set - n' = Set.size set' - n'' = Set.size set'' - set' = mirrorStep set - set'' = Set.union set (Set.map negateVec set) - -mirrorStep :: Set HalfVec -> Set HalfVec -mirrorStep old = Set.union old new where - new = Set.fromList [ mirror b a | [a,b] <- choose 2 $ Set.toList old ] - --------------------------------------------------------------------------------- --- * E6, E7 and E8 - --- | This is a basis of E6 as the subset of the even E8 root system --- where the first three coordinates agree (they are consolidated --- into the first coordinate here) -simpleRootsE6_123:: [HalfVec] -simpleRootsE6_123 = roots where - h = half - roots = - [ [-h,-h,-h,-h,-h,-h,-h,-h] - , [ h, h, h, h, h, h,-h,-h] - , [ 0, 0, 0, 0,-1, 0, 1, 0] - , [ 0, 0, 0, 0, 0, 0,-1, 1] - , [-h,-h,-h, h, h, h, h,-h] - , [ 0, 0, 0,-1, 1, 0, 0, 0] - ] - --- | This is a basis of E8 as the subset of the even E8 root system --- where the first two coordinates agree (they are consolidated --- into the first coordinate here) -simpleRootsE7_12:: [HalfVec] -simpleRootsE7_12 = roots where - h = half - roots = - [ [-h,-h,-h,-h,-h,-h,-h,-h] - , [ h, h, h, h, h, h,-h,-h] - , [ h, h,-h,-h,-h,-h, h, h] - , [-h,-h, h, h,-h, h, h,-h] - , [ 0, 0, 0,-1, 1, 0, 0, 0] - , [ 0, 0,-1, 1, 0, 0, 0, 0] - , [ 0, 0, 0, 0, 0, 0,-1, 1] - ] - --- | This is a basis of E7 as the subset of the even E8 root system --- for which the sum of coordinates sum to zero -simpleRootsE7_diag :: [HalfVec] -simpleRootsE7_diag = roots where - roots = [ e i - e (i+1) | i <-[2..7] ] ++ [[h,h,h,h,-h,-h,-h,-h]] - h = half - n = 8 - - e :: Int -> HalfVec - e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 - -simpleRootsE8_even :: [HalfVec] -simpleRootsE8_even = roots where - roots = [v1,v2,v3,v4,v5,v7,v8,v6] - - [v1,v2,v3,v4,v5,v6,v7,v8] = roots0 - roots0 = [ e i - e (i+1) | i <-[1..6] ] ++ [ e 6 + e 7 , replicate 8 (-h) ] - - h = half - n = 8 - - e :: Int -> HalfVec - e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 - -simpleRootsE8_odd :: [HalfVec] -simpleRootsE8_odd = roots where - roots = [ e i - e (i+1) | i <-[1..7] ] ++ [[-h,-h,-h,-h,-h , h,h,h]] - h = half - n = 8 - - e :: Int -> HalfVec - e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Sets.hs b/Math/Combinat/Sets.hs deleted file mode 100644 --- a/Math/Combinat/Sets.hs +++ /dev/null @@ -1,212 +0,0 @@ - --- | Subsets. - -{-# LANGUAGE BangPatterns, Rank2Types #-} -module Math.Combinat.Sets - ( - -- * Choices - choose_ , choose , choose' , choose'' , chooseTagged - -- * Compositions - , combine , compose - -- * Tensor products - , tuplesFromList - , listTensor - -- * Sublists - , kSublists - , sublists - , countKSublists - , countSublists - -- * Random choice - , randomChoice - ) - where - --------------------------------------------------------------------------------- - -import Data.List ( sort , mapAccumL ) -import System.Random - -import Control.Monad -import Control.Monad.ST -import Data.Array.ST -import Data.Array.MArray - --- import Data.Map (Map) --- import qualified Data.Map as Map - -import Math.Combinat.Numbers ( binomial ) -import Math.Combinat.Helper ( swap ) - --------------------------------------------------------------------------------- --- * choices - - --- | @choose_ k n@ returns all possible ways of choosing @k@ disjoint elements from @[1..n]@ --- --- > choose_ k n == choose k [1..n] --- -choose_ :: Int -> Int -> [[Int]] -choose_ k n = if n<0 || k<0 - then error "choose_: n and k should nonnegative" - else if k>n || k<0 - then [] - else choose k [1..n] - --- | All possible ways to choose @k@ elements from a list, without --- repetitions. \"Antisymmetric power\" for lists. Synonym for 'kSublists'. -choose :: Int -> [a] -> [[a]] -choose 0 _ = [[]] -choose k [] = [] -choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs - --- | A version of 'choose' which also returns the complementer sets. --- --- > choose k = map fst . choose' k --- -choose' :: Int -> [a] -> [([a],[a])] -choose' 0 xs = [([],xs)] -choose' k [] = [] -choose' k (x:xs) = map f (choose' (k-1) xs) ++ map g (choose' k xs) where - f (as,bs) = (x:as , bs) - g (as,bs) = ( as , x:bs) - --- | Another variation of 'choose''. This satisfies --- --- > choose'' k == map (\(xs,ys) -> (map fst xs, map snd ys)) . choose' k --- -choose'' :: Int -> [(a,b)] -> [([a],[b])] -choose'' 0 xys = [([] , map snd xys)] -choose'' k [] = [] -choose'' k ((x,y):xs) = map f (choose'' (k-1) xs) ++ map g (choose'' k xs) where - f (as,bs) = (x:as , bs) - g (as,bs) = ( as , y:bs) - --- | Another variation on 'choose' which tags the elements based on whether they are part of --- the selected subset ('Right') or not ('Left'): --- --- > choose k = map rights . chooseTagged k --- -chooseTagged :: Int -> [a] -> [[Either a a]] -chooseTagged 0 xs = [map Left xs] -chooseTagged k [] = [] -chooseTagged k (x:xs) = map f (chooseTagged (k-1) xs) ++ map g (chooseTagged k xs) where - f eis = Right x : eis - g eis = Left x : eis - --- | All possible ways to choose @k@ elements from a list, /with repetitions/. --- \"Symmetric power\" for lists. See also "Math.Combinat.Compositions". --- TODO: better name? -combine :: Int -> [a] -> [[a]] -combine 0 _ = [[]] -combine k [] = [] -combine k xxs@(x:xs) = map (x:) (combine (k-1) xxs) ++ combine k xs - --- | A synonym for 'combine'. -compose :: Int -> [a] -> [[a]] -compose = combine - --------------------------------------------------------------------------------- --- * tensor products - --- | \"Tensor power\" for lists. Special case of 'listTensor': --- --- > tuplesFromList k xs == listTensor (replicate k xs) --- --- See also "Math.Combinat.Tuples". --- TODO: better name? -tuplesFromList :: Int -> [a] -> [[a]] -tuplesFromList 0 _ = [[]] -tuplesFromList k xs = [ (y:ys) | ys <- tuplesFromList (k-1) xs , y <- xs ] ---the order seems to be very important, the wrong order causes a memory leak! ---tuplesFromList k xs = [ (y:ys) | y <- xs, ys <- tuplesFromList (k-1) xs ] - --- | \"Tensor product\" for lists. -listTensor :: [[a]] -> [[a]] -listTensor [] = [[]] -listTensor (xs:xss) = [ y:ys | ys <- listTensor xss , y <- xs ] ---the order seems to be very important, the wrong order causes a memory leak! ---listTensor (xs:xss) = [ y:ys | y <- xs, ys <- listTensor xss ] - --------------------------------------------------------------------------------- --- * sublists - --- | Sublists of a list having given number of elements. Synonym for 'choose'. -kSublists :: Int -> [a] -> [[a]] -kSublists = choose - --- | @# = \binom { n } { k }@. -countKSublists :: Int -> Int -> Integer -countKSublists k n = binomial n k - --- | All sublists of a list. -sublists :: [a] -> [[a]] -sublists [] = [[]] -sublists (x:xs) = sublists xs ++ map (x:) (sublists xs) ---the order seems to be very important, the wrong order causes a memory leak! ---sublists (x:xs) = map (x:) (sublists xs) ++ sublists xs - --- | @# = 2^n@. -countSublists :: Int -> Integer -countSublists n = 2 ^ n - --------------------------------------------------------------------------------- --- * random choice - --- | @randomChoice k n@ returns a uniformly random choice of @k@ elements from the set @[1..n]@ --- --- Example: --- --- > do --- > cs <- replicateM 10000 (getStdRandom (randomChoice 3 7)) --- > mapM_ print $ histogram cs --- -randomChoice :: RandomGen g => Int -> Int -> g -> ([Int],g) -randomChoice k n g0 = - if k>n || k<0 - then error "randomChoice: k out of range" - else (makeChoiceFromIndicesKnuth n as, g1) - where - -- choose numbers from [1..n], [1..n-1], [1..n-2] etc - (g1,as) = mapAccumL (\g m -> swap (randomR (1,m) g)) g0 [n,n-1..n-k+1] - --------------------------------------------------------------------------------- - --- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, --- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@. --- --- Knuth's method. The first argument is the number @n@. --- -makeChoiceFromIndicesKnuth :: Int -> [Int] -> [Int] -makeChoiceFromIndicesKnuth n xs = - runST $ do - arr <- newArray_ (1,n) :: forall s. ST s (STUArray s Int Int) - forM_ [1..n] $ \(!j) -> writeArray arr j j - forM_ (zip [n,n-1..] xs) $ \(!j,!i) -> do - a <- readArray arr j - b <- readArray arr i - writeArray arr j b - writeArray arr i a - sel <- forM (zip [n,n-1..] xs) $ \(!j,_) -> readArray arr j - return (sort sel) - --- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, --- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@. -makeChoiceFromIndicesNaive :: [Int] -> [Int] -makeChoiceFromIndicesNaive = sort . go [] where - - go :: [Int] -> [Int] -> [Int] - go acc (b:bs) = b' : go (insert b' acc) bs where b' = skip b acc - go _ [] = [] - - -- skip over the already occupied positions. Second argument should be a sorted list - skip :: Int -> [Int] -> Int - skip x (y:ys) = if x>=y then skip (x+1) ys else x - skip x [] = x - - -- insert into a sorted list - insert :: Int -> [Int] -> [Int] - insert x (y:ys) = if x<=y then x:y:ys else y : insert x ys - insert x [] = [x] - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Sets/VennDiagrams.hs b/Math/Combinat/Sets/VennDiagrams.hs deleted file mode 100644 --- a/Math/Combinat/Sets/VennDiagrams.hs +++ /dev/null @@ -1,150 +0,0 @@ - --- | Venn diagrams. See --- --- TODO: write a more efficient implementation (for example an array of size @2^n@) --- - -{-# LANGUAGE BangPatterns #-} -module Math.Combinat.Sets.VennDiagrams where - --------------------------------------------------------------------------------- - -import Data.List - -import GHC.TypeLits -import Data.Proxy - -import qualified Data.Map as Map -import Data.Map (Map) - -import Math.Combinat.Compositions -import Math.Combinat.ASCII - --------------------------------------------------------------------------------- - --- | Venn diagrams of @n@ sets. Each possible zone is annotated with a value --- of type @a@. A typical use case is to annotate with the cardinality of the --- given zone. --- --- Internally this is representated by a map from @[Bool]@, where @True@ means element --- of the set, @False@ means not. --- --- TODO: write a more efficient implementation (for example an array of size 2^n) -newtype VennDiagram a = VennDiagram { vennTable :: Map [Bool] a } deriving (Eq,Ord,Show) - --- | How many sets are in the Venn diagram -vennDiagramNumberOfSets :: VennDiagram a -> Int -vennDiagramNumberOfSets (VennDiagram table) = length $ fst $ Map.findMin table - --- | How many zones are in the Venn diagram --- --- > vennDiagramNumberOfZones v == 2 ^ (vennDiagramNumberOfSets v) --- -vennDiagramNumberOfZones :: VennDiagram a -> Int -vennDiagramNumberOfZones venn = 2 ^ (vennDiagramNumberOfSets venn) - --- | How many /nonempty/ zones are in the Venn diagram -vennDiagramNumberOfNonemptyZones :: VennDiagram Int -> Int -vennDiagramNumberOfNonemptyZones (VennDiagram table) = length $ filter (/=0) $ Map.elems table - -unsafeMakeVennDiagram :: [([Bool],a)] -> VennDiagram a -unsafeMakeVennDiagram = VennDiagram . Map.fromList - --- | We call venn diagram trivial if all the intersection zones has zero cardinality --- (that is, the original sets are all disjoint) -isTrivialVennDiagram :: VennDiagram Int -> Bool -isTrivialVennDiagram (VennDiagram table) = and [ c == 0 | (bs,c) <- Map.toList table , isIntersection bs ] where - isIntersection bs = case filter id bs of - [] -> False - [_] -> False - _ -> True - -printVennDiagram :: Show a => VennDiagram a -> IO () -printVennDiagram = putStrLn . prettyVennDiagram - -prettyVennDiagram :: Show a => VennDiagram a -> String -prettyVennDiagram = unlines . asciiLines . asciiVennDiagram - -asciiVennDiagram :: Show a => VennDiagram a -> ASCII -asciiVennDiagram (VennDiagram table) = asciiFromLines $ map f (Map.toList table) where - f (bs,a) = "{" ++ extendTo (length bs) [ if b then z else ' ' | (b,z) <- zip bs abc ] ++ "} -> " ++ show a - extendTo k str = str ++ replicate (k - length str) ' ' - abc = ['A'..'Z'] - -instance Show a => DrawASCII (VennDiagram a) where - ascii = asciiVennDiagram - --- | Given a Venn diagram of cardinalities, we compute the cardinalities of the --- original sets (note: this is slow!) -vennDiagramSetCardinalities :: VennDiagram Int -> [Int] -vennDiagramSetCardinalities (VennDiagram table) = go n list where - list = Map.toList table - n = length $ fst $ head list - go :: Int -> [([Bool],Int)] -> [Int] - go !0 _ = [] - go !k xs = this : go (k-1) (map xtail xs) where - this = foldl' (+) 0 [ c | ((True:_) , c) <- xs ] - xtail (bs,c) = (tail bs,c) - --------------------------------------------------------------------------------- - --- | Given the cardinalities of some finite sets, we list all possible --- Venn diagrams. --- --- Note: we don't include the empty zone in the tables, because it's always empty. --- --- Remark: if each sets is a singleton set, we get back set partitions: --- --- > > [ length $ enumerateVennDiagrams $ replicate k 1 | k<-[1..8] ] --- > [1,2,5,15,52,203,877,4140] --- > --- > > [ countSetPartitions k | k<-[1..8] ] --- > [1,2,5,15,52,203,877,4140] --- --- Maybe this could be called multiset-partitions? --- --- Example: --- --- > autoTabulate RowMajor (Right 6) $ map ascii $ enumerateVennDiagrams [2,3,3] --- -enumerateVennDiagrams :: [Int] -> [VennDiagram Int] -enumerateVennDiagrams dims = - case dims of - [] -> [] - [d] -> venns1 d - (d:ds) -> concatMap (worker (length ds) d) $ enumerateVennDiagrams ds - where - - worker !n !d (VennDiagram table) = result where - - list = Map.toList table - falses = replicate n False - - comps k = compositions' (map snd list) k - result = - [ unsafeMakeVennDiagram $ - [ (False:tfs , m-c) | ((tfs,m),c) <- zip list comp ] ++ - [ (True :tfs , c) | ((tfs,m),c) <- zip list comp ] ++ - [ (True :falses , d-k) ] - | k <- [0..d] - , comp <- comps k - ] - - venns1 :: Int -> [VennDiagram Int] - venns1 p = [ theVenn ] where - theVenn = unsafeMakeVennDiagram [ ([True],p) ] - --------------------------------------------------------------------------------- - -{- - --- | for testing only -venns2 :: Int -> Int -> [Venn Int] -venns2 p q = - [ mkVenn [ ([t,f],p-k) , ([f,t],q-k) , ([t,t],k) ] - | k <- [0..min p q] - ] - where - t = True - f = False --} diff --git a/Math/Combinat/Sign.hs b/Math/Combinat/Sign.hs deleted file mode 100644 --- a/Math/Combinat/Sign.hs +++ /dev/null @@ -1,114 +0,0 @@ - --- | Signs - -{-# LANGUAGE CPP, BangPatterns #-} -module Math.Combinat.Sign where - --------------------------------------------------------------------------------- - -import Data.Monoid - --- Semigroup became a superclass of Monoid -#if MIN_VERSION_base(4,11,0) -import Data.Foldable -import Data.Semigroup -#endif - -import System.Random - --------------------------------------------------------------------------------- - -data Sign - = Plus -- hmm, this way @Plus < Minus@, not sure about that - | Minus - deriving (Eq,Ord,Show,Read) - --------------------------------------------------------------------------------- - --- Semigroup became a superclass of Monoid -#if MIN_VERSION_base(4,11,0) - -instance Semigroup Sign where - (<>) = mulSign - sconcat = foldl1 mulSign - -instance Monoid Sign where - mempty = Plus - mconcat = productOfSigns - -#else - -instance Monoid Sign where - mempty = Plus - mappend = mulSign - mconcat = productOfSigns - -#endif - --------------------------------------------------------------------------------- - -instance Random Sign where - random g = let (b,g') = random g in (if b then Plus else Minus, g') - randomR (u,v) g = let (y,g') = random g in (if u==v then u else y , g') - -isPlus, isMinus :: Sign -> Bool -isPlus s = case s of { Plus -> True ; _ -> False } -isMinus s = case s of { Minus -> True ; _ -> False } - -{-# SPECIALIZE signValue :: Sign -> Int #-} -{-# SPECIALIZE signValue :: Sign -> Integer #-} - --- | @+1@ or @-1@ -signValue :: Num a => Sign -> a -signValue s = case s of - Plus -> 1 - Minus -> -1 - -{-# SPECIALIZE signed :: Sign -> Int -> Int #-} -{-# SPECIALIZE signed :: Sign -> Integer -> Integer #-} - --- | Negate the second argument if the first is 'Minus' -signed :: Num a => Sign -> a -> a -signed s y = case s of - Plus -> y - Minus -> negate y - -{-# SPECIALIZE paritySign :: Int -> Sign #-} -{-# SPECIALIZE paritySign :: Integer -> Sign #-} - --- | 'Plus' if even, 'Minus' if odd -paritySign :: Integral a => a -> Sign -paritySign x = if even x then Plus else Minus - -{-# SPECIALIZE paritySignValue :: Int -> Integer #-} -{-# SPECIALIZE paritySignValue :: Integer -> Integer #-} - --- | @(-1)^k@ -paritySignValue :: Integral a => a -> Integer -paritySignValue k = if odd k then (-1) else 1 - -{-# SPECIALIZE negateIfOdd :: Int -> Int -> Int #-} -{-# SPECIALIZE negateIfOdd :: Int -> Integer -> Integer #-} - --- | Negate the second argument if the first is odd -negateIfOdd :: (Integral a, Num b) => a -> b -> b -negateIfOdd k y = if even k then y else negate y - -oppositeSign :: Sign -> Sign -oppositeSign s = case s of - Plus -> Minus - Minus -> Plus - -mulSign :: Sign -> Sign -> Sign -mulSign s1 s2 = case s1 of - Plus -> s2 - Minus -> oppositeSign s2 - -productOfSigns :: [Sign] -> Sign -productOfSigns = go Plus where - go !acc [] = acc - go !acc (x:xs) = case x of - Plus -> go acc xs - Minus -> go (oppositeSign acc) xs - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Tableaux.hs b/Math/Combinat/Tableaux.hs deleted file mode 100644 --- a/Math/Combinat/Tableaux.hs +++ /dev/null @@ -1,242 +0,0 @@ - --- | 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 Young 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 ] --- > ] --- - -{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} -module Math.Combinat.Tableaux where - --------------------------------------------------------------------------------- - -import Data.List - -import Math.Combinat.Classes -import Math.Combinat.Numbers ( factorial , binomial ) -import Math.Combinat.Partitions.Integer -import Math.Combinat.Partitions.Integer.IntList ( _dualPartition ) -import Math.Combinat.ASCII -import Math.Combinat.Helper - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map - --------------------------------------------------------------------------------- --- * Basic stuff - --- | A tableau is simply represented as a list of lists. -type Tableau a = [[a]] - --- | ASCII diagram of a tableau -asciiTableau :: Show a => Tableau a -> ASCII -asciiTableau t = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) - $ (map . map) asciiShow - $ t - -instance CanBeEmpty (Tableau a) where - empty = [] - isEmpty = null - -instance Show a => DrawASCII (Tableau a) where - ascii = asciiTableau - -_tableauShape :: Tableau a -> [Int] -_tableauShape t = map length t - --- | The shape of a tableau -tableauShape :: Tableau a -> Partition -tableauShape t = toPartition (_tableauShape t) - -instance HasShape (Tableau a) Partition where - shape = tableauShape - --- | Number of entries -tableauWeight :: Tableau a -> Int -tableauWeight = sum' . map length - -instance HasWeight (Tableau a) where - weight = tableauWeight - --- | The dual of the tableau is the mirror image to the main diagonal. -dualTableau :: Tableau a -> Tableau a -dualTableau = transpose - -instance HasDuality (Tableau a) where - dual = dualTableau - --- | The content of a tableau is the list of its entries. The ordering is from the left to the right and --- then from the top to the bottom -tableauContent :: Tableau a -> [a] -tableauContent = concat - --- | An element @(i,j)@ of the resulting tableau (which has shape of the --- given partition) means that the vertical part of the hook has length @i@, --- and the horizontal part @j@. The /hook length/ is thus @i+j-1@. --- --- Example: --- --- > > mapM_ print $ hooks $ toPartition [5,4,1] --- > [(3,5),(2,4),(2,3),(2,2),(1,1)] --- > [(2,4),(1,3),(1,2),(1,1)] --- > [(1,1)] --- -hooks :: Partition -> Tableau (Int,Int) -hooks part = zipWith f p [1..] where - p = fromPartition part - q = _dualPartition p - f l i = zipWith (\x y -> (x-i+1,y)) q [l,l-1..1] - -hookLengths :: Partition -> Tableau Int -hookLengths part = (map . map) (\(i,j) -> i+j-1) (hooks part) - --------------------------------------------------------------------------------- --- * Row and column words - --- | The /row word/ of a tableau is the list of its entry read from the right to the left and then --- from the top to the bottom. -rowWord :: Tableau a -> [a] -rowWord = concat . reverse - --- | /Semistandard/ tableaux can be reconstructed from their row words -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 - --- | The /column word/ of a tableau is the list of its entry read from the bottom to the top and then from the left to the right -columnWord :: Tableau a -> [a] -columnWord = rowWord . transpose - --- | /Standard/ tableaux can be reconstructed from either their column or row words -columnWordToTableau :: Ord a => [a] -> Tableau a -columnWordToTableau = transpose . rowWordToTableau - --- | Checks whether a sequence of positive integers is a /lattice word/, --- which means that in every initial part of the sequence any number @i@ --- occurs at least as often as the number @i+1@ --- -isLatticeWord :: [Int] -> Bool -isLatticeWord = go Map.empty where - go :: Map Int Int -> [Int] -> Bool - go _ [] = True - go !table (i:is) = - if check i - then go table' is - else False - where - table' = Map.insertWith (+) i 1 table - check j = j==1 || cnt (j-1) >= cnt j - cnt j = case Map.lookup j table' of - Just k -> k - Nothing -> 0 - --------------------------------------------------------------------------------- --- * Semistandard Young tableaux - --- | A tableau is /semistandard/ if its entries are weekly increasing horizontally --- and strictly increasing vertically -isSemiStandardTableau :: Tableau Int -> Bool -isSemiStandardTableau t = weak && strict where - weak = and [ isWeaklyIncreasing xs | xs <- t ] - strict = and [ isStrictlyIncreasing ys | ys <- dt ] - dt = dualTableau t - --- | Semistandard Young tableaux of given shape, \"naive\" algorithm -semiStandardYoungTableaux :: Int -> Partition -> [Tableau Int] -semiStandardYoungTableaux n part = worker (repeat 0) shape where - shape = fromPartition part - worker _ [] = [[]] - worker prevRow (s:ss) - = [ (r:rs) | r <- row n s 1 prevRow, rs <- worker (map (+1) r) ss ] - - -- weekly increasing lists of length @len@, pointwise at least @xs@, - -- maximum value @n@, minimum value @prev@. - row :: Int -> Int -> Int -> [Int] -> [[Int]] - row _ 0 _ _ = [[]] - row n len prev (x:xs) = [ (a:as) | a <- [max x prev..n] , as <- row n (len-1) a xs ] - --- | Stanley's hook formula (cf. Fulton page 55) -countSemiStandardYoungTableaux :: Int -> Partition -> Integer -countSemiStandardYoungTableaux n shape = k `div` h where - h = product $ map fromIntegral $ concat $ hookLengths shape - k = product [ fromIntegral (n+j-i) | (i,j) <- elements shape ] - - --------------------------------------------------------------------------------- --- * Standard Young tableaux - --- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@, --- where @n@ is the weight. -isStandardTableau :: Tableau Int -> Bool -isStandardTableau t = isSemiStandardTableau t && sort (concat t) == [1..n] where - n = sum [ length xs | xs <- t ] - --- | 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 (hookLengths part) $ -} - factorial n `div` h where - h = product $ map fromIntegral $ concat $ hookLengths part - n = weight part - --------------------------------------------------------------------------------- - - diff --git a/Math/Combinat/Tableaux/GelfandTsetlin.hs b/Math/Combinat/Tableaux/GelfandTsetlin.hs deleted file mode 100644 --- a/Math/Combinat/Tableaux/GelfandTsetlin.hs +++ /dev/null @@ -1,341 +0,0 @@ - --- | Gelfand-Tsetlin patterns and Kostka numbers. --- --- Gelfand-Tsetlin patterns (or tableaux) are triangular arrays like --- --- > [ 3 ] --- > [ 3 , 2 ] --- > [ 3 , 1 , 0 ] --- > [ 2 , 0 , 0 , 0 ] --- --- with both rows and columns non-increasing non-negative integers. --- Note: these are in bijection with the semi-standard Young tableaux. --- --- If we add the further restriction that --- the top diagonal reads @lambda@, --- and the diagonal sums are partial sums of @mu@, where @lambda@ and @mu@ are two --- partitions (in this case @lambda=[3,2]@ and @mu=[2,1,1,1]@), --- then the number of the resulting patterns --- or tableaux is the Kostka number @K(lambda,mu)@. --- Actually @mu@ doesn't even need to the be non-increasing. --- - -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -module Math.Combinat.Tableaux.GelfandTsetlin where - --------------------------------------------------------------------------------- - -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Ord - -import Control.Monad -import Control.Monad.Trans.State - -import Data.Map (Map) -import qualified Data.Map as Map - -import Math.Combinat.Partitions.Integer -import Math.Combinat.Tableaux -import Math.Combinat.Helper -import Math.Combinat.ASCII - --------------------------------------------------------------------------------- --- * Kostka numbers - --- | Kostka numbers (via counting Gelfand-Tsetlin patterns). See for example --- --- @K(lambda,mu)==0@ unless @lambda@ dominates @mu@: --- --- > [ mu | mu <- partitions (weight lam) , kostkaNumber lam mu > 0 ] == dominatedPartitions lam --- -kostkaNumber :: Partition -> Partition -> Int -kostkaNumber = countKostkaGelfandTsetlinPatterns - --- | Very naive (and slow) implementation of Kostka numbers, for reference. -kostkaNumberReferenceNaive :: Partition -> Partition -> Int -kostkaNumberReferenceNaive plambda pmu@(Partition mu) = length stuff where - stuff = [ (1::Int) | t <- semiStandardYoungTableaux k plambda , cond t ] - k = length mu - cond t = [ (head xs, length xs) | xs <- group (sort $ concat t) ] == zip [1..] mu - --------------------------------------------------------------------------------- - --- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @lambda@: --- --- > kostkaNumbersWithGivenLambda lambda == Map.fromList [ (mu , kostkaNumber lambda mu) | mu <- dominatedPartitions lambda ] --- --- It's much faster than computing the individual Kostka numbers, but not as fast --- as it could be. --- -{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Int #-} -{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Integer #-} -kostkaNumbersWithGivenLambda :: forall coeff. Num coeff => Partition -> Map Partition coeff -kostkaNumbersWithGivenLambda plambda@(Partition lam) = evalState (worker lam) Map.empty where - - worker :: [Int] -> State (Map Partition (Map Partition coeff)) (Map Partition coeff) - worker unlam = case unlam of - [] -> return $ Map.singleton (Partition []) 1 - _ -> do - cache <- get - case Map.lookup (Partition unlam) cache of - Just sol -> return sol - Nothing -> do - let s = foldl' (+) 0 unlam - subsols <- forM (prevLambdas0 unlam) $ \p -> do - sub <- worker p - let t = s - foldl' (+) 0 p - f (Partition xs , c) = case xs of - (y:_) -> if t >= y then Just (Partition (t:xs) , c) else Nothing - [] -> if t > 0 then Just (Partition [t] , c) else Nothing - if t > 0 - then return $ Map.fromList $ mapMaybe f $ Map.toList sub - else return $ Map.empty - - let sol = Map.unionsWith (+) subsols - put $! (Map.insert (Partition unlam) sol cache) - return sol - - -- needs decreasing sequence - prevLambdas0 :: [Int] -> [[Int]] - prevLambdas0 (l:ls) = go l ls where - go b [a] = [ [x] | x <- [a..b] ] ++ [ [x,y] | x <- [a..b] , y<-[1..a] ] - go b (a:as) = [ x:xs | x <- [a..b] , xs <- go a as ] - go b [] = [] : [ [j] | j <- [1..b] ] - prevLambdas0 [] = [] - --- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @mu@: --- --- > kostkaNumbersWithGivenMu mu == Map.fromList [ (lambda , kostkaNumber lambda mu) | lambda <- dominatingPartitions mu ] --- --- This function uses the iterated Pieri rule, and is relatively fast. --- -kostkaNumbersWithGivenMu :: Partition -> Map Partition Int -kostkaNumbersWithGivenMu (Partition mu) = iteratedPieriRule (reverse mu) - --------------------------------------------------------------------------------- --- * Gelfand-Tsetlin patterns - --- | A Gelfand-Tstetlin tableau -type GT = [[Int]] - -asciiGT :: GT -> ASCII -asciiGT gt = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) - $ (map . map) asciiShow - $ gt - -kostkaGelfandTsetlinPatterns :: Partition -> Partition -> [GT] -kostkaGelfandTsetlinPatterns lambda (Partition mu) = kostkaGelfandTsetlinPatterns' lambda mu - --- | Generates all Kostka-Gelfand-Tsetlin tableau, that is, triangular arrays like --- --- > [ 3 ] --- > [ 3 , 2 ] --- > [ 3 , 1 , 0 ] --- > [ 2 , 0 , 0 , 0 ] --- --- with both rows and column non-increasing such that --- the top diagonal read lambda (in this case @lambda=[3,2]@) and the diagonal sums --- are partial sums of mu (in this case @mu=[2,1,1,1]@) --- --- The number of such GT tableaux is the Kostka --- number K(lambda,mu). --- -kostkaGelfandTsetlinPatterns' :: Partition -> [Int] -> [GT] -kostkaGelfandTsetlinPatterns' plam@(Partition lambda0) mu0 - | minimum mu0 < 0 = [] - | wlam == 0 = if wmu == 0 then [ [] ] else [] - | wmu == wlam && plam `dominates` pmu = list - | otherwise = [] - where - - pmu = mkPartition mu0 - - nlam = length lambda0 - nmu = length mu0 - - n = max nlam nmu - - lambda = lambda0 ++ replicate (n - nlam) 0 - mu = mu0 ++ replicate (n - nmu ) 0 - - revlam = reverse lambda - - wmu = sum' mu - wlam = sum' lambda - - list = worker - revlam - (scanl1 (+) mu) - (replicate (n-1) 0) - (replicate (n ) 0) - [] - - worker - :: [Int] -- lambda_i in reverse order - -> [Int] -- partial sums of mu - -> [Int] -- sums of the tails of previous rows - -> [Int] -- last row - -> [[Int]] -- the lower part of GT tableau we accumulated so far (this is not needed if we only want to count) - -> [GT] - - worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) table = stuff - where - x0 = smu - a - stuff = concat - [ worker rls smus (zipWith (+) acc (tail row)) (init row) (row:table) - | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda - ] - worker [rl] _ _ _ table = [ [rl]:table ] - worker [] _ _ _ _ = [ [] ] - - boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] - boundedNonIncrSeqs' = go where - go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] - go _ [] _ = [[]] - go _ _ [] = [[]] - --------------------------------------------------------------------------------- - --- | This returns the corresponding Kostka number: --- --- > countKostkaGelfandTsetlinPatterns lambda mu == length (kostkaGelfandTsetlinPatterns lambda mu) --- -countKostkaGelfandTsetlinPatterns :: Partition -> Partition -> Int -countKostkaGelfandTsetlinPatterns plam@(Partition lambda0) pmu@(Partition mu0) - | wlam == 0 = if wmu == 0 then 1 else 0 - | wmu == wlam && plam `dominates` pmu = cnt - | otherwise = 0 - where - - nlam = length lambda0 - nmu = length mu0 - - n = max nlam nmu - - lambda = lambda0 ++ replicate (n - nlam) 0 - mu = mu0 ++ replicate (n - nmu ) 0 - - revlam = reverse lambda - - wmu = sum' mu - wlam = sum' lambda - - cnt = worker - revlam - (scanl1 (+) mu) - (replicate (n-1) 0) - (replicate (n ) 0) - - worker - :: [Int] -- lambda_i in reverse order - -> [Int] -- partial sums of mu - -> [Int] -- sums of the tails of previous rows - -> [Int] -- last row - -> Int - - worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) = stuff - where - x0 = smu - a - stuff = sum' - [ worker rls smus (zipWith (+) acc (tail row)) (init row) - | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda - ] - worker [rl] _ _ _ = 1 - worker [] _ _ _ = 1 - - boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] - boundedNonIncrSeqs' = go where - go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] - go _ [] _ = [[]] - go _ _ [] = [[]] - --------------------------------------------------------------------------------- - -{- - --- | All non-increasing sentences between a lower and an upper bound -boundedNonIncrSeqs :: [Int] -> [Int] -> [[Int]] -boundedNonIncrSeqs as bs = case bs of - (h0:_) -> boundedNonIncrSeqs' h0 as bs - [] -> [[]] - --- | All non-increasing sentences between a lower and an upper bound, and also less-or-equal than the given number -boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] -boundedNonIncrSeqs' = go where - go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] - go _ [] _ = [[]] - go _ _ [] = [[]] - --- | All non-decreasing sentences between a lower and an upper bound -boundedNonDecrSeqs :: [Int] -> [Int] -> [[Int]] -boundedNonDecrSeqs = boundedNonDecrSeqs' 0 - --- | All non-decreasing sentences between a lower and an upper bound, and also greator-or-equal then the given number -boundedNonDecrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] -boundedNonDecrSeqs' h0 = go (max 0 h0) where - go h0 (a:as) (b:bs) = [ h:hs | h <- [(max h0 a)..b] , hs <- go h as bs ] - go _ [] _ = [[]] - go _ _ [] = [[]] - --} - --------------------------------------------------------------------------------- --- * The iterated Pieri rule - --- | Computes the Schur expansion of @h[n1]*h[n2]*h[n3]*...*h[nk]@ via iterating the Pieri rule. --- Note: the coefficients are actually the Kostka numbers; the following is true: --- --- > Map.toList (iteratedPieriRule (fromPartition mu)) == [ (lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ] --- --- This should be faster than individually computing all these Kostka numbers. --- -iteratedPieriRule :: Num coeff => [Int] -> Map Partition coeff -iteratedPieriRule = iteratedPieriRule' (Partition []) - --- | Iterating the Pieri rule, we can compute the Schur expansion of --- @h[lambda]*h[n1]*h[n2]*h[n3]*...*h[nk]@ -iteratedPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff -iteratedPieriRule' plambda ns = iteratedPieriRule'' (plambda,1) ns - -{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Int ) -> [Int] -> Map Partition Int #-} -{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-} -iteratedPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff -iteratedPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where - worker old [] = old - worker old (n:ns) = worker new ns where - stuff = [ (coeff, pieriRule lam n) | (lam,coeff) <- Map.toList old ] - new = foldl' f Map.empty stuff - f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps - --------------------------------------------------------------------------------- - --- | Computes the Schur expansion of @e[n1]*e[n2]*e[n3]*...*e[nk]@ via iterating the Pieri rule. --- Note: the coefficients are actually the Kostka numbers; the following is true: --- --- > Map.toList (iteratedDualPieriRule (fromPartition mu)) == --- > [ (dualPartition lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ] --- --- This should be faster than individually computing all these Kostka numbers. --- It is a tiny bit slower than 'iteratedPieriRule'. --- -iteratedDualPieriRule :: Num coeff => [Int] -> Map Partition coeff -iteratedDualPieriRule = iteratedDualPieriRule' (Partition []) - --- | Iterating the Pieri rule, we can compute the Schur expansion of --- @e[lambda]*e[n1]*e[n2]*e[n3]*...*e[nk]@ -iteratedDualPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff -iteratedDualPieriRule' plambda ns = iteratedDualPieriRule'' (plambda,1) ns - -{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Int ) -> [Int] -> Map Partition Int #-} -{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-} -iteratedDualPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff -iteratedDualPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where - worker old [] = old - worker old (n:ns) = worker new ns where - stuff = [ (coeff, dualPieriRule lam n) | (lam,coeff) <- Map.toList old ] - new = foldl' f Map.empty stuff - f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs b/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs deleted file mode 100644 --- a/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs +++ /dev/null @@ -1,261 +0,0 @@ - --- TODO: better name? - --- | This module contains a function to generate (equivalence classes of) --- triangular tableaux of size /k/, strictly increasing to the right and --- to the bottom. For example --- --- > 1 --- > 2 4 --- > 3 5 8 --- > 6 7 9 10 --- --- is such a tableau of size 4. --- The numbers filling a tableau always consist of an interval @[1..c]@; --- @c@ is called the /content/ of the tableaux. There is a unique tableau --- of minimal content @2k-1@: --- --- > 1 --- > 2 3 --- > 3 4 5 --- > 4 5 6 7 --- --- Let us call the tableaux with maximal content (that is, @m = binomial (k+1) 2@) --- /standard/. The number of such standard tableaux are --- --- > 1, 1, 2, 12, 286, 33592, 23178480, ... --- --- OEIS:A003121, \"Strict sense ballot numbers\", --- . --- --- See --- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88. --- --- The number of tableaux with content @c=m-d@ are --- --- > d= | 0 1 2 3 ... --- > -----+---------------------------------------------- --- > k=2 | 1 --- > k=3 | 2 1 --- > k=4 | 12 18 8 1 --- > k=5 | 286 858 1001 572 165 22 1 --- > k=6 | 33592 167960 361114 436696 326196 155584 47320 8892 962 52 1 --- --- We call these \"GT simplex tableaux\" (in the lack of a better name), since --- they are in bijection with the simplicial cones in a canonical simplicial --- decompositions of the Gelfand-Tsetlin cones (the content corresponds --- to the dimension), which encode the combinatorics of Kostka numbers. --- - -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -module Math.Combinat.Tableaux.GelfandTsetlin.Cone - ( - -- * Types - Tableau - , Tri(..) - , TriangularArray - , fromTriangularArray - , triangularArrayUnsafe - -- * ASCII - , asciiTriangularArray - , asciiTableau - -- * Content - , gtSimplexContent - , _gtSimplexContent - , invertGTSimplexTableau - , _invertGTSimplexTableau - -- * Enumeration - , gtSimplexTableaux - , _gtSimplexTableaux - , countGTSimplexTableaux - ) - where - --------------------------------------------------------------------------------- - -import Data.Ix -import Data.Ord -import Data.List - -import Control.Monad -import Control.Monad.ST -import Data.Array.IArray -import Data.Array.Unboxed -import Data.Array.ST - -import Math.Combinat.Tableaux (Tableau) -import Math.Combinat.Helper -import Math.Combinat.ASCII - --------------------------------------------------------------------------------- - --- | Triangular arrays -type TriangularArray a = Array Tri a - --- | Set of @(i,j)@ pairs with @i>=j>=1@. -newtype Tri = Tri { unTri :: (Int,Int) } deriving (Eq,Ord,Show) - -binom2 :: Int -> Int -binom2 n = (n*(n-1)) `div` 2 - -index' :: Tri -> Int -index' (Tri (i,j)) = binom2 i + j - 1 - --- it should be (1+8*m), --- the 2 is a hack to be safe with the floating point stuff -deIndex' :: Int -> Tri -deIndex' m = Tri ( i+1 , m - binom2 (i+1) + 1 ) where - i = ( (floor.sqrt.(fromIntegral::Int->Double)) (2+8*m) - 1 ) `div` 2 - -instance Ix Tri where - index (a,b) x = index' x - index' a - inRange (a,b) x = (u<=j && j<=v) where - u = index' a - v = index' b - j = index' x - range (a,b) = map deIndex' [ index' a .. index' b ] - rangeSize (a,b) = index' b - index' a + 1 - -triangularArrayUnsafe :: Tableau a -> TriangularArray a -triangularArrayUnsafe tableau = listArray (Tri (1,1),Tri (k,k)) (concat tableau) - where k = length tableau - -fromTriangularArray :: TriangularArray a -> Tableau a -fromTriangularArray arr = (map.map) snd $ groupBy (equating f) $ assocs arr - where f = fst . unTri . fst - --------------------------------------------------------------------------------- - -asciiTriangularArray :: Show a => TriangularArray a -> ASCII -asciiTriangularArray = asciiTableau . fromTriangularArray - -asciiTableau :: Show a => Tableau a -> ASCII -asciiTableau xxs = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) - $ (map . map) asciiShow - $ xxs - -instance Show a => DrawASCII (TriangularArray a) where - ascii = asciiTriangularArray - --- instance Show a => DrawASCII (Tableau a) where --- ascii = asciiTableau - --------------------------------------------------------------------------------- - --- "fractional fillings" -data Hole = Hole Int Int deriving (Eq,Ord,Show) - -type ReverseTableau = [[Int ]] -type ReverseHoleTableau = [[Hole]] - -toHole :: Int -> Hole -toHole k = Hole k 0 - -nextHole :: Hole -> Hole -nextHole (Hole k l) = Hole k (l+1) - -reverseTableau :: [[a]] -> [[a]] -reverseTableau = reverse . map reverse - --------------------------------------------------------------------------------- - -gtSimplexContent :: TriangularArray Int -> Int -gtSimplexContent arr = max (arr ! (fst (bounds arr))) (arr ! (snd (bounds arr))) -- we also handle inverted tableau - -_gtSimplexContent :: Tableau Int -> Int -_gtSimplexContent t = max (head $ head t) (last $ last t) -- we also handle inverted tableau - -normalize :: ReverseHoleTableau -> TriangularArray Int -normalize = snd . normalize' - --- returns ( content , tableau ) -normalize' :: ReverseHoleTableau -> ( Int , TriangularArray Int ) -normalize' holes = ( c , array (Tri (1,1), Tri (k,k)) xys ) where - k = length holes - c = length sorted - xys = concat $ zipWith hs [1..] sorted - hs a xs = map (h a) xs - h a (ij,_) = (Tri ij , a) - sorted = groupSortBy snd (concat withPos) - withPos = zipWith f [1..] (reverseTableau holes) - f i xs = zipWith (g i) [1..] xs - g i j hole = ((i,j),hole) - --------------------------------------------------------------------------------- - -startHole :: [Hole] -> [Int] -> Hole -startHole (t:ts) (p:ps) = max t (toHole p) -startHole (t:ts) [] = t -startHole [] (p:ps) = toHole p -startHole [] [] = error "startHole" - --- c is the "content" of the small tableau -enumHoles :: Int -> Hole -> [Hole] -enumHoles c start@(Hole k l) - = nextHole start - : [ Hole i 0 | i <- [k+1..c] ] ++ [ Hole i 1 | i <- [k+1..c] ] - -helper :: Int -> [Int] -> [Hole] -> [[Hole]] -helper c [] this = [[]] -helper c prev@(p:ps) this = - [ t:rest | t <- enumHoles c (startHole this prev), rest <- helper c ps (t:this) ] - -newLines' :: Int -> [Int] -> [[Hole]] -newLines' c lastReversed = helper c last [] - where - top = head lastReversed - last = reverse (top : lastReversed) - -newLines :: [Int] -> [[Hole]] -newLines lastReversed = newLines' (head lastReversed) lastReversed - --- | Generates all tableaux of size @k@. Effective for @k<=6@. -gtSimplexTableaux :: Int -> [TriangularArray Int] -gtSimplexTableaux 0 = [ triangularArrayUnsafe [] ] -gtSimplexTableaux 1 = [ triangularArrayUnsafe [[1]] ] -gtSimplexTableaux k = map normalize $ concatMap f smalls where - smalls :: [ [[Int]] ] - smalls = map (reverseTableau . fromTriangularArray) $ gtSimplexTableaux (k-1) - f :: [[Int]] -> [ [[Hole]] ] - f small = map (:smallhole) $ map reverse $ newLines (head small) where - smallhole = map (map toHole) small - -_gtSimplexTableaux :: Int -> [Tableau Int] -_gtSimplexTableaux k = map fromTriangularArray $ gtSimplexTableaux k - --------------------------------------------------------------------------------- - --- | Note: This is slow (it actually generates all the tableaux) -countGTSimplexTableaux :: Int -> [Int] -countGTSimplexTableaux = elems . sizes' - -sizes' :: Int -> UArray Int Int -sizes' k = - runSTUArray $ do - let (a,b) = ( 2*k-1 , binom2 (k+1) ) - ar <- newArray (a,b) 0 :: ST s (STUArray s Int Int) - mapM_ (worker ar) $ gtSimplexTableaux k - return ar - where - worker :: STUArray s Int Int -> TriangularArray Int -> ST s () - worker ar t = do - let c = gtSimplexContent t - n <- readArray ar c - writeArray ar c (n+1) - --------------------------------------------------------------------------------- - --- | We can flip the numbers in the tableau so that the interval @[1..c]@ becomes --- @[c..1]@. This way we a get a maybe more familiar form, when each row and each --- column is strictly /decreasing/ (to the right and to the bottom). -invertGTSimplexTableau :: TriangularArray Int -> TriangularArray Int -invertGTSimplexTableau t = amap f t where - c = gtSimplexContent t - f x = c+1-x - -_invertGTSimplexTableau :: [[Int]] -> [[Int]] -_invertGTSimplexTableau t = (map . map) f t where - c = _gtSimplexContent t - f x = c+1-x - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Tableaux/LittlewoodRichardson.hs b/Math/Combinat/Tableaux/LittlewoodRichardson.hs deleted file mode 100644 --- a/Math/Combinat/Tableaux/LittlewoodRichardson.hs +++ /dev/null @@ -1,399 +0,0 @@ - --- | The Littlewood-Richardson rule - -module Math.Combinat.Tableaux.LittlewoodRichardson - ( lrCoeff , lrCoeff' - , lrMult - , lrRule , _lrRule , lrRuleNaive - , lrScalar , _lrScalar - ) - where - --------------------------------------------------------------------------------- - -import Data.List -import Data.Maybe - -import Math.Combinat.Partitions.Integer -import Math.Combinat.Partitions.Skew -import Math.Combinat.Tableaux -import Math.Combinat.Tableaux.Skew -import Math.Combinat.Helper - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map - --------------------------------------------------------------------------------- - --- | Naive (very slow) reference implementation of the Littlewood-Richardson rule, based --- on the definition "count the semistandard skew tableaux whose row content is a lattice word" --- -lrRuleNaive :: SkewPartition -> Map Partition Int -lrRuleNaive skew = final where - n = skewPartitionWeight skew - ssst = semiStandardSkewTableaux n skew - final = foldl' f Map.empty $ catMaybes [ skewTableauRowContent skew | skew <- ssst ] - f old nu = Map.insertWith (+) nu 1 old - --------------------------------------------------------------------------------- --- SKEW EXPANSION - --- | @lrRule@ computes the expansion of a skew Schur function --- @s[lambda\/mu]@ via the Littlewood-Richardson rule. --- --- Adapted from John Stembridge's Maple code: --- --- --- > lrRule (mkSkewPartition (lambda,nu)) == Map.fromList list where --- > muw = weight lambda - weight nu --- > list = [ (mu, coeff) --- > | mu <- partitions muw --- > , let coeff = lrCoeff lambda (mu,nu) --- > , coeff /= 0 --- > ] --- -lrRule :: SkewPartition -> Map Partition Int -lrRule skew = _lrRule lam mu where - (lam,mu) = fromSkewPartition skew - --- | @_lrRule lambda mu@ computes the expansion of the skew --- Schur function @s[lambda\/mu]@ via the Littlewood-Richardson rule. --- -_lrRule :: Partition -> Partition -> Map Partition Int -_lrRule plam@(Partition lam) pmu@(Partition mu0) = - if not (pmu `isSubPartitionOf` plam) - then Map.empty - else foldl' f Map.empty [ nu | (nu,_) <- fillings n diagram ] - where - f old nu = Map.insertWith (+) (Partition nu) 1 old - diagram = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ] - mu = mu0 ++ repeat 0 - n = sum' $ zipWith (-) lam mu -- n == length diagram - -{- -LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm; - if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi; - l:=nops(lambda); mu:=[op(args[2]),0$l]; - dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)]; - if nargs>2 then alpha:=args[3]; - if nargs>3 then beta:=args[4] else beta:=[] fi; - if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi; - l:=convert([op(lambda),op(beta)],`+`); - if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi; - nops(LR_fillings(dgrm,[alpha,beta])) - else - convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`) - fi -end; --} - --------------------------------------------------------------------------------- - --- | A filling is a pair consisting a shape @nu@ and a lattice permutation @lp@ -type Filling = ( [Int] , [Int] ) - --- | A diagram is a set of boxes in a skew shape (in the right order) -type Diagram = [ (Int,Int) ] - --- | Note: we use reverse ordering in Diagrams compared the Stembridge's code. --- Also, for performance reasons, we need the length of the diagram -fillings :: Int -> Diagram -> [Filling] -fillings _ [] = [ ([],[]) ] -fillings n diagram@((x,y):rest) = concatMap (nextLetter lower upper) (fillings (n-1) rest) where - upper = case findIndex (==(x ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 } - lower = case findIndex (==(x-1,y )) diagram of { Just j -> n-j ; Nothing -> 0 } - -{- -LR_fillings:=proc(dgrm) local n,x,upper,lower; - if dgrm=[] then - if nargs=1 then x:=[] else x:=args[2][2] fi; - RETURN([[x,[]]]) - fi; - n:=nops(dgrm); x:=dgrm[n]; - if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi; - if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi; - if nargs=1 then - map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper) - else - map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]), - lower,upper,args[2][1]) - fi; -end: --} - --------------------------------------------------------------------------------- - -nextLetter :: Int -> Int -> Filling -> [Filling] -nextLetter lower upper (nu,lpart) = stuff where - stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] - shape = nu ++ [0] - lb = if lower>0 - then lpart !! (lower-1) - else 0 - ub = if upper>0 - then min (length shape) (lpart !! (upper-1)) - else length shape - - nlist = filter (>0) $ map f [lb+1..ub] - f j = if j==1 || shape!!(j-2) > shape!!(j-1) then j else 0 - -{- - -- another nlist implementation, but doesn't seem to be faster - (h0:hs0) = drop lb (-666:shape) - nlist = go h0 hs0 [lb+1..ub] where - go !lasth (h:hs) (j:js) = if j==1 || lasth > h - then j : go h hs js - else go h hs js - go _ _ [] = [] --} - - -- increments the i-th element (starting from 1) - incr :: Int -> [Int] -> [Int] - incr i (x:xs) = case i of - 0 -> finish (x:xs) - 1 -> (x+1) : finish xs - _ -> x : incr (i-1) xs - incr _ [] = [] - - -- removes tailing zeros - finish :: [Int] -> [Int] - finish (x:xs) = if x>0 then x : finish xs else [] - finish [] = [] - -{- -`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl; - shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape); - if nargs>3 then ub:=min(ub,nops(args[4])) fi; - if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi; - if args[3]>0 then ub:=min(lp[args[3]],ub) fi; - if nargs<4 then - nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape) - else - nl:=map(proc(x,y,z) if y[x]y[x]) then x fi end, - [$lb+1..ub],shape,args[4]) - fi; - nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)]; - op(subs(0=NULL,nl)) -end: --} - --------------------------------------------------------------------------------- --- COEFF - --- | @lrCoeff lam (mu,nu)@ computes the coressponding Littlewood-Richardson coefficients. --- This is also the coefficient of @s[lambda]@ in the product @s[mu]*s[nu]@ --- --- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients --- at the same time! -lrCoeff :: Partition -> (Partition,Partition) -> Int -lrCoeff lam (mu,nu) = - if nu `isSubPartitionOf` lam - then lrScalar (mkSkewPartition (lam,nu)) (mkSkewPartition (mu,emptyPartition)) - else 0 - --- | @lrCoeff (lam\/nu) mu@ computes the coressponding Littlewood-Richardson coefficients. --- This is also the coefficient of @s[mu]@ in the product @s[lam\/nu]@ --- --- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients --- at the same time! -lrCoeff' :: SkewPartition -> Partition -> Int -lrCoeff' skew p = lrScalar skew (mkSkewPartition (p,emptyPartition)) - --------------------------------------------------------------------------------- --- SCALAR PRODUCT - --- | @lrScalar (lambda\/mu) (alpha\/beta)@ computes the scalar product of the two skew --- Schur functions @s[lambda\/mu]@ and @s[alpha\/beta]@ via the Littlewood-Richardson rule. --- --- Adapted from John Stembridge Maple code: --- --- -lrScalar :: SkewPartition -> SkewPartition -> Int -lrScalar lambdaMu alphaBeta = _lrScalar (fromSkewPartition lambdaMu) (fromSkewPartition alphaBeta) - -_lrScalar :: (Partition,Partition) -> (Partition,Partition) -> Int -_lrScalar ( plam@( Partition lam ) , pmu@( Partition mu0 ) ) - ( palpha@(Partition alpha) , pbeta@(Partition beta) ) = - if not (pmu `isSubPartitionOf` plam ) - || not (pbeta `isSubPartitionOf` palpha) - || (sum' lam + sum' beta) /= (sum' alpha + sum' mu0) -- equivalent to (lambda-mu) /= (alpha-beta) - then 0 - else length $ fillings' n diagram (alpha,beta) - where - f old nu = Map.insertWith (+) (Partition nu) 1 old - diagram = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ] - mu = mu0 ++ repeat 0 - n = sum' $ zipWith (-) lam mu -- n == length diagram - -{- -LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm; - if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi; - l:=nops(lambda); mu:=[op(args[2]),0$l]; - dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)]; - if nargs>2 then alpha:=args[3]; - if nargs>3 then beta:=args[4] else beta:=[] fi; - if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi; - l:=convert([op(lambda),op(beta)],`+`); - if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi; - nops(LR_fillings(dgrm,[alpha,beta])) - else - convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`) - fi -end; --} - --------------------------------------------------------------------------------- - --- | Note: we use reverse ordering in Diagrams compared the Stembridge's code. --- Also, for performance reasons, we need the length of the diagram -fillings' :: Int -> Diagram -> ([Int],[Int]) -> [Filling] -fillings' _ [] (alpha,beta) = [ (beta,[]) ] -fillings' n diagram@((x,y):rest) alphaBeta@(alpha,beta) = stuff where - stuff = concatMap (nextLetter' lower upper alpha) (fillings' (n-1) rest alphaBeta) - upper = case findIndex (==(x ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 } - lower = case findIndex (==(x-1,y )) diagram of { Just j -> n-j ; Nothing -> 0 } - -{- -LR_fillings:=proc(dgrm) local n,x,upper,lower; - if dgrm=[] then - if nargs=1 then x:=[] else x:=args[2][2] fi; - RETURN([[x,[]]]) - fi; - n:=nops(dgrm); x:=dgrm[n]; - if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi; - if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi; - if nargs=1 then - map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper) - else - map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]), - lower,upper,args[2][1]) - fi; -end: --} - --------------------------------------------------------------------------------- - -nextLetter' :: Int -> Int -> [Int] -> Filling -> [Filling] -nextLetter' lower upper alpha (nu,lpart) = stuff where - stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] - shape = nu ++ [0] - lb = if lower>0 - then lpart !! (lower-1) - else 0 - ub1 = if upper>0 - then min (length shape) (lpart !! (upper-1)) - else length shape - ub = min (length alpha) ub1 - nlist = filter (>0) $ map f [lb+1..ub] - f j = if ( shape!!(j-1) < alpha!!(j-1)) && - (j==1 || shape!!(j-2) > shape!!(j-1)) - then j - else 0 - - -- increments the i-th element (starting from 1) - incr :: Int -> [Int] -> [Int] - incr i (x:xs) = case i of - 0 -> finish (x:xs) - 1 -> (x+1) : finish xs - _ -> x : incr (i-1) xs - incr _ [] = [] - - -- removes tailing zeros - finish :: [Int] -> [Int] - finish (x:xs) = if x>0 then x : finish xs else [] - finish [] = [] - -{- -`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl; - shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape); - if nargs>3 then ub:=min(ub,nops(args[4])) fi; - if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi; - if args[3]>0 then ub:=min(lp[args[3]],ub) fi; - if nargs<4 then - nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape) - else - nl:=map(proc(x,y,z) if y[x]y[x]) then x fi end, - [$lb+1..ub],shape,args[4]) - fi; - nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)]; - op(subs(0=NULL,nl)) -end: --} - --------------------------------------------------------------------------------- --- MULTIPLICATION - -type Part = [Int] - --- | Computes the expansion of the product of Schur polynomials @s[mu]*s[nu]@ using the --- Littlewood-Richardson rule. Note: this is symmetric in the two arguments. --- --- Based on the wikipedia article --- --- > lrMult mu nu == Map.fromList list where --- > lamw = weight nu + weight mu --- > list = [ (lambda, coeff) --- > | lambda <- partitions lamw --- > , let coeff = lrCoeff lambda (mu,nu) --- > , coeff /= 0 --- > ] --- -lrMult :: Partition -> Partition -> Map Partition Int -lrMult pmu@(Partition mu) pnu@(Partition nu) = result where - result = foldl' add Map.empty (addMu mu nu) where - add !old lambda = Map.insertWith (+) (Partition lambda) 1 old - --- | This basically lists all the outer shapes (with multiplicities) which can be result from the LR rule -addMu :: Part -> Part -> [Part] -addMu mu part = go ubs0 mu dmu part where - - go _ [] _ part = [part] - go ubs (m:ms) (d:ds) part = concat [ go (drop d ubs') ms ds part' | (ubs',part') <- addRowOf ubs part ] - - ubs0 = take (headOrZero mu) [headOrZero part + 1..] - dmu = diffSeq mu - - --- | Adds a full row of @(length pcols)@ boxes containing to a partition, with --- pcols being the upper bounds of the columns, respectively. We also return the --- newly added columns -addRowOf :: [Int] -> Part -> [([Int],Part)] -addRowOf pcols part = go 0 pcols part [] where - go !lb [] p ncols = [(reverse ncols , p)] - go !lb (!ub:ubs) p ncols = concat [ go col ubs (addBox ij p) (col:ncols) | ij@(row,col) <- newBoxes (lb+1) ub p ] - --- | Returns the (row,column) pairs of the new boxes which --- can be added to the given partition with the given column bounds --- and the 1-Rieri rule -newBoxes :: Int -> Int -> Part -> [(Int,Int)] -newBoxes lb ub part = reverse $ go [1..] part (headOrZero part + 1) where - go (!i:_ ) [] !lp - | lb <= 1 && 1 <= ub && lp > 0 = [(i,1)] - | otherwise = [] - go (!i:is) (!j:js) !lp - | j1 < lb = [] - | j1 <= ub && lp > j = (i,j1) : go is js j - | otherwise = go is js j - where - j1 = j+1 - --- | Adds a box to a partition -addBox :: (Int,Int) -> Part -> Part -addBox (k,_) part = go 1 part where - go !i (p:ps) = if i==k then (p+1):ps else p : go (i+1) ps - go !i [] = if i==k then [1] else error "addBox: shouldn't happen" - --- | Safe head defaulting to zero -headOrZero :: [Int] -> Int -headOrZero xs = case xs of - (!x:_) -> x - [] -> 0 - --- | Computes the sequence of differences from a partition (including the last difference to zero) -diffSeq :: Part -> [Int] -diffSeq = go where - go (p:ps@(q:_)) = (p-q) : go ps - go [p] = [p] - go [] = [] - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Tableaux/Skew.hs b/Math/Combinat/Tableaux/Skew.hs deleted file mode 100644 --- a/Math/Combinat/Tableaux/Skew.hs +++ /dev/null @@ -1,224 +0,0 @@ - --- | Skew tableaux are skew partitions filled with numbers. --- --- For example: --- --- <> --- - -{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, MultiParamTypeClasses #-} - -module Math.Combinat.Tableaux.Skew where - --------------------------------------------------------------------------------- - -import Data.List - -import Math.Combinat.Classes -import Math.Combinat.Partitions.Integer -import Math.Combinat.Partitions.Integer.IntList ( _diffSequence ) -import Math.Combinat.Partitions.Skew -import Math.Combinat.Tableaux -import Math.Combinat.ASCII -import Math.Combinat.Helper - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map - --------------------------------------------------------------------------------- --- * Basics --- | A skew tableau is represented by a list of offsets and entries -newtype SkewTableau a = SkewTableau [(Int,[a])] deriving (Eq,Ord,Show) - --- unSkewTableau :: SkewTableau a -> [(Int,[a])] --- unSkewTableau (SkewTableau a) = a - -instance Functor SkewTableau where - fmap f (SkewTableau t) = SkewTableau [ (a, map f xs) | (a,xs) <- t ] - --- | The shape of a skew tableau -skewTableauShape :: SkewTableau a -> SkewPartition -skewTableauShape (SkewTableau list) = SkewPartition [ (o,length xs) | (o,xs) <- list ] - -instance HasShape (SkewTableau a) SkewPartition where - shape = skewTableauShape - --- | The weight of a tableau is the weight of its shape, or the number of entries -skewTableauWeight :: SkewTableau a -> Int -skewTableauWeight = skewPartitionWeight . skewTableauShape - -instance HasWeight (SkewTableau a) where - weight = skewTableauWeight - --------------------------------------------------------------------------------- - --- | The dual of a skew tableau, that is, its mirror image to the main diagonal -dualSkewTableau :: forall a. SkewTableau a -> SkewTableau a -dualSkewTableau (SkewTableau axs) = SkewTableau (go axs) where - - go [] = [] - go axs = case sub 0 axs of - (0,[]) -> [] - this -> this : go (strip axs) - - strip :: [(Int,[a])] -> [(Int,[a])] - strip [] = [] - strip ((a,xs):rest) = if a>0 - then (a-1,xs) : strip rest - else case xs of - [] -> [] - (z:zs) -> case zs of - [] -> [] - _ -> (0,zs) : strip rest - - sub :: Int -> [(Int,[a])] -> (Int,[a]) - sub !b [] = (b,[]) - sub !b ((a,this):rest) = if a>0 - then sub (b+1) rest - else (b,ys) where - ys = map head $ takeWhile (not . null) (this : map snd rest) - -{- -test_dualSkewTableau :: [SkewTableau Int] -test_dualSkewTableau = bad where - ps = allPartitions 11 - bad = [ st - | p<-ps , q<-ps - , (q `isSubPartitionOf` p) - , let sp = mkSkewPartition (p,q) - , let st = fillSkewPartitionWithRowWord sp [1..] - , dualSkewTableau (dualSkewTableau st) /= st - ] --} - -instance HasDuality (SkewTableau a) where - dual = dualSkewTableau - --------------------------------------------------------------------------------- --- * Semistandard tableau - --- | A tableau is /semistandard/ if its entries are weekly increasing horizontally --- and strictly increasing vertically -isSemiStandardSkewTableau :: SkewTableau Int -> Bool -isSemiStandardSkewTableau st@(SkewTableau axs) = weak && strict where - weak = and [ isWeaklyIncreasing xs | (a,xs) <- axs ] - strict = and [ isStrictlyIncreasing ys | (b,ys) <- bys ] - SkewTableau bys = dualSkewTableau st - --- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@, --- where @n@ is the weight. -isStandardSkewTableau :: SkewTableau Int -> Bool -isStandardSkewTableau st = isSemiStandardSkewTableau st && sort (skewTableauRowWord st) == [1..n] where - n = skewTableauWeight st - --------------------------------------------------------------------------------- - --- | All semi-standard skew tableaux filled with the numbers @[1..n]@ -semiStandardSkewTableaux :: Int -> SkewPartition -> [SkewTableau Int] -semiStandardSkewTableaux n (SkewPartition abs) = map SkewTableau stuff where - - stuff = worker as bs ds (repeat 1) - (as,bs) = unzip abs - ds = _diffSequence as - - -- | @worker inner outerMinusInner innerdiffs lowerbound - worker :: [Int] -> [Int] -> [Int] -> [Int] -> [[(Int,[Int])]] - worker (a:as) (b:bs) (d:ds) lb = [ (a,this):rest - | this <- row b 1 lb - , let lb' = (replicate d 1 ++ map (+1) this) - , rest <- worker as bs ds lb' ] - worker [] _ _ _ = [ [] ] - - -- @row length minimum lowerbound@ - row 0 _ _ = [[]] - row _ _ [] = [] - row !k !m (!a:as) = [ x:xs | x <- [(max a m)..n] , xs <- row (k-1) x as ] - -{- --- | from a sequence @[a1,a2,..,an]@ computes the sequence of differences --- @[a1-a2,a2-a3,...,an-0]@ -diffSequence :: [Int] -> [Int] -diffSequence = go where - go (x:ys@(y:_)) = (x-y) : go ys - go [x] = [x] - go [] = [] --} - --------------------------------------------------------------------------------- --- * ASCII - --- | ASCII drawing of a skew tableau (using the English notation) -asciiSkewTableau :: Show a => SkewTableau a -> ASCII -asciiSkewTableau = asciiSkewTableau' "." EnglishNotation - -asciiSkewTableau' - :: Show a - => String -- ^ string representing the elements of the inner (unfilled) partition - -> PartitionConvention -- ^ orientation - -> SkewTableau a - -> ASCII -asciiSkewTableau' innerstr orient (SkewTableau axs) = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) stuff where - stuff = case orient of - EnglishNotation -> es - EnglishNotationCCW -> reverse (transpose es) - FrenchNotation -> reverse es - inner = asciiFromString innerstr - es = [ replicate a inner ++ map asciiShow xs | (a,xs) <- axs ] - -instance Show a => DrawASCII (SkewTableau a) where - ascii = asciiSkewTableau - --------------------------------------------------------------------------------- --- * Row \/ column words - --- | The reversed (right-to-left) rows, concatenated -skewTableauRowWord :: SkewTableau a -> [a] -skewTableauRowWord (SkewTableau axs) = concatMap (reverse . snd) axs - --- | The reversed (bottom-to-top) columns, concatenated -skewTableauColumnWord :: SkewTableau a -> [a] -skewTableauColumnWord = skewTableauRowWord . dualSkewTableau - --- | Fills a skew partition with content, in row word order -fillSkewPartitionWithRowWord :: SkewPartition -> [a] -> SkewTableau a -fillSkewPartitionWithRowWord (SkewPartition abs) xs = SkewTableau $ go abs xs where - go ((b,a):rest) xs = let (ys,zs) = splitAt a xs in (b,reverse ys) : go rest zs - go [] xs = [] - --- | Fills a skew partition with content, in column word order -fillSkewPartitionWithColumnWord :: SkewPartition -> [a] -> SkewTableau a -fillSkewPartitionWithColumnWord shape content - = dualSkewTableau - $ fillSkewPartitionWithRowWord (dualSkewPartition shape) content - --------------------------------------------------------------------------------- - --- | If the skew tableau's row word is a lattice word, we can make a partition from its content -skewTableauRowContent :: SkewTableau Int -> Maybe Partition -skewTableauRowContent (SkewTableau axs) = go Map.empty rowword where - - rowword = concatMap (reverse . snd) axs - - finish table = Partition (f 1) where - f !i = case lkp i of - 0 -> [] - y -> y : f (i+1) - lkp j = case Map.lookup j table of - Just k -> k - Nothing -> 0 - - go :: Map Int Int -> [Int] -> Maybe Partition - go !table [] = Just (finish table) - go !table (i:is) = - if check i - then go table' is - else Nothing - where - table' = Map.insertWith (+) i 1 table - check j = j==1 || cnt (j-1) >= cnt j - cnt j = case Map.lookup j table' of - Just k -> k - Nothing -> 0 - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Trees.hs b/Math/Combinat/Trees.hs deleted file mode 100644 --- a/Math/Combinat/Trees.hs +++ /dev/null @@ -1,9 +0,0 @@ - -module Math.Combinat.Trees - ( module Math.Combinat.Trees.Binary - , module Math.Combinat.Trees.Nary - ) where - -import Math.Combinat.Trees.Binary -import Math.Combinat.Trees.Nary - diff --git a/Math/Combinat/Trees/Binary.hs b/Math/Combinat/Trees/Binary.hs deleted file mode 100644 --- a/Math/Combinat/Trees/Binary.hs +++ /dev/null @@ -1,492 +0,0 @@ - --- | 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: --- --- <> --- - -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -module Math.Combinat.Trees.Binary - ( -- * Types - BinTree(..) - , leaf - , graft - , BinTree'(..) - , forgetNodeDecorations - , Paren(..) - , parenthesesToString - , stringToParentheses - , numberOfNodes - , numberOfLeaves - -- * Conversion to rose trees (@Data.Tree@) - , toRoseTree , toRoseTree' - , module Data.Tree - -- * Enumerate leaves - , enumerateLeaves_ - , enumerateLeaves - , enumerateLeaves' - -- * Nested parentheses - , nestedParentheses - , randomNestedParentheses - , nthNestedParentheses - , countNestedParentheses - , fasc4A_algorithm_P - , fasc4A_algorithm_W - , fasc4A_algorithm_U - -- * Generating binary trees - , binaryTrees - , countBinaryTrees - , binaryTreesNaive - , randomBinaryTree - , fasc4A_algorithm_R - -- * ASCII drawing - , asciiBinaryTree_ - -- * Graphviz drawing - , Dot - , graphvizDotBinTree - , graphvizDotBinTree' - , graphvizDotForest - , graphvizDotTree - -- * Bijections - , forestToNestedParentheses - , forestToBinaryTree - , nestedParenthesesToForest - , nestedParenthesesToForestUnsafe - , nestedParenthesesToBinaryTree - , nestedParenthesesToBinaryTreeUnsafe - , binaryTreeToForest - , binaryTreeToNestedParentheses - ) - where - --------------------------------------------------------------------------------- - -import Control.Applicative -import Control.Monad -import Control.Monad.ST - -import Data.Array -import Data.Array.ST -import Data.Array.Unsafe - -import Data.List -import Data.Tree (Tree(..),Forest(..)) - -import Data.Monoid -import Data.Foldable (Foldable(foldMap)) -import Data.Traversable (Traversable(traverse)) - -import System.Random - -import Math.Combinat.Numbers (factorial,binomial) - -import Math.Combinat.Trees.Graphviz - ( Dot - , graphvizDotBinTree , graphvizDotBinTree' - , graphvizDotForest , graphvizDotTree - ) -import Math.Combinat.Classes -import Math.Combinat.Helper -import Math.Combinat.ASCII as ASCII - --------------------------------------------------------------------------------- --- * Types - --- | A binary tree with leaves decorated with type @a@. -data BinTree a - = Branch (BinTree a) (BinTree a) - | Leaf a - deriving (Eq,Ord,Show,Read) - -leaf :: BinTree () -leaf = Leaf () - --- | The monadic join operation of binary trees -graft :: BinTree (BinTree a) -> BinTree a -graft = go where - go (Branch l r) = Branch (go l) (go r) - go (Leaf t ) = t - --------------------------------------------------------------------------------- - --- | A binary tree with leaves and internal nodes decorated --- with types @a@ and @b@, respectively. -data BinTree' a b - = Branch' (BinTree' a b) b (BinTree' a b) - | Leaf' a - deriving (Eq,Ord,Show,Read) - -forgetNodeDecorations :: BinTree' a b -> BinTree a -forgetNodeDecorations = go where - go (Branch' left _ right) = Branch (go left) (go right) - go (Leaf' decor ) = Leaf decor - --------------------------------------------------------------------------------- - -instance HasNumberOfNodes (BinTree a) where - numberOfNodes = go where - go (Leaf _ ) = 0 - go (Branch l r) = go l + go r + 1 - -instance HasNumberOfLeaves (BinTree a) where - numberOfLeaves = go where - go (Leaf _ ) = 1 - go (Branch l r) = go l + go r - - -instance HasNumberOfNodes (BinTree' a b) where - numberOfNodes = go where - go (Leaf' _ ) = 0 - go (Branch' l _ r) = go l + go r + 1 - -instance HasNumberOfLeaves (BinTree' a b) where - numberOfLeaves = go where - go (Leaf' _ ) = 1 - go (Branch' l _ r) = go l + go r - --------------------------------------------------------------------------------- --- * Enumerate leaves - --- | Enumerates the leaves a tree, starting from 0, ignoring old labels -enumerateLeaves_ :: BinTree a -> BinTree Int -enumerateLeaves_ = snd . go 0 where - go !k t = case t of - Leaf _ -> (k+1 , Leaf k) - Branch l r -> (k'', Branch l' r') where - (k' ,l') = go k l - (k'',r') = go k' r - --- | Enumerates the leaves a tree, starting from zero, and also returns the number of leaves -enumerateLeaves' :: BinTree a -> (Int, BinTree (a,Int)) -enumerateLeaves' = go 0 where - go !k t = case t of - Leaf y -> (k+1 , Leaf (y,k)) - Branch l r -> (k'', Branch l' r') where - (k' ,l') = go k l - (k'',r') = go k' r - --- | Enumerates the leaves a tree, starting from zero -enumerateLeaves :: BinTree a -> BinTree (a,Int) -enumerateLeaves = snd . enumerateLeaves' - --------------------------------------------------------------------------------- --- * conversion to 'Data.Tree' - --- | Convert a binary tree to a rose tree (from "Data.Tree") -toRoseTree :: BinTree a -> Tree (Maybe a) -toRoseTree = go where - go (Branch t1 t2) = Node Nothing [go t1, go t2] - go (Leaf x) = Node (Just x) [] - -toRoseTree' :: BinTree' a b -> Tree (Either b a) -toRoseTree' = go where - go (Branch' t1 y t2) = Node (Left y) [go t1, go t2] - go (Leaf' x) = Node (Right x) [] - --------------------------------------------------------------------------------- --- instances - -instance Functor BinTree where - fmap f = go where - go (Branch left right) = Branch (go left) (go right) - go (Leaf x) = Leaf (f x) - -instance Foldable BinTree where - foldMap f = go where - go (Leaf x) = f x - go (Branch left right) = (go left) `mappend` (go right) - -instance Traversable BinTree where - traverse f = go where - go (Leaf x) = Leaf <$> f x - go (Branch left right) = Branch <$> go left <*> go right - -instance Applicative BinTree where - pure = Leaf - u <*> t = go u where - go (Branch l r) = Branch (go l) (go r) - go (Leaf f ) = fmap f t - -instance Monad BinTree where - return = Leaf - (>>=) t f = go t where - go (Branch l r) = Branch (go l) (go r) - go (Leaf y ) = f y - --------------------------------------------------------------------------------- --- * Nested parentheses - -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 - --- | Generates all sequences of nested parentheses of length @2n@ in --- lexigraphic order. --- --- Synonym for 'fasc4A_algorithm_P'. --- -nestedParentheses :: Int -> [[Paren]] -nestedParentheses = fasc4A_algorithm_P - --- | Synonym for 'fasc4A_algorithm_W'. -randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g) -randomNestedParentheses = fasc4A_algorithm_W - --- | Synonym for 'fasc4A_algorithm_U'. -nthNestedParentheses :: Int -> Integer -> [Paren] -nthNestedParentheses = fasc4A_algorithm_U - -countNestedParentheses :: Int -> Integer -countNestedParentheses = countBinaryTrees - --- | Generates all sequences of nested parentheses of length 2n. --- Order is lexicographical (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) , [] ) - next _ = error "fasc4A_algorithm_P: fatal error shouldn't happen" - - 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 , [] ) - findj _ _ = error "fasc4A_algorithm_P: fatal error shouldn't happen" - --- | Generates a uniformly random sequence of nested parentheses of length 2n. --- Based on \"Algorithm W\" in Knuth. -fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g) -fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where - n = fromIntegral n' :: Integer - -- the numbers we use are of order n^2, so for n >> 2^16 - -- on a 32 bit machine, we need big integers. - worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g) - worker (rnd,_,0,parens) = (parens,rnd) - worker (rnd,p,q,parens) = - if x<(q+1)*(q-p) - then worker (rnd' , p , q-1 , LeftParen :parens) - else worker (rnd' , p-1 , q , RightParen:parens) - where - (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd - --- | Nth sequence of nested parentheses of length 2n. --- The order is the same as in 'fasc4A_algorithm_P'. --- Based on \"Algorithm U\" in Knuth. -fasc4A_algorithm_U - :: Int -- ^ n - -> Integer -- ^ N; should satisfy 1 <= N <= C(n) - -> [Paren] -fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where - n = fromIntegral n' :: Integer - c0 = foldl f 1 [2..n] - f c p = ((4*p-2)*c) `div` (p+1) - worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren] - worker (_ ,_,_,0,parens) = parens - worker (bign,c,p,q,parens) = - if bign <= c' - then worker (bign , c' , p , q-1 , RightParen:parens) - else worker (bign-c' , c-c' , p-1 , q , LeftParen :parens) - where - c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1)) - --------------------------------------------------------------------------------- --- * Generating binary trees - --- | Generates all binary trees with @n@ nodes. --- At the moment just a synonym for 'binaryTreesNaive'. -binaryTrees :: Int -> [BinTree ()] -binaryTrees = binaryTreesNaive - --- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }. --- --- This is also the counting function for forests and nested parentheses. -countBinaryTrees :: Int -> Integer -countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n) - --- | Generates all binary trees with n nodes. The naive algorithm. -binaryTreesNaive :: Int -> [BinTree ()] -binaryTreesNaive 0 = [ leaf ] -binaryTreesNaive n = - [ Branch l r - | i <- [0..n-1] - , l <- binaryTreesNaive i - , r <- binaryTreesNaive (n-1-i) - ] - --- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'. -randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g) -randomBinaryTree n rnd = (tree,rnd') where - (decorated,rnd') = fasc4A_algorithm_R n rnd - tree = fmap (const ()) $ forgetNodeDecorations decorated - --- | Grows a uniformly random binary tree. --- \"Algorithm R\" (Remy's procudere) in Knuth. --- Nodes are decorated with odd numbers, leaves with even numbers (from the --- set @[0..2n]@). Uses mutable arrays internally. -fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g) -fasc4A_algorithm_R n0 rnd = res where - res = runST $ do - ar <- newArray (0,2*n0) 0 - rnd' <- worker rnd 1 ar - links <- Data.Array.Unsafe.unsafeFreeze ar - return (toTree links, rnd') - toTree links = f (links!0) where - f i = if odd i - then Branch' (f $ links!i) i (f $ links!(i+1)) - else Leaf' i - worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g - worker rnd n ar = do - if n > n0 - then return rnd - else do - writeArray ar (n2-b) n2 - lk <- readArray ar k - writeArray ar (n2-1+b) lk - writeArray ar k (n2-1) - worker rnd' (n+1) ar - where - n2 = n+n - (x,rnd') = randomR (0,4*n-3) rnd - (k,b) = x `divMod` 2 - --------------------------------------------------------------------------------- --- * ASCII drawing - --- | Draws a binary tree in ASCII, ignoring node labels. --- --- Example: --- --- > autoTabulate RowMajor (Right 5) $ map asciiBinaryTree_ $ binaryTrees 4 --- -asciiBinaryTree_ :: BinTree a -> ASCII -asciiBinaryTree_ = ASCII.asciiFromLines . fst . go where - - go :: BinTree a -> ([String],Int) - go (Leaf x) = ([],0) - go (Branch t1 t2) = ( new , j1+m ) where - (ls1,j1) = go t1 - (ls2,j2) = go t2 - w1 = blockWidth ls1 - w2 = blockWidth ls2 - m = max 1 $ (w1-j1+j2+2) `div` 2 - s = 2*m - (w1-j1+j2) - spaces = [replicate s ' '] - ls = hConcatLines [ ls1 , spaces , ls2 ] - top = [ replicate (j1+m-i) ' ' ++ "/" ++ replicate (2*(i-1)) ' ' ++ "\\" | i<-[1..m] ] - new = mkLinesUniformWidth $ vConcatLines [ top , ls ] - - blockWidth ls = case ls of - (l:_) -> length l - [] -> 0 - -instance DrawASCII (BinTree ()) where - ascii = asciiBinaryTree_ - --------------------------------------------------------------------------------- diff --git a/Math/Combinat/Trees/Binary.hs-boot b/Math/Combinat/Trees/Binary.hs-boot deleted file mode 100644 --- a/Math/Combinat/Trees/Binary.hs-boot +++ /dev/null @@ -1,22 +0,0 @@ - - -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 deleted file mode 100644 --- a/Math/Combinat/Trees/Graphviz.hs +++ /dev/null @@ -1,115 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/Math/Combinat/Trees/Nary.hs +++ /dev/null @@ -1,430 +0,0 @@ - --- | N-ary trees. - -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -module Math.Combinat.Trees.Nary - ( - -- * Types - module Data.Tree - , Tree(..) - -- * Regular trees - , ternaryTrees - , regularNaryTrees - , semiRegularTrees - , countTernaryTrees - , countRegularNaryTrees - -- * \"derivation trees\" - , derivTrees - -- * ASCII drawings - , asciiTreeVertical_ - , asciiTreeVertical - , asciiTreeVerticalLeavesOnly - -- * Graphviz drawing - , Dot - , graphvizDotTree - , graphvizDotForest - -- * Classifying nodes - , classifyTreeNode - , isTreeLeaf , isTreeNode - , isTreeLeaf_ , isTreeNode_ - , treeNodeNumberOfChildren - -- * Counting nodes - , countTreeNodes - , countTreeLeaves - , countTreeLabelsWith - , countTreeNodesWith - -- * Left and right spines - , leftSpine , leftSpine_ - , rightSpine , rightSpine_ - , leftSpineLength , rightSpineLength - -- * Unique labels - , addUniqueLabelsTree - , addUniqueLabelsForest - , addUniqueLabelsTree_ - , addUniqueLabelsForest_ - -- * Labelling by depth - , labelDepthTree - , labelDepthForest - , labelDepthTree_ - , labelDepthForest_ - -- * Labelling by number of children - , labelNChildrenTree - , labelNChildrenForest - , labelNChildrenTree_ - , labelNChildrenForest_ - - ) where - - --------------------------------------------------------------------------------- - -import Data.Tree -import Data.List - -import Control.Applicative - ---import Control.Monad.State -import Control.Monad.Trans.State -import Data.Traversable (traverse) - -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.Classes -import Math.Combinat.ASCII as ASCII -import Math.Combinat.Helper - --------------------------------------------------------------------------------- - -instance HasNumberOfNodes (Tree a) where - numberOfNodes = go where - go (Node label subforest) = if null subforest - then 0 - else 1 + sum' (map go subforest) - -instance HasNumberOfLeaves (Tree a) where - numberOfLeaves = go where - go (Node label subforest) = if null subforest - then 1 - else sum' (map go subforest) - --------------------------------------------------------------------------------- - --- | @regularNaryTrees d n@ returns the list of (rooted) trees on @n@ nodes where each --- node has exactly @d@ children. Note that the leaves do not count in @n@. --- Naive algorithm. -regularNaryTrees - :: Int -- ^ degree = number of children of each node - -> Int -- ^ number of nodes - -> [Tree ()] -regularNaryTrees d = go where - go 0 = [ Node () [] ] - go n = [ Node () cs - | is <- compositions d (n-1) - , cs <- listTensor [ go i | i<-is ] - ] - --- | Ternary trees on @n@ nodes (synonym for @regularNaryTrees 3@) -ternaryTrees :: Int -> [Tree ()] -ternaryTrees = regularNaryTrees 3 - --- | We have --- --- > length (regularNaryTrees d n) == countRegularNaryTrees d n == \frac {1} {(d-1)n+1} \binom {dn} {n} --- -countRegularNaryTrees :: (Integral a, Integral b) => a -> b -> Integer -countRegularNaryTrees d n = binomial (dd*nn) nn `div` ((dd-1)*nn+1) where - dd = fromIntegral d :: Integer - nn = fromIntegral n :: Integer - --- | @\# = \\frac {1} {(2n+1} \\binom {3n} {n}@ -countTernaryTrees :: Integral a => a -> Integer -countTernaryTrees = countRegularNaryTrees (3::Int) - --------------------------------------------------------------------------------- - --- | All trees on @n@ nodes where the number of children of all nodes is --- in element of the given set. Example: --- --- > 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,...] --- --- The latter sequence is A027307 in OEIS: --- --- Remark: clearly, we have --- --- > semiRegularTrees [d] n == regularNaryTrees d n --- --- -semiRegularTrees - :: [Int] -- ^ set of allowed number of children - -> Int -- ^ number of nodes - -> [Tree ()] -semiRegularTrees [] n = if n==0 then [Node () []] else [] -semiRegularTrees dset_ n = - if head dset >=1 - then go n - else error "semiRegularTrees: expecting a list of positive integers" - where - dset = map head $ group $ sort $ dset_ - - go 0 = [ Node () [] ] - go n = [ Node () cs - | d <- dset - , is <- compositions d (n-1) - , cs <- listTensor [ go i | i<-is ] - ] - -{- - -NOTES: - -A006318 = [ length $ semiRegularTrees [1,2] n | n<-[0..] ] == [1,2,6,22,90,394,1806,8558,41586,206098,1037718.. ] -?? = [ length $ semiRegularTrees [1,3] n | n<-[0..] ] == [1,2,8,44,280,1936,14128,107088,834912,6652608 .. ] -?? = [ length $ semiRegularTrees [1,4] n | n<-[0..] ] == [1,2,10,74,642,6082,60970,635818,6826690 - -A027307 = [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...] -A219534 = [ length $ semiRegularTrees [2,4] n | n<-[0..] ] == [1,2,12,100,968,10208,113792,1318832 ..] -?? = [ length $ semiRegularTrees [2,5] n | n<-[0..] ] == [1,2,14,142,1690,21994,303126,4348102 ..] - -A144097 = [ length $ semiRegularTrees [3,4] n | n<-[0..] ] == [1,2,14,134,1482,17818,226214,2984206,40503890..] - -A107708 = [ length $ semiRegularTrees [1,2,3] n | n<-[0..] ] == [1,3,18,144,1323,13176,138348,1507977 .. ] -?? = [ length $ semiRegularTrees [1,2,3,4] n | n<-[0..] ] == [1,4,40,560,9120,161856,3036800,59242240 .. ] - --} - --------------------------------------------------------------------------------- - --- | Vertical ASCII drawing of a tree, without labels. Example: --- --- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical_ $ regularNaryTrees 2 4 --- --- Nodes are denoted by @\@@, leaves by @*@. --- -asciiTreeVertical_ :: Tree a -> ASCII -asciiTreeVertical_ tree = ASCII.asciiFromLines (go tree) where - go :: Tree b -> [String] - go (Node _ cs) = case cs of - [] -> ["-*"] - _ -> concat $ mapWithFirstLast f $ map go cs - - f :: Bool -> Bool -> [String] -> [String] - f bf bl (l:ls) = let indent = if bl then " " else "| " - gap = if bl then [] else ["| "] - branch = if bl && not bf - then "\\-" - else if bf then "@-" - else "+-" - in (branch++l) : map (indent++) ls ++ gap - -instance DrawASCII (Tree ()) where - ascii = asciiTreeVertical_ - --- | 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] - _ -> concat $ mapWithFirstLast (f (show x)) $ map go cs - - f :: String -> Bool -> Bool -> [String] -> [String] - f label bf bl (l:ls) = - let spaces = (map (const ' ') label ) - dashes = (map (const '-') spaces ) - indent = if bl then " " ++spaces++" " else " |" ++ spaces ++ " " - gap = if bl then [] else [" |" ++ spaces ++ " "] - branch = if bl && not bf - then " \\"++dashes++"--" - else if bf - then "-(" ++ label ++ ")-" - else " +" ++ dashes ++ "--" - in (branch++l) : map (indent++) ls ++ gap - --- | 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] - _ -> concat $ mapWithFirstLast f $ map go cs - - f :: Bool -> Bool -> [String] -> [String] - f bf bl (l:ls) = let indent = if bl then " " else "| " - gap = if bl then [] else ["| "] - branch = if bl && not bf - then "\\-" - else if bf then "@-" - else "+-" - in (branch++l) : map (indent++) ls ++ gap - --------------------------------------------------------------------------------- - --- | The leftmost spine (the second element of the pair is the leaf node) -leftSpine :: Tree a -> ([a],a) -leftSpine = go where - go (Node x cs) = case cs of - [] -> ([],x) - _ -> let (xs,y) = go (head cs) in (x:xs,y) - -rightSpine :: Tree a -> ([a],a) -rightSpine = go where - go (Node x cs) = case cs of - [] -> ([],x) - _ -> let (xs,y) = go (last cs) in (x:xs,y) - --- | The leftmost spine without the leaf node -leftSpine_ :: Tree a -> [a] -leftSpine_ = go where - go (Node x cs) = case cs of - [] -> [] - _ -> x : go (head cs) - -rightSpine_ :: Tree a -> [a] -rightSpine_ = go where - go (Node x cs) = case cs of - [] -> [] - _ -> x : go (last cs) - --- | The length (number of edges) on the left spine --- --- > leftSpineLength tree == length (leftSpine_ tree) --- -leftSpineLength :: Tree a -> Int -leftSpineLength = go 0 where - go n (Node x cs) = case cs of - [] -> n - _ -> go (n+1) (head cs) - -rightSpineLength :: Tree a -> Int -rightSpineLength = go 0 where - go n (Node x cs) = case cs of - [] -> n - _ -> go (n+1) (last cs) - --------------------------------------------------------------------------------- - --- | 'Left' is leaf, 'Right' is node -classifyTreeNode :: Tree a -> Either a a -classifyTreeNode (Node x cs) = case cs of { [] -> Left x ; _ -> Right x } - -isTreeLeaf :: Tree a -> Maybe a -isTreeLeaf (Node x cs) = case cs of { [] -> Just x ; _ -> Nothing } - -isTreeNode :: Tree a -> Maybe a -isTreeNode (Node x cs) = case cs of { [] -> Nothing ; _ -> Just x } - -isTreeLeaf_ :: Tree a -> Bool -isTreeLeaf_ (Node x cs) = case cs of { [] -> True ; _ -> False } - -isTreeNode_ :: Tree a -> Bool -isTreeNode_ (Node x cs) = case cs of { [] -> False ; _ -> True } - -treeNodeNumberOfChildren :: Tree a -> Int -treeNodeNumberOfChildren (Node _ cs) = length cs - --------------------------------------------------------------------------------- --- counting - -countTreeNodes :: Tree a -> Int -countTreeNodes = go where - go (Node x cs) = case cs of - [] -> 0 - _ -> 1 + sum (map go cs) - -countTreeLeaves :: Tree a -> Int -countTreeLeaves = go where - go (Node x cs) = case cs of - [] -> 1 - _ -> sum (map go cs) - -countTreeLabelsWith :: (a -> Bool) -> Tree a -> Int -countTreeLabelsWith f = go where - go (Node label cs) = (if f label then 1 else 0) + sum (map go cs) - -countTreeNodesWith :: (Tree a -> Bool) -> Tree a -> Int -countTreeNodesWith f = go where - go node@(Node _ cs) = (if f node then 1 else 0) + sum (map go cs) - --------------------------------------------------------------------------------- - --- | Adds unique labels to the nodes (including leaves) of a 'Tree'. -addUniqueLabelsTree :: Tree a -> Tree (a,Int) -addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree]) - --- | Adds unique labels to the nodes (including leaves) of a 'Forest' -addUniqueLabelsForest :: Forest a -> Forest (a,Int) -addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where - globalAction tree = - unwrapMonad $ traverse localAction tree - localAction x = WrapMonad $ do - i <- get - put (i+1) - return (x,i) - -addUniqueLabelsTree_ :: Tree a -> Tree Int -addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree - -addUniqueLabelsForest_ :: Forest a -> Forest Int -addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest - --------------------------------------------------------------------------------- - --- | Attaches the depth to each node. The depth of the root is 0. -labelDepthTree :: Tree a -> Tree (a,Int) -labelDepthTree tree = worker 0 tree where - worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees) - -labelDepthForest :: Forest a -> Forest (a,Int) -labelDepthForest forest = map labelDepthTree forest - -labelDepthTree_ :: Tree a -> Tree Int -labelDepthTree_ = fmap snd . labelDepthTree - -labelDepthForest_ :: Forest a -> Forest Int -labelDepthForest_ = map (fmap snd) . labelDepthForest - --------------------------------------------------------------------------------- - --- | Attaches the number of children to each node. -labelNChildrenTree :: Tree a -> Tree (a,Int) -labelNChildrenTree (Node x subforest) = - Node (x, length subforest) (map labelNChildrenTree subforest) - -labelNChildrenForest :: Forest a -> Forest (a,Int) -labelNChildrenForest forest = map labelNChildrenTree forest - -labelNChildrenTree_ :: Tree a -> Tree Int -labelNChildrenTree_ = fmap snd . labelNChildrenTree - -labelNChildrenForest_ :: Forest a -> Forest Int -labelNChildrenForest_ = map (fmap snd) . labelNChildrenForest - --------------------------------------------------------------------------------- - --- | Computes the set of equivalence classes of rooted trees (in the --- sense that the leaves of a node are /unordered/) --- with @n = length ks@ leaves where the set of heights of --- the leaves matches the given set of numbers. --- The height is defined as the number of /edges/ from the leaf to the root. --- --- TODO: better name? -derivTrees :: [Int] -> [Tree ()] -derivTrees xs = derivTrees' (map (+1) xs) - -derivTrees' :: [Int] -> [Tree ()] -derivTrees' [] = [] -derivTrees' [n] = - if n>=1 - then [unfoldTree f 1] - else [] - where - f k = if k0) ks) - then - [ Node () sub - | part <- parts - , let subtrees = map g part - , sub <- listTensor subtrees - ] - else [] - where - parts = partitionMultiset ks - g xs = derivTrees' (map (\x->x-1) xs) - --------------------------------------------------------------------------------- - diff --git a/Math/Combinat/Trees/Nary.hs-boot b/Math/Combinat/Trees/Nary.hs-boot deleted file mode 100644 --- a/Math/Combinat/Trees/Nary.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ - -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/Math/Combinat/Tuples.hs b/Math/Combinat/Tuples.hs deleted file mode 100644 --- a/Math/Combinat/Tuples.hs +++ /dev/null @@ -1,61 +0,0 @@ - --- | 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/Math/Combinat/TypeLevel.hs b/Math/Combinat/TypeLevel.hs deleted file mode 100644 --- a/Math/Combinat/TypeLevel.hs +++ /dev/null @@ -1,117 +0,0 @@ - --- | Type-level hackery. --- --- This module is used for groups whose parameters are encoded as type-level natural numbers, --- for example finite cyclic groups, free groups, symmetric groups and braid groups. --- - -{-# LANGUAGE PolyKinds, DataKinds, KindSignatures, ScopedTypeVariables, - ExistentialQuantification, Rank2Types #-} - -module Math.Combinat.TypeLevel - ( -- * Proxy - Proxy(..) - , proxyUndef - , proxyOf - , proxyOf1 - , proxyOf2 - , asProxyTypeOf -- defined in Data.Proxy - , asProxyTypeOf1 - -- * Type-level naturals as type arguments - , typeArg - , iTypeArg - -- * Hiding the type parameter - , Some (..) - , withSome , withSomeM - , selectSome , selectSomeM - , withSelected , withSelectedM - ) - where - --------------------------------------------------------------------------------- - -import Data.Proxy ( Proxy(..) , asProxyTypeOf ) -import GHC.TypeLits - -import Math.Combinat.Numbers.Primes ( isProbablyPrime ) - --------------------------------------------------------------------------------- --- * Proxy - -proxyUndef :: Proxy a -> a -proxyUndef _ = error "proxyUndef" - -proxyOf :: a -> Proxy a -proxyOf _ = Proxy - -proxyOf1 :: f a -> Proxy a -proxyOf1 _ = Proxy - -proxyOf2 :: g (f a) -> Proxy a -proxyOf2 _ = Proxy - -asProxyTypeOf1 :: f a -> Proxy a -> f a -asProxyTypeOf1 y _ = y - --------------------------------------------------------------------------------- --- * Type-level naturals as type arguments - -typeArg :: KnownNat n => f (n :: Nat) -> Integer -typeArg = natVal . proxyOf1 - -iTypeArg :: KnownNat n => f (n :: Nat) -> Int -iTypeArg = fromIntegral . typeArg - --------------------------------------------------------------------------------- --- * Hiding the type parameter - --- | Hide the type parameter of a functor. Example: @Some Braid@ -data Some f = forall n. KnownNat n => Some (f n) - --- | Uses the value inside a 'Some' -withSome :: Some f -> (forall n. KnownNat n => f n -> a) -> a -withSome some polyFun = case some of { Some stuff -> polyFun stuff } - --- | Monadic version of 'withSome' -withSomeM :: Monad m => Some f -> (forall n. KnownNat n => f n -> m a) -> m a -withSomeM some polyAct = case some of { Some stuff -> polyAct stuff } - --- | Given a polymorphic value, we select at run time the --- one specified by the second argument -selectSome :: Integral int => (forall n. KnownNat n => f n) -> int -> Some f -selectSome poly n = case someNatVal (fromIntegral n :: Integer) of - Nothing -> error "selectSome: not a natural number" - Just snat -> case snat of - SomeNat pxy -> Some (asProxyTypeOf1 poly pxy) - --- | Monadic version of 'selectSome' -selectSomeM :: forall m f int. (Integral int, Monad m) => (forall n. KnownNat n => m (f n)) -> int -> m (Some f) -selectSomeM runPoly n = case someNatVal (fromIntegral n :: Integer) of - Nothing -> error "selectSomeM: not a natural number" - Just snat -> case snat of - SomeNat pxy -> do - poly <- runPoly - return $ Some (asProxyTypeOf1 poly pxy) - --- | Combination of 'selectSome' and 'withSome': we make a temporary structure --- of the given size, but we immediately consume it. -withSelected - :: Integral int - => (forall n. KnownNat n => f n -> a) - -> (forall n. KnownNat n => f n) - -> int - -> a -withSelected f x n = withSome (selectSome x n) f - --- | (Half-)monadic version of 'withSelected' -withSelectedM - :: forall m f int a. (Integral int, Monad m) - => (forall n. KnownNat n => f n -> a) - -> (forall n. KnownNat n => m (f n)) - -> int - -> m a -withSelectedM f mx n = do - s <- selectSomeM mx n - return (withSome s f) - --------------------------------------------------------------------------------- diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,31 @@ +combinat - a Haskell combinatorics library +------------------------------------------ + +For the API docs, [check out Hackage](https://hackage.haskell.org/package/combinat). + +This is a combinatorics library for Haskell. It contains functions +enumerating, counting, visualizing, manipulating, and sometimes randomly sampling +from many standard combinatorial objects, including: + +* subsets +* compositions +* trees +* numbers: + * natural numbers + * prime numbers + * formal power series +* permutations +* partitions: + * integer partitions + * set partitions, multiset partitions, non-crossing partitions + * plane partitions + * vector partitions + * skew partitions, ribbons +* Young tableaux, Littlewood-Richardson coefficients +* lattice paths, Dyck paths +* groups: + * permutation groups + * braid groups + * free groups, free products of cyclic groups + * Thompson's group F + diff --git a/combinat.cabal b/combinat.cabal --- a/combinat.cabal +++ b/combinat.cabal @@ -1,5 +1,5 @@ Name: combinat -Version: 0.2.10.0 +Version: 0.2.10.1 Synopsis: Generate and manipulate various combinatorial objects. Description: A collection of functions to generate, count, manipulate and visualize all kinds of combinatorial objects like @@ -8,31 +8,35 @@ License: BSD3 License-file: LICENSE Author: Balazs Komuves -Copyright: (c) 2008-2021 Balazs Komuves +Copyright: (c) 2008-2023 Balazs Komuves Maintainer: bkomuves (plus) hackage (at) gmail (dot) com -Homepage: http://moire.be/haskell/ +Homepage: https://github.com/bkomuves/combinat Stability: Experimental Category: Math -Tested-With: GHC == 8.6.5 +Tested-With: GHC == 8.6.5, GHC == 9.4.7 Cabal-Version: 1.24 Build-Type: Simple extra-doc-files: svg/*.svg + README.md extra-source-files: svg/*.svg svg/src/gen_figures.hs source-repository head - type: darcs - location: https://hub.darcs.net/bkomuves/combinat + type: git + location: https://github.com/bkomuves/combinat -------------------------------------------------------------------------------- Library Build-Depends: base >= 4 && < 5, - array >= 0.5, containers, random, transformers, - compact-word-vectors >= 0.2.0.2 + array >= 0.5 && < 0.7, + containers >= 0.6 && < 0.9, + random >= 1.1 && < 1.4, + transformers >= 0.4.2 && < 0.8, + compact-word-vectors >= 0.2.0.2 && < 0.4 Exposed-Modules: Math.Combinat Math.Combinat.Classes @@ -86,7 +90,7 @@ Default-Language: Haskell2010 - Hs-Source-Dirs: . + Hs-Source-Dirs: src ghc-options: -fwarn-tabs -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports @@ -113,11 +117,19 @@ Tests.Numbers.Primes Tests.Numbers.Sequences - build-depends: base >= 4 && < 5, array >= 0.5, containers >= 0.5, random, transformers, - combinat, compact-word-vectors >= 0.2.0.2, - test-framework, - test-framework-quickcheck2, QuickCheck >= 2, - tasty, tasty-quickcheck, tasty-hunit + build-depends: base >= 4 && < 5, + array >= 0.5 && < 0.7, + containers >= 0.6 && < 0.9, + random >= 1.1 && < 1.4, + transformers >= 0.4.2 && < 0.8, + compact-word-vectors >= 0.2.0.2 && < 0.4, + combinat, + test-framework > 0.8.1 && < 0.10, + test-framework-quickcheck2 >= 0.3 && < 0.5, + QuickCheck >= 2 && < 0.3, + tasty >= 0.11 && < 1.7, + tasty-quickcheck >= 0.9 && < 1.0, + tasty-hunit >= 0.10 && < 1.0 Default-Language: Haskell2010 Default-Extensions: CPP, BangPatterns diff --git a/src/Math/Combinat.hs b/src/Math/Combinat.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat.hs @@ -0,0 +1,76 @@ + +-- | A collection of functions to generate, manipulate, +-- visualize and count combinatorial objects like partitions, +-- compositions, permutations, braids, Young tableaux, +-- lattice paths, various tree structures, etc etc. +-- +-- +-- See also the @combinat-diagrams@ library for generating +-- graphical representations of (some of) these structure using +-- the @diagrams@ library (). +-- +-- +-- The long-term goals are +-- +-- (1) generate most of the standard structures; +-- +-- (2) manipulate these structures; +-- +-- (3) visualize these structures; +-- +-- (4) the generation should be efficient; +-- +-- (5) to be able to enumerate the structures +-- with constant memory usage; +-- +-- (6) to be able to randomly sample from them; +-- +-- (7) finally, to be a repository of algorithms. +-- +-- +-- The short-term goal is simply to generate +-- and manipulate 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; +-- +-- * \"random\" prefix: generates random objects +-- (typically with uniform distribution); +-- +-- * \"count\" prefix: counting functions. +-- +-- +-- This module re-exports the most commonly used modules. +-- + +module Math.Combinat + ( module Math.Combinat.Numbers + , module Math.Combinat.Sign + , module Math.Combinat.Sets + , module Math.Combinat.Tuples + , module Math.Combinat.Compositions + , module Math.Combinat.Partitions + , module Math.Combinat.Permutations + , module Math.Combinat.Tableaux + , module Math.Combinat.Trees + , module Math.Combinat.LatticePaths + , module Math.Combinat.ASCII + ) + where + +import Math.Combinat.Numbers +import Math.Combinat.Sign +import Math.Combinat.Sets +import Math.Combinat.Tuples +import Math.Combinat.Compositions +import Math.Combinat.Partitions +import Math.Combinat.Permutations +import Math.Combinat.Tableaux +import Math.Combinat.Trees +import Math.Combinat.LatticePaths +import Math.Combinat.ASCII diff --git a/src/Math/Combinat/ASCII.hs b/src/Math/Combinat/ASCII.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/ASCII.hs @@ -0,0 +1,438 @@ + +-- | 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.Char ( isSpace ) +import Data.List ( transpose , intercalate ) + +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * The basic ASCII 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] + } + +-- | A type class to have a simple way to draw things +class DrawASCII a where + ascii :: a -> ASCII + +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 + +-------------------------------------------------------------------------------- +-- * 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 + +-------------------------------------------------------------------------------- +-- * Concatenation + +-- | Horizontal append, centrally aligned, no separation. +(|||) :: ASCII -> ASCII -> ASCII +(|||) p q = hCatWith VCenter HSepEmpty [p,q] + +-- | Vertical append, centrally aligned, no separation. +(===) :: ASCII -> ASCII -> ASCII +(===) p q = vCatWith HCenter VSepEmpty [p,q] + +-- | Horizontal concatenation, top-aligned, no separation +hCatTop :: [ASCII] -> ASCII +hCatTop = hCatWith VTop HSepEmpty + +-- | Horizontal concatenation, bottom-aligned, no separation +hCatBot :: [ASCII] -> ASCII +hCatBot = hCatWith VBottom HSepEmpty + +-- | Vertical concatenation, left-aligned, no separation +vCatLeft :: [ASCII] -> ASCII +vCatLeft = vCatWith HLeft VSepEmpty + +-- | Vertical concatenation, right-aligned, no separation +vCatRight :: [ASCII] -> ASCII +vCatRight = vCatWith HRight VSepEmpty + +-- | General 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) + +-- | General 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 + +-------------------------------------------------------------------------------- +-- * 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 + +-------------------------------------------------------------------------------- +-- * Extension + +-- | Extends an ASCII figure with spaces horizontally to the given width. +-- Note: the alignment is the alignment of the original picture in the new bigger picture! +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. +-- Note: the alignment is the alignment of the original picture in the new bigger picture! +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 + +-------------------------------------------------------------------------------- +-- * Cutting + +-- | Cuts the given number of columns from the picture. +-- The alignment is the alignment of the /picture/, not the cuts. +-- +-- This should be the (left) inverse of 'hExtendWith'. +hCut :: HAlign -> Int -> ASCII -> ASCII +hCut halign k (ASCII (x,y) ls) = ASCII (x',y) (map f ls) where + x' = max 0 (x-k) + f = case halign of + HLeft -> reverse . drop k . reverse + HCenter -> reverse . drop (k-a) . reverse . drop a + HRight -> drop k + a = div k 2 + +-- | Cuts the given number of rows from the picture. +-- The alignment is the alignment of the /picture/, not the cuts. +-- +-- This should be the (left) inverse of 'vExtendWith'. +vCut :: VAlign -> Int -> ASCII -> ASCII +vCut valign k (ASCII (x,y) ls) = ASCII (x,y') (g ls) where + y' = max 0 (y-k) + g = case valign of + VTop -> reverse . drop k . reverse + VCenter -> reverse . drop (k-a) . reverse . drop a + VBottom -> drop k + a = div k 2 + +-------------------------------------------------------------------------------- +-- * Pasting + +-- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension +-- (that is, overlapping parts of the first one are ignored). +-- The offset is relative to the top-left corner of the second picture. +-- Spaces at treated as transparent. +-- +-- Example: +-- +-- > tabulate (HCenter,VCenter) (HSepSpaces 2, VSepSpaces 1) +-- > [ [ caption (show (x,y)) $ +-- > pasteOnto (x,y) (filledBox '@' (4,3)) (asciiBox (7,5)) +-- > | x <- [-4..7] ] +-- > | y <- [-3..5] ] +-- +pasteOnto :: (Int,Int) -> ASCII -> ASCII -> ASCII +pasteOnto = pasteOnto' isSpace + +-- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension. +-- The first argument specifies the transparency condition (on the first picture). +-- The offset is relative to the top-left corner of the second picture. +-- +pasteOnto' + :: (Char -> Bool) -- ^ transparency condition + -> (Int,Int) -- ^ offset relative to the top-left corner of the second picture + -> ASCII -- ^ picture to paste + -> ASCII -- ^ picture to paste onto + -> ASCII +pasteOnto' transparent (xpos,ypos) small big = new where + new = ASCII (xbig,ybig) lines' + (xbig,ybig) = asciiSize big + bigLines = asciiLines big + small' = (if (ypos>=0) then vExtendWith VBottom ypos else vCut VBottom (-ypos)) + $ (if (xpos>=0) then hExtendWith HRight xpos else hCut HRight (-xpos)) + $ small + smallLines = asciiLines small' + lines' = zipWith f bigLines (smallLines ++ repeat "") + f bl sl = zipWith g bl (sl ++ repeat ' ') + g b s = if transparent s then b else s + +-- | A version of 'pasteOnto' where we can specify the corner of the second picture +-- to which the offset is relative: +-- +-- > pasteOntoRel (HLeft,VTop) == pasteOnto +-- +pasteOntoRel :: (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII +pasteOntoRel = pasteOntoRel' isSpace + +pasteOntoRel' :: (Char -> Bool) -> (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII +pasteOntoRel' transparent (halign,valign) (xpos,ypos) small big = new where + new = pasteOnto' transparent (xpos',ypos') small big + (xsize,ysize) = asciiSize big + xpos' = case halign of + HLeft -> xpos + HCenter -> xpos + div xsize 2 + HRight -> xpos + xsize + ypos' = case valign of + VTop -> ypos + VCenter -> ypos + div ysize 2 + VBottom -> ypos + ysize + +-------------------------------------------------------------------------------- +-- * Tabulate + +-- | Tabulates the given matrix of pictures. Example: +-- +-- > tabulate (HCenter, VCenter) (HSepSpaces 2, VSepSpaces 1) +-- > [ [ asciiFromLines [ "x=" ++ show x , "y=" ++ show y ] | x<-[7..13] ] +-- > | y<-[98..102] ] +-- +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 + +-------------------------------------------------------------------------------- +-- * Ready-made boxes + +-- | An ASCII border 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 border 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) '-' ++ "/" + +-- | A box simply filled with the given character +filledBox :: Char -> (Int,Int) -> ASCII +filledBox c (x0,y0) = asciiFromLines $ replicate y (replicate x c) where + x = max 0 x0 + y = max 0 y0 + +-- | A box of spaces +transparentBox :: (Int,Int) -> ASCII +transparentBox = filledBox ' ' + +-------------------------------------------------------------------------------- +-- * Testing \/ miscellanea + +-- | An integer +asciiNumber :: Int -> ASCII +asciiNumber = asciiShow + +asciiShow :: Show a => a -> ASCII +asciiShow = asciiFromLines . (:[]) . show + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Classes.hs b/src/Math/Combinat/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Classes.hs @@ -0,0 +1,66 @@ + +-- | Type classes for some common properties shared by different objects + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +module Math.Combinat.Classes where + +-------------------------------------------------------------------------------- + +-- | Emptyness +class CanBeEmpty a where + isEmpty :: a -> Bool + empty :: a + +-------------------------------------------------------------------------------- +-- * Partitions + +-- | Number of parts +class HasNumberOfParts a where + numberOfParts :: a -> Int + +-------------------------------------------------------------------------------- + +class HasWidth a where + width :: a -> Int + +class HasHeight a where + height :: a -> Int + +-------------------------------------------------------------------------------- + +-- | Weight (of partitions, tableaux, etc) +class HasWeight a where + weight :: a -> Int + +-------------------------------------------------------------------------------- + +-- | Duality (of partitions, tableaux, etc) +class HasDuality a where + dual :: a -> a + +-------------------------------------------------------------------------------- +-- * Tableau + +-- | Shape (of tableaux, skew tableaux) +class HasShape a s | a -> s where + shape :: a -> s + +-------------------------------------------------------------------------------- +-- * Trees + +-- | Number of nodes (of trees) +class HasNumberOfNodes t where + numberOfNodes :: t -> Int + +-- | Number of leaves (of trees) +class HasNumberOfLeaves t where + numberOfLeaves :: t -> Int + +-------------------------------------------------------------------------------- +-- * Permutations + +-- | Number of cycles (of partitions) +class HasNumberOfCycles p where + numberOfCycles :: p -> Int + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Compositions.hs b/src/Math/Combinat/Compositions.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Compositions.hs @@ -0,0 +1,109 @@ + +-- | Compositions. +-- +-- See eg. +-- + +module Math.Combinat.Compositions where + +-------------------------------------------------------------------------------- + +import System.Random + +import Math.Combinat.Sets ( randomChoice ) +import Math.Combinat.Numbers ( factorial , binomial ) +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * generating all compositions + +-- | A /composition/ of an integer @n@ into @k@ parts is an ordered @k@-tuple of nonnegative (sometimes positive) integers +-- whose sum is @n@. +type Composition = [Int] + +-- | Compositions fitting into a given shape and having a given degree. +-- The order is lexicographic, that is, +-- +-- > sort cs == cs where cs = compositions' shape k +-- +compositions' + :: [Int] -- ^ shape + -> Int -- ^ sum + -> [[Int]] +compositions' [] 0 = [[]] +compositions' [] _ = [] +compositions' shape@(s:ss) n = + [ x:xs | x <- [0..min s n] , xs <- compositions' ss (n-x) ] + +countCompositions' :: [Int] -> Int -> Integer +countCompositions' [] 0 = 1 +countCompositions' [] _ = 0 +countCompositions' shape@(s:ss) n = sum + [ countCompositions' ss (n-x) | x <- [0..min s n] ] + +-- | All positive compositions of a given number (filtrated by the length). +-- Total number of these is @2^(n-1)@ +allCompositions1 :: Int -> [[Composition]] +allCompositions1 n = map (\d -> compositions1 d n) [1..n] + +-- | All compositions fitting into a given shape. +allCompositions' :: [Int] -> [[Composition]] +allCompositions' shape = map (compositions' shape) [0..d] where d = sum shape + +-- | Nonnegative compositions of a given length. +compositions + :: Integral a + => a -- ^ length + -> a -- ^ sum + -> [[Int]] +compositions len' d' = compositions' (replicate len d) d where + len = fromIntegral len' + d = fromIntegral d' + +-- | # = \\binom { len+d-1 } { len-1 } +countCompositions :: Integral a => a -> a -> Integer +countCompositions len d = binomial (len+d-1) (len-1) + +-- | Positive compositions of a given length. +compositions1 + :: Integral a + => a -- ^ length + -> a -- ^ sum + -> [[Int]] +compositions1 len d + | len > d = [] + | otherwise = map plus1 $ compositions len (d-len) + where + plus1 = map (+1) + -- len = fromIntegral len' + -- d = fromIntegral d' + +countCompositions1 :: Integral a => a -> a -> Integer +countCompositions1 len d = countCompositions len (d-len) + +-------------------------------------------------------------------------------- +-- * random compositions + +-- | @randomComposition k n@ returns a uniformly random composition +-- of the number @n@ as an (ordered) sum of @k@ /nonnegative/ numbers +randomComposition :: RandomGen g => Int -> Int -> g -> ([Int],g) +randomComposition k n g0 = + if k<1 || n<0 + then error "randomComposition: k should be positive, and n should be nonnegative" + else (comp, g1) + where + (cs,g1) = randomChoice (k-1) (n+k-1) g0 + comp = pairsWith (\x y -> y-x-1) (0 : cs ++ [n+k]) + +-- | @randomComposition1 k n@ returns a uniformly random composition +-- of the number @n@ as an (ordered) sum of @k@ /positive/ numbers +randomComposition1 :: RandomGen g => Int -> Int -> g -> ([Int],g) +randomComposition1 k n g0 = + if k<1 || n +-- +-- +-- Based on: +-- +-- * Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY +-- +-- +-- +-- Note: This module GHC 7.8, since we use type-level naturals +-- to parametrize the 'Braid' type. +-- + + +{-# LANGUAGE + CPP, BangPatterns, + ScopedTypeVariables, ExistentialQuantification, + DataKinds, KindSignatures, Rank2Types, + TypeOperators, TypeFamilies, + StandaloneDeriving #-} + +module Math.Combinat.Groups.Braid where + +-------------------------------------------------------------------------------- + +import Data.Proxy +import GHC.TypeLits + +import Control.Monad + +import Data.List ( mapAccumL , foldl' ) + +import Data.Array.Unboxed +import Data.Array.ST +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Unsafe +import Data.Array.Base + +import Control.Monad.ST + +import System.Random + +import Math.Combinat.ASCII +import Math.Combinat.Sign +import Math.Combinat.Helper +import Math.Combinat.TypeLevel +import Math.Combinat.Numbers.Series + +import Math.Combinat.Permutations ( Permutation(..) , (!!!) ) +import qualified Math.Combinat.Permutations as P + +-------------------------------------------------------------------------------- +-- * Artin generators + +-- | A standard Artin generator of a braid: @Sigma i@ represents twisting +-- the neighbour strands @i@ and @(i+1)@, such that strand @i@ goes /under/ strand @(i+1)@. +-- +-- Note: The strands are numbered @1..n@. +data BrGen + = Sigma !Int -- ^ @i@ goes under @(i+1)@ + | SigmaInv !Int -- ^ @i@ goes above @(i+1)@ + deriving (Eq,Ord,Show) + +-- | The strand (more precisely, the first of the two strands) the generator twistes +brGenIdx :: BrGen -> Int +brGenIdx g = case g of + Sigma i -> i + SigmaInv i -> i + +brGenSign :: BrGen -> Sign +brGenSign g = case g of + Sigma _ -> Plus + SigmaInv _ -> Minus + +brGenSignIdx :: BrGen -> (Sign,Int) +brGenSignIdx g = case g of + Sigma i -> (Plus ,i) + SigmaInv i -> (Minus,i) + +-- | The inverse of a braid generator +invBrGen :: BrGen -> BrGen +invBrGen g = case g of + Sigma i -> SigmaInv i + SigmaInv i -> Sigma i + +-------------------------------------------------------------------------------- +-- * The braid type + +-- | The braid group @B_n@ on @n@ strands. +-- The number @n@ is encoded as a type level natural in the type parameter. +-- +-- Braids are represented as words in the standard generators and their +-- inverses. +newtype Braid (n :: Nat) = Braid [BrGen] deriving (Show) + +-- | The number of strands in the braid +numberOfStrands :: KnownNat n => Braid n -> Int +numberOfStrands = fromInteger . natVal . braidProxy where + braidProxy :: Braid n -> Proxy n + braidProxy _ = Proxy + +-- | Sometimes we want to hide the type-level parameter @n@, for example when +-- dynamically creating braids whose size is known only at runtime. +data SomeBraid = forall n. KnownNat n => SomeBraid (Braid n) + +someBraid :: Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid +someBraid n polyBraid = + case snat of + SomeNat pxy -> SomeBraid (asProxyTypeOf1 polyBraid pxy) + where + snat = case someNatVal (fromIntegral n :: Integer) of + Just sn -> sn + Nothing -> error "someBraid: input is not a natural number" + +withSomeBraid :: SomeBraid -> (forall n. KnownNat n => Braid n -> a) -> a +withSomeBraid sbraid f = case sbraid of SomeBraid braid -> f braid + +mkBraid :: (forall n. KnownNat n => Braid n -> a) -> Int -> [BrGen] -> a +mkBraid f n w = y where + sb = someBraid n (Braid w) + y = withSomeBraid sb f + +withBraid + :: Int + -> (forall (n :: Nat). KnownNat n => Braid n) + -> (forall (n :: Nat). KnownNat n => Braid n -> a) + -> a +withBraid n polyBraid f = + case snat of + SomeNat pxy -> f (asProxyTypeOf1 polyBraid pxy) + where + snat = case someNatVal (fromIntegral n :: Integer) of + Just sn -> sn + Nothing -> error "withBraid: input is not a natural number" + +-------------------------------------------------------------------------------- + +braidWord :: Braid n -> [BrGen] +braidWord (Braid gs) = gs + +braidWordLength :: Braid n -> Int +braidWordLength (Braid gs) = length gs + +-- | Embeds a smaller braid group into a bigger braid group +extend :: (n1 <= n2) => Braid n1 -> Braid n2 +extend (Braid gs) = Braid gs + +-- | Apply \"free reduction\" to the word, that is, iteratively remove @sigma_i sigma_i^-1@ pairs. +-- The resulting braid is clearly equivalent to the original. +freeReduceBraidWord :: Braid n -> Braid n +freeReduceBraidWord (Braid orig) = Braid (loop orig) where + + loop w = case reduceStep w of + Nothing -> w + Just w' -> loop w' + + reduceStep :: [BrGen] -> Maybe [BrGen] + reduceStep = go False where + go !changed w = case w of + (Sigma x : SigmaInv y : rest) | x==y -> go True rest + (SigmaInv x : Sigma y : rest) | x==y -> go True rest + (this : rest) -> liftM (this:) $ go changed rest + _ -> if changed then Just w else Nothing + +-------------------------------------------------------------------------------- +-- * Some specific braids + +-- | The braid generator @sigma_i@ as a braid +sigma :: KnownNat n => Int -> Braid (n :: Nat) +sigma k = braid where + braid = if k > 0 && k < numberOfStrands braid + then Braid [Sigma k] + else error "sigma: braid generator index out of range" + +-- | The braid generator @sigma_i^(-1)@ as a braid +sigmaInv :: KnownNat n => Int -> Braid (n :: Nat) +sigmaInv k = braid where + braid = if k > 0 && k < numberOfStrands braid + then Braid [SigmaInv k] + else error "sigma: braid generator index out of range" + +-- | @doubleSigma s t@ (for s Int -> Int -> Braid (n :: Nat) +doubleSigma s t = braid where + n = numberOfStrands braid + braid + | s < 1 || s > n = error "doubleSigma: s index out of range" + | t < 1 || t > n = error "doubleSigma: t index out of range" + | s >= t = error "doubleSigma: s >= t" + | otherwise = Braid $ + [ Sigma i | i<-[t-1,t-2..s] ] ++ [ SigmaInv i | i<-[s+1..t-1] ] + +-- | @positiveWord [2,5,1]@ is shorthand for the word @sigma_2*sigma_5*sigma_1@. +positiveWord :: KnownNat n => [Int] -> Braid (n :: Nat) +positiveWord idxs = braid where + braid = Braid (map gen idxs) + n = numberOfStrands braid + gen i = if i>0 && i Braid n +halfTwist = braid where + braid = Braid $ map Sigma $ _halfTwist n + n = numberOfStrands braid + +-- | The untyped version of 'halfTwist' +_halfTwist :: Int -> [Int] +_halfTwist n = gens where + gens = concat [ sub k | k<-[1..n-1] ] + sub k = [ j | j<-[n-1,n-2..k] ] + +-- | Synonym for 'halfTwist' +theGarsideBraid :: KnownNat n => Braid n +theGarsideBraid = halfTwist + +-- | The inner automorphism defined by @tau(X) = Delta^-1 X Delta@, +-- where @Delta@ is the positive half-twist. +-- +-- This sends each generator @sigma_j@ to @sigma_(n-j)@. +-- +tau :: KnownNat n => Braid n -> Braid n +tau braid@(Braid gens) = Braid (map f gens) where + n = numberOfStrands braid + f (Sigma i) = Sigma (n-i) + f (SigmaInv i) = SigmaInv (n-i) + + +-- | The involution @tau@ on permutations (permutation braids) +-- +tauPerm :: Permutation -> Permutation +tauPerm perm = P.toPermutationUnsafeN n [ (n+1) - perm !!! (n-i) | i<-[0..n-1] ] where + n = P.permutationSize perm + +-------------------------------------------------------------------------------- +-- * Group operations + +-- | The trivial braid +identity :: Braid n +identity = Braid [] + +-- | The inverse of a braid. Note: we do not perform reduction here, +-- as a word is reduced if and only if its inverse is reduced. +inverse :: Braid n -> Braid n +inverse = Braid . reverse . map invBrGen . braidWord + +-- | Composes two braids, doing free reduction on the result +-- (that is, removing @(sigma_k * sigma_k^-1)@ pairs@) +compose :: Braid n -> Braid n -> Braid n +compose (Braid gs) (Braid hs) = freeReduceBraidWord $ Braid (gs++hs) + +composeMany :: [Braid n] -> Braid n +composeMany = freeReduceBraidWord . Braid . concat . map braidWord + +-- | Composes two braids without doing any reduction. +composeDontReduce :: Braid n -> Braid n -> Braid n +composeDontReduce (Braid gs) (Braid hs) = Braid (gs++hs) + +-------------------------------------------------------------------------------- +-- * Braid permutations + +-- | A braid is pure if its permutation is trivial +isPureBraid :: KnownNat n => Braid n -> Bool +isPureBraid braid = (braidPermutation braid == P.identityPermutation n) where + n = numberOfStrands braid + +-- | Returns the left-to-right permutation associated to the braid. +-- We follow the strands /from the left to the right/ (or from the top to the +-- bottom), and return the permutation taking the left side to the right side. +-- +-- This is compatible with /right/ (standard) action of the permutations: +-- @permuteRight (braidPermutationRight b1)@ corresponds to the left-to-right +-- permutation of the strands; also: +-- +-- > (braidPermutation b1) `multiply` (braidPermutation b2) == braidPermutation (b1 `compose` b2) +-- +-- Writing the right numbering of the strands below the left numbering, +-- we got the two-line notation of the permutation. +-- +braidPermutation :: KnownNat n => Braid n -> Permutation +braidPermutation braid@(Braid gens) = perm where + n = numberOfStrands braid + perm = _braidPermutation n (map brGenIdx gens) + +-- | This is an untyped version of 'braidPermutation' +_braidPermutation :: Int -> [Int] -> Permutation +_braidPermutation n idxs = P.uarrayToPermutationUnsafe (runSTUArray action) where + + action :: forall s. ST s (STUArray s Int Int) + action = do + arr <- newArray_ (1,n) + forM_ [1..n] $ \i -> writeArray arr i i + worker arr idxs + return arr + + worker arr = go where + go [] = return arr + go (i:is) = do + a <- readArray arr i + b <- readArray arr (i+1) + writeArray arr i b + writeArray arr (i+1) a + go is + +-------------------------------------------------------------------------------- +-- * Permutation braids + +-- | A positive braid word contains only positive (@Sigma@) generators. +isPositiveBraidWord :: KnownNat n => Braid n -> Bool +isPositiveBraidWord (Braid gs) = all (isPlus . brGenSign) gs + +-- | A /permutation braid/ is a positive braid where any two strands cross +-- at most one, and /positively/. +-- +isPermutationBraid :: KnownNat n => Braid n -> Bool +isPermutationBraid braid = isPositiveBraidWord braid && crosses where + crosses = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] + check i j = zeroOrOne (lkMatrix ! (i,j)) + zeroOrOne a = (a==1 || a==0) + lkMatrix = linkingMatrix braid + n = numberOfStrands braid + +-- | Untyped version of 'isPermutationBraid' for positive words. +_isPermutationBraid :: Int -> [Int] -> Bool +_isPermutationBraid n gens = crosses where + crosses = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] + check i j = zeroOrOne (lkMatrix ! (i,j)) + zeroOrOne a = (a==1 || a==0) + lkMatrix = _linkingMatrix n $ map Sigma gens + +-- | For any permutation this functions returns a /permutation braid/ realizing +-- that permutation. Note that this is not unique, so we make an arbitrary choice +-- (except for the permutation @[n,n-1..1]@ reversing the order, in which case +-- the result must be the half-twist braid). +-- +-- The resulting braid word will have a length at most @choose n 2@ (and will have +-- that length only for the permutation @[n,n-1..1]@) +-- +-- > braidPermutationRight (permutationBraid perm) == perm +-- > isPermutationBraid (permutationBraid perm) == True +-- +permutationBraid :: KnownNat n => Permutation -> Braid n +permutationBraid perm = braid where + n1 = numberOfStrands braid + n2 = P.permutationSize perm + braid = if n1 == n2 + then Braid (map Sigma $ _permutationBraid perm) + else error $ "permutationBraid: incompatible n: " ++ show n1 ++ " vs. " ++ show n2 + +-- | Untyped version of 'permutationBraid' +_permutationBraid :: Permutation -> [Int] +_permutationBraid = concat . _permutationBraid' + +-- | Returns the individual \"phases\" of the a permutation braid realizing the +-- given permutation. +_permutationBraid' :: Permutation -> [[Int]] +_permutationBraid' perm = runST action where + n = P.permutationSize perm + + action :: forall s. ST s [[Int]] + action = do + + -- cfwd = the current state of strands : cfwd!j = where is strand #j now? + -- cinv = the inverse of that permutation : cinv!i = which strand is on the #i position now? + + cfwd <- newArray_ (1,n) :: ST s (STUArray s Int Int) + cinv <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \j -> do + writeArray cfwd j j + writeArray cinv j j + + let doSwap i = do + a <- readArray cinv i + b <- readArray cinv (i+1) + writeArray cinv i b + writeArray cinv (i+1) a + + u <- readArray cfwd a + v <- readArray cfwd b + writeArray cfwd a v + writeArray cfwd b u + + -- at the k-th phase, we move the (inv!k)-th strand, which is the k-th strand /on the RHS/, to correct position. + let worker phase + | phase >= n = return [] + | otherwise = do + let tgt = P.lookupPermutation perm phase -- (arr ! phase) + src <- readArray cfwd tgt + let this = [src-1,src-2..phase] + mapM_ doSwap $ this + rest <- worker (phase+1) + return (this:rest) + + worker 1 + + +-- | We compute the linking numbers between all pairs of strands: +-- +-- > linkingMatrix braid ! (i,j) == strandLinking braid i j +-- +linkingMatrix :: KnownNat n => Braid n -> UArray (Int,Int) Int +linkingMatrix braid@(Braid gens) = _linkingMatrix (numberOfStrands braid) gens where + +-- | Untyped version of 'linkingMatrix' +_linkingMatrix :: Int -> [BrGen] -> UArray (Int,Int) Int +_linkingMatrix n gens = runSTUArray action where + + action :: forall s. ST s (STUArray s (Int,Int) Int) + action = do + perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \i -> writeArray perm i i + let doSwap :: Int -> ST s () + doSwap i = do + a <- readArray perm i + b <- readArray perm (i+1) + writeArray perm i b + writeArray perm (i+1) a + + mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int) + let doAdd :: Int -> Int -> Int -> ST s () + doAdd i j pm1 = do + x <- readArray mat (i,j) + writeArray mat (i,j) (x+pm1) + writeArray mat (j,i) (x+pm1) + + forM_ gens $ \g -> do + let (sgn,k) = brGenSignIdx g + u <- readArray perm k + v <- readArray perm (k+1) + doAdd u v (signValue sgn) + doSwap k + + return mat + + +-- | The linking number between two strands numbered @i@ and @j@ +-- (numbered such on the /left/ side). +strandLinking :: KnownNat n => Braid n -> Int -> Int -> Int +strandLinking braid@(Braid gens) i0 j0 + | i0 < 1 || i0 > n = error $ "strandLinkingNumber: invalid strand index i: " ++ show i0 + | j0 < 1 || j0 > n = error $ "strandLinkingNumber: invalid strand index j: " ++ show j0 + | i0 == j0 = 0 + | otherwise = go i0 j0 gens + where + n = numberOfStrands braid + + go !i !j [] = 0 + go !i !j (g:gs) + | i == k && j == k+1 = s + go (i+1) (j-1) gs + | j == k && i == k+1 = s + go (i-1) (j+1) gs + | i == k = go (i+1) j gs + | i == k+1 = go (i-1) j gs + | j == k = go i (j+1) gs + | j == k+1 = go i (j-1) gs + | otherwise = go i j gs + where + (sgn,k) = brGenSignIdx g + s = signValue sgn + +-------------------------------------------------------------------------------- +-- * Growth + +-- | Bronfman's recursive formula for the reciprocial of the growth function +-- of /positive/ braids. It was already known (by Deligne) that these generating functions +-- are reciprocials of polynomials; Bronfman [1] gave a recursive formula for them. +-- +-- > let count n l = length $ nub $ [ braidNormalForm w | w <- allPositiveBraidWords n l ] +-- > let convertPoly (1:cs) = zip (map negate cs) [1..] +-- > pseries' (convertPoly $ bronfmanH n) == expandBronfmanH n == [ count n l | l <- [0..] ] +-- +-- * [1] Aaron Bronfman: Growth functions of a class of monoids. Preprint, 2001 +-- +bronfmanH :: Int -> [Int] +bronfmanH n = bronfmanHsList !! n + +-- | An infinite list containing the Bronfman polynomials: +-- +-- > bronfmanH n = bronfmanHsList !! n +-- +bronfmanHsList :: [[Int]] +bronfmanHsList = list where + list = map go [0..] + go 0 = [1] + go n = sumSeries [ sgn i $ replicate (choose2 i) 0 ++ list !! (n-i) | i<-[1..n] ] + sgn i = if odd i then id else map negate + choose2 k = div (k*(k-1)) 2 + +-- | Expands the reciprocial of @H(n)@ into an infinite power series, +-- giving the growth function of the positive braids on @n@ strands. +expandBronfmanH :: Int -> [Int] +expandBronfmanH n = pseries' (convertPoly $ bronfmanH n) where + convertPoly (1:cs) = zip (map negate cs) [1..] + +-------------------------------------------------------------------------------- +-- * ASCII diagram + +instance KnownNat n => DrawASCII (Braid n) where + ascii = horizBraidASCII + +-- | Horizontal braid diagram, drawn from left to right, +-- with strands numbered from the bottom to the top +horizBraidASCII :: KnownNat n => Braid n -> ASCII +horizBraidASCII = horizBraidASCII' True + +-- | Horizontal braid diagram, drawn from left to right. +-- The boolean flag indicates whether to flip the strands +-- vertically ('True' means bottom-to-top, 'False' means top-to-bottom) +horizBraidASCII' :: KnownNat n => Bool -> Braid n -> ASCII +horizBraidASCII' flipped braid@(Braid gens) = final where + + n = numberOfStrands braid + + final = vExtendWith VTop 1 $ hCatTop allBlocks + allBlocks = prelude ++ middleBlocks ++ epilogue + prelude = [ numberBlock , spaceBlock , beginEndBlock ] + epilogue = [ beginEndBlock , spaceBlock , numberBlock' ] + middleBlocks = map block gens + + block g = case g of + Sigma i -> block' i $ if flipped then over else under + SigmaInv i -> block' i $ if flipped then under else over + + block' i middle = asciiFromLines $ drop 2 $ concat + $ replicate a horiz ++ [space3, middle] ++ replicate b horiz + where + (a,b) = if flipped then (n-i-1,i-1) else (i-1,n-i-1) + + -- cycleN :: Int -> [a] -> [a] + -- cycleN n = concat . replicate n + + spaceBlock = transparentBox (1,n*3-2) + beginEndBlock = asciiFromLines $ drop 2 $ concat $ replicate n horiz + numberBlock = mkNumbers [1..n] + numberBlock' = mkNumbers $ P.fromPermutation $ braidPermutation braid + + mkNumbers :: [Int] -> ASCII + mkNumbers list = vCatWith HRight (VSepSpaces 2) $ map asciiShow + $ (if flipped then reverse else id) $ list + + under = [ "\\ /" , " / " , "/ \\" ] + over = [ "\\ /" , " \\ " , "/ \\" ] + horiz = [ " " , " " , "___" ] + space3 = [ " " , " " , " " ] + +-------------------------------------------------------------------------------- + +{- this is unusably ugly and vertically loooong + +-- | Vertical braid diagram, drawn from the top to the bottom. +-- Strands are numbered from the left to the right. +-- +-- Writing down the strand numbers from the top and and the bottom +-- gives the two-line notation of the permutation realized by the braid. +-- +verticalBraidASCII :: KnownNat n => Braid n -> ASCII +verticalBraidASCII braid@(Braid gens) = final where + + n = numberOfStrands braid + + final = hExtendWith HLeft 1 $ vCatLeft allBlocks + allBlocks = prelude ++ middleBlocks ++ epilogue + prelude = [ numberBlock , spaceBlock , beginEndBlock ] + epilogue = [ beginEndBlock , spaceBlock , numberBlock' ] + middleBlocks = map block gens + + block g = case g of + Sigma i -> block' i under + SigmaInv i -> block' i over + + block' i middle = asciiFromLines (map f middle) where + f xs = drop 1 $ concat $ h (i-1) ++ [" ",xs] ++ h (n-i-1) + h k = replicate k " |" + + spaceBlock = transparentBox (n*3-2,1) + beginEndBlock = asciiFromLines $ replicate 3 $ drop 1 $ concat (replicate n " |") + numberBlock = mkNumbers [1..n] + numberBlock' = mkNumbers $ P.fromPermutation $ braidPermutation braid + + mkNumbers :: [Int] -> ASCII + mkNumbers list = asciiFromString (drop 1 $ concatMap show3 list) + show3 k = let s = show k + in replicate (3-length s) ' ' ++ s + + under = [ "\\ /" , " / " , "/ \\" ] + over = [ "\\ /" , " \\ " , "/ \\" ] + +-} + +-------------------------------------------------------------------------------- +-- * List of all words + +-- | All positive braid words of the given length +allPositiveBraidWords :: KnownNat n => Int -> [Braid n] +allPositiveBraidWords l = braids where + n = numberOfStrands (head braids) + braids = map Braid $ _allPositiveBraidWords n l + +-- | All braid words of the given length +allBraidWords :: KnownNat n => Int -> [Braid n] +allBraidWords l = braids where + n = numberOfStrands (head braids) + braids = map Braid $ _allBraidWords n l + +-- | Untyped version of 'allPositiveBraidWords' +_allPositiveBraidWords :: Int -> Int -> [[BrGen]] +_allPositiveBraidWords n = go where + go 0 = [[]] + go k = [ Sigma i : rest | i<-[1..n-1] , rest <- go (k-1) ] + +-- | Untyped version of 'allBraidWords' +_allBraidWords :: Int -> Int -> [[BrGen]] +_allBraidWords n = go where + go 0 = [[]] + go k = [ gen : rest | gen <- gens , rest <- go (k-1) ] + gens = concat [ [ Sigma i , SigmaInv i ] | i<-[1..n-1] ] + +-------------------------------------------------------------------------------- +-- * Random braids + +-- | Random braid word of the given length +randomBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g) +randomBraidWord len g = (braid, g') where + braid = Braid w + n = numberOfStrands braid + (w,g') = _randomBraidWord n len g + +-- | Random /positive/ braid word of the given length +randomPositiveBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g) +randomPositiveBraidWord len g = (braid, g') where + braid = Braid w + n = numberOfStrands braid + (w,g') = _randomPositiveBraidWord n len g + +-------------------------------------------------------------------------------- + +-- | Given a braid word, we perturb it randomly @m@ times using the braid relations, +-- so that the resulting new braid word is equivalent to the original. +-- +-- Useful for testing. +-- +randomPerturbBraidWord :: forall n g. (RandomGen g, KnownNat n) => Int -> Braid n -> g -> (Braid n, g) +randomPerturbBraidWord m braid@(Braid xs) g = (Braid word' , g') where + + (word',g') = go m (length xs) xs g + + n = numberOfStrands braid + + -- | A random pair cancelling each other + rndE :: g -> ([BrGen],g) + rndE g = (e1,g'') where + (i , g' ) = randomR (1,n-1) g + (b , g'' ) = random g' + e0 = [SigmaInv i, Sigma i] + e1 = if b then reverse e0 else e0 + + brg s i = case s of { Plus -> Sigma i ; Minus -> SigmaInv i } + brginv s i = case s of { Plus -> SigmaInv i ; Minus -> Sigma i } + + go :: Int -> Int -> [BrGen] -> g -> ([BrGen], g) + go !cnt !len !word !g + + | cnt <= 0 = (word, g) + + | len < 2 = let w' = if b1 then (e++word) else (word++e) -- if it is short, we just add a trivial pair somewhere + in continue g4 (len+2) w' + + | abs (i-j) >= 2 = continue g4 len (as ++ v:u:bs) -- they commute, so we just commute them + + | i == j && s/=t = continue g4 (len-2) (as ++ bs ) -- they are inverse of each other, so we kill them + + | abs (i-j) == 1 && s == t = let mid = if b1 + then [ brg s j , brg s i , brg s j , brginv s i ] -- insert pair and + else [ brginv s j , brg s i , brg s j , brg s i ] -- apply ternary relation + in continue g4 (len+2) (as ++ mid ++ bs) + + | otherwise = let mid = if b1 + then (u : e ++ [v]) + else if b2 + then [u,v] ++ e + else e ++ [u,v] + in continue g4 (len+2) (as++(u:e)++[v]++bs) -- otherwise we just insert an trivial pair + + where + + (pos , g1 ) = randomR (0,len-2) g + (b1 :: Bool , g2 ) = random g1 + (b2 :: Bool , g3 ) = random g2 + (e , g4 ) = rndE g3 + (as,u:v:bs) = splitAt pos word + (s,i) = brGenSignIdx u + (t,j) = brGenSignIdx v + + continue g' len' word' = go (cnt-1) len' word' g' + +-------------------------------------------------------------------------------- + +-- | This version of 'randomBraidWord' may be convenient to avoid the type level stuff +withRandomBraidWord + :: RandomGen g + => (forall n. KnownNat n => Braid n -> a) + -> Int -- ^ number of strands + -> Int -- ^ length of the random word + -> g -> (a, g) +withRandomBraidWord f n len = runRand $ do + withSelectedM f (rand $ randomBraidWord len) n + +-- | This version of 'randomPositiveBraidWord' may be convenient to avoid the type level stuff +withRandomPositiveBraidWord + :: RandomGen g + => (forall n. KnownNat n => Braid n -> a) + -> Int -- ^ number of strands + -> Int -- ^ length of the random word + -> g -> (a, g) +withRandomPositiveBraidWord f n len = runRand $ do + withSelectedM f (rand $ randomPositiveBraidWord len) n + +-- | Untyped version of 'randomBraidWord' +_randomBraidWord + :: (RandomGen g) + => Int -- ^ number of strands + -> Int -- ^ length of the random word + -> g -> ([BrGen], g) +_randomBraidWord n len = runRand $ replicateM len $ do + k <- randChoose (1,n-1) + s <- randRoll + return $ case s of + Plus -> Sigma k + Minus -> SigmaInv k + +-- | Untyped version of 'randomPositiveBraidWord' +_randomPositiveBraidWord + :: (RandomGen g) + => Int -- ^ number of strands + -> Int -- ^ length of the random word + -> g -> ([BrGen], g) +_randomPositiveBraidWord n len = runRand $ replicateM len $ do + liftM Sigma $ randChoose (1,n-1) + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Groups/Braid/NF.hs b/src/Math/Combinat/Groups/Braid/NF.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Groups/Braid/NF.hs @@ -0,0 +1,536 @@ + +-- | Normal form of braids, take 1. +-- +-- We implement the Adyan-Thurston-ElRifai-Morton solution to the word problem in braid groups. +-- +-- +-- Based on: +-- +-- * [1] Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY +-- (chapter 5.1) +-- +-- * [2] Elsayed A. Elrifai, Hugh R. Morton: Algorithms for positive braids +-- + +{-# LANGUAGE + CPP, BangPatterns, + ScopedTypeVariables, ExistentialQuantification, + DataKinds, KindSignatures, Rank2Types #-} + +module Math.Combinat.Groups.Braid.NF + ( -- * Normal form + BraidNF (..) + , nfReprWord + , braidNormalForm + , braidNormalForm' + , braidNormalFormNaive' + -- * Starting and finishing sets + , permWordStartingSet + , permWordFinishingSet + , permutationStartingSet + , permutationFinishingSet + ) + where + +-------------------------------------------------------------------------------- + +import Data.Proxy +import GHC.TypeLits + +import Control.Monad + +import Data.List ( mapAccumL , foldl' , (\\) ) + +import Data.Array.Unboxed +import Data.Array.ST +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Unsafe +import Data.Array.Base + +import Control.Monad.ST + +import Math.Combinat.Helper +import Math.Combinat.Sign + +import Math.Combinat.Permutations ( Permutation(..) , (!!!) , isIdentityPermutation , isReversePermutation ) +import qualified Math.Combinat.Permutations as P + +import Math.Combinat.Groups.Braid + +-------------------------------------------------------------------------------- + +-- | A unique normal form for braids, called the /left-greedy normal form/. +-- It looks like @Delta^i*P@, where @Delta@ is the positive half-twist, @i@ is an integer, +-- and @P@ is a positive word, which can be further decomposed into non-@Delta@ /permutation words/; +-- these words themselves are not unique, but the permutations they realize /are/ unique. +-- +-- This will solve the word problem relatively fast, +-- though it is not the fastest known algorithm. +-- +data BraidNF (n :: Nat) = BraidNF + { _nfDeltaExp :: !Int -- ^ the exponent of @Delta@ + , _nfPerms :: [Permutation] -- ^ the permutations + } + deriving (Eq,Ord,Show) + +-- | A braid word representing the given normal form +nfReprWord :: KnownNat n => BraidNF n -> Braid n +nfReprWord (BraidNF k perms) = freeReduceBraidWord $ composeMany (deltas ++ rest) where + + deltas + | k > 0 = replicate k halfTwist + | k < 0 = replicate (-k) (inverse halfTwist) + | otherwise = [] + + rest = map permutationBraid perms + +-------------------------------------------------------------------------------- + +-- | Computes the normal form of a braid. We apply free reduction first, it should be faster that way. +braidNormalForm :: KnownNat n => Braid n -> BraidNF n +braidNormalForm = braidNormalForm' . freeReduceBraidWord + +-- | This function does not apply free reduction before computing the normal form +braidNormalForm' :: KnownNat n => Braid n -> BraidNF n +braidNormalForm' braid@(Braid gens) = BraidNF (dexp+pexp) perms where + n = numberOfStrands braid + invless = replaceInverses n gens + (dexp,posxword) = moveDeltasLeft n invless + factors = leftGreedyFactors n $ expandPosXWord n posxword + (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors + +-- | This one uses the naive inverse replacement method. Probably somewhat slower than 'braidNormalForm''. +braidNormalFormNaive' :: KnownNat n => Braid n -> BraidNF n +braidNormalFormNaive' braid@(Braid gens) = BraidNF (dexp+pexp) perms where + n = numberOfStrands braid + invless = replaceInversesNaive gens + (dexp,posxword) = moveDeltasLeft n invless + factors = leftGreedyFactors n $ expandPosXWord n posxword + (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors + +-------------------------------------------------------------------------------- + +-- | Replaces groups of @sigma_i^-1@ generators by @(Delta^-1 * P)@, +-- where @P@ is a positive word. +-- +-- This should be more clever (resulting in shorter words) than the naive version below +-- +replaceInverses :: Int -> [BrGen] -> [XGen] +replaceInverses n gens = worker gens where + + worker [] = [] + worker xs = replaceNegs neg ++ map (XSigma . brGenIdx) pos ++ worker rest where + (neg,tmp ) = span (isMinus . brGenSign) xs + (pos,rest) = span (isPlus . brGenSign) tmp + + replaceNegs gs = concatMap replaceFac facs where + facs = leftGreedyFactors n $ map brGenIdx gs + + replaceFac idxs = XDelta (-1) : map XSigma (_permutationBraid perm) where + perm = (P.reversePermutation n) `P.multiplyPermutation` (P.adjacentTranspositions n idxs) + + +-- | Replaces @sigma_i^-1@ generators by @(Delta^-1 * L_i)@. +replaceInversesNaive :: [BrGen] -> [XGen] +replaceInversesNaive gens = concatMap f gens where + f (Sigma i) = [ XSigma i ] + f (SigmaInv i) = [ XDelta (-1) , XL i ] + +-------------------------------------------------------------------------------- + +-- | Temporary data structure to be used during the normal form computation +data XGen + = XDelta !Int -- ^ @Delta^k@ + | XSigma !Int -- ^ @Sigma_j@ + | XL !Int -- ^ @L_j = Delta * sigma_j^-1@ + | XTauL !Int -- ^ @tau(L_j)@ + deriving (Eq,Show) + +isXDelta :: XGen -> Bool +isXDelta x = case x of { XDelta {} -> True ; _ -> False } + +-- | We move the all @Delta@'s to the left +moveDeltasLeft :: Int -> [XGen] -> (Int,[XGen]) +moveDeltasLeft n input = (finalExp, finalPosWord) where + + (XDelta finalExp : finalPosWord) = reverse $ worker 0 (reverse input) + + -- we start from the right end, and work towards the left end + worker dexp [] = [ XDelta dexp ] + worker !dexp xs = this' ++ worker dexp' rest where + (delta,notdelta) = span isXDelta xs + (this ,rest ) = span (not . isXDelta) notdelta + dexp' = dexp + sumDeltas delta + this' = if even dexp' + then this + else map xtau this + + sumDeltas :: [XGen] -> Int + sumDeltas xs = foldl' (+) 0 [ k | XDelta k <- xs ] + + -- | The @X -> Delta^-1 * X * Delta@ inner automorphism + xtau :: XGen -> XGen + xtau (XSigma j) = XSigma (n-j) + xtau (XDelta k) = XDelta k + xtau (XL k) = XTauL k + xtau (XTauL k) = XL k + +-------------------------------------------------------------------------------- + +-- | Expands a /positive/ \"X-word\" into a positive braid word +expandPosXWord :: Int -> [XGen] -> [Int] +expandPosXWord n = concatMap f where + + posHalfTwist = _halfTwist n + + jtau :: Int -> Int + jtau j = n-j + + posLTable = listArray (1,n-1) [ _permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int [Int] + posTauLTable = amap (map jtau) posLTable + + -- posRTable = listArray (1,n-1) [ _permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int [Int] + + f x = case x of + XSigma i -> [i] + XL i -> posLTable ! i + XTauL i -> posTauLTable ! i + XDelta i + | i > 0 -> concat (replicate i posHalfTwist) + | i < 0 -> error "expandPosXWord: negative delta power" + | otherwise -> [] + + -- word :: Braid n -> [Int] + -- word (Braid gens) = map brGenIdx gens + + +-- | Expands an \"X-word\" into a braid word. Useful for debugging. +expandAnyXWord :: forall n. KnownNat n => [XGen] -> Braid n +expandAnyXWord xgens = braid where + n = numberOfStrands braid + + braid = composeMany (map f xgens) + + posHalfTwist = halfTwist :: Braid n + negHalfTwist = inverse posHalfTwist :: Braid n + + posLTable = listArray (1,n-1) [ permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n) + posTauLTable = amap tau posLTable + + -- posRTable = listArray (1,n-1) [ permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n) + + f :: XGen -> Braid n + f x = case x of + XSigma i -> sigma i + XL i -> posLTable ! i + XTauL i -> posTauLTable ! i + XDelta i + | i > 0 -> composeMany (replicate i posHalfTwist) + | i < 0 -> composeMany (replicate (-i) negHalfTwist) + | otherwise -> identity + +-------------------------------------------------------------------------------- + +-- | @posL k@ (denoted as @L_k@) is a /positive word/ which +-- satisfies @Delta = L_k * sigma_k@, or: +-- +-- > (inverse halfTwist) `compose` (posL k) ~=~ sigmaInv k@ +-- +-- Thus we can replace any word with a positive word plus some @Delta^-1@\'s +-- +posL :: KnownNat n => Int -> Braid n +posL k = braid where + n = numberOfStrands braid + braid = permutationBraid (posLPerm n k) + +-- | @posR k n@ (denoted as @R_k@) is a /permutation braid/ which +-- satisfies @Delta = sigma_k * R_k@ +-- +-- > (posR k) `compose` (inverse halfTwist) ~=~ sigmaInv k@ +-- +-- Thus we can replace any word with a positive word plus some @Delta^-1@'s +-- +posR :: KnownNat n => Int -> Braid n +posR k = braid where + n = numberOfStrands braid + braid = permutationBraid (posRPerm n k) + +-- | The permutation @posL k :: Braid n@ is realizing +posLPerm :: Int -> Int -> Permutation +posLPerm n k + | k>0 && k Int -> Permutation +posRPerm n k + | k>0 && k [[Int]] -> (Int, [[Int]]) +filterDeltaFactors n facs = (exp',facs'') where + + (exp',facs') = go 0 (reverse facs) + + jtau j = n-j + facs'' = reverse facs' + maxlen = div (n*(n-1)) 2 + + go !e [] = (e,[]) + go !e (xs:xxs) + | null xs = go e xxs + | length xs == maxlen = go (e+1) xxs + | otherwise = + if even e + then let (e',yys) = go e xxs in (e' , xs : yys) + else let (e',yys) = go e xxs in (e' , map jtau xs : yys) + +-------------------------------------------------------------------------------- + +-- | The /starting set/ of a positive braid P is the subset of @[1..n-1]@ defined by +-- +-- > S(P) = [ i | P = sigma_i * Q , Q is positive ] = [ i | (sigma_i^-1 * P) is positive ] +-- +-- This function returns the starting set a positive word, assuming it +-- is a /permutation braid/ (see Lemma 2.4 in [2]) +-- +permWordStartingSet :: Int -> [Int] -> [Int] +permWordStartingSet n xs = permWordFinishingSet n (reverse xs) + +-- | The /finishing set/ of a positive braid P is the subset of @[1..n-1]@ defined by +-- +-- > F(P) = [ i | P = Q * sigma_i , Q is positive ] = [ i | (P * sigma_i^-1) is positive ] +-- +-- This function returns the finishing set, assuming the input is a /permutation braid/ +-- +permWordFinishingSet :: Int -> [Int] -> [Int] +permWordFinishingSet n input = runST action where + + action :: forall s. ST s [Int] + action = do + perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \i -> writeArray perm i i + forM_ input $ \i -> do + a <- readArray perm i + b <- readArray perm (i+1) + writeArray perm i b + writeArray perm (i+1) a + flip filterM [1..n-1] $ \i -> do + a <- readArray perm i + b <- readArray perm (i+1) + return (b permutationStartingSet p == permWordStartingSet n (_permutationBraid p) +-- +permutationStartingSet :: Permutation -> [Int] +permutationStartingSet = permutationFinishingSet . P.inversePermutation + +-- | This satisfies +-- +-- > permutationFinishingSet p == permWordFinishingSet n (_permutationBraid p) +-- +permutationFinishingSet :: Permutation -> [Int] +permutationFinishingSet perm + = [ i | i<-[1..n-1] , perm !!! i > perm !!! (i+1) ] where n = P.permutationSize perm + +-- | Returns the list of permutations failing Lemma 2.5 in [2] +-- (so an empty list means the implementaton is correct) +fails_lemmma_2_5 :: Int -> [Permutation] +fails_lemmma_2_5 n = [ p | p <- P.permutations n , not (test p) ] where + test p = and [ check i | i<-[1..n-1] ] where + w = _permutationBraid p + s = permWordStartingSet n w + check i = _isPermutationBraid n (i:w) == (not $ elem i s) + +-------------------------------------------------------------------------------- + +-- | Given factors defined as permutation braids, we normalize them +-- to /left-canonical form/ by ensuring that +-- +-- * for each consecutive pair @(P,Q)@ the finishing set F(P) contains the starting set S(Q) +-- +-- * all @Delta@-s (corresponding to the reverse permutation) are moved to the left +-- +-- * all trivial factors are filtered out +-- +-- Unfortunately, it seems that we may need multiple sweeps to do that... +-- +normalizePermFactors :: Int -> [Permutation] -> (Int,[Permutation]) +normalizePermFactors n = go 0 where + go !acc input = + if (exp==0 && input == output) + then (acc,input) + else go (acc+exp) output + where + (exp,output) = normalizePermFactors1 n input + +-- | Does 1 sweep of the above normalization process. +-- Unfortunately, it seems that we may need to do this multiple times... +-- +normalizePermFactors1 :: Int -> [Permutation] -> (Int,[Permutation]) +normalizePermFactors1 n input = (exp, reverse output) where + (exp, output) = worker 0 (reverse input) + + -- Notes: We work in reverse order, from the right to the left. + -- We maintain the number of Delta-s pushed through; the tau involutions + -- are implicit in the parity of this number + -- + worker :: Int -> [Permutation] -> (Int,[Permutation]) + worker = worker' 0 0 + + -- We also maintain additional 0/1 flip flags for the first two permutations + -- this is a little bit of hack but it should work nicely + -- + worker' :: Int -> Int -> Int -> [Permutation] -> (Int,[Permutation]) + worker' !ep !eq !e (!p : rest@(!q : rest')) + + -- check if the very first element is identity or Delta + -- (note: these are tau-invariants) + + | isIdentityPermutation p = worker' eq 0 e rest + | isReversePermutation p = worker' eq 0 (e+1) rest + + -- check if the second element is identity or Delta + -- this is necessary since we "fatten" the second element and it can possibly + -- become Delta after a while (?) + + | isIdentityPermutation q = worker' ep 0 e (p : rest') + | isReversePermutation q = worker' (ep-1) 0 (e+1) (p : rest') + + -- ok so we have something like "... : Q : P" + -- if F(Q) contains S(P) then we can move on; + -- otherwise there is an element j in S(P) \\ F(Q), so we can + -- replace it by "... : Qj : jP" + + | otherwise = + case permutationStartingSet preal \\ permutationFinishingSet qreal of + [] -> let (e',rs) = worker' eq 0 e rest in (e', preal : rs) + (j:_) -> worker' (-e) (-e) e (p':q':rest') where + s = P.adjacentTransposition n j + p' = P.multiplyPermutation s preal + q' = P.multiplyPermutation qreal s + where + preal = oddTau (e+ep) p -- the "real" p + qreal = oddTau (e+eq) q -- the "real" q + + worker' _ _ !e [ ] = (e,[]) + worker' !ep _ !e [p] + | isIdentityPermutation p = (e , []) + | isReversePermutation p = (e+1 , []) + | otherwise = (e , [oddTau (e+ep) p] ) + + oddTau :: Int -> Permutation -> Permutation + oddTau !e p = if even e then p else tauPerm p + +{- + checkDelta :: Int -> Permutation -> [Permutation] -> (Int,[Permutation]) + checkDelta !e !p !rest + | P.isIdentityPermutation p = worker e rest + | isReversePermutation p = worker (e+1) rest + | otherwise = let (e',rs) = worker e rest in (e', oddTau e p : rs) +-} + +-------------------------------------------------------------------------------- + +-- | Given a /positive/ word, we apply left-greedy factorization of +-- that word into subwords representing /permutation braids/. +-- +-- Example 5.1 from the above handbook: +-- +-- > leftGreedyFactors 7 [1,3,2,2,1,3,3,2,3,2] == [[1,3,2],[2,1,3],[3,2,3],[2]] +-- +leftGreedyFactors :: Int -> [Int] -> [[Int]] +leftGreedyFactors n input = filter (not . null) $ runST (action input) where + + action :: forall s. [Int] -> ST s [[Int]] + action input = do + + perm <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \i -> writeArray perm i i + let doSwap :: Int -> ST s () + doSwap i = do + a <- readArray perm i + b <- readArray perm (i+1) + writeArray perm i b + writeArray perm (i+1) a + + mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int) + let clearMat = forM_ [1..n] $ \i -> + forM_ [1..n] $ \j -> writeArray mat (i,j) 0 + + let doAdd1 :: Int -> Int -> ST s Int + doAdd1 i j = do + x <- readArray mat (i,j) + let y = x+1 + writeArray mat (i,j) y + writeArray mat (j,i) y + return y + + let worker :: [Int] -> ST s [[Int]] + worker [] = return [[]] + worker (p:ps) = do + u <- readArray perm p + v <- readArray perm (p+1) + c <- doAdd1 u v + doSwap p + if c<=1 + then do + ffs <- worker ps + case ffs of + (f:fs) -> return ((p:f):fs) + _ -> error "Braid/NF/leftGreedyFactors/worker: fatal error; should not happen" + else do + clearMat + fs <- worker (p:ps) + return ([]:fs) + + worker input + +-------------------------------------------------------------------------------- + +{- + +-- | Finds ternary braid relations, and returns them as a list of indices, decorated +-- with a flag specifying which side of the relation we found, a sign specifying +-- whether it is a relation between positive or negative generators. +-- +findTernaryBraidRelations :: Braid n -> [(Int,Bool,Sign)] +findTernaryBraidRelations (Braid gens) = go 0 gens where + go !k (Sigma a : rest@(Sigma b : Sigma c : _)) + | a==c && b==a+1 = (k,True ,Plus) : go (k+1) rest + | a==c && b==a-1 = (k,False,Plus) : go (k+1) rest + | otherwise = go (k+1) rest + go !k (SigmaInv a : rest@(SigmaInv b : SigmaInv c : _)) + | a==c && b==a+1 = (k,True ,Minus) : go (k+1) rest + | a==c && b==a-1 = (k,False,Minus) : go (k+1) rest + | otherwise = go (k+1) rest + go !k (x:xs) = go (k+1) xs + go _ [] = [] + +-- | Finds subsequences like @(i,i+1,i)@ and @(i+1,i,i+1)@, and returns them +-- and a list of indices, plus a flag specifying which one we found (the first +-- one is 'True', second one is 'False') +-- +_findTernaryBraidRelations :: [Int] -> [(Int,Bool)] +_findTernaryBraidRelations = go 0 where + go !k (a:rest@(b:c:_)) + | a==c && b==a+1 = (k,True ) : go (k+1) rest + | a==c && b==a-1 = (k,False) : go (k+1) rest + | otherwise = go (k+1) rest + go !k (x:xs) = go (k+1) xs + go _ [] = [] + +-} + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Groups/Free.hs b/src/Math/Combinat/Groups/Free.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Groups/Free.hs @@ -0,0 +1,523 @@ + +-- | Words in free groups (and free powers of cyclic groups). +-- +-- This module is not re-exported by "Math.Combinat" +-- +{-# LANGUAGE CPP, BangPatterns, PatternGuards #-} +module Math.Combinat.Groups.Free where + +-------------------------------------------------------------------------------- + +-- new Base exports "Word" from Data.Word... +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,7,1) +import Prelude hiding ( Word ) +#endif +#elif __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ( Word ) +#endif + +import Data.Char ( chr ) +import Data.List ( mapAccumL , groupBy ) + +import Control.Monad ( liftM ) +import System.Random + +import Math.Combinat.Numbers +import Math.Combinat.Sign +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * Words + +-- | A generator of a (free) group, indexed by which \"copy\" of the group we are dealing with. +data Generator idx + = Gen !idx -- @a@ + | Inv !idx -- @a^(-1)@ + deriving (Eq,Ord,Show,Read) + +-- | The index of a generator +genIdx :: Generator idx -> idx +genIdx g = case g of + Gen x -> x + Inv x -> x + +-- | The sign of the (exponent of the) generator (that is, the generator is 'Plus', the inverse is 'Minus') +genSign :: Generator idx -> Sign +genSign g = case g of { Gen _ -> Plus ; Inv _ -> Minus } + +genSignValue :: Generator idx -> Int +genSignValue g = case g of { Gen _ -> (1::Int) ; Inv _ -> (-1::Int) } + +-- | keep the index, but return always the 'Gen' one. +absGen :: Generator idx -> Generator idx +absGen g = case g of + Gen x -> Gen x + Inv x -> Gen x + +-- | A /word/, describing (non-uniquely) an element of a group. +-- The identity element is represented (among others) by the empty word. +type Word idx = [Generator idx] + +-------------------------------------------------------------------------------- + +-- | Generators are shown as small letters: @a@, @b@, @c@, ... +-- and their inverses are shown as capital letters, so @A=a^-1@, @B=b^-1@, etc. +showGen :: Generator Int -> Char +showGen (Gen i) = chr (96+i) +showGen (Inv i) = chr (64+i) + +showWord :: Word Int -> String +showWord = map showGen + +-------------------------------------------------------------------------------- + +instance Functor Generator where + fmap f g = case g of + Gen x -> Gen (f x) + Inv y -> Inv (f y) + +-------------------------------------------------------------------------------- + +-- | The inverse of a generator +inverseGen :: Generator a -> Generator a +inverseGen g = case g of + Gen x -> Inv x + Inv x -> Gen x + +-- | The inverse of a word +inverseWord :: Word a -> Word a +inverseWord = map inverseGen . reverse + +-- | Lists all words of the given length (total number will be @(2g)^n@). +-- The numbering of the generators is @[1..g]@. +allWords + :: Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word + -> [Word Int] +allWords g = go where + go !0 = [[]] + go !n = [ x:xs | xs <- go (n-1) , x <- elems ] + elems = [ Gen a | a<-[1..g] ] + ++ [ Inv a | a<-[1..g] ] + +-- | Lists all words of the given length which do not contain inverse generators +-- (total number will be @g^n@). +-- The numbering of the generators is @[1..g]@. +allWordsNoInv + :: Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word + -> [Word Int] +allWordsNoInv g = go where + go !0 = [[]] + go !n = [ x:xs | xs <- go (n-1) , x <- elems ] + elems = [ Gen a | a<-[1..g] ] + +-------------------------------------------------------------------------------- +-- * Random words + +-- | A random group generator (or its inverse) between @1@ and @g@ +randomGenerator + :: RandomGen g + => Int -- ^ @g@ = number of generators + -> g -> (Generator Int, g) +randomGenerator !d !g0 = (gen, g2) where + (b, !g1) = random g0 + (k, !g2) = randomR (1,d) g1 + gen = if b then Gen k else Inv k + +-- | A random group generator (but never its inverse) between @1@ and @g@ +randomGeneratorNoInv + :: RandomGen g + => Int -- ^ @g@ = number of generators + -> g -> (Generator Int, g) +randomGeneratorNoInv !d !g0 = (Gen k, g1) where + (!k, !g1) = randomR (1,d) g0 + +-- | A random word of length @n@ using @g@ generators (or their inverses) +randomWord + :: RandomGen g + => Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word + -> g -> (Word Int, g) +randomWord !d !n !g0 = (word,g1) where + (g1,word) = mapAccumL (\g _ -> swap (randomGenerator d g)) g0 [1..n] + +-- | A random word of length @n@ using @g@ generators (but not their inverses) +randomWordNoInv + :: RandomGen g + => Int -- ^ @g@ = number of generators + -> Int -- ^ @n@ = length of the word + -> g -> (Word Int, g) +randomWordNoInv !d !n !g0 = (word,g1) where + (g1,word) = mapAccumL (\g _ -> swap (randomGeneratorNoInv d g)) g0 [1..n] + +-------------------------------------------------------------------------------- +-- * The free group on @g@ generators + +{-# SPECIALIZE multiplyFree :: Word Int -> Word Int -> Word Int #-} +{-# SPECIALIZE equivalentFree :: Word Int -> Word Int -> Bool #-} +{-# SPECIALIZE reduceWordFree :: Word Int -> Word Int #-} +{-# SPECIALIZE reduceWordFreeNaive :: Word Int -> Word Int #-} + +-- | Multiplication of the free group (returns the reduced result). It is true +-- for any two words w1 and w2 that +-- +-- > multiplyFree (reduceWordFree w1) (reduceWord w2) = multiplyFree w1 w2 +-- +multiplyFree :: Eq idx => Word idx -> Word idx -> Word idx +multiplyFree w1 w2 = reduceWordFree (w1 ++ w2) + +-- | Decides whether two words represent the same group element in the free group +equivalentFree :: Eq idx => Word idx -> Word idx -> Bool +equivalentFree w1 w2 = null $ reduceWordFree $ w1 ++ inverseWord w2 + +-- | Reduces a word in a free group by repeatedly removing @x*x^(-1)@ and +-- @x^(-1)*x@ pairs. The set of /reduced words/ forms the free group; the +-- multiplication is obtained by concatenation followed by reduction. +-- +reduceWordFree :: Eq idx => Word idx -> Word idx +reduceWordFree = loop where + + loop w = case reduceStep w of + Nothing -> w + Just w' -> loop w' + + reduceStep :: Eq a => Word a -> Maybe (Word a) + reduceStep = go False where + go !changed w = case w of + (Gen x : Inv y : rest) | x==y -> go True rest + (Inv x : Gen y : rest) | x==y -> go True rest + (this : rest) -> liftM (this:) $ go changed rest + _ -> if changed then Just w else Nothing + + +-- | Naive (but canonical) reduction algorithm for the free groups +reduceWordFreeNaive :: Eq idx => Word idx -> Word idx +reduceWordFreeNaive = loop where + loop w = let w' = step w in if w/=w' then loop w' else w + step = concatMap worker . groupBy (equating genIdx) where + worker gs + | s>0 = replicate s (Gen i) + | s<0 = replicate (abs s) (Inv i) + | otherwise = [] + where + i = genIdx (head gs) + s = sum' (map genSignValue gs) + +-------------------------------------------------------------------------------- + +-- | Counts the number of words of length @n@ which reduce to the identity element. +-- +-- Generating function is @Gf_g(u) = \\frac {2g-1} { g-1 + g \\sqrt{ 1 - (8g-4)u^2 } }@ +-- +countIdentityWordsFree + :: Int -- ^ g = number of generators in the free group + -> Int -- ^ n = length of the unreduced word + -> Integer +countIdentityWordsFree g n = countWordReductionsFree g n 0 + +-- | Counts the number of words of length @n@ whose reduced form has length @k@ +-- (clearly @n@ and @k@ must have the same parity for this to be nonzero): +-- +-- > countWordReductionsFree g n k == sum [ 1 | w <- allWords g n, k == length (reduceWordFree w) ] +-- +countWordReductionsFree + :: Int -- ^ g = number of generators in the free group + -> Int -- ^ n = length of the unreduced word + -> Int -- ^ k = length of the reduced word + -> Integer +countWordReductionsFree gens_ nn_ kk_ + | nn==0 = if k==0 then 1 else 0 + | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * gg^(i ) * (gg-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ] + | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | otherwise = 0 + where + g = fromIntegral gens_ :: Integer + nn = fromIntegral nn_ :: Integer + kk = fromIntegral kk_ :: Integer + + gg = 2*g + n = div nn 2 + k = div kk 2 + +-------------------------------------------------------------------------------- +-- * Free powers of cyclic groups + +{-# SPECIALIZE multiplyZ2 :: Word Int -> Word Int -> Word Int #-} +{-# SPECIALIZE multiplyZ3 :: Word Int -> Word Int -> Word Int #-} +{-# SPECIALIZE multiplyZm :: Int -> Word Int -> Word Int -> Word Int #-} + +-- | Multiplication in free products of Z2's +multiplyZ2 :: Eq idx => Word idx -> Word idx -> Word idx +multiplyZ2 w1 w2 = reduceWordZ2 (w1 ++ w2) + +-- | Multiplication in free products of Z3's +multiplyZ3 :: Eq idx => Word idx -> Word idx -> Word idx +multiplyZ3 w1 w2 = reduceWordZ3 (w1 ++ w2) + +-- | Multiplication in free products of Zm's +multiplyZm :: Eq idx => Int -> Word idx -> Word idx -> Word idx +multiplyZm k w1 w2 = reduceWordZm k (w1 ++ w2) + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE equivalentZ2 :: Word Int -> Word Int -> Bool #-} +{-# SPECIALIZE equivalentZ3 :: Word Int -> Word Int -> Bool #-} +{-# SPECIALIZE equivalentZm :: Int -> Word Int -> Word Int -> Bool #-} + +-- | Decides whether two words represent the same group element in free products of Z2 +equivalentZ2 :: Eq idx => Word idx -> Word idx -> Bool +equivalentZ2 w1 w2 = null $ reduceWordZ2 $ w1 ++ inverseWord w2 + +-- | Decides whether two words represent the same group element in free products of Z3 +equivalentZ3 :: Eq idx => Word idx -> Word idx -> Bool +equivalentZ3 w1 w2 = null $ reduceWordZ3 $ w1 ++ inverseWord w2 + +-- | Decides whether two words represent the same group element in free products of Zm +equivalentZm :: Eq idx => Int -> Word idx -> Word idx -> Bool +equivalentZm m w1 w2 = null $ reduceWordZm m $ w1 ++ inverseWord w2 + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE reduceWordZ2 :: Word Int -> Word Int #-} +{-# SPECIALIZE reduceWordZ3 :: Word Int -> Word Int #-} +{-# SPECIALIZE reduceWordZm :: Int -> Word Int -> Word Int #-} + +-------------------------------------------------------------------------------- + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@ +-- (that is, free products of Z2's) +reduceWordZ2 :: Eq idx => Word idx -> Word idx +reduceWordZ2 = loop where + loop w = case reduceStep w of + Nothing -> w + Just w' -> loop w' + + reduceStep :: Eq a => Word a -> Maybe (Word a) + reduceStep = go False where + go !changed w = case w of + (Gen x : Gen y : rest) | x==y -> go True rest + (Gen x : Inv y : rest) | x==y -> go True rest + (Inv x : Gen y : rest) | x==y -> go True rest + (Inv x : Inv y : rest) | x==y -> go True rest + (this : rest) -> liftM (absGen this:) $ go changed rest + _ -> if changed then Just w else Nothing + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@ +-- (that is, free products of Z3's) +reduceWordZ3 :: Eq idx => Word idx -> Word idx +reduceWordZ3 = loop where + loop w = case reduceStep w of + Nothing -> w + Just w' -> loop w' + + reduceStep :: Eq a => Word a -> Maybe (Word a) + reduceStep = go False where + go !changed w = case w of + (Gen x : Inv y : rest) | x==y -> go True rest + (Inv x : Gen y : rest) | x==y -> go True rest + (Gen x : Gen y : Gen z : rest) | x==y && y==z -> go True rest + (Inv x : Inv y : Inv z : rest) | x==y && y==z -> go True rest + (Gen x : Gen y : rest) | x==y -> go True (Inv x : rest) -- !!! + (Inv x : Inv y : rest) | x==y -> go True (Gen x : rest) + (this : rest) -> liftM (this:) $ go changed rest + _ -> if changed then Just w else Nothing + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@ +-- (that is, free products of Zm's) +reduceWordZm :: Eq idx => Int -> Word idx -> Word idx +reduceWordZm m = loop where + + loop w = case reduceStep w of + Nothing -> w + Just w' -> loop w' + + halfm = div m 2 -- if we encounter strictly more than m/2 equal elements in a row, we replace them by the inverses + + -- reduceStep :: Eq a => Word a -> Maybe (Word a) + reduceStep = go False where + go !changed w = case w of + (Gen x : Inv y : rest) | x==y -> go True rest + (Inv x : Gen y : rest) | x==y -> go True rest + something | Just (k,rest) <- dropIfMoreThanHalf w -> go True (replicate (m-k) (inverseGen (head w)) ++ rest) + (this : rest) -> liftM (this:) $ go changed rest + _ -> if changed then Just w else Nothing + + -- dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a) + dropIfMoreThanHalf w = + let (!k,rest) = dropWhileEqual w + in if k > halfm then Just (k,rest) + else Nothing + + -- dropWhileEqual :: Eq a => Word a -> (Int, Word a) + dropWhileEqual [] = (0,[]) + dropWhileEqual (x0:rest) = go 1 rest where + go !k [] = (k,[]) + go !k xxs@(x:xs) = if k==m then (m,xxs) + else if x==x0 then go (k+1) xs + else (k,xxs) + +{- + dropm :: Eq a => Word a -> Maybe (Word a) + dropm [] = Nothing + dropm (x:xs) = go (m-1) xs where + go 0 rest = Just rest + go j (y:ys) = if y==x + then go (j-1) ys + else Nothing + go j [] = Nothing +-} + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE reduceWordZ2Naive :: Word Int -> Word Int #-} +{-# SPECIALIZE reduceWordZ3Naive :: Word Int -> Word Int #-} +{-# SPECIALIZE reduceWordZmNaive :: Int -> Word Int -> Word Int #-} + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@ +-- (that is, free products of Z2's). Naive (but canonical) algorithm. +reduceWordZ2Naive :: Eq idx => Word idx -> Word idx +reduceWordZ2Naive = loop where + loop w = let w' = step w in if w/=w' then loop w' else w + step = concatMap worker . groupBy (equating genIdx) where + worker gs = + case mod s 2 of + 1 -> [Gen i] + 0 -> [] + _ -> error "reduceWordZ2: fatal error, shouldn't happen" + where + i = genIdx (head gs) + s = sum' (map genSignValue gs) + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@ +-- (that is, free products of Z3's). Naive (but canonical) algorithm. +reduceWordZ3Naive :: Eq idx => Word idx -> Word idx +reduceWordZ3Naive = loop where + loop w = let w' = step w in if w/=w' then loop w' else w + step = concatMap worker . groupBy (equating genIdx) where + worker gs = + case mod s 3 of + 0 -> [] + 1 -> [Gen i] + 2 -> [Inv i] + _ -> error "reduceWordZ3: fatal error, shouldn't happen" + where + i = genIdx (head gs) + s = sum' (map genSignValue gs) + +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@ +-- (that is, free products of Zm's). Naive (but canonical) algorithm. +reduceWordZmNaive :: Eq idx => Int -> Word idx -> Word idx +reduceWordZmNaive m = loop where + loop w = let w' = step w in if w/=w' then loop w' else w + step = concatMap worker . groupBy (equating genIdx) where + halfm1 = div (m+1) 2 + worker gs + | mods <= halfm1 = replicate mods (Gen i) + | otherwise = replicate (m-mods) (Inv i) + where + i = genIdx (head gs) + s = sum' (map genSignValue gs) + mods = mod s m + +-------------------------------------------------------------------------------- + +-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^2=1@. +-- +-- Generating function is @Gf_g(u) = \\frac {2g-2} { g-2 + g \\sqrt{ 1 - (4g-4)u^2 } }@ +-- +-- The first few @g@ cases: +-- +-- > A000984 = [ countIdentityWordsZ2 2 (2*n) | n<-[0..] ] = [1,2,6,20,70,252,924,3432,12870,48620,184756...] +-- > A089022 = [ countIdentityWordsZ2 3 (2*n) | n<-[0..] ] = [1,3,15,87,543,3543,23823,163719,1143999,8099511,57959535...] +-- > A035610 = [ countIdentityWordsZ2 4 (2*n) | n<-[0..] ] = [1,4,28,232,2092,19864,195352,1970896,20275660,211823800,2240795848...] +-- > A130976 = [ countIdentityWordsZ2 5 (2*n) | n<-[0..] ] = [1,5,45,485,5725,71445,925965,12335685,167817405,2321105525,32536755565...] +-- +countIdentityWordsZ2 + :: Int -- ^ g = number of generators in the free group + -> Int -- ^ n = length of the unreduced word + -> Integer +countIdentityWordsZ2 g n = countWordReductionsZ2 g n 0 + +-- | Counts the number of words (without inverse generators) of length @n@ whose +-- reduced form in the product of Z2-s (that is, for each generator @x@ we have @x^2=1@) +-- has length @k@ +-- (clearly @n@ and @k@ must have the same parity for this to be nonzero): +-- +-- > countWordReductionsZ2 g n k == sum [ 1 | w <- allWordsNoInv g n, k == length (reduceWordZ2 w) ] +-- +countWordReductionsZ2 + :: Int -- ^ g = number of generators in the free group + -> Int -- ^ n = length of the unreduced word + -> Int -- ^ k = length of the reduced word + -> Integer +countWordReductionsZ2 gens_ nn_ kk_ + | nn==0 = if k==0 then 1 else 0 + | even nn && kk == 0 = sum [ ( binomial (nn-i) (n -i) * g^(i ) * (g-1)^(n -i ) * ( i) ) `div` (nn-i) | i<-[0..n ] ] + | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | odd nn && odd kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] + | otherwise = 0 + where + g = fromIntegral gens_ :: Integer + nn = fromIntegral nn_ :: Integer + kk = fromIntegral kk_ :: Integer + + n = div nn 2 + k = div kk 2 + +-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^3=1@. +-- +-- > countIdentityWordsZ3NoInv g n == sum [ 1 | w <- allWordsNoInv g n, 0 == length (reduceWordZ2 w) ] +-- +-- In mathematica, the formula is: @Sum[ g^k * (g-1)^(n-k) * k/n * Binomial[3*n-k-1, n-k] , {k, 1,n} ]@ +-- +countIdentityWordsZ3NoInv + :: Int -- ^ g = number of generators in the free group + -> Int -- ^ n = length of the unreduced word + -> Integer +countIdentityWordsZ3NoInv gens_ nn_ + | nn==0 = 1 + | mod nn 3 == 0 = sum [ ( binomial (3*n-i-1) (n-i) * g^i * (g-1)^(n-i) * i ) `div` n | i<-[1..n] ] + | otherwise = 0 + where + g = fromIntegral gens_ :: Integer + nn = fromIntegral nn_ :: Integer + + n = div nn 3 + +-------------------------------------------------------------------------------- + +{- + +-- some basic testing. TODO: real tests + +import Math.Combinat.Helper +import Math.Combinat.Groups.Free + +g = 3 :: Int +maxn = 8 :: Int + +bad_free = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordFree w `equivalentFree` reduceWordFreeNaive w) ] +bad_z2 = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ2 w `equivalentZ2` reduceWordZ2Naive w) ] +bad_z3 = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ3 w `equivalentZ3` reduceWordZ3Naive w) ] +bad_zm m = [ w | n<-[0..maxn] , w <- allWords g n , not (equivalentZm m (reduceWordZm m w) (reduceWordZmNaive m w)) ] + +speed_free = sum' [ length (reduceWordFree w) | n<-[0..maxn] , w <- allWords g n ] +speed_z2 = sum' [ length (reduceWordZ2 w) | n<-[0..maxn] , w <- allWords g n ] +speed_z3 = sum' [ length (reduceWordZ3 w) | n<-[0..maxn] , w <- allWords g n ] +speed_zm m = sum' [ length (reduceWordZm m w) | n<-[0..maxn] , w <- allWords g n ] + +naive_speed_free = sum' [ length (reduceWordFreeNaive w) | n<-[0..maxn] , w <- allWords g n ] +naive_speed_z2 = sum' [ length (reduceWordZ2Naive w) | n<-[0..maxn] , w <- allWords g n ] +naive_speed_z3 = sum' [ length (reduceWordZ3Naive w) | n<-[0..maxn] , w <- allWords g n ] +naive_speed_zm m = sum' [ length (reduceWordZmNaive m w) | n<-[0..maxn] , w <- allWords g n ] + +-} + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Groups/Thompson/F.hs b/src/Math/Combinat/Groups/Thompson/F.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Groups/Thompson/F.hs @@ -0,0 +1,404 @@ + +-- | Thompson's group F. +-- +-- See eg. +-- +-- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; +-- see +-- + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} +module Math.Combinat.Groups.Thompson.F where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Classes +import Math.Combinat.ASCII + +import Math.Combinat.Trees.Binary ( BinTree ) +import qualified Math.Combinat.Trees.Binary as B + +-------------------------------------------------------------------------------- +-- * Tree diagrams + +-- | A tree diagram, consisting of two binary trees with the same number of leaves, +-- representing an element of the group F. +data TDiag = TDiag + { _width :: !Int -- ^ the width is the number of leaves, minus 1, of both diagrams + , _domain :: !T -- ^ the top diagram correspond to the /domain/ + , _range :: !T -- ^ the bottom diagram corresponds to the /range/ + } + deriving (Eq,Ord,Show) + +instance DrawASCII TDiag where + ascii = asciiTDiag + +instance HasWidth TDiag where + width = _width + +-- | Creates a tree diagram from two trees +mkTDiag :: T -> T -> TDiag +mkTDiag d1 d2 = reduce $ mkTDiagDontReduce d1 d2 + +-- | Creates a tree diagram, but does not reduce it. +mkTDiagDontReduce :: T -> T -> TDiag +mkTDiagDontReduce top bot = + if w1 == w2 + then TDiag w1 top bot + else error "mkTDiag: widths do not match" + where + w1 = treeWidth top + w2 = treeWidth bot + + +isValidTDiag :: TDiag -> Bool +isValidTDiag (TDiag w top bot) = (treeWidth top == w && treeWidth bot == w) + +isPositive :: TDiag -> Bool +isPositive (TDiag w top bot) = (bot == rightVine w) + +isReduced :: TDiag -> Bool +isReduced diag = (reduce diag == diag) + +-- | The generator x0 +x0 :: TDiag +x0 = TDiag 2 top bot where + top = branch caret leaf + bot = branch leaf caret + +-- | The generator x1 +x1 :: TDiag +x1 = xk 1 + +-- | The generators x0, x1, x2 ... +xk :: Int -> TDiag +xk = go where + go k | k< 0 = error "xk: negative indexed generator" + | k==0 = x0 + | otherwise = let TDiag _ t b = go (k-1) + in TDiag (k+2) (branch leaf t) (branch leaf b) + +-- | The identity element in the group F +identity :: TDiag +identity = TDiag 0 Lf Lf + +-- | A /positive diagram/ is a diagram whose bottom tree (the range) is a right vine. +positive :: T -> TDiag +positive t = TDiag w t (rightVine w) where w = treeWidth t + +-- | Swaps the top and bottom of a tree diagram. This is the inverse in the group F. +-- (Note: we don't do reduction here, as this operation keeps the reducedness) +inverse :: TDiag -> TDiag +inverse (TDiag w top bot) = TDiag w bot top + +-- | Decides whether two (possibly unreduced) tree diagrams represents the same group element in F. +equivalent :: TDiag -> TDiag -> Bool +equivalent diag1 diag2 = (identity == reduce (compose diag1 (inverse diag2))) + +-------------------------------------------------------------------------------- +-- * Reduction of tree diagrams + +-- | Reduces a diagram. The result is a normal form of an element in the group F. +reduce :: TDiag -> TDiag +reduce = worker where + + worker :: TDiag -> TDiag + worker diag = case step diag of + Nothing -> diag + Just diag' -> worker diag' + + step :: TDiag -> Maybe TDiag + step (TDiag w top bot) = + if null idxs + then Nothing + else Just $ TDiag w' top' bot' + where + cs1 = treeCaretList top + cs2 = treeCaretList bot + idxs = sortedIntersect cs1 cs2 + w' = w - length idxs + top' = removeCarets idxs top + bot' = removeCarets idxs bot + + -- | Intersects sorted lists + sortedIntersect :: [Int] -> [Int] -> [Int] + sortedIntersect = go where + go [] _ = [] + go _ [] = [] + go xxs@(x:xs) yys@(y:ys) = case compare x y of + LT -> go xs yys + EQ -> x : go xs ys + GT -> go xxs ys + +-- | List of carets at the bottom of the tree, indexed by their left edge position +treeCaretList :: T -> [Int] +treeCaretList = snd . go 0 where + go !x t = case t of + Lf -> (x+1 , [] ) + Ct -> (x+2 , [x] ) + Br t1 t2 -> (x2 , cs1++cs2) where + (x1 , cs1) = go x t1 + (x2 , cs2) = go x1 t2 + +-- | Remove the carets with the given indices +-- (throws an error if there is no caret at the given index) +removeCarets :: [Int] -> T -> T +removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where + + (_,rem,final) = go 0 idxs tree where + + go :: Int -> [Int] -> T -> (Int,[Int],T) + go !x [] t = (x + treeWidth t , [] , t) + go !x iis@(i:is) t = case t of + Lf -> (x+1 , iis , t) + Ct -> if x==i then (x+2 , is , Lf) else (x+2 , iis , Ct) + Br t1 t2 -> (x2 , iis2 , Br t1' t2') where + (x1 , iis1 , t1') = go x iis t1 + (x2 , iis2 , t2') = go x1 iis1 t2 + +-------------------------------------------------------------------------------- +-- * Composition of tree diagrams + +-- | If @diag1@ corresponds to the PL function @f@, and @diag2@ to @g@, then @compose diag1 diag2@ +-- will correspond to @(g.f)@ (note that the order is opposite than normal function composition!) +-- +-- This is the multiplication in the group F. +-- +compose :: TDiag -> TDiag -> TDiag +compose d1 d2 = reduce (composeDontReduce d1 d2) + +-- | Compose two tree diagrams without reducing the result +composeDontReduce :: TDiag -> TDiag -> TDiag +composeDontReduce (TDiag w1 top1 bot1) (TDiag w2 top2 bot2) = new where + new = mkTDiagDontReduce top' bot' + (list1,list2) = extensionToCommonTree bot1 top2 + top' = listGraft list1 top1 + bot' = listGraft list2 bot2 + +-- | Given two binary trees, we return a pair of list of subtrees which, grafted the to leaves of +-- the first (resp. the second) tree, results in the same extended tree. +extensionToCommonTree :: T -> T -> ([T],[T]) +extensionToCommonTree t1 t2 = snd $ go (0,0) (t1,t2) where + go (!x1,!x2) (!t1,!t2) = + case (t1,t2) of + ( Lf , Lf ) -> ( (x1+n1 , x2+n2 ) , ( [Lf] , [Lf] ) ) + ( Lf , Br _ _ ) -> ( (x1+n1 , x2+n2 ) , ( [t2] , replicate n2 Lf ) ) + ( Br _ _ , Lf ) -> ( (x1+n1 , x2+n2 ) , ( replicate n1 Lf , [t1] ) ) + ( Br l1 r1 , Br l2 r2 ) + -> let ( (x1' ,x2' ) , (ps1,ps2) ) = go (x1 ,x2 ) (l1,l2) + ( (x1'',x2'') , (qs1,qs2) ) = go (x1',x2') (r1,r2) + in ( (x1'',x2'') , (ps1++qs1, ps2++qs2) ) + where + n1 = numberOfLeaves t1 + n2 = numberOfLeaves t2 + +-------------------------------------------------------------------------------- +-- * Subdivions + +-- | Returns the list of dyadic subdivision points +subdivision1 :: T -> [Rational] +subdivision1 = go 0 1 where + go !a !b t = case t of + Leaf _ -> [a,b] + Branch l r -> go a c l ++ tail (go c b r) where c = (a+b)/2 + +-- | Returns the list of dyadic intervals +subdivision2 :: T -> [(Rational,Rational)] +subdivision2 = go 0 1 where + go !a !b t = case t of + Leaf _ -> [(a,b)] + Branch l r -> go a c l ++ go c b r where c = (a+b)/2 + + +-------------------------------------------------------------------------------- +-- * Binary trees + +-- | A (strict) binary tree with labelled leaves (but unlabelled nodes) +data Tree a + = Branch !(Tree a) !(Tree a) + | Leaf !a + deriving (Eq,Ord,Show,Functor) + +-- | The monadic join operation of binary trees +graft :: Tree (Tree a) -> Tree a +graft = go where + go (Branch l r) = Branch (go l) (go r) + go (Leaf t ) = t + +-- | A list version of 'graft' +listGraft :: [Tree a] -> Tree b -> Tree a +listGraft subs big = snd $ go subs big where + go ggs@(g:gs) t = case t of + Leaf _ -> (gs,g) + Branch l r -> (gs2, Branch l' r') where + (gs1,l') = go ggs l + (gs2,r') = go gs1 r + +-- | A completely unlabelled binary tree +type T = Tree () + +instance DrawASCII T where + ascii = asciiT + +instance HasNumberOfLeaves (Tree a) where + numberOfLeaves = treeNumberOfLeaves + +instance HasWidth (Tree a) where + width = treeWidth + +leaf :: T +leaf = Leaf () + +branch :: T -> T -> T +branch = Branch + +caret :: T +caret = branch leaf leaf + +treeNumberOfLeaves :: Tree a -> Int +treeNumberOfLeaves = go where + go (Branch l r) = go l + go r + go (Leaf _ ) = 1 + +-- | The width of the tree is the number of leaves minus 1. +treeWidth :: Tree a -> Int +treeWidth t = numberOfLeaves t - 1 + +-- | Enumerates the leaves a tree, starting from 0 +enumerate_ :: Tree a -> Tree Int +enumerate_ = snd . enumerate + +-- | Enumerates the leaves a tree, and also returns the number of leaves +enumerate :: Tree a -> (Int, Tree Int) +enumerate = go 0 where + go !k t = case t of + Leaf _ -> (k+1 , Leaf k) + Branch l r -> let (k' ,l') = go k l + (k'',r') = go k' r + in (k'', Branch l' r') + +-- | \"Right vine\" of the given width +rightVine :: Int -> T +rightVine k + | k< 0 = error "rightVine: negative width" + | k==0 = leaf + | otherwise = branch leaf (rightVine (k-1)) + +-- | \"Left vine\" of the given width +leftVine :: Int -> T +leftVine k + | k< 0 = error "leftVine: negative width" + | k==0 = leaf + | otherwise = branch (leftVine (k-1)) leaf + +-- | Flips each node of a binary tree +flipTree :: Tree a -> Tree a +flipTree = go where + go t = case t of + Leaf _ -> t + Branch l r -> Branch (go r) (go l) + +-------------------------------------------------------------------------------- +-- * Conversion to\/from BinTree + +-- | 'Tree' and 'BinTree' are the same type, except that 'Tree' is strict. +-- +-- TODO: maybe unify these two types? Until that, you can convert between the two +-- with these functions if necessary. +-- +toBinTree :: Tree a -> B.BinTree a +toBinTree = go where + go (Branch l r) = B.Branch (go l) (go r) + go (Leaf y ) = B.Leaf y + +fromBinTree :: B.BinTree a -> Tree a +fromBinTree = go where + go (B.Branch l r) = Branch (go l) (go r) + go (B.Leaf y ) = Leaf y + +-------------------------------------------------------------------------------- +-- * Pattern synonyms + +pattern Lf = Leaf () +pattern Br l r = Branch l r +pattern Ct = Br Lf Lf +pattern X0 = TDiag 2 (Br Ct Lf) (Br Lf Ct) +pattern X1 = TDiag 3 (Br Lf (Br Ct Lf)) (Br Lf (Br Lf Ct)) + +-------------------------------------------------------------------------------- +-- * ASCII + +-- | Draws a binary tree, with all leaves at the same (bottom) row +asciiT :: T -> ASCII +asciiT = asciiT' False + +-- | Draws a binary tree; when the boolean flag is @True@, we draw upside down +asciiT' :: Bool -> T -> ASCII +asciiT' inv = go where + + go t = case t of + Leaf _ -> emptyRect + Branch l r -> + if yl >= yr + then pasteOnto (yl+yr+1,if inv then yr else 0) (rs $ yl+1) $ + vcat HCenter + (bc $ yr+1) + (hcat bot al ar) + else pasteOnto (yl, if inv then yl else 0) (ls $ yr+1) $ + vcat HCenter + (bc $ yl+1) + (hcat bot al ar) + where + al = go l + ar = go r + yl = asciiYSize al + yr = asciiYSize ar + + bot = if inv then VTop else VBottom + hcat align p q = hCatWith align (HSepString " ") [p,q] + vcat align p q = vCatWith align VSepEmpty $ if inv then [q,p] else [p,q] + bc = if inv then asciiBigInvCaret else asciiBigCaret + ls = if inv then asciiBigRightSlope else asciiBigLeftSlope + rs = if inv then asciiBigLeftSlope else asciiBigRightSlope + + asciiBigCaret :: Int -> ASCII + asciiBigCaret k = hCatWith VTop HSepEmpty [ asciiBigLeftSlope k , asciiBigRightSlope k ] + + asciiBigInvCaret :: Int -> ASCII + asciiBigInvCaret k = hCatWith VTop HSepEmpty [ asciiBigRightSlope k , asciiBigLeftSlope k ] + + asciiBigLeftSlope :: Int -> ASCII + asciiBigLeftSlope k = if k>0 + then asciiFromLines [ replicate l ' ' ++ "/" | l<-[k-1,k-2..0] ] + else emptyRect + + asciiBigRightSlope :: Int -> ASCII + asciiBigRightSlope k = if k>0 + then asciiFromLines [ replicate l ' ' ++ "\\" | l<-[0..k-1] ] + else emptyRect + +-- | Draws a binary tree, with all leaves at the same (bottom) row, and labelling +-- the leaves starting with 0 (continuing with letters after 9) +asciiTLabels :: T -> ASCII +asciiTLabels = asciiTLabels' False + +-- | When the flag is true, we draw upside down +asciiTLabels' :: Bool -> T -> ASCII +asciiTLabels' inv t = + if inv + then vCatWith HLeft VSepEmpty [ labels , asciiT' inv t ] + else vCatWith HLeft VSepEmpty [ asciiT' inv t , labels ] + where + w = treeWidth t + labels = asciiFromString $ intersperse ' ' $ take (w+1) allLabels + allLabels = ['0'..'9'] ++ ['a'..'z'] + +-- | Draws a tree diagram +asciiTDiag :: TDiag -> ASCII +asciiTDiag (TDiag _ top bot) = vCatWith HLeft (VSepString " ") [asciiT' False top , asciiT' True bot] + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Helper.hs b/src/Math/Combinat/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Helper.hs @@ -0,0 +1,329 @@ + +-- | Miscellaneous helper functions used internally + +{-# LANGUAGE BangPatterns, PolyKinds, GeneralizedNewtypeDeriving #-} +module Math.Combinat.Helper where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Control.Applicative ( Applicative(..) ) -- required before AMP (before GHC 7.10) +import Data.Functor.Identity + +import Data.List +import Data.Ord +import Data.Proxy + +import Data.Set (Set) ; import qualified Data.Set as Set +import Data.Map (Map) ; import qualified Data.Map as Map + +import Debug.Trace + +import System.Random +import Control.Monad.Trans.State + +-------------------------------------------------------------------------------- +-- * debugging + +debug :: Show a => a -> b -> b +debug x y = trace ("-- " ++ show x ++ "\n") y + +-------------------------------------------------------------------------------- +-- * pairs + +swap :: (a,b) -> (b,a) +swap (x,y) = (y,x) + +pairs :: [a] -> [(a,a)] +pairs = go where + go (x:xs@(y:_)) = (x,y) : go xs + go _ = [] + +pairsWith :: (a -> a -> b) -> [a] -> [b] +pairsWith f = go where + go (x:xs@(y:_)) = f x y : go xs + go _ = [] + +-------------------------------------------------------------------------------- +-- * lists + +{-# SPECIALIZE sum' :: [Int] -> Int #-} +{-# SPECIALIZE sum' :: [Integer] -> Integer #-} +sum' :: Num a => [a] -> a +sum' = foldl' (+) 0 + +interleave :: [a] -> [a] -> [a] +interleave (x:xs) (y:ys) = x : y : interleave xs ys +interleave [x] [] = x : [] +interleave [] [] = [] +interleave _ _ = error "interleave: shouldn't happen" + +evens, odds :: [a] -> [a] +evens (x:xs) = x : odds xs +evens [] = [] +odds (x:xs) = evens xs +odds [] = [] + +-------------------------------------------------------------------------------- +-- * multiplication + +-- | Product of list of integers, but in interleaved order (for a list of big numbers, +-- it should be faster than the linear order) +productInterleaved :: [Integer] -> Integer +productInterleaved = go where + go [] = 1 + go [x] = x + go [x,y] = x*y + go list = go (evens list) * go (odds list) + +-- | Faster implementation of @product [ i | i <- [a+1..b] ]@ +productFromTo :: Integral a => a -> a -> Integer +productFromTo = go where + go !a !b + | dif < 1 = 1 + | dif < 5 = product [ fromIntegral i | i<-[a+1..b] ] + | otherwise = go a half * go half b + where + dif = b - a + half = div (a+b+1) 2 + +-- | Faster implementation of product @[ i | i <- [a+1,a+3,..b] ]@ +productFromToStride2 :: Integral a => a -> a -> Integer +productFromToStride2 = go where + go !a !b + | dif < 1 = 1 + | dif < 9 = product [ fromIntegral i | i<-[a+1,a+3..b] ] + | otherwise = go a half * go half b + where + dif = b - a + half = a + 2*(div dif 4) + +-------------------------------------------------------------------------------- +-- * equality and ordering + +equating :: Eq b => (a -> b) -> a -> a -> Bool +equating f x y = (f x == f y) + +reverseOrdering :: Ordering -> Ordering +reverseOrdering LT = GT +reverseOrdering GT = LT +reverseOrdering EQ = EQ + +reverseComparing :: Ord b => (a -> b) -> a -> a -> Ordering +reverseComparing f x y = compare (f y) (f x) + +reverseCompare :: Ord a => a -> a -> Ordering +reverseCompare x y = compare y x -- reverseOrdering $ compare x y + +reverseSort :: Ord a => [a] -> [a] +reverseSort = sortBy reverseCompare + +groupSortBy :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]] +groupSortBy f = groupBy (equating f) . sortBy (comparing f) + +nubOrd :: Ord a => [a] -> [a] +nubOrd = worker Set.empty where + worker _ [] = [] + worker s (x:xs) + | Set.member x s = worker s xs + | otherwise = x : worker (Set.insert x s) xs + +-------------------------------------------------------------------------------- +-- * increasing \/ decreasing sequences + +{-# SPECIALIZE isWeaklyIncreasing :: [Int] -> Bool #-} +isWeaklyIncreasing :: Ord a => [a] -> Bool +isWeaklyIncreasing = go where + go xs = case xs of + (a:rest@(b:_)) -> a <= b && go rest + [_] -> True + [] -> True + +{-# SPECIALIZE isStrictlyIncreasing :: [Int] -> Bool #-} +isStrictlyIncreasing :: Ord a => [a] -> Bool +isStrictlyIncreasing = go where + go xs = case xs of + (a:rest@(b:_)) -> a < b && go rest + [_] -> True + [] -> True + +{-# SPECIALIZE isWeaklyDecreasing :: [Int] -> Bool #-} +isWeaklyDecreasing :: Ord a => [a] -> Bool +isWeaklyDecreasing = go where + go xs = case xs of + (a:rest@(b:_)) -> a >= b && go rest + [_] -> True + [] -> True + +{-# SPECIALIZE isStrictlyDecreasing :: [Int] -> Bool #-} +isStrictlyDecreasing :: Ord a => [a] -> Bool +isStrictlyDecreasing = go where + go xs = case xs of + (a:rest@(b:_)) -> a > b && go rest + [_] -> True + [] -> True + +-------------------------------------------------------------------------------- +-- * first \/ last + +-- | The boolean argument will @True@ only for the last element +mapWithLast :: (Bool -> a -> b) -> [a] -> [b] +mapWithLast f = go where + go (x : []) = f True x : [] + go (x : xs) = f False x : go xs + +mapWithFirst :: (Bool -> a -> b) -> [a] -> [b] +mapWithFirst f = go True where + go b (x:xs) = f b x : go False xs + +mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b] +mapWithFirstLast f = go True where + go b (x : []) = f b True x : [] + go b (x : xs) = f b False x : go False xs + +-------------------------------------------------------------------------------- +-- * older helpers for ASCII drawing + +-- | extend lines with spaces so that they have the same line +mkLinesUniformWidth :: [String] -> [String] +mkLinesUniformWidth old = zipWith worker ls old where + ls = map length old + m = maximum ls + worker l s = s ++ replicate (m-l) ' ' + +mkBlocksUniformHeight :: [[String]] -> [[String]] +mkBlocksUniformHeight old = zipWith worker ls old where + ls = map length old + m = maximum ls + worker l s = s ++ replicate (m-l) "" + +mkUniformBlocks :: [[String]] -> [[String]] +mkUniformBlocks = map mkLinesUniformWidth . mkBlocksUniformHeight + +hConcatLines :: [[String]] -> [String] +hConcatLines = map concat . transpose . mkUniformBlocks + +vConcatLines :: [[String]] -> [String] +vConcatLines = concat + +-------------------------------------------------------------------------------- +-- * counting + +-- helps testing the random rutines +count :: Eq a => a -> [a] -> Int +count x xs = length $ filter (==x) xs + +histogram :: (Eq a, Ord a) => [a] -> [(a,Int)] +histogram xs = Map.toList table where + table = Map.fromListWith (+) [ (x,1) | x<-xs ] + +-------------------------------------------------------------------------------- +-- * maybe + +fromJust :: Maybe a -> a +fromJust (Just x) = x +fromJust Nothing = error "fromJust: Nothing" + +-------------------------------------------------------------------------------- +-- * bool + +intToBool :: Int -> Bool +intToBool 0 = False +intToBool 1 = True +intToBool _ = error "intToBool" + +boolToInt :: Bool -> Int +boolToInt False = 0 +boolToInt True = 1 + +-------------------------------------------------------------------------------- +-- * iteration + +-- iterated function application +nest :: Int -> (a -> a) -> a -> a +nest !0 _ x = x +nest !n f x = nest (n-1) f (f x) + +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) + +unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a] +unfoldM f y = do + (x,m) <- f y + case m of + Nothing -> return [x] + Just y' -> do + xs <- unfoldM f y' + return (x:xs) + +mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) +mapAccumM _ s [] = return (s, []) +mapAccumM f s (x:xs) = do + (s1,y) <- f s x + (s2,ys) <- mapAccumM f s1 xs + return (s2, y:ys) + +-------------------------------------------------------------------------------- +-- * long zipwith + +longZipWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c] +longZipWith a0 b0 f = go where + go (x:xs) (y:ys) = f x y : go xs ys + go [] ys = [ f a0 y | y<-ys ] + go xs [] = [ f x b0 | x<-xs ] + +{- +longZipWithZero :: (Num a, Num b) => (a -> b -> c) -> [a] -> [b] -> [c] +longZipWithZero = longZipWith 0 0 +-} + +-------------------------------------------------------------------------------- +-- * random + +-- | A simple random monad to make life suck less +type Rand g = RandT g Identity + +runRand :: Rand g a -> g -> (a,g) +runRand action g = runIdentity (runRandT action g) + +flipRunRand :: Rand s a -> s -> (s,a) +flipRunRand action g = runIdentity (flipRunRandT action g) + + +-- | The Rand monad transformer +newtype RandT g m a = RandT (StateT g m a) deriving (Functor,Applicative,Monad) + +runRandT :: RandT g m a -> g -> m (a,g) +runRandT (RandT stuff) = runStateT stuff + +-- | This may be occasionally useful +flipRunRandT :: Monad m => RandT s m a -> s -> m (s,a) +flipRunRandT action ini = liftM swap $ runRandT action ini + + +-- | Puts a standard-conforming random function into the monad +rand :: (g -> (a,g)) -> Rand g a +rand user = RandT (state user) + +randRoll :: (RandomGen g, Random a) => Rand g a +randRoll = rand random + +randChoose :: (RandomGen g, Random a) => (a,a) -> Rand g a +randChoose uv = rand (randomR uv) + +randProxy1 :: Rand g (f n) -> Proxy n -> Rand g (f n) +randProxy1 action _ = action + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/LatticePaths.hs b/src/Math/Combinat/LatticePaths.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/LatticePaths.hs @@ -0,0 +1,386 @@ + +-- | 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, FlexibleInstances, TypeSynonymInstances #-} +module Math.Combinat.LatticePaths where + +-------------------------------------------------------------------------------- + +import Data.List +import System.Random + +import Math.Combinat.Classes +import Math.Combinat.Numbers +import Math.Combinat.Trees.Binary +import Math.Combinat.ASCII as ASCII + +-------------------------------------------------------------------------------- +-- * Types + +-- | A step in a lattice path +data Step + = UpStep -- ^ the step @(1,1)@ + | DownStep -- ^ the step @(1,-1)@ + deriving (Eq,Ord,Show) + +-- | A lattice path is a path using only the allowed steps, never going below the zero level line @y=0@. +-- +-- Note that if you rotate such a path by 45 degrees counterclockwise, +-- you get a path which uses only the steps @(1,0)@ and @(0,1)@, and stays +-- above the main diagonal (hence the name, we just use a different convention). +-- +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 -> '\\' + +instance DrawASCII LatticePath where + ascii = asciiPath + +-------------------------------------------------------------------------------- +-- * elementary queries + +-- | A lattice path is called \"valid\", if it never goes below the @y=0@ line. +isValidPath :: LatticePath -> Bool +isValidPath = go 0 where + go :: Int -> LatticePath -> Bool + go !y [] = y>=0 + go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } + in if y'<0 then False + else go y' ts + +-- | A Dyck path is a lattice path whose last point lies on the @y=0@ line +isDyckPath :: LatticePath -> Bool +isDyckPath = go 0 where + go :: Int -> LatticePath -> Bool + go !y [] = y==0 + go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } + in if y'<0 then False + else go y' ts + +-- | Maximal height of a lattice path +pathHeight :: LatticePath -> Int +pathHeight = go 0 0 where + go :: Int -> Int -> LatticePath -> Int + go !h !y [] = h + go !h !y (t:ts) = case t of + UpStep -> go (max h (y+1)) (y+1) ts + DownStep -> go h (y-1) ts + +instance HasHeight LatticePath where + height = pathHeight + +instance HasWidth LatticePath where + width = length + +-- | Endpoint of a lattice path, which starts from @(0,0)@. +pathEndpoint :: LatticePath -> (Int,Int) +pathEndpoint = go 0 0 where + go :: Int -> Int -> LatticePath -> (Int,Int) + go !x !y [] = (x,y) + go !x !y (t:ts) = case t of + UpStep -> go (x+1) (y+1) ts + DownStep -> go (x+1) (y-1) ts + +-- | Returns the coordinates of the path (excluding the starting point @(0,0)@, but including +-- the endpoint) +pathCoordinates :: LatticePath -> [(Int,Int)] +pathCoordinates = go 0 0 where + go :: Int -> Int -> LatticePath -> [(Int,Int)] + go _ _ [] = [] + go !x !y (t:ts) = let x' = x + 1 + 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 :: Int -> Int -> LatticePath -> (Int,Int) + 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 + go :: Int -> LatticePath -> Int + go !k (x:xs@(y:_)) = go (if x==UpStep && y==DownStep then k+1 else k) xs + go !k [x] = k + go !k [ ] = k + +-- | Number of points on the path which touch the @y=0@ zero level line +-- (excluding the starting point @(0,0)@, but including the endpoint; that is, for Dyck paths it this is always positive!). +pathNumberOfZeroTouches :: LatticePath -> Int +pathNumberOfZeroTouches = pathNumberOfTouches' 0 + +-- | Number of points on the path which touch the level line at height @h@ +-- (excluding the starting point @(0,0)@, but including the endpoint). +pathNumberOfTouches' + :: Int -- ^ @h@ = the touch level + -> LatticePath -> Int +pathNumberOfTouches' h = go 0 0 0 where + go :: Int -> Int -> Int -> LatticePath -> Int + go !cnt _ _ [] = cnt + go !cnt !x !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 } + cnt' = if y'==h then cnt+1 else cnt + in go cnt' (x+1) y' ts + +-------------------------------------------------------------------------------- +-- * Dyck paths + +-- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. +-- +-- Remark: Dyck paths are obviously in bijection with nested parentheses, and thus +-- also with binary trees. +-- +-- Order is reverse lexicographical: +-- +-- > sort (dyckPaths m) == reverse (dyckPaths m) +-- +dyckPaths :: Int -> [LatticePath] +dyckPaths = map nestedParensToDyckPath . nestedParentheses + +-- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. +-- +-- > sort (dyckPathsNaive m) == sort (dyckPaths m) +-- +-- Naive recursive algorithm, order is ad-hoc +-- +dyckPathsNaive :: Int -> [LatticePath] +dyckPathsNaive = worker where + worker 0 = [[]] + worker m = as ++ bs where + as = [ bracket p | p <- worker (m-1) ] + bs = [ bracket p ++ q | k <- [1..m-1] , p <- worker (k-1) , q <- worker (m-k) ] + bracket p = UpStep : p ++ [DownStep] + +-- | The number of Dyck paths from @(0,0)@ to @(2m,0)@ is simply the m\'th Catalan number. +countDyckPaths :: Int -> Integer +countDyckPaths m = catalan m + +-- | The trivial bijection +nestedParensToDyckPath :: [Paren] -> LatticePath +nestedParensToDyckPath = map f where + f p = case p of { LeftParen -> UpStep ; RightParen -> DownStep } + +-- | The trivial bijection in the other direction +dyckPathToNestedParens :: LatticePath -> [Paren] +dyckPathToNestedParens = map g where + g s = case s of { UpStep -> LeftParen ; DownStep -> RightParen } + +-------------------------------------------------------------------------------- +-- * Bounded Dyck paths + +-- | @boundedDyckPaths h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@. +-- Synonym for 'boundedDyckPathsNaive'. +-- +boundedDyckPaths + :: Int -- ^ @h@ = maximum height + -> Int -- ^ @m@ = half-length + -> [LatticePath] +boundedDyckPaths = boundedDyckPathsNaive + +-- | @boundedDyckPathsNaive h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@. +-- +-- > sort (boundedDyckPaths h m) == sort [ p | p <- dyckPaths m , pathHeight p <= h ] +-- > sort (boundedDyckPaths m m) == sort (dyckPaths m) +-- +-- Naive recursive algorithm, resulting order is pretty ad-hoc. +-- +boundedDyckPathsNaive + :: Int -- ^ @h@ = maximum height + -> Int -- ^ @m@ = half-length + -> [LatticePath] +boundedDyckPathsNaive = worker where + worker !h !m + | h<0 = [] + | m<0 = [] + | m==0 = [[]] + | h<=0 = [] + | otherwise = as ++ bs + where + bracket p = UpStep : p ++ [DownStep] + as = [ bracket p | p <- boundedDyckPaths (h-1) (m-1) ] + bs = [ bracket p ++ q | k <- [1..m-1] , p <- boundedDyckPaths (h-1) (k-1) , q <- boundedDyckPaths h (m-k) ] + +-------------------------------------------------------------------------------- +-- * More general lattice paths + +-- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even. +-- Synonym for 'latticePathsNaive' +-- +latticePaths :: (Int,Int) -> [LatticePath] +latticePaths = latticePathsNaive + +-- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even. +-- +-- Note that +-- +-- > sort (dyckPaths n) == sort (latticePaths (0,2*n)) +-- +-- Naive recursive algorithm, resulting order is pretty ad-hoc. +-- +latticePathsNaive :: (Int,Int) -> [LatticePath] +latticePathsNaive (x,y) = worker x y where + worker !x !y + | odd (x-y) = [] + | x<0 = [] + | y<0 = [] + | y==0 = dyckPaths (div x 2) + | x==1 && y==1 = [[UpStep]] + | otherwise = as ++ bs + where + bracket p = UpStep : p ++ [DownStep] + 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 + +-- | @touchingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the +-- 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 zero-touches + -> Int -- ^ @m@ = half-length + -> [LatticePath] +touchingDyckPaths = touchingDyckPathsNaive + + +-- | @touchingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the +-- zero level line @y=0@ exactly @k@ times (excluding the starting point, but including the endpoint; +-- thus, @k@ should be positive). +-- +-- > sort (touchingDyckPathsNaive k m) == sort [ p | p <- dyckPaths m , pathNumberOfZeroTouches p == k ] +-- +-- Naive recursive algorithm, resulting order is pretty ad-hoc. +-- +touchingDyckPathsNaive + :: Int -- ^ @k@ = number of zero-touches + -> Int -- ^ @m@ = half-length + -> [LatticePath] +touchingDyckPathsNaive = worker where + worker !k !m + | m == 0 = if k==0 then [[]] else [] + | k <= 0 = [] + | m < 0 = [] + | k == 1 = [ bracket p | p <- dyckPaths (m-1) ] + | 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 + +-- | @peakingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks. +-- +-- Synonym for 'peakingDyckPathsNaive' +-- +peakingDyckPaths + :: Int -- ^ @k@ = number of peaks + -> Int -- ^ @m@ = half-length + -> [LatticePath] +peakingDyckPaths = peakingDyckPathsNaive + +-- | @peakingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks. +-- +-- > sort (peakingDyckPathsNaive k m) = sort [ p | p <- dyckPaths m , pathNumberOfPeaks p == k ] +-- +-- Naive recursive algorithm, resulting order is pretty ad-hoc. +-- +peakingDyckPathsNaive + :: Int -- ^ @k@ = number of peaks + -> Int -- ^ @m@ = half-length + -> [LatticePath] +peakingDyckPathsNaive = worker where + worker !k !m + | m == 0 = if k==0 then [[]] else [] + | k <= 0 = [] + | m < 0 = [] + | k == 1 = [ singlePeak m ] + | otherwise = as ++ bs ++ cs + where + as = [ bracket p | p <- worker k (m-1) ] + bs = [ smallHill ++ q | q <- worker (k-1) (m-1) ] + cs = [ bracket p ++ q | l <- [2..m-1] , a <- [1..k-1] , p <- worker a (l-1) , q <- worker (k-a) (m-l) ] + smallHill = [ UpStep , DownStep ] + singlePeak !m = replicate m UpStep ++ replicate m DownStep + bracket p = UpStep : p ++ [DownStep] + +-- | Dyck paths of length @2m@ with @k@ peaks are counted by the Narayana numbers @N(m,k) = \binom{m}{k} \binom{m}{k-1} / m@ +countPeakingDyckPaths + :: Int -- ^ @k@ = number of peaks + -> Int -- ^ @m@ = half-length + -> Integer +countPeakingDyckPaths k m + | m == 0 = if k==0 then 1 else 0 + | k <= 0 = 0 + | m < 0 = 0 + | k == 1 = 1 + | otherwise = div (binomial m k * binomial m (k-1)) (fromIntegral m) + +-------------------------------------------------------------------------------- +-- * Random lattice paths + +-- | A uniformly random Dyck path of length @2m@ +randomDyckPath :: RandomGen g => Int -> g -> (LatticePath,g) +randomDyckPath m g0 = (nestedParensToDyckPath parens, g1) where + (parens,g1) = randomNestedParentheses m g0 + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Numbers.hs b/src/Math/Combinat/Numbers.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Numbers.hs @@ -0,0 +1,12 @@ + +module Math.Combinat.Numbers + ( module Math.Combinat.Numbers.Integers + , module Math.Combinat.Numbers.Primes + , module Math.Combinat.Numbers.Sequences + ) + where + +import Math.Combinat.Numbers.Integers +import Math.Combinat.Numbers.Primes +import Math.Combinat.Numbers.Sequences + diff --git a/src/Math/Combinat/Numbers/Integers.hs b/src/Math/Combinat/Numbers/Integers.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Numbers/Integers.hs @@ -0,0 +1,113 @@ + +-- | Operations on integers + +module Math.Combinat.Numbers.Integers + ( -- * Integer logarithm + integerLog2 + , ceilingLog2 + -- * Integer square root + , isSquare + , integerSquareRoot + , ceilingSquareRoot + , integerSquareRoot' + , integerSquareRootNewton' + ) + where + +-------------------------------------------------------------------------------- + +-- import Math.Combinat.Numbers + +import Data.List ( group , sort ) +import Data.Bits + +import System.Random + +-------------------------------------------------------------------------------- +-- Integer logarithm + +-- | Largest integer @k@ such that @2^k@ is smaller or equal to @n@ +integerLog2 :: Integer -> Integer +integerLog2 n = go n where + go 0 = -1 + go k = 1 + go (shiftR k 1) + +-- | Smallest integer @k@ such that @2^k@ is larger or equal to @n@ +ceilingLog2 :: Integer -> Integer +ceilingLog2 0 = 0 +ceilingLog2 n = 1 + go (n-1) where + go 0 = -1 + go k = 1 + go (shiftR k 1) + +-------------------------------------------------------------------------------- +-- Integer square root + +isSquare :: Integer -> Bool +isSquare n = + if (fromIntegral $ mod n 32) `elem` rs + then snd (integerSquareRoot' n) == 0 + else False + where + rs = [0,1,4,9,16,17,25] :: [Int] + +-- | Integer square root (largest integer whose square is smaller or equal to the input) +-- using Newton's method, with a faster (for large numbers) inital guess based on bit shifts. +integerSquareRoot :: Integer -> Integer +integerSquareRoot = fst . integerSquareRoot' + +-- | Smallest integer whose square is larger or equal to the input +ceilingSquareRoot :: Integer -> Integer +ceilingSquareRoot n = (if r>0 then u+1 else u) where (u,r) = integerSquareRoot' n + +-- | We also return the excess residue; that is +-- +-- > (a,r) = integerSquareRoot' n +-- +-- means that +-- +-- > a*a + r = n +-- > a*a <= n < (a+1)*(a+1) +integerSquareRoot' :: Integer -> (Integer,Integer) +integerSquareRoot' n + | n<0 = error "integerSquareRoot: negative input" + | n<2 = (n,0) + | otherwise = go firstGuess + where + k = integerLog2 n + firstGuess = 2^(div (k+2) 2) -- !! note that (div (k+1) 2) is NOT enough !! + go a = + if m < a + then go a' + else (a, r + a*(m-a)) + where + (m,r) = divMod n a + a' = div (m + a) 2 + +-- | Newton's method without an initial guess. For very small numbers (<10^10) it +-- is somewhat faster than the above version. +integerSquareRootNewton' :: Integer -> (Integer,Integer) +integerSquareRootNewton' n + | n<0 = error "integerSquareRootNewton: negative input" + | n<2 = (n,0) + | otherwise = go (div n 2) + where + go a = + if m < a + then go a' + else (a, r + a*(m-a)) + where + (m,r) = divMod n a + a' = div (m + a) 2 + +{- +-- brute force test of integer square root +isqrt_test n1 n2 = + [ k + | k<-[n1..n2] + , let (a,r) = integerSquareRoot' k + , (a*a+r/=k) || (a*a>k) || (a+1)*(a+1)<=k + ] +-} + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Numbers/Primes.hs b/src/Math/Combinat/Numbers/Primes.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Numbers/Primes.hs @@ -0,0 +1,361 @@ + +-- | Prime numbers and related number theoretical stuff. + +module Math.Combinat.Numbers.Primes + ( -- * Elementary number theory + divides + , divisors, squareFreeDivisors, squareFreeDivisors_ + , divisorSum , divisorSum' + , moebiusMu , eulerTotient , liouvilleLambda + -- * List of prime numbers + , primes + , primesSimple + , primesTMWE + -- * Prime factorization + , factorize, factorizeNaive + , productOfFactors + , integerFactorsTrialDivision + , groupIntegerFactors + -- * Modulo @m@ arithmetic + , powerMod + -- * Prime testing + , millerRabinPrimalityTest + , isProbablyPrime + , isVeryProbablyPrime + ) + where + +-------------------------------------------------------------------------------- + +import Data.List ( group , sort , foldl' ) + +import Math.Combinat.Sign +import Math.Combinat.Helper +import Math.Combinat.Numbers.Integers + +-- import Math.Combinat.Sets ( sublists ) -- cyclic dependency... +import Math.Combinat.Tuples ( tuples' ) + +import Data.Bits + +import System.Random + +-------------------------------------------------------------------------------- + +-- | @d `divides` n@ +divides :: Integer -> Integer -> Bool +divides d n = (mod n d == 0) + +{-# SPECIALIZE moebiusMu :: Int -> Int #-} +{-# SPECIALIZE moebiusMu :: Integer -> Integer #-} +-- | The Moebius mu function +moebiusMu :: (Integral a, Num b) => a -> b +moebiusMu n + | any (>1) expos = 0 + | even (length primes) = 1 + | otherwise = -1 + where + factors = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n + (primes,expos) = unzip factors + +{-# SPECIALIZE liouvilleLambda :: Int -> Int #-} +{-# SPECIALIZE liouvilleLambda :: Integer -> Integer #-} +-- | The Liouville lambda function +liouvilleLambda :: (Integral a, Num b) => a -> b +liouvilleLambda n = + if odd (foldl' (+) 0 $ map snd grps) + then -1 + else 1 + where + grps = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n + +-- | Sum ofthe of the divisors +divisorSum :: Integer -> Integer +divisorSum n = foldl' (+) 0 [ d | d <- divisors n] + +-- | Sum of @k@-th powers of the divisors +divisorSum' :: Int -> Integer -> Integer +divisorSum' k n = foldl' (+) 0 [ d^k | d <- divisors n] + +-- | Euler's totient function +eulerTotient :: Integer -> Integer +eulerTotient n = div n prodp * prodp1 where + grps = groupIntegerFactors $ integerFactorsTrialDivision n + ps = map fst grps + prodp = foldl' (*) 1 [ p | p <- ps ] + prodp1 = foldl' (*) 1 [ p-1 | p <- ps ] + +-- | Divisors of @n@ (note: the result is /not/ ordered!) +divisors :: Integer -> [Integer] +divisors n = [ f tup | tup <- tuples' expos ] where + grps = groupIntegerFactors $ integerFactorsTrialDivision n + (ps,expos) = unzip grps + f es = foldl' (*) 1 $ zipWith (^) ps es + +-- | List of square-free divisors together with their Mobius mu value +-- (note: the result is /not/ ordered!) +squareFreeDivisors :: Integer -> [(Integer,Sign)] +squareFreeDivisors n = map f (sublists primes) where + grps = groupIntegerFactors $ integerFactorsTrialDivision n + primes = map fst grps + f ps = ( foldl' (*) 1 ps , if even (length ps) then Plus else Minus) + +-- | List of square-free divisors +-- (note: the result is /not/ ordered!) +squareFreeDivisors_ :: Integer -> [Integer] +squareFreeDivisors_ n = map f (sublists primes) where + grps = groupIntegerFactors $ integerFactorsTrialDivision n + primes = map fst grps + f ps = foldl' (*) 1 ps + +-- | To avoid cyclic dependencies, I made a local copy of this... +sublists :: [a] -> [[a]] +sublists [] = [[]] +sublists (x:xs) = sublists xs ++ map (x:) (sublists xs) + +-------------------------------------------------------------------------------- +-- List of prime numbers + +-- | Infinite list of primes, using the TMWE algorithm. +primes :: [Integer] +primes = primesTMWE + +-- | A relatively simple but still quite fast implementation of list of primes. +-- By Will Ness +primesSimple :: [Integer] +primesSimple = 2 : 3 : sieve 0 primes' 5 where + primes' = tail primesSimple + sieve k (p:ps) x = noDivs k h ++ sieve (k+1) ps (t+2) where + t = p*p + h = [x,x+2..t-2] + noDivs k = filter (\x -> all (\y -> rem x y /= 0) (take k primes')) + +-- | List of primes, using tree merge with wheel. Code by Will Ness. +primesTMWE :: [Integer] +primesTMWE = 2:3:5:7: gaps 11 wheel (fold3t $ roll 11 wheel primes') where + + primes' = 11: gaps 13 (tail wheel) (fold3t $ roll 11 wheel primes') + fold3t ((x:xs): ~(ys:zs:t)) + = x : union xs (union ys zs) `union` fold3t (pairs t) + pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t + wheel = 2:4:2:4:6:2:6:4:2:4:6:6:2:6:4:2:6:4:6:8:4:2:4:2: + 4:8:6:4:6:2:4:6:2:6:6:4:2:4:6:2:6:4:2:4:2:10:2:10:wheel + gaps k ws@(w:t) cs@(~(c:u)) + | k==c = gaps (k+w) t u + | True = k : gaps (k+w) t cs + roll k ws@(w:t) ps@(~(p:u)) + | k==p = scanl (\c d->c+p*d) (p*p) ws : roll (k+w) t u + | True = roll (k+w) t ps + + minus xxs@(x:xs) yys@(y:ys) = case compare x y of + LT -> x : minus xs yys + EQ -> minus xs ys + GT -> minus xxs ys + minus xs [] = xs + minus [] _ = [] + + union xxs@(x:xs) yys@(y:ys) = case compare x y of + LT -> x : union xs yys + EQ -> x : union xs ys + GT -> y : union xxs ys + union xs [] = xs + union [] ys =ys + +-------------------------------------------------------------------------------- +-- Prime factorization + +factorize :: Integer -> [(Integer,Int)] +factorize = factorizeNaive + +factorizeNaive :: Integer -> [(Integer,Int)] +factorizeNaive = groupIntegerFactors . integerFactorsTrialDivision + +productOfFactors :: [(Integer,Int)] -> Integer +productOfFactors = productInterleaved . map (uncurry pow) where + pow _ 0 = 1 + pow p 1 = p + pow 2 n = shiftL 1 n + pow p 2 = p*p + pow p n = if even n + then (pow p (shiftR n 1))^2 + else p * (pow p (shiftR n 1))^2 + +-- | Groups integer factors. Example: from [2,2,2,3,3,5] we produce [(2,3),(3,2),(5,1)] +groupIntegerFactors :: [Integer] -> [(Integer,Int)] +groupIntegerFactors = map f . group . sort where + f xs = (head xs, length xs) + +-- | The naive trial division algorithm. +integerFactorsTrialDivision :: Integer -> [Integer] +integerFactorsTrialDivision n + | n<1 = error "integerFactorsTrialDivision: n should be at least 1" + | otherwise = go primes n + where + go _ 1 = [] + go rs k = sub ps k where + sub [] k = [k] + sub qqs@(q:qs) k = case mod k q of + 0 -> q : go qqs (div k q) + _ -> sub qs k + ps = takeWhile (\p -> p*p <= k) rs +{- + go 1 = [] + go k = sub ps k where + sub [] k = [k] + sub (q:qs) k = case mod k q of + 0 -> q : go (div k q) + _ -> sub qs k + ps = takeWhile (\p -> p*p <= k) primes +-} + +{- +-- brute force testing of factors +ifactorsTest :: (Integer -> [Integer]) -> Integer -> Bool +ifactorsTest alg n = and [ product (alg k) == k | k<-[1..n] ] +-} + +-------------------------------------------------------------------------------- +-- Modulo @m@ arithmetic + +-- | Efficient powers modulo m. +-- +-- > powerMod a k m == (a^k) `mod` m +powerMod :: Integer -> Integer -> Integer -> Integer +powerMod a' k m = {- debug bs $ -} go a bs where + + bs = bin k + + bin 0 = [] + bin x = (x .&. 1 /= 0) : bin (shiftR x 1) + + a = mod a' m + + go _ [] = 1 + go x (b:bs) = -- debug (x,b) $ + if b + then mod (x*rest) m + else rest + where + rest = go (mod (x*x) m) bs + +-------------------------------------------------------------------------------- +-- Prime testing + +-- | Miller-Rabin Primality Test (taken from Haskell wiki). +-- We test the primality of the first argument @n@ by using the second argument @a@ as a candidate witness. +-- If it returs @False@, then @n@ is composite. If it returns @True@, then @n@ is either prime or composite. +-- +-- A random choice between @2@ and @(n-2)@ is a good choice for @a@. +millerRabinPrimalityTest :: Integer -> Integer -> Bool +millerRabinPrimalityTest n a + | a <= 1 || a >= n-1 = + error $ "millerRabinPrimalityTest: a out of range (" ++ show a ++ " for "++ show n ++ ")" + | n < 2 = False + | even n = False + | b0 == 1 || b0 == n' = True + | otherwise = iter (tail b) + where + n' = n-1 + (k,m) = find2km n' + b0 = powMod n a m + b = take (fromIntegral k) $ iterate (squareMod n) b0 + iter [] = False + iter (x:xs) + | x == 1 = False + | x == n' = True + | otherwise = iter xs + + +{-# SPECIALIZE find2km :: Integer -> (Integer,Integer) #-} +find2km :: Integral a => a -> (a,a) +find2km n = f 0 n where + f k m + | r == 1 = (k,m) + | otherwise = f (k+1) q + where (q,r) = quotRem m 2 + +{-# SPECIALIZE pow' :: (Integer -> Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer -> Integer #-} +pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a +pow' _ _ _ 0 = 1 +pow' mul sq x' n' = f x' n' 1 where + f x n y + | n == 1 = x `mul` y + | r == 0 = f x2 q y + | otherwise = f x2 q (x `mul` y) + where + (q,r) = quotRem n 2 + x2 = sq x + +{-# SPECIALIZE mulMod :: Integer -> Integer -> Integer -> Integer #-} +mulMod :: Integral a => a -> a -> a -> a +mulMod a b c = (b * c) `mod` a + +{-# SPECIALIZE squareMod :: Integer -> Integer -> Integer #-} +squareMod :: Integral a => a -> a -> a +squareMod a b = (b * b) `rem` a + +{-# SPECIALIZE powMod :: Integer -> Integer -> Integer -> Integer #-} +powMod :: Integral a => a -> a -> a -> a +powMod m = pow' (mulMod m) (squareMod m) + +-------------------------------------------------------------------------------- + +-- | For very small numbers, we use trial division, for larger numbers, we apply the +-- Miller-Rabin primality test @log4(n)@ times, with candidate witnesses derived +-- deterministically from @n@ using a pseudo-random sequence +-- (which /should be/ based on a cryptographic hash function, but isn\'t, yet). +-- +-- Thus the candidate witnesses should behave essentially like random, but the +-- resulting function is still a deterministic, pure function. +-- +-- TODO: implement the hash sequence, at the moment we use 'System.Random' instead... +-- +isProbablyPrime :: Integer -> Bool +isProbablyPrime n + | n < 2 = False + | even n = (n==2) + | n < 1000 = length (integerFactorsTrialDivision n) == 1 + | otherwise = and [ millerRabinPrimalityTest n a | a <- witnessList ] + where + log2n = integerLog2 n + nchecks = 1 + fromInteger (div log2n 2) :: Int + witnessList = take nchecks pseudoRnds + pseudoRnds = 2 : [ a | a <- integerRndSequence n , a > 1 && a < (n-1) ] + +-- | A more exhaustive version of 'isProbablyPrime', this one tests candidate +-- witnesses both the first log4(n) prime numbers and then log4(n) pseudo-random +-- numbers +isVeryProbablyPrime :: Integer -> Bool +isVeryProbablyPrime n + | n < 2 = False + | even n = (n==2) + | n < 1000 = length (integerFactorsTrialDivision n) == 1 + | otherwise = and [ millerRabinPrimalityTest n a | a <- witnessList ] + where + log2n = integerLog2 n + nchecks = 1 + fromInteger (div log2n 2) :: Int + witnessList = take nchecks primes ++ take nchecks pseudoRnds + pseudoRnds = [ a | a <- integerRndSequence (n+3) , a > 1 && a < (n-1) ] + +-------------------------------------------------------------------------------- + +{- +-- | Given an integer @n@, we return an infinite sequence of pseudo-random integers +-- between @0..n-1@, generated using a crypographic hash function. +-- +integerHashSequence :: Integer -> [Integer] +integerHashSequence = error "integerHashSequence: not implemented yet" +-} + +-- | Given an integer @n@, we initialize a system random generator with using a +-- seed derived from @n@ (note that this uses at most 32 or 64 bits), and generate +-- an infinite sequence of pseudo-random integers between @0..n-1@, generated by +-- that random generator. +-- +-- Note that this is not really a preferred way of generating such sequences! +-- +integerRndSequence :: Integer -> [Integer] +integerRndSequence n = randomRs (0,n-1) gen where + gen = mkStdGen $ fromInteger (n + 17 * integerLog2 n) + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Numbers/Sequences.hs b/src/Math/Combinat/Numbers/Sequences.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Numbers/Sequences.hs @@ -0,0 +1,307 @@ + +-- | Some important number sequences. +-- +-- See the \"On-Line Encyclopedia of Integer Sequences\", +-- . + +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Numbers.Sequences where + +-------------------------------------------------------------------------------- + +import Data.Array +import Data.Bits ( shiftL , shiftR , (.&.) ) + +import Math.Combinat.Helper +import Math.Combinat.Sign + +import Math.Combinat.Numbers.Primes ( primes , factorize , productOfFactors ) + +import qualified Data.Map.Strict as Map -- used for factorialPrimeExponentsNaive + +-------------------------------------------------------------------------------- +-- * Factorial + +-- | The factorial function (A000142). +factorial :: Integral a => a -> Integer +factorial = factorialSplit + +-- | Faster implementation of the factorial function +factorialSplit :: Integral a => a -> Integer +factorialSplit n = productFromTo 1 n + +-- | Naive implementation of factorial +factorialNaive :: Integral a => a -> Integer +factorialNaive n + | n < 0 = error "factorialNaive: input should be nonnegative" + | n == 0 = 1 + | otherwise = product [1..fromIntegral n] + +-- | \"Swing factorial\" algorithm +factorialSwing :: Integral a => a -> Integer +factorialSwing n = productOfFactors (factorialPrimeExponents $ fromIntegral n) where + +-------------------------------------------------------------------------------- + +-- | Prime factorization of the factorial (using the \"swing factorial\" algorithm) +factorialPrimeExponents :: Int -> [(Integer,Int)] +factorialPrimeExponents n = filter cond $ zip primes (factorialPrimeExponents_ n) where + cond (_,!e) = e > 0 + +factorialPrimeExponentsNaive :: forall a. Integral a => a -> [(Integer,Int)] +factorialPrimeExponentsNaive n = result where + fi = fromIntegral :: a -> Integer + result = Map.toList + $ Map.unionsWith (+) + $ map Map.fromList + $ map factorize + $ map fi [1..n] + +factorialPrimeExponents_ :: Int -> [Int] +factorialPrimeExponents_ = go where + go 0 = [] + go 1 = [] + go 2 = [1] + go !n = longAdd half swing where + half = map (flip shiftL 1) $ go (shiftR n 1) + swing = swingFactorialExponents_ n + + longAdd :: [Int] -> [Int] -> [Int] + longAdd xs [] = xs + longAdd [] ys = ys + longAdd (!x:xs) (!y:ys) = (x+y) : longAdd xs ys + +-- | Prime factorizaiton of the \"swing factorial\" function) +swingFactorialExponents_ :: Int -> [Int] +swingFactorialExponents_ = go where + go 0 = [] + go 1 = [] + go 2 = [1] + go n = expo2 : map expo (tail ps) where + + nn = fromIntegral n :: Integer + + ps :: [Integer] + ps = takeWhile (<=nn) primes + + expo2 :: Int + expo2 = go 0 (shiftR n 1) where + go :: Int -> Int -> Int + go !acc !r + | r < 1 = acc + | otherwise = go acc' r' + where + acc' = acc + (r .&. 1) + r' = shiftR r 1 + + expo :: Integer -> Int + expo pp = go 0 (div n p) where + p = fromInteger pp :: Int + go :: Int -> Int -> Int + go !acc !r + | r < 1 = acc + | otherwise = go acc' r' + where + acc' = acc + (r .&. 1) + r' = div r p + +-------------------------------------------------------------------------------- + +-- | The double factorial +doubleFactorial :: Integral a => a -> Integer +doubleFactorial = doubleFactorialSplit + +-- | Faster implementation of the double factorial function +doubleFactorialSplit :: Integral a => a -> Integer +doubleFactorialSplit n + | n < 0 = error "doubleFactorialSplit: input should be nonnegative" + | n == 0 = 1 + | odd n = productFromToStride2 2 n + | otherwise = let halfn = div n 2 + in shiftL (factorialSplit halfn) (fromIntegral halfn) + +-- | Naive implementation of the double factorial (A006882). +doubleFactorialNaive :: Integral a => a -> Integer +doubleFactorialNaive n + | n < 0 = error "doubleFactorialNaive: input should be nonnegative" + | n == 0 = 1 + | odd n = product [1,3..fromIntegral n] + | otherwise = product [2,4..fromIntegral n] + +-------------------------------------------------------------------------------- +-- * Binomial and multinomial + +-- | Binomial numbers (A007318). Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below. +binomial :: Integral a => a -> a -> Integer +binomial = binomialSplit + +-- | Faster implementation of binomial +binomialSplit :: Integral a => a -> a -> Integer +binomialSplit n k + | k > n = 0 + | k < 0 = 0 + | k > (n `div` 2) = binomialSplit n (n-k) + | otherwise = (productFromTo (n-k) n) `div` (productFromTo 1 k) + +-- | A007318. Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below. +binomialNaive :: Integral a => a -> a -> Integer +binomialNaive 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 + +-- | The extension of the binomial function to negative inputs. This should satisfy the following properties: +-- +-- > for n,k >=0 : signedBinomial n k == binomial n k +-- > for any n,k : signedBinomial n k == signedBinomial n (n-k) +-- > for k >= 0 : signedBinomial (-n) k == (-1)^k * signedBinomial (n+k-1) k +-- +-- Note: This is compatible with Mathematica's @Binomial@ function. +-- +signedBinomial :: Int -> Int -> Integer +signedBinomial n k + | n >= 0 = binomial n k + | k >= 0 = negateIfOdd k $ binomial (k-n-1) k + | otherwise = negateIfOdd (n+k) $ binomial (-k-1) (-n-1) + +{- +test_signed_0 = [ signedBinomial ( n) k == signedBinomial ( n) ( n-k) | n<-[-30..40] , k<-[-30..40] ] +test_signed_1 = [ signedBinomial (-n) k == signedBinomial (-n) (-n-k) | n<-[-30..40] , k<-[-30..40] ] +test_signed_2 = [ signedBinomial (-n) k == negateIfOdd k $ signedBinomial (n+k-1) k | n<-[-30..40] , k<-[0..30] ] +-} + +-- | A given row of the Pascal triangle; equivalent to a sequence of binomial +-- numbers, but much more efficient. You can also left-fold over it. +-- +-- > pascalRow n == [ binomial n k | k<-[0..n] ] +pascalRow :: Integral a => a -> [Integer] +pascalRow n' = worker 0 1 where + n = fromIntegral n' + worker j x + | j>n = [] + | True = let j'=j+1 in x : worker j' (div (x*(n-j)) j') + +multinomial :: Integral a => [a] -> Integer +multinomial xs = div + (factorial (sum xs)) + (product [ factorial x | x<-xs ]) + +-------------------------------------------------------------------------------- +-- * Catalan numbers + +-- | Catalan numbers. OEIS:A000108. +catalan :: Integral a => a -> Integer +catalan n + | n < 0 = 0 + | otherwise = binomial (n+n) n `div` fromIntegral (n+1) + +-- | Catalan's triangle. OEIS:A009766. +-- Note: +-- +-- > catalanTriangle n n == catalan n +-- > catalanTriangle n k == countStandardYoungTableaux (toPartition [n,k]) +-- +catalanTriangle :: Integral a => a -> a -> Integer +catalanTriangle n k + | k > n = 0 + | k < 0 = 0 + | otherwise = (binomial (n+k) n * fromIntegral (n-k+1)) `div` fromIntegral (n+1) + +-------------------------------------------------------------------------------- +-- * Stirling numbers + +-- | Rows of (signed) Stirling numbers of the first kind. OEIS:A008275. +-- Coefficients of the polinomial @(x-1)*(x-2)*...*(x-n+1)@. +-- This function uses the recursion formula. +signedStirling1stArray :: Integral a => a -> Array Int Integer +signedStirling1stArray n + | n < 1 = error "stirling1stArray: n should be at least 1" + | n == 1 = listArray (1,1 ) [1] + | otherwise = listArray (1,n') [ lkp (k-1) - fromIntegral (n-1) * lkp k | k<-[1..n'] ] + where + prev = signedStirling1stArray (n-1) + n' = fromIntegral n :: Int + lkp j | j < 1 = 0 + | j >= n' = 0 + | otherwise = prev ! j + +-- | (Signed) Stirling numbers of the first kind. OEIS:A008275. +-- This function uses 'signedStirling1stArray', so it shouldn't be used +-- to compute /many/ Stirling numbers. +-- +-- Argument order: @signedStirling1st n k@ +-- +signedStirling1st :: Integral a => a -> a -> Integer +signedStirling1st n k + | k==0 && n==0 = 1 + | k < 1 = 0 + | k > n = 0 + | otherwise = signedStirling1stArray n ! (fromIntegral k) + +-- | (Unsigned) Stirling numbers of the first kind. See 'signedStirling1st'. +unsignedStirling1st :: Integral a => a -> a -> Integer +unsignedStirling1st n k = abs (signedStirling1st n k) + +-- | Stirling numbers of the second kind. OEIS:A008277. +-- This function uses an explicit formula. +-- +-- Argument order: @stirling2nd n k@ +-- +stirling2nd :: Integral a => a -> a -> Integer +stirling2nd n k + | k==0 && n==0 = 1 + | k < 1 = 0 + | k > n = 0 + | otherwise = sum xs `div` factorial k where + xs = [ negateIfOdd (k-i) $ binomial k i * (fromIntegral i)^n | i<-[0..k] ] + +-------------------------------------------------------------------------------- +-- * Bernoulli numbers + +-- | Bernoulli numbers. @bernoulli 1 == -1%2@ and @bernoulli k == 0@ for +-- k>2 and /odd/. This function uses the formula involving Stirling numbers +-- of the second kind. Numerators: A027641, denominators: A027642. +bernoulli :: Integral a => a -> Rational +bernoulli n + | n < 0 = error "bernoulli: n should be nonnegative" + | n == 0 = 1 + | n == 1 = -1/2 + | otherwise = sum [ f k | k<-[1..n] ] + where + f k = toRational (negateIfOdd (n+k) $ factorial k * stirling2nd n k) + / toRational (k+1) + +-------------------------------------------------------------------------------- +-- * Bell numbers + +-- | Bell numbers (Sloane's A000110) from B(0) up to B(n). B(0)=B(1)=1, B(2)=2, etc. +-- +-- The Bell numbers count the number of /set partitions/ of a set of size @n@ +-- +-- See +-- +bellNumbersArray :: Integral a => a -> Array Int Integer +bellNumbersArray nn = arr where + arr = array (0::Int,n) kvs + n = fromIntegral nn :: Int + kvs = (0,1) : [ (k, f k) | k<-[1..n] ] + f n = sum' [ binomial (n-1) k * arr ! k | k<-[0..n-1] ] + +-- | The n-th Bell number B(n), using the Stirling numbers of the second kind. +-- This may be slower than using 'bellNumbersArray'. +bellNumber :: Integral a => a -> Integer +bellNumber nn + | n < 0 = error "bellNumber: expecting a nonnegative index" + | n == 0 = 1 + | otherwise = sum' [ stirling2nd n k | k<-[1..n] ] + where + n = fromIntegral nn :: Int + +-------------------------------------------------------------------------------- + + + diff --git a/src/Math/Combinat/Numbers/Series.hs b/src/Math/Combinat/Numbers/Series.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Numbers/Series.hs @@ -0,0 +1,434 @@ + +-- | Some basic univariate power series expansions. +-- This module is not re-exported by "Math.Combinat". +-- +-- Note: the \"@convolveWithXXX@\" functions are much faster than the equivalent +-- @(XXX \`convolve\`)@! +-- +-- TODO: better names for these functions. +-- + +{-# LANGUAGE CPP, BangPatterns, GeneralizedNewtypeDeriving #-} +module Math.Combinat.Numbers.Series where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Sign +import Math.Combinat.Numbers +import Math.Combinat.Partitions.Integer +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * Trivial series + +-- | The series [1,0,0,0,0,...], which is the neutral element for the convolution. +{-# SPECIALIZE unitSeries :: [Integer] #-} +unitSeries :: Num a => [a] +unitSeries = 1 : repeat 0 + +-- | Constant zero series +zeroSeries :: Num a => [a] +zeroSeries = repeat 0 + +-- | Power series representing a constant function +constSeries :: Num a => a -> [a] +constSeries x = x : repeat 0 + +-- | The power series representation of the identity function @x@ +idSeries :: Num a => [a] +idSeries = 0 : 1 : repeat 0 + +-- | The power series representation of @x^n@ +powerTerm :: Num a => Int -> [a] +powerTerm n = replicate n 0 ++ (1 : repeat 0) + +-------------------------------------------------------------------------------- +-- * Basic operations on power series + +addSeries :: Num a => [a] -> [a] -> [a] +addSeries xs ys = longZipWith 0 0 (+) xs ys + +sumSeries :: Num a => [[a]] -> [a] +sumSeries [] = [0] +sumSeries xs = foldl1' addSeries xs + +subSeries :: Num a => [a] -> [a] -> [a] +subSeries xs ys = longZipWith 0 0 (-) xs ys + +negateSeries :: Num a => [a] -> [a] +negateSeries = map negate + +scaleSeries :: Num a => a -> [a] -> [a] +scaleSeries s = map (*s) + +-- | A different implementation, taken from: +-- +-- M. Douglas McIlroy: Power Series, Power Serious +mulSeries :: Num a => [a] -> [a] -> [a] +mulSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where + go (f:fs) ggs@(g:gs) = f*g : (scaleSeries f gs) `addSeries` go fs ggs + +-- | Multiplication of power series. This implementation is a synonym for 'convolve' +mulSeriesNaive :: Num a => [a] -> [a] -> [a] +mulSeriesNaive = convolve + +productOfSeries :: Num a => [[a]] -> [a] +productOfSeries = convolveMany + +-------------------------------------------------------------------------------- +-- * Convolution (product) + +-- | Convolution of series (that is, multiplication of power series). +-- The result is always an infinite list. Warning: This is slow! +convolve :: Num a => [a] -> [a] -> [a] +convolve xs1 ys1 = res where + res = [ foldl' (+) 0 (zipWith (*) xs (reverse (take n ys))) + | n<-[1..] + ] + xs = xs1 ++ repeat 0 + ys = ys1 ++ repeat 0 + +-- | Convolution (= product) of many series. Still slow! +convolveMany :: Num a => [[a]] -> [a] +convolveMany [] = 1 : repeat 0 +convolveMany xss = foldl1 convolve xss + +-------------------------------------------------------------------------------- +-- * Reciprocals of general power series + +-- | Division of series. +-- +-- Taken from: M. Douglas McIlroy: Power Series, Power Serious +divSeries :: (Eq a, Fractional a) => [a] -> [a] -> [a] +divSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where + go (0:fs) (0:gs) = go fs gs + go (f:fs) ggs@(g:gs) = let q = f/g in q : go (fs `subSeries` scaleSeries q gs) ggs + +-- | Given a power series, we iteratively compute its multiplicative inverse +reciprocalSeries :: (Eq a, Fractional a) => [a] -> [a] +reciprocalSeries series = case series of + [] -> error "reciprocalSeries: empty input series (const 0 function does not have an inverse)" + (a:as) -> case a of + 0 -> error "reciprocalSeries: input series has constant term 0" + _ -> map (/a) $ integralReciprocalSeries $ map (/a) series + +-- | Given a power series starting with @1@, we can compute its multiplicative inverse +-- without divisions. +-- +{-# SPECIALIZE integralReciprocalSeries :: [Int] -> [Int] #-} +{-# SPECIALIZE integralReciprocalSeries :: [Integer] -> [Integer] #-} +integralReciprocalSeries :: (Eq a, Num a) => [a] -> [a] +integralReciprocalSeries series = case series of + [] -> error "integralReciprocalSeries: empty input series (const 0 function does not have an inverse)" + (a:as) -> case a of + 1 -> 1 : worker [1] + _ -> error "integralReciprocalSeries: input series must start with 1" + where + worker bs = let b' = - sum (zipWith (*) (tail series) bs) + in b' : worker (b':bs) + +-------------------------------------------------------------------------------- +-- * Composition of formal power series + +-- | @g \`composeSeries\` f@ is the power series expansion of @g(f(x))@. +-- This is a synonym for @flip substitute@. +-- +-- This implementation is taken from +-- +-- M. Douglas McIlroy: Power Series, Power Serious +composeSeries :: (Eq a, Num a) => [a] -> [a] -> [a] +composeSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where + go (f:fs) (0:gs) = f : mulSeries gs (go fs (0:gs)) + go (f:fs) (_:gs) = error "PowerSeries/composeSeries: we expect the the constant term of the inner series to be zero" + +-- | @substitute f g@ is the power series corresponding to @g(f(x))@. +-- Equivalently, this is the composition of univariate functions (in the \"wrong\" order). +-- +-- Note: for this to be meaningful in general (not depending on convergence properties), +-- we need that the constant term of @f@ is zero. +substitute :: (Eq a, Num a) => [a] -> [a] -> [a] +substitute f g = composeSeries g f + +-- | Naive implementation of 'composeSeries' (via 'substituteNaive') +composeSeriesNaive :: (Eq a, Num a) => [a] -> [a] -> [a] +composeSeriesNaive g f = substituteNaive f g + +-- | Naive implementation of 'substitute' +substituteNaive :: (Eq a, Num a) => [a] -> [a] -> [a] +substituteNaive as_ bs_ = + case head as of + 0 -> [ f n | n<-[0..] ] + _ -> error "PowerSeries/substituteNaive: we expect the the constant term of the inner series to be zero" + where + as = as_ ++ repeat 0 + bs = bs_ ++ repeat 0 + a i = as !! i + b j = bs !! j + f n = sum + [ b m * product [ (a i)^j | (i,j)<-es ] * fromInteger (multinomial (map snd es)) + | p <- partitions n + , let es = toExponentialForm p + , let m = partitionWidth p + ] + +-------------------------------------------------------------------------------- +-- * Lagrange inversions + +-- | We expect the input series to match @(0:a1:_)@. with a1 nonzero The following is true for the result (at least with exact arithmetic): +-- +-- > substitute f (lagrangeInversion f) == (0 : 1 : repeat 0) +-- > substitute (lagrangeInversion f) f == (0 : 1 : repeat 0) +-- +-- This implementation is taken from: +-- +-- M. Douglas McIlroy: Power Series, Power Serious +lagrangeInversion :: (Eq a, Fractional a) => [a] -> [a] +lagrangeInversion xs = go (xs ++ repeat 0) where + go (0:fs) = rs where rs = 0 : divSeries unitSeries (composeSeries fs rs) + go (_:fs) = error "lagrangeInversion: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero" + +-- | Coefficients of the Lagrange inversion +lagrangeCoeff :: Partition -> Integer +lagrangeCoeff p = div numer denom where + numer = (-1)^m * product (map fromIntegral [n+1..n+m]) + denom = fromIntegral (n+1) * product (map (factorial . snd) es) + m = partitionWidth p + n = partitionWeight p + es = toExponentialForm p + +-- | We expect the input series to match @(0:1:_)@. The following is true for the result (at least with exact arithmetic): +-- +-- > substitute f (integralLagrangeInversion f) == (0 : 1 : repeat 0) +-- > substitute (integralLagrangeInversion f) f == (0 : 1 : repeat 0) +-- +integralLagrangeInversionNaive :: (Eq a, Num a) => [a] -> [a] +integralLagrangeInversionNaive series_ = + case series of + (0:1:rest) -> 0 : 1 : [ f n | n<-[1..] ] + _ -> error "integralLagrangeInversionNaive: the series should start with (0 + x + a2*x^2 + ...)" + where + series = series_ ++ repeat 0 + as = tail series + a i = as !! i + f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ] + | p <- partitions n + ] + +-- | Naive implementation of 'lagrangeInversion' +lagrangeInversionNaive :: (Eq a, Fractional a) => [a] -> [a] +lagrangeInversionNaive series_ = + case series of + (0:a1:rest) -> if a1 ==0 + then err + else 0 : (1/a1) : [ f n / a1^(n+1) | n<-[1..] ] + _ -> err + where + err = error "lagrangeInversionNaive: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero" + series = series_ ++ repeat 0 + a1 = series !! 1 + as = map (/a1) (tail series) + a i = as !! i + f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ] + | p <- partitions n + ] + + +-------------------------------------------------------------------------------- +-- * Differentiation and integration + +differentiateSeries :: Num a => [a] -> [a] +differentiateSeries (y:ys) = go (1::Int) ys where + go !n (x:xs) = fromIntegral n * x : go (n+1) xs + go _ [] = [] + +integrateSeries :: Fractional a => [a] -> [a] +integrateSeries ys = 0 : go (1::Int) ys where + go !n (x:xs) = x / (fromIntegral n) : go (n+1) xs + go _ [] = [] + +-------------------------------------------------------------------------------- +-- * Power series expansions of elementary functions + +-- | Power series expansion of @exp(x)@ +expSeries :: Fractional a => [a] +expSeries = go 0 1 where + go i e = e : go (i+1) (e / (i+1)) + +-- | Power series expansion of @cos(x)@ +cosSeries :: Fractional a => [a] +cosSeries = go 0 1 where + go i e = e : 0 : go (i+2) (-e / ((i+1)*(i+2))) + +-- | Power series expansion of @sin(x)@ +sinSeries :: Fractional a => [a] +sinSeries = go 1 1 where + go i e = 0 : e : go (i+2) (-e / ((i+1)*(i+2))) + +-- | Alternative implementation using differential equations. +-- +-- Taken from: M. Douglas McIlroy: Power Series, Power Serious +cosSeries2, sinSeries2 :: Fractional a => [a] +cosSeries2 = unitSeries `subSeries` integrateSeries sinSeries2 +sinSeries2 = integrateSeries cosSeries2 + +-- | Power series expansion of @cosh(x)@ +coshSeries :: Fractional a => [a] +coshSeries = go 0 1 where + go i e = e : 0 : go (i+2) (e / ((i+1)*(i+2))) + +-- | Power series expansion of @sinh(x)@ +sinhSeries :: Fractional a => [a] +sinhSeries = go 1 1 where + go i e = 0 : e : go (i+2) (e / ((i+1)*(i+2))) + +-- | Power series expansion of @log(1+x)@ +log1Series :: Fractional a => [a] +log1Series = 0 : go 1 1 where + go i e = (e/i) : go (i+1) (-e) + +-- | Power series expansion of @(1-Sqrt[1-4x])/(2x)@ (the coefficients are the Catalan numbers) +dyckSeries :: Num a => [a] +dyckSeries = [ fromInteger (catalan i) | i<-[(0::Int)..] ] + +-------------------------------------------------------------------------------- +-- * \"Coin\" series + +-- | Power series expansion of +-- +-- > 1 / ( (1-x^k_1) * (1-x^k_2) * ... * (1-x^k_n) ) +-- +-- Example: +-- +-- @(coinSeries [2,3,5])!!k@ is the number of ways +-- to pay @k@ dollars with coins of two, three and five dollars. +-- +-- TODO: better name? +coinSeries :: [Int] -> [Integer] +coinSeries [] = 1 : repeat 0 +coinSeries (k:ks) = xs where + xs = zipWith (+) (coinSeries ks) (replicate k 0 ++ xs) + +-- | Generalization of the above to include coefficients: expansion of +-- +-- > 1 / ( (1-a_1*x^k_1) * (1-a_2*x^k_2) * ... * (1-a_n*x^k_n) ) +-- +coinSeries' :: Num a => [(a,Int)] -> [a] +coinSeries' [] = 1 : repeat 0 +coinSeries' ((a,k):aks) = xs where + xs = zipWith (+) (coinSeries' aks) (replicate k 0 ++ map (*a) xs) + +convolveWithCoinSeries :: [Int] -> [Integer] -> [Integer] +convolveWithCoinSeries ks series1 = worker ks where + series = series1 ++ repeat 0 + worker [] = series + worker (k:ks) = xs where + xs = zipWith (+) (worker ks) (replicate k 0 ++ xs) + +convolveWithCoinSeries' :: Num a => [(a,Int)] -> [a] -> [a] +convolveWithCoinSeries' ks series1 = worker ks where + series = series1 ++ repeat 0 + worker [] = series + worker ((a,k):aks) = xs where + xs = zipWith (+) (worker aks) (replicate k 0 ++ map (*a) xs) + +-------------------------------------------------------------------------------- +-- * Reciprocals of products of polynomials + +-- | Convolution of many 'pseries', that is, the expansion of the reciprocal +-- of a product of polynomials +productPSeries :: [[Int]] -> [Integer] +productPSeries = foldl (flip convolveWithPSeries) unitSeries + +-- | The same, with coefficients. +productPSeries' :: Num a => [[(a,Int)]] -> [a] +productPSeries' = foldl (flip convolveWithPSeries') unitSeries + +convolveWithProductPSeries :: [[Int]] -> [Integer] -> [Integer] +convolveWithProductPSeries kss ser = foldl (flip convolveWithPSeries) ser kss + +-- | This is the most general function in this module; all the others +-- are special cases of this one. +convolveWithProductPSeries' :: Num a => [[(a,Int)]] -> [a] -> [a] +convolveWithProductPSeries' akss ser = foldl (flip convolveWithPSeries') ser akss + +-------------------------------------------------------------------------------- +-- * Reciprocals of polynomials + +-- Reciprocals of polynomials, without coefficients + +-- | The power series expansion of +-- +-- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n) +-- +pseries :: [Int] -> [Integer] +pseries ks = convolveWithPSeries ks unitSeries + +-- | Convolve with (the expansion of) +-- +-- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n) +-- +convolveWithPSeries :: [Int] -> [Integer] -> [Integer] +convolveWithPSeries ks series1 = ys where + series = series1 ++ repeat 0 + ys = worker ks ys + worker [] _ = series + worker (k:ks) ys = xs where + xs = zipWith (+) (replicate k 0 ++ ys) (worker ks ys) + +-------------------------------------------------------------------------------- +-- Reciprocals of polynomials, with coefficients + +-- | The expansion of +-- +-- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n) +-- +pseries' :: Num a => [(a,Int)] -> [a] +pseries' aks = convolveWithPSeries' aks unitSeries + +-- | Convolve with (the expansion of) +-- +-- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n) +-- +convolveWithPSeries' :: Num a => [(a,Int)] -> [a] -> [a] +convolveWithPSeries' aks series1 = ys where + series = series1 ++ repeat 0 + ys = worker aks ys + worker [] _ = series + worker ((a,k):aks) ys = xs where + xs = zipWith (+) (replicate k 0 ++ map (*a) ys) (worker aks ys) + +{- +data Sign = Plus | Minus deriving (Eq,Show) + +signValue :: Num a => Sign -> a +signValue Plus = 1 +signValue Minus = -1 +-} + +signedPSeries :: [(Sign,Int)] -> [Integer] +signedPSeries aks = convolveWithSignedPSeries aks unitSeries + +-- | Convolve with (the expansion of) +-- +-- > 1 / (1 +- x^k_1 +- x^k_2 +- x^k_3 +- ... +- x^k_n) +-- +-- Should be faster than using `convolveWithPSeries'`. +-- Note: 'Plus' corresponds to the coefficient @-1@ in `pseries'` (since +-- there is a minus sign in the definition there)! +convolveWithSignedPSeries :: [(Sign,Int)] -> [Integer] -> [Integer] +convolveWithSignedPSeries aks series1 = ys where + series = series1 ++ repeat 0 + ys = worker aks ys + worker [] _ = series + worker ((a,k):aks) ys = xs where + xs = case a of + Minus -> zipWith (+) one two + Plus -> zipWith (-) one two + one = worker aks ys + two = replicate k 0 ++ ys + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Partitions.hs b/src/Math/Combinat/Partitions.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions.hs @@ -0,0 +1,22 @@ + +-- | Partitions of integers and multisets. +-- Integer partitions are nonincreasing sequences of positive integers. +-- +-- See: +-- +-- * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B. +-- +-- * +-- + +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Partitions + ( module Math.Combinat.Partitions.Integer + ) + where + +-------------------------------------------------------------------------------- + +import Math.Combinat.Partitions.Integer + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Integer.hs b/src/Math/Combinat/Partitions/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Integer.hs @@ -0,0 +1,459 @@ + +-- | 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 CPP, BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Partitions.Integer + ( -- module Math.Combinat.Partitions.Integer.Count + module Math.Combinat.Partitions.Integer.Naive + -- * Types and basic stuff + , Partition + -- * Conversion to\/from lists + , fromPartition + , mkPartition + , toPartition + , toPartitionUnsafe + , isPartition + -- * Conversion to\/from exponent vectors + , toExponentVector + , fromExponentVector + , dropTailingZeros + -- * Union and sum + , unionOfPartitions + , sumOfPartitions + -- * Generating partitions + , partitions + , partitions' + , allPartitions + , allPartitionsGrouped + , allPartitions' + , allPartitionsGrouped' + -- * Counting partitions + , countPartitions + , countPartitions' + , countAllPartitions + , countAllPartitions' + , countPartitionsWithKParts + -- * Random partitions + , randomPartition + , randomPartitions + -- * Dominating \/ dominated partitions + , dominanceCompare + , dominatedPartitions + , dominatingPartitions + -- * Conjugate lexicographic ordering + , conjugateLexicographicCompare + , ConjLex (..) , fromConjLex + -- * Partitions with given number of parts + , partitionsWithKParts + -- * Partitions with only odd\/distinct parts + , partitionsWithOddParts + , partitionsWithDistinctParts + -- * Sub- and super-partitions of a given partition + , subPartitions + , allSubPartitions + , superPartitions + -- * ASCII Ferrers diagrams + , PartitionConvention(..) + , asciiFerrersDiagram + , asciiFerrersDiagram' + ) + where + +-------------------------------------------------------------------------------- + +import Data.List +import Control.Monad ( liftM , replicateM ) + +-- import Data.Map (Map) +-- import qualified Data.Map as Map + +import Math.Combinat.Classes +import Math.Combinat.ASCII as ASCII +import Math.Combinat.Numbers (factorial,binomial,multinomial) +import Math.Combinat.Helper + +import Data.Array +import System.Random + +import Math.Combinat.Partitions.Integer.Naive hiding () -- this is for haddock! +import Math.Combinat.Partitions.Integer.IntList +import Math.Combinat.Partitions.Integer.Count + +--------------------------------------------------------------------------------- +-- * Conversion to\/from lists + +fromPartition :: Partition -> [Int] +fromPartition (Partition_ part) = part + +-- | Sorts the input, and cuts the nonpositive elements. +mkPartition :: [Int] -> Partition +mkPartition xs = toPartitionUnsafe $ sortBy (reverseCompare) $ filter (>0) xs + +-- | 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" + +-- | Assumes that the input is decreasing. +toPartitionUnsafe :: [Int] -> Partition +toPartitionUnsafe = Partition_ + +-- | This returns @True@ if the input is non-increasing sequence of +-- /positive/ integers (possibly empty); @False@ otherwise. +-- +isPartition :: [Int] -> Bool +isPartition [] = True +isPartition [x] = x > 0 +isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs + +-------------------------------------------------------------------------------- +-- * Conversion to\/from exponent vectors + +-- | Converts a partition to an exponent vector. +-- +-- For example, +-- +-- > toExponentVector (Partition [4,4,2,2,2,1]) == [1,3,0,2] +-- +-- meaning @(1^1,2^3,3^0,4^2)@. +-- +toExponentVector :: Partition -> [Int] +toExponentVector part = fun 1 $ reverse $ group (fromPartition part) where + fun _ [] = [] + fun !k gs@(this@(i:_):rest) + | k < i = replicate (i-k) 0 ++ fun i gs + | otherwise = length this : fun (k+1) rest + +fromExponentVector :: [Int] -> Partition +fromExponentVector expos = Partition $ concat $ reverse $ zipWith f [1..] expos where + f !i !e = replicate e i + +dropTailingZeros :: [Int] -> [Int] +dropTailingZeros = reverse . dropWhile (==0) . reverse + +{- +-- alternative implementation +toExponentialVector2 :: Partition -> [Int] +toExponentialVector2 p = go 1 (toExponentialForm p) where + go _ [] = [] + go !i ef@((j,e):rest) = if i Partition [4,2,1] `unionOfPartitions` Partition [4,3,1] == Partition [4,4,3,2,1,1] +-- +-- Note: This is the dual of pointwise sum, 'sumOfPartitions' +-- +unionOfPartitions :: Partition -> Partition -> Partition +unionOfPartitions (Partition_ xs) (Partition_ ys) = mkPartition (xs ++ ys) + +-- | Pointwise sum of the parts. For example: +-- +-- > Partition [3,2,1,1] `sumOfPartitions` Partition [4,3,1] == Partition [7,5,2,1] +-- +-- Note: This is the dual of 'unionOfPartitions' +-- +sumOfPartitions :: Partition -> Partition -> Partition +sumOfPartitions (Partition_ xs) (Partition_ ys) = Partition_ (longZipWith 0 0 (+) xs ys) + +-------------------------------------------------------------------------------- +-- * Generating partitions + +-- | Partitions of @d@. +partitions :: Int -> [Partition] +partitions = map toPartitionUnsafe . _partitions + +-- | 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 + +-------------------------------------------------------------------------------- + +-- | 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 = concat [ partitions i | i <- [0..d] ] + +-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@), +-- grouped by weight +allPartitionsGrouped :: Int -> [[Partition]] +allPartitionsGrouped d = [ partitions i | i <- [0..d] ] + +-- | All integer partitions fitting into a given rectangle. +allPartitions' + :: (Int,Int) -- ^ (height,width) + -> [Partition] +allPartitions' (h,w) = concat [ partitions' (h,w) i | i <- [0..d] ] where d = h*w + +-- | All integer partitions fitting into a given rectangle, grouped by weight. +allPartitionsGrouped' + :: (Int,Int) -- ^ (height,width) + -> [[Partition]] +allPartitionsGrouped' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w + + +--------------------------------------------------------------------------------- +-- * Random partitions + +-- | Uniformly random partition of the given weight. +-- +-- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely), +-- and the first time it is executed may be slower (as it needs to build the table of partitions counts first) +-- +-- Algorithm of Nijenhuis and Wilf (1975); see +-- +-- * Knuth Vol 4A, pre-fascicle 3B, exercise 47; +-- +-- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10 +-- +randomPartition :: RandomGen g => Int -> g -> (Partition, g) +randomPartition n g = (p, g') where + ([p], g') = randomPartitions 1 n g + +-- | Generates several uniformly random partitions of @n@ at the same time. +-- Should be a little bit faster then generating them individually. +-- +randomPartitions + :: forall g. RandomGen g + => Int -- ^ number of partitions to generate + -> Int -- ^ the weight of the partitions + -> g -> ([Partition], g) +randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where + + cnt = countPartitions + + finish :: [(Int,Int)] -> Partition + finish = mkPartition . concatMap f where f (j,d) = replicate j d + + fi :: Int -> Integer + fi = fromIntegral + + find_jd :: Int -> Integer -> (Int,Int) + find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where + go :: Integer -> [(Int,Int)] -> (Int,Int) + go !s [] = (1,1) -- ?? + go !s [jd] = jd -- ?? + go !s (jd@(j,d):rest) = + if s' > capm + then jd + else go s' rest + where + s' = s + fi d * cnt (m - j*d) + + worker :: Int -> [(Int,Int)] -> Rand g Partition + worker 0 acc = return $ finish acc + worker !m acc = do + capm <- randChoose (0, (fi m) * cnt m - 1) + let jd@(!j,!d) = find_jd m capm + worker (m - j*d) (jd:acc) + +-------------------------------------------------------------------------------- +-- * Dominating \/ dominated partitions + +-- | Dominance partial ordering as a partial ordering. +dominanceCompare :: Partition -> Partition -> Maybe Ordering +dominanceCompare p q + | p==q = Just EQ + | p `dominates` q = Just GT + | q `dominates` p = Just LT + | otherwise = Nothing + +-- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@ +-- (that is, all partial sums are less or equal): +-- +-- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ] +-- +dominatedPartitions :: Partition -> [Partition] +dominatedPartitions (Partition_ lambda) = map Partition_ (_dominatedPartitions lambda) + +-- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@ +-- (that is, all partial sums are greater or equal): +-- +-- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ] +-- +dominatingPartitions :: Partition -> [Partition] +dominatingPartitions (Partition_ mu) = map Partition_ (_dominatingPartitions mu) + +-------------------------------------------------------------------------------- +-- * Conjugate lexicographic ordering + +conjugateLexicographicCompare :: Partition -> Partition -> Ordering +conjugateLexicographicCompare p q = compare (dualPartition q) (dualPartition p) + +newtype ConjLex = ConjLex Partition deriving (Eq,Show) + +fromConjLex :: ConjLex -> Partition +fromConjLex (ConjLex p) = p + +instance Ord ConjLex where + compare (ConjLex p) (ConjLex q) = conjugateLexicographicCompare p q + +-- {- CONJUGATE LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -} +-- let test n = [ ConjLex p >= ConjLex q | p <- partitions n , q <-partitions n , p `dominates` q ] +-- and (test 20) + +-- {- LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -} +-- let test n = [ p >= q | p <- partitions n , q <-partitions n , p `dominates` q ] +-- and (test 20) + +-------------------------------------------------------------------------------- +-- * 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) ] + +-------------------------------------------------------------------------------- +-- * Partitions with only odd\/distinct parts + +-- | Partitions of @n@ with only odd parts +partitionsWithOddParts :: Int -> [Partition] +partitionsWithOddParts d = map Partition_ (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] + +{- +-- | Partitions of @n@ with only even parts +-- +-- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@ +-- +partitionsWithEvenParts :: Int -> [Partition] +partitionsWithEvenParts d = map Partition (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ] +-} + +-- | Partitions of @n@ with distinct parts. +-- +-- Note: +-- +-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) +-- +partitionsWithDistinctParts :: Int -> [Partition] +partitionsWithDistinctParts d = map Partition_ (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] + +-------------------------------------------------------------------------------- +-- * Sub- and super-partitions of a given partition + +-- | 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) + +-- | All sub-partitions of a given partition +allSubPartitions :: Partition -> [Partition] +allSubPartitions (Partition_ ps) = map Partition_ (_allSubPartitions ps) + +-- | Super-partitions of a given partition with the given weight: +-- +-- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ] +-- +superPartitions :: Int -> Partition -> [Partition] +superPartitions d (Partition_ ps) = map toPartitionUnsafe (_superPartitions d ps) + + +-------------------------------------------------------------------------------- +-- * 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 + +instance DrawASCII Partition where + ascii = asciiFerrersDiagram + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Partitions/Integer/Compact.hs b/src/Math/Combinat/Partitions/Integer/Compact.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Integer/Compact.hs @@ -0,0 +1,355 @@ + +{- | Compact representation of integer partitions. + +Partitions are conceptually nonincreasing sequences of /positive/ integers. + +This implementation uses the @compact-word-vectors@ library internally to provide +a much more memory-efficient Partition type that the naive lists of integer. +This is very helpful when building large tables indexed by partitions, for example; +and hopefully quite a bit faster, too. + +Note: This is an internal module, you are not supposed to import it directly. +It is also not fully ready to be used yet... + +-} + +{-# LANGUAGE BangPatterns, PatternSynonyms, ViewPatterns #-} +module Math.Combinat.Partitions.Integer.Compact where + +-------------------------------------------------------------------------------- + +import Data.Bits +import Data.Word +import Data.Ord +import Data.List ( intercalate , group , sort , sortBy , foldl' , scanl' ) + +import Data.Vector.Compact.WordVec ( WordVec , Shape(..) ) +import qualified Data.Vector.Compact.WordVec as V + +import Math.Combinat.Compositions ( compositions' ) + +-------------------------------------------------------------------------------- +-- * The compact partition data type + +newtype Partition + = Partition WordVec + deriving Eq + +instance Show Partition where + showsPrec = showsPrecPartition + +showsPrecPartition :: Int -> Partition -> ShowS +showsPrecPartition prec (Partition vec) + = showParen (prec > 10) + $ showString "Partition" + . showChar ' ' + . shows (V.toList vec) + +instance Ord Partition where + compare = cmpLexico + +-------------------------------------------------------------------------------- +-- * Pattern synonyms + +-- | Pattern sysnonyms allows us to use existing code with minimal modifications +pattern Nil :: Partition +pattern Nil <- (isEmpty -> True) where + Nil = empty + +pattern Cons :: Int -> Partition -> Partition +pattern Cons x xs <- (uncons -> Just (x,xs)) where + Cons x xs = cons x xs + +-- | Simulated newtype constructor +pattern Partition_ :: [Int] -> Partition +pattern Partition_ xs <- (toList -> xs) where + Partition_ xs = fromDescList xs + +pattern Head :: Int -> Partition +pattern Head h <- (height -> h) + +pattern Tail :: Partition -> Partition +pattern Tail xs <- (partitionTail -> xs) + +pattern Length :: Int -> Partition +pattern Length n <- (width -> n) + +-------------------------------------------------------------------------------- +-- * Lexicographic comparison + +-- | The lexicographic ordering +cmpLexico :: Partition -> Partition -> Ordering +cmpLexico (Partition vec1) (Partition vec2) = compare (V.toList vec1) (V.toList vec2) + +-------------------------------------------------------------------------------- +-- * Basic (de)constructrion + +empty :: Partition +empty = Partition (V.empty) + +isEmpty :: Partition -> Bool +isEmpty (Partition vec) = V.null vec + +-------------------------------------------------------------------------------- + +singleton :: Int -> Partition +singleton x + | x > 0 = Partition (V.singleton $ i2w x) + | x == 0 = empty + | otherwise = error "Parittion/singleton: negative input" + +-------------------------------------------------------------------------------- + +uncons :: Partition -> Maybe (Int,Partition) +uncons (Partition vec) = case V.uncons vec of + Nothing -> Nothing + Just (h,tl) -> Just (w2i h, Partition tl) + +-- | @partitionTail p == snd (uncons p)@ +partitionTail :: Partition -> Partition +partitionTail (Partition vec) = Partition (V.tail vec) + +------------------------------------------------------------------------------- + +-- | We assume that @x >= partitionHeight p@! +cons :: Int -> Partition -> Partition +cons !x (Partition !vec) + | V.null vec = Partition (if x > 0 then V.singleton y else V.empty) + | y >= h = Partition (V.cons y vec) + | otherwise = error "Partition/cons: invalid element to cons" + where + y = i2w x + h = V.head vec + +-------------------------------------------------------------------------------- + +-- | We assume that the element is not bigger than the last element! +snoc :: Partition -> Int -> Partition +snoc (Partition !vec) !x + | x == 0 = Partition vec + | V.null vec = Partition (V.singleton y) + | y <= V.last vec = Partition (V.snoc vec y) + | otherwise = error "Partition/snoc: invalid element to snoc" + where + y = i2w x + +-------------------------------------------------------------------------------- +-- * exponential form + +toExponentialForm :: Partition -> [(Int,Int)] +toExponentialForm = map (\xs -> (head xs,length xs)) . group . toAscList + +fromExponentialForm :: [(Int,Int)] -> Partition +fromExponentialForm = fromDescList . concatMap f . sortBy g where + f (!i,!e) = replicate e i + g (!i, _) (!j,_) = compare j i + +-------------------------------------------------------------------------------- +-- * Width and height of the bounding rectangle + +-- | Width, or the number of parts +width :: Partition -> Int +width (Partition vec) = V.vecLen vec + +-- | Height, or the first (that is, the largest) element +height :: Partition -> Int +height (Partition vec) = w2i (V.head vec) + +-- | Width and height +widthHeight :: Partition -> (Int,Int) +widthHeight (Partition vec) = (V.vecLen vec , w2i (V.head vec)) + +-------------------------------------------------------------------------------- +-- * Differential sequence + +-- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the sequence of differences +-- @[a1-a2,a2-a3,...,an-0]@ +diffSequence :: Partition -> [Int] +diffSequence = go . toDescList where + go (x:ys@(y:_)) = (x-y) : go ys + go [x] = [x] + go [] = [] + +---------------------------------------- + +-- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the reversed sequence of differences +-- @[ a[n]-0 , a[n-1]-a[n] , ... , a[2]-a[3] , a[1]-a[2] ] @ +reverseDiffSequence :: Partition -> [Int] +reverseDiffSequence p = go (0 : toAscList p) where + go (x:ys@(y:_)) = (y-x) : go ys + go [x] = [] + go [] = [] + +-------------------------------------------------------------------------------- +-- * Dual partition + +dualPartition :: Partition -> Partition +dualPartition compact@(Partition vec) + | V.null vec = Partition V.empty + | otherwise = Partition (V.fromList' shape $ map i2w dual) + where + height = V.head vec + len = V.vecLen vec + shape = Shape (w2i height) (V.bitsNeededFor $ i2w len) + dual = concat + [ replicate d j + | (j,d) <- zip (descendToOne len) (reverseDiffSequence compact) + ] + +-------------------------------------------------------------------------------- +-- * Conversion to list + +toList :: Partition -> [Int] +toList = toDescList + +-- | returns a descending (non-increasing) list +toDescList :: Partition -> [Int] +toDescList (Partition vec) = map w2i (V.toList vec) + +-- | Returns a reversed (ascending; non-decreasing) list +toAscList :: Partition -> [Int] +toAscList (Partition vec) = map w2i (V.toRevList vec) + +-------------------------------------------------------------------------------- +-- * Conversion from list + +fromDescList :: [Int] -> Partition +fromDescList list = fromDescList' (length list) list + +-- | We assume that the input is a non-increasing list of /positive/ integers! +fromDescList' + :: Int -- ^ length + -> [Int] -- ^ the list + -> Partition +fromDescList' !len !list = Partition (V.fromList' (Shape len bits) $ map i2w list) where + bits = case list of + [] -> 4 + (x:xs) -> V.bitsNeededFor (i2w x) + +-------------------------------------------------------------------------------- +-- * Partial orderings + +-- @ |p `isSubPartitionOf` q@ +isSubPartitionOf :: Partition -> Partition -> Bool +isSubPartitionOf p q = and $ zipWith (<=) (toList p) (toList q ++ repeat 0) + +-- | @q `dominates` p@ +dominates :: Partition -> Partition -> Bool +dominates (Partition vec_q) (Partition vec_p) = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) where + sums = tail . scanl' (+) 0 + ps = V.toList vec_p + qs = V.toList vec_q + +-------------------------------------------------------------------------------- +-- * Pieri rule + +-- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See +pieriRule :: Partition -> Int -> [Partition] +pieriRule = error "Partitions/Integer/Compact: pieriRule not implemented yet" + +{- +-- | Expands to product @s[lambda]*h[1] = s[lambda]*e[1]@ as a sum of @s[mu]@-s. See +pieriRuleSingleBox :: Partition -> [Partition] +pieriRuleSingleBox !compact = case compact of + + Nibble 0 -> [ singleton 1 ] + + Nibble w | h < 15 -> + [ Nibble (w + shiftL 1 (60-4*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ] + + Medium1 w | h < 255 -> + [ Medium1 (w + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ] + + Medium2 w1 w2 | h < 255 -> + let (diffs1a,diffs1b) = splitAt 8 diffs1 + in [ Medium2 (w1 + shiftL 1 (56-8*i)) w2 | (i,d)<-zip [0..7 ] diffs1a , d>0 ] ++ + [ Medium2 w1 (w2 + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-9] diffs1b , d>0 ] ++ + [ snoc compact 1 ] + + Medium3 w1 w2 w3 | h < 255 -> + let (diffs1a,tmp ) = splitAt 8 diffs1 + (diffs1b,diffs1c) = splitAt 8 tmp + in [ Medium3 (w1 + shiftL 1 (56-8*i)) w2 w3 | (i,d)<-zip [0..7 ] diffs1a , d>0 ] ++ + [ Medium3 w1 (w2 + shiftL 1 (56-8*i)) w3 | (i,d)<-zip [0..7 ] diffs1b , d>0 ] ++ + [ Medium3 w1 w2 (w3 + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-17] diffs1c , d>0 ] ++ + [ snoc compact 1 ] + + _ -> genericSingleBox + + where + (n,h) = widthHeight compact + list = toDescList compact + diffs1 = 1 : diffSequence compact + + genericSingleBox :: [Partition] + genericSingleBox = map (fromDescList' n) (go list diffs1) ++ [ fromDescList' (n+1) (list ++ [1]) ] where + go :: [Int] -> [Int] -> [[Int]] + go (a:as) (d:ds) = if d > 0 then ((a+1):as) : map (a:) (go as ds) + else map (a:) (go as ds) + go [] _ = [] + +-- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See +pieriRule :: Partition -> Int -> [Partition] +pieriRule !compact !k + | k < 0 = [] + | k == 0 = [ compact ] + | k == 1 = pieriRuleSingleBox compact + | h == 0 = [ singleton k ] + | h + k <= 15 && n < 15 = case compact of { Nibble w -> + [ Nibble (w + encode c) | c <- comps ] } + | otherwise = [ fromDescList' (n+b) xs | c <- comps , let (b,xs) = add c ] + + where + (n,h) = widthHeight compact + list = toDescList compact + bounds = k : {- map (min k) -} (diffSequence compact) + comps = compositions' bounds k + + add clist = go list clist where + go (!p:ps) (!c:cs) = let (b,rest) = go ps cs in (b, (p+c):rest) + go [] [c] = if c>0 then (1,[c]) else (0,[]) + go _ _ = error "Compact/pieriRule/add: shouldn't happen" + + encode :: [Int] -> Word64 + encode = go 60 where + go !k [c] = if c==0 then 0 else shiftL (i2w c) k + 1 + go !k (c:cs) = shiftL (i2w c) k + go (k-4) cs + go !k [] = error "Compact/pieriRule/encode: shouldn't happen" +-} + +-------------------------------------------------------------------------------- +-- * local (internally used) utility functions + +{-# INLINE i2w #-} +i2w :: Int -> Word +i2w = fromIntegral + +{-# INLINE w2i #-} +w2i :: Word -> Int +w2i = fromIntegral + +{-# INLINE sum' #-} +sum' :: [Word] -> Word +sum' = foldl' (+) 0 + +{-# INLINE safeTail #-} +safeTail :: [Int] -> [Int] +safeTail xs = case xs of { [] -> [] ; _ -> tail xs } + +{-# INLINE descendToZero #-} +descendToZero :: Int -> [Int] +descendToZero !n + | n > 0 = n : descendToZero (n-1) + | n == 0 = [0] + | n < 0 = [] + +{-# INLINE descendToOne #-} +descendToOne :: Int -> [Int] +descendToOne !n + | n > 1 = n : descendToOne (n-1) + | n == 1 = [1] + | n < 1 = [] + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Partitions/Integer/Count.hs b/src/Math/Combinat/Partitions/Integer/Count.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Integer/Count.hs @@ -0,0 +1,215 @@ + +-- | Counting partitions of integers. + +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Partitions.Integer.Count where + +-------------------------------------------------------------------------------- + +import Data.List +import Control.Monad ( liftM , replicateM ) + +-- import Data.Map (Map) +-- import qualified Data.Map as Map + +import Math.Combinat.Numbers ( factorial , binomial , multinomial ) +import Math.Combinat.Numbers.Integers -- Primes +import Math.Combinat.Helper + +import Data.Array +import System.Random + +-------------------------------------------------------------------------------- +-- * Infinite tables of integers + +-- | A data structure which is essentially an infinite list of @Integer@-s, +-- but fast lookup (for reasonable small inputs) +newtype TableOfIntegers = TableOfIntegers [Array Int Integer] + +lookupInteger :: TableOfIntegers -> Int -> Integer +lookupInteger (TableOfIntegers table) !n + | n >= 0 = (table !! k) ! r + | n < 0 = 0 + where + (k,r) = divMod n 1024 + +makeTableOfIntegers + :: ((Int -> Integer) -> (Int -> Integer)) + -> TableOfIntegers +makeTableOfIntegers user = table where + calc = user lkp + lkp = lookupInteger table + table = TableOfIntegers + [ listArray (0,1023) (map calc [a..b]) + | k<-[0..] + , let a = 1024*k + , let b = 1024*(k+1) - 1 + ] + +-------------------------------------------------------------------------------- +-- * Counting partitions + +-- | Number of partitions of @n@ (looking up a table built using Euler's algorithm) +countPartitions :: Int -> Integer +countPartitions = lookupInteger partitionCountTable + +-- | This uses the power series expansion of the infinite product. It is slower than the above. +countPartitionsInfiniteProduct :: Int -> Integer +countPartitionsInfiniteProduct k = partitionCountListInfiniteProduct !! k + +-- | This uses 'countPartitions'', and is (very) slow +countPartitionsNaive :: Int -> Integer +countPartitionsNaive d = countPartitions' (d,d) d + +-------------------------------------------------------------------------------- + +-- | This uses Euler's algorithm to compute p(n) +-- +-- See eg.: +-- NEIL CALKIN, JIMENA DAVIS, KEVIN JAMES, ELIZABETH PEREZ, AND CHARLES SWANNACK +-- COMPUTING THE INTEGER PARTITION FUNCTION +-- +-- +partitionCountTable :: TableOfIntegers +partitionCountTable = table where + + table = makeTableOfIntegers fun + + fun lkp !n + | n > 1 = foldl' (+) 0 + [ (if even k then negate else id) + ( lkp (n - div (k*(3*k+1)) 2) + + lkp (n - div (k*(3*k-1)) 2) + ) + | k <- [1..limit n] + ] + | n < 0 = 0 + | n == 0 = 1 + | n == 1 = 1 + + limit :: Int -> Int + limit !n = fromInteger $ ceilingSquareRoot (1 + div (nn+nn+1) 3) where + nn = fromIntegral n :: Integer + +-- | An infinite list containing all @p(n)@, starting from @p(0)@. +partitionCountList :: [Integer] +partitionCountList = map countPartitions [0..] + +-------------------------------------------------------------------------------- + +-- | Infinite list of number of partitions of @0,1,2,...@ +-- +-- This uses the infinite product formula the generating function of partitions, +-- recursively expanding it; it is reasonably fast for small numbers. +-- +-- > partitionCountListInfiniteProduct == map countPartitions [0..] +-- +partitionCountListInfiniteProduct :: [Integer] +partitionCountListInfiniteProduct = final where + + final = go 1 (1:repeat 0) + + go !k (x:xs) = x : go (k+1) ys where + ys = zipWith (+) xs (take k final ++ ys) + -- explanation: + -- xs == drop k $ f (k-1) + -- ys == drop k $ f (k ) + +{- + +Full explanation of 'partitionCountList': +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +let f k = productPSeries $ map (:[]) [1..k] + +f 0 = [1,0,0,0,0,0,0,0...] +f 1 = [1,1,1,1,1,1,1,1...] +f 2 = [1,1,2,2,3,3,4,4...] +f 3 = [1,1,2,3,4,5,7,8...] + +observe: + +* take (k+1) (f k) == take (k+1) partitionCountList +* f (k+1) == zipWith (+) (f k) (replicate (k+1) 0 ++ f (k+1)) + +now apply (drop (k+1)) to the second one : + +* drop (k+1) (f (k+1)) == zipWith (+) (drop (k+1) $ f k) (f (k+1)) +* f (k+1) = take (k+1) final ++ drop (k+1) (f (k+1)) + +-} + +-------------------------------------------------------------------------------- + +-- | Naive infinite list of number of partitions of @0,1,2,...@ +-- +-- > partitionCountListNaive == map countPartitionsNaive [0..] +-- +-- This is very slow. +-- +partitionCountListNaive :: [Integer] +partitionCountListNaive = map countPartitionsNaive [0..] + +-------------------------------------------------------------------------------- +-- * Counting all partitions + +countAllPartitions :: Int -> Integer +countAllPartitions d = sum' [ countPartitions i | i <- [0..d] ] + +-- | Count all partitions fitting into a rectangle. +-- # = \\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 + +-------------------------------------------------------------------------------- +-- * Counting fitting into a rectangle + +-- | Number of of d, fitting into a given rectangle. Naive recursive algorithm. +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 with given number of parts + +-- | Count partitions of @n@ into @k@ parts. +-- +-- Naive recursive algorithm. +-- +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))] ] + +-------------------------------------------------------------------------------- +-- Partitions with only odd\/distinct parts + +{- +-- | Partitions of @n@ with only odd parts +partitionsWithOddParts :: Int -> [Partition] +partitionsWithOddParts d = map Partition (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] +-} + +{- +-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) +-- +partitionsWithDistinctParts :: Int -> [Partition] +partitionsWithDistinctParts d = map Partition (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] +-} + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Integer/IntList.hs b/src/Math/Combinat/Partitions/Integer/IntList.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Integer/IntList.hs @@ -0,0 +1,398 @@ + +-- | Partition functions working on lists of integers. +-- +-- It's not recommended to use this module directly. + +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Partitions.Integer.IntList where + +-------------------------------------------------------------------------------- + +import Data.List +import Control.Monad ( liftM , replicateM ) + +import Math.Combinat.Numbers ( factorial , binomial , multinomial ) +import Math.Combinat.Helper + +import Data.Array +import System.Random + +import Math.Combinat.Partitions.Integer.Count ( countPartitions ) + +-------------------------------------------------------------------------------- +-- * Type and basic stuff + +-- | Sorts the input, and cuts the nonpositive elements. +_mkPartition :: [Int] -> [Int] +_mkPartition xs = sortBy (reverseCompare) $ filter (>0) xs + +-- | This returns @True@ if the input is non-increasing sequence of +-- /positive/ integers (possibly empty); @False@ otherwise. +-- +_isPartition :: [Int] -> Bool +_isPartition [] = True +_isPartition [x] = x > 0 +_isPartition (x:xs@(y:_)) = (x >= y) && _isPartition xs + + +_dualPartition :: [Int] -> [Int] +_dualPartition [] = [] +_dualPartition xs = go 0 (_diffSequence xs) [] where + go !i (d:ds) acc = go (i+1) ds (d:acc) + go n [] acc = finish n acc + finish !j (k:ks) = replicate k j ++ finish (j-1) ks + finish _ [] = [] + +-------------------------------------------------------------------------------- + +{- +-- more variations: + +_dualPartition_b :: [Int] -> [Int] +_dualPartition_b [] = [] +_dualPartition_b xs = go 1 (diffSequence xs) [] where + go !i (d:ds) acc = go (i+1) ds ((d,i):acc) + go _ [] acc = concatMap (\(d,i) -> replicate d i) acc + +_dualPartition_c :: [Int] -> [Int] +_dualPartition_c [] = [] +_dualPartition_c xs = reverse $ concat $ zipWith f [1..] (diffSequence xs) where + f _ 0 = [] + f k d = replicate d k +-} + +-- | A simpler, but bit slower (about twice?) implementation of dual partition +_dualPartitionNaive :: [Int] -> [Int] +_dualPartitionNaive [] = [] +_dualPartitionNaive xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ] + +-- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences +-- @[a1-a2,a2-a3,...,an-0]@ +_diffSequence :: [Int] -> [Int] +_diffSequence = go where + go (x:ys@(y:_)) = (x-y) : go ys + go [x] = [x] + go [] = [] + +-- | Example: +-- +-- > _elements [5,4,1] == +-- > [ (1,1), (1,2), (1,3), (1,4), (1,5) +-- > , (2,1), (2,2), (2,3), (2,4) +-- > , (3,1) +-- > ] +-- + +_elements :: [Int] -> [(Int,Int)] +_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] + +--------------------------------------------------------------------------------- +-- * Exponential form + +-- | We convert a partition to exponential form. +-- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example: +-- +-- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)] +-- +_toExponentialForm :: [Int] -> [(Int,Int)] +_toExponentialForm = reverse . map (\xs -> (head xs,length xs)) . group + +_fromExponentialForm :: [(Int,Int)] -> [Int] +_fromExponentialForm = sortBy reverseCompare . go where + go ((j,e):rest) = replicate e j ++ go rest + go [] = [] + +--------------------------------------------------------------------------------- +-- * Generating partitions + +-- | Partitions of @d@, as lists +_partitions :: Int -> [[Int]] +_partitions d = go d d where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1..min n h], as <- go a (n-a) ] + +-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@) +_allPartitions :: Int -> [[Int]] +_allPartitions d = concat [ _partitions i | i <- [0..d] ] + +-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@), +-- grouped by weight +_allPartitionsGrouped :: Int -> [[[Int]]] +_allPartitionsGrouped d = [ _partitions i | i <- [0..d] ] + +--------------------------------------------------------------------------------- + +-- | 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) ] + +--------------------------------------------------------------------------------- +-- * Random partitions + +-- | Uniformly random partition of the given weight. +-- +-- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely), +-- and the first time it is executed may be slower (as it needs to build the table 'partitionCountList' first) +-- +-- Algorithm of Nijenhuis and Wilf (1975); see +-- +-- * Knuth Vol 4A, pre-fascicle 3B, exercise 47; +-- +-- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10 +-- +_randomPartition :: RandomGen g => Int -> g -> ([Int], g) +_randomPartition n g = (p, g') where + ([p], g') = _randomPartitions 1 n g + +-- | Generates several uniformly random partitions of @n@ at the same time. +-- Should be a little bit faster then generating them individually. +-- +_randomPartitions + :: forall g. RandomGen g + => Int -- ^ number of partitions to generate + -> Int -- ^ the weight of the partitions + -> g -> ([[Int]], g) +_randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where + + cnt = countPartitions + + finish :: [(Int,Int)] -> [Int] + finish = _mkPartition . concatMap f where f (j,d) = replicate j d + + fi :: Int -> Integer + fi = fromIntegral + + find_jd :: Int -> Integer -> (Int,Int) + find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where + go :: Integer -> [(Int,Int)] -> (Int,Int) + go !s [] = (1,1) -- ?? + go !s [jd] = jd -- ?? + go !s (jd@(j,d):rest) = + if s' > capm + then jd + else go s' rest + where + s' = s + fi d * cnt (m - j*d) + + worker :: Int -> [(Int,Int)] -> Rand g [Int] + worker 0 acc = return $ finish acc + worker !m acc = do + capm <- randChoose (0, (fi m) * cnt m - 1) + let jd@(!j,!d) = find_jd m capm + worker (m - j*d) (jd:acc) + + +--------------------------------------------------------------------------------- +-- * 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 :: [Int] -> [Int] -> Bool +_dominates qs ps + = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) + where + sums = scanl (+) 0 + +-- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@ +-- (that is, all partial sums are less or equal): +-- +-- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ] +-- +_dominatedPartitions :: [Int] -> [[Int]] +_dominatedPartitions [] = [[]] +_dominatedPartitions lambda = go (head lambda) w dsums 0 where + + n = length lambda + w = sum lambda + dsums = scanl1 (+) (lambda ++ repeat 0) + + go _ 0 _ _ = [[]] + go !h !w (!d:ds) !e + | w > 0 = [ (a:as) | a <- [1..min h (d-e)] , as <- go a (w-a) ds (e+a) ] + | w == 0 = [[]] + | w < 0 = error "_dominatedPartitions: fatal error; shouldn't happen" + +-- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@ +-- (that is, all partial sums are greater or equal): +-- +-- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ] +-- +_dominatingPartitions :: [Int] -> [[Int]] +_dominatingPartitions [] = [[]] +_dominatingPartitions mu = go w w dsums 0 where + + n = length mu + w = sum mu + dsums = scanl1 (+) (mu ++ repeat 0) + + go _ 0 _ _ = [[]] + go !h !w (!d:ds) !e + | w > 0 = [ (a:as) | a <- [max 0 (d-e)..min h w] , as <- go a (w-a) ds (e+a) ] + | w == 0 = [[]] + | w < 0 = error "_dominatingPartitions: fatal error; shouldn't happen" + +-------------------------------------------------------------------------------- +-- * 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 + -> [[Int]] +_partitionsWithKParts k n = 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) ] + +-------------------------------------------------------------------------------- +-- * Partitions with only odd\/distinct parts + +-- | Partitions of @n@ with only odd parts +_partitionsWithOddParts :: Int -> [[Int]] +_partitionsWithOddParts d = (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ] + +{- +-- | Partitions of @n@ with only even parts +-- +-- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@ +-- +_partitionsWithEvenParts :: Int -> [[Int]] +_partitionsWithEvenParts d = (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ] +-} + +-- | Partitions of @n@ with distinct parts. +-- +-- Note: +-- +-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d) +-- +_partitionsWithDistinctParts :: Int -> [[Int]] +_partitionsWithDistinctParts d = (go d d) where + go _ 0 = [[]] + go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ] + +-------------------------------------------------------------------------------- +-- * Sub- and super-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 :: [Int] -> [Int] -> Bool +_isSubPartitionOf ps qs = and $ zipWith (<=) ps (qs ++ repeat 0) + +-- | This is provided for convenience\/completeness only, as: +-- +-- > isSuperPartitionOf q p == isSubPartitionOf p q +-- +_isSuperPartitionOf :: [Int] -> [Int] -> Bool +_isSuperPartitionOf qs ps = 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 -> [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 :: [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 ] + +---------------------------------------- + +-- | Super-partitions of a given partition with the given weight: +-- +-- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ] +-- +_superPartitions :: Int -> [Int] -> [[Int]] +_superPartitions dd small + | dd < w0 = [] + | null small = _partitions dd + | otherwise = go dd w1 dd (small ++ repeat 0) + where + w0 = sum' small + w1 = w0 - head small + -- d = remaining weight of the outer partition we are constructing + -- w = remaining weight of the inner partition (we need to reserve at least this amount) + -- h = max height (decreasing) + go !d !w !h (!a:as@(b:_)) + | d < 0 = [] + | d == 0 = if a == 0 then [[]] else [] + | otherwise = [ this:rest | this <- [max 1 a .. min h (d-w)] , rest <- go (d-this) (w-b) this as ] + +-------------------------------------------------------------------------------- +-- * The Pieri rule + +-- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1). +-- +-- See for example +-- +-- | We assume here that @lambda@ is a partition (non-increasing sequence of /positive/ integers)! +_pieriRule :: [Int] -> Int -> [[Int]] +_pieriRule lambda n + | n == 0 = [lambda] + | n < 0 = [] + | otherwise = go n diffs dsums (lambda++[0]) + where + diffs = n : _diffSequence lambda -- maximum we can add to a given row + dsums = reverse $ scanl1 (+) (reverse diffs) -- partial sums of remaining total we can add + go !k (d:ds) (p:ps@(q:_)) (l:ls) + | k > p = [] + | otherwise = [ h:tl | a <- [ max 0 (k-q) .. min d k ] , let h = l+a , tl <- go (k-a) ds ps ls ] + go !k [d] _ [l] = if k <= d + then if l+k>0 then [[l+k]] else [[]] + else [] + go !k [] _ _ = if k==0 then [[]] else [] + +-- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1) +_dualPieriRule :: [Int] -> Int -> [[Int]] +_dualPieriRule lam n = map _dualPartition $ _pieriRule (_dualPartition lam) n + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Integer/Naive.hs b/src/Math/Combinat/Partitions/Integer/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Integer/Naive.hs @@ -0,0 +1,214 @@ + +-- | Naive implementation of partitions of integers, encoded as list of @Int@-s. +-- +-- Integer partitions are nonincreasing sequences of positive integers. +-- +-- This is an internal module, you are not supposed to import it directly. +-- + + +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, PatternSynonyms, ViewPatterns #-} +module Math.Combinat.Partitions.Integer.Naive where + +-------------------------------------------------------------------------------- + +import Data.List +import Control.Monad ( liftM , replicateM ) + +-- import Data.Map (Map) +-- import qualified Data.Map as Map + +import Math.Combinat.Classes +import Math.Combinat.ASCII as ASCII +import Math.Combinat.Numbers (factorial,binomial,multinomial) +import Math.Combinat.Helper + +import Data.Array +import System.Random + +import Math.Combinat.Partitions.Integer.IntList +import Math.Combinat.Partitions.Integer.Count ( countPartitions ) + +-------------------------------------------------------------------------------- +-- * 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) + +instance HasNumberOfParts Partition where + numberOfParts (Partition p) = length p + +--------------------------------------------------------------------------------- + +toList :: Partition -> [Int] +toList (Partition xs) = xs + +fromList :: [Int] -> Partition +fromList = mkPartition where + mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs + +fromListUnsafe :: [Int] -> Partition +fromListUnsafe = Partition + +--------------------------------------------------------------------------------- + +isEmptyPartition :: Partition -> Bool +isEmptyPartition (Partition p) = null p + +emptyPartition :: Partition +emptyPartition = Partition [] + +instance CanBeEmpty Partition where + empty = emptyPartition + isEmpty = isEmptyPartition + +-- | The first element of the sequence. +partitionHeight :: Partition -> Int +partitionHeight (Partition part) = case part of + (p:_) -> p + [] -> 0 + +-- | The length of the sequence (that is, the number of parts). +partitionWidth :: Partition -> Int +partitionWidth (Partition part) = length part + +instance HasHeight Partition where + height = partitionHeight + +instance HasWidth Partition where + width = partitionWidth + +heightWidth :: Partition -> (Int,Int) +heightWidth part = (height part, width part) + +-- | The weight of the partition +-- (that is, the sum of the corresponding sequence). +partitionWeight :: Partition -> Int +partitionWeight (Partition part) = sum' part + +instance HasWeight Partition where + weight = partitionWeight + +-- | The dual (or conjugate) partition. +dualPartition :: Partition -> Partition +dualPartition (Partition part) = Partition (_dualPartition part) + +instance HasDuality Partition where + dual = dualPartition + +-- | 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 + +-------------------------------------------------------------------------------- +-- * Pattern synonyms + +-- | Pattern sysnonyms allows us to use existing code with minimal modifications +pattern Nil :: Partition +pattern Nil <- (isEmpty -> True) where + Nil = empty + +pattern Cons :: Int -> Partition -> Partition +pattern Cons x xs <- (unconsPartition -> Just (x,xs)) where + Cons x (Partition xs) = Partition (x:xs) + +-- | Simulated newtype constructor +pattern Partition_ :: [Int] -> Partition +pattern Partition_ xs = Partition xs + +pattern Head :: Int -> Partition +pattern Head h <- (head . toDescList -> h) + +pattern Tail :: Partition -> Partition +pattern Tail xs <- (Partition . tail . toDescList -> xs) + +pattern Length :: Int -> Partition +pattern Length n <- (partitionWidth -> n) + +--------------------------------------------------------------------------------- +-- * Exponential form + +-- | We convert a partition to exponential form. +-- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example: +-- +-- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)] +-- +toExponentialForm :: Partition -> [(Int,Int)] +toExponentialForm = _toExponentialForm . toDescList + +fromExponentialForm :: [(Int,Int)] -> Partition +fromExponentialForm = Partition . _fromExponentialForm where + +-------------------------------------------------------------------------------- +-- * List-like operations + +-- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences +-- @[a1-a2,a2-a3,...,an-0]@ +diffSequence :: Partition -> [Int] +diffSequence = go . toDescList where + go (x:ys@(y:_)) = (x-y) : go ys + go [x] = [x] + go [] = [] + +unconsPartition :: Partition -> Maybe (Int,Partition) +unconsPartition (Partition xs) = case xs of + (y:ys) -> Just (y, Partition ys) + [] -> Nothing + +toDescList :: Partition -> [Int] +toDescList (Partition xs) = xs + +--------------------------------------------------------------------------------- +-- * 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 + +-------------------------------------------------------------------------------- +-- * Containment partial ordering + +-- | 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) + +-- | This is provided for convenience\/completeness only, as: +-- +-- > isSuperPartitionOf q p == isSubPartitionOf p q +-- +isSuperPartitionOf :: Partition -> Partition -> Bool +isSuperPartitionOf (Partition qs) (Partition ps) = and $ zipWith (<=) ps (qs ++ repeat 0) + +-------------------------------------------------------------------------------- +-- * The Pieri rule + +-- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1). +-- +-- See for example +-- +pieriRule :: Partition -> Int -> [Partition] +pieriRule (Partition lambda) n = map Partition (_pieriRule lambda n) where + +-- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1) +dualPieriRule :: Partition -> Int -> [Partition] +dualPieriRule lam n = map dualPartition $ pieriRule (dualPartition lam) n + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Partitions/Multiset.hs b/src/Math/Combinat/Partitions/Multiset.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/Partitions/NonCrossing.hs b/src/Math/Combinat/Partitions/NonCrossing.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/NonCrossing.hs @@ -0,0 +1,205 @@ + +-- | Non-crossing partitions. +-- +-- 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 + +-------------------------------------------------------------------------------- + +import Control.Applicative + +import Data.List +import Data.Ord + +import System.Random + +import Math.Combinat.Numbers +import Math.Combinat.LatticePaths +import Math.Combinat.Helper +import Math.Combinat.Partitions.Set +import Math.Combinat.Classes + +-------------------------------------------------------------------------------- +-- * The type of non-crossing partitions + +-- | A non-crossing partition of the set @[1..n]@ in standard form: +-- entries decreasing in each block and blocks listed in increasing order of their first entries. +newtype NonCrossing = NonCrossing [[Int]] deriving (Eq,Ord,Show,Read) + +-- | Checks whether a set partition is noncrossing. +-- +-- Implementation method: we convert to a Dyck path and then back again, and finally compare. +-- Probably not very efficient, but should be better than a naive check for crosses...) +-- +_isNonCrossing :: [[Int]] -> Bool +_isNonCrossing zzs0 = _isNonCrossingUnsafe (_standardizeNonCrossing zzs0) + +-- | Warning: This function assumes the standard ordering! +_isNonCrossingUnsafe :: [[Int]] -> Bool +_isNonCrossingUnsafe zzs = + case _nonCrossingPartitionToDyckPathMaybe zzs of + Nothing -> False + Just dyck -> case dyckPathToNonCrossingPartitionMaybe dyck of + Nothing -> False + Just (NonCrossing yys) -> yys == zzs + +-- | Convert to standard form: entries decreasing in each block +-- and blocks listed in increasing order of their first entries. +_standardizeNonCrossing :: [[Int]] -> [[Int]] +_standardizeNonCrossing = sortBy (comparing myhead) . map reverseSort where + myhead xs = case xs of + (x:xs) -> x + [] -> error "_standardizeNonCrossing: empty subset" + +fromNonCrossing :: NonCrossing -> [[Int]] +fromNonCrossing (NonCrossing xs) = xs + +toNonCrossingUnsafe :: [[Int]] -> NonCrossing +toNonCrossingUnsafe = NonCrossing + +-- | Throws an error if the input is not a non-crossing partition +toNonCrossing :: [[Int]] -> NonCrossing +toNonCrossing xxs = case toNonCrossingMaybe xxs of + Just nc -> nc + Nothing -> error "toNonCrossing: not a non-crossing partition" + +toNonCrossingMaybe :: [[Int]] -> Maybe NonCrossing +toNonCrossingMaybe xxs0 = + if _isNonCrossingUnsafe xxs + then Just $ NonCrossing xxs + else Nothing + where + xxs = _standardizeNonCrossing xxs0 + +-- | If a set partition is actually non-crossing, then we can convert it +setPartitionToNonCrossing :: SetPartition -> Maybe NonCrossing +setPartitionToNonCrossing (SetPartition zzs0) = + if _isNonCrossingUnsafe zzs + then Just $ NonCrossing zzs + else Nothing + where + zzs = _standardizeNonCrossing zzs0 + +instance HasNumberOfParts NonCrossing where + numberOfParts (NonCrossing p) = length p + +-------------------------------------------------------------------------------- +-- * Bijection to Dyck paths + +-- | Bijection between Dyck paths and noncrossing partitions +-- +-- Based on: David Callan: /Sets, Lists and Noncrossing Partitions/ +-- +-- Fails if the input is not a Dyck path. +dyckPathToNonCrossingPartition :: LatticePath -> NonCrossing +dyckPathToNonCrossingPartition = NonCrossing . go 0 [] [] [] where + go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]] + go !cnt stack small big path = + case path of + (x:xs) -> case x of + UpStep -> let cnt' = cnt + 1 in case xs of + (y:ys) -> case y of + UpStep -> go cnt' (cnt':stack) small big xs + DownStep -> go cnt' (cnt':stack) [] (reverse small : big) xs + [] -> error "dyckPathToNonCrossingPartition: last step is an UpStep (thus input was not a Dyck path)" + DownStep -> case stack of + (k:ks) -> go cnt ks (k:small) big xs + [] -> error "dyckPathToNonCrossingPartition: empty stack, shouldn't happen (thus input was not a Dyck path)" + [] -> tail $ reverse (reverse small : big) + +-- | Safe version of 'dyckPathToNonCrossingPartition' +dyckPathToNonCrossingPartitionMaybe :: LatticePath -> Maybe NonCrossing +dyckPathToNonCrossingPartitionMaybe = fmap NonCrossing . go 0 [] [] [] where + go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]] + go !cnt stack small big path = + case path of + (x:xs) -> case x of + UpStep -> let cnt' = cnt + 1 in case xs of + (y:ys) -> case y of + UpStep -> go cnt' (cnt':stack) small big xs + DownStep -> go cnt' (cnt':stack) [] (reverse small : big) xs + [] -> Nothing + DownStep -> case stack of + (k:ks) -> go cnt ks (k:small) big xs + [] -> Nothing + [] -> Just $ tail $ reverse (reverse small : big) + +-- | The inverse bijection (should never fail proper 'NonCrossing'-s) +nonCrossingPartitionToDyckPath :: NonCrossing -> LatticePath +nonCrossingPartitionToDyckPath (NonCrossing zzs) = go 0 zzs where + go !k (ys@(y:_):yys) = replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ go y yys + go !k [] = [] + go _ _ = error "nonCrossingPartitionToDyckPath: shouldnt't happen" + +-- | Safe version 'nonCrossingPartitionToDyckPath' +_nonCrossingPartitionToDyckPathMaybe :: [[Int]] -> Maybe LatticePath +_nonCrossingPartitionToDyckPathMaybe = go 0 where + go !k (ys@(y:_):yys) = fmap (\zs -> replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ zs) (go y yys) + go !k [] = Just [] + go _ _ = Nothing + +-------------------------------------------------------------------------------- + +{- +-- this should be mapped to NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] +testpath = [u,u,u,d,u,u,d,d,d,u,u,d,d,d,u,u,d,d] where + u = UpStep + d = DownStep + +testnc = NonCrossing [[3],[5,4,2],[7,6,1],[9,8]] +-} + +-------------------------------------------------------------------------------- +-- * Generating non-crossing partitions + +-- | Lists all non-crossing partitions of @[1..n]@ +-- +-- Equivalent to (but orders of magnitude faster than) filtering out the non-crossing ones: +-- +-- > (sort $ catMaybes $ map setPartitionToNonCrossing $ setPartitions n) == sort (nonCrossingPartitions n) +-- +nonCrossingPartitions :: Int -> [NonCrossing] +nonCrossingPartitions = map dyckPathToNonCrossingPartition . dyckPaths + +-- | Lists all non-crossing partitions of @[1..n]@ into @k@ parts. +-- +-- > sort (nonCrossingPartitionsWithKParts k n) == sort [ p | p <- nonCrossingPartitions n , numberOfParts p == k ] +-- +nonCrossingPartitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = size of the set + -> [NonCrossing] +nonCrossingPartitionsWithKParts k n = map dyckPathToNonCrossingPartition $ peakingDyckPaths k n + +-- | Non-crossing partitions are counted by the Catalan numbers +countNonCrossingPartitions :: Int -> Integer +countNonCrossingPartitions = countDyckPaths + +-- | Non-crossing partitions with @k@ parts are counted by the Naranaya numbers +countNonCrossingPartitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = size of the set + -> Integer +countNonCrossingPartitionsWithKParts = countPeakingDyckPaths + +-------------------------------------------------------------------------------- + +-- | Uniformly random non-crossing partition +randomNonCrossingPartition :: RandomGen g => Int -> g -> (NonCrossing,g) +randomNonCrossingPartition n g0 = (dyckPathToNonCrossingPartition dyck, g1) where + (dyck,g1) = randomDyckPath n g0 + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Plane.hs b/src/Math/Combinat/Partitions/Plane.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Plane.hs @@ -0,0 +1,124 @@ + +-- | 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.Classes +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) + +instance CanBeEmpty PlanePart where + isEmpty = null . fromPlanePart + empty = PlanePart [] + +-- | 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.tableauShape . 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) + +instance HasWeight PlanePart where + weight = planePartWeight + +-------------------------------------------------------------------------------- +-- * 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/src/Math/Combinat/Partitions/Set.hs b/src/Math/Combinat/Partitions/Set.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Set.hs @@ -0,0 +1,109 @@ + +-- | Set partitions. +-- +-- See eg. +-- + +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Partitions.Set where + +-------------------------------------------------------------------------------- + +import Data.List +import Data.Ord + +import System.Random + +import Math.Combinat.Sets +import Math.Combinat.Numbers +import Math.Combinat.Helper +import Math.Combinat.Classes +import Math.Combinat.Partitions.Integer + +-------------------------------------------------------------------------------- +-- * The type of set partitions + +-- | A partition of the set @[1..n]@ (in standard order) +newtype SetPartition = SetPartition [[Int]] deriving (Eq,Ord,Show,Read) + +_standardizeSetPartition :: [[Int]] -> [[Int]] +_standardizeSetPartition = sortBy (comparing myhead) . map sort where + myhead xs = case xs of + (x:xs) -> x + [] -> error "_standardizeSetPartition: empty subset" + +fromSetPartition :: SetPartition -> [[Int]] +fromSetPartition (SetPartition zzs) = zzs + +toSetPartitionUnsafe :: [[Int]] -> SetPartition +toSetPartitionUnsafe = SetPartition + +toSetPartition :: [[Int]] -> SetPartition +toSetPartition zzs = if _isSetPartition zzs + then SetPartition (_standardizeSetPartition zzs) + else error "toSetPartition: not a set partition" + +_isSetPartition :: [[Int]] -> Bool +_isSetPartition zzs = sort (concat zzs) == [1..n] where + n = sum' (map length zzs) + +instance HasNumberOfParts SetPartition where + numberOfParts (SetPartition p) = length p + +-------------------------------------------------------------------------------- +-- * Forgetting the set structure + +-- | The \"shape\" of a set partition is the partition we get when we forget the +-- set structure, keeping only the cardinalities. +-- +setPartitionShape :: SetPartition -> Partition +setPartitionShape (SetPartition pps) = mkPartition (map length pps) + +-------------------------------------------------------------------------------- +-- * Generating set partitions + +-- | Synonym for 'setPartitionsNaive' +setPartitions :: Int -> [SetPartition] +setPartitions = setPartitionsNaive + +-- | Synonym for 'setPartitionsWithKPartsNaive' +-- +-- > sort (setPartitionsWithKParts k n) == sort [ p | p <- setPartitions n , numberOfParts p == k ] +-- +setPartitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = size of the set + -> [SetPartition] +setPartitionsWithKParts = setPartitionsWithKPartsNaive + +-- | List all set partitions of @[1..n]@, naive algorithm +setPartitionsNaive :: Int -> [SetPartition] +setPartitionsNaive n = map (SetPartition . _standardizeSetPartition) $ go [1..n] where + go :: [Int] -> [[[Int]]] + go [] = [[]] + go (z:zs) = [ s : rest | k <- [1..n] , s0 <- choose (k-1) zs , let s = z:s0 , rest <- go (zs \\ s) ] + +-- | Set partitions of the set @[1..n]@ into @k@ parts +setPartitionsWithKPartsNaive + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = size of the set + -> [SetPartition] +setPartitionsWithKPartsNaive k n = map (SetPartition . _standardizeSetPartition) $ go k [1..n] where + go :: Int -> [Int] -> [[[Int]]] + go !k [] = if k==0 then [[]] else [] + go 1 zs = [[zs]] + go !k (z:zs) = [ s : rest | l <- [1..n] , s0 <- choose (l-1) zs , let s = z:s0 , rest <- go (k-1) (zs \\ s) ] + + +-- | Set partitions are counted by the Bell numbers +countSetPartitions :: Int -> Integer +countSetPartitions = bellNumber + +-- | Set partitions of size @k@ are counted by the Stirling numbers of second kind +countSetPartitionsWithKParts + :: Int -- ^ @k@ = number of parts + -> Int -- ^ @n@ = size of the set + -> Integer +countSetPartitionsWithKParts k n = stirling2nd n k + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Skew.hs b/src/Math/Combinat/Partitions/Skew.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Skew.hs @@ -0,0 +1,153 @@ + +-- | Skew partitions. +-- +-- Skew partitions are the difference of two integer partitions, denoted by @lambda/mu@. +-- +-- For example +-- +-- > mkSkewPartition (Partition [9,7,3,2,2,1] , Partition [5,3,2,1]) +-- +-- creates the skew partition @(9,7,3,2,2,1) / (5,3,2,1)@, which looks like +-- +-- <> +-- + +{-# LANGUAGE CPP, BangPatterns #-} +module Math.Combinat.Partitions.Skew where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Classes +import Math.Combinat.Partitions.Integer +import Math.Combinat.ASCII + +-------------------------------------------------------------------------------- +-- * Basics + +-- | A skew partition @lambda/mu@ is internally represented by the list @[ (mu_i , lambda_i-mu_i) | i<-[1..n] ]@ +newtype SkewPartition = SkewPartition [(Int,Int)] deriving (Eq,Ord,Show) + +-- | @mkSkewPartition (lambda,mu)@ creates the skew partition @lambda/mu@. +-- Throws an error if @mu@ is not a sub-partition of @lambda@. +mkSkewPartition :: (Partition,Partition) -> SkewPartition +mkSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam + then SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0) + else error "mkSkewPartition: mu should be a subpartition of lambda!" + +-- | Returns 'Nothing' if @mu@ is not a sub-partition of @lambda@. +safeSkewPartition :: (Partition,Partition) -> Maybe SkewPartition +safeSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam + then Just $ SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0) + else Nothing + +-- | The weight of a skew partition is the weight of the outer partition minus the +-- the weight of the inner partition (that is, the number of boxes present). +skewPartitionWeight :: SkewPartition -> Int +skewPartitionWeight (SkewPartition abs) = foldl' (+) 0 (map snd abs) + +instance HasWeight SkewPartition where + weight = skewPartitionWeight + +-- | This function \"cuts off\" the \"uninteresting parts\" of a skew partition +normalizeSkewPartition :: SkewPartition -> SkewPartition +normalizeSkewPartition (SkewPartition abs) = SkewPartition abs' where + (as,bs) = unzip abs + a0 = minimum as + k = length (takeWhile (==0) bs) + abs' = zip [ a-a0 | a <- drop k as ] (drop k bs) + +-- | Returns the outer and inner partition of a skew partition, respectively: +-- +-- > mkSkewPartition . fromSkewPartition == id +-- +fromSkewPartition :: SkewPartition -> (Partition,Partition) +fromSkewPartition (SkewPartition list) = (toPartition (zipWith (+) as bs) , toPartition (filter (>0) as)) where + (as,bs) = unzip list + +-- | The @lambda@ part of @lambda/mu@ +outerPartition :: SkewPartition -> Partition +outerPartition = fst . fromSkewPartition + +-- | The @mu@ part of @lambda/mu@ +innerPartition :: SkewPartition -> Partition +innerPartition = snd . fromSkewPartition + +-- | The dual skew partition (that is, the mirror image to the main diagonal) +dualSkewPartition :: SkewPartition -> SkewPartition +dualSkewPartition = mkSkewPartition . f . fromSkewPartition where + f (lam,mu) = (dualPartition lam, dualPartition mu) + +instance HasDuality SkewPartition where + dual = dualSkewPartition + +-- | See "partitionElements" +skewPartitionElements :: SkewPartition -> [(Int, Int)] +skewPartitionElements (SkewPartition abs) = concat + [ [ (i,j) | j <- [a+1 .. a+b] ] + | (i,(a,b)) <- zip [1..] abs + ] + +-------------------------------------------------------------------------------- +-- * Listing skew partitions + +-- | Lists all skew partitions with the given outer shape and given (skew) weight +skewPartitionsWithOuterShape :: Partition -> Int -> [SkewPartition] +skewPartitionsWithOuterShape outer skewWeight + | innerWeight < 0 || innerWeight > outerWeight = [] + | otherwise = [ mkSkewPartition (outer,inner) | inner <- subPartitions innerWeight outer ] + where + outerWeight = weight outer + innerWeight = outerWeight - skewWeight + +-- | Lists all skew partitions with the given outer shape and any (skew) weight +allSkewPartitionsWithOuterShape :: Partition -> [SkewPartition] +allSkewPartitionsWithOuterShape outer + = concat [ skewPartitionsWithOuterShape outer w | w<-[0..outerWeight] ] + where + outerWeight = weight outer + +-- | Lists all skew partitions with the given inner shape and given (skew) weight +skewPartitionsWithInnerShape :: Partition -> Int -> [SkewPartition] +skewPartitionsWithInnerShape inner skewWeight + | innerWeight > outerWeight = [] + | otherwise = [ mkSkewPartition (outer,inner) | outer <- superPartitions outerWeight inner ] + where + outerWeight = innerWeight + skewWeight + innerWeight = weight inner + +-------------------------------------------------------------------------------- +-- connected components + +{- +connectedComponents :: SkewPartition -> [((Int,Int),SkewPartition)] +connectedComponents = error "connectedComponents: not implemented yet" + +isConnectedSkewPartition :: SkewPartition -> Bool +isConnectedSkewPartition skewp = length (connectedComponents skewp) == 1 +-} + +-------------------------------------------------------------------------------- +-- * ASCII + +asciiSkewFerrersDiagram :: SkewPartition -> ASCII +asciiSkewFerrersDiagram = asciiSkewFerrersDiagram' ('@','.') EnglishNotation + +asciiSkewFerrersDiagram' + :: (Char,Char) + -> PartitionConvention -- Orientation + -> SkewPartition + -> ASCII +asciiSkewFerrersDiagram' (outer,inner) orient (SkewPartition abs) = asciiFromLines stuff where + stuff = case orient of + EnglishNotation -> ls + EnglishNotationCCW -> reverse (transpose ls) + FrenchNotation -> reverse ls + ls = [ replicate a inner ++ replicate b outer | (a,b) <- abs ] + +instance DrawASCII SkewPartition where + ascii = asciiSkewFerrersDiagram + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Partitions/Skew/Ribbon.hs b/src/Math/Combinat/Partitions/Skew/Ribbon.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Partitions/Skew/Ribbon.hs @@ -0,0 +1,364 @@ + +-- | Ribbons (also called border strips, skew hooks, skew rim hooks, etc...). +-- +-- Ribbons are skew partitions that are 1) connected, 2) do not contain +-- 2x2 blocks. Intuitively, they are 1-box wide continuous strips on +-- the boundary. +-- +-- An alternative definition that they are skew partitions whose projection +-- to the diagonal line is a continuous segment of width 1. + +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Partitions.Skew.Ribbon where + +-------------------------------------------------------------------------------- + +import Data.Array +import Data.List +import Data.Maybe + +import qualified Data.Map as Map + +import Math.Combinat.Sets +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Integer.IntList ( _diffSequence ) +import Math.Combinat.Partitions.Skew +import Math.Combinat.Tableaux +import Math.Combinat.Tableaux.LittlewoodRichardson +import Math.Combinat.Tableaux.GelfandTsetlin +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- +-- * Corners (TODO: move to Partitions - but we also want to refactor that) + +-- | The coordinates of the outer corners +outerCorners :: Partition -> [(Int,Int)] +outerCorners = outerCornerBoxes + +-- | The coordinates of the inner corners, including the two on the two coordinate +-- axes. For the partition @[5,4,1]@ the result should be @[(0,5),(1,4),(2,1),(3,0)]@ +extendedInnerCorners:: Partition -> [(Int,Int)] +extendedInnerCorners (Partition_ ps) = (0, head ps') : catMaybes mbCorners where + ps' = ps ++ [0] + mbCorners = zipWith3 f [1..] (tail ps') (_diffSequence ps') + f !y !x !k = if k > 0 then Just (y,x) else Nothing + +-- | Sequence of all the (extended) corners +extendedCornerSequence :: Partition -> [(Int,Int)] +extendedCornerSequence (Partition_ ps) = {- if null ps then [(0,0)] else -} interleave inner outer where + inner = (0, head ps') : [ (y,x) | (y,x,k) <- zip3 [1..] (tail ps') diff , k>0 ] + outer = [ (y,x) | (y,x,k) <- zip3 [1..] ps' diff , k>0 ] + diff = _diffSequence ps' + ps' = ps ++ [0] + +-- | The inner corner /boxes/ of the partition. Coordinates are counted from 1 +-- (cf.the 'elements' function), and the first coordinate is the row, the second +-- the column (in English notation). +-- +-- For the partition @[5,4,1]@ the result should be @[(1,4),(2,1)]@ +-- +-- > innerCornerBoxes lambda == (tail $ init $ extendedInnerCorners lambda) +-- +innerCornerBoxes :: Partition -> [(Int,Int)] +innerCornerBoxes (Partition_ ps) = + case ps of + [] -> [] + _ -> catMaybes mbCorners + where + mbCorners = zipWith3 f [1..] (tail ps) (_diffSequence ps) + f !y !x !k = if k > 0 then Just (y,x) else Nothing + +-- | The outer corner /boxes/ of the partition. Coordinates are counted from 1 +-- (cf.the 'elements' function), and the first coordinate is the row, the second +-- the column (in English notation). +-- +-- For the partition @[5,4,1]@ the result should be @[(1,5),(2,4),(3,1)]@ +outerCornerBoxes :: Partition -> [(Int,Int)] +outerCornerBoxes (Partition_ ps) = catMaybes mbCorners where + mbCorners = zipWith3 f [1..] ps (_diffSequence ps) + f !y !x !k = if k > 0 then Just (y,x) else Nothing + +-- | The outer and inner corner boxes interleaved, so together they form +-- the turning points of the full border strip +cornerBoxSequence :: Partition -> [(Int,Int)] +cornerBoxSequence (Partition_ ps) = if null ps then [] else interleave outer inner where + inner = [ (y,x) | (y,x,k) <- zip3 [1..] tailps diff , k>0 ] + outer = [ (y,x) | (y,x,k) <- zip3 [1..] ps diff , k>0 ] + diff = _diffSequence ps + tailps = case ps of { [] -> [] ; _-> tail ps } + +-------------------------------------------------------------------------------- + +-- | Naive (and very slow) implementation of @innerCornerBoxes@, for testing purposes +innerCornerBoxesNaive :: Partition -> [(Int,Int)] +innerCornerBoxesNaive part = filter f boxes where + boxes = elements part + f (y,x) = elem (y+1,x ) boxes + && elem (y ,x+1) boxes + && not (elem (y+1,x+1) boxes) + +-- | Naive (and very slow) implementation of @outerCornerBoxes@, for testing purposes +outerCornerBoxesNaive :: Partition -> [(Int,Int)] +outerCornerBoxesNaive part = filter f boxes where + boxes = elements part + f (y,x) = not (elem (y+1,x ) boxes) + && not (elem (y ,x+1) boxes) + && not (elem (y+1,x+1) boxes) + +-------------------------------------------------------------------------------- +-- * Ribbon + +-- | A skew partition is a a ribbon (or border strip) if and only if projected +-- to the diagonals the result is an interval. +isRibbon :: SkewPartition -> Bool +isRibbon skewp = go Nothing proj where + proj = Map.toList + $ Map.fromListWith (+) [ (x-y , 1) | (y,x) <- skewPartitionElements skewp ] + go Nothing [] = False + go (Just _) [] = True + go Nothing ((a,h):rest) = (h == 1) && go (Just a) rest + go (Just b) ((a,h):rest) = (h == 1) && (a == b+1) && go (Just a) rest + +{- +-- | Naive (and slow) reference implementation of "isRibbon" +isRibbonNaive :: SkewPartition -> Bool +isRibbonNaive skewp = isConnectedSkewPartition skewp && no2x2 where + boxes = skewPartitionElements skewp + no2x2 = and + [ not ( elem (y+1,x ) boxes && + elem (y ,x+1) boxes && + elem (y+1,x+1) boxes ) -- no 2x2 blocks + | (y,x) <- boxes + ] +-} + +toRibbon :: SkewPartition -> Maybe Ribbon +toRibbon skew = + if not (isRibbon skew) + then Nothing + else Just ribbon + where + ribbon = Ribbon + { rbShape = skew + , rbLength = skewPartitionWeight skew + , rbHeight = height + , rbWidth = width + } + elems = skewPartitionElements skew + height = (length $ group $ sort $ map fst elems) - 1 -- TODO: optimize these + width = (length $ group $ sort $ map snd elems) - 1 + +-- | Border strips (or ribbons) are defined to be skew partitions which are +-- connected and do not contain 2x2 blocks. +-- +-- The /length/ of a border strip is the number of boxes it contains, +-- and its /height/ is defined to be one less than the number of rows +-- (in English notation) it occupies. The /width/ is defined symmetrically to +-- be one less than the number of columns it occupies. +-- +data Ribbon = Ribbon + { rbShape :: SkewPartition + , rbLength :: Int + , rbHeight :: Int + , rbWidth :: Int + } + deriving (Eq,Ord,Show) + +-------------------------------------------------------------------------------- +-- * Inner border strips + +-- | Ribbons (or border strips) are defined to be skew partitions which are +-- connected and do not contain 2x2 blocks. This function returns the +-- border strips whose outer partition is the given one. +innerRibbons :: Partition -> [Ribbon] +innerRibbons part@(Partition ps) = if null ps then [] else strips where + + strips = [ mkStrip i j + | i<-[1..n] , _canStartStrip (annArr!i) + , j<-[i..n] , _canEndStrip (annArr!j) + ] + + n = length annList + annList = annotatedInnerBorderStrip part + annArr = listArray (1,n) annList + + mkStrip !i1 !i2 = Ribbon shape len height width where + ps' = ps ++ [0] + shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] + indent !i !p !q + | i < y1 = 0 + | i > y2 = 0 + | i == y2 = p - x2 + 1 -- the order is important here !!! + | otherwise = p - q + 1 -- because of the case y1 == y2 == i + + len = i2 - i1 + 1 + height = y2 - y1 + width = x1 - x2 + BorderBox _ _ y1 x1 = annArr ! i1 + BorderBox _ _ y2 x2 = annArr ! i2 + +-- | Inner border strips (or ribbons) of the given length +innerRibbonsOfLength :: Partition -> Int -> [Ribbon] +innerRibbonsOfLength part@(Partition ps) givenLength = if null ps then [] else strips where + + strips = [ mkStrip i j + | i<-[1..n] , _canStartStrip (annArr!i) + , j<-[i..n] , _canEndStrip (annArr!j) + , j-i+1 == givenLength + ] + + n = length annList + annList = annotatedInnerBorderStrip part + annArr = listArray (1,n) annList + + mkStrip !i1 !i2 = Ribbon shape givenLength height width where + ps' = ps ++ [0] + shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] + indent !i !p !q + | i < y1 = 0 + | i > y2 = 0 + | i == y2 = p - x2 + 1 -- the order is important here !!! + | otherwise = p - q + 1 -- because of the case y1 == y2 == i + + height = y2 - y1 + width = x1 - x2 + BorderBox _ _ y1 x1 = annArr ! i1 + BorderBox _ _ y2 x2 = annArr ! i2 + + +-------------------------------------------------------------------------------- +-- * Outer border strips + +-- | Hooks of length @n@ (TODO: move to the partition module) +listHooks :: Int -> [Partition] +listHooks 0 = [] +listHooks 1 = [ Partition [1] ] +listHooks n = [ Partition (k : replicate (n-k) 1) | k<-[1..n] ] + +-- | Outer border strips (or ribbons) of the given length +outerRibbonsOfLength :: Partition -> Int -> [Ribbon] +outerRibbonsOfLength part@(Partition ps) givenLength = result where + + result = if null ps + then [ Ribbon shape givenLength ht wd + | p <- listHooks givenLength + , let shape = mkSkewPartition (p,part) + , let ht = partitionWidth p - 1 -- pretty inconsistent names here :((( + , let wd = partitionHeight p - 1 + ] + else strips + + strips = [ mkStrip i j + | i<-[1..n] , _canStartStrip (annArr!i) + , j<-[i..n] , _canEndStrip (annArr!j) + , j-i+1 == givenLength + ] + + ysize = partitionWidth part + xsize = partitionHeight part + + annList = [ BorderBox True False 1 x | x <- reverse [xsize+2 .. xsize+givenLength ] ] + ++ annList0 + ++ [ BorderBox False True y 1 | y <- [ysize+2 .. ysize+givenLength ] ] + + n = length annList + annList0 = annotatedOuterBorderStrip part + annArr = listArray (1,n) annList + + mkStrip !i1 !i2 = Ribbon shape len height width where + ps' = (-666) : ps ++ replicate (givenLength) 0 + shape = SkewPartition [ (p,k) | (i,p,q) <- zip3 [1..max ysize y2] (tail ps') ps' , let k = indent i p q ] + indent !i !p !q + | i < y1 = 0 + | i > y2 = 0 + | i == y1 = x1 - p -- the order is important here !!! +-- | i == y2 = x2 - p + | otherwise = q - p + 1 + + len = i2 - i1 + 1 + height = y2 - y1 + width = x1 - x2 + BorderBox _ _ y1 x1 = annArr ! i1 + BorderBox _ _ y2 x2 = annArr ! i2 + +-------------------------------------------------------------------------------- +-- * Naive implementations (for testing) + +-- | Naive (and slow) implementation listing all inner border strips +innerRibbonsNaive :: Partition -> [Ribbon] +innerRibbonsNaive outer = list where + list = [ Ribbon skew (len skew) (ht skew) (wt skew) + | skew <- allSkewPartitionsWithOuterShape outer + , isRibbon skew + ] + len skew = length (skewPartitionElements skew) + ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 + wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 + + +-- | Naive (and slow) implementation listing all inner border strips of the given length +innerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon] +innerRibbonsOfLengthNaive outer givenLength = list where + pweight = partitionWeight outer + list = [ Ribbon skew (len skew) (ht skew) (wt skew) + | skew <- skewPartitionsWithOuterShape outer givenLength + , isRibbon skew + ] + len skew = length (skewPartitionElements skew) + ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 + wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 + +-- | Naive (and slow) implementation listing all outer border strips of the given length +outerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon] +outerRibbonsOfLengthNaive inner givenLength = list where + pweight = partitionWeight inner + list = [ Ribbon skew (len skew) (ht skew) (wt skew) + | skew <- skewPartitionsWithInnerShape inner givenLength + , isRibbon skew + ] + len skew = length (skewPartitionElements skew) + ht skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1 + wt skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1 + +-------------------------------------------------------------------------------- +-- * Annotated borders + +-- | A box on the border of a partition +data BorderBox = BorderBox + { _canStartStrip :: !Bool + , _canEndStrip :: !Bool + , _yCoord :: !Int + , _xCoord :: !Int + } + deriving Show + +-- | The boxes of the full inner border strip, annotated with whether a border strip +-- can start or end there. +annotatedInnerBorderStrip :: Partition -> [BorderBox] +annotatedInnerBorderStrip partition = if isEmptyPartition partition then [] else list where + list = goVert (head corners) (tail corners) + corners = extendedCornerSequence partition + + goVert (y1,x ) ((y2,_ ):rest) = [ BorderBox True (y==y2) y x | y<-[y1+1..y2] ] ++ goHoriz (y2,x) rest + goVert _ [] = [] + + goHoriz (y ,x1) ((_, x2):rest) = case rest of + [] -> [ BorderBox False True y x | x<-[x1-1,x1-2..x2+1] ] + _ -> [ BorderBox False (x/=x2) y x | x<-[x1-1,x1-2..x2 ] ] ++ goVert (y,x2) rest + +-- | The boxes of the full outer border strip, annotated with whether a border strip +-- can start or end there. +annotatedOuterBorderStrip :: Partition -> [BorderBox] +annotatedOuterBorderStrip partition = if isEmptyPartition partition then [] else list where + list = goVert (head corners) (tail corners) + corners = extendedCornerSequence partition + + goVert (y1,x ) ((y2,_ ):rest) = [ BorderBox (y==y1) (y/=y2) (y+1) (x+1) | y<-[y1..y2] ] ++ goHoriz (y2,x) rest + goVert _ [] = [] + + goHoriz (y ,x1) ((_, x2):rest) = case rest of + [] -> [ BorderBox True (x==0) (y+1) (x+1) | x<-[x1-1,x1-2..x2 ] ] + _ -> [ BorderBox True False (y+1) (x+1) | x<-[x1-1,x1-2..x2+1] ] ++ goVert (y,x2) rest + + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Partitions/Vector.hs b/src/Math/Combinat/Partitions/Vector.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/Permutations.hs b/src/Math/Combinat/Permutations.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Permutations.hs @@ -0,0 +1,969 @@ + +-- | Permutations. +-- +-- See eg.: +-- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B. +-- +-- WARNING: As of version 0.2.8.0, I changed the convention of how permutations +-- are represented internally. Also now they act on the /right/ by default! +-- + +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-} +module Math.Combinat.Permutations + ( -- * The Permutation type + Permutation (..) + , fromPermutation + , lookupPermutation , (!!!) + , permutationArray + , permutationUArray + , uarrayToPermutationUnsafe + , isPermutation + , maybePermutation + , toPermutation + , toPermutationUnsafe + , toPermutationUnsafeN + , permutationSize + -- * Disjoint cycles + , DisjointCycles (..) + , fromDisjointCycles + , disjointCyclesUnsafe + , permutationToDisjointCycles + , disjointCyclesToPermutation + , numberOfCycles + , concatPermutations + -- * Queries + , isIdentityPermutation + , isReversePermutation + , isEvenPermutation + , isOddPermutation + , signOfPermutation + , signValueOfPermutation + , module Math.Combinat.Sign -- , Sign(..) + , isCyclicPermutation + -- * Some concrete permutations + , transposition + , transpositions + , adjacentTransposition + , adjacentTranspositions + , cycleLeft + , cycleRight + , reversePermutation + -- * Inversions + , inversions + , numberOfInversions + , numberOfInversionsNaive + , numberOfInversionsMerge + , bubbleSort2 + , bubbleSort + -- * Permutation groups + , identityPermutation + , inversePermutation + , multiplyPermutation + , productOfPermutations + , productOfPermutations' + -- * Action of the permutation group + , permuteArray + , permuteList + , permuteArrayLeft , permuteArrayRight + , permuteListLeft , permuteListRight + -- * Sorting + , sortingPermutationAsc + , sortingPermutationDesc + -- * ASCII drawing + , asciiPermutation + , asciiDisjointCycles + , twoLineNotation + , inverseTwoLineNotation + , genericTwoLineNotation + -- * List of permutations + , permutations + , _permutations + , permutationsNaive + , _permutationsNaive + , countPermutations + -- * Random permutations + , randomPermutation + , _randomPermutation + , randomCyclicPermutation + , _randomCyclicPermutation + , randomPermutationDurstenfeld + , randomCyclicPermutationSattolo + -- * Multisets + , permuteMultiset + , countPermuteMultiset + , fasc2B_algorithm_L + ) + where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Control.Monad.ST + +import Data.List hiding ( permutations ) +import Data.Ord ( comparing ) + +import Data.Array (Array) +import Data.Array.ST +import Data.Array.Unboxed +import Data.Array.IArray +import Data.Array.MArray +import Data.Array.Unsafe + +import Data.Vector.Compact.WordVec ( WordVec ) +import qualified Data.Vector.Compact.WordVec as V + +import Math.Combinat.ASCII +import Math.Combinat.Classes +import Math.Combinat.Helper +import Math.Combinat.Sign +import Math.Combinat.Numbers ( factorial , binomial ) + +import System.Random + +-------------------------------------------------------------------------------- +-- WordVec helpers + +toUArray :: WordVec -> UArray Int Int +toUArray vec = listArray (1,n) (map fromIntegral $ V.toList vec) where n = V.vecLen vec + +fromUArray :: UArray Int Int -> WordVec +fromUArray arr = fromPermListN n (map fromIntegral $ elems arr) where + (1,n) = bounds arr + +-- | maximum = length +fromPermListN :: Int -> [Int] -> WordVec +fromPermListN n perm = V.fromList' shape (map fromIntegral perm) where + shape = V.Shape n bits + bits = V.bitsNeededFor (fromIntegral n :: Word) + +fromPermList :: [Int] -> WordVec +fromPermList perm = V.fromList (map fromIntegral perm) + +(.!) :: WordVec -> Int -> Int +(.!) vec idx = fromIntegral (V.unsafeIndex (idx-1) vec) + +_elems :: WordVec -> [Int] +_elems = map fromIntegral . V.toList + +_assocs :: WordVec -> [(Int,Int)] +_assocs vec = zip [1..] (_elems vec) + +_bound :: WordVec -> Int +_bound = V.vecLen + +{- +-- the old internal representation (UArray Int Int) + +_elems :: UArray Int Int -> [Int] +_elems = elems + +_assocs :: UArray Int Int -> [(Int,Int)] +_assocs = elems + +_bound :: UArray Int Int -> Int +_bound = snd . bounds +-} + + +toPermN :: Int -> [Int] -> Permutation +toPermN n xs = Permutation (fromPermListN n xs) + +-------------------------------------------------------------------------------- +-- * Types + +-- | A permutation. Internally it is an (compact) vector +-- of the integers @[1..n]@. +-- +-- If this array of integers is @[p1,p2,...,pn]@, then in two-line +-- notations, that represents the permutation +-- +-- > ( 1 2 3 ... n ) +-- > ( p1 p2 p3 ... pn ) +-- +-- That is, it is the permutation @sigma@ whose (right) action on the set @[1..n]@ is +-- +-- > sigma(1) = p1 +-- > sigma(2) = p2 +-- > ... +-- +-- (NOTE: this changed at version 0.2.8.0!) +-- +newtype Permutation = Permutation WordVec deriving (Eq,Ord) -- ,Show,Read) + +instance Show Permutation where + showsPrec d (Permutation arr) + = showParen (d > 10) + $ showString "toPermutation " . showsPrec 11 (_elems arr) -- app_prec = 10 + +instance Read Permutation where + readsPrec d r = readParen (d > 10) fun r where + fun r = [ (toPermutation p,t) + | ("toPermutation",s) <- lex r + , (p,t) <- readsPrec 11 s -- app_prec = 10 + ] + +instance DrawASCII Permutation where + ascii = asciiPermutation + +-- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@. +-- +-- The cycles are to be understood as follows: a cycle @[c1,c2,...,ck]@ means +-- the permutation +-- +-- > ( c1 c2 c3 ... ck ) +-- > ( c2 c3 c4 ... c1 ) +-- +newtype DisjointCycles = DisjointCycles [[Int]] deriving (Eq,Ord,Show,Read) + +fromPermutation :: Permutation -> [Int] +fromPermutation (Permutation ar) = _elems ar + +permutationUArray :: Permutation -> UArray Int Int +permutationUArray (Permutation ar) = toUArray ar + +permutationArray :: Permutation -> Array Int Int +permutationArray (Permutation ar) = listArray (1,n) (_elems ar) where + n = _bound ar + +-- | Assumes that the input is a permutation of the numbers @[1..n]@. +toPermutationUnsafe :: [Int] -> Permutation +toPermutationUnsafe xs = Permutation (fromPermList xs) + +-- | This is faster than 'toPermutationUnsafe', but you need to supply @n@. +toPermutationUnsafeN :: Int -> [Int] -> Permutation +toPermutationUnsafeN n xs = Permutation (fromPermListN n xs) + +-- | Note: Indexing starts from 1. +uarrayToPermutationUnsafe :: UArray Int Int -> Permutation +uarrayToPermutationUnsafe = Permutation . fromUArray + +-- | Checks whether the input is a permutation of the numbers @[1..n]@. +isPermutation :: [Int] -> Bool +isPermutation xs = (ar!0 == 0) && and [ ar!j == 1 | j<-[1..n] ] where + n = length xs + -- the zero index is an unidiomatic hack + ar = (accumArray (+) 0 (0,n) $ map f xs) :: UArray Int Int + f :: Int -> (Int,Int) + f !j = if j<1 || j>n then (0,1) else (j,1) + +-- | Checks whether the input is a permutation of the numbers @[1..n]@. +maybePermutation :: [Int] -> Maybe Permutation +maybePermutation input = runST action where + n = length input + action :: forall s. ST s (Maybe Permutation) + action = do + ar <- newArray (1,n) 0 :: ST s (STUArray s Int Int) + let go [] = return $ Just (toPermutationUnsafe input) + go (j:js) = if j<1 || j>n + then return Nothing + else do + z <- readArray ar j + writeArray ar j (z+1) + if z==0 then go js + else return Nothing + go input + +-- | Checks the input. +toPermutation :: [Int] -> Permutation +toPermutation xs = case maybePermutation xs of + Just p -> p + Nothing -> error "toPermutation: not a permutation" + +-- | Returns @n@, where the input is a permutation of the numbers @[1..n]@ +permutationSize :: Permutation -> Int +permutationSize (Permutation ar) = _bound ar + +-- | Returns the image @sigma(k)@ of @k@ under the permutation @sigma@. +-- +-- Note: we don't check the bounds! It may even crash if you index out of bounds! +lookupPermutation :: Permutation -> Int -> Int +lookupPermutation (Permutation ar) idx = ar .! idx + +-- infix 8 !!! + +-- | Infix version of 'lookupPermutation' +(!!!) :: Permutation -> Int -> Int +(!!!) (Permutation ar) idx = ar .! idx + +instance HasWidth Permutation where + width = permutationSize + +-- | Checks whether the permutation is the identity permutation +isIdentityPermutation :: Permutation -> Bool +isIdentityPermutation (Permutation ar) = (_elems ar == [1..n]) where + n = _bound ar + +-- | Given a permutation of @n@ and a permutation of @m@, we return +-- a permutation of @n+m@ resulting by putting them next to each other. +-- This should satisfy +-- +-- > permuteList p1 xs ++ permuteList p2 ys == permuteList (concatPermutations p1 p2) (xs++ys) +-- +concatPermutations :: Permutation -> Permutation -> Permutation +concatPermutations perm1 perm2 = toPermutationUnsafe list where + n = permutationSize perm1 + list = fromPermutation perm1 ++ map (+n) (fromPermutation perm2) + +-------------------------------------------------------------------------------- +-- * ASCII + +-- | Synonym for 'twoLineNotation' +asciiPermutation :: Permutation -> ASCII +asciiPermutation = twoLineNotation + +asciiDisjointCycles :: DisjointCycles -> ASCII +asciiDisjointCycles (DisjointCycles cycles) = final where + final = hCatWith VTop (HSepSpaces 1) boxes + boxes = [ genericTwoLineNotation (f cyc) | cyc <- cycles ] + f cyc = pairs (cyc ++ [head cyc]) + +-- | The standard two-line notation, moving the element indexed by the top row into +-- the place indexed by the corresponding element in the bottom row. +twoLineNotation :: Permutation -> ASCII +twoLineNotation (Permutation arr) = genericTwoLineNotation $ zip [1..] (_elems arr) + +-- | The inverse two-line notation, where the it\'s the bottom line +-- which is in standard order. The columns of this are a permutation +-- of the columns 'twoLineNotation'. +-- +-- Remark: the top row of @inverseTwoLineNotation perm@ is the same +-- as the bottom row of @twoLineNotation (inversePermutation perm)@. +-- +inverseTwoLineNotation :: Permutation -> ASCII +inverseTwoLineNotation (Permutation arr) = + genericTwoLineNotation $ sortBy (comparing snd) $ zip [1..] (_elems arr) + +-- | Two-line notation for any set of numbers +genericTwoLineNotation :: [(Int,Int)] -> ASCII +genericTwoLineNotation xys = asciiFromLines [ topLine, botLine ] where + topLine = "( " ++ intercalate " " us ++ " )" + botLine = "( " ++ intercalate " " vs ++ " )" + pairs = [ (show x, show y) | (x,y) <- xys ] + (us,vs) = unzip (map f pairs) + f (s,t) = (s',t') where + a = length s + b = length t + c = max a b + s' = replicate (c-a) ' ' ++ s + t' = replicate (c-b) ' ' ++ t + +-------------------------------------------------------------------------------- +-- * Disjoint cycles + +fromDisjointCycles :: DisjointCycles -> [[Int]] +fromDisjointCycles (DisjointCycles cycles) = cycles + +disjointCyclesUnsafe :: [[Int]] -> DisjointCycles +disjointCyclesUnsafe = DisjointCycles + +instance DrawASCII DisjointCycles where + ascii = asciiDisjointCycles + +instance HasNumberOfCycles DisjointCycles where + numberOfCycles (DisjointCycles cycles) = length cycles + +instance HasNumberOfCycles Permutation where + numberOfCycles = numberOfCycles . permutationToDisjointCycles + +disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation +disjointCyclesToPermutation n (DisjointCycles cycles) = Permutation $ fromUArray perm where + + pairs :: [Int] -> [(Int,Int)] + pairs xs@(x:_) = worker (xs++[x]) where + worker (x:xs@(y:_)) = (x,y):worker xs + worker _ = [] + pairs [] = error "disjointCyclesToPermutation: empty cycle" + + perm = runSTUArray $ do + ar <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \i -> writeArray ar i i + forM_ cycles $ \cyc -> forM_ (pairs cyc) $ \(i,j) -> writeArray ar i j + return ar -- freeze ar + +-- | Convert to disjoint cycle notation. +-- +-- This is compatible with Maple's @convert(perm,\'disjcyc\')@ +-- and also with Mathematica's @PermutationCycles[perm]@ +-- +-- Note however, that for example Mathematica uses the +-- /top row/ to represent a permutation, while we use the +-- /bottom row/ - thus even though this function looks +-- identical, the /meaning/ of both the input and output +-- is different! +-- +permutationToDisjointCycles :: Permutation -> DisjointCycles +permutationToDisjointCycles (Permutation perm) = res where + + n = _bound perm + + -- we don't want trivial cycles + f :: [Int] -> Bool + f [_] = False + f _ = True + + res = runST $ do + tag <- newArray (1,n) False + cycles <- unfoldM (step tag) 1 + return (DisjointCycles $ filter f cycles) + + step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int) + step tag k = do + cyc <- worker tag k k [k] + m <- next tag (k+1) + return (reverse cyc, m) + + next :: STUArray s Int Bool -> Int -> ST s (Maybe Int) + next tag k = if k > n + then return Nothing + else readArray tag k >>= \b -> if b + then next tag (k+1) + else return (Just k) + + worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int] + worker tag k l cyc = do + writeArray tag l True + let m = perm .! l + if m == k + then return cyc + else worker tag k m (m:cyc) + +isEvenPermutation :: Permutation -> Bool +isEvenPermutation (Permutation perm) = res where + + n = _bound perm + res = runST $ do + tag <- newArray (1,n) False + cycles <- unfoldM (step tag) 1 + return $ even (sum cycles) + + step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int) + step tag k = do + cyclen <- worker tag k k 0 + m <- next tag (k+1) + return (cyclen,m) + + next :: STUArray s Int Bool -> Int -> ST s (Maybe Int) + next tag k = if k > n + then return Nothing + else readArray tag k >>= \b -> if b + then next tag (k+1) + else return (Just k) + + worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int + worker tag k l cyclen = do + writeArray tag l True + let m = perm .! l + if m == k + then return cyclen + else worker tag k m (1+cyclen) + +isOddPermutation :: Permutation -> Bool +isOddPermutation = not . isEvenPermutation + +signOfPermutation :: Permutation -> Sign +signOfPermutation perm = case isEvenPermutation perm of + True -> Plus + False -> Minus + +-- | Plus 1 or minus 1. +{-# SPECIALIZE signValueOfPermutation :: Permutation -> Int #-} +{-# SPECIALIZE signValueOfPermutation :: Permutation -> Integer #-} +signValueOfPermutation :: Num a => Permutation -> a +signValueOfPermutation = signValue . signOfPermutation + +isCyclicPermutation :: Permutation -> Bool +isCyclicPermutation perm = + case cycles of + [] -> True + [cyc] -> (length cyc == n) + _ -> False + where + n = permutationSize perm + DisjointCycles cycles = permutationToDisjointCycles perm + +-------------------------------------------------------------------------------- +-- * Inversions + +-- | An /inversion/ of a permutation @sigma@ is a pair @(i,j)@ such that +-- @i sigma(j)@. +-- +-- This functions returns the inversion of a permutation. +-- +inversions :: Permutation -> [(Int,Int)] +inversions (Permutation arr) = list where + n = _bound arr + list = [ (i,j) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ] + +-- | Returns the number of inversions: +-- +-- > numberOfInversions perm = length (inversions perm) +-- +-- Synonym for 'numberOfInversionsMerge' +-- +numberOfInversions :: Permutation -> Int +numberOfInversions = numberOfInversionsMerge + +-- | Returns the number of inversions, using the merge-sort algorithm. +-- This should be @O(n*log(n))@ +-- +numberOfInversionsMerge :: Permutation -> Int +numberOfInversionsMerge (Permutation arr) = fst (sortCnt n $ _elems arr) where + n = _bound arr + + -- | First argument is length of the list. + -- Returns also the inversion count. + sortCnt :: Int -> [Int] -> (Int,[Int]) + sortCnt 0 _ = (0,[] ) + sortCnt 1 [x] = (0,[x]) + sortCnt 2 [x,y] = if x>y then (1,[y,x]) else (0,[x,y]) + sortCnt n xs = mergeCnt (sortCnt k us) (sortCnt l vs) where + k = div n 2 + l = n - k + (us,vs) = splitAt k xs + + mergeCnt :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int]) + mergeCnt (!c,us) (!d,vs) = (c+d+e,ws) where + + (e,ws) = go 0 us vs + + go !k xs [] = ( k*length xs , xs ) + go _ [] ys = ( 0 , ys) + go !k xxs@(x:xs) yys@(y:ys) = if x < y + then let (a,zs) = go k xs yys in (a+k, x:zs) + else let (a,zs) = go (k+1) xxs ys in (a , y:zs) + +-- | Returns the number of inversions, using the definition, thus it's @O(n^2)@. +-- +numberOfInversionsNaive :: Permutation -> Int +numberOfInversionsNaive (Permutation arr) = length list where + n = _bound arr + list = [ (0::Int) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ] + +-- | Bubble sorts breaks a permutation into the product of adjacent transpositions: +-- +-- > multiplyMany' n (map (transposition n) $ bubbleSort2 perm) == perm +-- +-- Note that while this is not unique, the number of transpositions +-- equals the number of inversions. +-- +bubbleSort2 :: Permutation -> [(Int,Int)] +bubbleSort2 = map f . bubbleSort where f i = (i,i+1) + +-- | Another version of bubble sort. An entry @i@ in the return sequence means +-- the transposition @(i,i+1)@: +-- +-- > multiplyMany' n (map (adjacentTransposition n) $ bubbleSort perm) == perm +-- +bubbleSort :: Permutation -> [Int] +bubbleSort perm@(Permutation tgt) = runST action where + n = _bound tgt + + action :: forall s. ST s [Int] + action = do + fwd <- newArray_ (1,n) :: ST s (STUArray s Int Int) + inv <- newArray_ (1,n) :: ST s (STUArray s Int Int) + forM_ [1..n] $ \i -> writeArray fwd i i + forM_ [1..n] $ \i -> writeArray inv i i + + list <- forM [1..n] $ \x -> do + + let k = tgt .! x -- we take the number which will be at the @x@-th position at the end + i <- readArray inv k -- number @k@ is at the moment at position @i@ + let j = x -- but the final place is at @x@ + + let swaps = move i j + forM_ swaps $ \y -> do + + a <- readArray fwd y + b <- readArray fwd (y+1) + writeArray fwd (y+1) a + writeArray fwd y b + + u <- readArray inv a + v <- readArray inv b + writeArray inv b u + writeArray inv a v + + return swaps + + return (concat list) + + move :: Int -> Int -> [Int] + move !i !j + | j == i = [] + | j > i = [i..j-1] + | j < i = [i-1,i-2..j] + +-------------------------------------------------------------------------------- +-- * Some concrete permutations + +-- | The permutation @[n,n-1,n-2,...,2,1]@. Note that it is the inverse of itself. +reversePermutation :: Int -> Permutation +reversePermutation n = Permutation $ fromPermListN n [n,n-1..1] + +-- | Checks whether the permutation is the reverse permutation @[n,n-1,n-2,...,2,1]. +isReversePermutation :: Permutation -> Bool +isReversePermutation (Permutation arr) = _elems arr == [n,n-1..1] where n = _bound arr + +-- | A transposition (swapping two elements). +-- +-- @transposition n (i,j)@ is the permutation of size @n@ which swaps @i@\'th and @j@'th elements. +-- +transposition :: Int -> (Int,Int) -> Permutation +transposition n (i,j) = + if i>=1 && j>=1 && i<=n && j<=n + then Permutation $ fromPermListN n [ f k | k<-[1..n] ] + else error "transposition: index out of range" + where + f k | k == i = j + | k == j = i + | otherwise = k + +-- | Product of transpositions. +-- +-- > transpositions n list == multiplyMany [ transposition n pair | pair <- list ] +-- +transpositions :: Int -> [(Int,Int)] -> Permutation +transpositions n list = Permutation (fromUArray $ runSTUArray action) where + + action :: ST s (STUArray s Int Int) + action = do + arr <- newArray_ (1,n) + forM_ [1..n] $ \i -> writeArray arr i i + let doSwap (i,j) = do + u <- readArray arr i + v <- readArray arr j + writeArray arr i v + writeArray arr j u + mapM_ doSwap list + return arr + +-- | @adjacentTransposition n k@ swaps the elements @k@ and @(k+1)@. +adjacentTransposition :: Int -> Int -> Permutation +adjacentTransposition n k + | k>0 && k adjacentTranspositions n list == multiplyMany [ adjacentTransposition n idx | idx <- list ] +-- +adjacentTranspositions :: Int -> [Int] -> Permutation +adjacentTranspositions n list = Permutation (fromUArray $ runSTUArray action) where + + action :: ST s (STUArray s Int Int) + action = do + arr <- newArray_ (1,n) + forM_ [1..n] $ \i -> writeArray arr i i + let doSwap i + | i<0 || i>=n = error "adjacentTranspositions: index out of range" + | otherwise = do + u <- readArray arr i + v <- readArray arr (i+1) + writeArray arr i v + writeArray arr (i+1) u + mapM_ doSwap list + return arr + +-- | The permutation which cycles a list left by one step: +-- +-- > permuteList (cycleLeft 5) "abcde" == "bcdea" +-- +-- Or in two-line notation: +-- +-- > ( 1 2 3 4 5 ) +-- > ( 2 3 4 5 1 ) +-- +cycleLeft :: Int -> Permutation +cycleLeft n = Permutation $ fromPermListN n ([2..n] ++ [1]) + +-- | The permutation which cycles a list right by one step: +-- +-- > permuteList (cycleRight 5) "abcde" == "eabcd" +-- +-- Or in two-line notation: +-- +-- > ( 1 2 3 4 5 ) +-- > ( 5 1 2 3 4 ) +-- +cycleRight :: Int -> Permutation +cycleRight n = Permutation $ fromPermListN n (n : [1..n-1]) + +-------------------------------------------------------------------------------- +-- * Permutation groups + +-- | Multiplies two permutations together: @p `multiplyPermutation` q@ +-- means the permutation when we first apply @p@, and then @q@ +-- (that is, the natural action is the /right/ action) +-- +-- See also 'permuteArray' for our conventions. +-- +multiplyPermutation :: Permutation -> Permutation -> Permutation +multiplyPermutation pi1@(Permutation perm1) pi2@(Permutation perm2) = + if (n==m) + then Permutation $ fromUArray result + else error "multiplyPermutation: permutations of different sets" + where + n = _bound perm1 + m = _bound perm2 + result = permuteArray pi2 (toUArray perm1) + +infixr 7 `multiplyPermutation` + +-- | The inverse permutation. +inversePermutation :: Permutation -> Permutation +inversePermutation (Permutation perm1) = Permutation $ fromUArray result + where + result = array (1,n) $ map swap $ _assocs perm1 + n = _bound perm1 + +-- | The identity (or trivial) permutation. +identityPermutation :: Int -> Permutation +identityPermutation n = Permutation $ fromPermListN n [1..n] + +-- | Multiply together a /non-empty/ list of permutations (the reason for requiring the list to +-- be non-empty is that we don\'t know the size of the result). See also 'multiplyMany''. +productOfPermutations :: [Permutation] -> Permutation +productOfPermutations [] = error "productOfPermutations: empty list, we don't know size of the result" +productOfPermutations ps = foldl1' multiplyPermutation ps + +-- | Multiply together a (possibly empty) list of permutations, all of which has size @n@ +productOfPermutations' :: Int -> [Permutation] -> Permutation +productOfPermutations' n [] = identityPermutation n +productOfPermutations' n ps@(p:_) = if n == permutationSize p + then foldl1' multiplyPermutation ps + else error "productOfPermutations': incompatible permutation size(s)" + +-------------------------------------------------------------------------------- +-- * Action of the permutation group + +-- | /Right/ action of a permutation on a set. If our permutation is +-- encoded with the sequence @[p1,p2,...,pn]@, then in the +-- two-line notation we have +-- +-- > ( 1 2 3 ... n ) +-- > ( p1 p2 p3 ... pn ) +-- +-- We adopt the convention that permutations act /on the right/ +-- (as in Knuth): +-- +-- > permuteArray pi2 (permuteArray pi1 set) == permuteArray (pi1 `multiplyPermutation` pi2) set +-- +-- Synonym to 'permuteArrayRight' +-- +{-# SPECIALIZE permuteArray :: Permutation -> Array Int b -> Array Int b #-} +{-# SPECIALIZE permuteArray :: Permutation -> UArray Int Int -> UArray Int Int #-} +permuteArray :: IArray arr b => Permutation -> arr Int b -> arr Int b +permuteArray = permuteArrayRight + +-- | Right action on lists. Synonym to 'permuteListRight' +-- +permuteList :: Permutation -> [a] -> [a] +permuteList = permuteListRight + +-- | The right (standard) action of permutations on sets. +-- +-- > permuteArrayRight pi2 (permuteArrayRight pi1 set) == permuteArrayRight (pi1 `multiplyPermutation` pi2) set +-- +-- The second argument should be an array with bounds @(1,n)@. +-- The function checks the array bounds. +-- +{-# SPECIALIZE permuteArrayRight :: Permutation -> Array Int b -> Array Int b #-} +{-# SPECIALIZE permuteArrayRight :: Permutation -> UArray Int Int -> UArray Int Int #-} +permuteArrayRight :: IArray arr b => Permutation -> arr Int b -> arr Int b +permuteArrayRight pi@(Permutation perm) ar = + if (a==1) && (b==n) + then listArray (1,n) [ ar!(perm.!i) | i <- [1..n] ] + else error "permuteArrayRight: array bounds do not match" + where + n = _bound perm + (a,b) = bounds ar + +-- | The right (standard) action on a list. The list should be of length @n@. +-- +-- > fromPermutation perm == permuteListRight perm [1..n] +-- +permuteListRight :: forall a . Permutation -> [a] -> [a] +permuteListRight perm xs = elems $ permuteArrayRight perm $ arr where + arr = listArray (1,n) xs :: Array Int a + n = permutationSize perm + +-- | The left (opposite) action of the permutation group. +-- +-- > permuteArrayLeft pi2 (permuteArrayLeft pi1 set) == permuteArrayLeft (pi2 `multiplyPermutation` pi1) set +-- +-- It is related to 'permuteLeftArray' via: +-- +-- > permuteArrayLeft pi arr == permuteArrayRight (inversePermutation pi) arr +-- > permuteArrayRight pi arr == permuteArrayLeft (inversePermutation pi) arr +-- +{-# SPECIALIZE permuteArrayLeft :: Permutation -> Array Int b -> Array Int b #-} +{-# SPECIALIZE permuteArrayLeft :: Permutation -> UArray Int Int -> UArray Int Int #-} +permuteArrayLeft :: IArray arr b => Permutation -> arr Int b -> arr Int b +permuteArrayLeft pi@(Permutation perm) ar = + -- permuteRight (inverse pi) ar + if (a==1) && (b==n) + then array (1,n) [ ( perm.!i , ar!i ) | i <- [1..n] ] + else error "permuteArrayLeft: array bounds do not match" + where + n = _bound perm + (a,b) = bounds ar + +-- | The left (opposite) action on a list. The list should be of length @n@. +-- +-- > permuteListLeft perm set == permuteList (inversePermutation perm) set +-- > fromPermutation (inversePermutation perm) == permuteListLeft perm [1..n] +-- +permuteListLeft :: forall a. Permutation -> [a] -> [a] +permuteListLeft perm xs = elems $ permuteArrayLeft perm $ arr where + arr = listArray (1,n) xs :: Array Int a + n = permutationSize perm + +-------------------------------------------------------------------------------- + +-- | Given a list of things, we return a permutation which sorts them into +-- ascending order, that is: +-- +-- > permuteList (sortingPermutationAsc xs) xs == sort xs +-- +-- Note: if the things are not unique, then the sorting permutations is not +-- unique either; we just return one of them. +-- +sortingPermutationAsc :: Ord a => [a] -> Permutation +sortingPermutationAsc xs = toPermutation (map fst sorted) where + sorted = sortBy (comparing snd) $ zip [1..] xs + +-- | Given a list of things, we return a permutation which sorts them into +-- descending order, that is: +-- +-- > permuteList (sortingPermutationDesc xs) xs == reverse (sort xs) +-- +-- Note: if the things are not unique, then the sorting permutations is not +-- unique either; we just return one of them. +-- +sortingPermutationDesc :: Ord a => [a] -> Permutation +sortingPermutationDesc xs = toPermutation (map fst sorted) where + sorted = sortBy (reverseComparing snd) $ zip [1..] xs + +-------------------------------------------------------------------------------- +-- * Permutations of distinct elements + +-- | A synonym for 'permutationsNaive' +permutations :: Int -> [Permutation] +permutations = permutationsNaive + +_permutations :: Int -> [[Int]] +_permutations = _permutationsNaive + +-- | All permutations of @[1..n]@ in lexicographic order, naive algorithm. +permutationsNaive :: Int -> [Permutation] +permutationsNaive n = map toPermutationUnsafe $ _permutations n + +_permutationsNaive :: Int -> [[Int]] +_permutationsNaive 0 = [[]] +_permutationsNaive 1 = [[1]] +_permutationsNaive 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 + +-- | # = n! +countPermutations :: Int -> Integer +countPermutations = factorial + +-------------------------------------------------------------------------------- +-- * Random permutations + +-- | A synonym for 'randomPermutationDurstenfeld'. +randomPermutation :: RandomGen g => Int -> g -> (Permutation,g) +randomPermutation = randomPermutationDurstenfeld + +_randomPermutation :: RandomGen g => Int -> g -> ([Int],g) +_randomPermutation n rndgen = (fromPermutation perm, rndgen') where + (perm, rndgen') = randomPermutationDurstenfeld n rndgen + +-- | A synonym for 'randomCyclicPermutationSattolo'. +randomCyclicPermutation :: RandomGen g => Int -> g -> (Permutation,g) +randomCyclicPermutation = randomCyclicPermutationSattolo + +_randomCyclicPermutation :: RandomGen g => Int -> g -> ([Int],g) +_randomCyclicPermutation n rndgen = (fromPermutation perm, rndgen') where + (perm, rndgen') = randomCyclicPermutationSattolo n rndgen + +-- | Generates a uniformly random permutation of @[1..n]@. +-- Durstenfeld's algorithm (see ). +randomPermutationDurstenfeld :: RandomGen g => Int -> g -> (Permutation,g) +randomPermutationDurstenfeld = randomPermutationDurstenfeldSattolo False + +-- | Generates a uniformly random /cyclic/ permutation of @[1..n]@. +-- Sattolo's algorithm (see ). +randomCyclicPermutationSattolo :: RandomGen g => Int -> g -> (Permutation,g) +randomCyclicPermutationSattolo = randomPermutationDurstenfeldSattolo True + +randomPermutationDurstenfeldSattolo :: RandomGen g => Bool -> Int -> g -> (Permutation,g) +randomPermutationDurstenfeldSattolo isSattolo n rnd = res where + res = runST $ do + ar <- newArray_ (1,n) + forM_ [1..n] $ \i -> writeArray ar i i + rnd' <- worker n (if isSattolo then n-1 else n) rnd ar + perm <- Data.Array.Unsafe.unsafeFreeze ar + return (Permutation (fromUArray perm), rnd') + worker :: RandomGen g => Int -> Int -> g -> STUArray s Int Int -> ST s g + worker n m rnd ar = + if n==1 + then return rnd + else do + let (k,rnd') = randomR (1,m) rnd + when (k /= n) $ do + y <- readArray ar k + z <- readArray ar n + writeArray ar n y + writeArray ar k z + worker (n-1) (m-1) rnd' ar + +-------------------------------------------------------------------------------- +-- * Permutations of a multiset + +-- | Generates all permutations of a multiset. +-- The order is lexicographic. A synonym for 'fasc2B_algorithm_L' +permuteMultiset :: (Eq a, Ord a) => [a] -> [[a]] +permuteMultiset = fasc2B_algorithm_L + +-- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) } +countPermuteMultiset :: (Eq a, Ord a) => [a] -> Integer +countPermuteMultiset 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/src/Math/Combinat/RootSystems.hs b/src/Math/Combinat/RootSystems.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/RootSystems.hs @@ -0,0 +1,319 @@ + +-- | Naive (very inefficient) algorithm to generate the irreducible (Dynkin) root systems +-- +-- Based on + +{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +module Math.Combinat.RootSystems where + +-------------------------------------------------------------------------------- + +import Control.Monad + +import Data.Array + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.List +import Data.Ord + +import Math.Combinat.Numbers.Primes +import Math.Combinat.Sets + +-------------------------------------------------------------------------------- +-- * Half-integers + +-- | The type of half-integers (internally represented by their double) +-- +-- TODO: refactor this into its own module +newtype HalfInt + = HalfInt Int + deriving (Eq,Ord) + +half :: HalfInt +half = HalfInt 1 + +divByTwo :: Int -> HalfInt +divByTwo n = HalfInt n + +mulByTwo :: HalfInt -> Int +mulByTwo (HalfInt n) = n + +scaleBy :: Int -> HalfInt -> HalfInt +scaleBy k (HalfInt n) = HalfInt (k*n) + +instance Show HalfInt where + show (HalfInt n) = case divMod n 2 of + (k,0) -> show k + (_,1) -> show n ++ "/2" + +instance Num HalfInt where + fromInteger = HalfInt . (*2) . fromInteger + a + b = divByTwo $ mulByTwo a + mulByTwo b + a - b = divByTwo $ mulByTwo a - mulByTwo b + a * b = case divMod (mulByTwo a * mulByTwo b) 4 of + (k,0) -> HalfInt (2*k) + (k,2) -> HalfInt (2*k+1) + _ -> error "the result of multiplication is not a half-integer" + negate = divByTwo . negate . mulByTwo + signum = divByTwo . signum . mulByTwo + abs = divByTwo . abs . mulByTwo + +-------------------------------------------------------------------------------- +-- * Vectors of half-integers + +type HalfVec = [HalfInt] + +instance Num HalfVec where + fromInteger = error "HalfVec/fromInteger" + (+) = safeZip (+) + (-) = safeZip (-) + (*) = safeZip (*) + negate = map negate + abs = map abs + signum = map signum + +scaleVec :: Int -> HalfVec -> HalfVec +scaleVec k = map (scaleBy k) + +negateVec :: HalfVec -> HalfVec +negateVec = map negate + +-- dotProd :: HalfVec -> HalfVec +-- dotProd xs ys = foldl' (+) 0 $ safeZip (*) xs ys + +safeZip :: (a -> b -> c) -> [a] -> [b] -> [c] +safeZip f = go where + go (x:xs) (y:ys) = f x y : go xs ys + go [] [] = [] + go _ _ = error "safeZip: the lists do not have equal length" + +-------------------------------------------------------------------------------- +-- * Dynkin diagrams + +data Dynkin + = A !Int + | B !Int + | C !Int + | D !Int + | E6 | E7 | E8 + | F4 + | G2 + deriving (Eq,Show) + +-------------------------------------------------------------------------------- +-- * The roots of root systems + +-- | The ambient dimension of (our representation of the) system (length of the vector) +ambientDim :: Dynkin -> Int +ambientDim d = case d of + A n -> n+1 -- it's an n dimensional subspace of (n+1) dimensions + B n -> n + C n -> n + D n -> n + E6 -> 6 + E7 -> 8 -- sublattice of E8 ? + E8 -> 8 + F4 -> 4 + G2 -> 3 -- it's a 2 dimensional subspace of 3 dimensions + +simpleRootsOf :: Dynkin -> [HalfVec] +simpleRootsOf d = + + case d of + + A n -> [ e i - e (i+1) | i <- [1..n] ] + + B n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e n] + + C n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [scaleVec 2 (e n)] + + D n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e (n-1) + e n] + + E6 -> simpleRootsE6_123 + E7 -> simpleRootsE7_12 + E8 -> simpleRootsE8_even + + F4 -> [ [ 1,-1, 0, 0] + , [ 0, 1,-1, 0] + , [ 0, 0, 1, 0] + , [-h,-h,-h,-h] + ] + + G2 -> [ [ 1,-1, 0] + , [-1, 2,-1] + ] + + where + h = half + n = ambientDim d + + e :: Int -> HalfVec + e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 + +positiveRootsOf :: Dynkin -> Set HalfVec +positiveRootsOf = positiveRoots . simpleRootsOf + +negativeRootsOf :: Dynkin -> Set HalfVec +negativeRootsOf = Set.map negate . positiveRootsOf + +allRootsOf :: Dynkin -> Set HalfVec +allRootsOf dynkin = Set.unions [ pos , neg ] where + simple = simpleRootsOf dynkin + pos = positiveRoots simple + neg = Set.map negate pos + +-------------------------------------------------------------------------------- +-- * Positive roots + +-- | Finds a vector, which is hopefully not orthognal to any root +-- (generated by the given simple roots), and has positive dot product with each of them. +findPositiveHyperplane :: [HalfVec] -> [Double] +findPositiveHyperplane vs = w where + n = length (head vs) + w0 = map (fromIntegral . mulByTwo) (foldl1 (+) vs) :: [Double] + w = zipWith (+) w0 perturb + perturb = map small $ map fromIntegral $ take n primes + small :: Double -> Double + small x = x / (10**10) + +positiveRoots :: [HalfVec] -> Set HalfVec +positiveRoots simples = Set.fromList pos where + roots = mirrorClosure simples + w = findPositiveHyperplane simples + pos = [ r | r <- Set.toList roots , dot4 r > 0 ] where + + dot4 :: HalfVec -> Double + dot4 a = foldl' (+) 0 $ safeZip (*) w $ map (fromIntegral . mulByTwo) a + +basisOfPositives :: Set HalfVec -> [HalfVec] +basisOfPositives set = Set.toList (Set.difference set set2) where + set2 = Set.fromList [ a + b | [a,b] <- choose 2 (Set.toList set) ] + + +-------------------------------------------------------------------------------- +-- * Operations on half-integer vectors + +-- | bracket b a = (a,b)/(a,a) +bracket :: HalfVec -> HalfVec -> HalfInt +bracket b a = + case divMod (2*a_dot_b) (a_dot_a) of + (n,0) -> divByTwo n + _ -> error "bracket: result is not a half-integer" + where + a_dot_b = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo b) + a_dot_a = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo a) + +-- | mirror b a = b - 2*(a,b)/(a,a) * a +mirror :: HalfVec -> HalfVec -> HalfVec +mirror b a = b - scaleVec (mulByTwo $ bracket b a) a + +-- | Cartan matrix of a list of (simple) roots +cartanMatrix :: [HalfVec] -> Array (Int,Int) Int +cartanMatrix list = array ((1,1),(n,n)) [ ((i,j), f i j) | i<-[1..n] , j<-[1..n] ] where + n = length list + arr = listArray (1,n) list + f !i !j = mulByTwo $ bracket (arr!j) (arr!i) + +printMatrix :: Show a => Array (Int,Int) a -> IO () +printMatrix arr = do + let ((1,1),(n,m)) = bounds arr + arr' = fmap show arr + let ks = [ 1 + maximum [ length (arr'!(i,j)) | i<-[1..n] ] | j<-[1..m] ] + forM_ [1..n] $ \i -> do + putStrLn $ flip concatMap [1..m] $ \j -> extendTo (ks!!(j-1)) $ arr' ! (i,j) + where + extendTo n s = replicate (n-length s) ' ' ++ s + +-------------------------------------------------------------------------------- +-- * Mirroring + +-- | We mirror stuff until there is no more things happening +-- (very naive algorithm, but seems to work) +mirrorClosure :: [HalfVec] -> Set HalfVec +mirrorClosure = go . Set.fromList where + + go set + | n' > n = go set' + | n'' > n = go set'' + | otherwise = set + where + n = Set.size set + n' = Set.size set' + n'' = Set.size set'' + set' = mirrorStep set + set'' = Set.union set (Set.map negateVec set) + +mirrorStep :: Set HalfVec -> Set HalfVec +mirrorStep old = Set.union old new where + new = Set.fromList [ mirror b a | [a,b] <- choose 2 $ Set.toList old ] + +-------------------------------------------------------------------------------- +-- * E6, E7 and E8 + +-- | This is a basis of E6 as the subset of the even E8 root system +-- where the first three coordinates agree (they are consolidated +-- into the first coordinate here) +simpleRootsE6_123:: [HalfVec] +simpleRootsE6_123 = roots where + h = half + roots = + [ [-h,-h,-h,-h,-h,-h,-h,-h] + , [ h, h, h, h, h, h,-h,-h] + , [ 0, 0, 0, 0,-1, 0, 1, 0] + , [ 0, 0, 0, 0, 0, 0,-1, 1] + , [-h,-h,-h, h, h, h, h,-h] + , [ 0, 0, 0,-1, 1, 0, 0, 0] + ] + +-- | This is a basis of E8 as the subset of the even E8 root system +-- where the first two coordinates agree (they are consolidated +-- into the first coordinate here) +simpleRootsE7_12:: [HalfVec] +simpleRootsE7_12 = roots where + h = half + roots = + [ [-h,-h,-h,-h,-h,-h,-h,-h] + , [ h, h, h, h, h, h,-h,-h] + , [ h, h,-h,-h,-h,-h, h, h] + , [-h,-h, h, h,-h, h, h,-h] + , [ 0, 0, 0,-1, 1, 0, 0, 0] + , [ 0, 0,-1, 1, 0, 0, 0, 0] + , [ 0, 0, 0, 0, 0, 0,-1, 1] + ] + +-- | This is a basis of E7 as the subset of the even E8 root system +-- for which the sum of coordinates sum to zero +simpleRootsE7_diag :: [HalfVec] +simpleRootsE7_diag = roots where + roots = [ e i - e (i+1) | i <-[2..7] ] ++ [[h,h,h,h,-h,-h,-h,-h]] + h = half + n = 8 + + e :: Int -> HalfVec + e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 + +simpleRootsE8_even :: [HalfVec] +simpleRootsE8_even = roots where + roots = [v1,v2,v3,v4,v5,v7,v8,v6] + + [v1,v2,v3,v4,v5,v6,v7,v8] = roots0 + roots0 = [ e i - e (i+1) | i <-[1..6] ] ++ [ e 6 + e 7 , replicate 8 (-h) ] + + h = half + n = 8 + + e :: Int -> HalfVec + e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 + +simpleRootsE8_odd :: [HalfVec] +simpleRootsE8_odd = roots where + roots = [ e i - e (i+1) | i <-[1..7] ] ++ [[-h,-h,-h,-h,-h , h,h,h]] + h = half + n = 8 + + e :: Int -> HalfVec + e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Sets.hs b/src/Math/Combinat/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Sets.hs @@ -0,0 +1,212 @@ + +-- | Subsets. + +{-# LANGUAGE BangPatterns, Rank2Types #-} +module Math.Combinat.Sets + ( + -- * Choices + choose_ , choose , choose' , choose'' , chooseTagged + -- * Compositions + , combine , compose + -- * Tensor products + , tuplesFromList + , listTensor + -- * Sublists + , kSublists + , sublists + , countKSublists + , countSublists + -- * Random choice + , randomChoice + ) + where + +-------------------------------------------------------------------------------- + +import Data.List ( sort , mapAccumL ) +import System.Random + +import Control.Monad +import Control.Monad.ST +import Data.Array.ST +import Data.Array.MArray + +-- import Data.Map (Map) +-- import qualified Data.Map as Map + +import Math.Combinat.Numbers ( binomial ) +import Math.Combinat.Helper ( swap ) + +-------------------------------------------------------------------------------- +-- * choices + + +-- | @choose_ k n@ returns all possible ways of choosing @k@ disjoint elements from @[1..n]@ +-- +-- > choose_ k n == choose k [1..n] +-- +choose_ :: Int -> Int -> [[Int]] +choose_ k n = if n<0 || k<0 + then error "choose_: n and k should nonnegative" + else if k>n || k<0 + then [] + else choose k [1..n] + +-- | All possible ways to choose @k@ elements from a list, without +-- repetitions. \"Antisymmetric power\" for lists. Synonym for 'kSublists'. +choose :: Int -> [a] -> [[a]] +choose 0 _ = [[]] +choose k [] = [] +choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs + +-- | A version of 'choose' which also returns the complementer sets. +-- +-- > choose k = map fst . choose' k +-- +choose' :: Int -> [a] -> [([a],[a])] +choose' 0 xs = [([],xs)] +choose' k [] = [] +choose' k (x:xs) = map f (choose' (k-1) xs) ++ map g (choose' k xs) where + f (as,bs) = (x:as , bs) + g (as,bs) = ( as , x:bs) + +-- | Another variation of 'choose''. This satisfies +-- +-- > choose'' k == map (\(xs,ys) -> (map fst xs, map snd ys)) . choose' k +-- +choose'' :: Int -> [(a,b)] -> [([a],[b])] +choose'' 0 xys = [([] , map snd xys)] +choose'' k [] = [] +choose'' k ((x,y):xs) = map f (choose'' (k-1) xs) ++ map g (choose'' k xs) where + f (as,bs) = (x:as , bs) + g (as,bs) = ( as , y:bs) + +-- | Another variation on 'choose' which tags the elements based on whether they are part of +-- the selected subset ('Right') or not ('Left'): +-- +-- > choose k = map rights . chooseTagged k +-- +chooseTagged :: Int -> [a] -> [[Either a a]] +chooseTagged 0 xs = [map Left xs] +chooseTagged k [] = [] +chooseTagged k (x:xs) = map f (chooseTagged (k-1) xs) ++ map g (chooseTagged k xs) where + f eis = Right x : eis + g eis = Left x : eis + +-- | All possible ways to choose @k@ elements from a list, /with repetitions/. +-- \"Symmetric power\" for lists. See also "Math.Combinat.Compositions". +-- TODO: better name? +combine :: Int -> [a] -> [[a]] +combine 0 _ = [[]] +combine k [] = [] +combine k xxs@(x:xs) = map (x:) (combine (k-1) xxs) ++ combine k xs + +-- | A synonym for 'combine'. +compose :: Int -> [a] -> [[a]] +compose = combine + +-------------------------------------------------------------------------------- +-- * tensor products + +-- | \"Tensor power\" for lists. Special case of 'listTensor': +-- +-- > tuplesFromList k xs == listTensor (replicate k xs) +-- +-- See also "Math.Combinat.Tuples". +-- TODO: better name? +tuplesFromList :: Int -> [a] -> [[a]] +tuplesFromList 0 _ = [[]] +tuplesFromList k xs = [ (y:ys) | ys <- tuplesFromList (k-1) xs , y <- xs ] +--the order seems to be very important, the wrong order causes a memory leak! +--tuplesFromList k xs = [ (y:ys) | y <- xs, ys <- tuplesFromList (k-1) xs ] + +-- | \"Tensor product\" for lists. +listTensor :: [[a]] -> [[a]] +listTensor [] = [[]] +listTensor (xs:xss) = [ y:ys | ys <- listTensor xss , y <- xs ] +--the order seems to be very important, the wrong order causes a memory leak! +--listTensor (xs:xss) = [ y:ys | y <- xs, ys <- listTensor xss ] + +-------------------------------------------------------------------------------- +-- * sublists + +-- | Sublists of a list having given number of elements. Synonym for 'choose'. +kSublists :: Int -> [a] -> [[a]] +kSublists = choose + +-- | @# = \binom { n } { k }@. +countKSublists :: Int -> Int -> Integer +countKSublists k n = binomial n k + +-- | All sublists of a list. +sublists :: [a] -> [[a]] +sublists [] = [[]] +sublists (x:xs) = sublists xs ++ map (x:) (sublists xs) +--the order seems to be very important, the wrong order causes a memory leak! +--sublists (x:xs) = map (x:) (sublists xs) ++ sublists xs + +-- | @# = 2^n@. +countSublists :: Int -> Integer +countSublists n = 2 ^ n + +-------------------------------------------------------------------------------- +-- * random choice + +-- | @randomChoice k n@ returns a uniformly random choice of @k@ elements from the set @[1..n]@ +-- +-- Example: +-- +-- > do +-- > cs <- replicateM 10000 (getStdRandom (randomChoice 3 7)) +-- > mapM_ print $ histogram cs +-- +randomChoice :: RandomGen g => Int -> Int -> g -> ([Int],g) +randomChoice k n g0 = + if k>n || k<0 + then error "randomChoice: k out of range" + else (makeChoiceFromIndicesKnuth n as, g1) + where + -- choose numbers from [1..n], [1..n-1], [1..n-2] etc + (g1,as) = mapAccumL (\g m -> swap (randomR (1,m) g)) g0 [n,n-1..n-k+1] + +-------------------------------------------------------------------------------- + +-- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, +-- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@. +-- +-- Knuth's method. The first argument is the number @n@. +-- +makeChoiceFromIndicesKnuth :: Int -> [Int] -> [Int] +makeChoiceFromIndicesKnuth n xs = + runST $ do + arr <- newArray_ (1,n) :: forall s. ST s (STUArray s Int Int) + forM_ [1..n] $ \(!j) -> writeArray arr j j + forM_ (zip [n,n-1..] xs) $ \(!j,!i) -> do + a <- readArray arr j + b <- readArray arr i + writeArray arr j b + writeArray arr i a + sel <- forM (zip [n,n-1..] xs) $ \(!j,_) -> readArray arr j + return (sort sel) + +-- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, +-- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@. +makeChoiceFromIndicesNaive :: [Int] -> [Int] +makeChoiceFromIndicesNaive = sort . go [] where + + go :: [Int] -> [Int] -> [Int] + go acc (b:bs) = b' : go (insert b' acc) bs where b' = skip b acc + go _ [] = [] + + -- skip over the already occupied positions. Second argument should be a sorted list + skip :: Int -> [Int] -> Int + skip x (y:ys) = if x>=y then skip (x+1) ys else x + skip x [] = x + + -- insert into a sorted list + insert :: Int -> [Int] -> [Int] + insert x (y:ys) = if x<=y then x:y:ys else y : insert x ys + insert x [] = [x] + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Sets/VennDiagrams.hs b/src/Math/Combinat/Sets/VennDiagrams.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Sets/VennDiagrams.hs @@ -0,0 +1,150 @@ + +-- | Venn diagrams. See +-- +-- TODO: write a more efficient implementation (for example an array of size @2^n@) +-- + +{-# LANGUAGE BangPatterns #-} +module Math.Combinat.Sets.VennDiagrams where + +-------------------------------------------------------------------------------- + +import Data.List + +import GHC.TypeLits +import Data.Proxy + +import qualified Data.Map as Map +import Data.Map (Map) + +import Math.Combinat.Compositions +import Math.Combinat.ASCII + +-------------------------------------------------------------------------------- + +-- | Venn diagrams of @n@ sets. Each possible zone is annotated with a value +-- of type @a@. A typical use case is to annotate with the cardinality of the +-- given zone. +-- +-- Internally this is representated by a map from @[Bool]@, where @True@ means element +-- of the set, @False@ means not. +-- +-- TODO: write a more efficient implementation (for example an array of size 2^n) +newtype VennDiagram a = VennDiagram { vennTable :: Map [Bool] a } deriving (Eq,Ord,Show) + +-- | How many sets are in the Venn diagram +vennDiagramNumberOfSets :: VennDiagram a -> Int +vennDiagramNumberOfSets (VennDiagram table) = length $ fst $ Map.findMin table + +-- | How many zones are in the Venn diagram +-- +-- > vennDiagramNumberOfZones v == 2 ^ (vennDiagramNumberOfSets v) +-- +vennDiagramNumberOfZones :: VennDiagram a -> Int +vennDiagramNumberOfZones venn = 2 ^ (vennDiagramNumberOfSets venn) + +-- | How many /nonempty/ zones are in the Venn diagram +vennDiagramNumberOfNonemptyZones :: VennDiagram Int -> Int +vennDiagramNumberOfNonemptyZones (VennDiagram table) = length $ filter (/=0) $ Map.elems table + +unsafeMakeVennDiagram :: [([Bool],a)] -> VennDiagram a +unsafeMakeVennDiagram = VennDiagram . Map.fromList + +-- | We call venn diagram trivial if all the intersection zones has zero cardinality +-- (that is, the original sets are all disjoint) +isTrivialVennDiagram :: VennDiagram Int -> Bool +isTrivialVennDiagram (VennDiagram table) = and [ c == 0 | (bs,c) <- Map.toList table , isIntersection bs ] where + isIntersection bs = case filter id bs of + [] -> False + [_] -> False + _ -> True + +printVennDiagram :: Show a => VennDiagram a -> IO () +printVennDiagram = putStrLn . prettyVennDiagram + +prettyVennDiagram :: Show a => VennDiagram a -> String +prettyVennDiagram = unlines . asciiLines . asciiVennDiagram + +asciiVennDiagram :: Show a => VennDiagram a -> ASCII +asciiVennDiagram (VennDiagram table) = asciiFromLines $ map f (Map.toList table) where + f (bs,a) = "{" ++ extendTo (length bs) [ if b then z else ' ' | (b,z) <- zip bs abc ] ++ "} -> " ++ show a + extendTo k str = str ++ replicate (k - length str) ' ' + abc = ['A'..'Z'] + +instance Show a => DrawASCII (VennDiagram a) where + ascii = asciiVennDiagram + +-- | Given a Venn diagram of cardinalities, we compute the cardinalities of the +-- original sets (note: this is slow!) +vennDiagramSetCardinalities :: VennDiagram Int -> [Int] +vennDiagramSetCardinalities (VennDiagram table) = go n list where + list = Map.toList table + n = length $ fst $ head list + go :: Int -> [([Bool],Int)] -> [Int] + go !0 _ = [] + go !k xs = this : go (k-1) (map xtail xs) where + this = foldl' (+) 0 [ c | ((True:_) , c) <- xs ] + xtail (bs,c) = (tail bs,c) + +-------------------------------------------------------------------------------- + +-- | Given the cardinalities of some finite sets, we list all possible +-- Venn diagrams. +-- +-- Note: we don't include the empty zone in the tables, because it's always empty. +-- +-- Remark: if each sets is a singleton set, we get back set partitions: +-- +-- > > [ length $ enumerateVennDiagrams $ replicate k 1 | k<-[1..8] ] +-- > [1,2,5,15,52,203,877,4140] +-- > +-- > > [ countSetPartitions k | k<-[1..8] ] +-- > [1,2,5,15,52,203,877,4140] +-- +-- Maybe this could be called multiset-partitions? +-- +-- Example: +-- +-- > autoTabulate RowMajor (Right 6) $ map ascii $ enumerateVennDiagrams [2,3,3] +-- +enumerateVennDiagrams :: [Int] -> [VennDiagram Int] +enumerateVennDiagrams dims = + case dims of + [] -> [] + [d] -> venns1 d + (d:ds) -> concatMap (worker (length ds) d) $ enumerateVennDiagrams ds + where + + worker !n !d (VennDiagram table) = result where + + list = Map.toList table + falses = replicate n False + + comps k = compositions' (map snd list) k + result = + [ unsafeMakeVennDiagram $ + [ (False:tfs , m-c) | ((tfs,m),c) <- zip list comp ] ++ + [ (True :tfs , c) | ((tfs,m),c) <- zip list comp ] ++ + [ (True :falses , d-k) ] + | k <- [0..d] + , comp <- comps k + ] + + venns1 :: Int -> [VennDiagram Int] + venns1 p = [ theVenn ] where + theVenn = unsafeMakeVennDiagram [ ([True],p) ] + +-------------------------------------------------------------------------------- + +{- + +-- | for testing only +venns2 :: Int -> Int -> [Venn Int] +venns2 p q = + [ mkVenn [ ([t,f],p-k) , ([f,t],q-k) , ([t,t],k) ] + | k <- [0..min p q] + ] + where + t = True + f = False +-} diff --git a/src/Math/Combinat/Sign.hs b/src/Math/Combinat/Sign.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Sign.hs @@ -0,0 +1,114 @@ + +-- | Signs + +{-# LANGUAGE CPP, BangPatterns #-} +module Math.Combinat.Sign where + +-------------------------------------------------------------------------------- + +import Data.Monoid + +-- Semigroup became a superclass of Monoid +#if MIN_VERSION_base(4,11,0) +import Data.Foldable +import Data.Semigroup +#endif + +import System.Random + +-------------------------------------------------------------------------------- + +data Sign + = Plus -- hmm, this way @Plus < Minus@, not sure about that + | Minus + deriving (Eq,Ord,Show,Read) + +-------------------------------------------------------------------------------- + +-- Semigroup became a superclass of Monoid +#if MIN_VERSION_base(4,11,0) + +instance Semigroup Sign where + (<>) = mulSign + sconcat = foldl1 mulSign + +instance Monoid Sign where + mempty = Plus + mconcat = productOfSigns + +#else + +instance Monoid Sign where + mempty = Plus + mappend = mulSign + mconcat = productOfSigns + +#endif + +-------------------------------------------------------------------------------- + +instance Random Sign where + random g = let (b,g') = random g in (if b then Plus else Minus, g') + randomR (u,v) g = let (y,g') = random g in (if u==v then u else y , g') + +isPlus, isMinus :: Sign -> Bool +isPlus s = case s of { Plus -> True ; _ -> False } +isMinus s = case s of { Minus -> True ; _ -> False } + +{-# SPECIALIZE signValue :: Sign -> Int #-} +{-# SPECIALIZE signValue :: Sign -> Integer #-} + +-- | @+1@ or @-1@ +signValue :: Num a => Sign -> a +signValue s = case s of + Plus -> 1 + Minus -> -1 + +{-# SPECIALIZE signed :: Sign -> Int -> Int #-} +{-# SPECIALIZE signed :: Sign -> Integer -> Integer #-} + +-- | Negate the second argument if the first is 'Minus' +signed :: Num a => Sign -> a -> a +signed s y = case s of + Plus -> y + Minus -> negate y + +{-# SPECIALIZE paritySign :: Int -> Sign #-} +{-# SPECIALIZE paritySign :: Integer -> Sign #-} + +-- | 'Plus' if even, 'Minus' if odd +paritySign :: Integral a => a -> Sign +paritySign x = if even x then Plus else Minus + +{-# SPECIALIZE paritySignValue :: Int -> Integer #-} +{-# SPECIALIZE paritySignValue :: Integer -> Integer #-} + +-- | @(-1)^k@ +paritySignValue :: Integral a => a -> Integer +paritySignValue k = if odd k then (-1) else 1 + +{-# SPECIALIZE negateIfOdd :: Int -> Int -> Int #-} +{-# SPECIALIZE negateIfOdd :: Int -> Integer -> Integer #-} + +-- | Negate the second argument if the first is odd +negateIfOdd :: (Integral a, Num b) => a -> b -> b +negateIfOdd k y = if even k then y else negate y + +oppositeSign :: Sign -> Sign +oppositeSign s = case s of + Plus -> Minus + Minus -> Plus + +mulSign :: Sign -> Sign -> Sign +mulSign s1 s2 = case s1 of + Plus -> s2 + Minus -> oppositeSign s2 + +productOfSigns :: [Sign] -> Sign +productOfSigns = go Plus where + go !acc [] = acc + go !acc (x:xs) = case x of + Plus -> go acc xs + Minus -> go (oppositeSign acc) xs + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Tableaux.hs b/src/Math/Combinat/Tableaux.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Tableaux.hs @@ -0,0 +1,242 @@ + +-- | 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 Young 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 ] +-- > ] +-- + +{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} +module Math.Combinat.Tableaux where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Classes +import Math.Combinat.Numbers ( factorial , binomial ) +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Integer.IntList ( _dualPartition ) +import Math.Combinat.ASCII +import Math.Combinat.Helper + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- +-- * Basic stuff + +-- | A tableau is simply represented as a list of lists. +type Tableau a = [[a]] + +-- | ASCII diagram of a tableau +asciiTableau :: Show a => Tableau a -> ASCII +asciiTableau t = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) + $ (map . map) asciiShow + $ t + +instance CanBeEmpty (Tableau a) where + empty = [] + isEmpty = null + +instance Show a => DrawASCII (Tableau a) where + ascii = asciiTableau + +_tableauShape :: Tableau a -> [Int] +_tableauShape t = map length t + +-- | The shape of a tableau +tableauShape :: Tableau a -> Partition +tableauShape t = toPartition (_tableauShape t) + +instance HasShape (Tableau a) Partition where + shape = tableauShape + +-- | Number of entries +tableauWeight :: Tableau a -> Int +tableauWeight = sum' . map length + +instance HasWeight (Tableau a) where + weight = tableauWeight + +-- | The dual of the tableau is the mirror image to the main diagonal. +dualTableau :: Tableau a -> Tableau a +dualTableau = transpose + +instance HasDuality (Tableau a) where + dual = dualTableau + +-- | The content of a tableau is the list of its entries. The ordering is from the left to the right and +-- then from the top to the bottom +tableauContent :: Tableau a -> [a] +tableauContent = concat + +-- | An element @(i,j)@ of the resulting tableau (which has shape of the +-- given partition) means that the vertical part of the hook has length @i@, +-- and the horizontal part @j@. The /hook length/ is thus @i+j-1@. +-- +-- Example: +-- +-- > > mapM_ print $ hooks $ toPartition [5,4,1] +-- > [(3,5),(2,4),(2,3),(2,2),(1,1)] +-- > [(2,4),(1,3),(1,2),(1,1)] +-- > [(1,1)] +-- +hooks :: Partition -> Tableau (Int,Int) +hooks part = zipWith f p [1..] where + p = fromPartition part + q = _dualPartition p + f l i = zipWith (\x y -> (x-i+1,y)) q [l,l-1..1] + +hookLengths :: Partition -> Tableau Int +hookLengths part = (map . map) (\(i,j) -> i+j-1) (hooks part) + +-------------------------------------------------------------------------------- +-- * Row and column words + +-- | The /row word/ of a tableau is the list of its entry read from the right to the left and then +-- from the top to the bottom. +rowWord :: Tableau a -> [a] +rowWord = concat . reverse + +-- | /Semistandard/ tableaux can be reconstructed from their row words +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 + +-- | The /column word/ of a tableau is the list of its entry read from the bottom to the top and then from the left to the right +columnWord :: Tableau a -> [a] +columnWord = rowWord . transpose + +-- | /Standard/ tableaux can be reconstructed from either their column or row words +columnWordToTableau :: Ord a => [a] -> Tableau a +columnWordToTableau = transpose . rowWordToTableau + +-- | Checks whether a sequence of positive integers is a /lattice word/, +-- which means that in every initial part of the sequence any number @i@ +-- occurs at least as often as the number @i+1@ +-- +isLatticeWord :: [Int] -> Bool +isLatticeWord = go Map.empty where + go :: Map Int Int -> [Int] -> Bool + go _ [] = True + go !table (i:is) = + if check i + then go table' is + else False + where + table' = Map.insertWith (+) i 1 table + check j = j==1 || cnt (j-1) >= cnt j + cnt j = case Map.lookup j table' of + Just k -> k + Nothing -> 0 + +-------------------------------------------------------------------------------- +-- * Semistandard Young tableaux + +-- | A tableau is /semistandard/ if its entries are weekly increasing horizontally +-- and strictly increasing vertically +isSemiStandardTableau :: Tableau Int -> Bool +isSemiStandardTableau t = weak && strict where + weak = and [ isWeaklyIncreasing xs | xs <- t ] + strict = and [ isStrictlyIncreasing ys | ys <- dt ] + dt = dualTableau t + +-- | Semistandard Young tableaux of given shape, \"naive\" algorithm +semiStandardYoungTableaux :: Int -> Partition -> [Tableau Int] +semiStandardYoungTableaux n part = worker (repeat 0) shape where + shape = fromPartition part + worker _ [] = [[]] + worker prevRow (s:ss) + = [ (r:rs) | r <- row n s 1 prevRow, rs <- worker (map (+1) r) ss ] + + -- weekly increasing lists of length @len@, pointwise at least @xs@, + -- maximum value @n@, minimum value @prev@. + row :: Int -> Int -> Int -> [Int] -> [[Int]] + row _ 0 _ _ = [[]] + row n len prev (x:xs) = [ (a:as) | a <- [max x prev..n] , as <- row n (len-1) a xs ] + +-- | Stanley's hook formula (cf. Fulton page 55) +countSemiStandardYoungTableaux :: Int -> Partition -> Integer +countSemiStandardYoungTableaux n shape = k `div` h where + h = product $ map fromIntegral $ concat $ hookLengths shape + k = product [ fromIntegral (n+j-i) | (i,j) <- elements shape ] + + +-------------------------------------------------------------------------------- +-- * Standard Young tableaux + +-- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@, +-- where @n@ is the weight. +isStandardTableau :: Tableau Int -> Bool +isStandardTableau t = isSemiStandardTableau t && sort (concat t) == [1..n] where + n = sum [ length xs | xs <- t ] + +-- | 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 (hookLengths part) $ -} + factorial n `div` h where + h = product $ map fromIntegral $ concat $ hookLengths part + n = weight part + +-------------------------------------------------------------------------------- + + diff --git a/src/Math/Combinat/Tableaux/GelfandTsetlin.hs b/src/Math/Combinat/Tableaux/GelfandTsetlin.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Tableaux/GelfandTsetlin.hs @@ -0,0 +1,341 @@ + +-- | Gelfand-Tsetlin patterns and Kostka numbers. +-- +-- Gelfand-Tsetlin patterns (or tableaux) are triangular arrays like +-- +-- > [ 3 ] +-- > [ 3 , 2 ] +-- > [ 3 , 1 , 0 ] +-- > [ 2 , 0 , 0 , 0 ] +-- +-- with both rows and columns non-increasing non-negative integers. +-- Note: these are in bijection with the semi-standard Young tableaux. +-- +-- If we add the further restriction that +-- the top diagonal reads @lambda@, +-- and the diagonal sums are partial sums of @mu@, where @lambda@ and @mu@ are two +-- partitions (in this case @lambda=[3,2]@ and @mu=[2,1,1,1]@), +-- then the number of the resulting patterns +-- or tableaux is the Kostka number @K(lambda,mu)@. +-- Actually @mu@ doesn't even need to the be non-increasing. +-- + +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +module Math.Combinat.Tableaux.GelfandTsetlin where + +-------------------------------------------------------------------------------- + +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord + +import Control.Monad +import Control.Monad.Trans.State + +import Data.Map (Map) +import qualified Data.Map as Map + +import Math.Combinat.Partitions.Integer +import Math.Combinat.Tableaux +import Math.Combinat.Helper +import Math.Combinat.ASCII + +-------------------------------------------------------------------------------- +-- * Kostka numbers + +-- | Kostka numbers (via counting Gelfand-Tsetlin patterns). See for example +-- +-- @K(lambda,mu)==0@ unless @lambda@ dominates @mu@: +-- +-- > [ mu | mu <- partitions (weight lam) , kostkaNumber lam mu > 0 ] == dominatedPartitions lam +-- +kostkaNumber :: Partition -> Partition -> Int +kostkaNumber = countKostkaGelfandTsetlinPatterns + +-- | Very naive (and slow) implementation of Kostka numbers, for reference. +kostkaNumberReferenceNaive :: Partition -> Partition -> Int +kostkaNumberReferenceNaive plambda pmu@(Partition mu) = length stuff where + stuff = [ (1::Int) | t <- semiStandardYoungTableaux k plambda , cond t ] + k = length mu + cond t = [ (head xs, length xs) | xs <- group (sort $ concat t) ] == zip [1..] mu + +-------------------------------------------------------------------------------- + +-- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @lambda@: +-- +-- > kostkaNumbersWithGivenLambda lambda == Map.fromList [ (mu , kostkaNumber lambda mu) | mu <- dominatedPartitions lambda ] +-- +-- It's much faster than computing the individual Kostka numbers, but not as fast +-- as it could be. +-- +{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Int #-} +{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Integer #-} +kostkaNumbersWithGivenLambda :: forall coeff. Num coeff => Partition -> Map Partition coeff +kostkaNumbersWithGivenLambda plambda@(Partition lam) = evalState (worker lam) Map.empty where + + worker :: [Int] -> State (Map Partition (Map Partition coeff)) (Map Partition coeff) + worker unlam = case unlam of + [] -> return $ Map.singleton (Partition []) 1 + _ -> do + cache <- get + case Map.lookup (Partition unlam) cache of + Just sol -> return sol + Nothing -> do + let s = foldl' (+) 0 unlam + subsols <- forM (prevLambdas0 unlam) $ \p -> do + sub <- worker p + let t = s - foldl' (+) 0 p + f (Partition xs , c) = case xs of + (y:_) -> if t >= y then Just (Partition (t:xs) , c) else Nothing + [] -> if t > 0 then Just (Partition [t] , c) else Nothing + if t > 0 + then return $ Map.fromList $ mapMaybe f $ Map.toList sub + else return $ Map.empty + + let sol = Map.unionsWith (+) subsols + put $! (Map.insert (Partition unlam) sol cache) + return sol + + -- needs decreasing sequence + prevLambdas0 :: [Int] -> [[Int]] + prevLambdas0 (l:ls) = go l ls where + go b [a] = [ [x] | x <- [a..b] ] ++ [ [x,y] | x <- [a..b] , y<-[1..a] ] + go b (a:as) = [ x:xs | x <- [a..b] , xs <- go a as ] + go b [] = [] : [ [j] | j <- [1..b] ] + prevLambdas0 [] = [] + +-- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @mu@: +-- +-- > kostkaNumbersWithGivenMu mu == Map.fromList [ (lambda , kostkaNumber lambda mu) | lambda <- dominatingPartitions mu ] +-- +-- This function uses the iterated Pieri rule, and is relatively fast. +-- +kostkaNumbersWithGivenMu :: Partition -> Map Partition Int +kostkaNumbersWithGivenMu (Partition mu) = iteratedPieriRule (reverse mu) + +-------------------------------------------------------------------------------- +-- * Gelfand-Tsetlin patterns + +-- | A Gelfand-Tstetlin tableau +type GT = [[Int]] + +asciiGT :: GT -> ASCII +asciiGT gt = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) + $ (map . map) asciiShow + $ gt + +kostkaGelfandTsetlinPatterns :: Partition -> Partition -> [GT] +kostkaGelfandTsetlinPatterns lambda (Partition mu) = kostkaGelfandTsetlinPatterns' lambda mu + +-- | Generates all Kostka-Gelfand-Tsetlin tableau, that is, triangular arrays like +-- +-- > [ 3 ] +-- > [ 3 , 2 ] +-- > [ 3 , 1 , 0 ] +-- > [ 2 , 0 , 0 , 0 ] +-- +-- with both rows and column non-increasing such that +-- the top diagonal read lambda (in this case @lambda=[3,2]@) and the diagonal sums +-- are partial sums of mu (in this case @mu=[2,1,1,1]@) +-- +-- The number of such GT tableaux is the Kostka +-- number K(lambda,mu). +-- +kostkaGelfandTsetlinPatterns' :: Partition -> [Int] -> [GT] +kostkaGelfandTsetlinPatterns' plam@(Partition lambda0) mu0 + | minimum mu0 < 0 = [] + | wlam == 0 = if wmu == 0 then [ [] ] else [] + | wmu == wlam && plam `dominates` pmu = list + | otherwise = [] + where + + pmu = mkPartition mu0 + + nlam = length lambda0 + nmu = length mu0 + + n = max nlam nmu + + lambda = lambda0 ++ replicate (n - nlam) 0 + mu = mu0 ++ replicate (n - nmu ) 0 + + revlam = reverse lambda + + wmu = sum' mu + wlam = sum' lambda + + list = worker + revlam + (scanl1 (+) mu) + (replicate (n-1) 0) + (replicate (n ) 0) + [] + + worker + :: [Int] -- lambda_i in reverse order + -> [Int] -- partial sums of mu + -> [Int] -- sums of the tails of previous rows + -> [Int] -- last row + -> [[Int]] -- the lower part of GT tableau we accumulated so far (this is not needed if we only want to count) + -> [GT] + + worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) table = stuff + where + x0 = smu - a + stuff = concat + [ worker rls smus (zipWith (+) acc (tail row)) (init row) (row:table) + | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda + ] + worker [rl] _ _ _ table = [ [rl]:table ] + worker [] _ _ _ _ = [ [] ] + + boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] + boundedNonIncrSeqs' = go where + go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] + go _ [] _ = [[]] + go _ _ [] = [[]] + +-------------------------------------------------------------------------------- + +-- | This returns the corresponding Kostka number: +-- +-- > countKostkaGelfandTsetlinPatterns lambda mu == length (kostkaGelfandTsetlinPatterns lambda mu) +-- +countKostkaGelfandTsetlinPatterns :: Partition -> Partition -> Int +countKostkaGelfandTsetlinPatterns plam@(Partition lambda0) pmu@(Partition mu0) + | wlam == 0 = if wmu == 0 then 1 else 0 + | wmu == wlam && plam `dominates` pmu = cnt + | otherwise = 0 + where + + nlam = length lambda0 + nmu = length mu0 + + n = max nlam nmu + + lambda = lambda0 ++ replicate (n - nlam) 0 + mu = mu0 ++ replicate (n - nmu ) 0 + + revlam = reverse lambda + + wmu = sum' mu + wlam = sum' lambda + + cnt = worker + revlam + (scanl1 (+) mu) + (replicate (n-1) 0) + (replicate (n ) 0) + + worker + :: [Int] -- lambda_i in reverse order + -> [Int] -- partial sums of mu + -> [Int] -- sums of the tails of previous rows + -> [Int] -- last row + -> Int + + worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) = stuff + where + x0 = smu - a + stuff = sum' + [ worker rls smus (zipWith (+) acc (tail row)) (init row) + | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda + ] + worker [rl] _ _ _ = 1 + worker [] _ _ _ = 1 + + boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] + boundedNonIncrSeqs' = go where + go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] + go _ [] _ = [[]] + go _ _ [] = [[]] + +-------------------------------------------------------------------------------- + +{- + +-- | All non-increasing sentences between a lower and an upper bound +boundedNonIncrSeqs :: [Int] -> [Int] -> [[Int]] +boundedNonIncrSeqs as bs = case bs of + (h0:_) -> boundedNonIncrSeqs' h0 as bs + [] -> [[]] + +-- | All non-increasing sentences between a lower and an upper bound, and also less-or-equal than the given number +boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] +boundedNonIncrSeqs' = go where + go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ] + go _ [] _ = [[]] + go _ _ [] = [[]] + +-- | All non-decreasing sentences between a lower and an upper bound +boundedNonDecrSeqs :: [Int] -> [Int] -> [[Int]] +boundedNonDecrSeqs = boundedNonDecrSeqs' 0 + +-- | All non-decreasing sentences between a lower and an upper bound, and also greator-or-equal then the given number +boundedNonDecrSeqs' :: Int -> [Int] -> [Int] -> [[Int]] +boundedNonDecrSeqs' h0 = go (max 0 h0) where + go h0 (a:as) (b:bs) = [ h:hs | h <- [(max h0 a)..b] , hs <- go h as bs ] + go _ [] _ = [[]] + go _ _ [] = [[]] + +-} + +-------------------------------------------------------------------------------- +-- * The iterated Pieri rule + +-- | Computes the Schur expansion of @h[n1]*h[n2]*h[n3]*...*h[nk]@ via iterating the Pieri rule. +-- Note: the coefficients are actually the Kostka numbers; the following is true: +-- +-- > Map.toList (iteratedPieriRule (fromPartition mu)) == [ (lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ] +-- +-- This should be faster than individually computing all these Kostka numbers. +-- +iteratedPieriRule :: Num coeff => [Int] -> Map Partition coeff +iteratedPieriRule = iteratedPieriRule' (Partition []) + +-- | Iterating the Pieri rule, we can compute the Schur expansion of +-- @h[lambda]*h[n1]*h[n2]*h[n3]*...*h[nk]@ +iteratedPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff +iteratedPieriRule' plambda ns = iteratedPieriRule'' (plambda,1) ns + +{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Int ) -> [Int] -> Map Partition Int #-} +{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-} +iteratedPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff +iteratedPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where + worker old [] = old + worker old (n:ns) = worker new ns where + stuff = [ (coeff, pieriRule lam n) | (lam,coeff) <- Map.toList old ] + new = foldl' f Map.empty stuff + f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps + +-------------------------------------------------------------------------------- + +-- | Computes the Schur expansion of @e[n1]*e[n2]*e[n3]*...*e[nk]@ via iterating the Pieri rule. +-- Note: the coefficients are actually the Kostka numbers; the following is true: +-- +-- > Map.toList (iteratedDualPieriRule (fromPartition mu)) == +-- > [ (dualPartition lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ] +-- +-- This should be faster than individually computing all these Kostka numbers. +-- It is a tiny bit slower than 'iteratedPieriRule'. +-- +iteratedDualPieriRule :: Num coeff => [Int] -> Map Partition coeff +iteratedDualPieriRule = iteratedDualPieriRule' (Partition []) + +-- | Iterating the Pieri rule, we can compute the Schur expansion of +-- @e[lambda]*e[n1]*e[n2]*e[n3]*...*e[nk]@ +iteratedDualPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff +iteratedDualPieriRule' plambda ns = iteratedDualPieriRule'' (plambda,1) ns + +{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Int ) -> [Int] -> Map Partition Int #-} +{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-} +iteratedDualPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff +iteratedDualPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where + worker old [] = old + worker old (n:ns) = worker new ns where + stuff = [ (coeff, dualPieriRule lam n) | (lam,coeff) <- Map.toList old ] + new = foldl' f Map.empty stuff + f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs b/src/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs @@ -0,0 +1,261 @@ + +-- TODO: better name? + +-- | This module contains a function to generate (equivalence classes of) +-- triangular tableaux of size /k/, strictly increasing to the right and +-- to the bottom. For example +-- +-- > 1 +-- > 2 4 +-- > 3 5 8 +-- > 6 7 9 10 +-- +-- is such a tableau of size 4. +-- The numbers filling a tableau always consist of an interval @[1..c]@; +-- @c@ is called the /content/ of the tableaux. There is a unique tableau +-- of minimal content @2k-1@: +-- +-- > 1 +-- > 2 3 +-- > 3 4 5 +-- > 4 5 6 7 +-- +-- Let us call the tableaux with maximal content (that is, @m = binomial (k+1) 2@) +-- /standard/. The number of such standard tableaux are +-- +-- > 1, 1, 2, 12, 286, 33592, 23178480, ... +-- +-- OEIS:A003121, \"Strict sense ballot numbers\", +-- . +-- +-- See +-- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88. +-- +-- The number of tableaux with content @c=m-d@ are +-- +-- > d= | 0 1 2 3 ... +-- > -----+---------------------------------------------- +-- > k=2 | 1 +-- > k=3 | 2 1 +-- > k=4 | 12 18 8 1 +-- > k=5 | 286 858 1001 572 165 22 1 +-- > k=6 | 33592 167960 361114 436696 326196 155584 47320 8892 962 52 1 +-- +-- We call these \"GT simplex tableaux\" (in the lack of a better name), since +-- they are in bijection with the simplicial cones in a canonical simplicial +-- decompositions of the Gelfand-Tsetlin cones (the content corresponds +-- to the dimension), which encode the combinatorics of Kostka numbers. +-- + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Math.Combinat.Tableaux.GelfandTsetlin.Cone + ( + -- * Types + Tableau + , Tri(..) + , TriangularArray + , fromTriangularArray + , triangularArrayUnsafe + -- * ASCII + , asciiTriangularArray + , asciiTableau + -- * Content + , gtSimplexContent + , _gtSimplexContent + , invertGTSimplexTableau + , _invertGTSimplexTableau + -- * Enumeration + , gtSimplexTableaux + , _gtSimplexTableaux + , countGTSimplexTableaux + ) + where + +-------------------------------------------------------------------------------- + +import Data.Ix +import Data.Ord +import Data.List + +import Control.Monad +import Control.Monad.ST +import Data.Array.IArray +import Data.Array.Unboxed +import Data.Array.ST + +import Math.Combinat.Tableaux (Tableau) +import Math.Combinat.Helper +import Math.Combinat.ASCII + +-------------------------------------------------------------------------------- + +-- | Triangular arrays +type TriangularArray a = Array Tri a + +-- | Set of @(i,j)@ pairs with @i>=j>=1@. +newtype Tri = Tri { unTri :: (Int,Int) } deriving (Eq,Ord,Show) + +binom2 :: Int -> Int +binom2 n = (n*(n-1)) `div` 2 + +index' :: Tri -> Int +index' (Tri (i,j)) = binom2 i + j - 1 + +-- it should be (1+8*m), +-- the 2 is a hack to be safe with the floating point stuff +deIndex' :: Int -> Tri +deIndex' m = Tri ( i+1 , m - binom2 (i+1) + 1 ) where + i = ( (floor.sqrt.(fromIntegral::Int->Double)) (2+8*m) - 1 ) `div` 2 + +instance Ix Tri where + index (a,b) x = index' x - index' a + inRange (a,b) x = (u<=j && j<=v) where + u = index' a + v = index' b + j = index' x + range (a,b) = map deIndex' [ index' a .. index' b ] + rangeSize (a,b) = index' b - index' a + 1 + +triangularArrayUnsafe :: Tableau a -> TriangularArray a +triangularArrayUnsafe tableau = listArray (Tri (1,1),Tri (k,k)) (concat tableau) + where k = length tableau + +fromTriangularArray :: TriangularArray a -> Tableau a +fromTriangularArray arr = (map.map) snd $ groupBy (equating f) $ assocs arr + where f = fst . unTri . fst + +-------------------------------------------------------------------------------- + +asciiTriangularArray :: Show a => TriangularArray a -> ASCII +asciiTriangularArray = asciiTableau . fromTriangularArray + +asciiTableau :: Show a => Tableau a -> ASCII +asciiTableau xxs = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) + $ (map . map) asciiShow + $ xxs + +instance Show a => DrawASCII (TriangularArray a) where + ascii = asciiTriangularArray + +-- instance Show a => DrawASCII (Tableau a) where +-- ascii = asciiTableau + +-------------------------------------------------------------------------------- + +-- "fractional fillings" +data Hole = Hole Int Int deriving (Eq,Ord,Show) + +type ReverseTableau = [[Int ]] +type ReverseHoleTableau = [[Hole]] + +toHole :: Int -> Hole +toHole k = Hole k 0 + +nextHole :: Hole -> Hole +nextHole (Hole k l) = Hole k (l+1) + +reverseTableau :: [[a]] -> [[a]] +reverseTableau = reverse . map reverse + +-------------------------------------------------------------------------------- + +gtSimplexContent :: TriangularArray Int -> Int +gtSimplexContent arr = max (arr ! (fst (bounds arr))) (arr ! (snd (bounds arr))) -- we also handle inverted tableau + +_gtSimplexContent :: Tableau Int -> Int +_gtSimplexContent t = max (head $ head t) (last $ last t) -- we also handle inverted tableau + +normalize :: ReverseHoleTableau -> TriangularArray Int +normalize = snd . normalize' + +-- returns ( content , tableau ) +normalize' :: ReverseHoleTableau -> ( Int , TriangularArray Int ) +normalize' holes = ( c , array (Tri (1,1), Tri (k,k)) xys ) where + k = length holes + c = length sorted + xys = concat $ zipWith hs [1..] sorted + hs a xs = map (h a) xs + h a (ij,_) = (Tri ij , a) + sorted = groupSortBy snd (concat withPos) + withPos = zipWith f [1..] (reverseTableau holes) + f i xs = zipWith (g i) [1..] xs + g i j hole = ((i,j),hole) + +-------------------------------------------------------------------------------- + +startHole :: [Hole] -> [Int] -> Hole +startHole (t:ts) (p:ps) = max t (toHole p) +startHole (t:ts) [] = t +startHole [] (p:ps) = toHole p +startHole [] [] = error "startHole" + +-- c is the "content" of the small tableau +enumHoles :: Int -> Hole -> [Hole] +enumHoles c start@(Hole k l) + = nextHole start + : [ Hole i 0 | i <- [k+1..c] ] ++ [ Hole i 1 | i <- [k+1..c] ] + +helper :: Int -> [Int] -> [Hole] -> [[Hole]] +helper c [] this = [[]] +helper c prev@(p:ps) this = + [ t:rest | t <- enumHoles c (startHole this prev), rest <- helper c ps (t:this) ] + +newLines' :: Int -> [Int] -> [[Hole]] +newLines' c lastReversed = helper c last [] + where + top = head lastReversed + last = reverse (top : lastReversed) + +newLines :: [Int] -> [[Hole]] +newLines lastReversed = newLines' (head lastReversed) lastReversed + +-- | Generates all tableaux of size @k@. Effective for @k<=6@. +gtSimplexTableaux :: Int -> [TriangularArray Int] +gtSimplexTableaux 0 = [ triangularArrayUnsafe [] ] +gtSimplexTableaux 1 = [ triangularArrayUnsafe [[1]] ] +gtSimplexTableaux k = map normalize $ concatMap f smalls where + smalls :: [ [[Int]] ] + smalls = map (reverseTableau . fromTriangularArray) $ gtSimplexTableaux (k-1) + f :: [[Int]] -> [ [[Hole]] ] + f small = map (:smallhole) $ map reverse $ newLines (head small) where + smallhole = map (map toHole) small + +_gtSimplexTableaux :: Int -> [Tableau Int] +_gtSimplexTableaux k = map fromTriangularArray $ gtSimplexTableaux k + +-------------------------------------------------------------------------------- + +-- | Note: This is slow (it actually generates all the tableaux) +countGTSimplexTableaux :: Int -> [Int] +countGTSimplexTableaux = elems . sizes' + +sizes' :: Int -> UArray Int Int +sizes' k = + runSTUArray $ do + let (a,b) = ( 2*k-1 , binom2 (k+1) ) + ar <- newArray (a,b) 0 :: ST s (STUArray s Int Int) + mapM_ (worker ar) $ gtSimplexTableaux k + return ar + where + worker :: STUArray s Int Int -> TriangularArray Int -> ST s () + worker ar t = do + let c = gtSimplexContent t + n <- readArray ar c + writeArray ar c (n+1) + +-------------------------------------------------------------------------------- + +-- | We can flip the numbers in the tableau so that the interval @[1..c]@ becomes +-- @[c..1]@. This way we a get a maybe more familiar form, when each row and each +-- column is strictly /decreasing/ (to the right and to the bottom). +invertGTSimplexTableau :: TriangularArray Int -> TriangularArray Int +invertGTSimplexTableau t = amap f t where + c = gtSimplexContent t + f x = c+1-x + +_invertGTSimplexTableau :: [[Int]] -> [[Int]] +_invertGTSimplexTableau t = (map . map) f t where + c = _gtSimplexContent t + f x = c+1-x + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Tableaux/LittlewoodRichardson.hs b/src/Math/Combinat/Tableaux/LittlewoodRichardson.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Tableaux/LittlewoodRichardson.hs @@ -0,0 +1,399 @@ + +-- | The Littlewood-Richardson rule + +module Math.Combinat.Tableaux.LittlewoodRichardson + ( lrCoeff , lrCoeff' + , lrMult + , lrRule , _lrRule , lrRuleNaive + , lrScalar , _lrScalar + ) + where + +-------------------------------------------------------------------------------- + +import Data.List +import Data.Maybe + +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Skew +import Math.Combinat.Tableaux +import Math.Combinat.Tableaux.Skew +import Math.Combinat.Helper + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- + +-- | Naive (very slow) reference implementation of the Littlewood-Richardson rule, based +-- on the definition "count the semistandard skew tableaux whose row content is a lattice word" +-- +lrRuleNaive :: SkewPartition -> Map Partition Int +lrRuleNaive skew = final where + n = skewPartitionWeight skew + ssst = semiStandardSkewTableaux n skew + final = foldl' f Map.empty $ catMaybes [ skewTableauRowContent skew | skew <- ssst ] + f old nu = Map.insertWith (+) nu 1 old + +-------------------------------------------------------------------------------- +-- SKEW EXPANSION + +-- | @lrRule@ computes the expansion of a skew Schur function +-- @s[lambda\/mu]@ via the Littlewood-Richardson rule. +-- +-- Adapted from John Stembridge's Maple code: +-- +-- +-- > lrRule (mkSkewPartition (lambda,nu)) == Map.fromList list where +-- > muw = weight lambda - weight nu +-- > list = [ (mu, coeff) +-- > | mu <- partitions muw +-- > , let coeff = lrCoeff lambda (mu,nu) +-- > , coeff /= 0 +-- > ] +-- +lrRule :: SkewPartition -> Map Partition Int +lrRule skew = _lrRule lam mu where + (lam,mu) = fromSkewPartition skew + +-- | @_lrRule lambda mu@ computes the expansion of the skew +-- Schur function @s[lambda\/mu]@ via the Littlewood-Richardson rule. +-- +_lrRule :: Partition -> Partition -> Map Partition Int +_lrRule plam@(Partition lam) pmu@(Partition mu0) = + if not (pmu `isSubPartitionOf` plam) + then Map.empty + else foldl' f Map.empty [ nu | (nu,_) <- fillings n diagram ] + where + f old nu = Map.insertWith (+) (Partition nu) 1 old + diagram = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ] + mu = mu0 ++ repeat 0 + n = sum' $ zipWith (-) lam mu -- n == length diagram + +{- +LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm; + if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi; + l:=nops(lambda); mu:=[op(args[2]),0$l]; + dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)]; + if nargs>2 then alpha:=args[3]; + if nargs>3 then beta:=args[4] else beta:=[] fi; + if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi; + l:=convert([op(lambda),op(beta)],`+`); + if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi; + nops(LR_fillings(dgrm,[alpha,beta])) + else + convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`) + fi +end; +-} + +-------------------------------------------------------------------------------- + +-- | A filling is a pair consisting a shape @nu@ and a lattice permutation @lp@ +type Filling = ( [Int] , [Int] ) + +-- | A diagram is a set of boxes in a skew shape (in the right order) +type Diagram = [ (Int,Int) ] + +-- | Note: we use reverse ordering in Diagrams compared the Stembridge's code. +-- Also, for performance reasons, we need the length of the diagram +fillings :: Int -> Diagram -> [Filling] +fillings _ [] = [ ([],[]) ] +fillings n diagram@((x,y):rest) = concatMap (nextLetter lower upper) (fillings (n-1) rest) where + upper = case findIndex (==(x ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 } + lower = case findIndex (==(x-1,y )) diagram of { Just j -> n-j ; Nothing -> 0 } + +{- +LR_fillings:=proc(dgrm) local n,x,upper,lower; + if dgrm=[] then + if nargs=1 then x:=[] else x:=args[2][2] fi; + RETURN([[x,[]]]) + fi; + n:=nops(dgrm); x:=dgrm[n]; + if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi; + if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi; + if nargs=1 then + map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper) + else + map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]), + lower,upper,args[2][1]) + fi; +end: +-} + +-------------------------------------------------------------------------------- + +nextLetter :: Int -> Int -> Filling -> [Filling] +nextLetter lower upper (nu,lpart) = stuff where + stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] + shape = nu ++ [0] + lb = if lower>0 + then lpart !! (lower-1) + else 0 + ub = if upper>0 + then min (length shape) (lpart !! (upper-1)) + else length shape + + nlist = filter (>0) $ map f [lb+1..ub] + f j = if j==1 || shape!!(j-2) > shape!!(j-1) then j else 0 + +{- + -- another nlist implementation, but doesn't seem to be faster + (h0:hs0) = drop lb (-666:shape) + nlist = go h0 hs0 [lb+1..ub] where + go !lasth (h:hs) (j:js) = if j==1 || lasth > h + then j : go h hs js + else go h hs js + go _ _ [] = [] +-} + + -- increments the i-th element (starting from 1) + incr :: Int -> [Int] -> [Int] + incr i (x:xs) = case i of + 0 -> finish (x:xs) + 1 -> (x+1) : finish xs + _ -> x : incr (i-1) xs + incr _ [] = [] + + -- removes tailing zeros + finish :: [Int] -> [Int] + finish (x:xs) = if x>0 then x : finish xs else [] + finish [] = [] + +{- +`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl; + shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape); + if nargs>3 then ub:=min(ub,nops(args[4])) fi; + if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi; + if args[3]>0 then ub:=min(lp[args[3]],ub) fi; + if nargs<4 then + nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape) + else + nl:=map(proc(x,y,z) if y[x]y[x]) then x fi end, + [$lb+1..ub],shape,args[4]) + fi; + nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)]; + op(subs(0=NULL,nl)) +end: +-} + +-------------------------------------------------------------------------------- +-- COEFF + +-- | @lrCoeff lam (mu,nu)@ computes the coressponding Littlewood-Richardson coefficients. +-- This is also the coefficient of @s[lambda]@ in the product @s[mu]*s[nu]@ +-- +-- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients +-- at the same time! +lrCoeff :: Partition -> (Partition,Partition) -> Int +lrCoeff lam (mu,nu) = + if nu `isSubPartitionOf` lam + then lrScalar (mkSkewPartition (lam,nu)) (mkSkewPartition (mu,emptyPartition)) + else 0 + +-- | @lrCoeff (lam\/nu) mu@ computes the coressponding Littlewood-Richardson coefficients. +-- This is also the coefficient of @s[mu]@ in the product @s[lam\/nu]@ +-- +-- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients +-- at the same time! +lrCoeff' :: SkewPartition -> Partition -> Int +lrCoeff' skew p = lrScalar skew (mkSkewPartition (p,emptyPartition)) + +-------------------------------------------------------------------------------- +-- SCALAR PRODUCT + +-- | @lrScalar (lambda\/mu) (alpha\/beta)@ computes the scalar product of the two skew +-- Schur functions @s[lambda\/mu]@ and @s[alpha\/beta]@ via the Littlewood-Richardson rule. +-- +-- Adapted from John Stembridge Maple code: +-- +-- +lrScalar :: SkewPartition -> SkewPartition -> Int +lrScalar lambdaMu alphaBeta = _lrScalar (fromSkewPartition lambdaMu) (fromSkewPartition alphaBeta) + +_lrScalar :: (Partition,Partition) -> (Partition,Partition) -> Int +_lrScalar ( plam@( Partition lam ) , pmu@( Partition mu0 ) ) + ( palpha@(Partition alpha) , pbeta@(Partition beta) ) = + if not (pmu `isSubPartitionOf` plam ) + || not (pbeta `isSubPartitionOf` palpha) + || (sum' lam + sum' beta) /= (sum' alpha + sum' mu0) -- equivalent to (lambda-mu) /= (alpha-beta) + then 0 + else length $ fillings' n diagram (alpha,beta) + where + f old nu = Map.insertWith (+) (Partition nu) 1 old + diagram = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ] + mu = mu0 ++ repeat 0 + n = sum' $ zipWith (-) lam mu -- n == length diagram + +{- +LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm; + if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi; + l:=nops(lambda); mu:=[op(args[2]),0$l]; + dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)]; + if nargs>2 then alpha:=args[3]; + if nargs>3 then beta:=args[4] else beta:=[] fi; + if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi; + l:=convert([op(lambda),op(beta)],`+`); + if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi; + nops(LR_fillings(dgrm,[alpha,beta])) + else + convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`) + fi +end; +-} + +-------------------------------------------------------------------------------- + +-- | Note: we use reverse ordering in Diagrams compared the Stembridge's code. +-- Also, for performance reasons, we need the length of the diagram +fillings' :: Int -> Diagram -> ([Int],[Int]) -> [Filling] +fillings' _ [] (alpha,beta) = [ (beta,[]) ] +fillings' n diagram@((x,y):rest) alphaBeta@(alpha,beta) = stuff where + stuff = concatMap (nextLetter' lower upper alpha) (fillings' (n-1) rest alphaBeta) + upper = case findIndex (==(x ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 } + lower = case findIndex (==(x-1,y )) diagram of { Just j -> n-j ; Nothing -> 0 } + +{- +LR_fillings:=proc(dgrm) local n,x,upper,lower; + if dgrm=[] then + if nargs=1 then x:=[] else x:=args[2][2] fi; + RETURN([[x,[]]]) + fi; + n:=nops(dgrm); x:=dgrm[n]; + if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi; + if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi; + if nargs=1 then + map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper) + else + map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]), + lower,upper,args[2][1]) + fi; +end: +-} + +-------------------------------------------------------------------------------- + +nextLetter' :: Int -> Int -> [Int] -> Filling -> [Filling] +nextLetter' lower upper alpha (nu,lpart) = stuff where + stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] + shape = nu ++ [0] + lb = if lower>0 + then lpart !! (lower-1) + else 0 + ub1 = if upper>0 + then min (length shape) (lpart !! (upper-1)) + else length shape + ub = min (length alpha) ub1 + nlist = filter (>0) $ map f [lb+1..ub] + f j = if ( shape!!(j-1) < alpha!!(j-1)) && + (j==1 || shape!!(j-2) > shape!!(j-1)) + then j + else 0 + + -- increments the i-th element (starting from 1) + incr :: Int -> [Int] -> [Int] + incr i (x:xs) = case i of + 0 -> finish (x:xs) + 1 -> (x+1) : finish xs + _ -> x : incr (i-1) xs + incr _ [] = [] + + -- removes tailing zeros + finish :: [Int] -> [Int] + finish (x:xs) = if x>0 then x : finish xs else [] + finish [] = [] + +{- +`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl; + shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape); + if nargs>3 then ub:=min(ub,nops(args[4])) fi; + if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi; + if args[3]>0 then ub:=min(lp[args[3]],ub) fi; + if nargs<4 then + nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape) + else + nl:=map(proc(x,y,z) if y[x]y[x]) then x fi end, + [$lb+1..ub],shape,args[4]) + fi; + nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)]; + op(subs(0=NULL,nl)) +end: +-} + +-------------------------------------------------------------------------------- +-- MULTIPLICATION + +type Part = [Int] + +-- | Computes the expansion of the product of Schur polynomials @s[mu]*s[nu]@ using the +-- Littlewood-Richardson rule. Note: this is symmetric in the two arguments. +-- +-- Based on the wikipedia article +-- +-- > lrMult mu nu == Map.fromList list where +-- > lamw = weight nu + weight mu +-- > list = [ (lambda, coeff) +-- > | lambda <- partitions lamw +-- > , let coeff = lrCoeff lambda (mu,nu) +-- > , coeff /= 0 +-- > ] +-- +lrMult :: Partition -> Partition -> Map Partition Int +lrMult pmu@(Partition mu) pnu@(Partition nu) = result where + result = foldl' add Map.empty (addMu mu nu) where + add !old lambda = Map.insertWith (+) (Partition lambda) 1 old + +-- | This basically lists all the outer shapes (with multiplicities) which can be result from the LR rule +addMu :: Part -> Part -> [Part] +addMu mu part = go ubs0 mu dmu part where + + go _ [] _ part = [part] + go ubs (m:ms) (d:ds) part = concat [ go (drop d ubs') ms ds part' | (ubs',part') <- addRowOf ubs part ] + + ubs0 = take (headOrZero mu) [headOrZero part + 1..] + dmu = diffSeq mu + + +-- | Adds a full row of @(length pcols)@ boxes containing to a partition, with +-- pcols being the upper bounds of the columns, respectively. We also return the +-- newly added columns +addRowOf :: [Int] -> Part -> [([Int],Part)] +addRowOf pcols part = go 0 pcols part [] where + go !lb [] p ncols = [(reverse ncols , p)] + go !lb (!ub:ubs) p ncols = concat [ go col ubs (addBox ij p) (col:ncols) | ij@(row,col) <- newBoxes (lb+1) ub p ] + +-- | Returns the (row,column) pairs of the new boxes which +-- can be added to the given partition with the given column bounds +-- and the 1-Rieri rule +newBoxes :: Int -> Int -> Part -> [(Int,Int)] +newBoxes lb ub part = reverse $ go [1..] part (headOrZero part + 1) where + go (!i:_ ) [] !lp + | lb <= 1 && 1 <= ub && lp > 0 = [(i,1)] + | otherwise = [] + go (!i:is) (!j:js) !lp + | j1 < lb = [] + | j1 <= ub && lp > j = (i,j1) : go is js j + | otherwise = go is js j + where + j1 = j+1 + +-- | Adds a box to a partition +addBox :: (Int,Int) -> Part -> Part +addBox (k,_) part = go 1 part where + go !i (p:ps) = if i==k then (p+1):ps else p : go (i+1) ps + go !i [] = if i==k then [1] else error "addBox: shouldn't happen" + +-- | Safe head defaulting to zero +headOrZero :: [Int] -> Int +headOrZero xs = case xs of + (!x:_) -> x + [] -> 0 + +-- | Computes the sequence of differences from a partition (including the last difference to zero) +diffSeq :: Part -> [Int] +diffSeq = go where + go (p:ps@(q:_)) = (p-q) : go ps + go [p] = [p] + go [] = [] + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Tableaux/Skew.hs b/src/Math/Combinat/Tableaux/Skew.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Tableaux/Skew.hs @@ -0,0 +1,224 @@ + +-- | Skew tableaux are skew partitions filled with numbers. +-- +-- For example: +-- +-- <> +-- + +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, MultiParamTypeClasses #-} + +module Math.Combinat.Tableaux.Skew where + +-------------------------------------------------------------------------------- + +import Data.List + +import Math.Combinat.Classes +import Math.Combinat.Partitions.Integer +import Math.Combinat.Partitions.Integer.IntList ( _diffSequence ) +import Math.Combinat.Partitions.Skew +import Math.Combinat.Tableaux +import Math.Combinat.ASCII +import Math.Combinat.Helper + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- +-- * Basics +-- | A skew tableau is represented by a list of offsets and entries +newtype SkewTableau a = SkewTableau [(Int,[a])] deriving (Eq,Ord,Show) + +-- unSkewTableau :: SkewTableau a -> [(Int,[a])] +-- unSkewTableau (SkewTableau a) = a + +instance Functor SkewTableau where + fmap f (SkewTableau t) = SkewTableau [ (a, map f xs) | (a,xs) <- t ] + +-- | The shape of a skew tableau +skewTableauShape :: SkewTableau a -> SkewPartition +skewTableauShape (SkewTableau list) = SkewPartition [ (o,length xs) | (o,xs) <- list ] + +instance HasShape (SkewTableau a) SkewPartition where + shape = skewTableauShape + +-- | The weight of a tableau is the weight of its shape, or the number of entries +skewTableauWeight :: SkewTableau a -> Int +skewTableauWeight = skewPartitionWeight . skewTableauShape + +instance HasWeight (SkewTableau a) where + weight = skewTableauWeight + +-------------------------------------------------------------------------------- + +-- | The dual of a skew tableau, that is, its mirror image to the main diagonal +dualSkewTableau :: forall a. SkewTableau a -> SkewTableau a +dualSkewTableau (SkewTableau axs) = SkewTableau (go axs) where + + go [] = [] + go axs = case sub 0 axs of + (0,[]) -> [] + this -> this : go (strip axs) + + strip :: [(Int,[a])] -> [(Int,[a])] + strip [] = [] + strip ((a,xs):rest) = if a>0 + then (a-1,xs) : strip rest + else case xs of + [] -> [] + (z:zs) -> case zs of + [] -> [] + _ -> (0,zs) : strip rest + + sub :: Int -> [(Int,[a])] -> (Int,[a]) + sub !b [] = (b,[]) + sub !b ((a,this):rest) = if a>0 + then sub (b+1) rest + else (b,ys) where + ys = map head $ takeWhile (not . null) (this : map snd rest) + +{- +test_dualSkewTableau :: [SkewTableau Int] +test_dualSkewTableau = bad where + ps = allPartitions 11 + bad = [ st + | p<-ps , q<-ps + , (q `isSubPartitionOf` p) + , let sp = mkSkewPartition (p,q) + , let st = fillSkewPartitionWithRowWord sp [1..] + , dualSkewTableau (dualSkewTableau st) /= st + ] +-} + +instance HasDuality (SkewTableau a) where + dual = dualSkewTableau + +-------------------------------------------------------------------------------- +-- * Semistandard tableau + +-- | A tableau is /semistandard/ if its entries are weekly increasing horizontally +-- and strictly increasing vertically +isSemiStandardSkewTableau :: SkewTableau Int -> Bool +isSemiStandardSkewTableau st@(SkewTableau axs) = weak && strict where + weak = and [ isWeaklyIncreasing xs | (a,xs) <- axs ] + strict = and [ isStrictlyIncreasing ys | (b,ys) <- bys ] + SkewTableau bys = dualSkewTableau st + +-- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@, +-- where @n@ is the weight. +isStandardSkewTableau :: SkewTableau Int -> Bool +isStandardSkewTableau st = isSemiStandardSkewTableau st && sort (skewTableauRowWord st) == [1..n] where + n = skewTableauWeight st + +-------------------------------------------------------------------------------- + +-- | All semi-standard skew tableaux filled with the numbers @[1..n]@ +semiStandardSkewTableaux :: Int -> SkewPartition -> [SkewTableau Int] +semiStandardSkewTableaux n (SkewPartition abs) = map SkewTableau stuff where + + stuff = worker as bs ds (repeat 1) + (as,bs) = unzip abs + ds = _diffSequence as + + -- | @worker inner outerMinusInner innerdiffs lowerbound + worker :: [Int] -> [Int] -> [Int] -> [Int] -> [[(Int,[Int])]] + worker (a:as) (b:bs) (d:ds) lb = [ (a,this):rest + | this <- row b 1 lb + , let lb' = (replicate d 1 ++ map (+1) this) + , rest <- worker as bs ds lb' ] + worker [] _ _ _ = [ [] ] + + -- @row length minimum lowerbound@ + row 0 _ _ = [[]] + row _ _ [] = [] + row !k !m (!a:as) = [ x:xs | x <- [(max a m)..n] , xs <- row (k-1) x as ] + +{- +-- | from a sequence @[a1,a2,..,an]@ computes the sequence of differences +-- @[a1-a2,a2-a3,...,an-0]@ +diffSequence :: [Int] -> [Int] +diffSequence = go where + go (x:ys@(y:_)) = (x-y) : go ys + go [x] = [x] + go [] = [] +-} + +-------------------------------------------------------------------------------- +-- * ASCII + +-- | ASCII drawing of a skew tableau (using the English notation) +asciiSkewTableau :: Show a => SkewTableau a -> ASCII +asciiSkewTableau = asciiSkewTableau' "." EnglishNotation + +asciiSkewTableau' + :: Show a + => String -- ^ string representing the elements of the inner (unfilled) partition + -> PartitionConvention -- ^ orientation + -> SkewTableau a + -> ASCII +asciiSkewTableau' innerstr orient (SkewTableau axs) = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) stuff where + stuff = case orient of + EnglishNotation -> es + EnglishNotationCCW -> reverse (transpose es) + FrenchNotation -> reverse es + inner = asciiFromString innerstr + es = [ replicate a inner ++ map asciiShow xs | (a,xs) <- axs ] + +instance Show a => DrawASCII (SkewTableau a) where + ascii = asciiSkewTableau + +-------------------------------------------------------------------------------- +-- * Row \/ column words + +-- | The reversed (right-to-left) rows, concatenated +skewTableauRowWord :: SkewTableau a -> [a] +skewTableauRowWord (SkewTableau axs) = concatMap (reverse . snd) axs + +-- | The reversed (bottom-to-top) columns, concatenated +skewTableauColumnWord :: SkewTableau a -> [a] +skewTableauColumnWord = skewTableauRowWord . dualSkewTableau + +-- | Fills a skew partition with content, in row word order +fillSkewPartitionWithRowWord :: SkewPartition -> [a] -> SkewTableau a +fillSkewPartitionWithRowWord (SkewPartition abs) xs = SkewTableau $ go abs xs where + go ((b,a):rest) xs = let (ys,zs) = splitAt a xs in (b,reverse ys) : go rest zs + go [] xs = [] + +-- | Fills a skew partition with content, in column word order +fillSkewPartitionWithColumnWord :: SkewPartition -> [a] -> SkewTableau a +fillSkewPartitionWithColumnWord shape content + = dualSkewTableau + $ fillSkewPartitionWithRowWord (dualSkewPartition shape) content + +-------------------------------------------------------------------------------- + +-- | If the skew tableau's row word is a lattice word, we can make a partition from its content +skewTableauRowContent :: SkewTableau Int -> Maybe Partition +skewTableauRowContent (SkewTableau axs) = go Map.empty rowword where + + rowword = concatMap (reverse . snd) axs + + finish table = Partition (f 1) where + f !i = case lkp i of + 0 -> [] + y -> y : f (i+1) + lkp j = case Map.lookup j table of + Just k -> k + Nothing -> 0 + + go :: Map Int Int -> [Int] -> Maybe Partition + go !table [] = Just (finish table) + go !table (i:is) = + if check i + then go table' is + else Nothing + where + table' = Map.insertWith (+) i 1 table + check j = j==1 || cnt (j-1) >= cnt j + cnt j = case Map.lookup j table' of + Just k -> k + Nothing -> 0 + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Trees.hs b/src/Math/Combinat/Trees.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Trees.hs @@ -0,0 +1,9 @@ + +module Math.Combinat.Trees + ( module Math.Combinat.Trees.Binary + , module Math.Combinat.Trees.Nary + ) where + +import Math.Combinat.Trees.Binary +import Math.Combinat.Trees.Nary + diff --git a/src/Math/Combinat/Trees/Binary.hs b/src/Math/Combinat/Trees/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Trees/Binary.hs @@ -0,0 +1,492 @@ + +-- | 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: +-- +-- <> +-- + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Math.Combinat.Trees.Binary + ( -- * Types + BinTree(..) + , leaf + , graft + , BinTree'(..) + , forgetNodeDecorations + , Paren(..) + , parenthesesToString + , stringToParentheses + , numberOfNodes + , numberOfLeaves + -- * Conversion to rose trees (@Data.Tree@) + , toRoseTree , toRoseTree' + , module Data.Tree + -- * Enumerate leaves + , enumerateLeaves_ + , enumerateLeaves + , enumerateLeaves' + -- * Nested parentheses + , nestedParentheses + , randomNestedParentheses + , nthNestedParentheses + , countNestedParentheses + , fasc4A_algorithm_P + , fasc4A_algorithm_W + , fasc4A_algorithm_U + -- * Generating binary trees + , binaryTrees + , countBinaryTrees + , binaryTreesNaive + , randomBinaryTree + , fasc4A_algorithm_R + -- * ASCII drawing + , asciiBinaryTree_ + -- * Graphviz drawing + , Dot + , graphvizDotBinTree + , graphvizDotBinTree' + , graphvizDotForest + , graphvizDotTree + -- * Bijections + , forestToNestedParentheses + , forestToBinaryTree + , nestedParenthesesToForest + , nestedParenthesesToForestUnsafe + , nestedParenthesesToBinaryTree + , nestedParenthesesToBinaryTreeUnsafe + , binaryTreeToForest + , binaryTreeToNestedParentheses + ) + where + +-------------------------------------------------------------------------------- + +import Control.Applicative +import Control.Monad +import Control.Monad.ST + +import Data.Array +import Data.Array.ST +import Data.Array.Unsafe + +import Data.List +import Data.Tree (Tree(..),Forest(..)) + +import Data.Monoid +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +import System.Random + +import Math.Combinat.Numbers (factorial,binomial) + +import Math.Combinat.Trees.Graphviz + ( Dot + , graphvizDotBinTree , graphvizDotBinTree' + , graphvizDotForest , graphvizDotTree + ) +import Math.Combinat.Classes +import Math.Combinat.Helper +import Math.Combinat.ASCII as ASCII + +-------------------------------------------------------------------------------- +-- * Types + +-- | A binary tree with leaves decorated with type @a@. +data BinTree a + = Branch (BinTree a) (BinTree a) + | Leaf a + deriving (Eq,Ord,Show,Read) + +leaf :: BinTree () +leaf = Leaf () + +-- | The monadic join operation of binary trees +graft :: BinTree (BinTree a) -> BinTree a +graft = go where + go (Branch l r) = Branch (go l) (go r) + go (Leaf t ) = t + +-------------------------------------------------------------------------------- + +-- | A binary tree with leaves and internal nodes decorated +-- with types @a@ and @b@, respectively. +data BinTree' a b + = Branch' (BinTree' a b) b (BinTree' a b) + | Leaf' a + deriving (Eq,Ord,Show,Read) + +forgetNodeDecorations :: BinTree' a b -> BinTree a +forgetNodeDecorations = go where + go (Branch' left _ right) = Branch (go left) (go right) + go (Leaf' decor ) = Leaf decor + +-------------------------------------------------------------------------------- + +instance HasNumberOfNodes (BinTree a) where + numberOfNodes = go where + go (Leaf _ ) = 0 + go (Branch l r) = go l + go r + 1 + +instance HasNumberOfLeaves (BinTree a) where + numberOfLeaves = go where + go (Leaf _ ) = 1 + go (Branch l r) = go l + go r + + +instance HasNumberOfNodes (BinTree' a b) where + numberOfNodes = go where + go (Leaf' _ ) = 0 + go (Branch' l _ r) = go l + go r + 1 + +instance HasNumberOfLeaves (BinTree' a b) where + numberOfLeaves = go where + go (Leaf' _ ) = 1 + go (Branch' l _ r) = go l + go r + +-------------------------------------------------------------------------------- +-- * Enumerate leaves + +-- | Enumerates the leaves a tree, starting from 0, ignoring old labels +enumerateLeaves_ :: BinTree a -> BinTree Int +enumerateLeaves_ = snd . go 0 where + go !k t = case t of + Leaf _ -> (k+1 , Leaf k) + Branch l r -> (k'', Branch l' r') where + (k' ,l') = go k l + (k'',r') = go k' r + +-- | Enumerates the leaves a tree, starting from zero, and also returns the number of leaves +enumerateLeaves' :: BinTree a -> (Int, BinTree (a,Int)) +enumerateLeaves' = go 0 where + go !k t = case t of + Leaf y -> (k+1 , Leaf (y,k)) + Branch l r -> (k'', Branch l' r') where + (k' ,l') = go k l + (k'',r') = go k' r + +-- | Enumerates the leaves a tree, starting from zero +enumerateLeaves :: BinTree a -> BinTree (a,Int) +enumerateLeaves = snd . enumerateLeaves' + +-------------------------------------------------------------------------------- +-- * conversion to 'Data.Tree' + +-- | Convert a binary tree to a rose tree (from "Data.Tree") +toRoseTree :: BinTree a -> Tree (Maybe a) +toRoseTree = go where + go (Branch t1 t2) = Node Nothing [go t1, go t2] + go (Leaf x) = Node (Just x) [] + +toRoseTree' :: BinTree' a b -> Tree (Either b a) +toRoseTree' = go where + go (Branch' t1 y t2) = Node (Left y) [go t1, go t2] + go (Leaf' x) = Node (Right x) [] + +-------------------------------------------------------------------------------- +-- instances + +instance Functor BinTree where + fmap f = go where + go (Branch left right) = Branch (go left) (go right) + go (Leaf x) = Leaf (f x) + +instance Foldable BinTree where + foldMap f = go where + go (Leaf x) = f x + go (Branch left right) = (go left) `mappend` (go right) + +instance Traversable BinTree where + traverse f = go where + go (Leaf x) = Leaf <$> f x + go (Branch left right) = Branch <$> go left <*> go right + +instance Applicative BinTree where + pure = Leaf + u <*> t = go u where + go (Branch l r) = Branch (go l) (go r) + go (Leaf f ) = fmap f t + +instance Monad BinTree where + return = Leaf + (>>=) t f = go t where + go (Branch l r) = Branch (go l) (go r) + go (Leaf y ) = f y + +-------------------------------------------------------------------------------- +-- * Nested parentheses + +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 + +-- | Generates all sequences of nested parentheses of length @2n@ in +-- lexigraphic order. +-- +-- Synonym for 'fasc4A_algorithm_P'. +-- +nestedParentheses :: Int -> [[Paren]] +nestedParentheses = fasc4A_algorithm_P + +-- | Synonym for 'fasc4A_algorithm_W'. +randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g) +randomNestedParentheses = fasc4A_algorithm_W + +-- | Synonym for 'fasc4A_algorithm_U'. +nthNestedParentheses :: Int -> Integer -> [Paren] +nthNestedParentheses = fasc4A_algorithm_U + +countNestedParentheses :: Int -> Integer +countNestedParentheses = countBinaryTrees + +-- | Generates all sequences of nested parentheses of length 2n. +-- Order is lexicographical (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) , [] ) + next _ = error "fasc4A_algorithm_P: fatal error shouldn't happen" + + 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 , [] ) + findj _ _ = error "fasc4A_algorithm_P: fatal error shouldn't happen" + +-- | Generates a uniformly random sequence of nested parentheses of length 2n. +-- Based on \"Algorithm W\" in Knuth. +fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g) +fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where + n = fromIntegral n' :: Integer + -- the numbers we use are of order n^2, so for n >> 2^16 + -- on a 32 bit machine, we need big integers. + worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g) + worker (rnd,_,0,parens) = (parens,rnd) + worker (rnd,p,q,parens) = + if x<(q+1)*(q-p) + then worker (rnd' , p , q-1 , LeftParen :parens) + else worker (rnd' , p-1 , q , RightParen:parens) + where + (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd + +-- | Nth sequence of nested parentheses of length 2n. +-- The order is the same as in 'fasc4A_algorithm_P'. +-- Based on \"Algorithm U\" in Knuth. +fasc4A_algorithm_U + :: Int -- ^ n + -> Integer -- ^ N; should satisfy 1 <= N <= C(n) + -> [Paren] +fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where + n = fromIntegral n' :: Integer + c0 = foldl f 1 [2..n] + f c p = ((4*p-2)*c) `div` (p+1) + worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren] + worker (_ ,_,_,0,parens) = parens + worker (bign,c,p,q,parens) = + if bign <= c' + then worker (bign , c' , p , q-1 , RightParen:parens) + else worker (bign-c' , c-c' , p-1 , q , LeftParen :parens) + where + c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1)) + +-------------------------------------------------------------------------------- +-- * Generating binary trees + +-- | Generates all binary trees with @n@ nodes. +-- At the moment just a synonym for 'binaryTreesNaive'. +binaryTrees :: Int -> [BinTree ()] +binaryTrees = binaryTreesNaive + +-- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }. +-- +-- This is also the counting function for forests and nested parentheses. +countBinaryTrees :: Int -> Integer +countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n) + +-- | Generates all binary trees with n nodes. The naive algorithm. +binaryTreesNaive :: Int -> [BinTree ()] +binaryTreesNaive 0 = [ leaf ] +binaryTreesNaive n = + [ Branch l r + | i <- [0..n-1] + , l <- binaryTreesNaive i + , r <- binaryTreesNaive (n-1-i) + ] + +-- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'. +randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g) +randomBinaryTree n rnd = (tree,rnd') where + (decorated,rnd') = fasc4A_algorithm_R n rnd + tree = fmap (const ()) $ forgetNodeDecorations decorated + +-- | Grows a uniformly random binary tree. +-- \"Algorithm R\" (Remy's procudere) in Knuth. +-- Nodes are decorated with odd numbers, leaves with even numbers (from the +-- set @[0..2n]@). Uses mutable arrays internally. +fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g) +fasc4A_algorithm_R n0 rnd = res where + res = runST $ do + ar <- newArray (0,2*n0) 0 + rnd' <- worker rnd 1 ar + links <- Data.Array.Unsafe.unsafeFreeze ar + return (toTree links, rnd') + toTree links = f (links!0) where + f i = if odd i + then Branch' (f $ links!i) i (f $ links!(i+1)) + else Leaf' i + worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g + worker rnd n ar = do + if n > n0 + then return rnd + else do + writeArray ar (n2-b) n2 + lk <- readArray ar k + writeArray ar (n2-1+b) lk + writeArray ar k (n2-1) + worker rnd' (n+1) ar + where + n2 = n+n + (x,rnd') = randomR (0,4*n-3) rnd + (k,b) = x `divMod` 2 + +-------------------------------------------------------------------------------- +-- * ASCII drawing + +-- | Draws a binary tree in ASCII, ignoring node labels. +-- +-- Example: +-- +-- > autoTabulate RowMajor (Right 5) $ map asciiBinaryTree_ $ binaryTrees 4 +-- +asciiBinaryTree_ :: BinTree a -> ASCII +asciiBinaryTree_ = ASCII.asciiFromLines . fst . go where + + go :: BinTree a -> ([String],Int) + go (Leaf x) = ([],0) + go (Branch t1 t2) = ( new , j1+m ) where + (ls1,j1) = go t1 + (ls2,j2) = go t2 + w1 = blockWidth ls1 + w2 = blockWidth ls2 + m = max 1 $ (w1-j1+j2+2) `div` 2 + s = 2*m - (w1-j1+j2) + spaces = [replicate s ' '] + ls = hConcatLines [ ls1 , spaces , ls2 ] + top = [ replicate (j1+m-i) ' ' ++ "/" ++ replicate (2*(i-1)) ' ' ++ "\\" | i<-[1..m] ] + new = mkLinesUniformWidth $ vConcatLines [ top , ls ] + + blockWidth ls = case ls of + (l:_) -> length l + [] -> 0 + +instance DrawASCII (BinTree ()) where + ascii = asciiBinaryTree_ + +-------------------------------------------------------------------------------- diff --git a/src/Math/Combinat/Trees/Binary.hs-boot b/src/Math/Combinat/Trees/Binary.hs-boot new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/Trees/Graphviz.hs b/src/Math/Combinat/Trees/Graphviz.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/Trees/Nary.hs b/src/Math/Combinat/Trees/Nary.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/Trees/Nary.hs @@ -0,0 +1,430 @@ + +-- | N-ary trees. + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Math.Combinat.Trees.Nary + ( + -- * Types + module Data.Tree + , Tree(..) + -- * Regular trees + , ternaryTrees + , regularNaryTrees + , semiRegularTrees + , countTernaryTrees + , countRegularNaryTrees + -- * \"derivation trees\" + , derivTrees + -- * ASCII drawings + , asciiTreeVertical_ + , asciiTreeVertical + , asciiTreeVerticalLeavesOnly + -- * Graphviz drawing + , Dot + , graphvizDotTree + , graphvizDotForest + -- * Classifying nodes + , classifyTreeNode + , isTreeLeaf , isTreeNode + , isTreeLeaf_ , isTreeNode_ + , treeNodeNumberOfChildren + -- * Counting nodes + , countTreeNodes + , countTreeLeaves + , countTreeLabelsWith + , countTreeNodesWith + -- * Left and right spines + , leftSpine , leftSpine_ + , rightSpine , rightSpine_ + , leftSpineLength , rightSpineLength + -- * Unique labels + , addUniqueLabelsTree + , addUniqueLabelsForest + , addUniqueLabelsTree_ + , addUniqueLabelsForest_ + -- * Labelling by depth + , labelDepthTree + , labelDepthForest + , labelDepthTree_ + , labelDepthForest_ + -- * Labelling by number of children + , labelNChildrenTree + , labelNChildrenForest + , labelNChildrenTree_ + , labelNChildrenForest_ + + ) where + + +-------------------------------------------------------------------------------- + +import Data.Tree +import Data.List + +import Control.Applicative + +--import Control.Monad.State +import Control.Monad.Trans.State +import Data.Traversable (traverse) + +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.Classes +import Math.Combinat.ASCII as ASCII +import Math.Combinat.Helper + +-------------------------------------------------------------------------------- + +instance HasNumberOfNodes (Tree a) where + numberOfNodes = go where + go (Node label subforest) = if null subforest + then 0 + else 1 + sum' (map go subforest) + +instance HasNumberOfLeaves (Tree a) where + numberOfLeaves = go where + go (Node label subforest) = if null subforest + then 1 + else sum' (map go subforest) + +-------------------------------------------------------------------------------- + +-- | @regularNaryTrees d n@ returns the list of (rooted) trees on @n@ nodes where each +-- node has exactly @d@ children. Note that the leaves do not count in @n@. +-- Naive algorithm. +regularNaryTrees + :: Int -- ^ degree = number of children of each node + -> Int -- ^ number of nodes + -> [Tree ()] +regularNaryTrees d = go where + go 0 = [ Node () [] ] + go n = [ Node () cs + | is <- compositions d (n-1) + , cs <- listTensor [ go i | i<-is ] + ] + +-- | Ternary trees on @n@ nodes (synonym for @regularNaryTrees 3@) +ternaryTrees :: Int -> [Tree ()] +ternaryTrees = regularNaryTrees 3 + +-- | We have +-- +-- > length (regularNaryTrees d n) == countRegularNaryTrees d n == \frac {1} {(d-1)n+1} \binom {dn} {n} +-- +countRegularNaryTrees :: (Integral a, Integral b) => a -> b -> Integer +countRegularNaryTrees d n = binomial (dd*nn) nn `div` ((dd-1)*nn+1) where + dd = fromIntegral d :: Integer + nn = fromIntegral n :: Integer + +-- | @\# = \\frac {1} {(2n+1} \\binom {3n} {n}@ +countTernaryTrees :: Integral a => a -> Integer +countTernaryTrees = countRegularNaryTrees (3::Int) + +-------------------------------------------------------------------------------- + +-- | All trees on @n@ nodes where the number of children of all nodes is +-- in element of the given set. Example: +-- +-- > 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,...] +-- +-- The latter sequence is A027307 in OEIS: +-- +-- Remark: clearly, we have +-- +-- > semiRegularTrees [d] n == regularNaryTrees d n +-- +-- +semiRegularTrees + :: [Int] -- ^ set of allowed number of children + -> Int -- ^ number of nodes + -> [Tree ()] +semiRegularTrees [] n = if n==0 then [Node () []] else [] +semiRegularTrees dset_ n = + if head dset >=1 + then go n + else error "semiRegularTrees: expecting a list of positive integers" + where + dset = map head $ group $ sort $ dset_ + + go 0 = [ Node () [] ] + go n = [ Node () cs + | d <- dset + , is <- compositions d (n-1) + , cs <- listTensor [ go i | i<-is ] + ] + +{- + +NOTES: + +A006318 = [ length $ semiRegularTrees [1,2] n | n<-[0..] ] == [1,2,6,22,90,394,1806,8558,41586,206098,1037718.. ] +?? = [ length $ semiRegularTrees [1,3] n | n<-[0..] ] == [1,2,8,44,280,1936,14128,107088,834912,6652608 .. ] +?? = [ length $ semiRegularTrees [1,4] n | n<-[0..] ] == [1,2,10,74,642,6082,60970,635818,6826690 + +A027307 = [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...] +A219534 = [ length $ semiRegularTrees [2,4] n | n<-[0..] ] == [1,2,12,100,968,10208,113792,1318832 ..] +?? = [ length $ semiRegularTrees [2,5] n | n<-[0..] ] == [1,2,14,142,1690,21994,303126,4348102 ..] + +A144097 = [ length $ semiRegularTrees [3,4] n | n<-[0..] ] == [1,2,14,134,1482,17818,226214,2984206,40503890..] + +A107708 = [ length $ semiRegularTrees [1,2,3] n | n<-[0..] ] == [1,3,18,144,1323,13176,138348,1507977 .. ] +?? = [ length $ semiRegularTrees [1,2,3,4] n | n<-[0..] ] == [1,4,40,560,9120,161856,3036800,59242240 .. ] + +-} + +-------------------------------------------------------------------------------- + +-- | Vertical ASCII drawing of a tree, without labels. Example: +-- +-- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical_ $ regularNaryTrees 2 4 +-- +-- Nodes are denoted by @\@@, leaves by @*@. +-- +asciiTreeVertical_ :: Tree a -> ASCII +asciiTreeVertical_ tree = ASCII.asciiFromLines (go tree) where + go :: Tree b -> [String] + go (Node _ cs) = case cs of + [] -> ["-*"] + _ -> concat $ mapWithFirstLast f $ map go cs + + f :: Bool -> Bool -> [String] -> [String] + f bf bl (l:ls) = let indent = if bl then " " else "| " + gap = if bl then [] else ["| "] + branch = if bl && not bf + then "\\-" + else if bf then "@-" + else "+-" + in (branch++l) : map (indent++) ls ++ gap + +instance DrawASCII (Tree ()) where + ascii = asciiTreeVertical_ + +-- | 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] + _ -> concat $ mapWithFirstLast (f (show x)) $ map go cs + + f :: String -> Bool -> Bool -> [String] -> [String] + f label bf bl (l:ls) = + let spaces = (map (const ' ') label ) + dashes = (map (const '-') spaces ) + indent = if bl then " " ++spaces++" " else " |" ++ spaces ++ " " + gap = if bl then [] else [" |" ++ spaces ++ " "] + branch = if bl && not bf + then " \\"++dashes++"--" + else if bf + then "-(" ++ label ++ ")-" + else " +" ++ dashes ++ "--" + in (branch++l) : map (indent++) ls ++ gap + +-- | 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] + _ -> concat $ mapWithFirstLast f $ map go cs + + f :: Bool -> Bool -> [String] -> [String] + f bf bl (l:ls) = let indent = if bl then " " else "| " + gap = if bl then [] else ["| "] + branch = if bl && not bf + then "\\-" + else if bf then "@-" + else "+-" + in (branch++l) : map (indent++) ls ++ gap + +-------------------------------------------------------------------------------- + +-- | The leftmost spine (the second element of the pair is the leaf node) +leftSpine :: Tree a -> ([a],a) +leftSpine = go where + go (Node x cs) = case cs of + [] -> ([],x) + _ -> let (xs,y) = go (head cs) in (x:xs,y) + +rightSpine :: Tree a -> ([a],a) +rightSpine = go where + go (Node x cs) = case cs of + [] -> ([],x) + _ -> let (xs,y) = go (last cs) in (x:xs,y) + +-- | The leftmost spine without the leaf node +leftSpine_ :: Tree a -> [a] +leftSpine_ = go where + go (Node x cs) = case cs of + [] -> [] + _ -> x : go (head cs) + +rightSpine_ :: Tree a -> [a] +rightSpine_ = go where + go (Node x cs) = case cs of + [] -> [] + _ -> x : go (last cs) + +-- | The length (number of edges) on the left spine +-- +-- > leftSpineLength tree == length (leftSpine_ tree) +-- +leftSpineLength :: Tree a -> Int +leftSpineLength = go 0 where + go n (Node x cs) = case cs of + [] -> n + _ -> go (n+1) (head cs) + +rightSpineLength :: Tree a -> Int +rightSpineLength = go 0 where + go n (Node x cs) = case cs of + [] -> n + _ -> go (n+1) (last cs) + +-------------------------------------------------------------------------------- + +-- | 'Left' is leaf, 'Right' is node +classifyTreeNode :: Tree a -> Either a a +classifyTreeNode (Node x cs) = case cs of { [] -> Left x ; _ -> Right x } + +isTreeLeaf :: Tree a -> Maybe a +isTreeLeaf (Node x cs) = case cs of { [] -> Just x ; _ -> Nothing } + +isTreeNode :: Tree a -> Maybe a +isTreeNode (Node x cs) = case cs of { [] -> Nothing ; _ -> Just x } + +isTreeLeaf_ :: Tree a -> Bool +isTreeLeaf_ (Node x cs) = case cs of { [] -> True ; _ -> False } + +isTreeNode_ :: Tree a -> Bool +isTreeNode_ (Node x cs) = case cs of { [] -> False ; _ -> True } + +treeNodeNumberOfChildren :: Tree a -> Int +treeNodeNumberOfChildren (Node _ cs) = length cs + +-------------------------------------------------------------------------------- +-- counting + +countTreeNodes :: Tree a -> Int +countTreeNodes = go where + go (Node x cs) = case cs of + [] -> 0 + _ -> 1 + sum (map go cs) + +countTreeLeaves :: Tree a -> Int +countTreeLeaves = go where + go (Node x cs) = case cs of + [] -> 1 + _ -> sum (map go cs) + +countTreeLabelsWith :: (a -> Bool) -> Tree a -> Int +countTreeLabelsWith f = go where + go (Node label cs) = (if f label then 1 else 0) + sum (map go cs) + +countTreeNodesWith :: (Tree a -> Bool) -> Tree a -> Int +countTreeNodesWith f = go where + go node@(Node _ cs) = (if f node then 1 else 0) + sum (map go cs) + +-------------------------------------------------------------------------------- + +-- | Adds unique labels to the nodes (including leaves) of a 'Tree'. +addUniqueLabelsTree :: Tree a -> Tree (a,Int) +addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree]) + +-- | Adds unique labels to the nodes (including leaves) of a 'Forest' +addUniqueLabelsForest :: Forest a -> Forest (a,Int) +addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where + globalAction tree = + unwrapMonad $ traverse localAction tree + localAction x = WrapMonad $ do + i <- get + put (i+1) + return (x,i) + +addUniqueLabelsTree_ :: Tree a -> Tree Int +addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree + +addUniqueLabelsForest_ :: Forest a -> Forest Int +addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest + +-------------------------------------------------------------------------------- + +-- | Attaches the depth to each node. The depth of the root is 0. +labelDepthTree :: Tree a -> Tree (a,Int) +labelDepthTree tree = worker 0 tree where + worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees) + +labelDepthForest :: Forest a -> Forest (a,Int) +labelDepthForest forest = map labelDepthTree forest + +labelDepthTree_ :: Tree a -> Tree Int +labelDepthTree_ = fmap snd . labelDepthTree + +labelDepthForest_ :: Forest a -> Forest Int +labelDepthForest_ = map (fmap snd) . labelDepthForest + +-------------------------------------------------------------------------------- + +-- | Attaches the number of children to each node. +labelNChildrenTree :: Tree a -> Tree (a,Int) +labelNChildrenTree (Node x subforest) = + Node (x, length subforest) (map labelNChildrenTree subforest) + +labelNChildrenForest :: Forest a -> Forest (a,Int) +labelNChildrenForest forest = map labelNChildrenTree forest + +labelNChildrenTree_ :: Tree a -> Tree Int +labelNChildrenTree_ = fmap snd . labelNChildrenTree + +labelNChildrenForest_ :: Forest a -> Forest Int +labelNChildrenForest_ = map (fmap snd) . labelNChildrenForest + +-------------------------------------------------------------------------------- + +-- | Computes the set of equivalence classes of rooted trees (in the +-- sense that the leaves of a node are /unordered/) +-- with @n = length ks@ leaves where the set of heights of +-- the leaves matches the given set of numbers. +-- The height is defined as the number of /edges/ from the leaf to the root. +-- +-- TODO: better name? +derivTrees :: [Int] -> [Tree ()] +derivTrees xs = derivTrees' (map (+1) xs) + +derivTrees' :: [Int] -> [Tree ()] +derivTrees' [] = [] +derivTrees' [n] = + if n>=1 + then [unfoldTree f 1] + else [] + where + f k = if k0) ks) + then + [ Node () sub + | part <- parts + , let subtrees = map g part + , sub <- listTensor subtrees + ] + else [] + where + parts = partitionMultiset ks + g xs = derivTrees' (map (\x->x-1) xs) + +-------------------------------------------------------------------------------- + diff --git a/src/Math/Combinat/Trees/Nary.hs-boot b/src/Math/Combinat/Trees/Nary.hs-boot new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/Tuples.hs b/src/Math/Combinat/Tuples.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Math/Combinat/TypeLevel.hs b/src/Math/Combinat/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Math/Combinat/TypeLevel.hs @@ -0,0 +1,117 @@ + +-- | Type-level hackery. +-- +-- This module is used for groups whose parameters are encoded as type-level natural numbers, +-- for example finite cyclic groups, free groups, symmetric groups and braid groups. +-- + +{-# LANGUAGE PolyKinds, DataKinds, KindSignatures, ScopedTypeVariables, + ExistentialQuantification, Rank2Types #-} + +module Math.Combinat.TypeLevel + ( -- * Proxy + Proxy(..) + , proxyUndef + , proxyOf + , proxyOf1 + , proxyOf2 + , asProxyTypeOf -- defined in Data.Proxy + , asProxyTypeOf1 + -- * Type-level naturals as type arguments + , typeArg + , iTypeArg + -- * Hiding the type parameter + , Some (..) + , withSome , withSomeM + , selectSome , selectSomeM + , withSelected , withSelectedM + ) + where + +-------------------------------------------------------------------------------- + +import Data.Proxy ( Proxy(..) , asProxyTypeOf ) +import GHC.TypeLits + +import Math.Combinat.Numbers.Primes ( isProbablyPrime ) + +-------------------------------------------------------------------------------- +-- * Proxy + +proxyUndef :: Proxy a -> a +proxyUndef _ = error "proxyUndef" + +proxyOf :: a -> Proxy a +proxyOf _ = Proxy + +proxyOf1 :: f a -> Proxy a +proxyOf1 _ = Proxy + +proxyOf2 :: g (f a) -> Proxy a +proxyOf2 _ = Proxy + +asProxyTypeOf1 :: f a -> Proxy a -> f a +asProxyTypeOf1 y _ = y + +-------------------------------------------------------------------------------- +-- * Type-level naturals as type arguments + +typeArg :: KnownNat n => f (n :: Nat) -> Integer +typeArg = natVal . proxyOf1 + +iTypeArg :: KnownNat n => f (n :: Nat) -> Int +iTypeArg = fromIntegral . typeArg + +-------------------------------------------------------------------------------- +-- * Hiding the type parameter + +-- | Hide the type parameter of a functor. Example: @Some Braid@ +data Some f = forall n. KnownNat n => Some (f n) + +-- | Uses the value inside a 'Some' +withSome :: Some f -> (forall n. KnownNat n => f n -> a) -> a +withSome some polyFun = case some of { Some stuff -> polyFun stuff } + +-- | Monadic version of 'withSome' +withSomeM :: Monad m => Some f -> (forall n. KnownNat n => f n -> m a) -> m a +withSomeM some polyAct = case some of { Some stuff -> polyAct stuff } + +-- | Given a polymorphic value, we select at run time the +-- one specified by the second argument +selectSome :: Integral int => (forall n. KnownNat n => f n) -> int -> Some f +selectSome poly n = case someNatVal (fromIntegral n :: Integer) of + Nothing -> error "selectSome: not a natural number" + Just snat -> case snat of + SomeNat pxy -> Some (asProxyTypeOf1 poly pxy) + +-- | Monadic version of 'selectSome' +selectSomeM :: forall m f int. (Integral int, Monad m) => (forall n. KnownNat n => m (f n)) -> int -> m (Some f) +selectSomeM runPoly n = case someNatVal (fromIntegral n :: Integer) of + Nothing -> error "selectSomeM: not a natural number" + Just snat -> case snat of + SomeNat pxy -> do + poly <- runPoly + return $ Some (asProxyTypeOf1 poly pxy) + +-- | Combination of 'selectSome' and 'withSome': we make a temporary structure +-- of the given size, but we immediately consume it. +withSelected + :: Integral int + => (forall n. KnownNat n => f n -> a) + -> (forall n. KnownNat n => f n) + -> int + -> a +withSelected f x n = withSome (selectSome x n) f + +-- | (Half-)monadic version of 'withSelected' +withSelectedM + :: forall m f int a. (Integral int, Monad m) + => (forall n. KnownNat n => f n -> a) + -> (forall n. KnownNat n => m (f n)) + -> int + -> m a +withSelectedM f mx n = do + s <- selectSomeM mx n + return (withSome s f) + +--------------------------------------------------------------------------------