diff options
author  Jeshiba <baconp@gmail.com>  20170717 10:21:26 0400 

committer  Jeshiba <baconp@gmail.com>  20170717 10:21:26 0400 
commit  e36c52e338b82695da51030927ec5f6efdb3bbc4 (patch)  
tree  64a751a12dbfc50df97ac11c61fe6129c9992f03  
parent  73f5c3f45e5971f9b5c78d0a0fcac23b4561b869 (diff) 
cleaned up the code.
 removed useless comments
 added documentation, mainly in PitmanTransform.hs
rwrr  Math/Combinatorics/PitmanTransform.hs  36  
rwrr  Math/Combinatorics/RootSystem.hs  15  
rwrr  Math/Combinatorics/YoungTableaux.hs  3 
3 files changed, 15 insertions, 39 deletions
diff git a/Math/Combinatorics/PitmanTransform.hs b/Math/Combinatorics/PitmanTransform.hs index fa979d7..1f17571 100644  a/Math/Combinatorics/PitmanTransform.hs +++ b/Math/Combinatorics/PitmanTransform.hs @@ 12,14 +12,13 @@ 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 Test.QuickCheck import qualified Data.List as L import Data.Ratio pitman :: (Fractional a, Ord a) => Type > Int > [a] > [a] + pitman t n xs is the Pitman's transform of type t_n acting on path xs. It preprocesses xs by prepending a row of zeros to the input and postprocesses by removing the first row of the output pitman :: Type > Int > [[Q]] > [[Q]] pitman t n xs = tail $ foldr s (prependWithZero xs) (longestElement $ simpleSystem t n) @@ 27,25 +26,29 @@ prependWithZero :: [[Q]] > [[Q]] prependWithZero [] = [] prependWithZero xs = (replicate (length $ head xs) 0) : xs + s alpha f: the cumulative infimum of twice the projection of path f on root alpha 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 (+) + + transform a word to a path word2Path :: Word Int > [[Q]] word2Path (W []) = [] word2Path (W xs) = L.transpose $ cumSum <$> [0:(indicator (==k) xs)  k < [1..maximum xs]] word2Path (W xs) = L.transpose $ cumSum <$> [indicator (==k) xs  k < [1..maximum xs]] + + indicator function indicator :: (a > Bool) > [a] > [Q] indicator f xs = (\x > if f x then 1 else 0) <$> xs + + Pitman's transform of type A pitmanA :: [[Q]] > [[Q]] pitmanA [] = [] pitmanA xs = @@ 55,6 +58,8 @@ pitmanA xs = pitmanAShape :: [[Q]] > [Q] pitmanAShape = last . pitmanA + + RS via Pitman's transform of type A pitmanAGTP :: [[Q]] > GTP Q pitmanAGTP = GTP . (pitmanAGTP' []) where pitmanAGTP' :: [[Q]] > [[Q]] > [[Q]] @@ 62,6 +67,7 @@ pitmanAGTP = GTP . (pitmanAGTP' []) where pitmanAGTP' xs ys = pitmanAGTP' ((pitmanAShape ys):xs) (L.transpose $ init $ L.transpose ys) + QuickCheck property that the Pitman's transform of type A coincides with RS algorithm prop_Pitman_RobinsonSchensted :: [Int] > Bool prop_Pitman_RobinsonSchensted xs = let w = prop_Pitman_RobinsonSchensted_sanitise xs in @@ 74,6 +80,7 @@ prop_Pitman_RobinsonSchensted_sanitise :: [Int] > Word Int prop_Pitman_RobinsonSchensted_sanitise = W . (fmap (\t > abs t + 1)) + QuickCheck generator that generates rational numbers with small numerators and denominators smallRational :: Gen Q smallRational = do x < smallInt @@ 82,16 +89,6 @@ smallRational = do return $ (toInteger x) / (toInteger (abs y + 1))  this line does not work for Q = Math.Algebra.Field.Base.Q  Couldn't match type ‘Integer’ with ‘Q’ smallRational :: Gen Q smallRational = getSmall <$> (arbitrary :: Gen (Small Q))  mediumInt :: Gen Int mediumInt = do  x < smallInt  y < smallInt  return $ x * y   smallInt :: Gen Int smallInt = getSmall <$> (arbitrary :: Gen (Small Int)) @@ 101,14 +98,7 @@ arbRational = arbitrary randomQMatrix :: Int > Gen [[Q]] randomQMatrix n = vectorOf 20 $ vectorOf n smallRational + QuickCheck property that the output of the Pitman's transform is in the Weyl Chamber, for any type. prop_Pitman_WeylChamber :: Int > Property prop_Pitman_WeylChamber m = let (t, n) = int2TypeInt m in forAll (randomQMatrix $ dimensionOfHostSpace t n) (\xs > isInWeylChamber (simpleSystem t n) (last $ pitman t n xs))  prop_PitmanA_WeylChamber :: Int > Property prop_PitmanA_WeylChamber n = let m = (n `mod` 2) + 1 in  forAll (randomQMatrix $ m + 1) (\xs > isInWeylChamber (simpleSystem A m) (last $ pitman A m xs))  prop_PitmanA_WeylChamber :: Property prop_PitmanA_WeylChamber = let m = (1 `mod` 2) + 1 in  forAll (randomQMatrix $ m + 1) (\xs > isInWeylChamber (simpleSystem A m) (last $ pitman A m xs)) diff git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs index a1674b7..9ed7c89 100644  a/Math/Combinatorics/RootSystem.hs +++ b/Math/Combinatorics/RootSystem.hs @@ 9,15 +9,9 @@ import Prelude hiding ( (*>) ) import Data.Ratio
import Data.List
import Data.Maybe
import qualified Data.List as L
import qualified Data.Set as S
import Math.Algebra.LinearAlgebra
import Math.Algebra.Group.PermutationGroup hiding (elts, order, closure)
import Math.Algebra.Group.SchreierSims as SS
import Math.Algebra.Group.StringRewriting as SG

