module FoulkesMultiplicities where
import Data.Array
import qualified Data.Map as Map
import Debug.Trace
import Data.List
-------------------------------------------------------------------------------
--Memoized functions at top level end 'M'. We memoize Foulkes multiplicities for
--m <= m_max, n <= n_max and partitions with at most row_max parts. For FC, it
--is enough to look at partitions with at most m parts.
m_max = 12
n_max = 12
row_max = 12
--For (9^10) use m_max = 10, n_max = 9, row_max = 9.
--For (10^9) use m_max = 10, n_max = 8, row_max = 9.
--Compute separately and then zip lists together.
-- did same for 9 and 11
-------------------------------------------------------------------------------
--Partitions
type Partition = [Int]
partitions :: Int -> [Partition]
partitions 0 = [[]]
partitions n = partitionsInBox n n n
type NumberOfRows = Int
type NumberOfColumns = Int
partitionsInBox _ _ 0 = [[]]
partitionsInBox 0 _ _ = []
partitionsInBox _ 0 _ = []
partitionsInBox b a r = [t : ts | t <- reverse [1..a `min` r],
ts <- partitionsInBox (b-1) t (r-t)]
partitionsMaxRows :: NumberOfRows -> Int -> [Partition]
partitionsMaxRows b n = partitionsInBox b n n
depth [] = error "Depth of empty partition not defined"
depth (x : xs) = sum xs
-------------------------------------------------------------------------------
--Abacus, with numbered beads, stored as a list of bead positions. For example,
--the abacus .*..*.* with beads numbered 1,2,3 is stored as [6,4,1]. After moving
--bead 1 three places to the left, it becomes [3,4,1], with a sign, calculated
--later in abacusToSignedPartition, of -1.
type Bead = Int
type Abacus = [Bead]
type Sign = Integer
--Downwardly remove m distinct l-hooks in all possible ways. Abaci with two beads
--are dealt with as a special case for efficiency (about 10% speed-up).
type HookMultiplicity = Int
type HookLength = Int
removeHooks :: HookMultiplicity -> HookLength -> Abacus -> [Abacus]
removeHooks 0 _ [] = [[]]
removeHooks _ _ [] = []
removeHooks m l [b] = if c >= 0 then [[c]] else [] where c = b-m*l
removeHooks m l [b,c] =
if (b-c) `mod` l /= 0
then [[b-(m-r)*l,c-r*l] | r <- [0 `max` (m - (b `div` l)) .. (c `div` l) `min` m]]
else [[b-(m-r)*l,c-r*l] | r <- [0 `max` (m + 1 - ((b-c) `div` l)) .. ((c `div` l) `min` m)]]
removeHooks m l (b : bs) = [b_new : cs | r <- movesForRemoving m l bs b,
let b_new = b-r*l,
cs <- removeHooks (m-r) l bs]
movesForRemoving :: HookMultiplicity -> HookLength -> Abacus -> Bead -> [Int]
movesForRemoving m l bs b = takeWhile isLegal [0..(b `div` l) `min` m]
where isLegal j = not (b - j*l `elem` bs)
partitionToAbacus :: Partition -> Abacus
partitionToAbacus xs = zipWith (+) xs (downFrom (k-1))
where k = length xs
abacusToSignedPartition :: Abacus -> (Partition, Sign)
abacusToSignedPartition bs = (takeWhile (/=0) $ zipWith (-) bs_sorted (downFrom (k-1)), s)
where (bs_sorted, s) = mergeSortWithSign bs
k = length bs_sorted
abacusToPartition :: Abacus -> Partition
abacusToPartition bs = let (p, _) = abacusToSignedPartition bs in p
removeHooksP :: HookMultiplicity -> HookLength -> Partition -> [(Partition, Sign)]
removeHooksP m l xs = [abacusToSignedPartition cs | cs <- removeHooks m l bs]
where bs = partitionToAbacus xs
-------------------------------------------------------------------------------
--Core, added January 2014
removableHooks :: HookLength -> Abacus -> [Bead]
removableHooks l bs = [b | b <- bs, b - l >= 0, not ((b-l) `elem` bs)]
core :: HookLength -> Abacus -> Abacus
core l a | rs == [] = a
| otherwise = core l (head $ removeHooks 1 l a)
where rs = removableHooks l a
coreP :: HookLength -> Partition -> Partition
coreP l p = abacusToPartition (core l (partitionToAbacus p) :: Abacus)
-------------------------------------------------------------------------------
--Character multiplicities. Memoize with a map over m, then an array on n, then
--a map on the partitions, using partitions with at most row_max parts. In any
--run there are at most two values of m, so at most two arrays are populated.
--(Maps are strict in keys, lazy in values.)
multiplicitiesM fStep = Map.fromList [(m, multiplicityArray m) | m <- [1..m_max]]
where multiplicityArray m = array (0,n_max) [(n, fMap fStep m n) | n <- [0..n_max]]
fMap fStep m n = Map.fromList [(xs, aux m n xs) | xs <- partitionsMaxRows row_max (m*n)]
where aux _ 0 [] = 1
aux _ 0 _ = 0
aux _ 1 [r] = 1
aux _ 1 _ = 0
aux m n xs = fStep m n xs
-------------------------------------------------------------------------------
--Foulkes multiplicities: in any single run of the programme there will be at
--most two different values for m (the number of columns). So memoize with a map
--on m, then an array on n, then a map on the partitions. This avoids
--constructing large maps full of partitions that are constructed but never used.
foulkesMultiplicitiesM = multiplicitiesM foulkesStep
foulkesStep m n xs =
let t = sum [s * fm m (n-l) ys | l <- [1..n],
(ys, s) <- removeHooksP m l xs,
length ys <= n-l]
in t `div` (toInteger n)
fm :: NumberOfColumns -> NumberOfRows -> Partition -> Integer
fm m n xs | n > n_max || (length xs > row_max) || m > m_max = error message --foulkesStep m n xs
| otherwise = ((foulkesMultiplicitiesM Map.! m) ! n) Map.! xs
where message = "Not in map: m = " ++ show m ++ " n = " ++ show n ++ " xs = " ++ show xs
fms m n k = [(xs, fm m n xs) | xs <- partitionsMaxRows k (m*n)]
fmsNZ m n k = [(xs, c) | (xs, c) <- fms m n k, c > 0]
fmsNZA m n = fmsNZ m n n
fmsNZwithCores m n k l = [(xs, c, coreP l xs) | (xs, c) <- fmsNZ m n k]
fmsDepth m n d = [(xs, fm m n xs) | xs <- partitionsMaxRows n (m*n), depth xs == d]
fmsDepthNZ m n d = [(xs, c) | (xs, c) <- fmsDepth m n d, c > 0]
-------------------------------------------------------------------------------
--Comparing Foulkes multiplicities for Foulkes Conjecture
--only run for m < n
fmsBoth m n = (fms m n m, fms n m m)
fmsComp m n = let (bigger, smaller) = fmsBoth m n
in map check [(xs, r, s) | ((xs,r),(_,s)) <- zip bigger smaller]
where check (xs, r, s) | r >= s = (xs, r, s)
| otherwise = error ("Counterexample: " ++ show xs)
fmsCompNZ m n = [(xs, c, d) | (xs, c, d) <- fmsComp m n, c > 0 || d > 0]
-------------------------------------------------------------------------------
--Kostka multiplicities by analogous recurrence, i.e. using SSYT interpretation
--of downwards removal of m disjoint 1-hooks. But what about the iteration?
kostkaMultiplicitiesM = multiplicitiesM kostkaStep
kostkaStep m n xs = sum [km m (n-1) ys | (ys, s) <- removeHooksP m 1 xs,
length ys <= n-1]
km :: NumberOfColumns -> NumberOfRows -> Partition -> Integer
km m n xs | n > n_max || n > row_max = kostkaStep m n xs
| otherwise = ((kostkaMultiplicitiesM Map.! m) ! n) Map.! xs
kms m n k = [(xs, km m n xs) | xs <- partitionsMaxRows k (m*n)]
--only run for m < n
kmsBoth m n = (kms m n m, kms n m m)
kmsComp m n = [(xs, r, s) | ((xs, r), (_, s)) <- zip larger smaller]
where (larger, smaller) = kmsBoth m n
-------------------------------------------------------------------------------
--Minimal constituents: test conjecture that all n-row constituents are minimal
p `dominates` q = and $ zipWith (>=) (partialSums p) (partialSums q)
partialSums p = scanl1 (+) p
minimals [] = []
minimals ((p, m) : rest) | isMinimal = (p,m) : minimals rest'
| otherwise = minimals rest
where isMinimal = not $ or [p `dominates` q | (q, _) <- rest]
rest' = [(q, m) | (q, m) <- rest, not (q `dominates` p)]
fullRows ts = [(p, m) | (p, m) <- ts, length p == n]
where n = maximum [length p | (p, m) <- ts]
fullRowsNonMinimals ts = [(p,m) | (p,m) <- fullRows ts, not $ (p, m) `elem` minimals ts]
allFullRowsMinimal ts = fullRowsNonMinimals ts == []
-------------------------------------------------------------------------------
-- Depth conjecture
depthCXs m n d = [(p, r, s) | (p, r, s) <- fmsComp m n,
depth p <= d,
r /= s]
-------------------------------------------------------------------------------
-- New feature January 2019: compute a single multiplicity using subpartitions
subpartitions [] = [[]]
subpartitions xs@(x : _) = [filter (/= 0) p | p <- subpartitionsBounded xs x]
subpartitionsBounded [] _ = [[]]
subpartitionsBounded (x : xs) b = [y : ys | y <- [0..x `min` b], ys <- subpartitionsBounded xs (y `min` b)]
subpartitionsSizeMultiple m xs = [ys | ys <- subpartitions xs, sum ys `mod` m == 0]
oneMultiplicity m xs =
let fmap = Map.fromList [(ys, f ys) | ys <- subpartitionsSizeMultiple m xs]
f [] = 1
f ys = let n' = sum ys `div` m
in sum [s * fmap Map.! ys' | l <- [1..n'], (ys', s) <- removeHooksP m l ys, length ys' <= n'-l] `div` (toInteger n')
in fmap Map.! xs
-------------------------------------------------------------------------------
--Conversion to list of (Float, Float, Comment) for use in Plotter
toTriples :: [(Partition, Integer)] -> [(Float, Float, String)]
toTriples ms = map f (zip [1..] ms)
where f (n, (xs, c)) =
let xs_str = show xs
in (n, fromInteger c, xs_str ++ spaceBy (20 - length xs_str) ++ show c)
toTriplesLog :: [(Partition, Integer)] -> [(Float, Float, String)]
toTriplesLog ms = map g (zip [1..] ms)
where g (n, (xs, c)) =
let xs_str = show xs
in (n, slog2 (fromInteger c), xs_str ++ spaceBy (20 - length xs_str) ++ show c)
--for comparison: maybe best not to plot points where smaller multiplicity is 0,
--or maybe these should be shown in some other way.
toTriplesLogComp :: [(Partition, Integer, Integer)] -> ([(Float, Float, String)], [(Float, Float, String)])
toTriplesLogComp ms = let ps = map h (zip [1..] ms)
in ([t | (1,t) <- ps], [t | (2,t) <- ps])
where h (n, (xs, c, d)) | d > 0 = (1, (n, log2 (fromInteger c) - log2 (fromInteger d), comment (xs, c, d)))
| d == 0 = (2, (n, slog2 (fromInteger c), comment (xs, c, d)))
comment (xs, c, d) = let xs_str = show xs in xs_str ++ spaceBy (20 - length xs_str) ++ show c ++ " " ++ show d
-------------------------------------------------------------------------------
--largest parts
partitionChanges :: [(Integer, Partition)] -> [(Float,Int)]
partitionChanges [] = []
partitionChanges ((_, xs) : []) = []
partitionChanges ((n, xs) : rest@((n', xs') : _))
| head xs == head xs' = partitionChanges rest
| otherwise = (fromInteger n + 0.5, head xs') : partitionChanges rest
-------------------------------------------------------------------------------
--Sorting functions
mergeSortWithSign [] = ([], 1)
mergeSortWithSign [x] = ([x], 1)
mergeSortWithSign xs = (xs_sorted, i_sign * ys_sign * zs_sign)
where n = length xs
m = n `div` 2
(ys, zs) = splitAt m xs
(ys_sorted, ys_sign) = mergeSortWithSign ys
(zs_sorted, zs_sign) = mergeSortWithSign zs
(xs_sorted, i_sign) = intermingle ys_sorted zs_sorted m
intermingle xs [] _ = (xs, 1)
intermingle [] ys _ = (ys, 1)
intermingle lx@(x : xs) ly@(y : ys) r
| x > y = let (rest, t) = intermingle xs ly (r-1) in (x : rest, t)
| otherwise = let (rest, t) = intermingle lx ys r in
if r `mod` 2 == 0 then (y : rest, t) else (y : rest, -t)
-------------------------------------------------------------------------------
--Utility functions
qtrace _ y = y
downFrom 0 = [0]
downFrom r = r : downFrom (r-1)
printList xs = putStrLn $ unlines $ map show xs
spaceBy r = take r (repeat ' ')
slog2 x | x == 0 = -0.5
| otherwise = log2 x
log2 x = log x / log 2