----------------------------------------------------------------------------
-- 
-- Copyright   :  (C) 2017 Yuchen Pei
-- License     :  GPLv3+
--
-- Maintainer  :  Yuchen Pei
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
--import Math.Combinatorics.RootSystem hiding (s)
import RootSystem hiding (s)
import YoungTableaux
import RobinsonSchensted
import Math.Algebra.LinearAlgebra
import Prelude hiding ( (*>), Word )
import Test.QuickCheck
import qualified Data.List as L
import Data.Ratio

-- |pitman t n xs is the Pitman's transform of type t_n acting on path xs. It pre-processes xs by prepending a row of zeros to the input and post-processes by removing the first row of the output
pitman :: Type -> Int -> [[Q]] -> [[Q]]
pitman t n xs = tail $ foldr s (prependWithZero xs) (longestElement $ simpleSystem t n)

prependWithZero :: [[Q]] -> [[Q]]
prependWithZero [] = []
prependWithZero xs = (replicate (length $ head xs) 0) : xs

-- |s alpha f: the cumulative infimum of twice the projection of path f on root alpha
s :: [Q] -> [[Q]] -> [[Q]]
s alpha f = f <<->> fmap (*> alpha) (cumMin $ dynkinIndex alpha <$> f) 

cumMin :: [Q] -> [Q]
cumMin = scanl1 min

cumSum :: [Q] -> [Q]
cumSum = scanl1 (+)


-- |transform a word to a path
word2Path :: Word Int -> [[Q]]
word2Path (W []) = []
word2Path (W xs) = L.transpose $ cumSum <$> [indicator (==k) xs | k <- [1..maximum xs]]


-- |indicator function
indicator :: (a -> Bool) -> [a] -> [Q]
indicator f xs = (\x -> if f x then 1 else 0) <$> xs


-- |Pitman's transform of type A
pitmanA :: [[Q]] -> [[Q]]
pitmanA [] = []
pitmanA xs = 
    let n = length $ head xs in
        if n == 1 then xs else pitman A (n - 1) xs

pitmanAShape :: [[Q]] -> [Q]
pitmanAShape = last . pitmanA


-- |RS via Pitman's transform of type A
pitmanAGTP :: [[Q]] -> GTP Q
pitmanAGTP = GTP . (pitmanAGTP' []) where 
    pitmanAGTP' :: [[Q]] -> [[Q]] -> [[Q]]
    pitmanAGTP' xs [] = xs
    pitmanAGTP' xs ys = pitmanAGTP' ((pitmanAShape ys):xs) (L.transpose $ init $ L.transpose ys)


-- |QuickCheck property that the Pitman's transform of type A coincides with RS algorithm
prop_Pitman_RobinsonSchensted :: [Int] -> Bool
prop_Pitman_RobinsonSchensted xs = 
    let w = prop_Pitman_RobinsonSchensted_sanitise xs in
        (pitmanAGTP $ word2Path w) == (gTPFromInt $ sSYT2GTP $ robinsonSchensted' w)

gTPFromInt :: GTP Int -> GTP Q
gTPFromInt (GTP xs) = GTP $ fmap (fmap fromIntegral) xs

prop_Pitman_RobinsonSchensted_sanitise :: [Int] -> Word Int
prop_Pitman_RobinsonSchensted_sanitise = W . (fmap (\t -> abs t + 1))


-- |QuickCheck generator that generates rational numbers with small numerators and denominators
smallRational :: Gen Q
smallRational = do
    x <- smallInt
    y <- smallInt
    return $ (toInteger x) % (toInteger (abs y + 1)) 
    --return $ (toInteger x) / (toInteger (abs y + 1)) -- this line does not work for Q = Math.Algebra.Field.Base.Q - Couldn't match type ‘Integer’ with ‘Q’


smallInt :: Gen Int
smallInt = getSmall <$> (arbitrary :: Gen (Small Int))

arbRational :: Gen Q
arbRational = arbitrary

randomQMatrix :: Int -> Gen [[Q]]
randomQMatrix n = vectorOf 20 $ vectorOf n smallRational

-- |QuickCheck property that the output of the Pitman's transform is in the Weyl Chamber, for any type.
prop_Pitman_WeylChamber :: Int -> Property
prop_Pitman_WeylChamber m = let (t, n) = int2TypeInt m in
    forAll (randomQMatrix $ dimensionOfHostSpace t n) (\xs -> isInWeylChamber (simpleSystem t n) (last $ pitman t n xs))