aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeshiba <baconp@gmail.com>2017-06-23 16:16:15 -0400
committerJeshiba <baconp@gmail.com>2017-06-23 16:16:15 -0400
commit6134f1f3b075376bdb6a9a086191c2bd35028877 (patch)
treef3c204cb0782fee640b6bfbae92ac95bbad556c0
parent21b4068e2570497b168c6b1038bd499f45ce473e (diff)
added SSYT and Wrd datatypes; added comments.
-rw-r--r--Math/Combinatorics/.YoungTableaux.hs.swpbin12288 -> 0 bytes
-rw-r--r--Math/Combinatorics/YoungTableaux.hs60
2 files changed, 38 insertions, 22 deletions
diff --git a/Math/Combinatorics/.YoungTableaux.hs.swp b/Math/Combinatorics/.YoungTableaux.hs.swp
deleted file mode 100644
index 0e4e515..0000000
--- a/Math/Combinatorics/.YoungTableaux.hs.swp
+++ /dev/null
Binary files differ
diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs
index 8964469..ada2da1 100644
--- a/Math/Combinatorics/YoungTableaux.hs
+++ b/Math/Combinatorics/YoungTableaux.hs
@@ -1,36 +1,52 @@
-type Tableau a = [[a]]
---data SSYT a = S [[a]]
-type SSYT a = [[a]]
-type GT a = [[a]]
+--import Data.Monoid ((<>))
---instance Show a => Show (SSYT a)
- --where show (S xs) = show $ fst $ break null xs
+data SSYT a = S [[a]]
+data Wrd a = W [a] deriving Show
+-- |Knuth equivalence
+instance Ord a => Eq (Wrd 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 t = truncInfList . rowInsert' (t ++ (repeat []))
+rowInsert (S t) = S . rowInsert' t
-rowInsert' :: Ord a => SSYT a -> a -> SSYT a
+-- |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 = truncInfList . foldl rowInsert' (repeat [])
+robinsonSchensted = foldl rowInsert mempty
-truncInfList :: [[a]] -> [[a]]
-truncInfList = fst . break null
+-- |Truncate a nested list (tableau) by disgarding empty rows
+truncList :: [[a]] -> [[a]]
+truncList = fst . break null
+-- |Convert an SSYT to a row word
toRowWord :: Ord a => SSYT a -> [a]
-toRowWord = concat . reverse
+toRowWord (S t) = concat $ reverse $ truncList t
-{--
-rowInsert :: Ord a => SSYT a -> a -> SSYT a
-rowInsert (S t) x =
- case break (>x) (head t) of
- (r, []) -> S $ (r ++ [x]):(tail t)
- (r1, r2) -> let S s = rowInsert (S (tail t)) (head r2) in S $ (r1 ++ x:(tail r2)):s
- --}
+-- |Whether a word is a row word
+isRowWord :: Ord a => [a] -> Bool
+isRowWord = isRowWord' [] []
isRowWord' :: Ord a => [a] -> [a] -> [a] -> Bool
isRowWord' _ ys [] = ys == []
@@ -41,9 +57,7 @@ isRowWord' xs ys zs =
then head ys > head zs && (isRowWord' (xs ++ [head zs]) (tail ys) (tail zs))
else ys == [] && isRowWord' [] xs zs
-isRowWord :: Ord a => [a] -> Bool
-isRowWord = isRowWord' [] []
-
+-- |Reduce a word to a row word
reduceWord :: Ord a => [a] -> [a]
reduceWord xs
| length xs <= 2 = xs
@@ -68,6 +82,7 @@ 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)
+-- |QuickCheck properties
prop_ReduceWord :: [Int] -> Bool
prop_ReduceWord = isRowWord . reduceWord
@@ -77,6 +92,7 @@ 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) =
if isRowWord (u:v:w:ys)