aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeshiba <baconp@gmail.com>2017-07-17 07:59:18 -0400
committerJeshiba <baconp@gmail.com>2017-07-17 07:59:18 -0400
commit72aaa08677777e76cef0433802abc53cd7f4bce3 (patch)
treeb19034ab80161205660afa0cc059cd7f0117e3e0
parentf1ad02cf7a29e3ad007bf58ac13ea8da96bfcd39 (diff)
check pint
-rw-r--r--Math/Combinatorics/PitmanTransform.hs9
-rw-r--r--Math/Combinatorics/RootSystem.hs18
2 files changed, 21 insertions, 6 deletions
diff --git a/Math/Combinatorics/PitmanTransform.hs b/Math/Combinatorics/PitmanTransform.hs
index e6eea85..0379bce 100644
--- a/Math/Combinatorics/PitmanTransform.hs
+++ b/Math/Combinatorics/PitmanTransform.hs
@@ -15,6 +15,7 @@ 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
--pitman :: (Fractional a, Ord a) => Type -> Int -> [a] -> [a]
@@ -65,3 +66,11 @@ 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))
+
+
+randomQMatrix :: Int -> Gen [[Q]]
+randomQMatrix n = vectorOf 20 (vector n)
+
+prop_Pitman_WeylChamber :: Int -> Property
+prop_Pitman_WeylChamber m = let (t, n) = int2TypeInt m in
+ forAll (randomQMatrix $ dimensionOfHostSpace t n) (\xs -> isInWeylChamber $ pitman t n xs)
diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs
index 0e1181c..f92b642 100644
--- a/Math/Combinatorics/RootSystem.hs
+++ b/Math/Combinatorics/RootSystem.hs
@@ -61,6 +61,8 @@ simpleSystem G 2 = [e 1 <-> e 2, ((-2) *> e 1) <+> e 2 <+> e 3]
where e = basisElt 3
simpleSystem t n = error $ "Invalid root system of type " ++ (show t) ++ " and rank " ++ (show n) ++ "."
+dimensionOfHostSpace :: Type -> Int -> Int
+dimensionOfHostSpace t n = length $ head $ simpleSystem t n
-- ROOT SYSTEMS
-- Calculating the full root system from the fundamental roots
@@ -143,6 +145,10 @@ dynkinIndex r s = 2 * (r <.> s) / (r <.> r)
dynkinIndex' :: [Q] -> [[Q]] -> [Q]
dynkinIndex' ri cm = ri <*>> cm
+
+isInWeylChamber :: SimpleSystem -> [Q] -> Bool
+isInWeylChamber ss r = all (\t -> t <.> r >= 0) ss
+
-- numRoots t n == length (closure $ simpleSystem t n)
numRoots A n = n*(n+1)
numRoots B n = 2*n*n
@@ -155,9 +161,9 @@ numRoots F 4 = 48
numRoots G 2 = 12
-positiveRoots_transform :: Int -> (Type, Int)
-positiveRoots_transform n
- | n > 108 = positiveRoots_transform (n `mod` 108 + 1)
+int2TypeInt :: Int -> (Type, Int)
+int2TypeInt n
+ | n > 108 = int2TypeInt (n `mod` 108 + 1)
| n > 105 = (E, n - 100)
| n > 96 = (G, 2)
| n > 88 = (F, 4)
@@ -166,13 +172,13 @@ positiveRoots_transform n
| n > 40 = (C, n - 40)
| n > 20 = (B, n - 20)
| n > 0 = (A, n)
- | otherwise = positiveRoots_transform (n `mod` 108 + 1)
+ | otherwise = int2TypeInt (n `mod` 108 + 1)
-- | test the number of positive roots is half that of all roots
prop_positiveRoots :: Int -> Bool
prop_positiveRoots n = prop_positiveRoots' t m
- where (t, m) = positiveRoots_transform n
+ where (t, m) = int2TypeInt n
prop_positiveRoots' :: Type -> Int -> Bool
prop_positiveRoots' t n = (length $ positiveRoots (simpleSystem t n)) * 2 == numRoots t n
@@ -181,7 +187,7 @@ prop_positiveRoots' t n = (length $ positiveRoots (simpleSystem t n)) * 2 == num
-- | test the positive roots and negative roots form all the roots
prop_positiveRoots1 :: Int -> Bool
prop_positiveRoots1 n = prop_positiveRoots1' t m
- where (t, m) = positiveRoots_transform n
+ where (t, m) = int2TypeInt n
prop_positiveRoots1' :: Type -> Int -> Bool