-- Copyright (c) David Amos, 2008-2015. All rights reserved.


module Math.Projects.RootSystem where

import Prelude hiding ( (*>) )

import Data.Ratio
import qualified Data.List as L
import qualified Data.Set as S

import Math.Algebra.LinearAlgebra
import Math.Algebra.Group.PermutationGroup hiding (elts, order, closure)
import Math.Algebra.Group.SchreierSims as SS
import Math.Algebra.Group.StringRewriting as SG

import Math.Algebra.Field.Base -- for Q


data Type = A | B | C | D | E | F | G

-- Humphreys, Reflection Groups and Coxeter Groups



-- SIMPLE SYSTEMS

-- sometimes called fundamental systems


-- The ith basis vector in K^n

basisElt :: Int -> Int -> [Q] -- this type signature determines all the rest

basisElt :: Int -> Int -> [Q]
basisElt n :: Int
n i :: Int
i = Int -> Q -> [Q]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) 0 [Q] -> [Q] -> [Q]
forall a. [a] -> [a] -> [a]
++ 1 Q -> [Q] -> [Q]
forall a. a -> [a] -> [a]
: Int -> Q -> [Q]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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


-- A simple system is like a basis for the root system (see Humphreys p8 for full definition)

-- simpleSystem :: Type -> Int -> [[Q]]

