From 6ce11c525d765b22261d06a939247b9f1e0e3a38 Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Wed, 12 Jul 2017 15:44:44 -0400
Subject: implemented longestElement

---
 Math/Combinatorics/RootSystem.hs | 66 ++++++++++++++++++++++++++++------------
 1 file changed, 47 insertions(+), 19 deletions(-)

(limited to 'Math/Combinatorics/RootSystem.hs')

diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs
index 5b56a3a..53cf65c 100644
--- a/Math/Combinatorics/RootSystem.hs
+++ b/Math/Combinatorics/RootSystem.hs
@@ -43,10 +43,13 @@ simpleSystem A n | n >= 1 = [e i <-> e (i+1) | i <- [1..n]]
     where e = basisElt (n+1)
 simpleSystem B n | n >= 2 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [e n]
     where e = basisElt n
+simpleSystem B 1 = simpleSystem A 1
 simpleSystem C n | n >= 2 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [2 *> e n]
     where e = basisElt n
+simpleSystem C 1 = simpleSystem A 1
 simpleSystem D n | n >= 4 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [e (n-1) <+> e n]
     where e = basisElt n
+simpleSystem D 3 = simpleSystem A 3
 simpleSystem E n | n `elem` [6,7,8] = take n simpleroots
     where e = basisElt 8
           simpleroots = ((1/2) *> (e 1 <-> e 2 <-> e 3 <-> e 4 <-> e 5 <-> e 6 <-> e 7 <+> e 8))
@@ -67,9 +70,23 @@ 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
 
---cartanRows :: SimpleSystem -> [[Q]]
---cartanRows ss = cartanRows' 
-
+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) 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)
+
+
+-- |all positive roots
 positiveRoots :: SimpleSystem -> [[Q]]
 positiveRoots ss = (positiveRoots' $ cartanMatrix ss) <<*>> ss
 
@@ -81,12 +98,6 @@ positiveRoots' cm = positiveRoots'' [] ((basisElt $ length cm) <$> [1..length cm
               | null npr = pr
               | otherwise = positiveRoots'' (pr ++ npr) (S.toList . S.fromList $ mconcat $ zipWith newRootIndices npr (pIndex pr cm <$> npr))
 
-test'' :: [[Q]] -> [[Q]] -> [[Q]]
-test'' pr npr
-    | null npr = pr
-    | otherwise = test'' (pr ++ npr) (S.toList . S.fromList $ mconcat $ zipWith newRootIndices npr (pIndex pr cm <$> npr))
-        where cm = cartanMatrix (simpleSystem G 2)
-                  
 newRootIndices :: [Q] -> [Q] -> [[Q]]
 newRootIndices ri pi = (ri <+>) <$> (go pi [] 1)
     where go :: [Q] -> [Int] -> Int -> [[Q]]
@@ -124,6 +135,33 @@ dynkinIndex r s = 2 * (r <.> s) / (r <.> r)
 dynkinIndex' :: [Q] -> [[Q]] -> [Q]
 dynkinIndex' ri cm = ri <*>> cm
 
+-- numRoots t n == length (closure $ simpleSystem t n)
+numRoots A n = n*(n+1)
+numRoots B n = 2*n*n
+numRoots C n = 2*n*n
+numRoots D n = 2*n*(n-1)
+numRoots E 6 = 72
+numRoots E 7 = 126
+numRoots E 8 = 240    
+numRoots F 4 = 48
+numRoots G 2 = 12
+
+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' :: Type -> Int -> Bool
+prop_positiveRoots' t n = (length $ positiveRoots (simpleSystem t n)) * 2 == numRoots t n
+
 -- Given a simple system, return the full root system
 -- The closure of a set of roots under reflection
 {--allRoots :: SimpleSystem -> [[Q]]
@@ -296,16 +334,6 @@ rootSystem G 2 = shortRoots ++ longRoots
           longRoots = concatMap (\r-> [r,[] <-> r]) [2 *> e i <-> e j <-> e k | i <- [1..3], [j,k] <- [[1..3] L.\\ [i]] ]
 
 
--- numRoots t n == length (closure $ simpleSystem t n)
-numRoots A n = n*(n+1)
-numRoots B n = 2*n*n
-numRoots C n = 2*n*n
-numRoots D n = 2*n*(n-1)
-numRoots E 6 = 72
-numRoots E 7 = 126
-numRoots E 8 = 240    
-numRoots F 4 = 48
-numRoots G 2 = 12
 
 -- The order of the Weyl group
 -- orderWeyl t n == S.order (weylPerms t n)
-- 
cgit v1.2.3