Shader Pipeline: PrimShader and Random Face Colours

[tobz619]

While building my toy rasterizer I was thinking that I could implement various stages like so:

type VertexShader = ViewSpace -> ViewSpace
type PrimShader = forall f. Functor f => f ViewSpace -> f ViewSpace
type MeshShader = forall t f. (Traversable t, Functor f) => t (f ViewSpace) -> t (f ViewSpace)
type FragmentShader = ProjectionSpace -> ProjectionSpace

data Shader = Shader {
    getVertexShader :: VertexShader,
    getPrimShader :: PrimShader,
    getMeshShader :: MeshShader,
    getFragmentShader :: FragmentShader
  }

noShaders :: Shader
noShaders = Shader id id id id

addShader :: Shader -> Shader -> Shader
addShader (Shader v0 p0 m0 f0) (Shader v1 p1 m1 f1) =
  Shader (v0 . v1) (p0 . p1) (m0 . m1) (f0 . f1)

And use them in a pipeline like so:

getObjFaces :: Dimensions -> ModelSpaceTransform -> Projection a -> CameraTransform -> Shader -> ObjFile -> [[ScreenSpace]]
getObjFaces dims modelTransform projection camera shader obj =
  let allFaces = snd <$> Map.elems (objFaces obj)
      allVerts = fmap someFunc allFaces
      someFunc faceVec = concatMap (objShaderPipeline shader modelTransform projection camera obj) (V.toList faceVec)
        
   in [toScreenSpace dims <$> verts | verts <- allVerts, all pointIsVisible verts]

objShaderPipeline :: Shader -> ModelSpaceTransform -> Projection a -> CameraTransform -> ObjFile -> Face ObjFaceInfo -> [ProjectionSpace]
objShaderPipeline (Shader vertexShader primShader _ fragmentShader) modelTransform projection camera obj (Face p1 p2 p3 pn) =
  let faceInfoList = p1 : p2 : p3 : pn
      vs = objVertices obj
      points =
        fmap
          (fragmentShader . toProjection projection)
          faceVertices
      faceVertices =
        Debug.traceShowWith (fmap (getVertexColour . getViewSpace)) . primShader . fmap
          ( vertexShader
            . toViewSpace camera
            . toModelView modelTransform    
            . (vs V.!)
            . subtract 1
            . objFaceVertexIndex
          ) $
          faceInfoList
   in points

 

The problem I’m having is implementing a PrimShader that randomly sets all the vertices on one face to one specfic VertexColour using unsafePerformIO. This colour would ideally be generated every time the shader is called:

genCol :: IO VertexColour
genCol =  VertexColour
              <$> randomRIO (0, 255)
              <*> randomRIO (0, 255)
              <*> randomRIO (0, 255)
              <*> pure 255
        
randomFaceColourShader :: IO VertexColour -> Shader
randomFaceColourShader colGenerator = Shader id colourFaces id id
  where colourFaces vs = fmap (toGeneratedColour colGenerator) vs
        toGeneratedColour col (ViewSpace (Vertex pos _ vnorm)) = ViewSpace (Vertex pos (Just (unsafePerformIO col)) vnorm)

I later execute the whole pipeline as part of getting the pixelsToRender in the canvasLoop function.

canvasLoop = do
  SDL.initializeAll
  -- model <- testParse
  let --  Initialisation stuff
      shader = randomFaceColourShader genCol -- The shader of interest. 
      -- shader = noShaders
      -- projection = projectFrustrum (-right * aspect ) (right * aspect) (-top) (top) near far
      -- projection = projectPerspective 53 aspect 1 20
      -- depthBufferPix = getObjFaceDepth dims modelOpts projection camera model
      pixelsToRender = getObjFaces dims modelOpts projection camera shader model -- Shaders executed in here via getObjFaces
      -- ...
      (newZ, newCanv) = addPointsToBuffer (fromIntegral w) pixelsToRender 1 zBuf canv
      -- rest of program

In cabal repland cabal run I get all the verts being correctly set according to my Debug.Trace output but a dithered and incorrectly coloured output face colours.

EDIT: Or maybe not: this output is inconsistent. Sometimes all three verts are same colour and other times, I get this lol. Even still, the dithering should not be happening as far as I can tell!

ghci> canvasLoop 
[Just (VertexColour {r = 131, g = 191, b = 83, a = 255}),Just (VertexColour {r = 204, g = 226, b = 140, a = 255}),Just (VertexColour {r = 114, g = 205, b = 169, a = 255})]
[Just (VertexColour {r = 223, g = 67, b = 147, a = 255}),Just (VertexColour {r = 49, g = 228, b = 23, a = 255}),Just (VertexColour {r = 9, g = 62, b = 174, a = 255})]
[Just (VertexColour {r = 161, g = 94, b = 184, a = 255}),Just (VertexColour {r = 227, g = 206, b = 146, a = 255}),Just (VertexColour {r = 138, g = 6, b = 29, a = 255})]
[Just (VertexColour {r = 255, g = 187, b = 217, a = 255}),Just (VertexColour {r = 140, g = 55, b = 221, a = 255}),Just (VertexColour {r = 182, g = 113, b = 167, a = 255})]
[Just (VertexColour {r = 44, g = 213, b = 17, a = 255}),Just (VertexColour {r = 180, g = 135, b = 37, a = 255}),Just (VertexColour {r = 25, g = 189, b = 69, a = 255})]
[Just (VertexColour {r = 39, g = 6, b = 180, a = 255}),Just (VertexColour {r = 11, g = 1, b = 24, a = 255}),Just (VertexColour {r = 69, g = 88, b = 6, a = 255})]
[Just (VertexColour {r = 92, g = 64, b = 121, a = 255}),Just (VertexColour {r = 64, g = 160, b = 76, a = 255}),Just (VertexColour {r = 239, g = 17, b = 85, a = 255})]
[Just (VertexColour {r = 28, g = 156, b = 188, a = 255}),Just (VertexColour {r = 28, g = 200, b = 218, a = 255}),Just (VertexColour {r = 30, g = 232, b = 153, a = 255})]

If I cabal install followed by executing the binary, all vertices on every face get set to the same colour:

$ game-engine +RTS -s -N8
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]
[Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255}),Just (VertexColour {r = 136, g = 243, b = 159, a = 255})]

The only thing I can think of doing at this point is lifting all of the Shader types to be in IO and everything that interacts with the shader pipeline to also be in IObut I’m wondering if there is any other approach that could be worth trying.

[jmcarthur]

Parameterize the shader on a color instead of on a color generator. Generate the color before calling the function. Pass the color, not the generator, down through any intermediate functions.

[tobz619]

The difficulty I have with this is that I can only generate anything once - whether it’s a StdGen or VertexColour: my entry point is canvasLoop :: IO () and I get one single StdGen via initStdGen.

The primShader is retrieved via the getPrimShaderrecord accessor to the the overall Shader and is deeply embedded in the objShaderPipeline function. Therefore, whatever colour I set on randomColourShader is set and cannot be changed unless I can thread the new state through to subsequent calls effectively creating some kind of global state or dependency chain where every call to primShader needs to know about any calls to other primShader.

@wiz suggested making the Shader types some kind of State monad Shader → (a, Shader) so I’m going to try that?

[tobz619]

It took all bloody day but I’ve finally done it.

mapAccumL is an AWESOME function. It is annoying to have to unwrap tuples tho but oh well.

