{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, KindSignatures, GeneralizedNewtypeDeriving, PolyKinds #-} module Graphics.Rendering.Ombra.Draw.Internal ( Draw, DrawState, drawState, drawInit, clearBuffers, drawLayer, drawObject, preloadGeometry, preloadTexture, preloadProgram, removeGeometry, removeTexture, removeProgram, textureSize, setProgram, resizeViewport, runDraw, execDraw, evalDraw, gl, drawGet ) where import Data.Proxy import qualified Graphics.Rendering.Ombra.Blend.Internal as Blend import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Geometry.Internal import Graphics.Rendering.Ombra.Layer.Internal hiding (clear) import Graphics.Rendering.Ombra.Object.Internal import Graphics.Rendering.Ombra.Texture.Internal import Graphics.Rendering.Ombra.Backend (GLES) import qualified Graphics.Rendering.Ombra.Backend as GL import Graphics.Rendering.Ombra.Internal.GL hiding (Texture, Program, Buffer, UniformLocation, cullFace, depthMask, colorMask) import qualified Graphics.Rendering.Ombra.Internal.GL as GL import Graphics.Rendering.Ombra.Internal.Resource import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Shader.GLSL import Graphics.Rendering.Ombra.Shader.Program import Graphics.Rendering.Ombra.Shader.ShaderVar import qualified Graphics.Rendering.Ombra.Stencil.Internal as Stencil import Graphics.Rendering.Ombra.Vector import Data.Hashable (Hashable) import Data.Word (Word8) import Control.Monad (when) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.State -- | The state of the 'Draw' monad. data DrawState = DrawState { currentProgram :: Maybe ProgramIndex, loadedProgram :: Maybe LoadedProgram, programs :: ResMap LoadedProgram, uniforms :: ResMap UniformLocation, elemBuffers :: ResMap LoadedBuffer, attributes :: ResMap LoadedAttribute, geometries :: ResMap LoadedGeometry, textureImages :: ResMap LoadedTexture, activeTextures :: Int, viewportSize :: (Int, Int), blendMode :: Maybe Blend.Mode, stencilMode :: Maybe Stencil.Mode, cullFace :: Maybe CullFace, depthTest :: Bool, depthMask :: Bool, colorMask :: (Bool, Bool, Bool, Bool) } newtype UniformLocation = UniformLocation GL.UniformLocation -- | A state monad on top of 'GL'. newtype Draw a = Draw { unDraw :: StateT DrawState GL a } deriving (Functor, Applicative, Monad, MonadIO) instance EmbedIO Draw where embedIO f (Draw a) = Draw get >>= Draw . lift . embedIO f . evalStateT a -- | Create a 'DrawState'. drawState :: GLES => Int -- ^ Viewport width -> Int -- ^ Viewport height -> IO DrawState drawState w h = do programs <- newGLResMap elemBuffers <- newGLResMap attributes <- newGLResMap geometries <- newDrawResMap uniforms <- newGLResMap textureImages <- newGLResMap return DrawState { currentProgram = Nothing , loadedProgram = Nothing , programs = programs , elemBuffers = elemBuffers , attributes = attributes , geometries = geometries , uniforms = uniforms , textureImages = textureImages , activeTextures = 0 , viewportSize = (w, h) , blendMode = Nothing , depthTest = True , depthMask = True , stencilMode = Nothing , cullFace = Nothing , colorMask = (True, True, True, True) } where newGLResMap :: IO (ResMap r) newGLResMap = newResMap newDrawResMap :: IO (ResMap r) newDrawResMap = newResMap -- | Initialize the render engine. drawInit :: GLES => Draw () drawInit = viewportSize <$> Draw get >>= \(w, h) -> gl $ do clearColor 0.0 0.0 0.0 1.0 enable gl_DEPTH_TEST depthFunc gl_LESS viewport 0 0 (fromIntegral w) (fromIntegral h) {- maxTexs :: (Integral a, GLES) => a maxTexs = fromIntegral gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS -} -- | Run a 'Draw' action. runDraw :: Draw a -> DrawState -> GL (a, DrawState) runDraw (Draw a) = runStateT a -- | Execute a 'Draw' action. execDraw :: Draw a -- ^ Action. -> DrawState -- ^ State. -> GL DrawState execDraw (Draw a) = execStateT a -- | Evaluate a 'Draw' action. evalDraw :: Draw a -- ^ Action. -> DrawState -- ^ State. -> GL a evalDraw (Draw a) = evalStateT a -- | Viewport. resizeViewport :: GLES => Int -- ^ Width. -> Int -- ^ Height. -> Draw () resizeViewport w h = do gl $ viewport 0 0 (fromIntegral w) (fromIntegral h) Draw . modify $ \s -> s { viewportSize = (w, h) } clearBuffers :: GLES => [Buffer] -> Draw () clearBuffers = mapM_ $ gl . clear . buffer where buffer ColorBuffer = gl_COLOR_BUFFER_BIT buffer DepthBuffer = gl_DEPTH_BUFFER_BIT buffer StencilBuffer = gl_STENCIL_BUFFER_BIT -- | Manually allocate a 'Geometry' in the GPU. preloadGeometry :: GLES => Geometry is -> Draw () preloadGeometry g = () <$ getGeometry g -- | Manually allocate a 'Texture' in the GPU. preloadTexture :: GLES => Texture -> Draw () preloadTexture t = () <$ getTexture t -- | Manually allocate a 'Program' in the GPU. preloadProgram :: GLES => Program gs is -> Draw () preloadProgram p = () <$ getProgram p -- | Manually delete a 'Geometry' from the GPU. Note that if you try to draw it, it will be allocated again. removeGeometry :: GLES => Geometry is -> Draw () removeGeometry g = removeDrawResource id geometries g -- | Manually delete a 'Texture' from the GPU. removeTexture :: GLES => Texture -> Draw () removeTexture (TextureImage i) = removeDrawResource gl textureImages i removeTexture (TextureLoaded l) = gl $ unloadResource (Nothing :: Maybe TextureImage) l -- | Manually delete a 'Program' from the GPU. removeProgram :: GLES => Program gs is -> Draw () removeProgram = removeDrawResource gl programs -- | Draw a 'Layer'. drawLayer :: GLES => Layer' Drawable t a -> Draw a drawLayer = fmap fst . flip drawLayer' [] drawLayer' :: GLES => Layer' s t a -> [TTexture t] -> Draw (a, [TTexture t]) drawLayer' (Layer prg grp) ts = do setProgram prg drawObject grp return ((), ts) drawLayer' (TextureLayer drawBufs stypes (w, h) (rx, ry, rw, rh) inspCol inspDepth layer) tts0 = do (x, tts1, ts, mcol, mdepth) <- layerToTexture drawBufs stypes w h layer (mayInspect inspCol) (mayInspect inspDepth) tts0 let tts2 = map (TTexture . LoadedTexture gw gh) ts return ((x, tts2, mcol, mdepth), tts1 ++ tts2) where (gw, gh) = (fromIntegral w, fromIntegral h) mayInspect :: Bool -> Either (Maybe [r]) ([r] -> Draw (Maybe [r]), Int, Int, Int, Int) mayInspect True = Right (return . Just, rx, ry, rw, rh) mayInspect False = Left Nothing drawLayer' (Permanent tt@(TTexture lt)) tts = do let t = TextureLoaded lt gl $ unloader t (Nothing :: Maybe TextureImage) lt return (t, filter (/= tt) tts) drawLayer' (WithTTextures ets f) tts = do drawLayer . f $ map (\(TTexture lt) -> TextureLoaded lt) ets return ((), tts) drawLayer' (Free layer) tts = do (x, tts') <- drawLayer' layer [] mapM_ (\(TTexture lt) -> removeTexture $ TextureLoaded lt) tts' return (x, tts) drawLayer' (Clear bufs) tts = clearBuffers bufs >> return ((), tts) drawLayer' (Cast layer) tts = do (x, tts') <- drawLayer' layer $ map castTTexture tts return (x, map castTTexture tts') drawLayer' (Bind lx f) tts0 = drawLayer' lx tts0 >>= \(x, tts1) -> drawLayer' (f x) tts1 drawLayer' (Return x) tts = return (x, tts) -- | Draw an 'Object'. drawObject :: GLES => Object gs is -> Draw () drawObject (g :~> o) = withGlobal g $ drawObject o drawObject (Mesh g) = withRes_ (getGeometry g) drawGeometry drawObject NoMesh = return () drawObject (Prop p o) = withObjProp p $ drawObject o drawObject (Append o o') = drawObject o >> drawObject o' withObjProp :: GLES => ObjProp -> Draw a -> Draw a withObjProp (Blend m) a = stateReset blendMode setBlendMode m a withObjProp (Stencil m) a = stateReset stencilMode setStencilMode m a withObjProp (DepthTest d) a = stateReset depthTest setDepthTest d a withObjProp (DepthMask d) a = stateReset depthMask setDepthMask d a withObjProp (ColorMask d) a = stateReset colorMask setColorMask d a withObjProp (Cull face) a = stateReset cullFace setCullFace face a stateReset :: (DrawState -> a) -> (a -> Draw ()) -> a -> Draw b -> Draw b stateReset getOld set new act = do old <- getOld <$> Draw get set new b <- act set old return b withGlobal :: GLES => Global g -> Draw () -> Draw () withGlobal (Single g c) a = uniform (Proxy :: Proxy 'S) (g undefined) c >> a withGlobal (Mirror g c) a = uniform (Proxy :: Proxy 'M) (varBuild (const undefined) g) c >> a withGlobal (WithTexture t gf) a = withActiveTexture t $ flip withGlobal a . gf withGlobal (WithTextureSize t gf) a = textureSize t >>= flip withGlobal a . gf withGlobal (WithFramebufferSize gf) a = viewportSize <$> drawGet >>= flip withGlobal a . gf where tupleToVec (x, y) = Vec2 (fromIntegral x) (fromIntegral y) uniform :: (GLES, ShaderVar g, Uniform s g) => proxy (s :: CPUSetterType *) -> g -> CPU s g -> Draw () uniform p g c = withUniforms p g c $ \n ug uc -> withRes_ (getUniform $ uniformName g n) $ \(UniformLocation l) -> gl $ setUniform l ug uc withActiveTexture :: GLES => Texture -> (ActiveTexture -> Draw ()) -> Draw () withActiveTexture tex f = withRes (getTexture tex) (return ()) $ \(LoadedTexture _ _ wtex) -> makeActive tex $ \at -> do gl $ bindTexture gl_TEXTURE_2D wtex f at makeActive :: GLES => Texture -> (ActiveTexture -> Draw a) -> Draw a makeActive t f = do atn <- activeTextures <$> Draw get Draw . modify $ \ds -> ds { activeTextures = atn + 1 } gl . activeTexture $ gl_TEXTURE0 + fromIntegral atn ret <- f . ActiveTexture . fromIntegral $ atn Draw . modify $ \ds -> ds { activeTextures = atn } return ret -- | Get the dimensions of a 'Texture'. textureSize :: (GLES, Num a) => Texture -> Draw (a, a) textureSize tex = withRes (getTexture tex) (return (0, 0)) $ \(LoadedTexture w h _) -> return ( fromIntegral w , fromIntegral h) -- | Set the program. setProgram :: GLES => Program g i -> Draw () setProgram p = do current <- currentProgram <$> Draw get when (current /= Just (programIndex p)) $ withRes_ (getProgram p) $ \lp@(LoadedProgram glp _ _) -> do Draw . modify $ \s -> s { currentProgram = Just $ programIndex p, loadedProgram = Just lp, activeTextures = 0 } gl $ useProgram glp withRes_ :: Draw (Either String a) -> (a -> Draw ()) -> Draw () withRes_ drs = withRes drs $ return () withRes :: Draw (Either String a) -> Draw b -> (a -> Draw b) -> Draw b withRes drs u l = drs >>= \rs -> case rs of Right r -> l r _ -> u getUniform :: GLES => String -> Draw (Either String UniformLocation) getUniform name = do mprg <- loadedProgram <$> Draw get case mprg of Just prg -> getDrawResource gl uniforms (prg, name) Nothing -> return $ Left "No loaded program." getGeometry :: GLES => Geometry is -> Draw (Either String LoadedGeometry) getGeometry = getDrawResource id geometries getTexture :: GLES => Texture -> Draw (Either String LoadedTexture) getTexture (TextureLoaded l) = return $ Right l getTexture (TextureImage t) = getTextureImage t getTextureImage :: GLES => TextureImage -> Draw (Either String LoadedTexture) getTextureImage = getDrawResource gl textureImages getProgram :: GLES => Program gs is -> Draw (Either String LoadedProgram) getProgram = getDrawResource gl programs -- | Draw a 'Layer' on some textures. layerToTexture :: (GLES, Integral a) => Bool -- ^ Draw buffers -> [LayerType] -- ^ Textures contents -> a -- ^ Width -> a -- ^ Height -> Layer' s t x -- ^ Layer to draw -> Either b ( [Color] -> Draw b , Int, Int, Int, Int) -- ^ Color inspecting -- function, start x, -- start y, width, -- height -> Either c ( [Word8] -> Draw c , Int, Int, Int, Int) -- ^ Depth inspecting, -- function, etc. -> [TTexture t] -> Draw (x, [TTexture t], [GL.Texture], b ,c) layerToTexture drawBufs stypes wp hp layer einspc einspd tts = do (ts, (x, tts', colRes, depthRes)) <- renderToTexture drawBufs (map arguments stypes) w h $ do (x, tts') <- drawLayer' layer tts colRes <- inspect einspc gl_RGBA wordsToColors 4 depthRes <- inspect einspd gl_DEPTH_COMPONENT id 1 return (x, tts', colRes, depthRes) return (x, tts', ts, colRes, depthRes) where (w, h) = (fromIntegral wp, fromIntegral hp) arguments stype = case stype of ColorLayer -> ( fromIntegral gl_RGBA , gl_RGBA , gl_UNSIGNED_BYTE , gl_COLOR_ATTACHMENT0 , [ColorBuffer] ) DepthLayer -> ( fromIntegral gl_DEPTH_COMPONENT , gl_DEPTH_COMPONENT , gl_UNSIGNED_SHORT , gl_DEPTH_ATTACHMENT , [DepthBuffer] ) DepthStencilLayer -> ( fromIntegral gl_DEPTH_STENCIL , gl_DEPTH_STENCIL , gl_UNSIGNED_INT_24_8 , gl_DEPTH_STENCIL_ATTACHMENT , [ DepthBuffer , StencilBuffer] ) BufferLayer n -> ( fromIntegral gl_RGBA32F , gl_RGBA , gl_FLOAT , gl_COLOR_ATTACHMENT0 + fromIntegral n , [] ) inspect :: Either c (a -> Draw c, Int, Int, Int, Int) -> GLEnum -> ([Word8] -> a) -> Int -> Draw c inspect (Left r) _ _ _ = return r inspect (Right (insp, x, y, rw, rh)) format trans s = do arr <- liftIO . newByteArray $ fromIntegral rw * fromIntegral rh * s gl $ readPixels (fromIntegral x) (fromIntegral y) (fromIntegral rw) (fromIntegral rh) format gl_UNSIGNED_BYTE arr liftIO (decodeBytes arr) >>= insp . trans wordsToColors (r : g : b : a : xs) = Color r g b a : wordsToColors xs wordsToColors _ = [] renderToTexture :: GLES => Bool -> [(GLInt, GLEnum, GLEnum, GLEnum, [Buffer])] -> GLSize -> GLSize -> Draw a -> Draw ([GL.Texture], a) renderToTexture drawBufs infos w h act = do fb <- gl createFramebuffer gl $ bindFramebuffer gl_FRAMEBUFFER fb (ts, attchs, buffersToClear) <- fmap unzip3 . gl . flip mapM infos $ \(internalFormat, format, pixelType, attachment, buffer) -> do t <- emptyTexture (Linear, Nothing) Linear bindTexture gl_TEXTURE_2D t if pixelType == gl_FLOAT then liftIO noFloat32Array >>= texImage2DFloat gl_TEXTURE_2D 0 internalFormat w h 0 format pixelType else liftIO noUInt8Array >>= texImage2DUInt gl_TEXTURE_2D 0 internalFormat w h 0 format pixelType framebufferTexture2D gl_FRAMEBUFFER attachment gl_TEXTURE_2D t 0 return (t, fromIntegral attachment, buffer) let buffersToDraw = filter (/= fromIntegral gl_DEPTH_ATTACHMENT) attchs when drawBufs $ liftIO (encodeInts buffersToDraw) >>= gl . drawBuffers (sw, sh) <- viewportSize <$> Draw get resizeViewport (fromIntegral w) (fromIntegral h) clearBuffers $ concat buffersToClear ret <- act resizeViewport sw sh gl $ deleteFramebuffer fb return (ts, ret) setBlendMode :: GLES => Maybe Blend.Mode -> Draw () setBlendMode Nothing = do m <- blendMode <$> Draw get case m of Just _ -> gl $ disable gl_BLEND Nothing -> return () Draw . modify $ \s -> s { blendMode = Nothing } setBlendMode (Just newMode) = do mOldMode <- blendMode <$> Draw get case mOldMode of Nothing -> do gl $ enable gl_BLEND changeColor >> changeEquation >> changeFunction Just oldMode -> do when (Blend.constantColor oldMode /= constantColor) changeColor when (Blend.equation oldMode /= equation) changeEquation when (Blend.function oldMode /= function) changeFunction Draw . modify $ \s -> s { blendMode = Just newMode } where constantColor = Blend.constantColor newMode equation@(rgbEq, alphaEq) = Blend.equation newMode function@(rgbs, rgbd, alphas, alphad) = Blend.function newMode changeColor = case constantColor of Just (Vec4 r g b a) -> gl $ blendColor r g b a Nothing -> return () changeEquation = gl $ blendEquationSeparate rgbEq alphaEq changeFunction = gl $ blendFuncSeparate rgbs rgbd alphas alphad setStencilMode :: GLES => Maybe Stencil.Mode -> Draw () setStencilMode Nothing = do m <- stencilMode <$> Draw get case m of Just _ -> gl $ disable gl_STENCIL_TEST Nothing -> return () Draw . modify $ \s -> s { stencilMode = Nothing } setStencilMode (Just newMode@(Stencil.Mode newFun newOp)) = do mOldMode <- stencilMode <$> Draw get case mOldMode of Nothing -> do gl $ enable gl_STENCIL_TEST sides newFun changeFunction sides newOp changeOperation Just (Stencil.Mode oldFun oldOp) -> do when (oldFun /= newFun) $ sides newFun changeFunction when (oldOp /= newOp) $ sides newOp changeOperation Draw . modify $ \s -> s { stencilMode = Just newMode } where changeFunction face f = let (t, v, m) = Stencil.function f in gl $ stencilFuncSeparate face t v m changeOperation face o = let (s, d, n) = Stencil.operation o in gl $ stencilOpSeparate face s d n sides (Stencil.FrontBack x) f = f gl_FRONT_AND_BACK x sides (Stencil.Separate x y) f = f gl_FRONT x >> f gl_BACK y setCullFace :: GLES => Maybe CullFace -> Draw () setCullFace Nothing = do old <- cullFace <$> Draw get case old of Just _ -> gl $ disable gl_CULL_FACE Nothing -> return () Draw . modify $ \s -> s { cullFace = Nothing } setCullFace (Just newFace) = do old <- cullFace <$> Draw get when (old == Nothing) . gl $ enable gl_CULL_FACE case old of Just oldFace | oldFace == newFace -> return () _ -> gl . GL.cullFace $ case newFace of CullFront -> gl_FRONT CullBack -> gl_BACK CullFrontBack -> gl_FRONT_AND_BACK Draw . modify $ \s -> s { cullFace = Just newFace } setDepthTest :: GLES => Bool -> Draw () setDepthTest = setFlag depthTest (\x s -> s { depthTest = x }) (gl $ enable gl_DEPTH_TEST) (gl $ disable gl_DEPTH_TEST) setDepthMask :: GLES => Bool -> Draw () setDepthMask = setFlag depthMask (\x s -> s { depthMask = x }) (gl $ GL.depthMask true) (gl $ GL.depthMask false) setFlag :: (DrawState -> Bool) -> (Bool -> DrawState -> DrawState) -> Draw () -> Draw () -> Bool -> Draw () setFlag getF setF enable disable new = do old <- getF <$> Draw get case (old, new) of (False, True) -> enable (True, False) -> disable _ -> return () Draw . modify $ setF new setColorMask :: GLES => (Bool, Bool, Bool, Bool) -> Draw () setColorMask new@(r, g, b, a) = do old <- colorMask <$> Draw get when (old /= new) . gl $ GL.colorMask r' g' b' a' Draw . modify $ \s -> s { colorMask = new } where (r', g', b', a') = (bool r, bool g, bool b, bool a) bool True = true bool False = false getDrawResource :: Resource i r m => (m (Either String r) -> Draw (Either String r)) -> (DrawState -> ResMap r) -> i -> Draw (Either String r) getDrawResource lft mg i = do map <- mg <$> Draw get lft $ getResource i map removeDrawResource :: (Resource i r m, Hashable i) => (m () -> Draw ()) -> (DrawState -> ResMap r) -> i -> Draw () removeDrawResource lft mg i = do s <- mg <$> Draw get lft $ removeResource i s drawGeometry :: GLES => LoadedGeometry -> Draw () drawGeometry (LoadedGeometry ec vao) = currentProgram <$> Draw get >>= \mcp -> case mcp of Just _ -> gl $ do bindVertexArray vao drawElements gl_TRIANGLES (fromIntegral ec) gl_UNSIGNED_SHORT nullGLPtr bindVertexArray noVAO Nothing -> return () instance GLES => Resource (LoadedProgram, String) UniformLocation GL where loadResource (LoadedProgram prg _ _, g) = do loc <- getUniformLocation prg $ toGLString g return . Right $ UniformLocation loc unloadResource _ _ = return () instance GLES => Resource (Geometry is) LoadedGeometry Draw where loadResource = runExceptT . loadGeometry (ExceptT . getDrawResource gl attributes) (ExceptT . getDrawResource gl elemBuffers) (lift . gl) unloadResource _ = gl . deleteGeometry -- | Perform a 'GL' action in the 'Draw' monad. gl :: GL a -> Draw a gl = Draw . lift -- | Get the 'DrawState'. drawGet :: Draw DrawState drawGet = Draw get