-- | 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
(HalfInt -> HalfInt -> Bool)
-> (HalfInt -> HalfInt -> Bool) -> Eq HalfInt
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
Eq HalfInt
-> (HalfInt -> HalfInt -> Ordering)
-> (HalfInt -> HalfInt -> Bool)
-> (HalfInt -> HalfInt -> Bool)
-> (HalfInt -> HalfInt -> Bool)
-> (HalfInt -> HalfInt -> Bool)
-> (HalfInt -> HalfInt -> HalfInt)
-> (HalfInt -> HalfInt -> HalfInt)
-> Ord 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
$cp1Ord :: Eq HalfInt
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
kInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n)

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

instance Num HalfInt where
  fromInteger :: Integer -> HalfInt
fromInteger = Int -> HalfInt
HalfInt (Int -> HalfInt) -> (Integer -> Int) -> Integer -> HalfInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2) (Int -> Int) -> (Integer -> Int) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger
  HalfInt
a + :: HalfInt -> HalfInt -> HalfInt
+ HalfInt
b = Int -> HalfInt
divByTwo (Int -> HalfInt) -> Int -> HalfInt
forall a b. (a -> b) -> a -> b
$ HalfInt -> Int
mulByTwo HalfInt
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ HalfInt -> Int
mulByTwo HalfInt
b
  HalfInt
a - :: HalfInt -> HalfInt -> HalfInt
- HalfInt
b = Int -> HalfInt
divByTwo (Int -> HalfInt) -> Int -> HalfInt
forall a b. (a -> b) -> a -> b
$ HalfInt -> Int
mulByTwo HalfInt
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- HalfInt -> Int
mulByTwo HalfInt
b
  HalfInt
