---------------------------------------------------------------------------- -- -- 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.Field.Base (Q)-- for Q import Math.Algebra.LinearAlgebra import Prelude hiding ( (*>), Word ) import qualified Data.List as L --pitman :: (Fractional a, Ord a) => Type -> Int -> [a] -> [a] pitman :: Type -> Int -> [[Q]] -> [[Q]] pitman t n xs = foldr s xs (longestElement \$ simpleSystem t n) s :: [Q] -> [[Q]] -> [[Q]] --s :: (Fractional a, Ord a) => [a] -> [a] -> [a] s alpha f = f <<->> fmap (*> alpha) (cumMin \$ dynkinIndex alpha <\$> f) --cumMin :: Ord a => [a] -> [a] cumMin :: [Q] -> [Q] cumMin = scanl1 min cumSum :: [Q] -> [Q] cumSum = scanl1 (+) word2Path :: Word Int -> [[Q]] word2Path (W []) = [] word2Path (W xs) = L.transpose \$ cumSum <\$> [0:(indicator (==k) xs) | k <- [1..maximum xs]] indicator :: (a -> Bool) -> [a] -> [Q] indicator f xs = (\x -> if f x then 1 else 0) <\$> xs 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 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) 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))