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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
----------------------------------------------------------------------------
--
-- Copyright : (C) 2017 Yuchen Pei
-- License : GPLv3+
--
-- Maintainer : Yuchen Pei
-- Stability : experimental
-- Portability : non-portable
--
----------------------------------------------------------------------------
--import Data.Monoid ((<>))
module YoungTableaux where
import Prelude hiding (Word)
import qualified Data.List as L
data SSYT a = S [[a]]
data Word a = W [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 == 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 [])
transpose :: SSYT a -> SSYT a
transpose (S t) = S $ (L.transpose $ truncList t) ++ (repeat [])
-- |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 -> Word a
toRowWord (S t) = W $ mconcat $ reverse $ truncList t
-- |Whether a word is a row word
isRowWord :: Ord a => Word a -> Bool
isRowWord (W w) = isRowWord' [] [] w
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 => 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
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 (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 $ 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)
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 . W
prop_ReduceWord' :: [Int] -> Bool
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 $ 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 $ 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
|
