diff options
author | Jeshiba <baconp@gmail.com> | 2017-07-13 15:10:58 -0400 |
---|---|---|
committer | Jeshiba <baconp@gmail.com> | 2017-07-13 15:10:58 -0400 |
commit | f1ad02cf7a29e3ad007bf58ac13ea8da96bfcd39 (patch) | |
tree | 89ec104bf27f8e97e90dfc2c45fc4d8b49b87a1d /Math/Combinatorics/PitmanTransform.hs | |
parent | 513bc5e8933d4e16fe8eeb2d2f997a12a6a96a4a (diff) |
added PitmanTransform and RobinsonSchensted.
- Implemented Pitman's transforms, relying on RootSystem.hs
- Tested by checking equality with Column insertion.
- Moved row insertion from YoungTableaux to RobinsonSchensted
- Implemented column insertion
- Using Word where previously was [a]
Diffstat (limited to 'Math/Combinatorics/PitmanTransform.hs')
-rw-r--r-- | Math/Combinatorics/PitmanTransform.hs | 38 |
1 files changed, 38 insertions, 0 deletions
diff --git a/Math/Combinatorics/PitmanTransform.hs b/Math/Combinatorics/PitmanTransform.hs index 19a437f..e6eea85 100644 --- a/Math/Combinatorics/PitmanTransform.hs +++ b/Math/Combinatorics/PitmanTransform.hs @@ -1,3 +1,13 @@ +---------------------------------------------------------------------------- +-- +-- 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 @@ -23,7 +33,35 @@ 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)) |