From e36c52e338b82695da51030927ec5f6efdb3bbc4 Mon Sep 17 00:00:00 2001 From: Jeshiba Date: Mon, 17 Jul 2017 10:21:26 -0400 Subject: cleaned up the code. - removed useless comments - added documentation, mainly in PitmanTransform.hs --- Math/Combinatorics/PitmanTransform.hs | 36 +++++++++++++---------------------- Math/Combinatorics/RootSystem.hs | 15 ++------------- 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 pre-processes xs by prepending a row of zeros to the input and post-processes 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 = -- cgit v1.2.3