module Graphics.OpenGLES.Core (
GL,
forkGL, stopGL, --destroyGL,
endFrameGL, runGL, --runGLRes
withGL, resetDrawQueue,
glLog, glReadLogs, glLogContents,
glFrameCount, glFlipping, framesize,
glDraw,
DrawMode, drawPoints, drawLines,
drawLineLoop, drawLineStrip,
drawTriangles, triangleStrip, triangleFan,
linesAdjacency, lineStripAdjacency,
trianglesAdjacency, triangleStripAdjacency,
RenderConfig, renderTo,
Shader, vertexShader, fragmentShader, pixelShader,
computeShader, geometryShader,
tessellationEvalS, tessellationCtrlS,
Program, module Data.Typeable,
TransformFeedback(..), ProgramBinary,
glCompile, glValidate,
Uniform, uniform, ($=), UnifVal, UniformAssignment,
Attrib, attrib, normalized, divisor, (&=),
VertexArray, glVA,
VertexAttribute, AttrStruct, SetVertexAttr,
constAttrib,
VertexPicker,
takeFrom,
takeFromInstanced,
takeFromMany,
takeFromMany',
VertexIx,
byIndex,
byIndexInstanced,
byIndices,
byIndices',
byRange
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent (forkOS, ThreadId, myThreadId, killThread)
import Control.Concurrent.Chan
import Control.Exception (catch, SomeException)
import Control.Future
import qualified Data.ByteString as B
import Data.IORef
import Data.Typeable
import qualified Data.Vector.Storable as V
import Foreign
import Foreign.C.String (peekCStringLen)
import Graphics.OpenGLES.Base
import Graphics.OpenGLES.Buffer
import Graphics.OpenGLES.Caps
import Graphics.OpenGLES.Internal
forkGL :: MonadIO m
=> IO Bool
-> GL ()
-> GL ()
-> m ThreadId
forkGL resumeGL suspendGL swapBuffers = liftIO $ forkOS $ do
writeIORef drawOrExit (Just swapBuffers)
resumeGL
putStrLn "bindEGL"
let loop count = do
putStrLn $ "start draw " ++ show count
readChan drawQueue >>= id
loop (count + 1 :: Integer)
catch (loop 0) $ \(e :: SomeException) -> do
glLog $ "Rendering thread terminated: " ++ show e
suspendGL
putStrLn "unbindEGL"
writeIORef drawOrExit (Just (glLog "Fatal lifecycle bug"))
stopGL :: MonadIO m => m ()
stopGL = liftIO $ do
putStrLn "stopGL"
writeIORef drawOrExit Nothing
let waitGLThread = readIORef drawOrExit >>= \case
Just _ -> nop
Nothing -> waitGLThread
waitGLThread
putStrLn "Rendering has stopped."
endFrameGL :: MonadIO m => m ()
endFrameGL = liftIO $ withGL go >>= waitFor >> nop
where go = do
readIORef drawOrExit >>= \case
Just eglSwapBuffer -> do
eglSwapBuffer
modifyIORef frameCounter (+1)
Nothing -> myThreadId >>= killThread
runGL :: MonadIO m => GL () -> m ()
runGL io = liftIO $ writeChan drawQueue io
withGL :: MonadIO m => GL a -> m (Future' a)
withGL io = mkFuture $ \update -> runGL (io >>= update . Finished)
resetDrawQueue :: MonadIO m => m ()
resetDrawQueue = liftIO $ do
isEmpty <- isEmptyChan drawQueue
when (not isEmpty) (readChan drawQueue >> resetDrawQueue)
glReadLogs :: MonadIO m => m [String]
glReadLogs = liftIO $ do
isEmpty <- isEmptyChan errorQueue
if isEmpty
then return []
else (:) <$> readChan errorQueue <*> glReadLogs
glLogContents :: MonadIO m => m [String]
glLogContents = liftIO $ getChanContents errorQueue
nop :: MonadIO m => m ()
nop = return ()
glFrameCount :: MonadIO m => m Int64
glFrameCount = liftIO $ readIORef frameCounter
glFlipping :: MonadIO m => m Bool
glFlipping = fmap odd glFrameCount
framesize :: MonadIO m => Int -> Int -> m ()
framesize w h = runGL $ glViewport 0 0 (f w) (f h)
where f = fromIntegral
glDraw :: Typeable p
=> DrawMode
-> Program p
-> [RenderConfig]
-> [UniformAssignment p]
-> VertexArray p
-> VertexPicker
-> GL Bool
glDraw (DrawMode mode) prog@(Program pobj _ _ _) setState unifs
(VertexArray (vao, setVA)) (VertexPicker picker) = do
glUseProgram =<< getObjId pobj
sequence setState
sequence unifs
case extVAO of
Nothing -> setVA
Just (_, bind, _) -> getObjId vao >>= bind
picker mode
renderTo :: RenderConfig -> GL ()
renderTo = id
drawPoints, drawLines, drawLineLoop, drawLineStrip,
drawTriangles, triangleStrip, triangleFan :: DrawMode
drawPoints = DrawMode 0
drawLines = DrawMode 1
drawLineLoop = DrawMode 2
drawLineStrip = DrawMode 3
drawTriangles = DrawMode 4
triangleStrip = DrawMode 5
triangleFan = DrawMode 6
linesAdjacency = DrawMode 10
lineStripAdjacency = DrawMode 11
trianglesAdjacency = DrawMode 12
triangleStripAdjacency = DrawMode 13
vertexShader, fragmentShader, pixelShader,
computeShader, geometryShader,
tessellationEvalS, tessellationCtrlS
:: GLName -> B.ByteString -> Shader
vertexShader = Shader 0x8B31
fragmentShader = Shader 0x8B30
pixelShader = fragmentShader
computeShader = Shader 0x91B9
geometryShader = Shader 0x8DD9
tessellationEvalS = Shader 0x8E87
tessellationCtrlS = Shader 0x8E88
glCompile
:: Typeable p
=> TransformFeedback
-> [Shader]
-> (Program p -> Int -> String -> Maybe ProgramBinary -> GL ())
-> GL (Progress [String] (Program p))
glCompile tf shaders progressLogger = do
glo <- newIORef undefined
let prog = Program glo tf shaders ([],[])
loadProgram prog (progressLogger prog)
glValidate :: Program p -> GL String
glValidate prog = alloca $ \intptr -> do
pid <- getObjId $ programGLO prog
glValidateProgram pid
glGetProgramiv pid c_info_log_length intptr
len <- fmap fromIntegral $ peek intptr
info <- allocaBytes len $ \buf -> do
glGetProgramInfoLog pid (fromIntegral len) nullPtr buf
peekCStringLen (buf, len1)
glLog $ "validateProgram: " ++ info
return info
type UniformAssignment p = GL ()
uniform
:: forall p a. (UnifVal a, Typeable p)
=> GLName -> IO (Uniform p a)
uniform name = do
desc <- lookupVarDesc typ
case desc of
Nothing -> return $ Uniform (1, 0, nullPtr)
Just (unifs, _) ->
case lookup name unifs of
Just unif -> validateType unif
Nothing -> glLog errmsg >> return (Uniform (1, 0, nullPtr))
where
typ = typeRep (undefined :: Program p)
errmsg = "Uniform not found: " ++ name ++ " (" ++ show typ ++ ")"
validateType (loc, size, gltyp) = do
ptr <- mallocArray (fromIntegral size) :: IO (Ptr Float)
return $ Uniform (loc, size, castPtr ptr)
infix 0 $=
($=) :: UnifVal a => Uniform p a -> a -> UniformAssignment p
Uniform desc $= value = glUniform desc value
attrib
:: forall p a. (VertexAttribute a, Typeable p)
=> GLName -> IO (Attrib p a)
attrib name = do
desc <- lookupVarDesc typ
case desc of
Nothing -> return $ Attrib (1, 0, 0, 0)
Just (_, attrs) ->
case lookup name attrs of
Just attr -> validateType attr
Nothing -> glLog errmsg >> return (Attrib (1, 0, 0, 0))
where
typ = typeRep (undefined :: Program p)
errmsg = "Attribute not found: " ++ name ++ " (" ++ show typ ++ ")"
validateType (loc, size, gltyp) =
return $ Attrib (fromIntegral loc, size, 0, 0)
normalized :: Attrib p a -> Attrib p a
normalized (Attrib (i, s, 0, d)) = Attrib (i, s, 1, d)
normalized _ = error "inapplicable use of 'normalized'"
divisor :: Attrib p a -> Word32 -> Attrib p a
divisor (Attrib (i, s, n, _)) d = Attrib (i, s, n, d)
type SetVertexAttr p = GL ()
infix 0 &=
(&=) :: AttrStruct a p b => a -> Buffer b -> SetVertexAttr p
attribs &= buf = do
bindBuffer array_buffer buf
glVertexBuffer attribs buf
glVA :: [SetVertexAttr p] -> GL (VertexArray p)
glVA attrs = do
let setVA = sequence_ attrs
glo <- case extVAO of
Nothing -> return (error "GLO not used")
Just (gen, bind, del) ->
newGLO gen del (\i -> bind i >> setVA)
return $ VertexArray (glo, setVA)
extVAO :: Maybe (GLsizei -> Ptr GLuint -> GL (),
GLuint -> GL (),
GLsizei -> Ptr GLuint -> GL ())
extVAO
| hasES3 =
Just (glGenVertexArrays, glBindVertexArray, glDeleteVertexArrays)
| hasExt "GL_OES_vertex_array_object" =
Just (glGenVertexArraysOES, glBindVertexArrayOES, glDeleteVertexArraysOES)
| otherwise = Nothing
constAttrib :: VertexAttribute a => Attrib p a -> a -> SetVertexAttr p
constAttrib (Attrib (ix, _, _, _)) val = do
glDisableVertexAttribArray ix
glVertexAttrib ix val
takeFrom :: Int32 -> Int32 -> VertexPicker
takeFrom first count =
VertexPicker $ \mode -> do
glDrawArrays mode first count
showError "glDrawArrays"
takeFromInstanced :: Int32 -> Int32 -> Int32 -> VertexPicker
takeFromInstanced first count numInstances =
VertexPicker $ \mode -> do
glDrawArraysInstanced mode first count numInstances
showError "glDrawArraysInstanced"
takeFromMany :: V.Vector Int32 -> V.Vector Int32 -> VertexPicker
takeFromMany first_ count_ = VertexPicker $ \mode ->
if hasMDA then do
let len = fromIntegral $ min (V.length first_) (V.length count_)
V.unsafeWith first_ $ \first ->
V.unsafeWith count_ $ \count ->
glMultiDrawArraysEXT mode first count len
showError "glMultiDrawArraysEXT"
else do
V.zipWithM_ (go mode) first_ count_
return True
where go mode first count = do
glDrawArrays mode first count
showError "glDrawArrays[]"
takeFromMany' :: [(Int32, Int32)] -> VertexPicker
takeFromMany' xs =
takeFromMany (V.fromList first) (V.fromList count)
where (first, count) = unzip xs
hasMDA = hasExt "GL_EXT_multi_draw_arrays"
sizePtr :: Int32 -> Ptr ()
sizePtr = intPtrToPtr . fromIntegral
byIndex :: VertexIx a => Buffer a -> Int32 -> Int32 -> VertexPicker
byIndex buf first count =
VertexPicker $ \mode -> do
let (typ, stride) = vxix buf
bindBuffer element_array_buffer buf
glDrawElements mode count typ (sizePtr $ first * stride)
showError "glDrawElements"
byIndexInstanced :: VertexIx a => Buffer a -> Int32 -> Int32 -> Int32 -> VertexPicker
byIndexInstanced buf first count instances =
VertexPicker $ \mode -> do
let (typ, stride) = vxix buf
bindBuffer element_array_buffer buf
glDrawElementsInstanced mode count typ
(sizePtr $ first * stride) instances
showError "glDrawElementsInstanced"
byIndices :: VertexIx a => Buffer a -> V.Vector Int32 -> V.Vector Int32 -> VertexPicker
byIndices buf first_ count_ = VertexPicker $ \mode -> do
let (typ, stride) = vxix buf
let offset ix = sizePtr (stride * ix)
bindBuffer element_array_buffer buf
if hasMDA then do
let len = fromIntegral $ min (V.length first_) (V.length count_)
V.unsafeWith first_ $ \first ->
V.unsafeWith count_ $ \count ->
glMultiDrawElementsEXT mode count typ (castPtr first) len
showError "glMultiDrawElementsEXT"
else do
let go mode first count = do
glDrawElements mode count typ (offset first)
showError "glDrawElements[]"
V.zipWithM_ (go mode) first_ count_
return True
byIndices' :: VertexIx a => Buffer a -> [(Int32, Int32)] -> VertexPicker
byIndices' buf xs = do
byIndices buf (V.fromList first) (V.fromList count)
where (first, count) = unzip xs
extDRE =
if hasES3 then
Just glDrawRangeElements
else if hasExt "GL_EXT_draw_range_elements" then
Just glDrawRangeElementsEXT
else Nothing
byRange :: VertexIx a => Buffer a -> Int32 -> Int32 -> Word32 -> Word32 -> VertexPicker
byRange buf first count start end_ = VertexPicker $ \mode -> do
let (typ, stride) = vxix buf
let offset = sizePtr (first * stride)
bindBuffer element_array_buffer buf
case extDRE of
Just glDRE -> do
glDRE mode start end_ count typ offset
showError "glDrawRangeElements[EXT]"
Nothing -> do
glDrawElements mode count typ offset
showError "glDrawElements'"