-- | Naive (very inefficient) algorithm to generate the irreducible (Dynkin) root systems

--

-- Based on <https://en.wikipedia.org/wiki/Root_system>


{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-}
module Math.Combinat.RootSystems where

--------------------------------------------------------------------------------


import Control.Monad

import Data.Array

import Data.Set (Set)
import qualified Data.Set as Set

import Data.List
import Data.Ord

import Math.Combinat.Numbers.Primes
import Math.Combinat.Sets

--------------------------------------------------------------------------------

-- * Half-integers


-- | The type of half-integers (internally represented by their double)

--

-- TODO: refactor this into its own module

newtype HalfInt 
  = HalfInt Int  
  deriving (HalfInt -> HalfInt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HalfInt -> HalfInt -> Bool
$c/= :: HalfInt -> HalfInt -> Bool
== :: HalfInt -> HalfInt -> Bool
$c== :: HalfInt -> HalfInt -> Bool
Eq,Eq HalfInt
HalfInt -> HalfInt -> Bool
HalfInt -> HalfInt -> Ordering
HalfInt -> HalfInt -> HalfInt
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HalfInt -> HalfInt -> HalfInt
$cmin :: HalfInt -> HalfInt -> HalfInt
max :: HalfInt -> HalfInt -> HalfInt
$cmax :: HalfInt -> HalfInt -> HalfInt
>= :: HalfInt -> HalfInt -> Bool
$c>= :: HalfInt -> HalfInt -> Bool
> :: HalfInt -> HalfInt -> Bool
$c> :: HalfInt -> HalfInt -> Bool
<= :: HalfInt -> HalfInt -> Bool
$c<= :: HalfInt -> HalfInt -> Bool
< :: HalfInt -> HalfInt -> Bool
$c< :: HalfInt -> HalfInt -> Bool
compare :: HalfInt -> HalfInt -> Ordering
$ccompare :: HalfInt -> HalfInt -> Ordering
Ord)

half :: HalfInt
half :: HalfInt
half = Int -> HalfInt
HalfInt Int
1

divByTwo :: Int -> HalfInt
divByTwo :: Int -> HalfInt
divByTwo Int
n = Int -> HalfInt
HalfInt Int
n

mulByTwo :: HalfInt -> Int
mulByTwo :: HalfInt -> Int
mulByTwo (HalfInt Int
n) = Int
n

scaleBy :: Int -> HalfInt -> HalfInt
scaleBy :: Int -> HalfInt -> HalfInt
scaleBy Int
k (HalfInt Int
n) = Int -> HalfInt
HalfInt (Int
kforall a. Num a => a -> a -> a
*Int
n)

instance Show HalfInt where
  show :: HalfInt -> String
show (HalfInt Int
n) = case forall a. Integral a => a -> a -> (a, a)
divMod Int
n Int
2 of
    (Int
k,Int
0) -> forall a. Show a => a -> String
show Int
k
    (Int
_,Int
1) -> forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
"/2"

instance Num HalfInt where
  fromInteger :: Integer -> HalfInt
fromInteger = Int -> HalfInt
HalfInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Int
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
  HalfInt
a + :: HalfInt -> HalfInt -> HalfInt
+ HalfInt
b = Int -> HalfInt
divByTwo forall a b. (a -> b) -> a -> b
$ HalfInt -> Int
mulByTwo HalfInt
a forall a. Num a => a -> a -> a
+ HalfInt -> Int
mulByTwo HalfInt
b
  HalfInt
a - :: HalfInt -> HalfInt -> HalfInt
- HalfInt
b = Int -> HalfInt
divByTwo forall a b. (a -> b) -> a -> b
$ HalfInt -> Int
mulByTwo HalfInt
a forall a. Num a => a -> a -> a
- HalfInt -> Int
mulByTwo HalfInt
b
  HalfInt
a * :: HalfInt -> HalfInt -> HalfInt
* HalfInt
b = case forall a. Integral a => a -> a -> (a, a)
divMod (HalfInt -> Int
mulByTwo HalfInt
a forall a. Num a => a -> a -> a
* HalfInt -> Int
mulByTwo HalfInt
b) Int
4 of
            (Int
k,Int
0) -> Int -> HalfInt
HalfInt (Int
2forall a. Num a => a -> a -> a
*Int
k)
            (Int
k,Int
2) -> Int -> HalfInt
HalfInt (Int
2forall a. Num a => a -> a -> a
*Int
kforall a. Num a => a -> a -> a
+Int
1)
            (Int, Int)
