1 files changed, 44 insertions, 22 deletions

diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs
index 40b62e9..683519f 100644
--- a/Math/Combinatorics/YoungTableaux.hs
+++ b/Math/Combinatorics/YoungTableaux.hs
@@ -16,16 +16,27 @@ import qualified Data.List as L
 
 data SSYT a = S [[a]]
 data Word a = W [a] deriving Show
-data GTP a = GTP [[a]] deriving Show
+data GTP a = GTP [[a]]
+
+instance (Eq a, Num a) => Eq (GTP a)
+  where (GTP xs) == (GTP ys) = (truncGTP xs) == (truncGTP ys)
+
+instance (Eq a, Num a, Show a) => Show (GTP a)
+  where show (GTP xs) = "GTP " ++ (show $ truncGTP xs)
 
 -- |Knuth equivalence
 instance Ord a => Eq (Word a)
-  where (W xs) == (W ys) = (reduceWord xs) == (reduceWord ys)
+  where w == w' = (reduceWord w) == (reduceWord w')
 
 -- |Show a tableau
 instance Show a => Show (SSYT a)
   where show (S xs) = "S " ++ (show $ truncList xs)
 
+instance Monoid (Word a)
+  where 
+    mempty = W []
+    mappend (W w) (W w') = W (w ++ w')
+
 -- |Convert a nested list to an SSYT
 toSSYT :: [[a]] -> SSYT a
 toSSYT t = S $ (truncList t) ++ (repeat [])
@@ -38,12 +49,12 @@ truncList :: [[a]] -> [[a]]
 truncList = fst . break null
 
 -- |Convert an SSYT to a row word
-toRowWord :: Ord a => SSYT a -> [a]
-toRowWord (S t) = concat $ reverse $ truncList t
+toRowWord :: Ord a => SSYT a -> Word a
+toRowWord (S t) = W $ mconcat $ reverse $ truncList t
 
 -- |Whether a word is a row word
-isRowWord :: Ord a => [a] -> Bool
-isRowWord = isRowWord' [] []
+isRowWord :: Ord a => Word a -> Bool
+isRowWord (W w) = isRowWord' [] [] w
 
 isRowWord' :: Ord a => [a] -> [a] -> [a] -> Bool
 isRowWord' _  ys [] = ys == []
@@ -55,24 +66,27 @@ isRowWord' xs ys zs =
     else ys == [] && isRowWord' [] xs zs
 
 -- |Reduce a word to a row word
-reduceWord :: Ord a => [a] -> [a]
-reduceWord xs
+reduceWord :: Ord a => Word a -> Word a
+reduceWord (W xs) = W $ reduceWord'' xs
+
+reduceWord'' :: Ord a => [a] -> [a]
+reduceWord'' xs
   | length xs <= 2 = xs
-  | otherwise      = let ys = reduceWord $ init xs in reduceWord' (init $ init ys) (last $ init ys, last ys, last xs) []
+  | otherwise      = let ys = reduceWord'' $ init xs in reduceWord' (init $ init ys) (last $ init ys, last ys, last xs) []
   {-- | otherwise      = let ys = reduceWord $ init xs in 
                      let (zs, ws) = splitAt (length ys - 2) ys in
                        reduceWord'' zs (ws ++ [last xs]) --}
 
 reduceWord' :: Ord a => [a] -> (a, a, a) -> [a] -> [a]
 reduceWord' [] (u, v, w) ys =
-  if isRowWord (u:v:w:ys)
+  if isRowWord (W $ u:v:w:ys)
     then u:v:w:ys
     else if w < v && u <= v
       then if u > w then u:w:v:ys
                     else v:u:w:ys
       else u:v:w:ys
 reduceWord' xs (u, v, w) ys =
-  if isRowWord $ xs ++ (u:v:w:ys)
+  if isRowWord $ W $ xs ++ (u:v:w:ys)
     then xs ++ (u:v:w:ys)
     else if w < v && u <= v 
       then if u > w then reduceWord' (init xs) (last xs, u, w) (v:ys)
@@ -80,35 +94,43 @@ reduceWord' xs (u, v, w) ys =
       else reduceWord' (init xs) (last xs, u, v) (w:ys)
 
 sSYT2GTP :: SSYT Int -> GTP Int
+sSYT2GTP (S ([]:ys)) = GTP []
 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
 
 
+truncGTP :: (Eq a, Num a) => [[a]] -> [[a]]
+truncGTP [] = []
+truncGTP [[x]] = if x == 0 then [] else [[x]]
+truncGTP xs = if ys == 0:zs then truncGTP $ init xs else xs
+    where ys = last xs
+          zs = last $ init xs
+
 -- |QuickCheck properties
 prop_ReduceWord :: [Int] -> Bool
-prop_ReduceWord = isRowWord . reduceWord
+prop_ReduceWord = isRowWord . reduceWord . W
 
 prop_ReduceWord' :: [Int] -> Bool
-prop_ReduceWord' xs = (length xs) == (length $ reduceWord xs)
+prop_ReduceWord' xs = (length xs) == (length ys) where (W ys) = reduceWord $ W xs
 
 -- |Another implementation of reduceWord' in case of performance difference.
-reduceWord'' :: Ord a => [a] -> [a] -> [a]
-reduceWord'' [] (u:v:w:ys) =
-  if isRowWord (u:v:w:ys)
+reduceWord''' :: Ord a => [a] -> [a] -> [a]
+reduceWord''' [] (u:v:w:ys) =
+  if isRowWord $ W (u:v:w:ys)
     then u:v:w:ys
     else if w < v && u <= v
       then if u > w then u:w:v:ys
                     else v:u:w:ys
       else u:v:w:ys
-reduceWord'' xs (u:v:w:ys) =
-  if isRowWord $ xs ++ (u:v:w:ys)
+reduceWord''' xs (u:v:w:ys) =
+  if isRowWord $ W $ xs ++ (u:v:w:ys)
     then xs ++ (u:v:w:ys)
     else if w < v && u <= v 
-      then if u > w then reduceWord'' (init xs) (last xs:u:w:v: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
+      then if u > w then reduceWord''' (init xs) (last xs:u:w:v: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