From 0b116e817f65f416ad8dc835392b20fa6a57e990 Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Wed, 12 Jul 2017 17:03:14 -0400
Subject: fixed highest roots and positive roots.

---
 Math/Combinatorics/RootSystem.hs | 30 ++++++++++++++----------------
 1 file changed, 14 insertions(+), 16 deletions(-)

(limited to 'Math')

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
-- 
cgit v1.2.3