Remove polymorphism of shader type

src/Dodge/Render.hs

@@ -16,6 +16,7 @@ import Geometry
 --import Picture
 import Picture.Render
 import Picture.Preload
+import Picture.Data
 import Shader
 import MatrixHelper
 
@@ -135,7 +136,7 @@ renderBlankWalls
     -> GLmatrix GLfloat 
     -> IO ()
 renderBlankWalls pdata wps pmat = do
-    n <- F.foldM (pokeShader $ _wallBlankShader pdata) wps
+    n <- F.foldM (pokeShader $ _wallBlankShader pdata) (map Render22x4 wps)
     bindShaderBuffers [_wallBlankShader pdata] [n]
     currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
     uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat
@@ -149,7 +150,7 @@ renderTextureWalls
     -> GLmatrix GLfloat 
     -> IO ()
 renderTextureWalls pdata wps pmat = do
-    n <- F.foldM (pokeShader $ _wallTextureShader pdata) wps
+    n <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wps)
     bindShaderBuffers [_wallTextureShader pdata] [n]
     currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
     uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat

src/Picture/Data.hs

@@ -20,6 +20,11 @@ data RenderType
     | RenderArc  (Point3,Point4,Point4)
     | RenderLine [(Point3,Point4)]
     | RenderEllipse [(Point3,Point4)]
+    | RenderConst
+    | Render1111 {_unRender1111 :: (Float,Float,Float,Float)}
+    | Render22 {_unRender22 :: (Point2,Point2)}
+    | Render22x4 {_unRender22x4 :: ((Point2,Point2),Point4)}
+    | Render3x2 {_unRender3x2 :: (Point3,Point2)}
 
 type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)

src/Picture/Preload.hs

@@ -16,17 +16,17 @@ import Foreign
 import qualified Control.Foldl as F
 
 data RenderData = RenderData
-    { _lightingFloorShader      :: FullShader (Float,Float,Float,Float)
+    { _lightingFloorShader      :: FullShader
-    , _lightingOccludeShader    :: FullShader (Point2,Point2)
+    , _lightingOccludeShader    :: FullShader
-    , _lightingWallShader       :: FullShader (Point2,Point2)
+    , _lightingWallShader       :: FullShader
-    , _wallBlankShader          :: FullShader ((Point2,Point2),Point4)
+    , _wallBlankShader          :: FullShader
-    , _wallTextureShader        :: FullShader ((Point2,Point2),Point4)
+    , _wallTextureShader        :: FullShader
-    , _backgroundShader         :: FullShader (Point2,Point2,Point2,Point2)
+    , _backgroundShader         :: FullShader
-    , _textureShader            :: FullShader (Point3,Point2)
+    --, _textureShader            :: FullShader (Point3,Point2)
-    , _fullscreenShader         :: FullShader ()
+    , _fullscreenShader         :: FullShader
-    , _boxBlurShader            :: FullShader ()
+    , _boxBlurShader            :: FullShader
-    , _grayscaleShader          :: FullShader ()
+    , _grayscaleShader          :: FullShader
-    , _pictureShaders           :: [FullShader RenderType]
+    , _pictureShaders           :: [FullShader]
     , _spareFBO                 :: FramebufferObject
     , _fboTexture               :: TextureObject
     , _fboRenderbufferObject    :: RenderbufferObject
@@ -38,8 +38,8 @@ makeLenses ''RenderData
 preloadRender :: IO RenderData
 preloadRender = do
 -- lighting shaders
-    lsShad <- makeShader "lighting/floor" [vert,geom,frag] [(0,4)] Points 
+    lightningFloorShad <- makeShader "lighting/floor" [vert,geom,frag] [(0,4)] Points 
-                    (return . return . flat4)
+                    (return . return . flat4 . _unRender1111)
     wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [(0,4)] Points pokeWPStrat
                 >>= addUniforms ["lightPos"]
     wlLightShad 
@@ -62,21 +62,21 @@ preloadRender = do
         ,[[-1,-1],[0,0]]
         ,[[ 1,-1],[1,0]]
         ]
-    _ <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
+    _ <- F.foldM (pokeShader fsShad) [RenderConst] -- fix fullscreen vertex positions now
     boxBlurShad <- makeShader "texture/boxBlur" [vert,frag] [(0,2),(1,2)] TriangleStrip $ const
         [[[-1, 1],[0,1]]
         ,[[ 1, 1],[1,1]]
         ,[[-1,-1],[0,0]]
         ,[[ 1,-1],[1,0]]
         ]
-    _ <- F.foldM (pokeShader boxBlurShad) [()] -- fix fullscreen vertex positions now
+    _ <- F.foldM (pokeShader boxBlurShad) [RenderConst] -- fix fullscreen vertex positions now
     grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [(0,2),(1,2)] TriangleStrip $ const
         [[[-1, 1],[0,1]]
         ,[[ 1, 1],[1,1]]
         ,[[-1,-1],[0,0]]
         ,[[ 1,-1],[1,0]]
         ]
-    _ <- F.foldM (pokeShader grayscaleShad) [()] -- fix fullscreen vertex positions now
+    _ <- F.foldM (pokeShader grayscaleShad) [RenderConst] -- fix fullscreen vertex positions now
 -- background shader
     bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
                 >>= addTexture "data/texture/marbleSlabs.png"
@@ -87,9 +87,9 @@ preloadRender = do
     wlTexture <- makeShader "wall/texture" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
                 >>= addTexture "data/texture/grayscaleDirt.png"
 
--- texture shader
+---- texture shader
-    textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
+--    textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
-        >>= addTexture "data/texture/ayene_wooden_floor.png"
+--        >>= addTexture "data/texture/ayene_wooden_floor.png"
 
 -- framebuffer for lighting
     (fbo,fboTO,fboRBO) <- setupFramebufferWithStencil
@@ -99,12 +99,12 @@ preloadRender = do
     bindFramebuffer Framebuffer $= defaultFramebufferObject
     return $ RenderData
         { _pictureShaders           = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
-        , _lightingFloorShader      = lsShad
+        , _lightingFloorShader      = lightningFloorShad
         , _lightingOccludeShader    = wsShad
         , _lightingWallShader       = wlLightShad
         , _wallBlankShader          = wlBlank
         , _wallTextureShader        = wlTexture
-        , _textureShader            = textShad
+        --, _textureShader            = textShad
         , _backgroundShader         = bgShad
         , _fullscreenShader         = fsShad
         , _boxBlurShader            = boxBlurShad
@@ -190,13 +190,13 @@ pokeBezQStrat _ = []
 
 {-# INLINE pokeTriStrat #-}
 pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[[Float]]]
-pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
+pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> [flat3 p,flat4 co]) vs
 pokeTriStrat _ = []
 
-pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs
+pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> [flat3 a, flat4 b, flat3 c]) vs
 pokeCharStrat _ = []
 
