jackpolynomials-1.3.0.0: src/Math/Algebra/Jack/Internal.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Math.Algebra.Jack.Internal
(Partition
, jackCoeffP
, jackCoeffQ
, jackCoeffC
, jackSymbolicCoeffC
, jackSymbolicCoeffPinv
, jackSymbolicCoeffQinv
, _betaratio
, _betaRatioOfSprays
, _isPartition
, _N
, _fromInt
, skewSchurLRCoefficients
, isSkewPartition)
where
import Prelude
hiding ((*), (+), (-), (/), (^), (*>), product, sum, fromIntegral, fromInteger, recip)
import Algebra.Additive ( (+), (-), sum )
import qualified Algebra.Additive as AlgAdd
import Algebra.Field ( (/), recip )
import qualified Algebra.Field as AlgField
import Algebra.Ring ( (*), product, one
, (^), fromInteger
)
import qualified Algebra.Ring as AlgRing
import Algebra.ToInteger ( fromIntegral )
import qualified Data.HashMap.Strict as HM
import Data.List.Index ( iconcatMap )
import Data.Maybe ( fromMaybe )
import qualified Data.Map.Strict as DM
import qualified Data.Sequence as S
import Math.Algebra.Hspray (
RatioOfSprays, (%:%)
, Spray
, lone, unitSpray
, (*^), (^**^), (^*^)
, (^+^), (.^), (^-^)
, Powers (..), Term
)
import qualified Math.Combinat.Partitions.Integer as MCP
import Math.Combinat.Tableaux.LittlewoodRichardson ( _lrRule )
type Partition = [Int]
_isPartition :: Partition -> Bool
_isPartition [] = True
_isPartition [x] = x > 0
_isPartition (x:xs@(y:_)) = (x >= y) && _isPartition xs
_diffSequence :: [Int] -> [Int]
_diffSequence = go where
go (x:ys@(y:_)) = (x-y) : go ys
go [x] = [x]
go [] = []
_dualPartition :: Partition -> Partition
_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 _ [] = []
_ij :: Partition -> ([Int], [Int])
_ij lambda =
(
iconcatMap (\i a -> replicate a (i + 1)) lambda,
concatMap (\a -> [1 .. a]) (filter (>0) lambda)
)
_convParts :: AlgRing.C b => [Int] -> ([b], [b])
_convParts lambda =
(map fromIntegral lambda, map fromIntegral (_dualPartition lambda))
_N :: [Int] -> [Int] -> Int
_N lambda mu = sum $ zipWith (*) mu prods
where
prods = map (\i -> product $ drop i (map (+1) lambda)) [1 .. length lambda]
hookLengths :: AlgRing.C a => Partition -> a -> ([a], [a])
hookLengths lambda alpha = (lower, upper)
where
(i, j) = _ij lambda
(lambda', lambdaConj') = _convParts lambda
upper = zipWith (fup lambdaConj' lambda') i j
where
fup x y ii jj =
x!!(jj-1) - fromIntegral ii +
alpha * (y!!(ii-1) - fromIntegral (jj - 1))
lower = zipWith (flow lambdaConj' lambda') i j
where
flow x y ii jj =
x!!(jj-1) - (fromIntegral $ ii - 1) +
alpha * (y!!(ii-1) - fromIntegral jj)
_productHookLengths :: AlgRing.C a => Partition -> a -> a
_productHookLengths lambda alpha = product lower * product upper
where
(lower, upper) = hookLengths lambda alpha
jackCoeffC :: AlgField.C a => Partition -> a -> a
jackCoeffC lambda alpha =
alpha^k * fromInteger (product [2 .. k]) * recip jlambda
where
k = fromIntegral (sum lambda)
jlambda = _productHookLengths lambda alpha
jackCoeffP :: AlgField.C a => Partition -> a -> a
jackCoeffP lambda alpha = one / product lower
where
(lower, _) = hookLengths lambda alpha
jackCoeffQ :: AlgField.C a => Partition -> a -> a
jackCoeffQ lambda alpha = one / product upper
where
(_, upper) = hookLengths lambda alpha
-- | addition of a term to a spray
addTerm :: (AlgAdd.C a, Eq a) => Spray a -> Term a -> Spray a
addTerm spray (powers, coeff) =
if getCoefficient' powers spray AlgAdd.+ coeff == AlgAdd.zero
then
HM.delete powers spray
else
HM.insertWith (AlgAdd.+) powers coeff spray
where
getCoefficient' pows s =
fromMaybe AlgAdd.zero (HM.lookup pows s)
(+>) :: (AlgAdd.C a, Eq a) => a -> Spray a -> Spray a
(+>) x spray = if x == AlgAdd.zero
then spray
else addTerm spray (Powers S.empty 0, x)
symbolicHookLengthsProducts :: forall a. (Eq a, AlgRing.C a)
=> Partition -> (Spray a, Spray a)
symbolicHookLengthsProducts lambda = (product lower, product upper)
where
alpha = lone 1 :: Spray a
(i, j) = _ij lambda
(lambda', lambdaConj') = _convParts lambda
upper = zipWith (fup lambdaConj' lambda') i j
where
fup x y ii jj =
(x!!(jj-1) - fromIntegral ii) +>
((y!!(ii-1) - fromIntegral (jj - 1)) *^ alpha)
lower = zipWith (flow lambdaConj' lambda') i j
where
flow x y ii jj =
(x!!(jj-1) - fromIntegral (ii - 1)) +>
((y!!(ii-1) - fromIntegral jj) *^ alpha)
symbolicHookLengthsProduct :: (Eq a, AlgRing.C a) => Partition -> Spray a
symbolicHookLengthsProduct lambda = lower ^*^ upper
where
(lower, upper) = symbolicHookLengthsProducts lambda
jackSymbolicCoeffC ::
forall a. (Eq a, AlgField.C a) => Partition -> RatioOfSprays a
jackSymbolicCoeffC lambda =
((fromIntegral factorialk) *^ alpha^**^k) %:% jlambda
where
alpha = lone 1 :: Spray a
k = sum lambda
factorialk = product [2 .. k]
jlambda = symbolicHookLengthsProduct lambda
jackSymbolicCoeffPinv :: (Eq a, AlgField.C a) => Partition -> Spray a
jackSymbolicCoeffPinv lambda = lower
where
(lower, _) = symbolicHookLengthsProducts lambda
jackSymbolicCoeffQinv :: (Eq a, AlgField.C a) => Partition -> Spray a
jackSymbolicCoeffQinv lambda = upper
where
(_, upper) = symbolicHookLengthsProducts lambda
_betaratio :: AlgField.C a => Partition -> Partition -> Int -> a -> a
_betaratio kappa mu k alpha = alpha * prod1 * prod2 * prod3
where
mukm1 = mu !! (k-1)
t = fromIntegral k - alpha * fromIntegral mukm1
u = zipWith (\s kap -> t + one - fromIntegral s + alpha * fromIntegral kap)
[1 .. k] kappa
v = zipWith (\s m -> t - fromIntegral s + alpha * fromIntegral m)
[1 .. k-1] mu
w = zipWith (\s m -> fromIntegral m - t - alpha * fromIntegral s)
[1 .. mukm1-1] (_dualPartition mu)
prod1 = product $ map (\x -> x / (x + alpha - one)) u
prod2 = product $ map (\x -> (x + alpha) / x) v
prod3 = product $ map (\x -> (x + alpha) / x) w
_betaRatioOfSprays :: forall a. (Eq a, AlgField.C a)
=> Partition -> Partition -> Int -> RatioOfSprays a
_betaRatioOfSprays kappa mu k =
((x ^*^ num1 ^*^ num2 ^*^ num3) %:% (den1 ^*^ den2 ^*^ den3))
where
mukm1 = mu !! (k-1)
x = lone 1 :: Spray a
u = zipWith
(
\s kap ->
(fromIntegral $ k - s + 1) +> ((fromIntegral $ kap - mukm1) *^ x)
)
[1 .. k] kappa
v = zipWith
(
\s m -> (fromIntegral $ k - s) +> ((fromIntegral $ m - mukm1) *^ x)
)
[1 .. k-1] mu
w = zipWith
(
\s m -> (fromIntegral $ m - k) +> ((fromIntegral $ mukm1 - s) *^ x)
)
[1 .. mukm1-1] (_dualPartition mu)
num1 = product u
den1 = product $ map (\p -> p ^+^ x ^-^ unitSpray) u
num2 = product $ map (\p -> p ^+^ x) v
den2 = product v
num3 = product $ map (\p -> p ^+^ x) w
den3 = product w
_fromInt :: (AlgRing.C a, Eq a) => Int -> a
_fromInt k = k .^ AlgRing.one
skewSchurLRCoefficients :: Partition -> Partition -> DM.Map Partition Int
skewSchurLRCoefficients lambda mu =
DM.mapKeys toPartition (_lrRule lambda' mu')
where
toPartition :: MCP.Partition -> Partition
toPartition (MCP.Partition part) = part
fromPartition :: Partition -> MCP.Partition
fromPartition part = MCP.Partition part
lambda' = fromPartition lambda
mu' = fromPartition mu
isSkewPartition :: Partition -> Partition -> Bool
isSkewPartition lambda mu =
_isPartition lambda && _isPartition mu && all (>= 0) (zipWith (-) lambda mu)