aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeshiba <baconp@gmail.com>2017-07-13 12:27:51 -0400
committerJeshiba <baconp@gmail.com>2017-07-13 12:27:51 -0400
commit513bc5e8933d4e16fe8eeb2d2f997a12a6a96a4a (patch)
treeaa2eae9e4d879659bb917ad16d2d8531bd7d4aa8
parent4a01a7a38363b80289576690f303cc926846a2cd (diff)
Checkpoint
-rw-r--r--Math/Combinatorics/.RootSystem.hs.swpbin28672 -> 0 bytes
-rw-r--r--Math/Combinatorics/PitmanTransform.hs29
-rw-r--r--Math/Combinatorics/RobinsonSchensted.hs53
-rw-r--r--Math/Combinatorics/RootSystem.hs5
-rw-r--r--Math/Combinatorics/YoungTableaux.hs43
5 files changed, 103 insertions, 27 deletions
diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp
deleted file mode 100644
index f8ca377..0000000
--- a/Math/Combinatorics/.RootSystem.hs.swp
+++ /dev/null
Binary files 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
+
+