simpleSystem :: Type -> Int -> [[Q]]
simpleSystem A n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) | Int
i <- [1..Int
n]]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
simpleSystem B n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) | Int
i <- [1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]] [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [Int -> [Q]
e Int
n]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
simpleSystem C n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) | Int
i <- [1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]] [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [2 Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> Int -> [Q]
e Int
n]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
simpleSystem D n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) | Int
i <- [1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]] [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [Int -> [Q]
e (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
n]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
simpleSystem E n :: Int
n | Int
n Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [6,7,8] = Int -> [[Q]] -> [[Q]]
forall a. Int -> [a] -> [a]
take Int
n [[Q]]
simpleroots
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt 8
          simpleroots :: [[Q]]
simpleroots = ((1Q -> Q -> Q
forall a. Fractional a => a -> a -> a
/2) Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> (Int -> [Q]
e 1 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 2 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 3 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 4 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 5 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 6 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 7 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e 8))
                      [Q] -> [[Q]] -> [[Q]]
forall a. a -> [a] -> [a]
: (Int -> [Q]
e 1 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e 2)
                      [Q] -> [[Q]] -> [[Q]]
forall a. a -> [a] -> [a]
: [Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-2) | Int
i <- [3..8]]
simpleSystem F 4 = [Int -> [Q]
e 2 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 3, Int -> [Q]
e 3 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 4, Int -> [Q]
e 4, (1Q -> Q -> Q
forall a. Fractional a => a -> a -> a
/2) Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> (Int -> [Q]
e 1 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 2 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 3 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 4)]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt 4
simpleSystem G 2 = [Int -> [Q]
e 1 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e 2, ((-2) Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> Int -> [Q]
e 1) [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e 2 [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e 3]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt 3


-- ROOT SYSTEMS

-- Calculating the full root system from the fundamental roots


-- Humphreys p3

-- Weyl group element corresponding to a root

-- w r is the reflection in the hyperplane orthogonal to r

w :: [a] -> [a] -> [a]
w r :: [a]
r s :: [a]
s = [a]
s [a] -> [a] -> [a]
forall a. Num a => [a] -> [a] -> [a]
<-> (2 a -> a -> a
forall a. Num a => a -> a -> a
* ([a]
s [a] -> [a] -> a
forall a. Num a => [a] -> [a] -> a
<.> [a]
r) a -> a -> a
forall a. Fractional a => a -> a -> a
/ ([a]
r [a] -> [a] -> a
forall a. Num a => [a] -> [a] -> a
<.> [a]
r)) a -> [a] -> [a]
forall a. Num a => a -> [a] -> [a]
*> [a]
r

-- Given a simple system, return the full root system

-- The closure of a set of roots under reflection

closure :: [[a]] -> [[a]]
closure rs :: [[a]]
rs = Set [a] -> [[a]]
forall a. Set a -> [a]
S.toList (Set [a] -> [[a]]) -> Set [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Set [a] -> Set [a] -> Set [a]
closure' Set [a]
forall a. Set a
S.empty ([[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
rs) where
    closure' :: Set [a] -> Set [a] -> Set [a]
closure' interior :: Set [a]
interior boundary :: Set [a]
boundary
        | Set [a] -> Bool
forall a. Set a -> Bool
S.null Set [a]
boundary = Set [a]
interior
        | Bool
otherwise =
            let interior' :: Set [a]
interior' = Set [a] -> Set [a] -> Set [a]
forall a. Ord a => Set a -> Set a -> Set a
S.union Set [a]
interior Set [a]
boundary
                boundary' :: Set [a]
boundary' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a] -> [a] -> [a]
forall a. Fractional a => [a] -> [a] -> [a]
w [a]
r [a]
s | [a]
r <- [[a]]
rs, [a]
s <- Set [a] -> [[a]]
forall a. Set a -> [a]
S.toList Set [a]
boundary] Set [a] -> Set [a] -> Set [a]
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set [a]
interior'
            in Set [a] -> Set [a] -> Set [a]
closure' Set [a]
interior' Set [a]
boundary'


-- WEYL GROUP

-- The finite reflection group generated by the root system


-- Generators of the Weyl group as permutation group on the roots

weylPerms :: Type -> Int -> [Permutation [Q]]
weylPerms t :: Type
t n :: Int
n =
    let rs :: [[Q]]
rs = Type -> Int -> [[Q]]
simpleSystem Type
t Int
n
        xs :: [[Q]]
xs = [[Q]] -> [[Q]]
forall a. (Ord a, Fractional a) => [[a]] -> [[a]]
closure [[Q]]
rs
        toPerm :: [Q] -> Permutation [Q]
toPerm r :: [Q]
r = [([Q], [Q])] -> Permutation [Q]
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [([Q]
x, [Q] -> [Q] -> [Q]
forall a. Fractional a => [a] -> [a] -> [a]
w [Q]
r [Q]
x) | [Q]
x <- [[Q]]
xs]
    in ([Q] -> Permutation [Q]) -> [[Q]] -> [Permutation [Q]]
forall a b. (a -> b) -> [a] -> [b]
map [Q] -> Permutation [Q]
toPerm [[Q]]
rs
    
-- Generators of the Weyl group as a matrix group

weylMatrices :: Type -> Int -> [[[Q]]]
weylMatrices t :: Type
t n :: Int
n = ([Q] -> [[Q]]) -> [[Q]] -> [[[Q]]]
forall a b. (a -> b) -> [a] -> [b]
map [Q] -> [[Q]]
wMx (Type -> Int -> [[Q]]
simpleSystem Type
t Int
n)

-- The Weyl group element corresponding to a root, represented as a matrix

wMx :: [Q] -> [[Q]]
wMx r :: [Q]
r = ([Q] -> [Q]) -> [[Q]] -> [[Q]]
forall a b. (a -> b) -> [a] -> [b]
map ([Q] -> [Q] -> [Q]
forall a. Fractional a => [a] -> [a] -> [a]
w [Q]
r) [Int -> [Q]
e Int
i | Int
i <- [1..Int
d]] -- matrix for reflection in hyperplane orthogonal to r

    where d :: Int
d = [Q] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q]
r -- dimension of the space

          e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
d
-- the images of the basis elts form the columns of the matrix

-- however, reflection matrices are symmetric, so they also form the rows



-- CARTAN MATRIX, DYNKIN DIAGRAM, COXETER SYSTEM


cartanMatrix :: Type -> Int -> [[Q]]
cartanMatrix t :: Type
t n :: Int
n = [[2 Q -> Q -> Q
forall a. Num a => a -> a -> a
* ([Q]
ai [Q] -> [Q] -> Q
forall a. Num a => [a] -> [a] -> a
<.> [Q]
aj) Q -> Q -> Q
forall a. Fractional a => a -> a -> a
/ ([Q]
ai [Q] -> [Q] -> Q
forall a. Num a => [a] -> [a] -> a
<.> [Q]
ai) | [Q]
aj <- [[Q]]
roots] | [Q]
ai <- [[Q]]
roots]
    where roots :: [[Q]]
roots = Type -> Int -> [[Q]]
simpleSystem Type
t Int
n
-- Note: The Cartan matrices for A, D, E systems are symmetric.

-- Those of B, C, F, G are not

-- Carter, Simple Groups of Lie Type, p44-5 gives the expected answers

-- They agree with our answers except for G2, which is the transpose

-- (So probably Carter defines the roots of G2 the other way round to Humphreys)


-- set the diagonal entries of (square) matrix mx to constant c

setDiag :: a -> [[a]] -> [[a]]
setDiag c :: a
c mx :: [[a]]
mx@((x :: a
x:xs :: [a]
xs):rs :: [[a]]
rs) = (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (a -> [a] -> [a]) -> [a] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) (([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
forall a. [a] -> a
head [[a]]
rs) (a -> [[a]] -> [[a]]
setDiag a
c ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. [a] -> [a]
tail [[a]]
rs)
setDiag _ [[]] = [[]]

-- Carter, Segal, Macdonald p17-18

-- given a Cartan matrix, derive the corresponding matrix describing the Dynkin diagram

-- nij = Aij * Aji, nii = 0

dynkinFromCartan :: [[a]] -> [[a]]
dynkinFromCartan aij :: [[a]]
aij = a -> [[a]] -> [[a]]
forall a. a -> [[a]] -> [[a]]
setDiag 0 ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]])
-> ((a -> a -> a) -> [a] -> [a] -> [a])
-> (a -> a -> a)
-> [[a]]
-> [[a]]
-> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith) a -> a -> a
forall a. Num a => a -> a -> a
(*) [[a]]
aij ([[a]] -> [[a]]
forall a. [[a]] -> [[a]]
L.transpose [[a]]
aij)

dynkinDiagram :: Type -> Int -> [[Q]]
dynkinDiagram t :: Type
t n :: Int
n = [[Q]] -> [[Q]]
forall a. Num a => [[a]] -> [[a]]
dynkinFromCartan ([[Q]] -> [[Q]]) -> [[Q]] -> [[Q]]
forall a b. (a -> b) -> a -> b
$ Type -> Int -> [[Q]]
cartanMatrix Type
t Int
n

-- given the Dynkin diagram nij, derive the coefficients mij of the Coxeter group <si | si^2, (sisj)^mij> (so mii == 1)

-- using nij = 4 cos^2 theta_ij

-- nij == 0 <=> theta = pi/2

-- nij == 1 <=> theta = pi/3

-- nij == 2 <=> theta = pi/4

-- nij == 3 <=> theta = pi/6

coxeterFromDynkin :: [[a]] -> [[a]]
coxeterFromDynkin nij :: [[a]]
nij = a -> [[a]] -> [[a]]
forall a. a -> [[a]] -> [[a]]
setDiag 1 ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [a]) -> [[a]] -> [[a]])
-> ((a -> a) -> [a] -> [a]) -> (a -> a) -> [[a]] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map) a -> a
forall a p. (Eq a, Num a, Num p) => a -> p
f [[a]]
nij
    where f :: a -> p
