aboutsummaryrefslogtreecommitdiff
path: root/Math/Combinatorics/RootSystem.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Math/Combinatorics/RootSystem.hs')
-rw-r--r--Math/Combinatorics/RootSystem.hs30
1 files changed, 14 insertions, 16 deletions
diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs
index e388a23..f2d829f 100644
--- a/Math/Combinatorics/RootSystem.hs
+++ b/Math/Combinatorics/RootSystem.hs
@@ -1,6 +1,4 @@
--- Copyright (c) Yuchen Pei, 2017.
--- Released under the GNU General Public License version 3 or later.
---
+-- Copyright (c) Yuchen Pei, 2017. (Added positive roots and highest elements etc.)
-- Copyright (c) David Amos, 2008-2015. All rights reserved.
module Math.Projects.RootSystem where
@@ -9,6 +7,7 @@ import Prelude hiding ( (*>) )
import Data.Ratio
import Data.List
+import Data.Maybe
import qualified Data.List as L
import qualified Data.Set as S
@@ -70,13 +69,19 @@ simpleSystem t n = error $ "Invalid root system of type " ++ (show t) ++ " and r
s :: [Q] -> [Q] -> [Q]
s alpha beta = beta <-> (dynkinIndex alpha beta) *> alpha
+
+longestElementIndex :: SimpleSystem -> [Int]
+longestElementIndex ss = (+1) <$> fromJust <$> flip elemIndex ss <$> longestElement ss
+
+
longestElement :: SimpleSystem -> [[Q]]
longestElement ss = longestElement' [] posRoots
where
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.\\ (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
@@ -88,7 +93,7 @@ negateM = fmap (fmap negate)
-- |all positive roots
positiveRoots :: SimpleSystem -> [[Q]]
-positiveRoots ss = (positiveRoots' $ cartanMatrix ss) <<*>> ss
+positiveRoots ss = (positiveRoots' $ cartanMatrix' ss) <<*>> ss
-- |return root indices of all positive roots
positiveRoots' :: [[Q]] -> [[Q]]
@@ -123,6 +128,9 @@ sumV = foldl1 (<+>)
cartanMatrix :: SimpleSystem -> [[Q]]
cartanMatrix ss = [dynkinIndex r <$> ss | r <- ss]
+cartanMatrix' :: SimpleSystem -> [[Q]]
+cartanMatrix' ss = transpose $ cartanMatrix ss
+
isMultBasis :: [Q] -> Bool
isMultBasis v = (length $ filter (/=0) v) == 1
@@ -164,7 +172,7 @@ prop_positiveRoots' t n = (length $ positiveRoots (simpleSystem t n)) * 2 == num
-- Given a simple system, return the full root system
-- The closure of a set of roots under reflection
-{--allRoots :: SimpleSystem -> [[Q]]
+allRoots :: SimpleSystem -> [[Q]]
allRoots ss = S.toList $ closure S.empty (S.fromList ss) where
closure interior boundary
| S.null boundary = interior
@@ -172,17 +180,7 @@ allRoots ss = S.toList $ closure S.empty (S.fromList ss) where
let interior' = S.union interior boundary
boundary' = S.fromList [s alpha beta | alpha <- ss, beta <- S.toList boundary] S.\\ interior'
in closure interior' boundary'
- --}
-{--positiveRoots :: SimpleSystem -> [[Q]]
-positiveRoots ss = S.toList $ go S.empty (S.fromList ss) where
- go pr newPr
- | S.null newPr = pr
- | otherwise =
- let pr' = S.union pr newPr
- newPr' = S.fromList [s alpha (negate <$> beta) | alpha <- ss, beta <- S.toList newPr] S.\\ pr'
- in go pr' newPr'
- --}
{--
-- WEYL GROUP