module FWGL.Graphics.Draw (
Draw,
DrawState,
execDraw,
drawInit,
drawBegin,
drawLayer,
drawEnd,
textureUniform,
textureSize,
setProgram,
resize
) where
import FWGL.Geometry
import FWGL.Graphics.Shapes
import FWGL.Graphics.Types
import FWGL.Graphics.Texture
import FWGL.Backend.IO
import FWGL.Internal.GL hiding (Texture, Program, UniformLocation)
import qualified FWGL.Internal.GL as GL
import FWGL.Internal.Resource
import FWGL.Shader.CPU
import FWGL.Shader.GLSL
import FWGL.Shader.Program hiding (program)
import FWGL.Vector
import Data.Bits ((.|.))
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as H
import Data.Typeable
import Data.Word (Word)
import Control.Applicative
import Control.Monad (when)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
drawInit :: (BackendIO, GLES) => Int -> Int -> GL DrawState
drawInit w h = do enable gl_DEPTH_TEST
enable gl_BLEND
blendFunc gl_SRC_ALPHA gl_ONE_MINUS_SRC_ALPHA
clearColor 0.0 0.0 0.0 1.0
depthFunc gl_LESS
resize w h
return DrawState { program = Nothing
, loadedProgram = Nothing
, programs = newGLResMap
, gpuMeshes = newGLResMap
, uniforms = newGLResMap
, textureImages = newGLResMap }
where newGLResMap :: (Hashable i, Resource i r GL) => ResMap i r
newGLResMap = newResMap
execDraw :: Draw () -> DrawState -> GL DrawState
execDraw (Draw a) = execStateT a
resize :: GLES => Int -> Int -> GL ()
resize w h = viewport 0 0 (fromIntegral w) (fromIntegral h)
drawBegin :: GLES => Draw ()
drawBegin = gl . clear $ gl_COLOR_BUFFER_BIT .|. gl_DEPTH_BUFFER_BIT
drawEnd :: GLES => Draw ()
drawEnd = return ()
drawLayer :: (GLES, BackendIO) => Layer -> Draw ()
drawLayer (Layer prg obj) = setProgram prg >> drawObject obj
drawLayer (SubLayer w' h' sub sup) =
do t <- renderTexture w h sub
mapM_ drawLayer $ sup (TextureLoaded $ LoadedTexture w h t)
gl $ deleteTexture t
where w = fromIntegral w'
h = fromIntegral h'
drawObject :: (GLES, BackendIO) => Object gs is -> Draw ()
drawObject ObjectEmpty = return ()
drawObject (ObjectMesh m) = drawMesh m
drawObject (ObjectGlobal g c o) = c >>= uniform g >> drawObject o
drawObject (ObjectAppend o o') = drawObject o >> drawObject o'
drawMesh :: GLES => Mesh is -> Draw ()
drawMesh Empty = return ()
drawMesh Cube = drawMesh (StaticGeom cubeGeometry)
drawMesh (StaticGeom g) = withRes_ (getGPUGeometry $ castGeometry g)
drawGPUGeometry
drawMesh (DynamicGeom _ _) = error "drawMesh DynamicGeom: unsupported"
uniform :: (GLES, Typeable g, UniformCPU c g) => g -> c -> Draw ()
uniform g c = withRes_ (getUniform g)
$ \(UniformLocation l) -> gl $ setUniform l g c
textureUniform :: (GLES, BackendIO) => Texture -> Draw ActiveTexture
textureUniform tex = do withRes_ (getTexture tex)
$ \(LoadedTexture _ _ wtex) ->
gl $ do activeTexture gl_TEXTURE0
bindTexture gl_TEXTURE_2D wtex
return $ ActiveTexture 0
textureSize :: (GLES, BackendIO, Num a) => Texture -> Draw (a, a)
textureSize tex = withRes (getTexture tex) (return (0, 0))
$ \(LoadedTexture w h _) -> return ( fromIntegral w
, fromIntegral h)
setProgram :: GLES => Program g i -> Draw ()
setProgram p = do current <- program <$> Draw get
when (current /= Just (castProgram p)) $
withRes_ (getProgram $ castProgram p) $
\lp@(LoadedProgram glp _ _) -> do
Draw . modify $ \s -> s {
program = Just $ castProgram p,
loadedProgram = Just lp
}
gl $ useProgram glp
withRes_ :: Draw (ResStatus a) -> (a -> Draw ()) -> Draw ()
withRes_ drs = withRes drs $ return ()
withRes :: Draw (ResStatus a) -> Draw b -> (a -> Draw b) -> Draw b
withRes drs u l = drs >>= \rs -> case rs of
Loaded r -> l r
_ -> u
getUniform :: (Typeable a, GLES) => a -> Draw (ResStatus UniformLocation)
getUniform g = do mprg <- loadedProgram <$> Draw get
case mprg of
Just prg ->
getDrawResource gl uniforms
(\ m s -> s { uniforms = m })
(prg, globalName g)
Nothing -> return $ Error "No loaded program."
getGPUGeometry :: GLES => Geometry '[] -> Draw (ResStatus GPUGeometry)
getGPUGeometry = getDrawResource gl gpuMeshes (\ m s -> s { gpuMeshes = m })
getTexture :: (GLES, BackendIO) => Texture -> Draw (ResStatus LoadedTexture)
getTexture (TextureLoaded l) = return $ Loaded l
getTexture (TextureImage t) = getTextureImage t
getTextureImage :: (GLES, BackendIO) => TextureImage
-> Draw (ResStatus LoadedTexture)
getTextureImage = getDrawResource gl textureImages
(\ m s -> s { textureImages = m })
getProgram :: GLES => Program '[] '[] -> Draw (ResStatus LoadedProgram)
getProgram = getDrawResource gl programs (\ m s -> s { programs = m })
renderTexture :: (GLES, BackendIO) => GLSize -> GLSize
-> Layer -> Draw GL.Texture
renderTexture w h layer = do
fb <- gl createFramebuffer
t <- gl emptyTexture
gl $ do arr <- liftIO $ noArray
bindTexture gl_TEXTURE_2D t
texImage2DBuffer gl_TEXTURE_2D 0 (fromIntegral gl_RGBA) w
h 0 gl_RGBA
gl_UNSIGNED_BYTE arr
bindFramebuffer gl_FRAMEBUFFER fb
framebufferTexture2D gl_FRAMEBUFFER
gl_COLOR_ATTACHMENT0
gl_TEXTURE_2D t 0
drawBegin
drawLayer layer
drawEnd
gl $ deleteFramebuffer fb
return t
getDrawResource :: (Resource i r m, Hashable i)
=> (m (ResStatus r, ResMap i r)
-> Draw (ResStatus r, ResMap i r))
-> (DrawState -> ResMap i r)
-> (ResMap i r -> DrawState -> DrawState)
-> i
-> Draw (ResStatus r)
getDrawResource lft mg ms i = do
s <- Draw get
(r, map) <- lft . getResource i $ mg s
Draw . put $ ms map s
return r
drawGPUGeometry :: GLES => GPUGeometry -> Draw ()
drawGPUGeometry (GPUGeometry abs eb ec) =
loadedProgram <$> Draw get >>= \mlp -> case mlp of
Nothing -> return ()
Just (LoadedProgram _ locs _) -> gl $ do
bindBuffer gl_ARRAY_BUFFER noBuffer
enabledLocs <- mapM (\(nm, buf, setAttr) ->
let loc = locs H.! nm in
do bindBuffer gl_ARRAY_BUFFER
buf
enableVertexAttribArray $
fromIntegral loc
setAttr $ fromIntegral loc
return loc
) abs
bindBuffer gl_ELEMENT_ARRAY_BUFFER eb
drawElements gl_TRIANGLES (fromIntegral ec)
gl_UNSIGNED_SHORT nullGLPtr
bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer
mapM_ (disableVertexAttribArray . fromIntegral)
enabledLocs
bindBuffer gl_ARRAY_BUFFER noBuffer
instance GLES => Resource (LoadedProgram, String) UniformLocation GL where
loadResource (LoadedProgram prg _ _, g) f =
do loc <- getUniformLocation prg $ toGLString g
f . Right $ UniformLocation loc
unloadResource _ _ = return ()
gl :: GL a -> Draw a
gl = Draw . lift