From 513bc5e8933d4e16fe8eeb2d2f997a12a6a96a4a Mon Sep 17 00:00:00 2001 From: Jeshiba Date: Thu, 13 Jul 2017 12:27:51 -0400 Subject: Checkpoint --- Math/Combinatorics/.RootSystem.hs.swp | Bin 28672 -> 0 bytes Math/Combinatorics/PitmanTransform.hs | 29 +++++++++++++++++ Math/Combinatorics/RobinsonSchensted.hs | 53 ++++++++++++++++++++++++++++++++ Math/Combinatorics/RootSystem.hs | 5 +-- Math/Combinatorics/YoungTableaux.hs | 43 +++++++++++--------------- 5 files changed, 103 insertions(+), 27 deletions(-) delete mode 100644 Math/Combinatorics/.RootSystem.hs.swp create mode 100644 Math/Combinatorics/PitmanTransform.hs create mode 100644 Math/Combinatorics/RobinsonSchensted.hs (limited to 'Math') diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp deleted file mode 100644 index f8ca377..0000000 Binary files a/Math/Combinatorics/.RootSystem.hs.swp and /dev/null differ diff --git a/Math/Combinatorics/PitmanTransform.hs b/Math/Combinatorics/PitmanTransform.hs new file mode 100644 index 0000000..19a437f --- /dev/null +++ b/Math/Combinatorics/PitmanTransform.hs @@ -0,0 +1,29 @@ +--import Math.Combinatorics.RootSystem hiding (s) +import RootSystem hiding (s) +import YoungTableaux +import RobinsonSchensted +import Math.Algebra.Field.Base (Q)-- for Q +import Math.Algebra.LinearAlgebra +import Prelude hiding ( (*>), Word ) +import qualified Data.List as L + +--pitman :: (Fractional a, Ord a) => Type -> Int -> [a] -> [a] +pitman :: Type -> Int -> [[Q]] -> [[Q]] +pitman t n xs = foldr s xs (longestElement $ simpleSystem t n) + +s :: [Q] -> [[Q]] -> [[Q]] +--s :: (Fractional a, Ord a) => [a] -> [a] -> [a] +s alpha f = f <<->> fmap (*> alpha) (cumMin $ dynkinIndex alpha <$> f) + +--cumMin :: Ord a => [a] -> [a] +cumMin :: [Q] -> [Q] +cumMin = scanl1 min + +cumSum :: [Q] -> [Q] +cumSum = scanl1 (+) + +word2Path :: Word Int -> [[Q]] +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 diff --git a/Math/Combinatorics/RobinsonSchensted.hs b/Math/Combinatorics/RobinsonSchensted.hs new file mode 100644 index 0000000..ffefc5a --- /dev/null +++ b/Math/Combinatorics/RobinsonSchensted.hs @@ -0,0 +1,53 @@ +---------------------------------------------------------------------------- +-- +-- Copyright : (C) 2017 Yuchen Pei +-- License : GPLv3+ +-- +-- Maintainer : Yuchen Pei +-- Stability : experimental +-- Portability : non-portable +-- +---------------------------------------------------------------------------- +module RobinsonSchensted where +import YoungTableaux + +-- |Plactic monoid +instance Ord a => Monoid (SSYT a) + where + mempty = S $ repeat [] + mappend s1 s2 = foldl rowInsert s1 (toRowWord s2) + +-- |Row insertion algorithm +rowInsert :: Ord a => SSYT a -> a -> SSYT a +rowInsert (S t) = toSSYT . (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)) + +colInsert :: Ord a => SSYT a -> a -> SSYT a +colInsert st = transpose . (colInsert' (transpose st)) + +colInsert' :: Ord a => SSYT a -> a -> SSYT a +colInsert' (S t) = toSSYT . (colInsert'' t) + +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)) + +-- |The Robinson-Schensted algorithm +robinsonSchensted :: Ord a => [a] -> SSYT a +robinsonSchensted = foldl rowInsert mempty + +-- |The Robinson-Schensted algorithm with column insertion +robinsonSchensted' :: Ord a => [a] -> SSYT a +robinsonSchensted' = foldl colInsert mempty + +prop_ReduceWord_RobinsonSchensted :: [Int] -> Bool +prop_ReduceWord_RobinsonSchensted xs = (toRowWord $ robinsonSchensted xs) == (reduceWord xs) + diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs index a116d55..0e1181c 100644 --- a/Math/Combinatorics/RootSystem.hs +++ b/Math/Combinatorics/RootSystem.hs @@ -1,14 +1,15 @@ -- Copyright (c) Yuchen Pei, 2017. (Added positive roots and highest elements etc.) -- Copyright (c) David Amos, 2008-2015. All rights reserved. -module Math.Projects.RootSystem where +--module Math.Combinatorics.RootSystem where +module RootSystem where import Prelude hiding ( (*>) ) import Data.Ratio import Data.List import Data.Maybe -import qualified Data.List as L +--import qualified Data.List as L import qualified Data.Set as S import Math.Algebra.LinearAlgebra diff --git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs index eedb971..40b62e9 100644 --- a/Math/Combinatorics/YoungTableaux.hs +++ b/Math/Combinatorics/YoungTableaux.hs @@ -10,41 +10,28 @@ ---------------------------------------------------------------------------- --import Data.Monoid ((<>)) +module YoungTableaux where +import Prelude hiding (Word) +import qualified Data.List as L + data SSYT a = S [[a]] -data Wrd a = W [a] deriving Show +data Word a = W [a] deriving Show +data GTP a = GTP [[a]] deriving Show -- |Knuth equivalence -instance Ord a => Eq (Wrd a) +instance Ord a => Eq (Word 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 +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]] @@ -92,6 +79,13 @@ reduceWord' xs (u, v, w) 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 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 + + -- |QuickCheck properties prop_ReduceWord :: [Int] -> Bool prop_ReduceWord = isRowWord . reduceWord @@ -99,9 +93,6 @@ 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) = @@ -119,3 +110,5 @@ reduceWord'' xs (u:v:w: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