f 0 = 2; f 1 = 3; f 2 = 4; f 3 = 6

-- The mij coefficients of the Coxeter group <si | si^2, (sisj)^mij>, as a matrix

coxeterMatrix :: Type -> Int -> [[a]]
coxeterMatrix t :: Type
t n :: Int
n = [[Q]] -> [[a]]
forall a a. (Eq a, Num a, Num a) => [[a]] -> [[a]]
coxeterFromDynkin ([[Q]] -> [[a]]) -> [[Q]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Type -> Int -> [[Q]]
dynkinDiagram Type
t Int
n


-- Given the matrix of coefficients mij, return the Coxeter group <si | si^2, (sisj)^mij>

-- We assume but don't check that mii == 1 and mij == mji

fromCoxeterMatrix :: [[Int]] -> ([SGen], [([SGen], [a])])
fromCoxeterMatrix mx :: [[Int]]
mx = ([SGen]
gs,[([SGen], [a])]
forall a. [([SGen], [a])]
rs) where
    n :: Int
n = [[Int]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
mx
    gs :: [SGen]
gs = (Int -> SGen) -> [Int] -> [SGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SGen
s_ [1..Int
n]
    rs :: [([SGen], [a])]
rs = [[Int]] -> Int -> [([SGen], [a])]
forall a. [[Int]] -> Int -> [([SGen], [a])]
rules [[Int]]
mx 1
    rules :: [[Int]] -> Int -> [([SGen], [a])]
rules [] _ = []
    rules ((1:xs :: [Int]
xs):rs :: [[Int]]
rs) i :: Int
i = ([Int -> SGen
s_ Int
i, Int -> SGen
s_ Int
i],[]) ([SGen], [a]) -> [([SGen], [a])] -> [([SGen], [a])]
forall a. a -> [a] -> [a]
: [Int -> Int -> Int -> ([SGen], [a])
forall a. Int -> Int -> Int -> ([SGen], [a])
powerRelation Int
i Int
j Int
m | (j :: Int
j,m :: Int
m) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..] [Int]
xs] [([SGen], [a])] -> [([SGen], [a])] -> [([SGen], [a])]
forall a. [a] -> [a] -> [a]
++ [[Int]] -> Int -> [([SGen], [a])]
rules (([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. [a] -> [a]
tail [[Int]]
rs) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
    powerRelation :: Int -> Int -> Int -> ([SGen], [a])
powerRelation i :: Int
i j :: Int
j m :: Int
m = ([[SGen]] -> [SGen]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SGen]] -> [SGen]) -> [[SGen]] -> [SGen]
forall a b. (a -> b) -> a -> b
$ Int -> [SGen] -> [[SGen]]
forall a. Int -> a -> [a]
replicate Int
m [Int -> SGen
s_ Int
i, Int -> SGen
s_ Int
j],[])

-- Another presentation for the Coxeter group, using braid relations

fromCoxeterMatrix2 :: [[Int]] -> ([SGen], [([SGen], [SGen])])
fromCoxeterMatrix2 mx :: [[Int]]
mx = ([SGen]
gs,[([SGen], [SGen])]
rs) where
    n :: Int
n = [[Int]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
mx
    gs :: [SGen]
gs = (Int -> SGen) -> [Int] -> [SGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SGen
s_ [1..Int
n]
    rs :: [([SGen], [SGen])]
rs = [[Int]] -> Int -> [([SGen], [SGen])]
rules [[Int]]
mx 1
    rules :: [[Int]] -> Int -> [([SGen], [SGen])]
rules [] _ = []
    rules ((1:xs :: [Int]
xs):rs :: [[Int]]
rs) i :: Int
i = ([Int -> SGen
s_ Int
i, Int -> SGen
s_ Int
i],[]) ([SGen], [SGen]) -> [([SGen], [SGen])] -> [([SGen], [SGen])]
forall a. a -> [a] -> [a]
: [Int -> Int -> Int -> ([SGen], [SGen])
braidRelation Int
i Int
j Int
m | (j :: Int
j,m :: Int
m) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..] [Int]
xs] [([SGen], [SGen])] -> [([SGen], [SGen])] -> [([SGen], [SGen])]
forall a. [a] -> [a] -> [a]
++ [[Int]] -> Int -> [([SGen], [SGen])]
rules (([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. [a] -> [a]
tail [[Int]]
rs) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
    braidRelation :: Int -> Int -> Int -> ([SGen], [SGen])
braidRelation i :: Int
i j :: Int
j m :: Int
m = (Int -> [SGen] -> [SGen]
forall a. Int -> [a] -> [a]
take Int
m ([SGen] -> [SGen]) -> [SGen] -> [SGen]
forall a b. (a -> b) -> a -> b
$ [SGen] -> [SGen]
forall a. [a] -> [a]
cycle [Int -> SGen
s_ Int
j, Int -> SGen
s_ Int
i], Int -> [SGen] -> [SGen]
forall a. Int -> [a] -> [a]
take Int
m ([SGen] -> [SGen]) -> [SGen] -> [SGen]
forall a b. (a -> b) -> a -> b
$ [SGen] -> [SGen]
forall a. [a] -> [a]
cycle [Int -> SGen
s_ Int
i, Int -> SGen
s_ Int
j])



coxeterPresentation :: Type -> Int -> ([SGen], [([SGen], [a])])
coxeterPresentation t :: Type
t n :: Int
n = [[Int]] -> ([SGen], [([SGen], [a])])
forall a. [[Int]] -> ([SGen], [([SGen], [a])])
fromCoxeterMatrix ([[Int]] -> ([SGen], [([SGen], [a])]))
-> [[Int]] -> ([SGen], [([SGen], [a])])
forall a b. (a -> b) -> a -> b
$ Type -> Int -> [[Int]]
forall a. Num a => Type -> Int -> [[a]]
coxeterMatrix Type
t Int
n

eltsCoxeter :: Type -> Int -> [[SGen]]
eltsCoxeter t :: Type
t n :: Int
n = ([SGen], [([SGen], [SGen])]) -> [[SGen]]
forall a. Ord a => ([a], [([a], [a])]) -> [[a]]
SG.elts (([SGen], [([SGen], [SGen])]) -> [[SGen]])
-> ([SGen], [([SGen], [SGen])]) -> [[SGen]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> ([SGen], [([SGen], [SGen])])
fromCoxeterMatrix2 ([[Int]] -> ([SGen], [([SGen], [SGen])]))
-> [[Int]] -> ([SGen], [([SGen], [SGen])])
forall a b. (a -> b) -> a -> b
$ Type -> Int -> [[Int]]
forall a. Num a => Type -> Int -> [[a]]
coxeterMatrix Type
t Int
n
-- it's just slightly faster to use the braid presentation


poincarePoly :: Type -> Int -> [Int]
poincarePoly t :: Type
t n :: Int
n = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
L.group ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ ([SGen] -> Int) -> [[SGen]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [SGen] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[SGen]] -> [Int]) -> [[SGen]] -> [Int]
forall a b. (a -> b) -> a -> b
$ Type -> Int -> [[SGen]]
eltsCoxeter Type
t Int
n


-- LIE ALGEBRAS


elemMx :: Int -> Int -> Int -> [[Q]]
elemMx n :: Int
n i :: Int
i j :: Int
j = Int -> [Q] -> [[Q]]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [Q]
z [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ Int -> [Q]
e Int
j [Q] -> [[Q]] -> [[Q]]
forall a. a -> [a] -> [a]
: Int -> [Q] -> [[Q]]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) [Q]
z
    where z :: [Q]
z = Int -> Q -> [Q]
forall a. Int -> a -> [a]
replicate Int
n 0
          e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n


lieMult :: a -> a -> a
lieMult x :: a
x y :: a
y = a
xa -> a -> a
forall a. Num a => a -> a -> a
*a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
ya -> a -> a
forall a. Num a => a -> a -> a
*a
x

-- for gluing matrices together

+|+ :: [[a]] -> [[a]] -> [[a]]
(+|+) = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) -- glue two matrices together side by side

+-+ :: [a] -> [a] -> [a]
(+-+) = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)         -- glue two matrices together above and below


form :: Type -> Int -> [[a]]
form D n :: Int
n = (Int -> [[a]]
forall t. Num t => Int -> [[t]]
zMx Int
n [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
+|+ Int -> [[a]]
forall t. Num t => Int -> [[t]]
idMx Int
n)
                  [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
+-+
          (Int -> [[a]]
forall t. Num t => Int -> [[t]]
idMx Int
n [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
+|+ Int -> [[a]]
forall t. Num t => Int -> [[t]]
zMx Int
n)
form C n :: Int
n = (2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) 0) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:
           (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (0a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (Type -> Int -> [[a]]
form Type
D Int
n))
form B n :: Int
n = let id' :: [[a]]
id' = (-1) a -> [[a]] -> [[a]]
forall a. Num a => a -> [[a]] -> [[a]]
*>> Int -> [[a]]
forall t. Num t => Int -> [[t]]
idMx Int
n
           in (Int -> [[a]]
forall t. Num t => Int -> [[t]]
zMx Int
n [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
+|+ Int -> [[a]]
forall t. Num t => Int -> [[t]]
idMx Int
n)
                     [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
+-+
               ([[a]]
id'  [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
+|+ Int -> [[a]]
forall t. Num t => Int -> [[t]]
zMx Int
n)


-- TESTING

-- The expected values of the root system, number of roots, order of Weyl group

-- for comparison against the calculated values


-- !! Not yet got root systems for E6,7,8, F4


-- Humphreys p41ff


-- The full root system

-- L.sort (rootSystem t n) == closure (simpleSystem t n)

-- rootSystem :: Type -> Int -> [[QQ]]

rootSystem :: Type -> Int -> [[Q]]
rootSystem A n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1], Int
j <- [1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1], Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
rootSystem B n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [[Q]]
shortRoots [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[Q]]
longRoots
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
          shortRoots :: [[Q]]
shortRoots = [Int -> [Q]
e Int
i | Int
i <- [1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i | Int
i <- [1..Int
n]]
          longRoots :: [[Q]]
longRoots  = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
rootSystem C n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [[Q]]
longRoots [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[Q]]
shortRoots
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
          longRoots :: [[Q]]
longRoots  = [2 Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> Int -> [Q]
e Int
i | Int
i <- [1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> (2 Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> Int -> [Q]
e Int
i) | Int
i <- [1..Int
n]]
          shortRoots :: [[Q]]
shortRoots = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
                    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
rootSystem D n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 =
    [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<+> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
    [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..Int
n], Int
j <- [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1..Int
n]]
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt Int
n
rootSystem G 2 = [[Q]]
shortRoots [[Q]] -> [[Q]] -> [[Q]]
forall a. [a] -> [a] -> [a]
++ [[Q]]
longRoots
    where e :: Int -> [Q]
e = Int -> Int -> [Q]
basisElt 3
          shortRoots :: [[Q]]
shortRoots = [Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j | Int
i <- [1..3], Int
j <- [1..3], Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j]
          longRoots :: [[Q]]
longRoots = ([Q] -> [[Q]]) -> [[Q]] -> [[Q]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\r :: [Q]
r-> [[Q]
r,[] [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> [Q]
r]) [2 Q -> [Q] -> [Q]
forall a. Num a => a -> [a] -> [a]
*> Int -> [Q]
e Int
i [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
j [Q] -> [Q] -> [Q]
forall a. Num a => [a] -> [a] -> [a]
<-> Int -> [Q]
e Int
k | Int
i <- [1..3], [j :: Int
j,k :: Int
k] <- [[1..3] [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Int
i]] ]


-- numRoots t n == length (closure $ simpleSystem t n)

numRoots :: Type -> a -> a
numRoots A n :: a
n = a
na -> a -> a
forall a. Num a => a -> a -> a
*(a
na -> a -> a
forall a. Num a => a -> a -> a
+1)
numRoots B n :: a
n = 2a -> a -> a
forall a. Num a => a -> a -> a
*a
na -> a -> a
forall a. Num a => a -> a -> a
*a
n
numRoots C n :: a
n = 2a -> a -> a
forall a. Num a => a -> a -> a
*a
na -> a -> a
forall a. Num a => a -> a -> a
*a
n
numRoots D n :: a
n = 2a -> a -> a
forall a. Num a => a -> a -> a
*a
na -> a -> a
forall a. Num a => a -> a -> a
*(a
na -> a -> a
forall a. Num a => a -> a -> a
-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)

orderWeyl :: Type -> a -> Integer
orderWeyl A n :: a
n = a -> Integer
forall a. Integral a => a -> Integer
factorial (a
na -> a -> a
forall a. Num a => a -> a -> a
+1)
orderWeyl B n :: a
n = 2Integer -> a -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^a
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* a -> Integer
forall a. Integral a => a -> Integer
factorial a
n
orderWeyl C n :: a
n = 2Integer -> a -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^a
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* a -> Integer
forall a. Integral a => a -> Integer
factorial a
n
orderWeyl D n :: a
n = 2Integer -> a -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(a
na -> a -> a
forall a. Num a => a -> a -> a
-1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* a -> Integer
forall a. Integral a => a -> Integer
factorial a
n
orderWeyl E 6 = 2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^7 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 3Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^4 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 5
orderWeyl E 7 = 2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 3Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^4 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 5 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 7
orderWeyl E 8 = 2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^14 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 3Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^5 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 5Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 7
orderWeyl F 4 = 2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^7 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 3Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^2
orderWeyl G 2 = 12


factorial :: a -> Integer
factorial n :: a
n = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [1..a -> Integer
forall a. Integral a => a -> Integer
toInteger a
n]


{-
-- now moved to TRootSystem
test1 = all (\(t,n) -> orderWeyl t n == L.genericLength (eltsCoxeter t n))
    [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(F,4),(G,2)]

test2 = all (\(t,n) -> orderWeyl t n == SS.order (weylPerms t n))
    [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(E,6),(F,4),(G,2)]
-}