From 630c0f86b4efd617a0e55ec6bfad5c8e29f4c793 Mon Sep 17 00:00:00 2001
From: Jeshiba <baconp@gmail.com>
Date: Wed, 12 Jul 2017 14:32:40 -0400
Subject: implemented positive roots.

---
 Math/Combinatorics/.RootSystem.hs.swp | Bin 0 -> 32768 bytes
 Math/Combinatorics/RootSystem.hs      |  66 ++++++++++++++++++++++++++++++++--
 2 files changed, 64 insertions(+), 2 deletions(-)
 create mode 100644 Math/Combinatorics/.RootSystem.hs.swp

diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp
new file mode 100644
index 0000000..b31575f
Binary files /dev/null and b/Math/Combinatorics/.RootSystem.hs.swp differ
diff --git a/Math/Combinatorics/RootSystem.hs b/Math/Combinatorics/RootSystem.hs
index 8cff2b9..5b56a3a 100644
--- a/Math/Combinatorics/RootSystem.hs
+++ b/Math/Combinatorics/RootSystem.hs
@@ -8,6 +8,7 @@ module Math.Projects.RootSystem where
 import Prelude hiding ( (*>) )
 
 import Data.Ratio
+import Data.List
 import qualified Data.List as L
 import qualified Data.Set as S
 
@@ -30,6 +31,9 @@ type SimpleSystem = [[Q]]
 -- The ith basis vector in K^n
 basisElt :: Int -> Int -> [Q] -- this type signature determines all the rest
 basisElt n i = replicate (i-1) 0 ++ 1 : replicate (n-i) 0
+
+--basisElt' :: Int -> Int -> [Int] -- this type signature determines all the rest
+--basisElt' n i = replicate (i-1) 0 ++ 1 : replicate (n-i) 0
 -- We need to work over the rationals to ensure that arithmetic is exact
 -- So long as our simple systems are rational, then reflection matrices are rational
 
@@ -61,7 +65,64 @@ simpleSystem t n = error $ "Invalid root system of type " ++ (show t) ++ " and r
 -- Weyl group element corresponding to a root
 -- s alpha beta = s_\alpha \beta
 s :: [Q] -> [Q] -> [Q]
-s alpha beta = beta <-> (2 * (alpha <.> beta) / (alpha <.> alpha)) *> alpha
+s alpha beta = beta <-> (dynkinIndex alpha beta) *> alpha
+
+--cartanRows :: SimpleSystem -> [[Q]]
+--cartanRows ss = cartanRows' 
+
+positiveRoots :: SimpleSystem -> [[Q]]
+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])
+    where positiveRoots'' :: [[Q]] -> [[Q]] -> [[Q]]
+          positiveRoots'' pr npr
+              | 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]]
+          go [] ys n = basisElt n <$> ys
+          go (x:xs) ys k = go xs (if x == 0 then ys else ys ++ [k]) (k + 1)
+
+
+pIndex :: [[Q]] -> [[Q]] -> [Q] -> [Q]
+pIndex allRootIndices cm rootIndex = (mIndex rootIndex allRootIndices) <-> (dynkinIndex' rootIndex cm)
+
+mIndex :: [Q] -> [[Q]] -> [Q]
+mIndex rootIndex allRootIndices = 
+    if isMultBasis rootIndex 
+        then 2 *> rootIndex
+        else maxV $ filter isMultBasis [rootIndex <-> r | r <- allRootIndices]
+
+maxV :: Ord a => [[a]] -> [a]
+maxV xs = maximum <$> (transpose xs)
+
+sumV :: Num a => [[a]] -> [a]
+sumV = foldl1 (<+>)
+
+cartanMatrix :: SimpleSystem -> [[Q]]
+cartanMatrix ss = [dynkinIndex r <$> ss | r <- ss]
+
+isMultBasis :: [Q] -> Bool
+isMultBasis v = (length $ filter (/=0) v) == 1
+
+dynkinRow :: [Q] -> SimpleSystem -> [Q]
+dynkinRow r ss = dynkinIndex r <$> ss
+
+dynkinIndex :: [Q] -> [Q] -> Q
+dynkinIndex r s = 2 * (r <.> s) / (r <.> r)
+
+dynkinIndex' :: [Q] -> [[Q]] -> [Q]
+dynkinIndex' ri cm = ri <*>> cm
 
 -- Given a simple system, return the full root system
 -- The closure of a set of roots under reflection
@@ -75,7 +136,7 @@ allRoots ss = S.toList $ closure S.empty (S.fromList ss) where
             in closure interior' boundary'
             --}
 
-positiveRoots :: SimpleSystem -> [[Q]]
+{--positiveRoots :: SimpleSystem -> [[Q]]
 positiveRoots ss = S.toList $ go S.empty (S.fromList ss) where
     go pr newPr
         | S.null newPr = pr
@@ -83,6 +144,7 @@ positiveRoots ss = S.toList $ go S.empty (S.fromList ss) where
             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