a * :: HalfInt -> HalfInt -> HalfInt
* HalfInt
b = case Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (HalfInt -> Int
mulByTwo HalfInt
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* HalfInt -> Int
mulByTwo HalfInt
b) Int
4 of
            (Int
k,Int
0) -> Int -> HalfInt
HalfInt (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
k)
            (Int
k,Int
2) -> Int -> HalfInt
HalfInt (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            (Int, Int)
_     -> String -> HalfInt
forall a. HasCallStack => String -> a
error String
"the result of multiplication is not a half-integer"
  negate :: HalfInt -> HalfInt
negate = Int -> HalfInt
divByTwo (Int -> HalfInt) -> (HalfInt -> Int) -> HalfInt -> HalfInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (HalfInt -> Int) -> HalfInt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo
  signum :: HalfInt -> HalfInt
signum = Int -> HalfInt
divByTwo (Int -> HalfInt) -> (HalfInt -> Int) -> HalfInt -> HalfInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
signum (Int -> Int) -> (HalfInt -> Int) -> HalfInt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo
  abs :: HalfInt -> HalfInt
abs    = Int -> HalfInt
divByTwo (Int -> HalfInt) -> (HalfInt -> Int) -> HalfInt -> HalfInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
abs    (Int -> Int) -> (HalfInt -> Int) -> HalfInt -> Int
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 -> [HalfInt]
fromInteger = String -> Integer -> [HalfInt]
forall a. HasCallStack => String -> a
error String
"HalfVec/fromInteger"
  + :: [HalfInt] -> [HalfInt] -> [HalfInt]
(+) = (HalfInt -> HalfInt -> HalfInt)
-> [HalfInt] -> [HalfInt] -> [HalfInt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip HalfInt -> HalfInt -> HalfInt
forall a. Num a => a -> a -> a
(+)
  (-) = (HalfInt -> HalfInt -> HalfInt)
-> [HalfInt] -> [HalfInt] -> [HalfInt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip (-)
  * :: [HalfInt] -> [HalfInt] -> [HalfInt]
(*) = (HalfInt -> HalfInt -> HalfInt)
-> [HalfInt] -> [HalfInt] -> [HalfInt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
safeZip HalfInt -> HalfInt -> HalfInt
forall a. Num a => a -> a -> a
(*)
  negate :: [HalfInt] -> [HalfInt]
negate = (HalfInt -> HalfInt) -> [HalfInt] -> [HalfInt]
forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> HalfInt
forall a. Num a => a -> a
negate
  abs :: [HalfInt] -> [HalfInt]
abs    = (HalfInt -> HalfInt) -> [HalfInt] -> [HalfInt]
forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> HalfInt
forall a. Num a => a -> a
abs
  signum :: [HalfInt] -> [HalfInt]
signum = (HalfInt -> HalfInt) -> [HalfInt] -> [HalfInt]
forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> HalfInt
forall a. Num a => a -> a
signum

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

negateVec :: HalfVec -> HalfVec
negateVec :: [HalfInt] -> [HalfInt]
negateVec = (HalfInt -> HalfInt) -> [HalfInt] -> [HalfInt]
forall a b. (a -> b) -> [a] -> [b]
map HalfInt -> HalfInt
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 :: (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 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [c]
go [a]
xs [b]
ys
  go []     []     = []
  go [a]
_      [b]
_      = String -> [c]
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
(Dynkin -> Dynkin -> Bool)
-> (Dynkin -> Dynkin -> Bool) -> Eq Dynkin
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
(Int -> Dynkin -> ShowS)
-> (Dynkin -> String) -> ([Dynkin] -> ShowS) -> Show Dynkin
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
nInt -> Int -> Int
forall 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 -> [[HalfInt]]
simpleRootsOf Dynkin
d = 

  case Dynkin
d of

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

    B Int
n -> [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
forall a. [a] -> [a] -> [a]
++ [Int -> [HalfInt]
e Int
n]

    C Int
n -> [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
forall a. [a] -> [a] -> [a]
++ [Int -> [HalfInt] -> [HalfInt]
scaleVec Int
2 (Int -> [HalfInt]
e Int
n)]

    D Int
n -> [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <- [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
forall a. [a] -> [a] -> [a]
++ [Int -> [HalfInt]
e (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
+ Int -> [HalfInt]
e Int
n]

    Dynkin
E6  -> [[HalfInt]]
simpleRootsE6_123
    Dynkin
E7  -> [[HalfInt]]
simpleRootsE7_12
    Dynkin
E8  -> [[HalfInt]]
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 -> [HalfInt]
e Int
i = Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HalfInt
0 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ [HalfInt
1] [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) HalfInt
0

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

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

allRootsOf :: Dynkin -> Set HalfVec
allRootsOf :: Dynkin -> Set [HalfInt]
allRootsOf Dynkin
dynkin = [Set [HalfInt]] -> Set [HalfInt]
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [  Set [HalfInt]
pos , Set [HalfInt]
neg ] where
  simple :: [[HalfInt]]
simple = Dynkin -> [[HalfInt]]
simpleRootsOf Dynkin
dynkin
  pos :: Set [HalfInt]
pos   = [[HalfInt]] -> Set [HalfInt]
positiveRoots [[HalfInt]]
simple
  neg :: Set [HalfInt]
neg   = ([HalfInt] -> [HalfInt]) -> Set [HalfInt] -> Set [HalfInt]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map [HalfInt] -> [HalfInt]
forall a. Num a => a -> a
negate Set [HalfInt]
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 :: [[HalfInt]] -> [Double]
findPositiveHyperplane [[HalfInt]]
vs = [Double]
w where
  n :: Int
n  = [HalfInt] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[HalfInt]] -> [HalfInt]
forall a. [a] -> a
head [[HalfInt]]
vs)
  w0 :: [Double]
w0 = (HalfInt -> Double) -> [HalfInt] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (HalfInt -> Int) -> HalfInt -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HalfInt -> Int
mulByTwo) (([HalfInt] -> [HalfInt] -> [HalfInt]) -> [[HalfInt]] -> [HalfInt]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
(+) [[HalfInt]]
vs) :: [Double]
  w :: [Double]
w  = (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) [Double]
w0 [Double]
perturb
  perturb :: [Double]
perturb = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
small ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ (Integer -> Double) -> [Integer] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Integer] -> [Double]) -> [Integer] -> [Double]
forall a b. (a -> b) -> a -> b
$ Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
n [Integer]
primes
  small :: Double -> Double
  small :: Double -> Double
small Double
x = Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
10Double -> Double -> Double
forall a. Floating a => a -> a -> a
**Double
10) 

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

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

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


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

-- * Operations on half-integer vectors


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

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

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

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

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

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

printMatrix :: Show a => Array (Int,Int) a -> IO ()
printMatrix :: Array (Int, Int) a -> IO ()
printMatrix Array (Int, Int) a
arr = do
  let ((Int
1,Int
1),(Int
n,Int
m)) = Array (Int, Int) a -> ((Int, Int), (Int, Int))
forall i e. Array i e -> (i, i)
bounds Array (Int, Int) a
arr
      arr' :: Array (Int, Int) String
arr' = (a -> String) -> Array (Int, Int) a -> Array (Int, Int) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
forall a. Show a => a -> String
show Array (Int, Int) a
arr
  let ks :: [Int]
ks   = [ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array (Int, Int) String
arr'Array (Int, Int) String -> (Int, Int) -> String
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] ]
  [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Int -> String) -> [Int] -> String)
-> [Int] -> (Int -> String) -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Int
1..Int
m] ((Int -> String) -> String) -> (Int -> String) -> String
forall a b. (a -> b) -> a -> b
$ \Int
j -> Int -> ShowS
extendTo ([Int]
ks[Int] -> Int -> Int
forall a. [a] -> Int -> a
!!(Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Array (Int, Int) String
arr' Array (Int, Int) String -> (Int, Int) -> String
forall i e. Ix i => Array i e -> i -> e
! (Int
i,Int
j)
  where
    extendTo :: Int -> ShowS
extendTo Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> ShowS
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 :: [[HalfInt]] -> Set [HalfInt]
mirrorClosure = Set [HalfInt] -> Set [HalfInt]
go (Set [HalfInt] -> Set [HalfInt])
-> ([[HalfInt]] -> Set [HalfInt]) -> [[HalfInt]] -> Set [HalfInt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[HalfInt]] -> Set [HalfInt]
forall a. Ord a => [a] -> Set a
Set.fromList where 
  
  go :: Set [HalfInt] -> Set [HalfInt]
go Set [HalfInt]
set 
    | Int
n'  Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n   = Set [HalfInt] -> Set [HalfInt]
go Set [HalfInt]
set'
    | Int
n'' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n   = Set [HalfInt] -> Set [HalfInt]
go Set [HalfInt]
set''
    | Bool
otherwise = Set [HalfInt]
set
    where
      n :: Int
n   = Set [HalfInt] -> Int
forall a. Set a -> Int
Set.size Set [HalfInt]
set
      n' :: Int
n'  = Set [HalfInt] -> Int
forall a. Set a -> Int
Set.size Set [HalfInt]
set'
      n'' :: Int
n'' = Set [HalfInt] -> Int
forall a. Set a -> Int
Set.size Set [HalfInt]
set''
      set' :: Set [HalfInt]
set'  = Set [HalfInt] -> Set [HalfInt]
mirrorStep Set [HalfInt]
set
      set'' :: Set [HalfInt]
set'' = Set [HalfInt] -> Set [HalfInt] -> Set [HalfInt]
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set [HalfInt]
set (([HalfInt] -> [HalfInt]) -> Set [HalfInt] -> Set [HalfInt]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map [HalfInt] -> [HalfInt]
negateVec Set [HalfInt]
set) 

mirrorStep :: Set HalfVec -> Set HalfVec
mirrorStep :: Set [HalfInt] -> Set [HalfInt]
mirrorStep Set [HalfInt]
old = Set [HalfInt] -> Set [HalfInt] -> Set [HalfInt]
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set [HalfInt]
old Set [HalfInt]
new where
  new :: Set [HalfInt]
new = [[HalfInt]] -> Set [HalfInt]
forall a. Ord a => [a] -> Set a
Set.fromList [ [HalfInt] -> [HalfInt] -> [HalfInt]
mirror [HalfInt]
b [HalfInt]
a | [[HalfInt]
a,[HalfInt]
b] <- Int -> [[HalfInt]] -> [[[HalfInt]]]
forall a. Int -> [a] -> [[a]]
choose Int
2 ([[HalfInt]] -> [[[HalfInt]]]) -> [[HalfInt]] -> [[[HalfInt]]]
forall a b. (a -> b) -> a -> b
$ Set [HalfInt] -> [[HalfInt]]
forall a. Set a -> [a]
Set.toList Set [HalfInt]
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 :: [[HalfInt]]
simpleRootsE6_123 = [[HalfInt]]
roots where
  h :: HalfInt
h = HalfInt
half
  roots :: [[HalfInt]]
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 :: [[HalfInt]]
simpleRootsE7_12 = [[HalfInt]]
roots where
  h :: HalfInt
h = HalfInt
half
  roots :: [[HalfInt]]
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 :: [[HalfInt]]
simpleRootsE7_diag = [[HalfInt]]
roots where
  roots :: [[HalfInt]]
roots = [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
2..Int
7] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
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 -> [HalfInt]
e Int
i = Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HalfInt
0 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ [HalfInt
1] [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) HalfInt
0 

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

  [[HalfInt]
v1,[HalfInt]
v2,[HalfInt]
v3,[HalfInt]
v4,[HalfInt]
v5,[HalfInt]
v6,[HalfInt]
v7,[HalfInt]
v8] = [[HalfInt]]
roots0
  roots0 :: [[HalfInt]]
roots0 = [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
1..Int
6] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
forall a. [a] -> [a] -> [a]
++ [ Int -> [HalfInt]
e Int
6 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
+ Int -> [HalfInt]
e Int
7 , Int -> HalfInt -> [HalfInt]
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 -> [HalfInt]
e Int
i = Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HalfInt
0 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ [HalfInt
1] [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) HalfInt
0

simpleRootsE8_odd :: [HalfVec]
simpleRootsE8_odd :: [[HalfInt]]
simpleRootsE8_odd = [[HalfInt]]
roots where
  roots :: [[HalfInt]]
roots = [ Int -> [HalfInt]
e Int
i [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. Num a => a -> a -> a
- Int -> [HalfInt]
e (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
i <-[Int
1..Int
7] ] [[HalfInt]] -> [[HalfInt]] -> [[HalfInt]]
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 -> [HalfInt]
e Int
i = Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HalfInt
0 [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ [HalfInt
1] [HalfInt] -> [HalfInt] -> [HalfInt]
forall a. [a] -> [a] -> [a]
++ Int -> HalfInt -> [HalfInt]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) HalfInt
0 

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