-pokeArcStrat (RenderArc (a,b,c)) = [flat3 (flat3 a, flat4 b, flat4 c)]
+pokeArcStrat (RenderArc (a,b,c)) = [[flat3 a, flat4 b, flat4 c]]
 pokeArcStrat _ = []
 
 pokeLineStrat (RenderLine vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
@@ -210,11 +210,11 @@ vert = VertexShader
 geom = GeometryShader
 frag = FragmentShader
 
-pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
+pokeWPStrat :: RenderType -> [[[Float]]]
-pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
+pokeWPStrat Render22{_unRender22 = ((x,y),(z,w))} = [[[x,y,z,w]]]
 
-pokeWPColStrat :: ((Point2,Point2),Point4) -> [[[Float]]]
+pokeWPColStrat :: RenderType -> [[[Float]]]
-pokeWPColStrat (((x,y),(z,w)),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
+pokeWPColStrat Render22x4{_unRender22x4=(((x,y),(z,w)),(r,g,b,a))} = [[[x,y,z,w],[r,g,b,a]]]
 
 poke32 :: (Point3,Point2) -> [[[Float]]]
 poke32 ((x,y,z),(a,b)) = [[[x,y,z],[a,b]]]

src/Picture/Render.hs

@@ -34,7 +34,7 @@ setWallDepth
 setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do
     startTicks <- SDL.ticks
     colorMask $= Color4 Disabled Disabled Disabled Disabled
-    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) wallPoints
+    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
     bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
 
     currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
@@ -76,9 +76,9 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _
     bindFramebuffer Framebuffer $= _spareFBO pdata
 
 -- store wall and light positions into buffer
-    nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) wallPoints
+    nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints)
     bindShaderBuffers [_lightingWallShader pdata] [nWallLights]
-    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) wallPoints
+    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
     bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
 -- set uniforms for shader that draws lights
     currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
@@ -237,14 +237,14 @@ setIsoMatrixUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
     setShaderUniforms rot camZoom (tranx,trany) (winx,winy) 
         ( extractProgAndUnis (_lightingFloorShader pdata) 
         : extractProgAndUnis (_backgroundShader pdata) 
-        : extractProgAndUnis (_textureShader pdata)
+        -- : extractProgAndUnis (_textureShader pdata)
         : map extractProgAndUnis (_pictureShaders pdata)
         )
 
 renderShader
     :: Foldable f
-    => FullShader a
+    => FullShader
-    -> f a
+    -> f RenderType
     -> IO Word32
 renderShader shad dat = do
     sticks <- SDL.ticks

src/Shader.hs

@@ -23,6 +23,7 @@ module Shader
 import Geometry
 import Shader.Data
 import MatrixHelper
+import Picture.Data
 
 import Foreign
 import Codec.Picture