_     -> forall a. HasCallStack => String -> a
error String
"the result of multiplication is not a half-integer"
  negate :: HalfInt -> HalfInt
negate = Int -> HalfInt
divByTwo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo
  signum :: HalfInt -> HalfInt
signum = Int -> HalfInt
divByTwo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
signum forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo
  abs :: HalfInt -> HalfInt
abs    = Int -> HalfInt
divByTwo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs    forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo

--------------------------------------------------------------------------------

-- * Vectors of half-integers


type HalfVec = [HalfInt]

instance Num HalfVec where
  fromInteger :: Integer -> HalfVec
fromInteger = forall a. HasCallStack => String -> a
error String
"HalfVec/fromInteger"
  + :: HalfVec -> HalfVec -> HalfVec
(+) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip forall a. Num a => a -> a -> a
(+)
  (-) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip (-)
  * :: HalfVec -> HalfVec -> HalfVec
(*) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip forall a. Num a => a -> a -> a
(*)
  negate :: HalfVec -> HalfVec
negate = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
negate
  abs :: HalfVec -> HalfVec
abs    = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
abs
  signum :: HalfVec -> HalfVec
signum = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
signum

scaleVec :: Int -> HalfVec -> HalfVec  
scaleVec :: Int -> HalfVec -> HalfVec
scaleVec Int
k = forall a b. (a -> b) -> [a] -> [b]
map (Int -> HalfInt -> HalfInt
scaleBy Int
k)

negateVec :: HalfVec -> HalfVec
negateVec :: HalfVec -> HalfVec
negateVec = forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
negate

-- dotProd :: HalfVec -> HalfVec

-- dotProd xs ys = foldl' (+) 0 $ safeZip (*) xs ys


safeZip :: (a -> b -> c) -> [a] -> [b] -> [c]
safeZip :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip a -> b -> c
f = [a] -> [b] -> [c]
go where
  go :: [a] -> [b] -> [c]
go (a
x:[a]
xs) (b
y:[b]
ys) = a -> b -> c
f a
x b
y forall a. a -> [a] -> [a]
: [a] -> [b] -> [c]
go [a]
xs [b]
ys
  go []     []     = []
  go [a]
_      [b]
_      = forall a. HasCallStack => String -> a
error String
"safeZip: the lists do not have equal length"

--------------------------------------------------------------------------------

-- * Dynkin diagrams


data Dynkin
  = A !Int
  | B !Int
  | C !Int
  | D !Int
  | E6 | E7 | E8
  | F4
  | G2
  deriving (Dynkin -> Dynkin -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dynkin -> Dynkin -> Bool
$c/= :: Dynkin -> Dynkin -> Bool
== :: Dynkin -> Dynkin -> Bool
$c== :: Dynkin -> Dynkin -> Bool
Eq,Int -> Dynkin -> ShowS
[Dynkin] -> ShowS
Dynkin -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dynkin] -> ShowS
$cshowList :: [Dynkin] -> ShowS
show :: Dynkin -> String
$cshow :: Dynkin -> String
showsPrec :: Int -> Dynkin -> ShowS
$cshowsPrec :: Int -> Dynkin -> ShowS
Show)

--------------------------------------------------------------------------------

-- * The roots of root systems


-- | The ambient dimension of (our representation of the) system (length of the vector)

ambientDim :: Dynkin -> Int
ambientDim :: Dynkin -> Int
ambientDim Dynkin
d = case Dynkin
d of
  A Int
n -> Int
nforall a. Num a => a -> a -> a
+Int
1   -- it's an n dimensional subspace of (n+1) dimensions

  B Int
n -> Int
n
  C Int
n -> Int
n
  D Int
n -> Int
n
  Dynkin
E6  -> Int
6
  Dynkin
E7  -> Int
8     -- sublattice of E8 ?

  Dynkin
E8  -> Int
8
  Dynkin
F4  -> Int
4
  Dynkin
G2  -> Int
3     -- it's a 2 dimensional subspace of 3 dimensions


