module LambdaCube.GL.Data 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.Trie as T
import Foreign
import System.IO.Unsafe
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as V
import Graphics.Rendering.OpenGL.Raw.Core32
( GLuint
, glDrawArrays
, glDrawElements
, gl_LINES
, gl_LINES_ADJACENCY
, gl_LINE_STRIP
, gl_LINE_STRIP_ADJACENCY
, gl_POINTS
, gl_TRIANGLES
, gl_TRIANGLES_ADJACENCY
, gl_TRIANGLE_FAN
, gl_TRIANGLE_STRIP
, gl_TRIANGLE_STRIP_ADJACENCY
, glBindBuffer
, glBindVertexArray
, glBufferData
, glBufferSubData
, glGenBuffers
, glGenVertexArrays
, gl_ARRAY_BUFFER
, gl_ELEMENT_ARRAY_BUFFER
, gl_STATIC_DRAW
, glBindTexture
, glGenTextures
, glGenerateMipmap
, glPixelStorei
, glTexImage2D
, glTexSubImage2D
, glTexParameteri
, gl_CLAMP_TO_EDGE
, gl_LINEAR
, gl_LINEAR_MIPMAP_LINEAR
, gl_REPEAT
, gl_RGB
, gl_RGBA
, gl_RGBA8
, gl_TEXTURE_2D
, gl_TEXTURE_BASE_LEVEL
, gl_TEXTURE_MAG_FILTER
, gl_TEXTURE_MAX_LEVEL
, gl_TEXTURE_MIN_FILTER
, gl_TEXTURE_WRAP_S
, gl_TEXTURE_WRAP_T
, gl_UNPACK_ALIGNMENT
, gl_UNSIGNED_BYTE
)
import Data.Word
import Data.Bitmap.Pure
import LambdaCube.GL.Type
import LambdaCube.GL.Util
import LambdaCube.Core.Type
import LambdaCube.Core.DeBruijn
compileBuffer :: [Array] -> IO Buffer
compileBuffer arrs = do
let calcDesc (offset,setters,descs) (Array arrType cnt setter) =
let size = cnt * sizeOfArrayType arrType
in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)
(bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs
bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
glBindBuffer gl_ARRAY_BUFFER bo
glBufferData gl_ARRAY_BUFFER (fromIntegral bufSize) nullPtr gl_STATIC_DRAW
forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
glBindBuffer gl_ARRAY_BUFFER 0
return $! Buffer (V.fromList $! reverse arrDescs) bo
updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
updateBuffer (Buffer arrDescs bo) arrs = do
glBindBuffer gl_ARRAY_BUFFER bo
forM arrs $ \(i,Array arrType cnt setter) -> do
let ArrayDesc ty len offset size = arrDescs V.! i
when (ty == arrType && cnt == len) $
setter $! glBufferSubData gl_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
glBindBuffer gl_ARRAY_BUFFER 0
bufferSize :: Buffer -> Int
bufferSize = V.length . bufArrays
arraySize :: Buffer -> Int -> Int
arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx
arrayType :: Buffer -> Int -> ArrayType
arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx
nullObject :: Object
nullObject = unsafePerformIO $ Object "" T.empty 0 <$> newIORef False
addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
addObject renderer slotName prim objIndices objAttributes objUniforms =
if (not $ T.member slotName $! slotUniform renderer) then do
putStrLn $ "WARNING: unknown slot name: " ++ show slotName
return nullObject
else do
let Just (slotType,sType) = T.lookup slotName $ slotStream renderer
objSType = fmap streamToInputType objAttributes
primType = case prim of
TriangleStrip -> Triangles
TriangleList -> Triangles
TriangleFan -> Triangles
LineStrip -> Lines
LineList -> Lines
PointList -> Points
TriangleStripAdjacency -> TrianglesAdjacency
TriangleListAdjacency -> TrianglesAdjacency
LineStripAdjacency -> LinesAdjacency
LineListAdjacency -> LinesAdjacency
primGL = case prim of
TriangleStrip -> gl_TRIANGLE_STRIP
TriangleList -> gl_TRIANGLES
TriangleFan -> gl_TRIANGLE_FAN
LineStrip -> gl_LINE_STRIP
LineList -> gl_LINES
PointList -> gl_POINTS
TriangleStripAdjacency -> gl_TRIANGLE_STRIP_ADJACENCY
TriangleListAdjacency -> gl_TRIANGLES_ADJACENCY
LineStripAdjacency -> gl_LINE_STRIP_ADJACENCY
LineListAdjacency -> gl_LINES_ADJACENCY
streamCounts = [c | Stream _ _ _ _ c <- T.elems objAttributes]
count = head $ streamCounts ++ error "streamCounts"
when (slotType /= primType) $ fail $ "addObject: primitive type mismatch: " ++ show (slotType,primType)
when (objSType /= sType) $ fail $ unlines
[ "addObject: attribute mismatch"
, "expected:"
, " " ++ show sType
, "actual:"
, " " ++ show objSType
]
when (L.null streamCounts) $ fail "addObject: missing stream attribute, a least one stream attribute is required!"
when (L.or [c /= count | c <- streamCounts]) $ fail "addObject: streams should have the same length!"
(iSetup,draw) <- case objIndices of
Nothing -> return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0") >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER 0,
putStrLn_ ("OBJ: glDrawArrays " ++ show prim ++ " 0 " ++ show count) >> glDrawArrays primGL 0 (fromIntegral count))
Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> do
let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx
glType = arrayTypeToGLType arrType
ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
when (notElem arrType [ArrWord8, ArrWord16, ArrWord32]) $ fail "addObject: index type should be unsigned integer type"
return (putStrLn_ ("OBJ: glBindBuffer gl_ELEMENT_ARRAY_BUFFER " ++ show bo) >> glBindBuffer gl_ELEMENT_ARRAY_BUFFER bo,
putStrLn_ ("OBJ: glDrawElements " ++ show prim ++ " " ++ show idxCount ++ " " ++ show arrType ++ " " ++ show ptr) >> glDrawElements primGL (fromIntegral idxCount) glType ptr)
let renderDescriptorMap = renderDescriptor renderer
uniformType = T.fromList $ concat [T.toList t | (_,t) <- T.toList $ slotUniform renderer]
mkUSetup = mkUniformSetup renderer
globalUNames = Set.toList $! (Set.fromList $! T.keys uniformType) Set.\\ (Set.fromList objUniforms)
rendState = renderState renderer
stateIORef <- newIORef True
(mkObjUSetup,objUSetters,_) <- unzip3 <$> (sequence [mkUniformSetter rendState t | n <- objUniforms, t <- maybeToList $ T.lookup n uniformType])
let objUSetterTrie = T.fromList $! zip objUniforms objUSetters
mkDrawAction :: Exp -> IO (GLuint,IO ())
mkDrawAction gp = do
let Just rd = Map.lookup gp renderDescriptorMap
sLocs = streamLocation rd
uLocs = uniformLocation rd
sSetup = sequence_ [ mkSSetter t loc s
| (n,s) <- T.toList objAttributes
, t <- maybeToList $ T.lookup n sType
, loc <- maybeToList $ T.lookup n sLocs
]
globalUSetup = V.sequence_ $ V.fromList
[ mkUS loc
| n <- globalUNames
, let Just mkUS = T.lookup n mkUSetup
, loc <- maybeToList $ T.lookup n uLocs
]
objUSetup = sequence_ [ mkOUS loc
| (n,mkOUS) <- zip objUniforms mkObjUSetup
, loc <- maybeToList $ T.lookup n uLocs
]
vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
glBindVertexArray vao
sSetup
iSetup
let renderFun = readIORef stateIORef >>= \enabled -> when enabled $ do
globalUSetup
putStrLn_ $ "OBJ: globalUSetup"
objUSetup
putStrLn_ $ "OBJ: objUSetup"
putStrLn_ $ "OBJ: glBindVertexArray " ++ show vao
glBindVertexArray vao
draw
return (vao,renderFun)
Just (SlotDescriptor gps objSetRef) = T.lookup slotName (slotDescriptor renderer)
gpList = Set.toList gps
(vaoList,drawList) <- unzip <$> mapM mkDrawAction gpList
objID <- readIORef (objectIDSeed renderer)
modifyIORef (objectIDSeed renderer) (+1)
let obj = Object
{ objectSlotName = slotName
, objectUniformSetter = objUSetterTrie
, objectID = objID
, objectEnabledIORef = stateIORef
}
modifyIORef objSetRef $ \s -> Set.insert obj s
forM_ (zip gpList drawList) $ \(gp,draw) -> do
let Just rd = Map.lookup gp renderDescriptorMap
modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->
let drawMap' = Map.insert obj draw drawMap
in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'
return obj
removeObject :: Renderer -> Object -> IO ()
removeObject rend obj = do
let Just (SlotDescriptor gps objSetRef) = T.lookup (objectSlotName obj) (slotDescriptor rend)
renderDescriptorMap = renderDescriptor rend
modifyIORef objSetRef $ \s -> Set.delete obj s
forM_ (Set.toList gps) $ \gp -> do
let Just rd = Map.lookup gp renderDescriptorMap
modifyIORef (drawObjectsIORef rd) $ \(ObjectSet _ drawMap) ->
let drawMap' = Map.delete obj drawMap
in ObjectSet (sequence_ $ Map.elems drawMap') drawMap'
enableObject :: Object -> Bool -> IO ()
enableObject obj b = writeIORef (objectEnabledIORef obj) b
compileTexture2DRGBAF :: Bool -> Bool -> Bitmap Word8 -> IO TextureData
compileTexture2DRGBAF isMip isClamped bitmap = do
glPixelStorei gl_UNPACK_ALIGNMENT 1
to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
glBindTexture gl_TEXTURE_2D to
let (width,height) = bitmapSize bitmap
wrapMode = case isClamped of
True -> gl_CLAMP_TO_EDGE
False -> gl_REPEAT
(minFilter,maxLevel) = case isMip of
False -> (gl_LINEAR,0)
True -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
let internalFormat = fromIntegral gl_RGBA8
dataFormat = fromIntegral $ case nchn of
3 -> gl_RGB
4 -> gl_RGBA
_ -> error "unsupported texture format!"
glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr
when isMip $ glGenerateMipmap gl_TEXTURE_2D
return $ TextureData to
updateTexture2DRGBAF :: TextureData -> Bool -> Bitmap Word8 -> IO ()
updateTexture2DRGBAF tx isMip bitmap = do
glPixelStorei gl_UNPACK_ALIGNMENT 1
let to = textureObject tx
glBindTexture gl_TEXTURE_2D to
withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
let internalFormat = fromIntegral gl_RGBA8
dataFormat = fromIntegral $ case nchn of
3 -> gl_RGB
4 -> gl_RGBA
_ -> error "unsupported texture format!"
glTexSubImage2D gl_TEXTURE_2D 0 0 0 (fromIntegral w) (fromIntegral h) dataFormat gl_UNSIGNED_BYTE $ castPtr ptr
when isMip $ glGenerateMipmap gl_TEXTURE_2D
putStrLn_ :: String -> IO ()
putStrLn_ _ = return ()