aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeshiba <baconp@gmail.com>2017-07-12 14:32:40 -0400
committerJeshiba <baconp@gmail.com>2017-07-12 14:32:40 -0400
commit630c0f86b4efd617a0e55ec6bfad5c8e29f4c793 (patch)
treee8814ee854f8e176c14c2fb32650e6d929d70b0c
parentbe96efb2eedef71c12f8c7cd487f39fbb645d8bc (diff)
implemented positive roots.
-rw-r--r--Math/Combinatorics/.RootSystem.hs.swpbin0 -> 32768 bytes
-rw-r--r--Math/Combinatorics/RootSystem.hs66
2 files changed, 64 insertions, 2 deletions
diff --git a/Math/Combinatorics/.RootSystem.hs.swp b/Math/Combinatorics/.RootSystem.hs.swp
new file mode 100644
index 0000000..b31575f
--- /dev/null
+++ b/Math/Combinatorics/.RootSystem.hs.swp
Binary files 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