1 files changed, 53 insertions, 0 deletions
diff --git a/Math/Combinatorics/RobinsonSchensted.hs b/Math/Combinatorics/RobinsonSchensted.hs
new file mode 100644
index 0000000..ffefc5a
--- /dev/null
+++ b/Math/Combinatorics/RobinsonSchensted.hs
@@ -0,0 +1,53 @@
+----------------------------------------------------------------------------
+-- 
+-- Copyright   :  (C) 2017 Yuchen Pei
+-- License     :  GPLv3+
+--
+-- Maintainer  :  Yuchen Pei
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+module RobinsonSchensted where
+import YoungTableaux
+
+-- |Plactic monoid
+instance Ord a => Monoid (SSYT a)
+  where
+    mempty = S $ repeat []
+    mappend s1 s2 = foldl rowInsert s1 (toRowWord s2)
+
+-- |Row insertion algorithm
+rowInsert :: Ord a => SSYT a -> a -> SSYT a
+rowInsert (S t) = toSSYT . (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))
+
+colInsert :: Ord a => SSYT a -> a -> SSYT a
+colInsert st = transpose . (colInsert' (transpose st))
+
+colInsert' :: Ord a => SSYT a -> a -> SSYT a
+colInsert' (S t) = toSSYT . (colInsert'' t)
+
+colInsert'' :: Ord a => [[a]] -> a -> [[a]]
+colInsert'' 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
+
+-- |The Robinson-Schensted algorithm with column insertion
+robinsonSchensted' :: Ord a => [a] -> SSYT a
+robinsonSchensted' = foldl colInsert mempty
+
+prop_ReduceWord_RobinsonSchensted :: [Int] -> Bool
+prop_ReduceWord_RobinsonSchensted xs = (toRowWord $ robinsonSchensted xs) == (reduceWord xs)
+