From f1ad02cf7a29e3ad007bf58ac13ea8da96bfcd39 Mon Sep 17 00:00:00 2001 From: Jeshiba Date: Thu, 13 Jul 2017 15:10:58 -0400 Subject: added PitmanTransform and RobinsonSchensted. - Implemented Pitman's transforms, relying on RootSystem.hs - Tested by checking equality with Column insertion. - Moved row insertion from YoungTableaux to RobinsonSchensted - Implemented column insertion - Using Word where previously was [a] --- Math/Combinatorics/PitmanTransform.hs | 38 +++++++++++++++++++ Math/Combinatorics/RobinsonSchensted.hs | 17 +++++---- Math/Combinatorics/YoungTableaux.hs | 66 ++++++++++++++++++++++----------- 3 files changed, 91 insertions(+), 30 deletions(-) (limited to 'Math') diff --git a/Math/Combinatorics/PitmanTransform.hs b/Math/Combinatorics/PitmanTransform.hs index 19a437f..e6eea85 100644 --- a/Math/Combinatorics/PitmanTransform.hs +++ b/Math/Combinatorics/PitmanTransform.hs @@ -1,3 +1,13 @@ +---------------------------------------------------------------------------- +-- +-- Copyright : (C) 2017 Yuchen Pei +-- License : GPLv3+ +-- +-- Maintainer : Yuchen Pei +-- Stability : experimental +-- Portability : non-portable +-- +---------------------------------------------------------------------------- --import Math.Combinatorics.RootSystem hiding (s) import RootSystem hiding (s) import YoungTableaux @@ -23,7 +33,35 @@ cumSum :: [Q] -> [Q] cumSum = scanl1 (+) word2Path :: Word Int -> [[Q]] +word2Path (W []) = [] word2Path (W xs) = L.transpose $ cumSum <$> [0:(indicator (==k) xs) | k <- [1..maximum xs]] indicator :: (a -> Bool) -> [a] -> [Q] indicator f xs = (\x -> if f x then 1 else 0) <$> xs + +pitmanA :: [[Q]] -> [[Q]] +pitmanA [] = [] +pitmanA xs = + let n = length $ head xs in + if n == 1 then xs else pitman A (n - 1) xs + +pitmanAShape :: [[Q]] -> [Q] +pitmanAShape = last . pitmanA + +pitmanAGTP :: [[Q]] -> GTP Q +pitmanAGTP = GTP . (pitmanAGTP' []) where + pitmanAGTP' :: [[Q]] -> [[Q]] -> [[Q]] + pitmanAGTP' xs [] = xs + pitmanAGTP' xs ys = pitmanAGTP' ((pitmanAShape ys):xs) (L.transpose $ init $ L.transpose ys) + + +prop_Pitman_RobinsonSchensted :: [Int] -> Bool +prop_Pitman_RobinsonSchensted xs = + let w = prop_Pitman_RobinsonSchensted_sanitise xs in + (pitmanAGTP $ word2Path w) == (gTPFromInt $ sSYT2GTP $ robinsonSchensted' w) + +gTPFromInt :: GTP Int -> GTP Q +gTPFromInt (GTP xs) = GTP $ fmap (fmap fromIntegral) xs + +prop_Pitman_RobinsonSchensted_sanitise :: [Int] -> Word Int +prop_Pitman_RobinsonSchensted_sanitise = W . (fmap (\t -> abs t + 1)) diff --git a/Math/Combinatorics/RobinsonSchensted.hs b/Math/Combinatorics/RobinsonSchensted.hs index ffefc5a..a321708 100644 --- a/Math/Combinatorics/RobinsonSchensted.hs +++ b/Math/Combinatorics/RobinsonSchensted.hs @@ -10,12 +10,13 @@ ---------------------------------------------------------------------------- module RobinsonSchensted where import YoungTableaux +import Prelude hiding (Word) -- |Plactic monoid instance Ord a => Monoid (SSYT a) where mempty = S $ repeat [] - mappend s1 s2 = foldl rowInsert s1 (toRowWord s2) + mappend s1 s2 = foldl rowInsert s1 xs where W xs = toRowWord s2 -- |Row insertion algorithm rowInsert :: Ord a => SSYT a -> a -> SSYT a @@ -38,16 +39,16 @@ colInsert'' :: Ord a => [[a]] -> a -> [[a]] colInsert'' t x = case break (>=x) (head t) of (r, []) -> (r ++ [x]):(tail t) - (r1, r2) -> (r1 ++ x:(tail r2)):(rowInsert' (tail t) (head r2)) + (r1, r2) -> (r1 ++ x:(tail r2)):(colInsert'' (tail t) (head r2)) -- |The Robinson-Schensted algorithm -robinsonSchensted :: Ord a => [a] -> SSYT a -robinsonSchensted = foldl rowInsert mempty +robinsonSchensted :: Ord a => Word a -> SSYT a +robinsonSchensted (W xs) = foldl rowInsert mempty xs -- |The Robinson-Schensted algorithm with column insertion -robinsonSchensted' :: Ord a => [a] -> SSYT a -robinsonSchensted' = foldl colInsert mempty +robinsonSchensted' :: Ord a => Word a -> SSYT a +robinsonSchensted' (W xs) = foldl colInsert mempty xs -prop_ReduceWord_RobinsonSchensted :: [Int] -> Bool -prop_ReduceWord_RobinsonSchensted xs = (toRowWord $ robinsonSchensted xs) == (reduceWord xs) +prop_ReduceWord_RobinsonSchensted :: Word Int -> Bool +prop_ReduceWord_RobinsonSchensted w = (toRowWord $ robinsonSchensted w) == (reduceWord w) diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs index 40b62e9..683519f 100644 --- a/Math/Combinatorics/YoungTableaux.hs +++ b/Math/Combinatorics/YoungTableaux.hs @@ -16,16 +16,27 @@ import qualified Data.List as L data SSYT a = S [[a]] data Word a = W [a] deriving Show -data GTP a = GTP [[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 xs) == (W ys) = (reduceWord xs) == (reduceWord ys) + 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 []) @@ -38,12 +49,12 @@ 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 +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 => [a] -> Bool -isRowWord = isRowWord' [] [] +isRowWord :: Ord a => Word a -> Bool +isRowWord (W w) = isRowWord' [] [] w isRowWord' :: Ord a => [a] -> [a] -> [a] -> Bool isRowWord' _ ys [] = ys == [] @@ -55,24 +66,27 @@ isRowWord' xs ys zs = else ys == [] && isRowWord' [] xs zs -- |Reduce a word to a row word -reduceWord :: Ord a => [a] -> [a] -reduceWord xs +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 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) + 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 $ 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) @@ -80,35 +94,43 @@ reduceWord' xs (u, v, 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 +prop_ReduceWord = isRowWord . reduceWord . W prop_ReduceWord' :: [Int] -> Bool -prop_ReduceWord' xs = (length xs) == (length $ reduceWord xs) +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 (u:v:w:ys) +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 $ xs ++ (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 + 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 -- cgit v1.2.3