implemented longestElement

1 files changed, 47 insertions, 19 deletions

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)