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

import qualified Control.Applicative as Ap

import Linear.Matrix
import Linear.V4

import qualified Control.Foldl as F

import Data.Bifunctor

import Picture.Data
import Geometry

import Picture.Preload

import Foreign hiding (rotate)

import Codec.Picture

import Graphics.GL.Core43

import Graphics.Rendering.OpenGL hiding (Line,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 qualified Data.DList as DL

import Control.DeepSeq

import qualified SDL as SDL

white = (1,1,1,1)
black = (0,0,0,1)

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,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3)
{-# INLINE scaleT #-}
scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))

overPos :: (Point3 -> Point3) -> RenderType -> RenderType
{-# INLINE overPos #-}
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 (RenderEllipse vs) = RenderEllipse $ map (first f) vs
overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)

overRot :: Float -> RenderType -> RenderType
{-# INLINE overRot #-}
overRot ang (RenderArc (a,b,(r,s,t,v))) = RenderArc (a,b,(r+ang,s+ang,t,v))
overRot _ ren = ren

overCol :: (Point4 -> Point4) -> RenderType -> RenderType
{-# INLINE overCol #-}
overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
overCol f (RenderLine vs)      = RenderLine $ map (second $ f) vs
overCol f (RenderEllipse vs)   = RenderEllipse $ 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)

overSca :: (Point2 -> Point2) -> RenderType -> RenderType
{-# INLINE overSca #-}
overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs
overSca f p = p

scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
{-# INLINE scaleRen #-}
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) 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,Point3)]
{-# 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
dimText :: Float
dimText = 100

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

picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
{-# INLINE picToAlt #-}
picToAlt x (Polygon i ps) 
    | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
    | otherwise = Ap.empty
picToAlt x (PolygonCol i vs) 
    | i /= x = Ap.empty 
    | otherwise = 
        let (ps,cs) = unzip vs
        in  Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToAlt x (Circle i r) 
    | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
    | otherwise = Ap.empty
picToAlt x (Ellipse i (ax,ay) (bx,by) r) 
    | i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
                                       ,((ax,ay-r,0),black)
                                       ,((bx,by-r,0),black)
                                       ]
    | otherwise = Ap.empty
picToAlt x (ThickArc i startA endA rad wdth) 
    | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
    | otherwise = Ap.empty
picToAlt x (Line i ps) 
    | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
    | otherwise = Ap.empty
picToAlt x (Text i s) 
    | i == x = Ap.pure $ RenderText $ stringToList s
    | otherwise = Ap.empty
picToAlt j Blank = Ap.empty
picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics

collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
collapseBranch f (FBranch g t) = FBranch (f . g) t
collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
collapseBranch f (FLeaf x) = FLeaf (f x)

picToLTree :: Maybe Int -> Picture -> LTree RenderType
{-# INLINE picToLTree #-}
picToLTree mx (Polygon i ps)
    | Just i == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
    | Nothing == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
    | otherwise = LBranches []
picToLTree mx (PolygonCol i vs) 
    | Just i == mx || Nothing == mx = 
        let (ps,cs) = unzip vs
        in  LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
    | otherwise = LBranches []
picToLTree mx (Circle i r) 
    | Just i == mx || Nothing == mx = LLeaf $ RenderEllipse
                                                [((-r, r,0), black)
                                                ,((-r,-r,0), black)
                                                ,(( r,-r,0), black)
                                                ]
    | otherwise = LBranches []
picToLTree mx (Ellipse i (ax,ay) (bx,by) r) 
    | Just i == mx || Nothing == mx = LLeaf $ RenderEllipse [((ax,ay+r,0),black)
                                       ,((ax,ay-r,0),black)
                                       ,((bx,by-r,0),black)
                                       ]
    | otherwise = LBranches []
picToLTree mx (ThickArc i startA endA rad wdth) 
    | Just i == mx || Nothing == mx = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
    | otherwise = LBranches []
picToLTree mx (Line i ps) 
    | Just i == mx || Nothing == mx = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
    | otherwise = LBranches []
picToLTree mx (LineCol i vs) 
    | Just i == mx || Nothing == mx = 
        let (ps,cs) = unzip vs
        in  LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
    | otherwise = LBranches []
picToLTree mx (Text i s) 
    | Just i == mx || Nothing == mx = LLeaf $ RenderText $ stringToList s
    | otherwise = LBranches []
picToLTree j Blank = LBranches []
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) 
    = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . overCol f'') $ picToLTree j pic
picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                    | otherwise = LBranches []
picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic

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

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

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
{-# INLINE pokeThreePtrsWith #-}
pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
    -> TwoPtrs -> F.FoldM IO RenderType Int
{-# INLINE pokeTwoPtrsWith #-}
pokeTwoPtrsWith  pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return

pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeArc #-}
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

pokeEllipse:: TwoPtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeEllipse #-}
pokeEllipse ptrs n (RenderEllipse vs) = foldM (pokeEllipseVert ptrs) n vs
pokeEllipse _    n _ = return n

pokeEllipseVert :: TwoPtrs -> Int -> (Point3,Point4) -> IO Int
{-# INLINE pokeEllipseVert #-}
pokeEllipseVert (pa,pb) n (p,c)
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        return $ n + 1

pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
{-# INLINE pokeTwoOff #-}
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 ()
{-# INLINE pokeThreeOff #-}
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 ()
{-# INLINE pokeFourOff #-}
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
{-# INLINE pokeLine #-}
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
{-# INLINE pokeLineVert #-}
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
{-# INLINE pokeCirc #-}
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
{-# INLINE pokeText #-}
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, Point3) -> IO Int
{-# INLINE pokeTextVert #-}
pokeTextVert pa pb pc n (p,c,t)
    | n > 20000 * 2 = return n
    | otherwise = do
        pokeThreeOff pa n p
        pokeFourOff  pb n c
        pokeThreeOff pc n t
        return (n+1)

pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
{-# INLINE pokePoly #-}
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
{-# INLINE pokeVert #-}
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)
{-# INLINE twoPtrsVAO #-}
twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
    (a:b:_) -> (a,b)
threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
{-# INLINE threePtrsVAO #-}
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 (Word32,Word32)
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
    wallPokeStart <- SDL.ticks

-- setting the depth function to less, instead of lequal, 
-- seems to stop a lot of unecessary drawing
-- of wall shadows when creating the light map
    depthFunc $= Just Less

-- calculate world transformation matrix
    let scalMat = Linear.Matrix.transpose $
            V4 (V4 (2*zoom/winx) 0             0 (0::GLfloat))
                (V4 0             (2*zoom/winy) 0 0)
                (V4 0             0             1 0)
                (V4 0             0             0 1)
    let rotMat = Linear.Matrix.transpose $
            V4 (V4 (cos rot) (sin (-rot)) 0 0)
                (V4 (sin rot) (cos rot)    0 0)
                (V4 0             0        1 0)
                (V4 0             0        0 1)
    let tranMat = Linear.Matrix.transpose $
            V4 (V4 1        0        0 0)
                (V4 0        1        0 0)
                (V4 0        0        1 0)
                (V4 (-tranx) (-trany) 0 1)
    let wmat = scalMat !*! rotMat !*! tranMat
        vToL (V4 a b c d) = [a,b,c,d]
    wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)

-- set common uniforms
    forM_ [_basicShader      pdata
          ,_textShader       pdata
          ,_circShader       pdata
          ,_arcShader        pdata
          ,_ellipseShader    pdata
          ,_lightmapCircleShader pdata
          ,_backShader       pdata
          ,_wallShadowShader pdata
          ] $ \shad -> do
        currentProgram $= Just (fst shad)
        uniform (snd shad !! 0) $= Vector2 winx winy
        uniform (snd shad !! 1) $= zoom
        uniform (snd shad !! 2) $= rot
        uniform (snd shad !! 3) $= Vector2 tranx trany
        uniform (snd shad !! 4) $= wmata

-- 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)
--                pokeElemOff (_dummyPtr pdata) n (fromIntegral n)
                pokeFourOff wallPtr2 n (a,b,c,d)
                return $ n+1
    nWalls <- foldM foldWalls 0 wallPoints 
    bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata

    forM_ lightPoints $ \(x,y,r,lum) -> do
        cullFace $= Just Front
        clear [DepthBuffer]
        currentProgram $= Just (fst $ _wallShadowShader pdata)
        bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
        uniform (_wssLightPos pdata)  $= Vector2 (x) (y)
        blendFunc $= (Zero,One)
--        drawElements Points (fromIntegral nWalls) UnsignedByte (_dummyPtr pdata)
--        withArray [0..(nWalls-1)::Int] $ \ptr -> 
----            --drawElements Points (fromIntegral nWalls) UnsignedByte ptr
--            glDrawElements GL_POINTS (fromIntegral $ length wallPoints) GL_UNSIGNED_BYTE ptr
        drawArrays Points (fromIntegral 0) (fromIntegral $ nWalls)
        cullFace $= Nothing
        currentProgram $= Just (fst $ _lightmapCircleShader 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
        blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
        drawArrays Points (fromIntegral 0) (fromIntegral 1)
    startWallTicks <- SDL.ticks
    wallPokeEnd <- SDL.ticks
    ticksS <- SDL.ticks
    ticksAfterL <- SDL.ticks
-- draw picture
-- set drawing for on top
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    clear [DepthBuffer]
-- draw layer 0
    ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
                                                        --((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
-- set drawing for on top
    aticks <- SDL.ticks
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
    bticks <- SDL.ticks
-- reset uniforms (hacky for now)
    idmat <- (newMatrix RowMajor [1,0,0,0
                                 ,0,1,0,0
                                 ,0,0,1,0
                                 ,0,0,0,1
                                 ]
             ) :: IO (GLmatrix GLfloat)
    forM_ [_basicShader      pdata
          ,_textShader       pdata
          ,_circShader       pdata
          ,_arcShader        pdata
          ,_ellipseShader    pdata
          ] $ \shad -> do
        currentProgram $= Just (fst shad)
        uniform (snd shad !! 0)  $= Vector2 (2::Float) 2
        uniform (snd shad !! 1)  $= (1::Float)
        uniform (snd shad !! 2)  $= (0::Float)
        uniform (snd shad !! 3)  $= Vector2 (0::Float) 0
        uniform (snd shad !! 4)  $= idmat
    endWallTicks <- SDL.ticks
    --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
    ticksE <- SDL.ticks
    --return (ticksAfterL, ticksE - ticksS)
    --return (ticksAfterL, ticks2 + ticks3 + ticks4)
    return (ticksAfterL, wallPokeEnd - wallPokeStart)

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
-- nor does it set uniforms
renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
                    -> f RenderType -> IO Word32
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do

    pokeStartTicks <- SDL.ticks
-- poke necessary data
    (nTriVs,nTextVs,nCircVs,nLineVs,nArcVs,nEllVs) 
--        <- 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)
                            (twoPtrsVAO $ _ellipseVAO pdata)
                   ) $ tree

    pokeEndTicks <-SDL.ticks
-- bind buffers
-- the idea of doing as much of this at once, rather than interweaving with draw
-- calls, is to prevent opengl from waiting for a draw call to finish
-- before it performs another state change
    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
    bindArrayBuffers nCircVs $ _vaoBufferTargets $ _circVAO pdata
    bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
    bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
    bindArrayBuffers nEllVs $ _vaoBufferTargets $ _ellipseVAO pdata

    depthFunc $= Just Less

    currentProgram $= Just (fst $ _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)
    textureBinding Texture2D $= Just (_textures pdata !! 1)
    drawArrays Points (fromIntegral 0) (fromIntegral 1)

    depthFunc $= Just Lequal

-- draw triangles
    currentProgram $= Just (fst $ _basicShader pdata)
    bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
    drawArrays Triangles 0 (fromIntegral $ nTriVs)
-- draw circles
    currentProgram $= Just (fst $ _circShader pdata)
    bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
    drawArrays Points 0 (fromIntegral $ nCircVs)
-- draw ellipses
    currentProgram $= Just (fst $ _ellipseShader pdata)
    bindVertexArrayObject $= Just (_vao $ _ellipseVAO pdata)
    drawArrays Triangles 0 (fromIntegral $ nEllVs)
-- draw arcs
    currentProgram $= Just (fst $ _arcShader pdata)
    bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
    drawArrays Points 0 (fromIntegral $ nArcVs)
-- draw lines
    currentProgram $= Just (fst $ _basicShader pdata)
    bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
    drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
    currentProgram $= Just (fst $ _textShader pdata)
    bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
    textureBinding Texture2D $= Just (_textures pdata !! 0)
    drawArrays Points 0 (fromIntegral $ nTextVs)
    return (pokeEndTicks - pokeStartTicks)