diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -44,4 +44,9 @@ 1.2.2.0 ------- -* slight modifications due to the upgrade of **hspray** +* slight modifications due to the upgrade of **hspray** + +1.3.0.0 +------- +* the type of the Jack polynomials with a symbolic Jack parameter has changed +from `OneParameterSpray a` to `ParametricSpray a` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -38,7 +38,7 @@ The first argument, here `2`, is the number of variables of the polynomial. -### Symbolic (or parametric) Jack polynomial +### Symbolic Jack parameter As of version `1.2.0.0`, it is possible to get Jack polynomials with a symbolic Jack parameter: @@ -47,21 +47,18 @@ import Math.Algebra.JackSymbolicPol import Math.Algebra.Hspray jp = jackSymbolicPol' 2 [3, 1] 'J' -putStrLn $ prettyOneParameterQSpray "a" jp --- { 2*a^2 + 4*a + 2 }*x^3.y + { 4*a + 4 }*x^2.y^2 + { 2*a^2 + 4*a + 2 }*x.y^3 -putStrLn $ prettyQSpray' $ evalOneParameterSpray jp 2 +putStrLn $ prettyParametricQSpray jp +-- { [ 2*a^2 + 4*a + 2 ] }*X^3.Y + { [ 4*a + 4 ] }*X^2.Y^2 + { [ 2*a^2 + 4*a + 2 ] }*X.Y^3 +putStrLn $ prettyQSpray' $ substituteParameters jp [2] -- 18*x^3.y + 12*x^2.y^2 + 18*x.y^3 ``` -This is possible thanks to an upgrade of the **hspray** package which now -provides the type `OneParameterSpray` (and more). An object of this type -represents a multivariate polynomial whose coefficients depend on a parameter -which is symbolically treated. The type of the Jack polynomial returned by -the `jackSymbolicPol` function is `OneParameterSpray a`, and it is -`OneParameterQSpray` for the `jackSymbolicPol'` function. The type -`OneParameterQSpray` is an alias of `OneParameterSpray Rational'` where -`Rational'` is a type defined in the **numeric-prelude** package, -analogous to the well known `Rational` type. +This is possible thanks to the **hspray** package which provides the type +`ParametricSpray`. An object of this type represents a multivariate polynomial +whose coefficients depend on some parameters which are symbolically treated. +The type of the Jack polynomial returned by the `jackSymbolicPol` function is +`ParametricSpray a`, and it is `ParametricQSpray` for the `jackSymbolicPol'` +function. The type `ParametricQSpray` is an alias of `ParametricSpray Rational`. From the definition of Jack polynomials, as well as from their implementation in this package, the coefficients of the Jack polynomials are @@ -71,11 +68,11 @@ the $J$-Jack polynomials (not for $C$, $P$ and $Q$). This is a consequence of the Knop & Sahi combinatorial formula. But be aware that in spite of this fact, the coefficients of the polynomials returned by Haskell are *fractions* of -polynomials, in the sense that this is the nature of the `OneParameterQSpray` +polynomials, in the sense that this is the nature of the `ParametricSpray` objects. Note that if you use the function `jackSymbolicPol` to get a -`OneParameterSpray Double` object in the output, it is not guaranted that you +`ParametricSpray Double` object in the output, it is not guaranted that you will visually get some polynomials in the Jack parameter for the coefficients, because the arithmetic operations are not exact with the `Double` type @@ -103,8 +100,8 @@ import Math.Algebra.JackSymbolicPol import Math.Algebra.Jack.SymmetricPolynomials jp = jackSymbolicPol' 3 [3, 1, 1] 'J' -putStrLn $ prettySymmetricOneParameterQSpray "a" jp --- { 4*a^2 + 10*a + 6 }*M[3,1,1] + { 8*a + 12 }*M[2,2,1] +putStrLn $ prettySymmetricParametricQSpray ["a"] jp +-- { [ 4*a^2 + 10*a + 6 ] }*M[3,1,1] + { [ 8*a + 12 ] }*M[2,2,1] ``` Of course you can use these functions for other polynomials, but carefully: diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,9 +1,7 @@ -module Main (main) where -import Math.Algebra.Hspray ( evalSymbolicSpray - , Rational' - , QSpray - , QSpray' - , SymbolicQSpray +module Main ( main ) where +import Math.Algebra.Hspray ( QSpray + , ParametricQSpray + , substituteParameters ) import Math.Algebra.JackPol ( jackPol' ) @@ -22,17 +20,14 @@ alphaT :: Rational alphaT = 2 -alphaT' :: Rational' -alphaT' = 2 - jP :: (Int, [Int], Rational) -> QSpray jP (n, lambda, alpha) = jackPol' n lambda alpha 'J' -jSP :: (Int, [Int]) -> SymbolicQSpray +jSP :: (Int, [Int]) -> ParametricQSpray jSP (n, lambda) = jackSymbolicPol' n lambda 'J' -jSPeval :: (Int, [Int], Rational') -> QSpray' -jSPeval (n, lambda, alpha') = evalSymbolicSpray (jackSymbolicPol' n lambda 'J') alpha' +jSPeval :: (Int, [Int], Rational) -> QSpray +jSPeval (n, lambda, alpha) = substituteParameters (jackSymbolicPol' n lambda 'J') [alpha] main :: IO () main = @@ -43,6 +38,6 @@ , bench "jackSymbolicPol" $ whnf jSP (nT, lambdaT) , bench "jackSymbolicPol evaluated at alpha" $ - whnf jSPeval (nT, lambdaT, alphaT') + whnf jSPeval (nT, lambdaT, alphaT) ] ] diff --git a/jackpolynomials.cabal b/jackpolynomials.cabal --- a/jackpolynomials.cabal +++ b/jackpolynomials.cabal @@ -1,5 +1,5 @@ name: jackpolynomials -version: 1.2.2.0 +version: 1.3.0.0 synopsis: Jack, zonal, Schur and skew Schur polynomials description: This library can evaluate Jack polynomials, zonal polynomials, Schur and skew Schur polynomials. It is also able to compute them in symbolic form. homepage: https://github.com/stla/jackpolynomials#readme @@ -26,10 +26,11 @@ , ilist >= 0.4.0.1 && < 0.4.1 , array >= 0.5.4.0 && < 0.6 , lens >= 5.0.1 && < 5.3 - , hspray >= 0.3.0.0 && < 0.4.0.0 + , hspray >= 0.4.0.0 && < 0.5.0.0 , numeric-prelude >= 0.4.4 && < 0.5 , combinat >= 0.2.10 && < 0.3 , containers >= 0.6.4.1 && < 0.8 + , unordered-containers >= 0.2.17.0 && < 0.3 other-extensions: ScopedTypeVariables , BangPatterns default-language: Haskell2010 @@ -51,7 +52,7 @@ , tasty >= 1.4 && < 1.6 , tasty-hunit >= 0.10 && < 0.11 , jackpolynomials - , hspray >= 0.3.0.0 && < 0.4.0.0 + , hspray >= 0.4.0.0 && < 0.5.0.0 , hypergeomatrix >= 1.1.0.2 && < 2 Default-Language: Haskell2010 ghc-options: -Wall @@ -70,7 +71,7 @@ Build-Depends: base >= 4.7 && < 5 , miniterion >= 0.1.1.0 && < 0.2 , jackpolynomials - , hspray >= 0.3.0.0 && < 0.4.0.0 + , hspray >= 0.4.0.0 && < 0.5.0.0 Default-Language: Haskell2010 ghc-options: -Wall -Wcompat diff --git a/src/Math/Algebra/Jack.hs b/src/Math/Algebra/Jack.hs --- a/src/Math/Algebra/Jack.hs +++ b/src/Math/Algebra/Jack.hs @@ -25,11 +25,12 @@ import Data.Array ( Array, (!), (//), listArray ) import Data.Maybe ( fromJust, isJust ) import qualified Data.Map.Strict as DM -import Math.Algebra.Jack.Internal ( (.^), _N, jackCoeffC +import Math.Algebra.Jack.Internal ( _N, jackCoeffC , jackCoeffP, jackCoeffQ , _betaratio, _isPartition , Partition, skewSchurLRCoefficients , isSkewPartition, _fromInt ) +import Math.Algebra.Hspray ( (.^) ) -- | Evaluation of Jack polynomial jack' @@ -66,23 +67,24 @@ theproduct nu0 = if nu0 <= 1 then one else product $ map (\i -> one + i .^ alpha) [1 .. nu0-1] - jac :: Int -> Int -> [Int] -> [Int] -> Array (Int,Int) (Maybe a) -> a -> a + jac :: + Int -> Int -> [Int] -> [Int] -> Array (Int,Int) (Maybe a) -> a -> a jac m k mu nu arr beta | null nu || nu!!0 == 0 || m == 0 = one | length nu > m && nu!!m > 0 = zero - | m == 1 = x0 ^ (fromIntegral $ nu!!0) * theproduct (nu!!0) + | m == 1 = x0 ^ (fromIntegral $ nu !! 0) * theproduct (nu !! 0) | k == 0 && isJust (arr ! (_N lambda nu, m)) = fromJust $ arr ! (_N lambda nu, m) | otherwise = s where - s = go (jac (m-1) 0 nu nu arr one * beta * x!!(m-1) ^ (fromIntegral $ sum mu - sum nu)) - (max 1 k) + s = go (jac (m-1) 0 nu nu arr one * beta * + x!!(m-1) ^ (fromIntegral $ sum mu - sum nu)) (max 1 k) go :: a -> Int -> a go !ss ii | length nu < ii || nu!!(ii-1) == 0 = ss | otherwise = let u = nu!!(ii-1) in - if length nu == ii && u > 0 || u > nu!!ii + if length nu == ii && u > 0 || u > nu !! ii then let nu' = (element (ii-1) .~ u-1) nu in let gamma = beta * _betaratio mu nu ii alpha in @@ -92,12 +94,15 @@ else if nu' !! 0 == 0 then - go (ss + gamma * x!!(m-1)^ (fromIntegral $ sum mu)) (ii + 1) + go (ss + gamma * x!!(m-1)^ (fromIntegral $ sum mu)) + (ii + 1) else let arr' = arr // [((_N lambda nu, m), Just ss)] in let jck = jac (m-1) 0 nu' nu' arr' one in - let jck' = jck * gamma * - x!!(m-1) ^ (fromIntegral $ sum mu - sum nu') in + let jck' = + jck * gamma * + x!!(m-1) ^ (fromIntegral $ sum mu - sum nu') + in go (ss + jck') (ii + 1) else go ss (ii + 1) @@ -139,10 +144,11 @@ arr0 = listArray ((1, 1), (nll, n)) (replicate (nll * n) Nothing) sch :: Int -> Int -> [Int] -> Array (Int,Int) (Maybe a) -> a sch m k nu arr - | null nu || nu!!0 == 0 || m == 0 = one - | length nu > m && nu!!m > 0 = zero - | m == 1 = product (replicate (nu!!0) x0) - | isJust (arr ! (_N lambda nu, m)) = fromJust $ arr ! (_N lambda nu, m) + | null nu || nu !! 0 == 0 || m == 0 = one + | length nu > m && nu !! m > 0 = zero + | m == 1 = product (replicate (nu !! 0) x0) + | isJust (arr ! (_N lambda nu, m)) = + fromJust $ arr ! (_N lambda nu, m) | otherwise = s where s = go (sch (m-1) 1 nu arr) k @@ -162,8 +168,10 @@ then go (ss + x!!(m-1)) (ii + 1) else - let arr' = arr // [((_N lambda nu, m), Just ss)] in - go (ss + x!!(m-1) * sch (m-1) 1 nu' arr') (ii + 1) + let arr' = + arr // [((_N lambda nu, m), Just ss)] in + go (ss + x!!(m-1) * sch (m-1) 1 nu' arr') + (ii + 1) else go ss (ii + 1) diff --git a/src/Math/Algebra/Jack/Internal.hs b/src/Math/Algebra/Jack/Internal.hs --- a/src/Math/Algebra/Jack/Internal.hs +++ b/src/Math/Algebra/Jack/Internal.hs @@ -9,10 +9,9 @@ , jackSymbolicCoeffPinv , jackSymbolicCoeffQinv , _betaratio - , _betaRatioOfPolynomials + , _betaRatioOfSprays , _isPartition , _N - , (.^) , _fromInt , skewSchurLRCoefficients , isSkewPartition) @@ -20,23 +19,29 @@ import Prelude hiding ((*), (+), (-), (/), (^), (*>), product, sum, fromIntegral, fromInteger, recip) import Algebra.Additive ( (+), (-), sum ) -import Algebra.Field ( (/), recip ) -import Algebra.Ring ( (*), product, one, (^), fromInteger ) -import Algebra.ToInteger ( fromIntegral ) 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 ( - RatioOfPolynomials - , Polynomial - , soleParameter - , constPoly + RatioOfSprays, (%:%) + , Spray + , lone, unitSpray + , (*^), (^**^), (^*^) + , (^+^), (.^), (^-^) + , Powers (..), Term ) import qualified Math.Combinat.Partitions.Integer as MCP import Math.Combinat.Tableaux.LittlewoodRichardson ( _lrRule ) -import Number.Ratio ( T( (:%) ) ) type Partition = [Int] @@ -83,11 +88,13 @@ 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)) + 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) + 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 @@ -111,43 +118,65 @@ where (_, upper) = hookLengths lambda alpha -symbolicHookLengthsProducts :: forall a. AlgRing.C a - => Partition -> (Polynomial a, Polynomial a) +-- | 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 = soleParameter :: Polynomial a + 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 = - constPoly (x!!(jj-1) - fromIntegral ii) - + constPoly (y!!(ii-1) - fromIntegral (jj - 1)) * alpha + (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 = - constPoly (x!!(jj-1) - fromIntegral (ii - 1)) - + constPoly (y!!(ii-1) - fromIntegral jj) * alpha + (x!!(jj-1) - fromIntegral (ii - 1)) +> + ((y!!(ii-1) - fromIntegral jj) *^ alpha) -symbolicHookLengthsProduct :: AlgRing.C a => Partition -> Polynomial a -symbolicHookLengthsProduct lambda = fst hlproducts * snd hlproducts +symbolicHookLengthsProduct :: (Eq a, AlgRing.C a) => Partition -> Spray a +symbolicHookLengthsProduct lambda = lower ^*^ upper where - hlproducts = symbolicHookLengthsProducts lambda + (lower, upper) = symbolicHookLengthsProducts lambda -jackSymbolicCoeffC :: forall a. AlgField.C a => Partition -> RatioOfPolynomials a +jackSymbolicCoeffC :: + forall a. (Eq a, AlgField.C a) => Partition -> RatioOfSprays a jackSymbolicCoeffC lambda = - (constPoly (fromInteger factorialk) * alpha^k) :% jlambda + ((fromIntegral factorialk) *^ alpha^**^k) %:% jlambda where - alpha = soleParameter :: Polynomial a - k = fromIntegral (sum lambda) + alpha = lone 1 :: Spray a + k = sum lambda factorialk = product [2 .. k] jlambda = symbolicHookLengthsProduct lambda -jackSymbolicCoeffPinv :: AlgField.C a => Partition -> Polynomial a -jackSymbolicCoeffPinv lambda = fst $ symbolicHookLengthsProducts lambda +jackSymbolicCoeffPinv :: (Eq a, AlgField.C a) => Partition -> Spray a +jackSymbolicCoeffPinv lambda = lower + where + (lower, _) = symbolicHookLengthsProducts lambda -jackSymbolicCoeffQinv :: AlgField.C a => Partition -> Polynomial a -jackSymbolicCoeffQinv lambda = snd $ 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 @@ -164,48 +193,35 @@ prod2 = product $ map (\x -> (x + alpha) / x) v prod3 = product $ map (\x -> (x + alpha) / x) w -_betaRatioOfPolynomials :: forall a. AlgField.C a - => Partition -> Partition -> Int -> RatioOfPolynomials a -_betaRatioOfPolynomials kappa mu k = - ((x * num1 * num2 * num3) :% (den1 * den2 * den3)) +_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 = soleParameter :: Polynomial a - t = constPoly (fromIntegral k) - constPoly (fromIntegral mukm1) * x + x = lone 1 :: Spray a u = zipWith ( \s kap -> - t - constPoly (fromIntegral $ s-1) + constPoly (fromIntegral kap) * x + (fromIntegral $ k - s + 1) +> ((fromIntegral $ kap - mukm1) *^ x) ) [1 .. k] kappa v = zipWith ( - \s m -> t - constPoly (fromIntegral s) + constPoly (fromIntegral m) * x + \s m -> (fromIntegral $ k - s) +> ((fromIntegral $ m - mukm1) *^ x) ) [1 .. k-1] mu w = zipWith ( - \s m -> constPoly (fromIntegral m) - t - constPoly (fromIntegral s) * x + \s m -> (fromIntegral $ m - k) +> ((fromIntegral $ mukm1 - s) *^ x) ) [1 .. mukm1-1] (_dualPartition mu) num1 = product u - den1 = product $ map (\p -> p + x - constPoly one) u - num2 = product $ map (\p -> p + x) v + 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 + num3 = product $ map (\p -> p ^+^ x) w den3 = product w - -infixr 7 .^ --- | scale by an integer (I do not find this operation in __numeric-prelude__) -(.^) :: (AlgAdd.C a, Eq a) => Int -> a -> a -k .^ x = if k >= 0 - then powerOperation (AlgAdd.+) AlgAdd.zero x k - else (.^) (-k) (AlgAdd.negate x) - where - powerOperation op = - let go acc _ 0 = acc - go acc a n = go (if even n then acc else op acc a) (op a a) (div n 2) - in go _fromInt :: (AlgRing.C a, Eq a) => Int -> a _fromInt k = k .^ AlgRing.one diff --git a/src/Math/Algebra/Jack/SymmetricPolynomials.hs b/src/Math/Algebra/Jack/SymmetricPolynomials.hs --- a/src/Math/Algebra/Jack/SymmetricPolynomials.hs +++ b/src/Math/Algebra/Jack/SymmetricPolynomials.hs @@ -19,7 +19,7 @@ , prettySymmetricNumSpray , prettySymmetricQSpray , prettySymmetricQSpray' - , prettySymmetricOneParameterQSpray + , prettySymmetricParametricQSpray ) where import qualified Algebra.Ring as AlgRing import qualified Data.Foldable as DF @@ -33,11 +33,11 @@ , Spray , QSpray , QSpray' - , OneParameterQSpray + , ParametricQSpray , fromList , getCoefficient , numberOfVariables - , prettyRatioOfQPolynomials + , prettyRatioOfQSpraysXYZ , showNumSpray , showQSpray , showQSpray' @@ -58,8 +58,10 @@ -> Partition -- ^ integer partition -> Spray a msPolynomial n lambda - | n < 0 = error "msPolynomial: negative number of variables." - | not (_isPartition lambda) = error "msPolynomial: invalid partition." + | n < 0 = + error "msPolynomial: negative number of variables." + | not (_isPartition lambda) = + error "msPolynomial: invalid partition." | llambda > n = zeroSpray | otherwise = fromList $ zip permutations coefficients where @@ -105,7 +107,8 @@ -- -- >>> putStrLn $ prettySymmetricNumSpray $ schurPol' 3 [3, 1, 1] -- M[3,1,1] + M[2,2,1] -prettySymmetricNumSpray :: (Num a, Ord a, Show a, AlgRing.C a) => Spray a -> String +prettySymmetricNumSpray :: + (Num a, Ord a, Show a, AlgRing.C a) => Spray a -> String prettySymmetricNumSpray spray = showNumSpray showSymmetricMonomials show mspray where @@ -126,14 +129,14 @@ where mspray = makeMSpray spray --- | Prints a symmetric one-parameter spray as a linear combination of monomial +-- | Prints a symmetric parametric spray as a linear combination of monomial -- symmetric polynomials -- --- >>> putStrLn $ prettySymmetricOneParameterQSpray "a" $ jackSymbolicPol' 3 [3, 1, 1] 'J' --- { 4*a^2 + 10*a + 6 }*M[3,1,1] + { 8*a + 12 }*M[2,2,1] -prettySymmetricOneParameterQSpray :: String -> OneParameterQSpray -> String -prettySymmetricOneParameterQSpray a spray = - showSpray (prettyRatioOfQPolynomials a) ("{ ", " }") +-- >>> putStrLn $ prettySymmetricParametricQSpray ["a"] $ jackSymbolicPol' 3 [3, 1, 1] 'J' +-- { [ 4*a^2 + 10*a + 6 ] }*M[3,1,1] + { [ 8*a + 12 ] }*M[2,2,1] +prettySymmetricParametricQSpray :: [String] -> ParametricQSpray -> String +prettySymmetricParametricQSpray letters spray = + showSpray (prettyRatioOfQSpraysXYZ letters) ("{ ", " }") showSymmetricMonomials mspray where mspray = makeMSpray spray diff --git a/src/Math/Algebra/JackPol.hs b/src/Math/Algebra/JackPol.hs --- a/src/Math/Algebra/JackPol.hs +++ b/src/Math/Algebra/JackPol.hs @@ -18,21 +18,19 @@ import Prelude hiding ((*), (+), (-), (/), (^), (*>), product, sum, fromIntegral, fromInteger) import Algebra.Additive ( (+), (-), sum ) -import Algebra.Module ( (*>) ) -import Algebra.Ring ( (*), product, one, fromInteger ) -import qualified Algebra.Module as AlgMod import qualified Algebra.Field as AlgField +import Algebra.Ring ( (*), product, one, fromInteger ) import qualified Algebra.Ring as AlgRing import Control.Lens ( (.~), element ) import Data.Array ( Array, (!), (//), listArray ) import qualified Data.Map.Strict as DM import Data.Maybe ( fromJust, isJust ) -import Math.Algebra.Jack.Internal ( (.^), _betaratio, jackCoeffC +import Math.Algebra.Jack.Internal ( _betaratio, jackCoeffC , _N, _isPartition, Partition , jackCoeffP, jackCoeffQ , skewSchurLRCoefficients , isSkewPartition, _fromInt ) -import Math.Algebra.Hspray ( (*^), (^**^), (^*^), (^+^) +import Math.Algebra.Hspray ( (*^), (^**^), (^*^), (^+^), (.^) , lone, Spray , zeroSpray, unitSpray ) @@ -57,9 +55,9 @@ False -> error "jackPol: invalid integer partition" True -> case which of 'J' -> resultJ - 'C' -> jackCoeffC lambda alpha *> resultJ - 'P' -> jackCoeffP lambda alpha *> resultJ - 'Q' -> jackCoeffQ lambda alpha *> resultJ + 'C' -> jackCoeffC lambda alpha *^ resultJ + 'P' -> jackCoeffP lambda alpha *^ resultJ + 'Q' -> jackCoeffQ lambda alpha *^ resultJ _ -> error "jackPol: please use 'J', 'C', 'P' or 'Q' for last argument" where resultJ = jac (length x) 0 lambda lambda arr0 one @@ -70,23 +68,25 @@ theproduct nu0 = if nu0 <= 1 then one else product $ map (\i -> i .^ alpha + one) [1 .. nu0-1] - jac :: Int -> Int -> Partition -> Partition -> Array (Int,Int) (Maybe (Spray a)) -> a -> Spray a + jac :: Int -> Int -> Partition -> Partition + -> Array (Int,Int) (Maybe (Spray a)) -> a -> Spray a jac m k mu nu arr beta | null nu || nu!!0 == 0 || m == 0 = unitSpray - | length nu > m && nu!!m > 0 = zeroSpray - | m == 1 = theproduct (nu!!0) *^ (x!!0 ^**^ nu!!0) + | length nu > m && nu !! m > 0 = zeroSpray + | m == 1 = + theproduct (nu!!0) *^ (x!!0 ^**^ nu!!0) | k == 0 && isJust (arr ! (_N lambda nu, m)) = fromJust $ arr ! (_N lambda nu, m) | otherwise = s where - s = go (beta *^ (jac (m-1) 0 nu nu arr one ^*^ ((x!!(m-1)) ^**^ (sum mu - sum nu)))) - (max 1 k) + s = go (beta *^ (jac (m-1) 0 nu nu arr one ^*^ + ((x!!(m-1)) ^**^ (sum mu - sum nu)))) (max 1 k) go :: Spray a -> Int -> Spray a go !ss ii | length nu < ii || nu!!(ii-1) == 0 = ss | otherwise = let u = nu!!(ii-1) in - if length nu == ii && u > 0 || u > nu!!ii + if length nu == ii && u > 0 || u > nu !! ii then let nu' = (element (ii-1) .~ u-1) nu in let gamma = beta * _betaratio mu nu ii alpha in @@ -96,7 +96,8 @@ else if nu'!!0 == 0 then - go (ss ^+^ (gamma *^ (x!!(m-1) ^**^ sum mu))) (ii + 1) + go (ss ^+^ (gamma *^ (x!!(m-1) ^**^ sum mu))) + (ii + 1) else let arr' = arr // [((_N lambda nu, m), Just ss)] in let jck = jac (m-1) 0 nu' nu' arr' one in @@ -141,12 +142,14 @@ x = map lone [1 .. n] :: [Spray a] nll = _N lambda lambda arr0 = listArray ((1, 1), (nll, n)) (replicate (nll * n) Nothing) - sch :: Int -> Int -> [Int] -> Array (Int,Int) (Maybe (Spray a)) -> Spray a + sch :: + Int -> Int -> [Int] -> Array (Int,Int) (Maybe (Spray a)) -> Spray a sch m k nu arr | null nu || nu!!0 == 0 || m == 0 = unitSpray | length nu > m && nu!!m > 0 = zeroSpray | m == 1 = x!!0 ^**^ nu!!0 - | isJust (arr ! (_N lambda nu, m)) = fromJust $ arr ! (_N lambda nu, m) + | isJust (arr ! (_N lambda nu, m)) = + fromJust $ arr ! (_N lambda nu, m) | otherwise = s where s = go (sch (m-1) 1 nu arr) k @@ -160,14 +163,17 @@ let nu' = (element (ii-1) .~ u-1) nu in if u > 1 then - go (ss ^+^ ((x!!(m-1)) ^*^ sch m ii nu' arr)) (ii + 1) + go (ss ^+^ ((x!!(m-1)) ^*^ sch m ii nu' arr)) + (ii + 1) else - if nu'!!0 == 0 + if nu' !! 0 == 0 then go (ss ^+^ (x!!(m-1))) (ii + 1) else - let arr' = arr // [((_N lambda nu, m), Just ss)] in - go (ss ^+^ ((x!!(m-1)) ^*^ sch (m-1) 1 nu' arr')) (ii + 1) + let arr' = + arr // [((_N lambda nu, m), Just ss)] in + go (ss ^+^ ((x!!(m-1)) ^*^ sch (m-1) 1 nu' arr')) + (ii + 1) else go ss (ii + 1) @@ -192,7 +198,4 @@ where lrCoefficients = skewSchurLRCoefficients lambda mu f :: Spray a -> Partition -> Int -> Spray a - f spray nu k = spray ^+^ (_fromInt' k) AlgMod.*> (schurPol n nu) - _fromInt' :: Int -> a - _fromInt' = _fromInt - + f spray nu k = spray ^+^ (_fromInt k) *^ (schurPol n nu) diff --git a/src/Math/Algebra/JackSymbolicPol.hs b/src/Math/Algebra/JackSymbolicPol.hs --- a/src/Math/Algebra/JackSymbolicPol.hs +++ b/src/Math/Algebra/JackSymbolicPol.hs @@ -12,35 +12,35 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Math.Algebra.JackSymbolicPol - (jackSymbolicPol', jackSymbolicPol) + ( jackSymbolicPol, jackSymbolicPol' ) where import Prelude hiding ((*), (+), (-), (/), (^), (*>), product, sum, fromIntegral, fromInteger, recip) import Algebra.Additive ( (+), (-), sum ) -import Algebra.Ring ( (*), product, one ) -import Algebra.ToInteger ( fromIntegral ) +import Algebra.Ring ( (*), product ) +import Algebra.Field ( recip ) import qualified Algebra.Field as AlgField import Control.Lens ( (.~), element ) import Data.Array ( Array, (!), (//), listArray ) import Data.Maybe ( fromJust, isJust ) -import Math.Algebra.Jack.Internal ( _betaRatioOfPolynomials +import Math.Algebra.Jack.Internal ( _betaRatioOfSprays , jackSymbolicCoeffC , jackSymbolicCoeffPinv , jackSymbolicCoeffQinv , _N, _isPartition, Partition ) -import Math.Algebra.Hspray ( (*^), (^**^), (^*^), (^+^) - , lone, OneParameterSpray, OneParameterQSpray - , Polynomial, soleParameter - , constPoly, RatioOfPolynomials +import Math.Algebra.Hspray ( (*^), (^*^), (^+^), (.^) + , lone, lone' + , ParametricSpray, ParametricQSpray + , Spray, asRatioOfSprays + , RatioOfSprays, unitRatioOfSprays , zeroSpray, unitSpray ) -import Number.Ratio ( fromValue, recip ) -- | Jack polynomial with symbolic Jack parameter jackSymbolicPol' :: Int -- ^ number of variables -> Partition -- ^ partition of integers -> Char -- ^ which Jack polynomial, @'J'@, @'C'@, @'P'@ or @'Q'@ - -> OneParameterQSpray + -> ParametricQSpray jackSymbolicPol' = jackSymbolicPol -- | Jack polynomial with symbolic Jack parameter @@ -48,63 +48,66 @@ => Int -- ^ number of variables -> Partition -- ^ partition of integers -> Char -- ^ which Jack polynomial, @'J'@, @'C'@, @'P'@ or @'Q'@ - -> OneParameterSpray a + -> ParametricSpray a jackSymbolicPol n lambda which = case _isPartition lambda of False -> error "jackSymbolicPol: invalid integer partition" True -> case which of 'J' -> resultJ 'C' -> jackSymbolicCoeffC lambda *^ resultJ - 'P' -> recip (fromValue (jackSymbolicCoeffPinv lambda)) *^ resultJ - 'Q' -> recip (fromValue (jackSymbolicCoeffQinv lambda)) *^ resultJ + 'P' -> recip (asRatioOfSprays (jackSymbolicCoeffPinv lambda)) *^ resultJ + 'Q' -> recip (asRatioOfSprays (jackSymbolicCoeffQinv lambda)) *^ resultJ _ -> error "jackSymbolicPol: please use 'J', 'C', 'P' or 'Q' for last argument" where - alpha = soleParameter :: Polynomial a - resultJ = jac (length x) 0 lambda lambda arr0 one + alpha = lone 1 :: Spray a + resultJ = jac n 0 lambda lambda arr0 unitRatioOfSprays nll = _N lambda lambda - x = map lone [1 .. n] :: [OneParameterSpray a] + -- x = map lone [1 .. n] :: [ParametricSpray a] arr0 = listArray ((1, 1), (nll, n)) (replicate (nll * n) Nothing) - theproduct :: Int -> RatioOfPolynomials a + theproduct :: Int -> RatioOfSprays a theproduct nu0 = if nu0 <= 1 - then fromValue (constPoly one) - else fromValue $ product $ map - (\i -> constPoly (fromIntegral i) * alpha + constPoly one) + then unitRatioOfSprays + else asRatioOfSprays $ product $ map + (\i -> i .^ alpha ^+^ unitSpray) [1 .. nu0-1] jac :: Int -> Int -> Partition -> Partition - -> Array (Int,Int) (Maybe (OneParameterSpray a)) - -> RatioOfPolynomials a -> OneParameterSpray a + -> Array (Int,Int) (Maybe (ParametricSpray a)) + -> RatioOfSprays a -> ParametricSpray a jac m k mu nu arr beta - | null nu || nu!!0 == 0 || m == 0 = unitSpray - | length nu > m && nu!!m > 0 = zeroSpray - | m == 1 = theproduct (nu!!0) *^ (x!!0 ^**^ nu!!0) + | null nu || nu !! 0 == 0 || m == 0 = unitSpray + | length nu > m && nu !! m > 0 = zeroSpray + | m == 1 = + theproduct (nu !! 0) *^ (lone' 1 (nu !! 0)) | k == 0 && isJust (arr ! (_N lambda nu, m)) = fromJust $ arr ! (_N lambda nu, m) | otherwise = s where - s = go (beta *^ (jac (m-1) 0 nu nu arr one ^*^ ((x!!(m-1)) ^**^ (sum mu - sum nu)))) - (max 1 k) - go :: OneParameterSpray a -> Int -> OneParameterSpray a + s = go (beta *^ (jac (m-1) 0 nu nu arr unitRatioOfSprays ^*^ + (lone' m (sum mu - sum nu)))) (max 1 k) + go :: ParametricSpray a -> Int -> ParametricSpray a go !ss ii | length nu < ii || nu!!(ii-1) == 0 = ss | otherwise = let u = nu!!(ii-1) in - if length nu == ii && u > 0 || u > nu!!ii + if length nu == ii && u > 0 || u > nu !! ii then let nu' = (element (ii-1) .~ u-1) nu in - let gamma = _betaRatioOfPolynomials mu nu ii * beta in + let gamma = _betaRatioOfSprays mu nu ii * beta in if u > 1 then go (ss ^+^ jac m ii mu nu' arr gamma) (ii + 1) else - if nu'!!0 == 0 + if nu' !! 0 == 0 then - go (ss ^+^ (gamma *^ (x!!(m-1) ^**^ sum mu))) (ii + 1) + go (ss ^+^ (gamma *^ (lone' m (sum mu)))) + (ii + 1) else let arr' = arr // [((_N lambda nu, m), Just ss)] in - let jck = jac (m-1) 0 nu' nu' arr' one in + let jck = + jac (m-1) 0 nu' nu' arr' unitRatioOfSprays in let jck' = gamma *^ (jck ^*^ - (x!!(m-1) ^**^ (sum mu - sum nu'))) in + (lone' m (sum mu - sum nu'))) in go (ss ^+^ jck') (ii + 1) else go ss (ii + 1) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,15 +1,18 @@ -module Main where +module Main ( main ) where import Data.Ratio ( (%) ) -import Math.Algebra.Hspray ( (^+^), (*^), (^*^), (^**^), Spray, lone +import Math.Algebra.Hspray ( (^+^), (*^), (^*^), (^**^) + , Spray, lone , evalSpray - , evalOneParameterSpray, evalOneParameterSpray' - , Rational' ) + , evalParametricSpray' + , substituteParameters + , canCoerceToSimpleParametricSpray + ) import qualified Math.Algebra.Hspray as Hspray import Math.Algebra.Jack ( schur, skewSchur , jack', zonal' ) import Math.Algebra.Jack.HypergeoPQ ( hypergeoPQ ) import Math.Algebra.Jack.SymmetricPolynomials ( isSymmetricSpray - , prettySymmetricOneParameterQSpray ) + , prettySymmetricParametricQSpray ) import Math.Algebra.JackPol ( zonalPol, zonalPol', jackPol' , schurPol, schurPol', skewSchurPol' ) import Math.Algebra.JackSymbolicPol ( jackSymbolicPol' ) @@ -28,15 +31,19 @@ "Tests" [ - testCase "jackSymbolicPol" $ do + testCase "jackSymbolicPol J" $ do let jp = jackSymbolicPol' 3 [3, 1] 'J' - v = evalOneParameterSpray' jp 2 [-3, 4, 5] + v = evalParametricSpray' jp [2] [-3, 4, 5] assertEqual "" v 1488 + , testCase "jackSymbolicPol J has polynomial coefficients only" $ do + let jp = jackSymbolicPol' 3 [3, 1] 'J' + assertBool "" (canCoerceToSimpleParametricSpray jp) + , testCase "jackSymbolicPol C" $ do let jp = jackSymbolicPol' 4 [3, 1] 'C' - zp = zonalPol 4 [3, 1] :: Spray Rational' - p = evalOneParameterSpray jp 2 + zp = zonalPol 4 [3, 1] :: Spray Rational + p = substituteParameters jp [2] assertEqual "" zp p , testCase "jackSymbolicPol Q is symmetric" $ do @@ -47,18 +54,18 @@ let jp = jackSymbolicPol' 5 [3, 2, 1] 'P' assertBool "" (isSymmetricSpray jp) - , testCase "prettySymmetricOneParameterQSpray - jack J" $ do + , testCase "prettySymmetricParametricQSpray - jack J" $ do let jp = jackSymbolicPol' 3 [3, 1, 1] 'J' assertEqual "" - (prettySymmetricOneParameterQSpray "a" jp) - ("{ 4*a^2 + 10*a + 6 }*M[3,1,1] + { 8*a + 12 }*M[2,2,1]") + (prettySymmetricParametricQSpray ["a"] jp) + ("{ [ 4*a^2 + 10*a + 6 ] }*M[3,1,1] + { [ 8*a + 12 ] }*M[2,2,1]") - , testCase "prettySymmetricOneParameterQSpray - jack C" $ do + , testCase "prettySymmetricParametricQSpray - jack C" $ do let jp = jackSymbolicPol' 3 [3, 1, 1] 'C' assertEqual "" - (prettySymmetricOneParameterQSpray "a" jp) + (prettySymmetricParametricQSpray ["a"] jp) ("{ [ 20*a^2 ] %//% [ a^2 + (5/3)*a + (2/3) ] }*M[3,1,1] + { [ 40*a^2 ] %//% [ a^3 + (8/3)*a^2 + (7/3)*a + (2/3) ] }*M[2,2,1]") - + , testCase "jackPol" $ do let jp = jackPol' 2 [3, 1] (2 % 1) 'J' v = evalSpray jp [1, 1]