module Graphics.Luminance.Core.Draw where
import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Bits ( (.|.) )
import Data.Foldable ( traverse_ )
import Foreign.Ptr ( nullPtr )
import Graphics.GL
import Graphics.Luminance.Core.Blending ( setBlending )
import Graphics.Luminance.Core.Debug ( debugGL )
import Graphics.Luminance.Core.Framebuffer ( Framebuffer(..), Output, defaultFramebuffer )
import Graphics.Luminance.Core.Geometry ( Geometry(..), VertexArray(..) )
import Graphics.Luminance.Core.RW ( RW, Writable )
import Graphics.Luminance.Core.RenderCmd ( RenderCmd(..) )
import Graphics.Luminance.Core.Shader.Program ( Program(..), U'(..) )
data FrameCmd rw c d a = FrameCmd {
frameCmdFramebuffer :: Framebuffer rw c d
, frameCmdShadingCmds :: [ShadingCmd rw c d a]
}
defaultFrameCmd :: [ShadingCmd RW () () a] -> FrameCmd RW () () a
defaultFrameCmd = FrameCmd defaultFramebuffer
data ShadingCmd rw c d a = ShadingCmd {
shadingCmdProgram :: Program a
, shadingCmdUniforms :: a -> U'
, shadingCmdDrawCmds :: [DrawCmd rw c d a]
}
newtype DrawCmd rw c d a = DrawCmd { drawCmd :: a -> (U',RenderCmd rw c d Geometry) }
updateAndDraw :: (a -> U') -> RenderCmd rw c d Geometry -> DrawCmd rw c d a
updateAndDraw update rdrCmd = DrawCmd $ \a -> (update a,rdrCmd)
pureDraw :: RenderCmd rw c d Geometry -> DrawCmd rw c d a
pureDraw rdrCmd = DrawCmd $ const (mempty,rdrCmd)
draw :: (MonadIO m,Writable w)
=> FrameCmd w c d a
-> m (Output c d)
draw fc = do
debugGL $ glBindFramebuffer GL_DRAW_FRAMEBUFFER (fromIntegral . framebufferID $ frameCmdFramebuffer fc)
debugGL $ glClear $ GL_DEPTH_BUFFER_BIT .|. GL_COLOR_BUFFER_BIT
traverse_ shade (frameCmdShadingCmds fc)
pure (framebufferOutput . frameCmdFramebuffer $ fc)
shade :: (MonadIO m) => ShadingCmd rw c d a -> m ()
shade shd = do
debugGL $ glUseProgram (programID prog)
liftIO . runU' $ (shadingCmdUniforms shd) iface
traverse_ (\drw -> uncurry render $ drawCmd drw iface) (shadingCmdDrawCmds shd)
where
prog = shadingCmdProgram shd
iface = programInterface prog
render :: (MonadIO m) => U' -> RenderCmd rw c d Geometry -> m ()
render u (RenderCmd blending depthTest geometry) = do
liftIO (runU' u)
setBlending blending
(if depthTest then glEnable else glDisable) GL_DEPTH_TEST
case geometry of
DirectGeometry (VertexArray vid mode vbNb) -> do
debugGL $ glBindVertexArray vid
debugGL $ glDrawArrays mode 0 vbNb
IndexedGeometry (VertexArray vid mode ixNb) -> do
debugGL $ glBindVertexArray vid
debugGL $ glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr