|
|
----------------------------------------------------------------------------
--
-- 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
|
