aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeshiba <baconp@gmail.com>2017-06-23 12:31:56 -0400
committerJeshiba <baconp@gmail.com>2017-06-23 12:31:56 -0400
commit21b4068e2570497b168c6b1038bd499f45ce473e (patch)
tree81259b3b447ef613d3045a892d7d7b487b0eab74
parentb7095e3e6e703a1bbf1d2d4f4a20f4084d472500 (diff)
added robinsonSchensted and conversion to row words.
-rw-r--r--Math/Combinatorics/.YoungTableaux.hs.swpbin0 -> 12288 bytes
-rw-r--r--Math/Combinatorics/YoungTableaux.hs82
-rw-r--r--Math/Combinatorics/test.hs4
3 files changed, 83 insertions, 3 deletions
diff --git a/Math/Combinatorics/.YoungTableaux.hs.swp b/Math/Combinatorics/.YoungTableaux.hs.swp
new file mode 100644
index 0000000..0e4e515
--- /dev/null
+++ b/Math/Combinatorics/.YoungTableaux.hs.swp
Binary files differ
diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs
index e365ee7..8964469 100644
--- a/Math/Combinatorics/YoungTableaux.hs
+++ b/Math/Combinatorics/YoungTableaux.hs
@@ -1,3 +1,37 @@
+type Tableau a = [[a]]
+--data SSYT a = S [[a]]
+type SSYT a = [[a]]
+type GT a = [[a]]
+
+--instance Show a => Show (SSYT a)
+ --where show (S xs) = show $ fst $ break null xs
+
+rowInsert :: Ord a => SSYT a -> a -> SSYT a
+rowInsert t = truncInfList . rowInsert' (t ++ (repeat []))
+
+rowInsert' :: Ord a => SSYT a -> a -> SSYT 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))
+
+robinsonSchensted :: Ord a => [a] -> SSYT a
+robinsonSchensted = truncInfList . foldl rowInsert' (repeat [])
+
+truncInfList :: [[a]] -> [[a]]
+truncInfList = fst . break null
+
+toRowWord :: Ord a => SSYT a -> [a]
+toRowWord = concat . reverse
+
+{--
+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
+ --}
+
isRowWord' :: Ord a => [a] -> [a] -> [a] -> Bool
isRowWord' _ ys [] = ys == []
isRowWord' [] [] zs = isRowWord' [head zs] [] (tail zs)
@@ -13,7 +47,49 @@ isRowWord = isRowWord' [] []
reduceWord :: Ord a => [a] -> [a]
reduceWord xs
| length xs <= 2 = xs
- | otherwise = reduceWord' (reduceWord (init xs)) (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)
+ 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)
+ 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)
+
+prop_ReduceWord :: [Int] -> Bool
+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)
-reduceWord' :: Ord a => [a] -> a -> [a]
-reduceWord' xs x =
+reduceWord'' :: Ord a => [a] -> [a] -> [a]
+reduceWord'' [] (u:v:w:ys) =
+ if isRowWord (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)
+ 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
diff --git a/Math/Combinatorics/test.hs b/Math/Combinatorics/test.hs
new file mode 100644
index 0000000..490594c
--- /dev/null
+++ b/Math/Combinatorics/test.hs
@@ -0,0 +1,4 @@
+data Matrix a = M [[a]]
+
+instance Show a => Show (Matrix a)
+ where show (M xs) = show $ break (==[]) xs