import Math.Algebra.Field.Base (Q) for Q
type Q = Rational
data Type = A  B  C  D  E  F  G deriving Show
@@ 64,11 +58,9 @@ simpleSystem t n = error $ "Invalid root system of type " ++ (show t) ++ " and r dimensionOfHostSpace :: Type > Int > Int
dimensionOfHostSpace t n = length $ head $ simpleSystem t n
 ROOT SYSTEMS
 Calculating the full root system from the fundamental roots
 Humphreys p3
 Weyl group element corresponding to a root
+ Reflection corresponding to a root
 s alpha beta = s_\alpha \beta
s :: [Q] > [Q] > [Q]
s alpha beta = beta <> (dynkinIndex alpha beta) *> alpha
@@ 90,9 +82,6 @@ longestElement ss = longestElement' [] posRoots else let alpha = (head (S.toList ys)) in
longestElement' (alpha:xs) (s alpha <$> rs)
negateM :: Num a => [[a]] > [[a]]
negateM = fmap (fmap negate)

 all positive roots
positiveRoots :: SimpleSystem > [[Q]]
@@ 207,7 +196,7 @@ allRoots ss = S.toList $ closure S.empty (S.fromList ss) where boundary' = S.fromList [s alpha beta  alpha < ss, beta < S.toList boundary] S.\\ interior'
in closure interior' boundary'

+ Old code in HaskellForMaths
{
 WEYL GROUP
 The finite reflection group generated by the root system
diff git a/Math/Combinatorics/YoungTableaux.hs b/Math/Combinatorics/YoungTableaux.hs index 683519f..357927c 100644  a/Math/Combinatorics/YoungTableaux.hs +++ b/Math/Combinatorics/YoungTableaux.hs @@ 73,9 +73,6 @@ 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 = 