module Math.Combinat.Partitions
(
Partition
, toPartition
, toPartitionUnsafe
, mkPartition
, isPartition
, fromPartition
, height
, width
, heightWidth
, weight
, dualPartition
, _dualPartition
, elements
, _elements
, countAutomorphisms
, _countAutomorphisms
, partitions'
, _partitions'
, countPartitions'
, partitions
, _partitions
, countPartitions
, allPartitions'
, allPartitions
, countAllPartitions'
, countAllPartitions
, partitionMultiset
, IntVector
, vectorPartitions
, _vectorPartitions
, fasc3B_algorithm_M
)
where
import Data.List
import Data.Array.Unboxed
import Math.Combinat.Helper
import Math.Combinat.Numbers (factorial,binomial,multinomial)
newtype Partition = Partition [Int] deriving (Eq,Ord,Show,Read)
mkPartition :: [Int] -> Partition
mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs
toPartitionUnsafe :: [Int] -> Partition
toPartitionUnsafe = Partition
toPartition :: [Int] -> Partition
toPartition xs = if isPartition xs
then toPartitionUnsafe xs
else error "toPartition: not a partition"
isPartition :: [Int] -> Bool
isPartition [] = True
isPartition [_] = True
isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs
fromPartition :: Partition -> [Int]
fromPartition (Partition part) = part
height :: Partition -> Int
height (Partition part) = case part of
(p:_) -> p
[] -> 0
width :: Partition -> Int
width (Partition part) = length part
heightWidth :: Partition -> (Int,Int)
heightWidth part = (height part, width part)
weight :: Partition -> Int
weight (Partition part) = sum part
dualPartition :: Partition -> Partition
dualPartition (Partition part) = Partition (_dualPartition part)
_dualPartition :: [Int] -> [Int]
_dualPartition [] = []
_dualPartition xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ]
elements :: Partition -> [(Int,Int)]
elements (Partition part) = _elements part
_elements :: [Int] -> [(Int,Int)]
_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ]
countAutomorphisms :: Partition -> Integer
countAutomorphisms = _countAutomorphisms . fromPartition
_countAutomorphisms :: [Int] -> Integer
_countAutomorphisms = multinomial . map length . group
_partitions'
:: (Int,Int)
-> Int
-> [[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,w1) (di) ]
partitions'
:: (Int,Int)
-> Int
-> [Partition]
partitions' hw d = map toPartitionUnsafe $ _partitions' hw d
countPartitions' :: (Int,Int) -> Int -> Integer
countPartitions' _ 0 = 1
countPartitions' (0,_) d = if d==0 then 1 else 0
countPartitions' (_,0) d = if d==0 then 1 else 0
countPartitions' (h,w) d = sum
[ countPartitions' (i,w1) (di) | i <- [1..min d h] ]
_partitions :: Int -> [[Int]]
_partitions d = _partitions' (d,d) d
partitions :: Int -> [Partition]
partitions d = partitions' (d,d) d
countPartitions :: Int -> Integer
countPartitions d = countPartitions' (d,d) d
allPartitions'
:: (Int,Int)
-> [[Partition]]
allPartitions' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w
allPartitions :: Int -> [[Partition]]
allPartitions d = [ partitions i | i <- [0..d] ]
countAllPartitions' :: (Int,Int) -> Integer
countAllPartitions' (h,w) =
binomial (h+w) (min h w)
countAllPartitions :: Int -> Integer
countAllPartitions d = sum [ countPartitions i | i <- [0..d] ]
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
type IntVector = UArray Int Int
vectorPartitions :: IntVector -> [[IntVector]]
vectorPartitions = fasc3B_algorithm_M . elems
_vectorPartitions :: [Int] -> [[[Int]]]
_vectorPartitions = map (map elems) . fasc3B_algorithm_M
fasc3B_algorithm_M :: [Int] -> [[IntVector]]
fasc3B_algorithm_M xs = worker [start] where
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,v1) :
[ (c,u,u) | (c,u,_) <- reverse second ]
_ -> error "should not happen"
to_vector cuvs =
accumArray (flip const) 0 (1,m)
[ (c,v) | (c,_,v) <- cuvs ]
subtract_rec all@(last:_) =
case subtract last of
[] -> all
new -> subtract_rec (new:all)
subtract [] = []
subtract full@((c,u,v):rest) =
if w >= v
then (c,w,v) : subtract rest
else subtract_b full
where w = u v
subtract_b [] = []
subtract_b ((c,u,v):rest) =
if w /= 0
then (c,w,w) : subtract_b rest
else subtract_b rest
where w = u v