aboutsummaryrefslogtreecommitdiff
path: root/Math
diff options
context:
space:
mode:
Diffstat (limited to 'Math')
-rw-r--r--Math/Combinatorics/.RootSystem.hs.swpbin0 -> 28672 bytes
-rw-r--r--Math/Combinatorics/RootSystem.hs48
2 files changed, 33 insertions, 15 deletions
diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp
new file mode 100644
index 0000000..f8ca377
--- /dev/null
+++ b/Math/Combinatorics/.RootSystem.hs.swp
Binary files 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]]