Refactor shader creation

src/Dodge/Rendering.hs

@@ -320,14 +320,16 @@ drawWallFace w wall
 -- it is not obvious which will be returned
 intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
 intersectLinefromScreen w a b = listToMaybe 
-        . mapMaybe (\(x,y) -> intersectSegLineFrom' x y a b)
+        . mapMaybe (\(x,y) -> intersectSegLineext x y a b)
         . makeLoopPairs 
         $ screenPolygon w
 
 extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
-extendConeToScreenEdge w c (x,y) = orderPolygon $ [x,y] ++ borderPs ++ cornerPs
+extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
     where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
           cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
+          wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y) 
+                                    . makeLoopPairs $ screenPolygon w
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 

src/Geometry/Intersect.hs

@@ -44,6 +44,21 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
         t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
         u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
 
+-- this is probably not correct...
+intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLineext #-}
+intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | den > 0 && ( t' < 0 || u' < den || t' > den )
+        = Nothing
+    | den < 0 && ( t' > 0 || u' > - den || t' < den )
+        = Nothing
+    | otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
+    where 
+        den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+        t'  = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
+        u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
+
 intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
 {-# INLINE intersectSegLine' #-}
 intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)

src/Picture/Preload.hs

@@ -21,6 +21,7 @@ data RenderData = RenderData
     { _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2)
     , _wallLightShader   :: FullShader (Point2,Point2)
+    , _wallFaceShader    :: FullShader (Point2,Point2,Point4)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
     , _listShaders :: [FullShader RenderType]
@@ -35,11 +36,11 @@ preloadRender = do
 -- lighting shaders
     lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points 
                     (return . return . flat4)
-    wsShad <- makeShaderCustomUnis "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+    wsShad <- makeShader "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
-                ["lightPos","perpMat","facesToDraw"]
+                >>= addUniforms ["lightPos","perpMat","facesToDraw"]
     wlLightShad 
-         <- makeShaderCustomUnis "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
+         <- makeShader "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
-                    ["lightPos","perpMat","radLum"]
+                >>= addUniforms ["lightPos","perpMat","radLum"]
 
 -- 2D draw shaders
     bslist <- makeShader "twoD/basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
@@ -48,9 +49,9 @@ preloadRender = do
     eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)]       Triangles pokeEllStrat
     bezierQuadShader <- makeShader 
                       "twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)]    TriangleStrip pokeBezQStrat
-    cslist <- makeTextureShader "twoD/character" [vert,geom,frag] 
+    cslist <- makeShader "twoD/character" [vert,geom,frag] 
                                 [(0,3),(1,4),(2,3)] Points pokeCharStrat
-                                "data/texture/charMap.png"
+                  >>= addTexture "data/texture/charMap.png"
 
 -- fullscreen shader
     fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip 
@@ -63,8 +64,13 @@ preloadRender = do
     n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
 
 -- background shader
-    bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
+    bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
-                                "data/texture/smudgedDirt.png"
+                >>= addTexture "data/texture/smudgedDirt.png"
+
+-- wallShader
+    wlShad <- makeShader "wallFace" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
+                >>= addTexture "data/texture/smudgedDirt.png"
+                >>= addUniforms ["perpMat"]
 
 -- framebuffer for lighting
     (fbo,fboTO) <- setupFramebuffer
@@ -77,6 +83,7 @@ preloadRender = do
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
         , _wallLightShader   = wlLightShad
+        , _wallFaceShader    = wlShad
         , _backgroundShader  = bgShad
         , _fullscreenShader  = fsShad
         , _spareFBO = fbo
@@ -148,6 +155,9 @@ frag = FragmentShader
 pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
 pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
 
+pokeWPColStrat :: (Point2,Point2,Point4) -> [[[Float]]]
+pokeWPColStrat ((x,y),(z,w),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
+
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []
 

src/Shader.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Shader
     ( makeShader
-    , makeTextureShader
+    , addTexture
-    , makeShaderCustomUnis
+    , addUniforms
     , pokeShaders
     , pokeShader
     , bindArrayBuffers
@@ -28,6 +28,9 @@ import Codec.Picture
 import qualified Data.Vector.Storable as V
 
 import Control.Monad (when, forM, zipWithM_, forM_, foldM)
+import Control.Lens
+
+import Data.Maybe (fromMaybe)
 
 import qualified Control.Foldl as F
 
@@ -97,13 +100,10 @@ drawShader fs i = do
         _   -> return ()
     drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
 
-makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)] 
+-- I am not sure if this assumes that the shader is constructed directly before
-            -> PrimitiveMode -> (a -> [[[Float]]]) 
+-- the texture is added...
-            -> String
+addTexture :: String -> FullShader a -> IO (FullShader a)
-            -> IO (FullShader a)
+addTexture texturePath shad = do
-makeTextureShader s shaderlist alocs pm renStrat texturePath = do
-    (prog,unis)  <- makeSourcedShader s shaderlist
-
     Right cmap <- readImage texturePath
     let tex = convertRGBA8 cmap
     textureOb <- genObjectName
@@ -116,31 +116,7 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do
                         (PixelData RGBA UnsignedByte ptr)
     generateMipmap' Texture2D
     textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
-
+    return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
-    vao        <- setupVAO alocs
-
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
-                        , _shaderCustomUnis = Nothing
-                        }
-
-makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) 
-                -> [String] -> IO (FullShader a)
-makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
-    (prog,unis,unis')  <- makeSourcedShaderCustomUnis s shaderlist uniStrings
-    vao        <- setupVAO alocs
-    return $ FullShader { _shaderProgram = prog
-                        , _shaderUniforms = unis
-                        , _shaderVAO = vao
-                        , _shaderPokeStrategy = renStrat
-                        , _shaderDrawPrimitive = pm
-                        , _shaderTexture = Nothing
-                        , _shaderCustomUnis = Just unis'
-                        }
 
 makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
 makeShader s shaderlist alocs pm renStrat = do
@@ -203,12 +179,11 @@ makeSourcedShader s sts = do
                     $ \uniString -> uniformLocation prog uniString
     return (prog,uniformLocations)
 
-makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String] 
+addUniforms :: [String] -> FullShader a -> IO (FullShader a)
-                -> IO (Program, [UniformLocation], [UniformLocation])
+addUniforms uniStrings shad = do
-makeSourcedShaderCustomUnis s shadTypes uniStrings = do
+    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
-    (prog,unis0) <- makeSourcedShader s shadTypes
+    return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
-    unis <- mapM (uniformLocation prog) uniStrings
+
-    return (prog,unis0,unis)
 
 shaderTypeExt :: ShaderType -> String
 shaderTypeExt VertexShader   = ".vert"