simpleRootsOf :: Dynkin -> [HalfVec]
simpleRootsOf :: Dynkin -> [HalfVec]
simpleRootsOf Dynkin
d = 

  case Dynkin
d of

    A Int
n -> [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
n]   ]

    B Int
n -> [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nforall a. Num a => a -> a -> a
-Int
1] ] forall a. [a] -> [a] -> [a]
++ [Int -> HalfVec
e Int
n]

    C Int
n -> [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nforall a. Num a => a -> a -> a
-Int
1] ] forall a. [a] -> [a] -> [a]
++ [Int -> HalfVec -> HalfVec
scaleVec Int
2 (Int -> HalfVec
e Int
n)]

    D Int
n -> [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nforall a. Num a => a -> a -> a
-Int
1] ] forall a. [a] -> [a] -> [a]
++ [Int -> HalfVec
e (Int
nforall a. Num a => a -> a -> a
-Int
1) forall a. Num a => a -> a -> a
+ Int -> HalfVec
e Int
n]

    Dynkin
E6  -> [HalfVec]
simpleRootsE6_123
    Dynkin
E7  -> [HalfVec]
simpleRootsE7_12
    Dynkin
E8  -> [HalfVec]
simpleRootsE8_even 

    Dynkin
F4  -> [ [ HalfInt
1,-HalfInt
1, HalfInt
0, HalfInt
0]
           , [ HalfInt
0, HalfInt
1,-HalfInt
1, HalfInt
0]
           , [ HalfInt
0, HalfInt
0, HalfInt
1, HalfInt
0]
           , [-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h]
           ]

    Dynkin
G2  -> [ [ HalfInt
1,-HalfInt
1, HalfInt
0]
           , [-HalfInt
1, HalfInt
2,-HalfInt
1]
           ]

  where
    h :: HalfInt
h = HalfInt
half
    n :: Int
n = Dynkin -> Int
ambientDim Dynkin
d

    e :: Int -> HalfVec
    e :: Int -> HalfVec
e Int
i = forall a. Int -> a -> [a]
replicate (Int
iforall a. Num a => a -> a -> a
-Int
1) HalfInt
0 forall a. [a] -> [a] -> [a]
++ [HalfInt
1] forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
-Int
i) HalfInt
0

positiveRootsOf :: Dynkin -> Set HalfVec
positiveRootsOf :: Dynkin -> Set HalfVec
positiveRootsOf = [HalfVec] -> Set HalfVec
positiveRoots forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynkin -> [HalfVec]
simpleRootsOf

negativeRootsOf :: Dynkin -> Set HalfVec
negativeRootsOf :: Dynkin -> Set HalfVec
negativeRootsOf = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynkin -> Set HalfVec
positiveRootsOf

allRootsOf :: Dynkin -> Set HalfVec
allRootsOf :: Dynkin -> Set HalfVec
allRootsOf Dynkin
dynkin = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [  Set HalfVec
pos , Set HalfVec
neg ] where
  simple :: [HalfVec]
simple = Dynkin -> [HalfVec]
simpleRootsOf Dynkin
dynkin
  pos :: Set HalfVec
pos   = [HalfVec] -> Set HalfVec
positiveRoots [HalfVec]
simple
  neg :: Set HalfVec
neg   = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. Num a => a -> a
negate Set HalfVec
pos

--------------------------------------------------------------------------------

-- * Positive roots


-- | Finds a vector, which is hopefully not orthognal to any root

-- (generated by the given simple roots), and has positive dot product with each of them.

findPositiveHyperplane :: [HalfVec] -> [Double]
findPositiveHyperplane :: [HalfVec] -> [Double]
findPositiveHyperplane [HalfVec]
vs = [Double]
w where
  n :: Int
n  = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. [a] -> a
head [HalfVec]
vs)
  w0 :: [Double]
w0 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo) (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Num a => a -> a -> a
(+) [HalfVec]
vs) :: [Double]
  w :: [Double]
w  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Double]
w0 [Double]
perturb
  perturb :: [Double]
perturb = forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
small forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
n [Integer]
primes
  small :: Double -> Double
  small :: Double -> Double
small Double
x = Double
x forall a. Fractional a => a -> a -> a
/ (Double
10forall a. Floating a => a -> a -> a
**Double
10) 