@@ -36,20 +37,20 @@ import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Linear.Matrix
 import Linear.V4
 
-extractProgAndUnis :: FullShader a -> (Program,UniformLocation)
+extractProgAndUnis :: FullShader -> (Program,UniformLocation)
 extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)
 
-pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
+pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
 pokeShaders = traverse pokeShader
 
-pokeShader :: FullShader a -> F.FoldM IO a Int
+pokeShader :: FullShader -> F.FoldM IO RenderType Int
 pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss))  (return 0) return
   where 
     (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ _shaderVAO fs
     fls = _shaderPokeStrategy fs
 
-pokeRender :: (a -> [[[Float]]])
+pokeRender :: (RenderType -> [[[Float]]])
-                -> [(Ptr Float,Int)] -> Int -> a -> IO Int
+                -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int
 pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
 
 pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
@@ -72,15 +73,15 @@ bindArrayBuffers numVs ps = do
         bindBuffer ArrayBuffer $= Just bo
         bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, DynamicDraw)
 
-bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
+bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
 bindShaderBuffers = zipWithM_ f
   where 
     f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
 
-drawShaders :: [FullShader a] -> [Int] -> IO ()
+drawShaders :: [FullShader] -> [Int] -> IO ()
 drawShaders = zipWithM_ drawShader
 
-drawShader :: FullShader a -> Int -> IO ()
+drawShader :: FullShader -> Int -> IO ()
 {-# INLINE drawShader #-}
 drawShader fs i = do 
     currentProgram $= Just (_shaderProgram fs)
@@ -93,7 +94,7 @@ drawShader fs i = do
 
 -- I am not sure if this assumes that the shader is constructed directly before
 -- the texture is added...
-addTexture :: String -> FullShader a -> IO (FullShader a)
+addTexture :: String -> FullShader -> IO (FullShader)
 addTexture texturePath shad = do
     Right cmap <- readImage texturePath
     let tex = convertRGBA8 cmap
@@ -118,8 +119,8 @@ makeShader
     -> [ShaderType] -- ^ Filetype extensions
     -> [(GLuint,Int)]   -- ^ The shaders input vertices (location, size)
     -> PrimitiveMode
-    -> (a -> [[[Float]]])   -- ^ Poke strategy: method for creating a list of vertex data to be bound
+    -> (RenderType -> [[[Float]]])   -- ^ Poke strategy: method for creating a list of vertex data to be bound
-    -> IO (FullShader a)
+    -> IO (FullShader)
 makeShader s shaderlist alocs pm renStrat = do
     (prog,unis)  <- makeSourcedShader s shaderlist
     vaob        <- setupVAO alocs
@@ -215,7 +216,7 @@ makeSourcedShader s sts = do
     uniformLocations <- uniformLocation prog "worldMat"
     return (prog,uniformLocations)
 
-addUniforms :: [String] -> FullShader a -> IO (FullShader a)
+addUniforms :: [String] -> FullShader -> IO (FullShader)
 addUniforms uniStrings shad = do
     uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
     return $ shad & shaderCustomUnis %~ (++ uniLocs)
@@ -286,7 +287,7 @@ setPerpMatUniform
     -> Point2 -- ^ translation
     -> Point2 -- ^ window size
     -> Point2 -- ^ viewfrom point
-    -> FullShader a
+    -> FullShader
     -> IO ()
 setPerpMatUniform rot czoom trans wins vFrom shad = do
     pmat <- (newMatrix RowMajor $ perspectiveMatrix rot czoom trans wins vFrom) :: IO (GLmatrix GLfloat)
@@ -294,7 +295,7 @@ setPerpMatUniform rot czoom trans wins vFrom shad = do
     uniform (_shaderMatrixUniform shad) $= pmat
     return ()
 
-freeShaderPointers :: FullShader a -> IO ()
+freeShaderPointers :: FullShader -> IO ()
 freeShaderPointers fs = do
     forM_ (_vaoBufferTargets $ _shaderVAO fs) $ \(_,ptr,_) ->
         free ptr

src/Shader/Data.hs

@@ -21,6 +21,8 @@ module Shader.Data
 
 --    , textureObject 
     ) where
+import Picture.Data
+
 import Graphics.Rendering.OpenGL
 import Foreign
 import Control.Lens
@@ -42,11 +44,11 @@ data VBO = VBO
     }
 
 {- | Datatype containing the necessary information for a single shader.  -}
-data FullShader a = FullShader
+data FullShader = FullShader
     { _shaderProgram :: Program
     , _shaderMatrixUniform :: UniformLocation
     , _shaderVAO :: VAO
-    , _shaderPokeStrategy :: a -> [[[Float]]]-- -> F.FoldM IO RenderType Int
+    , _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
     , _shaderDrawPrimitive :: PrimitiveMode
     , _shaderTexture :: Maybe ShaderTexture
     , _shaderCustomUnis :: [UniformLocation]