From 3a73960fe269cfae8c4c6da9b51c6dc70f53a542 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <baconp@gmail.com>
Date: Mon, 17 Jul 2017 07:52:03 -0400
Subject: checkpoint

---
 Math/Combinatorics/PitmanTransform.hs |  9 +++++++++
 Math/Combinatorics/RootSystem.hs      | 18 ++++++++++++------
 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
-- 
cgit v1.2.3