Reduce rendertype down to vertex information

app/Main.hs

@@ -54,12 +54,12 @@ doSideEffects preData w = do
     
     endTicks <- SDL.ticks
     let lastFrameTicks = _frameTimer preData
-    when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
+-- FIXME    when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
-                (_renderData preData)
+-- FIXME                (_renderData preData)
-                (map snd $ setDepth (-1)
+-- FIXME                (map snd $ setDepth (-1)
-                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
+-- FIXME                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
-                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
+-- FIXME                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
-                )
+-- FIXME                )
     foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
                     & frameTimer .~ endTicks)) (_doneSideEffects w)
 

src/Data/Preload/Render.hs

@@ -21,7 +21,7 @@ data RenderData = RenderData
     , _colorBlurShader          :: FullShader
     , _barrelShader             :: FullShader
     , _grayscaleShader          :: FullShader
-    , _pictureShaders           :: [FullShader]
+    , _pictureShaders           :: [VShader]
     , _fbo2                     :: (FramebufferObject, TextureObject)
     , _fbo3                     :: (FramebufferObject, TextureObject)
     , _fboFourth1 :: (FramebufferObject, TextureObject)

src/Dodge/Render.hs

@@ -79,7 +79,7 @@ doDrawing pdata w = do
         else renderBlankWalls pdata nWalls
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
-    _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
+-- FIXME    _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
 
     --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
     vnums <- pokeBindFoldableLayer pdata $ pic
@@ -175,7 +175,7 @@ doDrawing pdata w = do
     depthMask $= Disabled
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    _ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
+-- FIXME    _ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
     depthMask $= Enabled
 
     eTicks <- SDL.ticks

src/Dodge/Render/Picture.hs

@@ -18,20 +18,19 @@ import Polyhedra.Data
 import Control.Lens
 import Data.Maybe
 import Data.List (partition)
-import qualified Data.IntMap.Strict as IM
+import qualified Data.IntMap.Lazy as IM
 
 worldPictures :: World -> Picture