objShaderPipeline s@(Shader vertexShader primShader _ fragmentShader _) modelTransform projection camera obj (Face p1 p2 p3 pn) =
  let faceInfoList = p1 : p2 : p3 : pn
      vs = objVertices obj
      out@(endShad, points) =
        (\(projSpace, shad) -> fragShaderHandler shad projSpace)
        . (\(coords, newShad) -> (fmap (toProjection projection) coords, newShad))
        . Debug.traceShowWith (fmap (getVertexColour . getViewSpace). fst)
        . primShaderHandling vertShaderOut
        $          
          faceVertices
      (vertShaderOut,faceVertices) =
        mapAccumL vertInvoker s . fmap
          ( toViewSpace camera
            . toModelView modelTransform    
            . (vs V.!)
            . subtract 1
            . objFaceVertexIndex
          ) $
          faceInfoList
   in (endShad, points)
   where vertInvoker shad vert = (newShader, transformed)
            where (transformed, newShader) = invokeVertShader shad (getShaderStdGen shad) vert  
         primShaderHandling shadState faceVerts = invokePrimShader shadState (getShaderStdGen shadState) faceVerts
         fragShaderHandler shadState projVerts = mapAccumL fragger shadState projVerts
         fragger shad pix = let 
          (newShad, newPix) = invokeFragmentShader shad (getShaderStdGen shad) pix
          in (newPix, newShad)

getObjFaces dims modelTransform projection camera shader obj =
  let allFaces = snd <$> Map.elems (objFaces obj)
      allVerts = snd . builder shader $ (concatMap V.toList allFaces)
      builder oldShad faces = mapAccumL buildHelper oldShad faces
      buildHelper shad face = objShaderPipeline shad modelTransform projection camera obj face
        
        
   in [toScreenSpace dims <$> verts | verts <- allVerts, all pointIsVisible verts] 

and Shaders look something like this:

type VertexShader = StdGen -> ViewSpace -> ViewSpace
type PrimShader = forall f. Functor f => StdGen -> f ViewSpace -> f ViewSpace
type MeshShader = forall t f. (Traversable t, Functor f) => StdGen -> t (f ViewSpace) -> t (f ViewSpace)
type FragmentShader = StdGen -> ProjectionSpace -> ProjectionSpace

data Shader = Shader {
    getVertexShader :: VertexShader,
    getPrimShader :: PrimShader,
    getMeshShader :: MeshShader,
    getFragmentShader :: FragmentShader,
    getShaderStdGen :: StdGen
  }


baseShader :: StdGen -> Shader
baseShader gen = Shader (const id) (const id) (const id) (const id) gen

invokeVertShader :: Shader -> StdGen -> ViewSpace -> (ViewSpace, Shader)
invokeVertShader s gen v = (getVertexShader s gen v, s {getShaderStdGen = newGen})
  where (_, newGen) = random gen :: (Int, StdGen)


invokePrimShader :: Functor f => Shader -> StdGen -> f ViewSpace -> (f ViewSpace, Shader)
invokePrimShader s gen vs = (getPrimShader s gen vs, s {getShaderStdGen = newGen})
  where (_, newGen) = random gen :: (Int, StdGen)

invokeMeshShader :: (Traversable t, Functor f) => Shader -> StdGen -> t (f ViewSpace) -> (t (f ViewSpace), Shader)
invokeMeshShader s gen vs  = (getMeshShader s gen vs, s {getShaderStdGen = newGen})
  where (_, newGen) = random gen :: (Int, StdGen)

invokeFragmentShader :: Shader -> StdGen -> ProjectionSpace -> (ProjectionSpace, Shader)
invokeFragmentShader s gen vs  = (getFragmentShader s gen vs, s {getShaderStdGen = newGen})
  where (_, newGen) = random gen :: (Int, StdGen)

-- genCol :: IO VertexColour
-- genCol :: RandomGen p => p -> VertexColour
genCol gen =  (g2, VertexColour r g b 255)
  where (r, g0) = randomR (0, 255) gen
        (g, g1) = randomR (0, 255) g0
        (b, g2) = randomR (0, 255) g1
        
randomFaceColourShader gen = colourFaces 
  where colourFaces vs = fmap (toGeneratedColour newCol) vs
        (newGen, newCol) = genCol gen
        toGeneratedColour col (ViewSpace (Vertex pos _ vnorm)) = ViewSpace (Vertex pos (Just col) vnorm)

I will obviously clean this up and make it more manageable, maybe even give myself a nice little wrapper type to keep track of things better but I’m just happy it works.