--{-# 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.DList as DL

import Control.DeepSeq

concat34 :: (Point3,RGBA) -> [Float]
concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]


toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w

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

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' :: PreloadData -> Float -> (Float,Float) -> Picture -> IO ()
renderPicture' pdata zoom (winx,winy) pic = do
    let firstIndex = 0

    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
--        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
                            (threePtrsVAO $ _textVAO' pdata)
                            (threePtrsVAO $ _circVAO' pdata)
                            (_ptrLinePos pdata, _ptrLineCol pdata)
                            (threePtrsVAO $ _arcVAO' pdata)
                   ) $ picToFTree pic

    depthFunc $= Just Less
-- draw triangles
    currentProgram $= Just (_basicShader pdata)
    bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
    drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
-- draw lines, don't need to change the program or vaos, just need to bind the
-- vbos and draw
    bindArrayBuffers nLineVs 
        [(_posVBO pdata, _ptrLinePos pdata, 3)
        ,(_colVBO pdata, _ptrLineCol pdata, 4)
        ]
    drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
-- 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 (fromIntegral firstIndex) (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 (fromIntegral firstIndex) (fromIntegral $ nArcVs)
-- draw text
    currentProgram $= Just (_textShader pdata)
    bindVertexArrayObject $= Just (_vao $ _textVAO' pdata)
    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO' pdata
    drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nTextVs)

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