---------------------------------------------------------------------------- -- -- Copyright : (C) 2017 Yuchen Pei -- License : GPLv3+ -- -- Maintainer : Yuchen Pei -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- --import Math.Combinatorics.RootSystem hiding (s) import RootSystem hiding (s) import YoungTableaux import RobinsonSchensted import Math.Algebra.LinearAlgebra import Prelude hiding ( (*>), Word ) import Test.QuickCheck import qualified Data.List as L import Data.Ratio -- |pitman t n xs is the Pitman's transform of type t_n acting on path xs. It pre-processes xs by prepending a row of zeros to the input and post-processes by removing the first row of the output pitman :: Type -> Int -> [[Q]] -> [[Q]] pitman t n xs = tail \$ foldr s (prependWithZero xs) (longestElement \$ simpleSystem t n) prependWithZero :: [[Q]] -> [[Q]] prependWithZero [] = [] prependWithZero xs = (replicate (length \$ head xs) 0) : xs -- |s alpha f: the cumulative infimum of twice the projection of path f on root alpha s :: [Q] -> [[Q]] -> [[Q]] s alpha f = f <<->> fmap (*> alpha) (cumMin \$ dynkinIndex alpha <\$> f) cumMin :: [Q] -> [Q] cumMin = scanl1 min cumSum :: [Q] -> [Q] cumSum = scanl1 (+) -- |transform a word to a path word2Path :: Word Int -> [[Q]] word2Path (W []) = [] word2Path (W xs) = L.transpose \$ cumSum <\$> [indicator (==k) xs | k <- [1..maximum xs]] -- |indicator function indicator :: (a -> Bool) -> [a] -> [Q] indicator f xs = (\x -> if f x then 1 else 0) <\$> xs -- |Pitman's transform of type A pitmanA :: [[Q]] -> [[Q]] pitmanA [] = [] pitmanA xs = let n = length \$ head xs in if n == 1 then xs else pitman A (n - 1) xs pitmanAShape :: [[Q]] -> [Q] pitmanAShape = last . pitmanA -- |RS via Pitman's transform of type A pitmanAGTP :: [[Q]] -> GTP Q pitmanAGTP = GTP . (pitmanAGTP' []) where pitmanAGTP' :: [[Q]] -> [[Q]] -> [[Q]] pitmanAGTP' xs [] = xs pitmanAGTP' xs ys = pitmanAGTP' ((pitmanAShape ys):xs) (L.transpose \$ init \$ L.transpose ys) -- |QuickCheck property that the Pitman's transform of type A coincides with RS algorithm prop_Pitman_RobinsonSchensted :: [Int] -> Bool prop_Pitman_RobinsonSchensted xs = let w = prop_Pitman_RobinsonSchensted_sanitise xs in (pitmanAGTP \$ word2Path w) == (gTPFromInt \$ sSYT2GTP \$ robinsonSchensted' w) gTPFromInt :: GTP Int -> GTP Q gTPFromInt (GTP xs) = GTP \$ fmap (fmap fromIntegral) xs prop_Pitman_RobinsonSchensted_sanitise :: [Int] -> Word Int prop_Pitman_RobinsonSchensted_sanitise = W . (fmap (\t -> abs t + 1)) -- |QuickCheck generator that generates rational numbers with small numerators and denominators smallRational :: Gen Q smallRational = do x <- smallInt y <- smallInt return \$ (toInteger x) % (toInteger (abs y + 1)) --return \$ (toInteger x) / (toInteger (abs y + 1)) -- this line does not work for Q = Math.Algebra.Field.Base.Q - Couldn't match type ‘Integer’ with ‘Q’ smallInt :: Gen Int smallInt = getSmall <\$> (arbitrary :: Gen (Small Int)) arbRational :: Gen Q arbRational = arbitrary randomQMatrix :: Int -> Gen [[Q]] randomQMatrix n = vectorOf 20 \$ vectorOf n smallRational -- |QuickCheck property that the output of the Pitman's transform is in the Weyl Chamber, for any type. prop_Pitman_WeylChamber :: Int -> Property prop_Pitman_WeylChamber m = let (t, n) = int2TypeInt m in forAll (randomQMatrix \$ dimensionOfHostSpace t n) (\xs -> isInWeylChamber (simpleSystem t n) (last \$ pitman t n xs))