From 4a01a7a38363b80289576690f303cc926846a2cd Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Thu, 13 Jul 2017 08:30:46 -0400
Subject: Added a test on positiveRoots.

positiveRoots ++ there negation form all the roots.
---
 Math/Combinatorics/.RootSystem.hs.swp | Bin 0 -> 28672 bytes
 Math/Combinatorics/RootSystem.hs      |  48 +++++++++++++++++++++++-----------
 2 files changed, 33 insertions(+), 15 deletions(-)
 create mode 100644 Math/Combinatorics/.RootSystem.hs.swp

(limited to 'Math')

diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp
new file mode 100644
index 0000000..f8ca377
Binary files /dev/null and b/Math/Combinatorics/.RootSystem.hs.swp differ
diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs
index f2d829f..a116d55 100644
--- a/Math/Combinatorics/RootSystem.hs
+++ b/Math/Combinatorics/RootSystem.hs
@@ -80,15 +80,14 @@ longestElement ss = longestElement' [] posRoots
         posRoots = positiveRoots ss
         longestElement' :: [[Q]] -> [[Q]] -> [[Q]]
         longestElement' xs rs = 
-            --let ys = (S.fromList ss) S.\\ (S.fromList $ negateM rs) S.\\ (if null xs then S.empty else S.singleton (head xs)) in
             let ys = (S.fromList ss) `S.intersection` (S.fromList rs) in
                 if S.null ys
                 then xs
                 else let alpha = (head (S.toList ys)) in
                          longestElement' (alpha:xs) (s alpha <$> rs)
         
-negateM :: Num a => [[a]] -> [[a]]
-negateM = fmap (fmap negate)
+--negateM :: Num a => [[a]] -> [[a]]
+--negateM = fmap (fmap negate)
 
 
 -- |all positive roots
@@ -97,7 +96,7 @@ positiveRoots ss = (positiveRoots' $ cartanMatrix' ss) <<*>> ss
 
 -- |return root indices of all positive roots
 positiveRoots' :: [[Q]] -> [[Q]]
-positiveRoots' cm = positiveRoots'' [] ((basisElt $ length cm) <$> [1..length cm])
+positiveRoots' cm = positiveRoots'' [] (iMx $ length cm)
     where positiveRoots'' :: [[Q]] -> [[Q]] -> [[Q]]
           positiveRoots'' pr npr
               | null npr = pr
@@ -154,22 +153,41 @@ numRoots E 8 = 240
 numRoots F 4 = 48
 numRoots G 2 = 12
 
+
+positiveRoots_transform :: Int -> (Type, Int)
+positiveRoots_transform n
+  | n > 108 = positiveRoots_transform (n `mod` 108 + 1)
+  | n > 105 = (E, n - 100)
+  | n > 96 = (G, 2)
+  | n > 88 = (F, 4)
+  | n > 85 = (E, n - 80)
+  | n > 62 = (D, n - 60)
+  | n > 40 = (C, n - 40)
+  | n > 20 = (B, n - 20)
+  | n > 0 = (A, n)
+  | otherwise = positiveRoots_transform (n `mod` 108 + 1)
+
+
+-- | test the number of positive roots is half that of all roots
 prop_positiveRoots :: Int -> Bool
-prop_positiveRoots n 
-  | n > 108 = prop_positiveRoots (n `mod` 108 + 1)
-  | n > 105 = prop_positiveRoots' E (n - 100)
-  | n > 96 = prop_positiveRoots' G 2
-  | n > 88 = prop_positiveRoots' F 4
-  | n > 85 = prop_positiveRoots' E (n - 80)
-  | n > 62 = prop_positiveRoots' D (n - 60)
-  | n > 40 = prop_positiveRoots' C (n - 40)
-  | n > 20 = prop_positiveRoots' B (n - 20)
-  | n > 0 = prop_positiveRoots' A n
-  | otherwise = prop_positiveRoots (n `mod` 108 + 1)
+prop_positiveRoots n = prop_positiveRoots' t m
+    where (t, m) = positiveRoots_transform n
 
 prop_positiveRoots' :: Type -> Int -> Bool
 prop_positiveRoots' t n = (length $ positiveRoots (simpleSystem t n)) * 2 == numRoots t n
 
+
+-- | 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
+
+
+prop_positiveRoots1' :: Type -> Int -> Bool
+prop_positiveRoots1' t n =
+    let pr = positiveRoots (simpleSystem t n) in
+        (S.fromList $ pr ++ ((-1) *>> pr)) == (S.fromList $ allRoots (simpleSystem t n))
+
 -- Given a simple system, return the full root system
 -- The closure of a set of roots under reflection
 allRoots :: SimpleSystem -> [[Q]]
-- 
cgit v1.2.3