aboutsummaryrefslogtreecommitdiff
path: root/Math
diff options
context:
space:
mode:
Diffstat (limited to 'Math')
-rw-r--r--Math/Combinatorics/PitmanTransform.hs38
-rw-r--r--Math/Combinatorics/RobinsonSchensted.hs17
-rw-r--r--Math/Combinatorics/YoungTableaux.hs66
3 files changed, 91 insertions, 30 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 15:59:54 +0000