module LC_B_GLCompile where
import Control.Applicative
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.List as L
import Data.Maybe
import Data.Set (Set)
import Data.Map (Map)
import Data.Trie as T
import Foreign
import qualified Data.ByteString.Char8 as SB
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Traversable as T
import qualified Data.Vector as V
import Graphics.Rendering.OpenGL.Raw.Core32
( GLboolean
, GLenum
, GLint
, GLuint
, glDisable
, glEnable
, gl_TRUE
, glAttachShader
, glBindFragDataLocation
, glCreateProgram
, glCreateShader
, glDeleteProgram
, glDeleteShader
, glLinkProgram
, glUseProgram
, gl_FRAGMENT_SHADER
, gl_GEOMETRY_SHADER
, gl_LINK_STATUS
, gl_VERTEX_SHADER
, glBlendColor
, glBlendEquationSeparate
, glBlendFuncSeparate
, gl_BLEND
, glLogicOp
, gl_COLOR_LOGIC_OP
, glClear
, glClearColor
, glClearDepth
, glColorMask
, gl_COLOR_BUFFER_BIT
, gl_DEPTH_BUFFER_BIT
, glDepthFunc
, glDepthMask
, gl_DEPTH_TEST
, gl_STENCIL_TEST
, glProvokingVertex
, gl_FIRST_VERTEX_CONVENTION
, gl_LAST_VERTEX_CONVENTION
, glPointParameterf
, glPointSize
, gl_LOWER_LEFT
, gl_POINT_FADE_THRESHOLD_SIZE
, gl_POINT_SPRITE_COORD_ORIGIN
, gl_PROGRAM_POINT_SIZE
, gl_UPPER_LEFT
, glLineWidth
, glCullFace
, glFrontFace
, glPolygonMode
, glPolygonOffset
, gl_BACK
, gl_CCW
, gl_CULL_FACE
, gl_CW
, gl_FILL
, gl_FRONT
, gl_FRONT_AND_BACK
, gl_LINE
, gl_POINT
, gl_POLYGON_OFFSET_FILL
, gl_POLYGON_OFFSET_LINE
, gl_POLYGON_OFFSET_POINT
)
import LC_G_Type
import LC_G_APIType
import LC_U_APIType
import LC_U_DeBruijn
import LC_B_GLType
import LC_B_GLUtil
import LC_B_GLSLCodeGen
import LC_B_Traversals
data ShaderSource
= VertexShaderSrc !ByteString
| GeometryShaderSrc !ByteString
| FragmentShaderSrc !ByteString
setupRasterContext :: RasterContext -> IO ()
setupRasterContext = cvt
where
cff :: FrontFace -> GLenum
cff CCW = gl_CCW
cff CW = gl_CW
setProvokingVertex :: ProvokingVertex -> IO ()
setProvokingVertex pv = glProvokingVertex $ case pv of
FirstVertex -> gl_FIRST_VERTEX_CONVENTION
LastVertex -> gl_LAST_VERTEX_CONVENTION
setPointSize :: PointSize -> IO ()
setPointSize ps = case ps of
ProgramPointSize -> glEnable gl_PROGRAM_POINT_SIZE
PointSize s -> do
glDisable gl_PROGRAM_POINT_SIZE
glPointSize $ realToFrac s
cvt :: RasterContext -> IO ()
cvt (PointCtx ps fts sc) = do
setPointSize ps
glPointParameterf gl_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
glPointParameterf gl_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
LowerLeft -> gl_LOWER_LEFT
UpperLeft -> gl_UPPER_LEFT
cvt (LineCtx lw pv) = do
glLineWidth (realToFrac lw)
setProvokingVertex pv
cvt (TriangleCtx cm pm po pv) = do
case cm of
CullNone -> glDisable gl_CULL_FACE
CullFront f -> do
glEnable gl_CULL_FACE
glCullFace gl_FRONT
glFrontFace $ cff f
CullBack f -> do
glEnable gl_CULL_FACE
glCullFace gl_BACK
glFrontFace $ cff f
case pm of
PolygonPoint ps -> do
setPointSize ps
glPolygonMode gl_FRONT_AND_BACK gl_POINT
PolygonLine lw -> do
glLineWidth (realToFrac lw)
glPolygonMode gl_FRONT_AND_BACK gl_LINE
PolygonFill -> glPolygonMode gl_FRONT_AND_BACK gl_FILL
glDisable gl_POLYGON_OFFSET_POINT
glDisable gl_POLYGON_OFFSET_LINE
glDisable gl_POLYGON_OFFSET_FILL
case po of
NoOffset -> return ()
Offset f u -> do
glPolygonOffset (realToFrac f) (realToFrac u)
glEnable $ case pm of
PolygonPoint _ -> gl_POLYGON_OFFSET_POINT
PolygonLine _ -> gl_POLYGON_OFFSET_LINE
PolygonFill -> gl_POLYGON_OFFSET_FILL
setProvokingVertex pv
setupAccumulationContext :: AccumulationContext -> IO ()
setupAccumulationContext (AccumulationContext n ops) = cvt ops
where
cvt :: [FragmentOperation] -> IO ()
cvt (StencilOp a b c : DepthOp f m : xs) = do
cvtC 0 xs
cvt (StencilOp a b c : xs) = do
cvtC 0 xs
cvt (DepthOp df dm : xs) = do
glDisable gl_STENCIL_TEST
case df == Always && dm == False of
True -> glDisable gl_DEPTH_TEST
False -> do
glEnable gl_DEPTH_TEST
glDepthFunc $! comparisonFunctionToGLType df
glDepthMask (cvtBool dm)
cvtC 0 xs
cvt xs = do
glDisable gl_DEPTH_TEST
glDisable gl_STENCIL_TEST
cvtC 0 xs
cvtC :: Int -> [FragmentOperation] -> IO ()
cvtC i (ColorOp b m : xs) = do
case b of
NoBlending -> do
glDisable gl_BLEND
glDisable gl_COLOR_LOGIC_OP
BlendLogicOp op -> do
glDisable gl_BLEND
glEnable gl_COLOR_LOGIC_OP
glLogicOp $ logicOperationToGLType op
Blend (cEq,aEq) ((scF,dcF),(saF,daF)) (V4 r g b a) -> do
glDisable gl_COLOR_LOGIC_OP
glEnable gl_BLEND
glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
(blendingFactorToGLType saF) (blendingFactorToGLType daF)
glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
let cvt True = 1
cvt False = 0
(mr,mg,mb,ma) = case m of
VBool r -> (cvt r, 1, 1, 1)
VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)
VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)
VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)
_ -> (1,1,1,1)
glColorMask mr mg mb ma
cvtC (i + 1) xs
cvtC _ [] = return ()
cvtBool :: Bool -> GLboolean
cvtBool True = 1
cvtBool False = 0
compileClearFrameBuffer :: Exp -> IO ()
compileClearFrameBuffer (FrameBuffer fb) = cvt fb
where
cvt :: [Image] -> IO ()
cvt (StencilImage sh1 s : DepthImage sh2 d : xs) = do
cvtC 0 xs
cvt (StencilImage sh s : xs) = do
cvtC 0 xs
cvt (DepthImage sh d : xs) = do
let
glClearDepth $ realToFrac d
glClear $ fromIntegral gl_DEPTH_BUFFER_BIT
cvtC 0 xs
cvt xs = cvtC 0 xs
cvtC :: Int -> [Image] -> IO ()
cvtC i (ColorImage sh c : xs) = do
let (r,g,b,a) = case c of
VFloat r -> (realToFrac r, 0, 0, 1)
VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
_ -> (0,0,0,1)
glClearColor r g b a
glClear $ fromIntegral gl_COLOR_BUFFER_BIT
cvtC i [] = return ()
compileRenderFrameBuffer :: DAG -> [(Exp,String)] -> [(Exp,String)] -> IORef ObjectSet -> Exp -> IO (IO (), IO (), Trie GLint, Trie GLuint, Int)
compileRenderFrameBuffer dag samplerNames slotSamplerNames objsIORef (Accumulate aCtx ffilter fsh rastExp fb) = do
po <- glCreateProgram
let Rasterize rCtx primsExp = toExp dag rastExp
(vsh,gsh,fetchExp) = case toExp dag primsExp of
Transform vsh fetchExp -> (vsh,Nothing,fetchExp)
Reassemble gsh transExp -> case toExp dag transExp of
Transform vsh fetchExp -> (vsh,Just gsh,fetchExp)
_ -> error "internal error: compileRenderFrameBuffer"
_ -> error "internal error: compileRenderFrameBuffer"
Fetch slotName slotPrim slotInput = toExp dag fetchExp
(shl,fragOuts,outColorCnt) = case gsh of
Nothing -> ([VertexShaderSrc srcV, FragmentShaderSrc srcF], (map fst outF), outColorCnt)
where
(srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outV (toExp dag ffilter) $ toExp dag fsh
Just gs -> ([VertexShaderSrc srcV, GeometryShaderSrc srcG, FragmentShaderSrc srcF], (map fst outF), outColorCnt)
where
(srcG,outG) = codeGenGeometryShader dag samplerNameMap slotPrim outV $ toExp dag gs
(srcF,outF,outColorCnt) = codeGenFragmentShader dag samplerNameMap outG (toExp dag ffilter) $ toExp dag fsh
(srcV,outV) = codeGenVertexShader dag samplerNameMap slotInput $ toExp dag vsh
allSamplerNames = samplerNames ++ slotSamplerNames
samplerNameMap = Map.fromList allSamplerNames
printGLStatus = checkGL >>= print
createAndAttach [] _ = return $! Nothing
createAndAttach sl t = do
mapM_ SB.putStrLn sl
o <- glCreateShader t
compileShader o sl
glAttachShader po o
putStr " + compile shader source: " >> printGLStatus
return $! Just o
putStrLn $ "compileRenderFrameBuffer: compiling program for slot: " ++ show slotName
putStrLn " + compile vertex shader"
vsh <- createAndAttach [s | VertexShaderSrc s <- shl] gl_VERTEX_SHADER
putStrLn " + compile geometry shader"
gsh <- createAndAttach [s | GeometryShaderSrc s <- shl] gl_GEOMETRY_SHADER
putStrLn " + compile fragment shader"
fsh <- createAndAttach [s | FragmentShaderSrc s <- shl] gl_FRAGMENT_SHADER
forM_ (zip fragOuts [0..]) $ \(n,i) -> SB.useAsCString n $ \pn -> do
putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i)
glBindFragDataLocation po i $ castPtr pn
putStr " + setup shader output mapping: " >> printGLStatus
glLinkProgram po
printProgramLog po
status <- glGetProgramiv1 gl_LINK_STATUS po
when (status /= fromIntegral gl_TRUE) $ fail "link program failed!"
(uLoc,uType) <- queryUniforms po
(sLoc,sType) <- queryStreams po
putStrLn $ "shader program stream input: " ++ show sLoc
putStrLn $ "shader program uniform input: " ++ show uLoc
putStrLn $ "expected sampler input: " ++ show allSamplerNames
glUseProgram po
forM_ (zip [0..] (map (SB.pack . snd) allSamplerNames)) $ \(tuIdx,n) -> case T.lookup n uLoc of
Nothing -> putStrLn $ "WARNING - unxepected inactive sampler: " ++ show n
Just i -> (setSampler i tuIdx) >> putStr (" + setup texture unit mapping (smp " ++ show i ++ " <-> TexUnit " ++ show tuIdx ++": ") >> printGLStatus
let uLoc' = foldl' (\t (_,n) -> setSamplerLoc t (SB.pack n)) uLoc allSamplerNames
renderSmpNamesS = Set.fromList $ map (SB.pack . snd) samplerNames
renderSmpCount = Set.size renderSmpNamesS
slotSmpName = map (SB.pack . snd) slotSamplerNames
setSamplerLoc :: Trie GLint -> ByteString -> Trie GLint
setSamplerLoc t n
| Set.member n renderSmpNamesS = T.delete n t
| otherwise = T.adjust (\_ -> fromIntegral $ renderSmpCount + idx) n t
where
Just idx = elemIndex n slotSmpName
disposeFun = glDeleteProgram po >> mapM_ glDeleteShader (catMaybes [vsh,gsh,fsh])
renderFun = do
ObjectSet drawObjs objsMap <- readIORef objsIORef
unless (Map.null objsMap) $ do
setupRasterContext rCtx
setupAccumulationContext aCtx
glUseProgram po
drawObjs
print slotName
print uLoc'
return $! (renderFun, disposeFun, uLoc', sLoc, outColorCnt)