--{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
    where
import Control.Lens
import Control.Monad
import Control.Monad.Trans.State

import qualified Control.Foldl as F

import Data.Bifunctor

import Picture
import Geometry

import Picture.Preload
--import Control.Lens

import Foreign

import Codec.Picture

import Graphics.Rendering.OpenGL hiding (Line,get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import qualified Graphics.Rendering.OpenGL as GL

import Data.Foldable
import Data.List
import qualified Data.Vector.Storable as V
import qualified Data.IntMap as IM

import Control.DeepSeq

polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
polyToTris _ = []

tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
{-# INLINE tripFirst #-}
tripFirst f (x,y,z) = (f x,y,z)

tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
{-# INLINE tripSecond #-}
tripSecond f (x,y,z) = (x,f y,z)

scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
{-# INLINE scaleT #-}
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))

overPos :: (Point3 -> Point3) -> RenderType -> RenderType
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
overPos _ RenderBlank = RenderBlank

overCol :: (Point4 -> Point4) -> RenderType -> RenderType
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
overCol _ RenderBlank = RenderBlank

scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
{-# INLINE scaleRen #-}
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
scaleRen x y rt = overPos (scale3 x y) rt
{-# INLINE translateRen #-}
translateRen x y = overPos $ translate3 x y
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
{-# INLINE rotateRen #-}
rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
    --where f b = normalizeAngle $ a + b
    where f b = a + b
rotateRen a pic = overPos (rotate3 a) pic
{-# INLINE setDepthRen #-}
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
{-# INLINE colorRen #-}
colorRen :: RGBA -> RenderType -> RenderType
colorRen c = overCol $ const c

stringToList :: String -> [(Point3,Point4,Point2)]
{-# INLINE stringToList #-}
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
                         [0,0.9*dimText..]
                         $ map charToTuple s
    where dimText = 100

charToTuple :: Char -> (Point3,Point4,Point2)
{-# INLINE charToTuple #-}
charToTuple c = ((0,0,0),white,(offset,100))
    where offset = fromIntegral (fromEnum c) - 32

--picToFTree :: Picture -> IM.IntMap (FTree RenderType)
--{-# INLINE picToFTree #-}
--picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
--picToFTree (PolygonCol i vs) 
--    = let (ps,cs) = unzip vs
--      in  IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--picToFTree (Circle i r)   = IM.singleton i $ FLeaf $ RenderCirc $ ((0,0,0),black,r)
--picToFTree (ThickArc i startA endA rad wdth) 
--    = IM.singleton i $ FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
--picToFTree Blank    = IM.singleton 0 $ FLeaf $ RenderBlank
--picToFTree (Line i ps) = IM.singleton 0 $ FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
--picToFTree (Text i s) = IM.singleton i $ FLeaf $ RenderText $ stringToList s
--picToFTree (Scale x y pic) = fmap (FBranch (scaleRen x y)) $ picToFTree pic
--picToFTree (Translate x y pic) = fmap (FBranch (translateRen x y)) $ picToFTree pic
--picToFTree (Rotate a pic) = fmap (FBranch (rotateRen a)) $ picToFTree pic
--picToFTree (SetDepth a pic) = fmap (FBranch (setDepthRen a)) $ picToFTree pic
--picToFTree (Color c pic) = fmap (FBranch (colorRen c)) $ picToFTree pic
--picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics

picToFTree :: Int -> Picture -> FTree RenderType
{-# INLINE picToFTree #-}
picToFTree x (Polygon i ps) 
    | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
    | otherwise = FLeaf RenderBlank
picToFTree x (PolygonCol i vs) 
    | i /= x = FLeaf RenderBlank
    | otherwise = 
        let (ps,cs) = unzip vs
        in  FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToFTree x (Circle i r) 
    | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
    | otherwise = FLeaf RenderBlank
picToFTree x (ThickArc i startA endA rad wdth) 
    | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
    | otherwise = FLeaf RenderBlank
picToFTree x (Line i ps) 
    | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
    | otherwise = FLeaf RenderBlank
picToFTree x (Text i s) 
    | i == x = FLeaf $ RenderText $ stringToList s
    | otherwise = FLeaf RenderBlank
picToFTree j Blank = FLeaf RenderBlank
picToFTree j (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree j pic
picToFTree j (Translate x y pic) = FBranch (translateRen x y) $ picToFTree j pic
picToFTree j (Rotate a pic) = FBranch (rotateRen a) $ picToFTree j pic
picToFTree j (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree j pic
picToFTree j (Color c pic) = FBranch (colorRen c) $ picToFTree j pic
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics

doubleLine :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
doubleLine _ = []

theFold :: TwoPtrs
        -> ThreePtrs
        -> ThreePtrs
        -> TwoPtrs
        -> ThreePtrs
        -> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
theFold pas pbs pcs pds pes 
   -- = (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
    = (,,,,) <$> pokeTwoPtrsWith pokePoly pas 
             <*> pokeThreePtrsWith pokeText pbs 
             <*> pokeThreePtrsWith pokeCirc pcs
             <*> pokeTwoPtrsWith pokeLine pds
             <*> pokeThreePtrsWith pokeArc pes

type ThreePtrs = (Ptr Float,Ptr Float,Ptr Float)
type TwoPtrs = (Ptr Float,Ptr Float)

pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
    -> ThreePtrs -> F.FoldM IO RenderType Int
pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
    -> TwoPtrs -> F.FoldM IO RenderType Int
pokeTwoPtrsWith  pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return

pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        pokeFourOff  pc n s
        return $ n + 1
pokeArc _ n _ = return n

pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
pokeTwoOff ptr n (x,y) = do
    pokeElemOff ptr (2*n+0) x
    pokeElemOff ptr (2*n+1) y
pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
pokeThreeOff ptr n (x,y,z) = do
    pokeElemOff ptr (3*n+0) x
    pokeElemOff ptr (3*n+1) y
    pokeElemOff ptr (3*n+2) z
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
pokeFourOff ptr n (x,y,z,w) = do
    pokeElemOff ptr (4*n+0) x
    pokeElemOff ptr (4*n+1) y
    pokeElemOff ptr (4*n+2) z
    pokeElemOff ptr (4*n+3) w


pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
pokeLine _       n _               = return n

pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
pokeLineVert pa pb n (p,c)
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        return (n+1)

pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) 
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        pokeElemOff  pc n s
        return (n+1)
pokeCirc _          n _               = return n

pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
pokeText (pa,pb,pc) n  (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
pokeText _          n _               = return n

pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
pokeTextVert pa pb pc n (p,c,t)
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        pokeTwoOff   pc n t
        return (n+1)

pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
pokePoly _       n _               = return n

pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
pokeVert pa pb n (p,c)
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        return (n+1)

translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
    where (x',y') = rotateV a (x,y)

fSize = sizeOf (0 :: Float)

bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
bindArrayBuffers numVs ps = do
    forM_ ps $ \(bo,ptr,i) -> do
        bindBuffer ArrayBuffer $= Just bo
        bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
        
twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
    (a:b:_) -> (a,b)
threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
    (a:b:c:_) -> (a,b,c)


renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                    [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO ()
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
    depthFunc $= Just Lequal

-- draw lightmap
    bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
    let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
        wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
        foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
                pokeFourOff wallPtr  n (x,y,z,w)
                pokeFourOff wallPtr2 n (a,b,c,d)
                return $ n+1
    nWalls <- foldM foldWalls 0 wallPoints 

    forM_ lightPoints $ \(x,y,r,lum) -> do
        cullFace $= Just Front
        clear [DepthBuffer]
        currentProgram $= Just (_wallShadowShader pdata)
        bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
        bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
        uniform (_wssLightPos pdata)  $= Vector2 (x) (y)
        blendFunc $= (Zero,One)
        drawArrays Points (fromIntegral 0) (fromIntegral $ length wallPoints)
        cullFace $= Nothing
        currentProgram $= Just (_fadeCircleShader pdata)
        bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata)
        let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata
        pokeFourOff fadeCircPtr 0 (x,y,r,lum)
        bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata
        uniform (_fcsWinUni pdata) $= Vector2 winx winy
        uniform (_fcsZoomUni pdata)  $= zoom
    -- to refactor: put these uniforms in a ubo
        blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
        drawArrays Points (fromIntegral 0) (fromIntegral 1)

-- draw picture
-- set drawing for on top
        blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
        clear [DepthBuffer]

-- draw layer 0
    renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)

    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic

-- reset blend so that light map doesn't apply
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)

    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
--
---- poke necessary data
--    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
----        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
--        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
--                            (threePtrsVAO $ _textVAO pdata)
--                            (threePtrsVAO $ _circVAO pdata)
--                            (twoPtrsVAO $ _lineVAO pdata)
--                            (threePtrsVAO $ _arcVAO pdata)
--                   ) $ (picToFTree 0 pic)
--
--    depthFunc $= Just Less
--
--    currentProgram $= Just (_backShader pdata)
--    bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
--    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
--        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
--    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
--    pokeTwoOff backPtr2 0  (winx,winy)
--    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
--    textureBinding Texture2D $= Just (_textures pdata !! 1)
--    drawArrays Points (fromIntegral 0) (fromIntegral 1)
--
---- draw triangles
--    currentProgram $= Just (_basicShader pdata)
--    bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
--    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
--    drawArrays Triangles 0 (fromIntegral $ nTriVs)
---- draw circles
--    currentProgram $= Just (_circShader pdata)
--    uniform (_uniWinSize pdata) $= Vector2 winx winy
--    uniform (_csZoomUni pdata)  $= zoom
--    bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
--    bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
--    drawArrays Points 0 (fromIntegral $ numCircVs)
---- draw arcs
--    currentProgram $= Just (_arcShader pdata)
--    uniform (_asWinUni pdata) $= Vector2 winx winy
--    uniform (_asZoomUni pdata)  $= zoom
--    bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
--    bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
--    drawArrays Points 0 (fromIntegral $ nArcVs)
--
---- reset blend so that light map doesn't apply
--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
--
---- draw lines
--    currentProgram $= Just (_basicShader pdata)
--    bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
--    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
--    drawArrays Lines 0 (fromIntegral $ nLineVs)
---- draw text
--    currentProgram $= Just (_textShader pdata)
--    bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
--    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
--    textureBinding Texture2D $= Just (_textures pdata !! 0)
--    drawArrays Points 0 (fromIntegral $ nTextVs)
    

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral


-- the following code draws a picture tree
-- it does not set nor change the blend function or depth buffer
renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
                    -> FTree RenderType -> IO ()
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do

-- poke necessary data
    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
--        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
                            (threePtrsVAO $ _textVAO pdata)
                            (threePtrsVAO $ _circVAO pdata)
                            (twoPtrsVAO $ _lineVAO pdata)
                            (threePtrsVAO $ _arcVAO pdata)
                   ) $ tree

    depthFunc $= Just Less

    currentProgram $= Just (_backShader pdata)
    bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
    pokeTwoOff backPtr2 0  (winx,winy)
    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
    textureBinding Texture2D $= Just (_textures pdata !! 1)
    drawArrays Points (fromIntegral 0) (fromIntegral 1)

-- draw triangles
    currentProgram $= Just (_basicShader pdata)
    bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
    drawArrays Triangles 0 (fromIntegral $ nTriVs)
-- draw circles
    currentProgram $= Just (_circShader pdata)
    uniform (_uniWinSize pdata) $= Vector2 winx winy
    uniform (_csZoomUni pdata)  $= zoom
    bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
    bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
    drawArrays Points 0 (fromIntegral $ numCircVs)
-- draw arcs
    currentProgram $= Just (_arcShader pdata)
    uniform (_asWinUni pdata) $= Vector2 winx winy
    uniform (_asZoomUni pdata)  $= zoom
    bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
    bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
    drawArrays Points 0 (fromIntegral $ nArcVs)

-- reset blend so that light map doesn't apply
--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)

-- draw lines
    currentProgram $= Just (_basicShader pdata)
    bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
    bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
    drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
    currentProgram $= Just (_textShader pdata)
    bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
    textureBinding Texture2D $= Just (_textures pdata !! 0)
    drawArrays Points 0 (fromIntegral $ nTextVs)