module E7 where


import           E8 (Vector,inp,e,showVector)
import qualified E8

import           Control.Applicative ((<$>),(<*>))
import           Control.Arrow       ((&&&))
import           Control.Monad       (msum)
import qualified Data.Vector   as V
import           Data.List           (genericLength)
import           Data.Maybe          (catMaybes)
import qualified Number.Peano  as Peano
import           Prelude hiding ((+))
import           System.Environment  (getArgs)

import           NumericPrelude      ((+))


-- Main program

main :: IO ()
main = do
  d : rest <- map read <$> getArgs
  putStr $ "d = " ++ show d ++ ": "
  if null rest
    then do
      let
        candidates = filter ((>= peano1) . snd) $ map (id &&& orthos) (gen d)
        special = filter ((<= peano8) . snd) candidates
        verySpecial = filter ((<= peano7) . snd) special
      case (map fst special,map fst verySpecial) of
        ([]   ,_    ) -> putStrLn $ "No special vectors found."
        (x : _,[]   ) -> putStrLn $ "No very special vectors, but found special vector:" ++ showVector x
        (_    ,x : _) -> putStrLn $ "Found very special vector:" ++ showVector x
    else
      putStrLn $ "Generated: " ++ show (length $ gen d)

-- Compute the number of *positive* roots orthogonal to the given vector.
orthos :: Vector -> Peano.T
orthos = genericLength . filter (== 0) . flip map posRoots . inp

peano1,peano7,peano8 :: Peano.T
peano1 = 1
peano7 = 7
peano8 = 8

-- Let H be the group of permutations and even sign changes, a subgroup of
-- the Weyl group of E_8.
-- @E8.gen d@ intersects every H-orbit of E_8 (of vectors of length @d@).
-- We want the intersection of every H-orbit with E_7 (or at least a
-- representative of every W(E_7)-orbit of such).
-- Now, since v \elem E_7 iff <v,e_7 + e_8> = 0 iff v_7 = -v_8, elements of
-- this intersection occur precisely when the representative has two
-- components that are equal up to sign change.
-- This is made easier by the fact that 'E8.gen' gives vectors with
-- nondecreasing successive coordinates.
e7InOrbit :: Vector -> [Vector]
e7InOrbit v = fmap V.fromList . concat . (zipWith3 f <$> id <*> tail <*> const [0 ..]) $ l
 where
  l = V.toList v
  f x y i = let (init,rest) = splitAt i l in case () of
    _ | x == y        -> [negateFirst $ init ++ drop 2 rest ++ [x,negate y]]
      | x == negate y -> [              init ++ drop 2 rest ++ [x,y]       ]
      | otherwise     -> []
  negateFirst (x : xs) = negate x : xs

-- We want to generate elements of E_7, at least one out of every W(E_7)-orbit.
-- This approach is not optimal: it may even give more than one element per 
-- $H `intersect` W(E_7)$-orbit.
gen :: Int -> [Vector]
gen = concatMap e7InOrbit . E8.gen

-- test:
-- *E7> mapM_ print . map (map numerator . V.toList) $ e7InOrbit v
-- *E7> :m +Data.Ratio
-- *E7 Data.Ratio> mapM_ print . map (map numerator . V.toList) $ e7InOrbit v


e7 :: Vector -> Bool
e7 = (== 0) . inp (e 7 + e 8)

posRoots :: [Vector]
posRoots = filter e7 E8.posRoots