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))