-worldPictures w = pictures $ concat 
+worldPictures w = 
-    [ IM.elems $ _decorations w 
+    concat (IM.elems $ _decorations w) ++ testPic w ++ concat
-    , map (dbArg _pjDraw)  . IM.elems $ _projectiles w
+    [ concatMap (dbArg _pjDraw)  . IM.elems $ _projectiles w
-    , map drawItem . IM.elems $ _floorItems w
+    , concatMap drawItem . IM.elems $ _floorItems w
-    , map (crDraw w) . IM.elems $ _creatures w
+    , concatMap (crDraw w) . IM.elems $ _creatures w
-    , map clDraw   . reverse $ _clouds w
+    , concatMap clDraw   . reverse $ _clouds w
-    , map ppDraw   . IM.elems $ _pressPlates w
+    , concatMap ppDraw   . IM.elems $ _pressPlates w
-    , map btDraw (IM.elems (_buttons w))
+    , concatMap btDraw (IM.elems (_buttons w))
-    , map (dbArg _ptDraw) $ _particles w
+    , concatMap (dbArg _ptDraw) $ _particles w
-    , map drawWallFloor (wallFloorsToDraw w)
+    , concatMap drawWallFloor (wallFloorsToDraw w)
-    , testPic w
     ]
 foregroundPics :: World -> [Polyhedra]
 foregroundPics = _foregroundDecorations
@@ -53,8 +52,8 @@ customMouseCursor w =
     . color white
     $ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
 
-testPic :: World -> [Picture]
+testPic :: World -> Picture
-testPic _ = [blank]
+testPic _ = blank
 --    [ setDepth (-1) . translate 0 0.8
 --        . scale 0.001 0.001 . text . show $ _crMvDir $ you w
 --    ]

src/Picture.hs

@@ -59,7 +59,7 @@ import Data.List
 import Data.Bifunctor
 --import qualified Data.DList as DL
 --import Graphics.Rendering.OpenGL (lineWidth, ($=))
---import Control.Lens
+import Control.Lens
 
 black :: RGBA
 black = (0,0,0,1)
@@ -69,17 +69,21 @@ zl rt = [(0,rt)]
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+polygon ps = map (f . zeroZ) $ polyToTris ps
+  where
+    f pos = Verx pos black PolyV 0
 
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
-polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+polygonZ ps z = map (f . zeroZ) $ polyToTris ps
+  where
+    f pos = Verx pos black (PolyzV z) 0
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol vs    = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+polygonCol vs = map f $ polyToTris vs
   where
-    (ps,cs) = unzip vs
+    f ((x,y),col) = Verx (x,y,0) col PolyV 0
 
 poly3 :: [Point3] -> Picture
 {-# INLINE poly3 #-}
@@ -87,7 +91,9 @@ poly3 = poly3Col . map (, black)
 
 poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
-poly3Col vs = zl $ RenderPoly $ polyToTris vs
+poly3Col vs = map f $ polyToTris vs
+  where
+    f (pos,col) = Verx pos col PolyV 0
 
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
@@ -124,12 +130,10 @@ bezierQuad cola colc ra rc a b c
     fa' = extrapolate aIn cIn bIn
     fc' = extrapolate cIn aIn bIn
 
-bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> [(Int, RenderType)]
+bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture
-bzhelp vs = zl $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+bzhelp = map f
   where
-    (ps,cols,offps,rads) = unzip4 vs
+    f ((x,y),col,(a,b),(c,d)) = Verx (x,y,0) col (BezV (a,b,c,d)) 0
-    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
-
 
 -- given a one and two zeros of a linear function over x and y,
 -- determine the function
@@ -148,8 +152,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
---color c = map $ second $ overCol (const c)
+color c = map $ overCol (const c)
-color c = map $ overCol' (const c)
 
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
@@ -158,21 +161,23 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
 translate :: Float -> Float -> Picture -> Picture
 --{-# INLINE translate #-}
 --translate x y = map $ second $ overPos (translate3 x y)
-translate x y = map $ overPos' (translate3 x y)
+translate x y = map $ overPos (translate3 x y)
 
 setDepth :: Float -> Picture -> Picture
 --{-# INLINE setDepth #-}
 --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
-setDepth d = map $ overPos' (\(x,y,_) -> (x,y,d))
+setDepth d = map $ overPos (\(x,y,_) -> (x,y,d))
 
 addDepth :: Float -> Picture -> Picture
 --{-# INLINE addDepth #-}
 --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
-addDepth d = map $ overPos' (\(x,y,z) -> (x,y,z+d))
+addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d))
 
 setLayer :: Int -> Picture -> Picture
 {-# INLINE setLayer #-}
-setLayer = map . first . const
+setLayer i = map $ f
+  where
+    f v = v {_vxLayer = i}
 
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
@@ -181,12 +186,11 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 scale :: Float -> Float -> Picture -> Picture
 --{-# INLINE scale #-}
 --scale x y = map . second . overPos $ scale3 x y
-scale x y = map $ overPos' $ scale3 x y
+scale x y = map $ overPos $ scale3 x y
 
 rotate :: Float -> Picture -> Picture
 --{-# INLINE rotate #-}
---rotate a = map . second . overPos $ rotate3 a
+rotate a = map $ overPos $ rotate3 a
-rotate a = map $ overPos' $ rotate3 a
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
@@ -205,11 +209,13 @@ circleSolid = circleSolidCol white white
 
 circleSolidCol :: Color -> Color -> Float -> Picture
 {-# INLINE circleSolidCol #-}
-circleSolidCol colC colE r = zl $ RenderEllipse 
+circleSolidCol colC colE r = map f
     [( (-r, r,0), colC)
     ,( (-r,-r,0), colE)
     ,( ( r,-r,0), black)
     ]
+  where
+    f (pos,col) = Verx pos col EllV 0
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
@@ -217,7 +223,9 @@ circle rad = thickArc 0 (2*pi) rad 1
 
 text :: String -> Picture
 {-# INLINE text #-}
-text s = zl $ RenderText $ stringToList s
+text s = map f $ stringToList s
+  where
+    f (pos,col,val) = Verx pos col (TextV val) 0
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
@@ -286,8 +294,8 @@ thickArc startA endA rad wdth
     r = rad + 0.5 * wdth
     w = 1 - wdth / r
 
-thickArcHelp :: Float -> Float -> Float -> Float -> [(Int, RenderType)]
+thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
-thickArcHelp startA endA rad wdth = zl $ RenderArc 
+thickArcHelp startA endA rad wdth = map f 
     [(  (0,0,0),black,(0,0,wdth))
     ,((xa,ya,0),black,(1,0,wdth))
     ,((xb,yb,0),black,(1,1,wdth))
@@ -299,6 +307,7 @@ thickArcHelp startA endA rad wdth = zl $ RenderArc
     (xa,ya) = rotateV startA (rad,0)
     (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
     (xc,yc) = rotateV endA (rad,0)
+    f (pos,col,val) = Verx pos col (ArcV val) 0
 
 withAlpha :: Float -> RGBA -> RGBA
 {-# INLINE withAlpha #-}
@@ -342,45 +351,12 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
 greyN :: Float -> Color
 greyN x = (x,x,x,1)
 
-overPos' :: (Point3 -> Point3) -> (Int,RenderType) -> (Int,RenderType)
+overPos :: (Point3 -> Point3) -> Verx -> Verx
---{-# INLINE overPos' #-}
-overPos' f (i,RenderPoly vs)    = (i, RenderPoly $ map (first f) vs )
-overPos' f (i,RenderText vs)    = (i, RenderText $ map (\(a,b,c) -> (f a,b,c)) vs )
-overPos' f (i,RenderBezQ vs)    = (i, RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs )
-overPos' f (i,RenderEllipse vs) = (i, RenderEllipse $ map (first f) vs )
-overPos' f (i,RenderArc vs)     = (i, RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs )
-overPos' f (i,RenderPolyZ vs)   = (i, RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs )
-overPos' _ rt = rt
-
-overPos :: (Point3 -> Point3) -> RenderType -> RenderType
 {-# INLINE overPos #-}
-overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
+overPos = over vxPos
-overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
-overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
-overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
-overPos f (RenderArc vs)  = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
-overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
-overPos _ rt = rt
 
-overCol' :: (Point4 -> Point4) -> (Int,RenderType) -> (Int,RenderType)
+overCol :: (Point4 -> Point4) -> Verx -> Verx
---{-# INLINE overCol #-}
+overCol = over vxCol
-overCol' f (i,(RenderPoly vs)   )  = (i,RenderPoly    $ map (second f) vs )
-overCol' f (i,(RenderEllipse vs))  = (i,RenderEllipse $ map (second f) vs )
-overCol' f (i,(RenderText vs)   )  = (i,RenderText    $ map (\(a,b,c) -> (a,f b,c)) vs )
-overCol' f (i,(RenderBezQ vs)   )  = (i,RenderBezQ    $ map (\(a,b,c) -> (a,f b,c)) vs )
-overCol' f (i,(RenderArc vs)    )  = (i,RenderArc     $ map (\(a,b,c) -> (a,f b,c)) vs )
-overCol' f (i,(RenderPolyZ vs)  )  = (i,RenderPolyZ   $ map (\(a,b,c) -> (a,f b,c)) vs )
-overCol' _ _ = undefined
-
-overCol :: (Point4 -> Point4) -> RenderType -> RenderType
---{-# INLINE overCol #-}
-overCol f (RenderPoly vs)     = RenderPoly    $ 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 (RenderBezQ vs)     = RenderBezQ    $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderArc vs)      = RenderArc     $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderPolyZ vs)    = RenderPolyZ   $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol _ _ = undefined
 
 -- no premature optimisation, consider changing to use texture arrays
 stringToList :: String -> [(Point3,Point4,Point2)]

src/Picture/Data.hs

@@ -1,4 +1,4 @@
---{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 --{-# LANGUAGE Strict #-}
 {-# LANGUAGE DeriveGeneric #-}
 module Picture.Data
@@ -15,17 +15,31 @@ import Data.Foldable
 --import qualified Data.Sequence as Se
 --import qualified Data.DList as DL
 --import qualified Data.Vector as V
---import Control.Lens
+import Control.Lens
 --import Control.Monad 
 
+data Verx = Verx
+    { _vxPos    :: Point3
+    , _vxCol    :: Point4
+    , _vxType   :: VertexType
+    , _vxLayer  :: Int
+    }
+data VertexType
+    = PolyV
+    | PolyzV Float
+    | BezV Point4
+    | TextV Point2
+    | ArcV Point3
+    | EllV
+
 data RenderType
-    = RenderPoly  [(Point3,Point4)]
+    -- -= RenderPoly  [(Point3,Point4)]
-    | RenderPolyZ [(Point3,Point4,Float)]
+    -- -| RenderPolyZ [(Point3,Point4,Float)]
-    | RenderBezQ  [(Point3,Point4,Point4)]
+    -- -| RenderBezQ  [(Point3,Point4,Point4)]
-    | RenderText  [(Point3,Point4,Point2)]
+    -- -| RenderText  [(Point3,Point4,Point2)]
-    | RenderArc   [(Point3,Point4,Point3)]
+    -- -| RenderArc   [(Point3,Point4,Point3)]
-    | RenderEllipse [(Point3,Point4)]
+    -- -| RenderEllipse [(Point3,Point4)]
-    | Render3 [Point3]
+    = Render3 [Point3]
     | Render1111 {_unRender1111 :: (Float,Float,Float,Float)}
     | Render22 {_unRender22 :: (Point2,Point2)}
     | Render2221 {_unRender2221 :: (Point2,Point2,Point2,Float)}
@@ -99,20 +113,10 @@ flat4 (x,y,z,w) = [x,y,z,w]
 {-# INLINE flat3 #-}
 {-# INLINE flat4 #-}
 
-type Picture = [(Int,RenderType)]
+type Picture = [Verx]
---    = Blank
---    | Text String
---    | Polygon [Point2]
---    | PolygonZ [Point2] Float
---    | BezierQuad [(Point2,RGBA,Point2,Point2)]
---    | PolygonCol [(Point2,RGBA)]
---    | Poly3D [(Point3,RGBA)]
---    | Circle RGBA RGBA Float
---    | ThickArc Float Float Float Float
---    | Pictures [Picture]
---    | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
---    | OnLayer Int Picture
 
 blank :: Picture
 {-# INLINE blank #-}
 blank = []
+
+makeLenses ''Verx

src/Polyhedra.hs

@@ -85,11 +85,10 @@ boxABC a b c =
 polyToPics :: Polyhedra -> [Picture]
 polyToPics = map helpPoly3D . _pyFaces
 
-helpPoly3D :: [(Point3, Point4)] -> [(Int, RenderType)]
+helpPoly3D :: [(Point3, Point4)] -> [Verx]
-helpPoly3D vs = zl $ RenderPoly $ polyToTris vs
+helpPoly3D vs = map f $ polyToTris vs
   where
-    zl :: RenderType -> [(Int,RenderType)]
+    f (pos,col) = Verx pos col PolyV 0
-    zl rt = [(0,rt)]
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics

src/Preload/Render.hs

@@ -63,14 +63,14 @@ preloadRender = do
         <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency poke3
                 >>= addUniforms ["lightPos"]
 -- 2D draw shaders
-    bslist <- makeShader "twoD/basic"   [vert,frag] [3,4]   ETriangles pokeTriStrat
+    bslist <- makeVShader "twoD/basic"   [vert,frag] [3,4]   ETriangles isPolyV
-    aslist <- makeShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles    pokeArcStrat
+    aslist <- makeVShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles isArcV
-    eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles pokeEllStrat
+    eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles isEllV
-    bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip pokeBezQStrat
+    bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip isBezV
-    cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles pokeCharStrat
+    cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles isTextV
-                  >>= addTextureNoFilter "data/texture/charMap.png"
+                  >>= vaddTextureNoFilter "data/texture/charMap.png"
                     -- this should really be a 2d texture array
-    basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ
+    basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles isPolyzV
 -- fullscreen shaders
     fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip $
         const cornerListNoCoord
@@ -208,36 +208,11 @@ minMagFilter = ((Nearest,Nothing),Nearest)
 
 cleanUpRenderPreload :: RenderData -> IO ()
 cleanUpRenderPreload pd = do
-    mapM_ freeShaderPointers $ _pictureShaders pd
+    -- TODO fix this
+    --mapM_ freeShaderPointers $ _pictureShaders pd
     freeShaderPointers $ _lightingOccludeShader pd
     freeShaderPointers $ _fullscreenShader pd
 
---{-# INLINE pokeBezQStrat #-}
-pokeBezQStrat :: RenderType -> [[Float]]
-pokeBezQStrat (RenderBezQ vs) = fmap 
-    (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r,g,b,a,s,t,u,v]) 
-    vs
-pokeBezQStrat _ = []
-
-
-pokeTriTweakZ :: RenderType -> [[Float]]
-pokeTriTweakZ (RenderPolyZ vs) = fmap (\(p,co,z) -> flat3 p ++ [z] ++ flat4 co) vs
-pokeTriTweakZ _ = []
-
---{-# INLINE pokeTriStrat #-}
-pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeEllStrat :: RenderType -> [[Float]]
-pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs
-pokeTriStrat _ = []
-
-pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> concat [flat3 a, flat4 b, flat2 c]) vs
-pokeCharStrat _ = []
-
-pokeArcStrat (RenderArc vs) = fmap (\(a,b,c) -> concat [flat3 a, flat4 b, flat3 c]) vs
-pokeArcStrat _ = []
-
-pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [x,y,z,r,g,b,a]) vs
-pokeEllStrat _ = []
-
 vert, geom, frag :: ShaderType
 vert = VertexShader
 geom = GeometryShader
@@ -262,3 +237,16 @@ pokeWPColStrat _ = undefined
 poke33 :: RenderType -> [[Float]]
 poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]]
 poke33 _ = undefined
+
+isPolyV PolyV = True
+isPolyV _ = False
+isArcV (ArcV _) = True
+isArcV _ = False
+isEllV EllV = True
+isEllV _ = False
+isTextV (TextV _) = True
+isTextV _ = False
+isBezV (BezV _) = True
+isBezV _ = False
+isPolyzV (PolyzV _) = True
+isPolyzV _ = False

src/Render.hs

@@ -155,8 +155,8 @@ renderShader shad dat = do
 pokeBindFoldableLayer
     :: Foldable f
     => RenderData
-    -> f (Int,RenderType)
+    -> f Verx
-    -> IO (IM.IntMap [(FullShader,Int)])
+    -> IO (IM.IntMap [(VShader,Int)])
 pokeBindFoldableLayer pdata m = do
     let slist = (,) <$> [0..6] <*> _pictureShaders pdata
 
@@ -164,28 +164,28 @@ pokeBindFoldableLayer pdata m = do
     bindShaderLayer slist is
     return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is
 
-renderFoldable
+--renderFoldable
-    :: Foldable f
+--    :: Foldable f
-    => RenderData
+--    => RenderData
-    -> f RenderType
+--    -> f RenderType
-    -> IO Word32
+--    -> IO Word32
-renderFoldable pdata struct = do
+--renderFoldable pdata struct = do
-    pokeStartTicks <- SDL.ticks
+--    pokeStartTicks <- SDL.ticks
-
+--
-    let slist = _pictureShaders pdata
+--    let slist = _pictureShaders pdata
-
+--
--- poke data, returns list buffer sizes for each shader
+---- poke data, returns list buffer sizes for each shader
-    is <- F.foldM (traverse pokeShader slist) struct
+--    is <- F.foldM (traverse pokeShader slist) struct
-
+--
--- the idea of binding many buffers at once, rather than interweaving with draw
+---- the idea of binding many buffers at once, rather than interweaving with draw
--- calls, is to prevent opengl from waiting for a draw call to finish
+---- calls, is to prevent opengl from waiting for a draw call to finish
--- before it performs another state change
+---- before it performs another state change
-    bindShaderBuffers slist is
+--    bindShaderBuffers slist is
-
+--
-    zipWithM_ drawShader slist is
+--    zipWithM_ drawShader slist is
-    
+--    
-    pokeEndTicks <- SDL.ticks
+--    pokeEndTicks <- SDL.ticks
-    return $ pokeEndTicks - pokeStartTicks
+--    return $ pokeEndTicks - pokeStartTicks
 ------------------------------end renderFoldable
 
 pokeTwoOff 

src/Shader.hs

@@ -42,26 +42,26 @@ bindArrayBuffersLayer numVs lay theVBO = do
   where
     stride = sum $ _vboAttribSizes theVBO
 
-bindShaderLayer :: [(Int,FullShader)] -> [Int] -> IO ()
+bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO ()
 bindShaderLayer = zipWithM_ f
   where 
-    f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _shaderVAO fs
+    f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs
 
 bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
 bindShaderBuffers = zipWithM_ f
   where 
     f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
 
-drawShaderLay :: Int -> FullShader -> Int -> IO ()
+drawShaderLay :: Int -> VShader -> Int -> IO ()
 {-# INLINE drawShaderLay #-}
 drawShaderLay l fs i = do 
-    currentProgram $= Just (_shaderProgram fs)
+    currentProgram $= Just (_vshaderProgram fs)
-    bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
+    bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs)
-    case _shaderTexture fs of 
+    case _vshaderTexture fs of 
         Just ShaderTexture{_textureObject = txo}
             -> textureBinding Texture2D $= Just txo
         _   -> return ()
-    glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
+    glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
 
 drawShader :: FullShader -> Int -> IO ()
 {-# INLINE drawShader #-}

src/Shader/AuxAddition.hs

@@ -1,6 +1,7 @@
 module Shader.AuxAddition
     ( addTexture
     , addTextureNoFilter
+    , vaddTextureNoFilter
     , addTextureArray
     , addUniforms
     ) where
@@ -34,6 +35,21 @@ addTexture texturePath shad = do
     generateMipmap' Texture2D
     return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
 
+vaddTextureNoFilter :: String -> VShader -> IO VShader
+vaddTextureNoFilter texturePath shad = do
+    Right cmap <- readImage texturePath
+    let tex = convertRGBA8 cmap
+    textureOb <- genObjectName
+    textureBinding Texture2D $= Just textureOb
+    textureFilter Texture2D $= ((Nearest,Nothing) , Nearest)
+    let texData = V.toList $ imageData tex
+        wtex = fromIntegral $ imageWidth  tex
+        htex = fromIntegral $ imageHeight tex
+    glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
+    withArray texData $ \ptr -> do
+        glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
+    return $ shad & vshaderTexture ?~ ShaderTexture {_textureObject = textureOb}
+
 addTextureNoFilter :: String -> FullShader -> IO FullShader
 addTextureNoFilter texturePath shad = do
     Right cmap <- readImage texturePath

src/Shader/Compile.hs

@@ -1,5 +1,6 @@
 module Shader.Compile
     ( makeShader
+    , makeVShader
     , makeShaderSized
     , makeShaderUsingShaderVAO
     , makeSourcedShader
@@ -16,6 +17,29 @@ import Control.Monad
 --import Control.Lens
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 
+{- | 
+Compiles a vertex shader found within the shader directory.
+The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
+-}
+makeVShader 
+    :: String       -- ^ First part of the name of the shader
+    -> [ShaderType] -- ^ Filetype extensions
+    -> [Int]   -- ^ The input vertex sizes
+    -> EPrimitiveMode
+    -> (VertexType -> Bool)
+    -> IO VShader
+makeVShader s shaderlist sizes renStrat vtest = do
+    prog <- makeSourcedShader s shaderlist
+    vaob <- setupVAO sizes
+    return $ VShader 
+        { _vshaderProgram = prog
+        , _vshaderVAO = vaob
+        , _vshaderTexture = Nothing
+        , _vshaderCustomUnis = []
+        , _vshaderPokeTest = vtest
+        , _vshaderDrawPrimitive = renStrat
+        }
+
 -- | Takes the VAO and poke strategy from another shader
 makeShaderUsingShaderVAO
     :: String       -- ^ First part of the name of the shader

src/Shader/Data.hs

@@ -6,6 +6,7 @@ module Shader.Data
     ( VAO (..)
     , VBO (..)
     , FullShader (..)
+    , VShader (..)
     , ShaderTexture (..)
     , EPrimitiveMode (..)
 -- | Lens functions
@@ -19,6 +20,13 @@ module Shader.Data
     , shaderTexture
     , shaderCustomUnis
 
+    , vshaderProgram
+    , vshaderVAO
+    , vshaderDrawPrimitive
+    , vshaderTexture
+    , vshaderCustomUnis
+    , vshaderPokeTest
+
 --    , textureObject 
     ) where
 import Picture.Data
@@ -42,6 +50,14 @@ data VBO = VBO
     , _vboPointer :: Ptr Float
     , _vboAttribSizes :: [Int]  -- ^ It is not clear to me if this is necessary to store or not
     }
+data VShader = VShader
+    { _vshaderProgram :: Program
+    , _vshaderVAO :: VAO
+    , _vshaderDrawPrimitive :: EPrimitiveMode
+    , _vshaderTexture :: Maybe ShaderTexture
+    , _vshaderCustomUnis :: [UniformLocation]
+    , _vshaderPokeTest :: VertexType -> Bool
+    }
 
 {- | Datatype containing the necessary information for a single shader.  -}
 data FullShader = FullShader
@@ -72,3 +88,4 @@ data EPrimitiveMode
 
 makeLenses ''VAO
 makeLenses ''FullShader
+makeLenses ''VShader

src/Shader/Poke.hs

@@ -19,13 +19,6 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride)  (return 0) return
     stride = sum $ _vboAttribSizes theVBO
     fls = _shaderPokeStrategy fs
 
-pokeShaderLayer :: (Int,FullShader) -> F.FoldM IO (Int,RenderType) Int
-pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff fls ptr stride l)  (return 0) return
-  where 
-    theVBO = _vaoVBO $ _shaderVAO fs
-    ptr = _vboPointer theVBO
-    stride = sum $ _vboAttribSizes theVBO
-    fls = _shaderPokeStrategy fs
 
 
 pokeVertices 
@@ -37,17 +30,37 @@ pokeVertices
     -> IO Int
 pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
 
+pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
+pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stride l)  (return 0) return
+  where 
+    theVBO = _vaoVBO $ _vshaderVAO fs
+    ptr = _vboPointer theVBO
+    stride = sum $ _vboAttribSizes theVBO
+
 pokeVerticesOff
-    :: (RenderType -> [[Float]])
+    :: Ptr Float
-    -> Ptr Float
+    -> (VertexType -> Bool)
     -> Int  -- ^ stride
     -> Int  -- ^ offset
     -> Int  -- ^ number of vertices already poked
-    -> (Int,RenderType)
+    -> Verx
     -> IO Int
-pokeVerticesOff toFs ptr stride offset n (i,rt) 
+pokeVerticesOff ptr vtest stride offset n vx
-    | offset == i = foldM (pokeVertexOff ptr stride offset) n (toFs rt)
+    | offset == i && typetest = do
+        foldM (pokeVertexOff ptr stride offset) n (toFls vx)
     | otherwise = return n
+  where
+    i = _vxLayer vx
+    typetest = vtest (_vxType vx)
+
+toFls :: Verx -> [[Float]]
+toFls vx = [flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)]
+  where
+    f (PolyzV x) = [x]
+    f (BezV x) = flat4 x
+    f (TextV x) = flat2 x
+    f (ArcV x) = flat3 x
+    f _ = []
 
 pokeVertexOff :: Ptr Float -> Int -> Int -> Int -> [Float] -> IO Int
 pokeVertexOff ptr stride offset n fs = do