From f1ad02cf7a29e3ad007bf58ac13ea8da96bfcd39 Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Thu, 13 Jul 2017 15:10:58 -0400
Subject: 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]
---
 Math/Combinatorics/PitmanTransform.hs | 38 +++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

(limited to 'Math/Combinatorics/PitmanTransform.hs')

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))
-- 
cgit v1.2.3