positiveRoots :: [HalfVec] -> Set HalfVec
positiveRoots :: [HalfVec] -> Set HalfVec
positiveRoots [HalfVec]
simples = forall a. Ord a => [a] -> Set a
Set.fromList [HalfVec]
pos where
  roots :: Set HalfVec
roots = [HalfVec] -> Set HalfVec
mirrorClosure [HalfVec]
simples
  w :: [Double]
w     = [HalfVec] -> [Double]
findPositiveHyperplane [HalfVec]
simples
  pos :: [HalfVec]
pos   = [ HalfVec
r | HalfVec
r <- forall a. Set a -> [a]
Set.toList Set HalfVec
roots , HalfVec -> Double
dot4 HalfVec
r forall a. Ord a => a -> a -> Bool
> Double
0 ] where

  dot4 :: HalfVec -> Double
  dot4 :: HalfVec -> Double
dot4 HalfVec
a = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Double
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip forall a. Num a => a -> a -> a
(*) [Double]
w forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo) HalfVec
a

basisOfPositives :: Set HalfVec -> [HalfVec]
basisOfPositives :: Set HalfVec -> [HalfVec]
basisOfPositives Set HalfVec
set = forall a. Set a -> [a]
Set.toList (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set HalfVec
set Set HalfVec
set2) where
  set2 :: Set HalfVec
set2 = forall a. Ord a => [a] -> Set a
Set.fromList [ HalfVec
a forall a. Num a => a -> a -> a
+ HalfVec
b | [HalfVec
a,HalfVec
b] <- forall a. Int -> [a] -> [[a]]
choose Int
2 (forall a. Set a -> [a]
Set.toList Set HalfVec
set) ]


--------------------------------------------------------------------------------

-- * Operations on half-integer vectors


-- | bracket b a = (a,b)/(a,a) 

bracket :: HalfVec -> HalfVec -> HalfInt
bracket :: HalfVec -> HalfVec -> HalfInt
bracket HalfVec
b HalfVec
a = 
  case forall a. Integral a => a -> a -> (a, a)
divMod (Int
2forall a. Num a => a -> a -> a
*Int
a_dot_b) (Int
a_dot_a) of
    (Int
n,Int
0) -> Int -> HalfInt
divByTwo Int
n
    (Int, Int)
_     -> forall a. HasCallStack => String -> a
error String
"bracket: result is not a half-integer"
  where
    a_dot_b :: Int
a_dot_b = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip forall a. Num a => a -> a -> a
(*) (forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> Int
mulByTwo HalfVec
a) (forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> Int
mulByTwo HalfVec
b)
    a_dot_a :: Int
a_dot_a = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip forall a. Num a => a -> a -> a
(*) (forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> Int
mulByTwo HalfVec
a) (forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> Int
mulByTwo HalfVec
a)

-- | mirror b a = b - 2*(a,b)/(a,a) * a

mirror :: HalfVec -> HalfVec -> HalfVec
mirror :: HalfVec -> HalfVec -> HalfVec
mirror HalfVec
b HalfVec
a = HalfVec
b forall a. Num a => a -> a -> a
- Int -> HalfVec -> HalfVec
scaleVec (HalfInt -> Int
mulByTwo forall a b. (a -> b) -> a -> b
$ HalfVec -> HalfVec -> HalfInt
bracket HalfVec
b HalfVec
a) HalfVec
a

-- | Cartan matrix of a list of (simple) roots

cartanMatrix :: [HalfVec] -> Array (Int,Int) Int
cartanMatrix :: [HalfVec] -> Array (Int, Int) Int
cartanMatrix [HalfVec]
list = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int
1,Int
1),(Int
n,Int
n)) [ ((Int
i,Int
j), Int -> Int -> Int
f Int
i Int
j) | Int
i<-[Int
1..Int
n] , Int
j<-[Int
1..Int
n] ] where
  n :: Int
n   = forall (t :: * -> *) a. Foldable t => t a -> Int
length [HalfVec]
list
  arr :: Array Int HalfVec
arr = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,Int
n) [HalfVec]
list
  f :: Int -> Int -> Int
f !Int
i !Int
j = HalfInt -> Int
mulByTwo forall a b. (a -> b) -> a -> b
$ HalfVec -> HalfVec -> HalfInt
bracket (Array Int HalfVec
arrforall i e. Ix i => Array i e -> i -> e
!Int
j) (Array Int HalfVec
arrforall i e. Ix i => Array i e -> i -> e
!Int
i)

