From 513bc5e8933d4e16fe8eeb2d2f997a12a6a96a4a Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Thu, 13 Jul 2017 12:27:51 -0400
Subject: Checkpoint

---
 Math/Combinatorics/YoungTableaux.hs | 43 ++++++++++++++++---------------------
 1 file changed, 18 insertions(+), 25 deletions(-)

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

diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs
index eedb971..40b62e9 100644
--- a/Math/Combinatorics/YoungTableaux.hs
+++ b/Math/Combinatorics/YoungTableaux.hs
@@ -10,41 +10,28 @@
 ----------------------------------------------------------------------------
 --import Data.Monoid ((<>))
 
+module YoungTableaux where
+import Prelude hiding (Word)
+import qualified Data.List as L
+
 data SSYT a = S [[a]]
-data Wrd a = W [a] deriving Show
+data Word a = W [a] deriving Show
+data GTP a = GTP [[a]] deriving Show
 
 -- |Knuth equivalence
-instance Ord a => Eq (Wrd a)
+instance Ord a => Eq (Word a)
   where (W xs) == (W ys) = (reduceWord xs) == (reduceWord ys)
 
 -- |Show a tableau
 instance Show a => Show (SSYT a)
   where show (S xs) = "S " ++ (show $ truncList xs)
 
--- |Plactic monoid
-instance Ord a => Monoid (SSYT a)
-  where
-    mempty = S $ repeat []
-    mappend s1 s2 = foldl rowInsert s1 (toRowWord s2)
-
 -- |Convert a nested list to an SSYT
 toSSYT :: [[a]] -> SSYT a
 toSSYT t = S $ (truncList t) ++ (repeat [])
 
--- |Row insertion algorithm
-rowInsert :: Ord a => SSYT a -> a -> SSYT a
-rowInsert (S t) = S . rowInsert' t
-
--- |Row insertion algorithm on an SSYT as a nested list
-rowInsert' :: Ord a => [[a]] -> a -> [[a]]
-rowInsert' t x = 
-  case break (>x) (head t) of
-    (r, []) -> (r ++ [x]):(tail t)
-    (r1, r2) -> (r1 ++ x:(tail r2)):(rowInsert' (tail t) (head r2))
-
--- |The Robinson-Schensted algorithm
-robinsonSchensted :: Ord a => [a] -> SSYT a
-robinsonSchensted = foldl rowInsert mempty
+transpose :: SSYT a -> SSYT a
+transpose (S t) = S $ (L.transpose $ truncList t) ++ (repeat [])
 
 -- |Truncate a nested list (tableau) by disgarding empty rows
 truncList :: [[a]] -> [[a]]
@@ -92,6 +79,13 @@ reduceWord' xs (u, v, w) ys =
                     else reduceWord' (init xs) (last xs, v, u) (w:ys)
       else reduceWord' (init xs) (last xs, u, v) (w:ys)
 
+sSYT2GTP :: SSYT Int -> GTP Int
+sSYT2GTP (S t) = GTP $ sSYT2GTP' (maximum $ maximum <$> (truncList t)) []
+    where sSYT2GTP' :: Int -> [[Int]] -> [[Int]]
+          sSYT2GTP' 0 ys = ys
+          sSYT2GTP' k ys = sSYT2GTP' (k - 1) $ ((length . filter (<=k)) <$> (take k t)):ys
+
+
 -- |QuickCheck properties
 prop_ReduceWord :: [Int] -> Bool
 prop_ReduceWord = isRowWord . reduceWord
@@ -99,9 +93,6 @@ prop_ReduceWord = isRowWord . reduceWord
 prop_ReduceWord' :: [Int] -> Bool
 prop_ReduceWord' xs = (length xs) == (length $ reduceWord xs)
 
-prop_ReduceWord_RobinsonSchensted :: [Int] -> Bool
-prop_ReduceWord_RobinsonSchensted xs = (toRowWord $ robinsonSchensted xs) == (reduceWord xs)
-
 -- |Another implementation of reduceWord' in case of performance difference.
 reduceWord'' :: Ord a => [a] -> [a] -> [a]
 reduceWord'' [] (u:v:w:ys) =
@@ -119,3 +110,5 @@ reduceWord'' xs (u:v:w:ys) =
                     else reduceWord'' (init xs) (last xs:v:u:w:ys)
       else reduceWord'' (init xs) (last xs:u:v:w:ys)
 reduceWord'' xs ys = xs ++ ys
+
+
-- 
cgit v1.2.3