module Rasterizer (
Rasterizer(),
VertexOutput(..),
rasterize,
rasterizeFront,
rasterizeFrontAndBack,
rasterizeBack,
) where
import Shader
import Data.Vec ((:.)(..), Vec2, Vec3, Vec4)
import GPUStream
import Control.Monad.State
newtype Rasterizer a = Rasterizer {fromRasterizer :: State [Shader String] a} deriving Monad
class GPU a => VertexOutput a where
type FragmentInput a
toFragment :: a -> Rasterizer (FragmentInput a)
instance VertexOutput (Vertex Float) where
type FragmentInput (Vertex Float) = Fragment Float
toFragment (Vertex a) = Rasterizer $ do x <- gets length
modify (a:)
return $ Fragment $ do addInput x
return $ "fa" ++ show x
instance VertexOutput () where
type FragmentInput () = ()
toFragment () = return ()
instance (VertexOutput a,VertexOutput b) => VertexOutput (a,b) where
type FragmentInput (a,b) = (FragmentInput a, FragmentInput b)
toFragment (a, b) = do a' <- toFragment a
b' <- toFragment b
return (a', b')
instance (VertexOutput a,VertexOutput b,VertexOutput c) => VertexOutput (a,b,c) where
type FragmentInput (a,b,c) = (FragmentInput a, FragmentInput b, FragmentInput c)
toFragment (a, b, c) = do a' <- toFragment a
b' <- toFragment b
c' <- toFragment c
return (a', b', c')
instance (VertexOutput a,VertexOutput b,VertexOutput c,VertexOutput d) => VertexOutput (a,b,c,d) where
type FragmentInput (a,b,c,d) = (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d)
toFragment (a, b, c, d) = do a' <- toFragment a
b' <- toFragment b
c' <- toFragment c
d' <- toFragment d
return (a', b', c', d')
instance (VertexOutput a, VertexOutput b) => VertexOutput (a:.b) where
type FragmentInput (a:.b) = FragmentInput a :. FragmentInput b
toFragment (a:.b) = do a' <- toFragment a
b' <- toFragment b
return $ a':.b'
rasterize :: VertexOutput a
=> PrimitiveStream p (VertexPosition, a)
-> FragmentStream (FragmentInput a)
rasterize (PrimitiveStream []) = FragmentStream []
rasterize (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs
where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, fs, getPositionCode pos), true, fa)
where (fa, fs) = getFragmentInput va
rasterizeFrontAndBack :: VertexOutput a
=> PrimitiveStream Triangle (VertexPosition, a)
-> FragmentStream (Fragment Bool, FragmentInput a)
rasterizeFrontAndBack (PrimitiveStream []) = FragmentStream []
rasterizeFrontAndBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs
where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, fs, getPositionCode pos), true, (Fragment $ return "gl_FrontFacing", fa))
where (fa, fs) = getFragmentInput va
rasterizeFront :: VertexOutput a
=> PrimitiveStream Triangle (VertexPosition, a)
-> FragmentStream (FragmentInput a)
rasterizeFront (PrimitiveStream []) = FragmentStream []
rasterizeFront (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs
where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, fs, getPositionCode pos), true, fa)
where (fa, fs) = getFragmentInput va
rasterizeBack :: VertexOutput a
=> PrimitiveStream Triangle (VertexPosition, a)
-> FragmentStream (FragmentInput a)
rasterizeBack (PrimitiveStream []) = FragmentStream []
rasterizeBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs
where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, fs, getPositionCode pos), true, fa)
where (fa, fs) = getFragmentInput va
getPositionCode (Vertex x :. Vertex y :. Vertex z :. Vertex w :. ()) = do x' <- x
y' <- y
z' <- z
w' <- w
return $ "vec4(" ++ x' ++ "," ++ y' ++ "," ++ z' ++ "," ++ w' ++ ")"
getFragmentInput :: VertexOutput a => a -> (FragmentInput a, [Shader String])
getFragmentInput = flip runState [] . revState . fromRasterizer . toFragment
where
revState m = do x <- m
modify reverse
return x