printMatrix :: Show a => Array (Int,Int) a -> IO ()
printMatrix :: forall a. Show a => Array (Int, Int) a -> IO ()
printMatrix Array (Int, Int) a
arr = do
  let ((Int
1,Int
1),(Int
n,Int
m)) = forall i e. Array i e -> (i, i)
bounds Array (Int, Int) a
arr
      arr' :: Array (Int, Int) String
arr' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show Array (Int, Int) a
arr
  let ks :: [Int]
ks   = [ Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array (Int, Int) String
arr'forall i e. Ix i => Array i e -> i -> e
!(Int
i,Int
j)) | Int
i<-[Int
1..Int
n] ] | Int
j<-[Int
1..Int
m] ]
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Int
1..Int
m] forall a b. (a -> b) -> a -> b
$ \Int
j -> Int -> ShowS
extendTo ([Int]
ksforall a. [a] -> Int -> a
!!(Int
jforall a. Num a => a -> a -> a
-Int
1)) forall a b. (a -> b) -> a -> b
$ Array (Int, Int) String
arr' forall i e. Ix i => Array i e -> i -> e
! (Int
i,Int
j)
  where
    extendTo :: Int -> ShowS
extendTo Int
n String
s = forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
-forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' forall a. [a] -> [a] -> [a]
++ String
s

--------------------------------------------------------------------------------

-- * Mirroring 


-- | We mirror stuff until there is no more things happening

-- (very naive algorithm, but seems to work)

mirrorClosure :: [HalfVec] -> Set HalfVec
mirrorClosure :: [HalfVec] -> Set HalfVec
mirrorClosure = Set HalfVec -> Set HalfVec
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList where 
  
  go :: Set HalfVec -> Set HalfVec
go Set HalfVec
set 
    | Int
n'  forall a. Ord a => a -> a -> Bool
> Int
n   = Set HalfVec -> Set HalfVec
go Set HalfVec
set'
    | Int
n'' forall a. Ord a => a -> a -> Bool
> Int
n   = Set HalfVec -> Set HalfVec
go Set HalfVec
set''
    | Bool
otherwise = Set HalfVec
set
    where
      n :: Int
n   = forall a. Set a -> Int
Set.size Set HalfVec
set
      n' :: Int
n'  = forall a. Set a -> Int
Set.size Set HalfVec
set'
      n'' :: Int
n'' = forall a. Set a -> Int
Set.size Set HalfVec
set''
      set' :: Set HalfVec
set'  = Set HalfVec -> Set HalfVec
mirrorStep Set HalfVec
set
      set'' :: Set HalfVec
set'' = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set HalfVec
set (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map HalfVec -> HalfVec
negateVec Set HalfVec
set) 

mirrorStep :: Set HalfVec -> Set HalfVec
mirrorStep :: Set HalfVec -> Set HalfVec
mirrorStep Set HalfVec
old = forall a. Ord a => Set a -> Set a -> Set a
Set.union Set HalfVec
old Set HalfVec
new where
  new :: Set HalfVec
new = forall a. Ord a => [a] -> Set a
Set.fromList [ HalfVec -> HalfVec -> HalfVec
mirror HalfVec
b HalfVec
a | [HalfVec
a,HalfVec
b] <- forall a. Int -> [a] -> [[a]]
choose Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set HalfVec
old ] 

--------------------------------------------------------------------------------

-- * E6, E7 and E8


-- | This is a basis of E6 as the subset of the even E8 root system

-- where the first three coordinates agree (they are consolidated 

-- into the first coordinate here)

simpleRootsE6_123:: [HalfVec]
simpleRootsE6_123 :: [HalfVec]
simpleRootsE6_123 = [HalfVec]
roots where
  h :: HalfInt
h = HalfInt
half
  roots :: [HalfVec]
roots =
    [ [-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h]
    , [ HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h,-HalfInt
h,-HalfInt
h]
    , [ HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
0, HalfInt
1, HalfInt
0]
    , [ HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
1]
    , [-HalfInt
h,-HalfInt
h,-HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h,-HalfInt
h]
    , [ HalfInt
0, HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
1, HalfInt
0, HalfInt
0, HalfInt
0]
    ]

