1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
----------------------------------------------------------------------------
--
-- Copyright : (C) 2017 Yuchen Pei
-- License : GPLv3+
--
-- Maintainer : Yuchen Pei
-- Stability : experimental
-- Portability : non-portable
--
----------------------------------------------------------------------------
--import Data.Monoid ((<>))
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 (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
-- |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 (S t) = concat $ reverse $ truncList t
-- |Whether a word is a row word
isRowWord :: Ord a => [a] -> Bool
isRowWord = isRowWord' [] []
isRowWord' :: Ord a => [a] -> [a] -> [a] -> Bool
isRowWord' _ ys [] = ys == []
isRowWord' [] [] zs = isRowWord' [head zs] [] (tail zs)
isRowWord' xs [] zs = if last xs <= head zs then isRowWord' (xs ++ [head zs]) [] (tail zs) else isRowWord' [] xs zs
isRowWord' xs ys zs =
if xs == [] || last xs <= head zs
then head ys > head zs && (isRowWord' (xs ++ [head zs]) (tail ys) (tail zs))
else ys == [] && isRowWord' [] xs zs
-- |Reduce a word to a row word
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
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)
-- |QuickCheck properties
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)
-- |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)
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
|