-- | This is a basis of E8 as the subset of the even E8 root system

-- where the first two coordinates agree (they are consolidated 

-- into the first coordinate here)

simpleRootsE7_12:: [HalfVec]
simpleRootsE7_12 :: [HalfVec]
simpleRootsE7_12 = [HalfVec]
roots where
  h :: HalfInt
h = HalfInt
half
  roots :: [HalfVec]
roots =
    [ [-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h]
    , [ HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h, HalfInt
h,-HalfInt
h,-HalfInt
h]
    , [ HalfInt
h, HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h, HalfInt
h, HalfInt
h]
    , [-HalfInt
h,-HalfInt
h, HalfInt
h, HalfInt
h,-HalfInt
h, HalfInt
h, HalfInt
h,-HalfInt
h]
    , [ HalfInt
0, HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
1, HalfInt
0, HalfInt
0, HalfInt
0]
    , [ HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
1, HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0]
    , [ HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0, HalfInt
0,-HalfInt
1, HalfInt
1]
    ]

-- | This is a basis of E7 as the subset of the even E8 root system

-- for which the sum of coordinates sum to zero

simpleRootsE7_diag :: [HalfVec]
simpleRootsE7_diag :: [HalfVec]
simpleRootsE7_diag = [HalfVec]
roots where
  roots :: [HalfVec]
roots = [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
2..Int
7] ] forall a. [a] -> [a] -> [a]
++ [[HalfInt
h,HalfInt
h,HalfInt
h,HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h]]
  h :: HalfInt
h = HalfInt
half
  n :: Int
n = Int
8

  e :: Int -> HalfVec
  e :: Int -> HalfVec
e Int
i = forall a. Int -> a -> [a]
replicate (Int
iforall a. Num a => a -> a -> a
-Int
1) HalfInt
0 forall a. [a] -> [a] -> [a]
++ [HalfInt
1] forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
-Int
i) HalfInt
0 

simpleRootsE8_even :: [HalfVec]
simpleRootsE8_even :: [HalfVec]
simpleRootsE8_even = [HalfVec]
roots where
  roots :: [HalfVec]
roots = [HalfVec
v1,HalfVec
v2,HalfVec
v3,HalfVec
v4,HalfVec
v5,HalfVec
v7,HalfVec
v8,HalfVec
v6]

  [HalfVec
v1,HalfVec
v2,HalfVec
v3,HalfVec
v4,HalfVec
v5,HalfVec
v6,HalfVec
v7,HalfVec
v8] = [HalfVec]
roots0
  roots0 :: [HalfVec]
roots0 = [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
1..Int
6] ] forall a. [a] -> [a] -> [a]
++ [ Int -> HalfVec
e Int
6 forall a. Num a => a -> a -> a
+ Int -> HalfVec
e Int
7 , forall a. Int -> a -> [a]
replicate Int
8 (-HalfInt
h)  ]
    
  h :: HalfInt
h = HalfInt
half
  n :: Int
n = Int
8

  e :: Int -> HalfVec
  e :: Int -> HalfVec
e Int
i = forall a. Int -> a -> [a]
replicate (Int
iforall a. Num a => a -> a -> a
-Int
1) HalfInt
0 forall a. [a] -> [a] -> [a]
++ [HalfInt
1] forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
-Int
i) HalfInt
0

simpleRootsE8_odd :: [HalfVec]
simpleRootsE8_odd :: [HalfVec]
simpleRootsE8_odd = [HalfVec]
roots where
  roots :: [HalfVec]
roots = [ Int -> HalfVec
e Int
i forall a. Num a => a -> a -> a
- Int -> HalfVec
e (Int
iforall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
1..Int
7] ] forall a. [a] -> [a] -> [a]
++ [[-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h,-HalfInt
h , HalfInt
h,HalfInt
h,HalfInt
h]]
  h :: HalfInt
h = HalfInt
half
  n :: Int
n = Int
8

  e :: Int -> HalfVec
  e :: Int -> HalfVec
e Int
i = forall a. Int -> a -> [a]
replicate (Int
iforall a. Num a => a -> a -> a
-Int
1) HalfInt
0 forall a. [a] -> [a] -> [a]
++ [HalfInt
1] forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
nforall a. Num a => a -> a -> a
-Int
i) HalfInt
0 

--------------------------------------------------------------------------------