From 64e13239772dae2a73e30bd0aa8ca2c70154987c Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 8 Jan 2016 12:01:39 +0100 Subject: move to LambdaCube.GL, use more descriptive names, update for OpenGLRaw 3.0 --- src/LambdaCube/GL/Backend.hs | 814 +++++++++++++++++++++++++++++++++++++++++++ src/LambdaCube/GL/Data.hs | 113 ++++++ src/LambdaCube/GL/Input.hs | 390 +++++++++++++++++++++ src/LambdaCube/GL/Mesh.hs | 218 ++++++++++++ src/LambdaCube/GL/Type.hs | 541 ++++++++++++++++++++++++++++ src/LambdaCube/GL/Util.hs | 719 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 2795 insertions(+) create mode 100644 src/LambdaCube/GL/Backend.hs create mode 100644 src/LambdaCube/GL/Data.hs create mode 100644 src/LambdaCube/GL/Input.hs create mode 100644 src/LambdaCube/GL/Mesh.hs create mode 100644 src/LambdaCube/GL/Type.hs create mode 100644 src/LambdaCube/GL/Util.hs (limited to 'src/LambdaCube/GL') diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs new file mode 100644 index 0000000..7251a78 --- /dev/null +++ b/src/LambdaCube/GL/Backend.hs @@ -0,0 +1,814 @@ +{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-} +module LambdaCube.GL.Backend where + +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Bits +import Data.ByteString.Char8 (ByteString,pack) +import Data.IORef +import Data.IntMap (IntMap) +import Data.Maybe (isNothing,fromJust) +import Data.Map (Map) +import Data.Set (Set) +import Data.Trie as T +import Data.Trie.Convenience as T +import Data.Vector (Vector,(!),(//)) +import qualified Data.ByteString.Char8 as SB +import qualified Data.Foldable as F +import qualified Data.IntMap as IM +import qualified Data.Map as Map +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Vector as V +import qualified Data.Vector.Storable as SV + +import Graphics.GL.Core33 +import Foreign + +-- LC IR imports +import Linear +import IR hiding (streamType) +import qualified IR as IR + +import LambdaCube.GL.Type +import LambdaCube.GL.Util + +import LambdaCube.GL.Data +import LambdaCube.GL.Input + +setupRasterContext :: RasterContext -> IO () +setupRasterContext = cvt + where + cff :: FrontFace -> GLenum + cff CCW = GL_CCW + cff CW = GL_CW + + setProvokingVertex :: ProvokingVertex -> IO () + setProvokingVertex pv = glProvokingVertex $ case pv of + FirstVertex -> GL_FIRST_VERTEX_CONVENTION + LastVertex -> GL_LAST_VERTEX_CONVENTION + + setPointSize :: PointSize -> IO () + setPointSize ps = case ps of + ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE + PointSize s -> do + glDisable GL_PROGRAM_POINT_SIZE + glPointSize $ realToFrac s + + cvt :: RasterContext -> IO () + cvt (PointCtx ps fts sc) = do + setPointSize ps + glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts) + glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of + LowerLeft -> GL_LOWER_LEFT + UpperLeft -> GL_UPPER_LEFT + + cvt (LineCtx lw pv) = do + glLineWidth (realToFrac lw) + setProvokingVertex pv + + cvt (TriangleCtx cm pm po pv) = do + -- cull mode + case cm of + CullNone -> glDisable GL_CULL_FACE + CullFront f -> do + glEnable GL_CULL_FACE + glCullFace GL_FRONT + glFrontFace $ cff f + CullBack f -> do + glEnable GL_CULL_FACE + glCullFace GL_BACK + glFrontFace $ cff f + + -- polygon mode + case pm of + PolygonPoint ps -> do + setPointSize ps + glPolygonMode GL_FRONT_AND_BACK GL_POINT + PolygonLine lw -> do + glLineWidth (realToFrac lw) + glPolygonMode GL_FRONT_AND_BACK GL_LINE + PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL + + -- polygon offset + glDisable GL_POLYGON_OFFSET_POINT + glDisable GL_POLYGON_OFFSET_LINE + glDisable GL_POLYGON_OFFSET_FILL + case po of + NoOffset -> return () + Offset f u -> do + glPolygonOffset (realToFrac f) (realToFrac u) + glEnable $ case pm of + PolygonPoint _ -> GL_POLYGON_OFFSET_POINT + PolygonLine _ -> GL_POLYGON_OFFSET_LINE + PolygonFill -> GL_POLYGON_OFFSET_FILL + + -- provoking vertex + setProvokingVertex pv + +setupAccumulationContext :: AccumulationContext -> IO () +setupAccumulationContext (AccumulationContext n ops) = cvt ops + where + cvt :: [FragmentOperation] -> IO () + cvt (StencilOp a b c : DepthOp f m : xs) = do + -- TODO + cvtC 0 xs + cvt (StencilOp a b c : xs) = do + -- TODO + cvtC 0 xs + cvt (DepthOp df dm : xs) = do + -- TODO + glDisable GL_STENCIL_TEST + case df == Always && dm == False of + True -> glDisable GL_DEPTH_TEST + False -> do + glEnable GL_DEPTH_TEST + glDepthFunc $! comparisonFunctionToGLType df + glDepthMask (cvtBool dm) + cvtC 0 xs + cvt xs = do + glDisable GL_DEPTH_TEST + glDisable GL_STENCIL_TEST + cvtC 0 xs + + cvtC :: Int -> [FragmentOperation] -> IO () + cvtC i (ColorOp b m : xs) = do + -- TODO + case b of + NoBlending -> do + -- FIXME: requires GL 3.1 + --glDisablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i + glDisable GL_BLEND -- workaround + glDisable GL_COLOR_LOGIC_OP + BlendLogicOp op -> do + glDisable GL_BLEND + glEnable GL_COLOR_LOGIC_OP + glLogicOp $ logicOperationToGLType op + Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do + glDisable GL_COLOR_LOGIC_OP + -- FIXME: requires GL 3.1 + --glEnablei GL_BLEND $ fromIntegral GL_DRAW_BUFFER0 + fromIntegral i + glEnable GL_BLEND -- workaround + glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq) + glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF) + (blendingFactorToGLType saF) (blendingFactorToGLType daF) + glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) + let cvt True = 1 + cvt False = 0 + (mr,mg,mb,ma) = case m of + VBool r -> (cvt r, 1, 1, 1) + VV2B (V2 r g) -> (cvt r, cvt g, 1, 1) + VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1) + VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a) + _ -> (1,1,1,1) + glColorMask mr mg mb ma + cvtC (i + 1) xs + cvtC _ [] = return () + + cvtBool :: Bool -> GLboolean + cvtBool True = 1 + cvtBool False = 0 + +clearRenderTarget :: [ClearImage] -> IO () +clearRenderTarget values = do + let setClearValue (m,i) value = case value of + ClearImage Depth (VFloat v) -> do + glDepthMask 1 + glClearDepth $ realToFrac v + return (m .|. GL_DEPTH_BUFFER_BIT, i) + ClearImage Stencil (VWord v) -> do + glClearStencil $ fromIntegral v + return (m .|. GL_STENCIL_BUFFER_BIT, i) + ClearImage Color c -> do + let (r,g,b,a) = case c of + VFloat r -> (realToFrac r, 0, 0, 1) + VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1) + VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1) + VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a) + _ -> (0,0,0,1) + glColorMask 1 1 1 1 + glClearColor r g b a + return (m .|. GL_COLOR_BUFFER_BIT, i+1) + _ -> error "internal error (clearRenderTarget)" + (mask,_) <- foldM setClearValue (0,0) values + glClear $ fromIntegral mask + + +printGLStatus = checkGL >>= print +printFBOStatus = checkFBO >>= print + +compileProgram :: Trie InputType -> Program -> IO GLProgram +compileProgram uniTrie p = do + po <- glCreateProgram + putStrLn $ "compile program: " ++ show po + let createAndAttach src t = do + o <- glCreateShader t + compileShader o $ map pack [src] + glAttachShader po o + putStr " + compile shader source: " >> printGLStatus + return o + + objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of + Nothing -> [] + Just s -> [createAndAttach s GL_GEOMETRY_SHADER] + + forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter (pack -> n) t,i) -> SB.useAsCString n $ \pn -> do + putStrLn ("variable " ++ show n ++ " attached to color number #" ++ show i) + glBindFragDataLocation po i $ castPtr pn + putStr " + setup shader output mapping: " >> printGLStatus + + glLinkProgram po + printProgramLog po + + -- check link status + status <- glGetProgramiv1 GL_LINK_STATUS po + when (status /= fromIntegral GL_TRUE) $ fail "link program failed!" + + -- check program input + (uniforms,uniformsType) <- queryUniforms po + (attributes,attributesType) <- queryStreams po + print uniforms + print attributes + let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p) + lcStreams = fmap ty (toTrie $ programStreams p) + check a m = and $ map go $ T.toList m + where go (k,b) = case T.lookup k a of + Nothing -> False + Just x -> x == b + unless (check lcUniforms uniformsType) $ do + putStrLn $ "expected: " ++ show lcUniforms + putStrLn $ "actual: " ++ show uniformsType + fail "shader program uniform input mismatch!" + unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) + -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input + let inUniNames = toTrie $ programUniforms p + inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms + inTextureNames = toTrie $ programInTextures p + inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms + texUnis = [n | (n,_) <- inTextures, T.member n uniTrie] + putStrLn $ "uniTrie: " ++ show (T.keys uniTrie) + putStrLn $ "inUniNames: " ++ show inUniNames + putStrLn $ "inUniforms: " ++ show inUniforms + putStrLn $ "inTextureNames: " ++ show inTextureNames + putStrLn $ "inTextures: " ++ show inTextures + putStrLn $ "texUnis: " ++ show texUnis + let valA = T.toList $ attributes + valB = T.toList $ toTrie $ programStreams p + putStrLn "------------" + print $ T.toList $ attributes + print $ T.toList $ toTrie $ programStreams p + let lcStreamName = fmap name (toTrie $ programStreams p) + return $ GLProgram + { shaderObjects = objs + , programObject = po + , inputUniforms = T.fromList inUniforms + , inputTextures = T.fromList inTextures + , inputTextureUniforms = S.fromList $ texUnis + , inputStreams = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName] + } + +compileSampler :: SamplerDescriptor -> IO GLSampler +compileSampler s = return $ GLSampler {} -- TODO + +compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget +compileRenderTarget texs glTexs (RenderTarget targets) = do + let isFB (Framebuffer _) = True + isFB _ = False + images = [img | TargetItem _ (Just img) <- V.toList targets] + case all isFB images of + True -> do + let bufs = [cvt img | TargetItem Color img <- V.toList targets] + cvt a = case a of + Nothing -> GL_NONE + Just (Framebuffer Color) -> GL_BACK_LEFT + _ -> error "internal error (compileRenderTarget)!" + return $ GLRenderTarget + { framebufferObject = 0 + , framebufferDrawbuffers = Just bufs + } + False -> do + when (any isFB images) $ fail "internal error (compileRenderTarget)!" + fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo + glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo + {- + void glFramebufferTexture1D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); + GL_TEXTURE_1D + void glFramebufferTexture2D(GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level); + GL_TEXTURE_2D + GL_TEXTURE_RECTANGLE + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + GL_TEXTURE_2D_MULTISAMPLE + void glFramebufferTextureLayer(GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer); + void glFramebufferRenderbuffer(GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer); + void glFramebufferTexture(GLenum target, GLenum attachment, GLuint texture, GLint level); + -} + let attach attachment (TextureImage texIdx level (Just layer)) = + glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer) + attach attachment (TextureImage texIdx level Nothing) = do + let glTex = glTexs ! texIdx + tex = texs ! texIdx + txLevel = fromIntegral level + txTarget = glTextureTarget glTex + txObj = glTextureObject glTex + attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel + attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel + case textureType tex of + Texture1D _ n + | n > 1 -> attachArray + | otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel + Texture2D _ n + | n > 1 -> attachArray + | otherwise -> attach2D + Texture3D _ -> attachArray + TextureCube _ -> attachArray + TextureRect _ -> attach2D + Texture2DMS _ n _ _ + | n > 1 -> attachArray + | otherwise -> attach2D + TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!" + + go a (TargetItem Stencil (Just img)) = do + fail "Stencil support is not implemented yet!" + return a + go a (TargetItem Depth (Just img)) = do + attach GL_DEPTH_ATTACHMENT img + return a + go (bufs,colorIdx) (TargetItem Color (Just img)) = do + let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx + attach attachment img + return (attachment : bufs, colorIdx + 1) + go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1) + go a _ = return a + (bufs,_) <- foldM go ([],0) targets + withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs) + return $ GLRenderTarget + { framebufferObject = fbo + , framebufferDrawbuffers = Nothing + } + +compileStreamData :: StreamData -> IO GLStream +compileStreamData s = do + let withV w a f = w a (\p -> f $ castPtr p) + let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v) + compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v) + compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v) + --TODO: compileAttr (VBoolArray v) = Array ArrWord32 (length v) (withV withArray v) + (indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s] + getLength n = l `div` c + where + l = case Map.lookup n $ IR.streamData s of + Just (VFloatArray v) -> V.length v + Just (VIntArray v) -> V.length v + Just (VWordArray v) -> V.length v + _ -> error "compileStreamData - getLength" + c = case Map.lookup n $ IR.streamType s of + Just Bool -> 1 + Just V2B -> 2 + Just V3B -> 3 + Just V4B -> 4 + Just Word -> 1 + Just V2U -> 2 + Just V3U -> 3 + Just V4U -> 4 + Just Int -> 1 + Just V2I -> 2 + Just V3I -> 3 + Just V4I -> 4 + Just Float -> 1 + Just V2F -> 2 + Just V3F -> 3 + Just V4F -> 4 + Just M22F -> 4 + Just M23F -> 6 + Just M24F -> 8 + Just M32F -> 6 + Just M33F -> 9 + Just M34F -> 12 + Just M42F -> 8 + Just M43F -> 12 + Just M44F -> 16 + _ -> error "compileStreamData - getLength element count" + buffer <- compileBuffer arrays + cmdRef <- newIORef [] + let toStream (n,i) = (n,Stream + { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s) + , streamBuffer = buffer + , streamArrIdx = i + , streamStart = 0 + , streamLength = getLength n + }) + return $ GLStream + { glStreamCommands = cmdRef + , glStreamPrimitive = case streamPrimitive s of + Points -> PointList + Lines -> LineList + Triangles -> TriangleList + LinesAdjacency -> LineListAdjacency + TrianglesAdjacency -> TriangleListAdjacency + , glStreamAttributes = toTrie $ Map.fromList $ map toStream indexMap + , glStreamProgram = V.head $ streamPrograms s + } + +createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] +createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] + where + -- object draw command + drawCmd = GLDrawArrays prim 0 (fromIntegral count) + where + prim = primitiveToGLType primitive + count = head [c | Stream _ _ _ _ c <- T.elems attrs] + + -- object uniform commands + -- texture slot setup commands + streamUniCmds = uniCmds ++ texCmds + where + uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] + uniMap = T.toList $ inputUniforms prg + topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis + texUnis = S.toList $ inputTextureUniforms prg + texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u + | n <- texUnis + , let u = topUni n + , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap + ] + uniInputType (GLUniform ty _) = ty + + -- object attribute stream commands + streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs] + where + attrMap = inputStreams prg + attrCmd i s = case s of + Stream ty (Buffer arrs bo) arrIdx start len -> case ty of + Attribute_Word -> setIntAttrib 1 + Attribute_V2U -> setIntAttrib 2 + Attribute_V3U -> setIntAttrib 3 + Attribute_V4U -> setIntAttrib 4 + Attribute_Int -> setIntAttrib 1 + Attribute_V2I -> setIntAttrib 2 + Attribute_V3I -> setIntAttrib 3 + Attribute_V4I -> setIntAttrib 4 + Attribute_Float -> setFloatAttrib 1 + Attribute_V2F -> setFloatAttrib 2 + Attribute_V3F -> setFloatAttrib 3 + Attribute_V4F -> setFloatAttrib 4 + Attribute_M22F -> setFloatAttrib 4 + Attribute_M23F -> setFloatAttrib 6 + Attribute_M24F -> setFloatAttrib 8 + Attribute_M32F -> setFloatAttrib 6 + Attribute_M33F -> setFloatAttrib 9 + Attribute_M34F -> setFloatAttrib 12 + Attribute_M42F -> setFloatAttrib 8 + Attribute_M43F -> setFloatAttrib 12 + Attribute_M44F -> setFloatAttrib 16 + where + setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) + setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) + ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx + glType = arrayTypeToGLType arrType + ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) + + -- constant generic attribute + constAttr -> GLSetVertexAttrib i constAttr + +allocRenderer :: Pipeline -> IO GLRenderer +allocRenderer p = do + let uniTrie = uniforms $ schemaFromPipeline p + smps <- V.mapM compileSampler $ samplers p + texs <- V.mapM compileTexture $ textures p + trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p + prgs <- V.mapM (compileProgram uniTrie) $ programs p + -- texture unit mapping ioref trie + -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) + texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p) + let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState + input <- newIORef Nothing + -- default Vertex Array Object + vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao + strs <- V.mapM compileStreamData $ streams p + return $ GLRenderer + { glPrograms = prgs + , glTextures = texs + , glSamplers = smps + , glTargets = trgs + , glCommands = cmds + , glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p + , glInput = input + , glSlotNames = V.map (pack . slotName) $ IR.slots p + , glVAO = vao + , glTexUnitMapping = texUnitMapRefs + , glStreams = strs + } + +disposeRenderer :: GLRenderer -> IO () +disposeRenderer p = do + setStorage' p Nothing + V.forM_ (glPrograms p) $ \prg -> do + glDeleteProgram $ programObject prg + mapM_ glDeleteShader $ shaderObjects prg + let targets = glTargets p + withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets) + let textures = glTextures p + withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures) + with (glVAO p) $ (glDeleteVertexArrays 1) + +{- +data SlotSchema + = SlotSchema + { primitive :: FetchPrimitive + , attributes :: Trie StreamType + } + deriving Show + +data PipelineSchema + = PipelineSchema + { slots :: Trie SlotSchema + , uniforms :: Trie InputType + } + deriving Show +-} +isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool +isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset] + where + isMember a Nothing = False + isMember a (Just b) = eqFun a b + +-- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms +{- + let sch = schema input + forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of + Nothing -> throw $ userError $ "Unknown uniform: " ++ show n + _ -> return () + case T.lookup slotName (slots sch) of + Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName + Just (SlotSchema sPrim sAttrs) -> do + when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ + "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim + let sType = fmap streamToStreamType attribs + when (sType /= sAttrs) $ throw $ userError $ unlines $ + [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " + , show sAttrs + , " but got " + , show sType + ] +-} + +setStorage :: GLRenderer -> GLStorage -> IO (Maybe String) +setStorage p input' = setStorage' p (Just input') + +setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String) +setStorage' p input' = do + -- TODO: check matching input schema + {- + case input' of + Nothing -> return () + Just input -> schemaFromPipeline p + -} + {- + deletion: + - remove pipeline's object commands from used slots + - remove pipeline from attached pipelines vector + -} + ic' <- readIORef $ glInput p + case ic' of + Nothing -> return () + Just ic -> do + let idx = icId ic + oldInput = icInput ic + slotMask = icSlotMapPipelineToInput ic + slotRefs = slotVector oldInput + modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)] + V.forM_ slotMask $ \slotIdx -> do + slot <- readIORef (slotRefs ! slotIdx) + forM_ (IM.elems $ objectMap slot) $ \obj -> do + modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)] + {- + addition: + - get an id from pipeline input + - add to attached pipelines + - generate slot mappings + - update used slots, and generate object commands for objects in the related slots + -} + case input' of + Nothing -> writeIORef (glInput p) Nothing >> return Nothing + Just input -> do + let pipelinesRef = pipelines input + oldPipelineV <- readIORef pipelinesRef + (idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of + Nothing -> do + -- we don't have empty space, hence we double the vector size + let len = V.length oldPipelineV + modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)] + return (len,Just len) + Just i -> do + modifyIORef pipelinesRef $ \v -> v // [(i,Just p)] + return (i,Nothing) + -- create input connection + let sm = slotMap input + pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm] + iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) + writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP + + -- generate object commands for related slots + {- + for each slot in pipeline: + map slot name to input slot name + for each object: + generate command program vector => for each dependent program: + generate object commands + -} + let slotV = slotVector input + progV = glPrograms p + texUnitMap = glTexUnitMapping p + topUnis = uniformSetup input + emptyV = V.replicate (V.length progV) [] + extend v = case shouldExtend of + Nothing -> v + Just l -> V.concat [v,V.replicate l V.empty] + V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do + slot <- readIORef $ slotV ! slotIdx + forM_ (IM.elems $ objectMap slot) $ \obj -> do + let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs] + modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)] + -- generate stream commands + V.forM_ (glStreams p) $ \s -> do + writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s) + return Nothing +{- + track state: + - render target + - binded textures +-} + +{- + render steps: + - update uniforms + - per uniform setup + - buffer setup (one buffer per object, which has per at least one object uniform) + - new command: set uniform buffer (binds uniform buffer to program's buffer slot) + - render slot steps: + - set uniform buffer or set uniforms separately + - set vertex and index array + - call draw command +-} +{- + storage alternatives: + - interleaved / separated + - VAO or VBOs +-} + {- + strategy: + step 1: generate commands for an object + step 2: sort object merge and do optimization by filtering redundant commands + -} +{- + design: + runtime eleminiation of redundant buffer bind commands and redundant texture bind commands +-} +{- + track: + buffer binding on various targets: GL_ARRAY_BUFFER, GL_ELEMENT_ARRAY_BUFFER + glEnable/DisableVertexAttribArray +-} +renderSlot :: [GLObjectCommand] -> IO () +renderSlot cmds = forM_ cmds $ \cmd -> do + case cmd of + GLSetVertexAttribArray idx buf size typ ptr -> do + glBindBuffer GL_ARRAY_BUFFER buf + glEnableVertexAttribArray idx + glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr + GLSetVertexAttribIArray idx buf size typ ptr -> do + glBindBuffer GL_ARRAY_BUFFER buf + glEnableVertexAttribArray idx + glVertexAttribIPointer idx size typ 0 ptr + GLDrawArrays mode first count -> glDrawArrays mode first count + GLDrawElements mode count typ buf indicesPtr -> do + glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf + glDrawElements mode count typ indicesPtr + GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref + GLBindTexture txTarget tuRef (GLUniform _ ref) -> do + txObjVal <- readIORef ref + -- HINT: ugly and hacky + with txObjVal $ \txObjPtr -> do + txObj <- peek $ castPtr txObjPtr :: IO GLuint + texUnit <- readIORef tuRef + glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit + glBindTexture txTarget txObj + putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj + GLSetVertexAttrib idx val -> do + glDisableVertexAttribArray idx + setVertexAttrib idx val + isOk <- checkGL + putStrLn $ SB.unpack isOk ++ " - " ++ show cmd + +renderFrame :: GLRenderer -> IO () +renderFrame glp = do + glBindVertexArray (glVAO glp) + forM_ (glCommands glp) $ \cmd -> do + case cmd of + GLSetRasterContext rCtx -> setupRasterContext rCtx + GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx + GLSetRenderTarget rt bufs -> do + -- set target viewport + --when (rt == 0) $ do -- screen out + ic' <- readIORef $ glInput glp + case ic' of + Nothing -> return () + Just ic -> do + let input = icInput ic + (w,h) <- readIORef $ screenSize input + glViewport 0 0 (fromIntegral w) (fromIntegral h) + -- TODO: set FBO target viewport + glBindFramebuffer GL_DRAW_FRAMEBUFFER rt + case bufs of + Nothing -> return () + Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl) + GLSetProgram p -> glUseProgram p + GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu + GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx + GLClearRenderTarget vals -> clearRenderTarget vals + GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target + GLRenderStream streamIdx progIdx -> do + renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx) + GLRenderSlot slotIdx progIdx -> do + input <- readIORef (glInput glp) + case input of + Nothing -> putStrLn "Warning: No pipeline input!" >> return () + Just ic -> do + GLSlot _ objs _ <- readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) + --putStrLn $ "Rendering " ++ show (V.length objs) ++ " objects" + V.forM_ objs $ \(_,obj) -> do + enabled <- readIORef $ objEnabled obj + when enabled $ do + cmd <- readIORef $ objCommands obj + --putStrLn "Render object" + renderSlot ((cmd ! icId ic) ! progIdx) + {- + GLSetSampler + GLSaveImage + GLLoadImage + -} + isOk <- checkGL + putStrLn $ SB.unpack isOk ++ " - " ++ show cmd + +data CGState + = CGState + { currentProgram :: ProgramName + , textureBinding :: IntMap GLTexture + , samplerUniforms :: Map UniformName TextureUnit + } + +initCGState = CGState + { currentProgram = error "CGState: empty currentProgram" + , textureBinding = IM.empty + , samplerUniforms = mempty + } + +type CG a = State CGState a + +compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand +compileCommand texUnitMap samplers textures targets programs cmd = case cmd of + SetRasterContext rCtx -> return $ GLSetRasterContext rCtx + SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx + SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs + SetProgram p -> do + modify (\s -> s {currentProgram = p}) + return $ GLSetProgram $ programObject $ programs ! p + SetSamplerUniform n tu -> do + modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms}) + p <- currentProgram <$> get + case T.lookup (pack n) (inputTextures $ programs ! p) of + Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd + Just i -> case T.lookup (pack n) texUnitMap of + Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd + Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r + SetTexture tu t -> do + let tex = textures ! t + modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s}) + return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex) +{- + SetSampler tu s -> liftIO $ do + glBindSampler (fromIntegral tu) (samplerObject $ glSamplers glp ! s) +-} + RenderSlot slot -> do + smpUnis <- samplerUniforms <$> get + p <- currentProgram <$> get + return $ GLRenderSlot slot p + RenderStream stream -> do + p <- currentProgram <$> get + return $ GLRenderStream stream p + ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals + GenerateMipMap tu -> do + tb <- textureBinding <$> get + case IM.lookup tu tb of + Nothing -> fail "internal error (GenerateMipMap)!" + Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) +{- + SaveImage _ _ -> undefined + LoadImage _ _ -> undefined +-} diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs new file mode 100644 index 0000000..231da8b --- /dev/null +++ b/src/LambdaCube/GL/Data.hs @@ -0,0 +1,113 @@ +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 qualified Data.IntMap as IM +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as V +import qualified Data.Vector.Storable as SV + +--import Control.DeepSeq + +import Graphics.GL.Core33 +import Data.Word +import Codec.Picture +import Codec.Picture.Types + +import LambdaCube.GL.Type +import LambdaCube.GL.Util + +-- Buffer +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 + +-- Texture + +-- FIXME: Temporary implemenation +uploadTexture2DToGPU :: DynamicImage -> IO TextureData +uploadTexture2DToGPU = uploadTexture2DToGPU' False True False + +uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData +uploadTexture2DToGPU' isSRGB isMip isClamped bitmap' = do + let bitmap = case bitmap' of + ImageRGB8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGB8 r g b) -> [PixelRGBA8 r g b maxBound]) i + ImageRGBA8 i@(Image w h _) -> bitmap' -- pixelFoldMap (\(PixelRGBA8 r g b a) -> [PixelRGBA8 r g b a]) i + ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i -- $ Image w h $ SV.fromList $ pixelFoldMap (\p -> let PixelRGB8 r g b = convertPixel p in [PixelRGBA8 r g b maxBound]) i + ImageCMYK16 _ -> error "uploadTexture2DToGPU: ImageCMYK16" + ImageCMYK8 _ -> error "uploadTexture2DToGPU: ImageCMYK8" + ImageRGBA16 _ -> error "uploadTexture2DToGPU: ImageRGBA16" + ImageRGBF _ -> error "uploadTexture2DToGPU: ImageRGBF" + ImageRGB16 _ -> error "uploadTexture2DToGPU: ImageRGB16" + ImageYA16 _ -> error "uploadTexture2DToGPU: ImageYA16" + ImageYA8 _ -> error "uploadTexture2DToGPU: ImageYA8" + ImageYF _ -> error "uploadTexture2DToGPU: ImageYF" + ImageY16 _ -> error "uploadTexture2DToGPU: ImageY16" + ImageY8 _ -> error "uploadTexture2DToGPU: ImageY8" + _ -> error "uploadTexture2DToGPU: unknown image" + + glPixelStorei GL_UNPACK_ALIGNMENT 1 + to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + glBindTexture GL_TEXTURE_2D to + let (width,height) = bitmapSize bitmap + bitmapSize (ImageRGB8 (Image w h _)) = (w,h) + bitmapSize (ImageRGBA8 (Image w h _)) = (w,h) + bitmapSize _ = error "unsupported image type :(" + withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0 + withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0 + withBitmap _ _ = error "unsupported image type :(" + 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 $ if isSRGB then (if nchn == 3 then GL_SRGB8 else GL_SRGB8_ALPHA8) else (if nchn == 3 then GL_RGB8 else 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 diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs new file mode 100644 index 0000000..aabf0e6 --- /dev/null +++ b/src/LambdaCube/GL/Input.hs @@ -0,0 +1,390 @@ +module LambdaCube.GL.Input where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.ByteString.Char8 (ByteString,pack) +import Data.IORef +import Data.IntMap (IntMap) +import Data.Trie (Trie) +import Data.Trie.Convenience as T +import Data.Vector (Vector,(//),(!)) +import Data.Word +import Foreign +import qualified Data.ByteString.Char8 as SB +import qualified Data.IntMap as IM +import qualified Data.Set as S +import qualified Data.Map as Map +import qualified Data.Trie as T +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as I + +import Graphics.GL.Core33 + +import IR as IR +import Linear as IR +import LambdaCube.GL.Type as T +import LambdaCube.GL.Util + +import qualified IR as IR + +schemaFromPipeline :: IR.Pipeline -> PipelineSchema +schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul) + where + (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams))) + , toTrie sUniforms + ) + | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a + ] + cvt a = case toStreamType a of + Just v -> v + Nothing -> error "internal error (schemaFromPipeline)" + +mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform) +mkUniform l = do + unisAndSetters <- forM l $ \(n,t) -> do + (uni, setter) <- mkUniformSetter t + return ((n,uni),(n,setter)) + let (unis,setters) = unzip unisAndSetters + return (T.fromList setters, T.fromList unis) + +allocStorage :: PipelineSchema -> IO GLStorage +allocStorage sch = do + let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..] + len = T.size sm + (setters,unis) <- mkUniform $ T.toList $ uniforms sch + seed <- newIORef 0 + slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) + size <- newIORef (0,0) + ppls <- newIORef $ V.singleton Nothing + return $ GLStorage + { schema = sch + , slotMap = sm + , slotVector = slotV + , objSeed = seed + , uniformSetter = setters + , uniformSetup = unis + , screenSize = size + , pipelines = ppls + } + +disposeStorage :: GLStorage -> IO () +disposeStorage = error "not implemented: disposeStorage" + +-- object +addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object +addObject input slotName prim indices attribs uniformNames = do + let sch = schema input + forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of + Nothing -> throw $ userError $ "Unknown uniform: " ++ show n + _ -> return () + case T.lookup slotName (T.slots sch) of + Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName + Just (SlotSchema sPrim sAttrs) -> do + when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ + "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim + let sType = fmap streamToStreamType attribs + when (sType /= sAttrs) $ throw $ userError $ unlines $ + [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " + , show sAttrs + , " but got " + , show sType + ] + + let slotIdx = case slotName `T.lookup` slotMap input of + Nothing -> error $ "internal error (slot index): " ++ show slotName + Just i -> i + seed = objSeed input + order <- newIORef 0 + enabled <- newIORef True + index <- readIORef seed + modifyIORef seed (1+) + (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)] + cmdsRef <- newIORef (V.singleton V.empty) + let obj = Object + { objSlot = slotIdx + , objPrimitive = prim + , objIndices = indices + , objAttributes = attribs + , objUniSetter = setters + , objUniSetup = unis + , objOrder = order + , objEnabled = enabled + , objId = index + , objCommands = cmdsRef + } + + modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate + + -- generate GLObjectCommands for the new object + {- + foreach pipeline: + foreach realted program: + generate commands + -} + ppls <- readIORef $ pipelines input + let topUnis = uniformSetup input + cmds <- V.forM ppls $ \mp -> case mp of + Nothing -> return V.empty + Just p -> do + Just ic <- readIORef $ glInput p + case icSlotMapInputToPipeline ic ! slotIdx of + Nothing -> do + putStrLn $ " ** slot is not used!" + return V.empty -- this slot is not used in that pipeline + Just pSlotIdx -> do + putStrLn "slot is used!" + --where + let emptyV = V.replicate (V.length $ glPrograms p) [] + return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx] + writeIORef cmdsRef cmds + return obj + +removeObject :: GLStorage -> Object -> IO () +removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate + +enableObject :: Object -> Bool -> IO () +enableObject obj b = writeIORef (objEnabled obj) b + +setObjectOrder :: GLStorage -> Object -> Int -> IO () +setObjectOrder p obj i = do + writeIORef (objOrder obj) i + modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder + +objectUniformSetter :: Object -> Trie InputSetter +objectUniformSetter = objUniSetter + +setScreenSize :: GLStorage -> Word -> Word -> IO () +setScreenSize p w h = writeIORef (screenSize p) (w,h) + +sortSlotObjects :: GLStorage -> IO () +sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do + GLSlot objMap sortedV ord <- readIORef slotRef + let cmpFun (a,_) (b,_) = a `compare` b + doSort objs = do + ordObjsM <- V.thaw objs + I.sortBy cmpFun ordObjsM + ordObjs <- V.freeze ordObjsM + writeIORef slotRef (GLSlot objMap ordObjs Ordered) + case ord of + Ordered -> return () + Generate -> do + objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do + ord <- readIORef $ objOrder obj + return (ord,obj) + doSort objs + Reorder -> do + objs <- V.forM sortedV $ \(_,obj) -> do + ord <- readIORef $ objOrder obj + return (ord,obj) + doSort objs + +createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand] +createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd] + where + -- object draw command + objDrawCmd = case objIndices obj of + Nothing -> GLDrawArrays prim 0 (fromIntegral count) + Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr + where + ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx + idxType = arrayTypeToGLType arrType + ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) + where + objAttrs = objAttributes obj + prim = primitiveToGLType $ objPrimitive obj + count = head [c | Stream _ _ _ _ c <- T.elems objAttrs] + + -- object uniform commands + -- texture slot setup commands + objUniCmds = uniCmds ++ texCmds + where + uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis] + uniMap = T.toList $ inputUniforms prg + topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis + objUnis = objUniSetup obj + texUnis = S.toList $ inputTextureUniforms prg + texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u + | n <- texUnis + , let u = T.lookupWithDefault (topUni n) n objUnis + , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap + ] + uniInputType (GLUniform ty _) = ty + + -- object attribute stream commands + objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs] + where + attrMap = inputStreams prg + objAttrs = objAttributes obj + attrCmd i s = case s of + Stream ty (Buffer arrs bo) arrIdx start len -> case ty of + Attribute_Word -> setIntAttrib 1 + Attribute_V2U -> setIntAttrib 2 + Attribute_V3U -> setIntAttrib 3 + Attribute_V4U -> setIntAttrib 4 + Attribute_Int -> setIntAttrib 1 + Attribute_V2I -> setIntAttrib 2 + Attribute_V3I -> setIntAttrib 3 + Attribute_V4I -> setIntAttrib 4 + Attribute_Float -> setFloatAttrib 1 + Attribute_V2F -> setFloatAttrib 2 + Attribute_V3F -> setFloatAttrib 3 + Attribute_V4F -> setFloatAttrib 4 + Attribute_M22F -> setFloatAttrib 4 + Attribute_M23F -> setFloatAttrib 6 + Attribute_M24F -> setFloatAttrib 8 + Attribute_M32F -> setFloatAttrib 6 + Attribute_M33F -> setFloatAttrib 9 + Attribute_M34F -> setFloatAttrib 12 + Attribute_M42F -> setFloatAttrib 8 + Attribute_M43F -> setFloatAttrib 12 + Attribute_M44F -> setFloatAttrib 16 + where + setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n) + setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n) + ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx + glType = arrayTypeToGLType arrType + ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType) + + -- constant generic attribute + constAttr -> GLSetVertexAttrib i constAttr + +nullSetter :: ByteString -> String -> a -> IO () +--nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t +nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t + +uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool +uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B +uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B +uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B + +uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32 +uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U +uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U +uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U + +uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32 +uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I +uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I +uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I + +uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float +uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F +uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F +uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F + +uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F +uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F +uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F +uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F +uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F +uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F +uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F +uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F +uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F + +uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData + +uniformBool n is = case T.lookup n is of + Just (SBool fun) -> fun + _ -> nullSetter n "Bool" + +uniformV2B n is = case T.lookup n is of + Just (SV2B fun) -> fun + _ -> nullSetter n "V2B" + +uniformV3B n is = case T.lookup n is of + Just (SV3B fun) -> fun + _ -> nullSetter n "V3B" + +uniformV4B n is = case T.lookup n is of + Just (SV4B fun) -> fun + _ -> nullSetter n "V4B" + +uniformWord n is = case T.lookup n is of + Just (SWord fun) -> fun + _ -> nullSetter n "Word" + +uniformV2U n is = case T.lookup n is of + Just (SV2U fun) -> fun + _ -> nullSetter n "V2U" + +uniformV3U n is = case T.lookup n is of + Just (SV3U fun) -> fun + _ -> nullSetter n "V3U" + +uniformV4U n is = case T.lookup n is of + Just (SV4U fun) -> fun + _ -> nullSetter n "V4U" + +uniformInt n is = case T.lookup n is of + Just (SInt fun) -> fun + _ -> nullSetter n "Int" + +uniformV2I n is = case T.lookup n is of + Just (SV2I fun) -> fun + _ -> nullSetter n "V2I" + +uniformV3I n is = case T.lookup n is of + Just (SV3I fun) -> fun + _ -> nullSetter n "V3I" + +uniformV4I n is = case T.lookup n is of + Just (SV4I fun) -> fun + _ -> nullSetter n "V4I" + +uniformFloat n is = case T.lookup n is of + Just (SFloat fun) -> fun + _ -> nullSetter n "Float" + +uniformV2F n is = case T.lookup n is of + Just (SV2F fun) -> fun + _ -> nullSetter n "V2F" + +uniformV3F n is = case T.lookup n is of + Just (SV3F fun) -> fun + _ -> nullSetter n "V3F" + +uniformV4F n is = case T.lookup n is of + Just (SV4F fun) -> fun + _ -> nullSetter n "V4F" + +uniformM22F n is = case T.lookup n is of + Just (SM22F fun) -> fun + _ -> nullSetter n "M22F" + +uniformM23F n is = case T.lookup n is of + Just (SM23F fun) -> fun + _ -> nullSetter n "M23F" + +uniformM24F n is = case T.lookup n is of + Just (SM24F fun) -> fun + _ -> nullSetter n "M24F" + +uniformM32F n is = case T.lookup n is of + Just (SM32F fun) -> fun + _ -> nullSetter n "M32F" + +uniformM33F n is = case T.lookup n is of + Just (SM33F fun) -> fun + _ -> nullSetter n "M33F" + +uniformM34F n is = case T.lookup n is of + Just (SM34F fun) -> fun + _ -> nullSetter n "M34F" + +uniformM42F n is = case T.lookup n is of + Just (SM42F fun) -> fun + _ -> nullSetter n "M42F" + +uniformM43F n is = case T.lookup n is of + Just (SM43F fun) -> fun + _ -> nullSetter n "M43F" + +uniformM44F n is = case T.lookup n is of + Just (SM44F fun) -> fun + _ -> nullSetter n "M44F" + +uniformFTexture2D n is = case T.lookup n is of + Just (SFTexture2D fun) -> fun + _ -> nullSetter n "FTexture2D" diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs new file mode 100644 index 0000000..f8a0bb9 --- /dev/null +++ b/src/LambdaCube/GL/Mesh.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE TupleSections #-} +module LambdaCube.GL.Mesh ( + loadMesh', + loadMesh, + saveMesh, + addMeshToObjectArray, + uploadMeshToGPU, + updateMesh, + Mesh(..), + MeshPrimitive(..), + MeshAttribute(..), + GPUData +) where + +import Control.Applicative +import Control.Monad +import Data.Binary +import Data.ByteString.Char8 (ByteString) +import Foreign.Ptr +import Data.Int +import Foreign.Storable +import Foreign.Marshal.Utils +import System.IO.Unsafe +import qualified Data.ByteString.Char8 as SB +import qualified Data.ByteString.Lazy as LB +import qualified Data.Trie as T +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as MV + +import LambdaCube.GL +import LambdaCube.GL.Type as T +import IR as IR +import Linear as IR + +fileVersion :: Int32 +fileVersion = 1 + +data MeshAttribute + = A_Float (V.Vector Float) + | A_V2F (V.Vector V2F) + | A_V3F (V.Vector V3F) + | A_V4F (V.Vector V4F) + | A_M22F (V.Vector M22F) + | A_M33F (V.Vector M33F) + | A_M44F (V.Vector M44F) + | A_Int (V.Vector Int32) + | A_Word (V.Vector Word32) + +data MeshPrimitive + = P_Points + | P_TriangleStrip + | P_Triangles + | P_TriangleStripI (V.Vector Int32) + | P_TrianglesI (V.Vector Int32) + +data Mesh + = Mesh + { mAttributes :: T.Trie MeshAttribute + , mPrimitive :: MeshPrimitive + , mGPUData :: Maybe GPUData + } + +data GPUData + = GPUData + { dPrimitive :: Primitive + , dStreams :: T.Trie (Stream Buffer) + , dIndices :: Maybe (IndexStream Buffer) + } + +loadMesh' :: String -> IO Mesh +loadMesh' n = decode <$> LB.readFile n + +loadMesh :: String -> IO Mesh +loadMesh n = uploadMeshToGPU =<< loadMesh' n + +saveMesh :: String -> Mesh -> IO () +saveMesh n m = LB.writeFile n (encode m) + +addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object +addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do + -- select proper attributes + let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input + filterStream n s + | T.member n slotStreams = Just s + | otherwise = Nothing + addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames +addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" + +withV w a f = w a (\p -> f $ castPtr p) + +meshAttrToArray :: MeshAttribute -> Array +meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v + +meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer +meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v) +meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v) +meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v) +meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v) +meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v) +meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v) +meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v) +meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) +meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) + +updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO () +updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do + -- check type match + let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 + ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA] + if not ok then putStrLn "updateMesh: attribute mismatch!" + else do + forM_ al $ \(n,a) -> do + case T.lookup n dS of + Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] + _ -> return () +{- + case mp of + Nothing -> return () + Just p -> do + let ok2 = case (dMP,p) of + (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2 + (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2 + (a,b) -> a == b +-} + +uploadMeshToGPU :: Mesh -> IO Mesh +uploadMeshToGPU (Mesh attrs mPrim Nothing) = do + let mkIndexBuf v = do + iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] + return $! Just $! IndexStream iBuf 0 0 (V.length v) + vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs] + (indices,prim) <- case mPrim of + P_Points -> return (Nothing,PointList) + P_TriangleStrip -> return (Nothing,TriangleStrip) + P_Triangles -> return (Nothing,TriangleList) + P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v + P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v + let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs) + gpuData = GPUData prim streams indices + return $! Mesh attrs mPrim (Just gpuData) + +uploadMeshToGPU mesh = return mesh + +sblToV :: Storable a => [SB.ByteString] -> V.Vector a +sblToV ls = v + where + offs o (s:xs) = (o,s):offs (o + SB.length s) xs + offs _ [] = [] + cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v) + v = unsafePerformIO $ do + mv <- MV.new cnt + MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) -> + SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len + V.unsafeFreeze mv + +vToSB :: Storable a => V.Vector a -> SB.ByteString +vToSB v = unsafePerformIO $ do + let len = V.length v * sizeOf (V.head v) + V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len) + +instance Storable a => Binary (V.Vector a) where + put v = put $ vToSB v + get = do s <- get ; return $ sblToV [s] + +instance Binary MeshAttribute where + put (A_Float a) = putWord8 0 >> put a + put (A_V2F a) = putWord8 1 >> put a + put (A_V3F a) = putWord8 2 >> put a + put (A_V4F a) = putWord8 3 >> put a + put (A_M22F a) = putWord8 4 >> put a + put (A_M33F a) = putWord8 5 >> put a + put (A_M44F a) = putWord8 6 >> put a + put (A_Int a) = putWord8 7 >> put a + put (A_Word a) = putWord8 8 >> put a + get = do + tag_ <- getWord8 + case tag_ of + 0 -> A_Float <$> get + 1 -> A_V2F <$> get + 2 -> A_V3F <$> get + 3 -> A_V4F <$> get + 4 -> A_M22F <$> get + 5 -> A_M33F <$> get + 6 -> A_M44F <$> get + 7 -> A_Int <$> get + 8 -> A_Word <$> get + _ -> fail "no parse" + +instance Binary MeshPrimitive where + put P_Points = putWord8 0 + put P_TriangleStrip = putWord8 1 + put P_Triangles = putWord8 2 + put (P_TriangleStripI a) = putWord8 3 >> put a + put (P_TrianglesI a) = putWord8 4 >> put a + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return P_Points + 1 -> return P_TriangleStrip + 2 -> return P_Triangles + 3 -> P_TriangleStripI <$> get + 4 -> P_TrianglesI <$> get + _ -> fail "no parse" + +instance Binary Mesh where + put (Mesh a b _) = put (T.toList a) >> put b + get = do + a <- get + b <- get + return $! Mesh (T.fromList a) b Nothing diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs new file mode 100644 index 0000000..c82a8f0 --- /dev/null +++ b/src/LambdaCube/GL/Type.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +module LambdaCube.GL.Type where + +import Data.ByteString.Char8 (ByteString) +import Data.IORef +import Data.Int +import Data.IntMap (IntMap) +import Data.Set (Set) +import Data.Trie (Trie) +import Data.Vector (Vector) +import Data.Word +import Foreign.Ptr +import Foreign.Storable + +import Graphics.GL.Core33 + +import Linear +import IR + +--------------- +-- Input API -- +--------------- +{- +-- Buffer + compileBuffer :: [Array] -> IO Buffer + bufferSize :: Buffer -> Int + arraySize :: Buffer -> Int -> Int + arrayType :: Buffer -> Int -> ArrayType + +-- Object + addObject :: Renderer -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object + removeObject :: Renderer -> Object -> IO () + objectUniformSetter :: Object -> Trie InputSetter +-} + +data Buffer -- internal type + = Buffer + { bufArrays :: Vector ArrayDesc + , bufGLObj :: GLuint + } + deriving (Show,Eq) + +data ArrayDesc + = ArrayDesc + { arrType :: ArrayType + , arrLength :: Int -- item count + , arrOffset :: Int -- byte position in buffer + , arrSize :: Int -- size in bytes + } + deriving (Show,Eq) + +{- + handles: + uniforms + textures + buffers + objects + + GLStorage can be attached to GLRenderer +-} + +{- + pipeline input: + - independent from pipeline + - per object features: enable/disable visibility, set render ordering +-} + +data SlotSchema + = SlotSchema + { primitive :: FetchPrimitive + , attributes :: Trie StreamType + } + deriving Show + +data PipelineSchema + = PipelineSchema + { slots :: Trie SlotSchema + , uniforms :: Trie InputType + } + deriving Show + +data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a) + +instance Show GLUniform where + show (GLUniform t _) = "GLUniform " ++ show t + +data OrderJob + = Generate + | Reorder + | Ordered + +data GLSlot + = GLSlot + { objectMap :: IntMap Object + , sortedObjects :: Vector (Int,Object) + , orderJob :: OrderJob + } + +data GLStorage + = GLStorage + { schema :: PipelineSchema + , slotMap :: Trie SlotName + , slotVector :: Vector (IORef GLSlot) + , objSeed :: IORef Int + , uniformSetter :: Trie InputSetter + , uniformSetup :: Trie GLUniform + , screenSize :: IORef (Word,Word) + , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines + } + +data Object -- internal type + = Object + { objSlot :: SlotName + , objPrimitive :: Primitive + , objIndices :: Maybe (IndexStream Buffer) + , objAttributes :: Trie (Stream Buffer) + , objUniSetter :: Trie InputSetter + , objUniSetup :: Trie GLUniform + , objOrder :: IORef Int + , objEnabled :: IORef Bool + , objId :: Int + , objCommands :: IORef (Vector (Vector [GLObjectCommand])) -- pipeline id, program name, commands + } + +-------------- +-- Pipeline -- +-------------- + +data GLProgram + = GLProgram + { shaderObjects :: [GLuint] + , programObject :: GLuint + , inputUniforms :: Trie GLint + , inputTextures :: Trie GLint -- all input textures (render texture + uniform texture) + , inputTextureUniforms :: Set ByteString + , inputStreams :: Trie (GLuint,ByteString) + } + +data GLTexture + = GLTexture + { glTextureObject :: GLuint + , glTextureTarget :: GLenum + } + +data InputConnection + = InputConnection + { icId :: Int -- identifier (vector index) for attached pipeline + , icInput :: GLStorage + , icSlotMapPipelineToInput :: Vector SlotName -- GLRenderer to GLStorage slot name mapping + , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLStorage to GLRenderer slot name mapping + } + +data GLStream + = GLStream + { glStreamCommands :: IORef [GLObjectCommand] + , glStreamPrimitive :: Primitive + , glStreamAttributes :: Trie (Stream Buffer) + , glStreamProgram :: ProgramName + } + +data GLRenderer + = GLRenderer + { glPrograms :: Vector GLProgram + , glTextures :: Vector GLTexture + , glSamplers :: Vector GLSampler + , glTargets :: Vector GLRenderTarget + , glCommands :: [GLCommand] + , glSlotPrograms :: Vector [ProgramName] -- programs depend on a slot + , glInput :: IORef (Maybe InputConnection) + , glSlotNames :: Vector ByteString + , glVAO :: GLuint + , glTexUnitMapping :: Trie (IORef GLint) -- maps texture uniforms to texture units + , glStreams :: Vector GLStream + } + +data GLSampler + = GLSampler + { samplerObject :: GLuint + } + +data GLRenderTarget + = GLRenderTarget + { framebufferObject :: GLuint + , framebufferDrawbuffers :: Maybe [GLenum] + } + +data GLCommand + = GLSetRasterContext !RasterContext + | GLSetAccumulationContext !AccumulationContext + | GLSetRenderTarget !GLuint !(Maybe [GLenum]) + | GLSetProgram !GLuint + | GLSetSamplerUniform !GLint !GLint (IORef GLint) -- sampler index, texture unit, IORef stores the actual texture unit mapping + | GLSetTexture !GLenum !GLuint !GLuint + | GLSetSampler !GLuint !GLuint + | GLRenderSlot !SlotName !ProgramName + | GLRenderStream !StreamName !ProgramName + | GLClearRenderTarget [ClearImage] + | GLGenerateMipMap !GLenum !GLenum + | GLSaveImage FrameBufferComponent ImageRef -- from framebuffer component to texture (image) + | GLLoadImage ImageRef FrameBufferComponent -- from texture (image) to framebuffer component + deriving Show + +instance Show (IORef GLint) where + show _ = "(IORef GLint)" + +data GLObjectCommand + = GLSetUniform !GLint !GLUniform + | GLBindTexture !GLenum !(IORef GLint) !GLUniform -- binds the texture from the gluniform to the specified texture unit and target + | GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer + | GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ()) -- index buffer size type pointer + | GLSetVertexAttrib !GLuint !(Stream Buffer) -- index value + | GLDrawArrays !GLenum !GLint !GLsizei -- mode first count + | GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ()) -- mode count type buffer indicesPtr + deriving Show + +type SetterFun a = a -> IO () + +-- user will provide scalar input data via this type +data InputSetter + = SBool (SetterFun Bool) + | SV2B (SetterFun V2B) + | SV3B (SetterFun V3B) + | SV4B (SetterFun V4B) + | SWord (SetterFun Word32) + | SV2U (SetterFun V2U) + | SV3U (SetterFun V3U) + | SV4U (SetterFun V4U) + | SInt (SetterFun Int32) + | SV2I (SetterFun V2I) + | SV3I (SetterFun V3I) + | SV4I (SetterFun V4I) + | SFloat (SetterFun Float) + | SV2F (SetterFun V2F) + | SV3F (SetterFun V3F) + | SV4F (SetterFun V4F) + | SM22F (SetterFun M22F) + | SM23F (SetterFun M23F) + | SM24F (SetterFun M24F) + | SM32F (SetterFun M32F) + | SM33F (SetterFun M33F) + | SM34F (SetterFun M34F) + | SM42F (SetterFun M42F) + | SM43F (SetterFun M43F) + | SM44F (SetterFun M44F) + -- shadow textures + | SSTexture1D + | SSTexture2D + | SSTextureCube + | SSTexture1DArray + | SSTexture2DArray + | SSTexture2DRect + -- float textures + | SFTexture1D + | SFTexture2D (SetterFun TextureData) + | SFTexture3D + | SFTextureCube + | SFTexture1DArray + | SFTexture2DArray + | SFTexture2DMS + | SFTexture2DMSArray + | SFTextureBuffer + | SFTexture2DRect + -- int textures + | SITexture1D + | SITexture2D + | SITexture3D + | SITextureCube + | SITexture1DArray + | SITexture2DArray + | SITexture2DMS + | SITexture2DMSArray + | SITextureBuffer + | SITexture2DRect + -- uint textures + | SUTexture1D + | SUTexture2D + | SUTexture3D + | SUTextureCube + | SUTexture1DArray + | SUTexture2DArray + | SUTexture2DMS + | SUTexture2DMSArray + | SUTextureBuffer + | SUTexture2DRect + +-- buffer handling +{- + user can fills a buffer (continuous memory region) + each buffer have a data descriptor, what describes the + buffer content. e.g. a buffer can contain more arrays of stream types +-} + +-- user will provide stream data using this setup function +type BufferSetter = (Ptr () -> IO ()) -> IO () + +-- specifies array component type (stream type in storage side) +-- this type can be overridden in GPU side, e.g ArrWord8 can be seen as TFloat or TWord also +data ArrayType + = ArrWord8 + | ArrWord16 + | ArrWord32 + | ArrInt8 + | ArrInt16 + | ArrInt32 + | ArrFloat + | ArrHalf -- Hint: half float is not supported in haskell + deriving (Show,Eq,Ord) + +sizeOfArrayType :: ArrayType -> Int +sizeOfArrayType ArrWord8 = 1 +sizeOfArrayType ArrWord16 = 2 +sizeOfArrayType ArrWord32 = 4 +sizeOfArrayType ArrInt8 = 1 +sizeOfArrayType ArrInt16 = 2 +sizeOfArrayType ArrInt32 = 4 +sizeOfArrayType ArrFloat = 4 +sizeOfArrayType ArrHalf = 2 + +-- describes an array in a buffer +data Array -- array type, element count (NOT byte size!), setter + = Array ArrayType Int BufferSetter + +-- dev hint: this should be InputType +-- we restrict StreamType using type class +-- subset of InputType, describes a stream type (in GPU side) +data StreamType + = Attribute_Word + | Attribute_V2U + | Attribute_V3U + | Attribute_V4U + | Attribute_Int + | Attribute_V2I + | Attribute_V3I + | Attribute_V4I + | Attribute_Float + | Attribute_V2F + | Attribute_V3F + | Attribute_V4F + | Attribute_M22F + | Attribute_M23F + | Attribute_M24F + | Attribute_M32F + | Attribute_M33F + | Attribute_M34F + | Attribute_M42F + | Attribute_M43F + | Attribute_M44F + deriving (Show,Eq,Ord) + +toStreamType :: InputType -> Maybe StreamType +toStreamType Word = Just Attribute_Word +toStreamType V2U = Just Attribute_V2U +toStreamType V3U = Just Attribute_V3U +toStreamType V4U = Just Attribute_V4U +toStreamType Int = Just Attribute_Int +toStreamType V2I = Just Attribute_V2I +toStreamType V3I = Just Attribute_V3I +toStreamType V4I = Just Attribute_V4I +toStreamType Float = Just Attribute_Float +toStreamType V2F = Just Attribute_V2F +toStreamType V3F = Just Attribute_V3F +toStreamType V4F = Just Attribute_V4F +toStreamType M22F = Just Attribute_M22F +toStreamType M23F = Just Attribute_M23F +toStreamType M24F = Just Attribute_M24F +toStreamType M32F = Just Attribute_M32F +toStreamType M33F = Just Attribute_M33F +toStreamType M34F = Just Attribute_M34F +toStreamType M42F = Just Attribute_M42F +toStreamType M43F = Just Attribute_M43F +toStreamType M44F = Just Attribute_M44F +toStreamType _ = Nothing + +fromStreamType :: StreamType -> InputType +fromStreamType Attribute_Word = Word +fromStreamType Attribute_V2U = V2U +fromStreamType Attribute_V3U = V3U +fromStreamType Attribute_V4U = V4U +fromStreamType Attribute_Int = Int +fromStreamType Attribute_V2I = V2I +fromStreamType Attribute_V3I = V3I +fromStreamType Attribute_V4I = V4I +fromStreamType Attribute_Float = Float +fromStreamType Attribute_V2F = V2F +fromStreamType Attribute_V3F = V3F +fromStreamType Attribute_V4F = V4F +fromStreamType Attribute_M22F = M22F +fromStreamType Attribute_M23F = M23F +fromStreamType Attribute_M24F = M24F +fromStreamType Attribute_M32F = M32F +fromStreamType Attribute_M33F = M33F +fromStreamType Attribute_M34F = M34F +fromStreamType Attribute_M42F = M42F +fromStreamType Attribute_M43F = M43F +fromStreamType Attribute_M44F = M44F + +-- user can specify streams using Stream type +-- a stream can be constant (ConstXXX) or can came from a buffer +data Stream b + = ConstWord Word32 + | ConstV2U V2U + | ConstV3U V3U + | ConstV4U V4U + | ConstInt Int32 + | ConstV2I V2I + | ConstV3I V3I + | ConstV4I V4I + | ConstFloat Float + | ConstV2F V2F + | ConstV3F V3F + | ConstV4F V4F + | ConstM22F M22F + | ConstM23F M23F + | ConstM24F M24F + | ConstM32F M32F + | ConstM33F M33F + | ConstM34F M34F + | ConstM42F M42F + | ConstM43F M43F + | ConstM44F M44F + | Stream + { streamType :: StreamType + , streamBuffer :: b + , streamArrIdx :: Int + , streamStart :: Int + , streamLength :: Int + } + deriving Show + +streamToStreamType :: Stream a -> StreamType +streamToStreamType s = case s of + ConstWord _ -> Attribute_Word + ConstV2U _ -> Attribute_V2U + ConstV3U _ -> Attribute_V3U + ConstV4U _ -> Attribute_V4U + ConstInt _ -> Attribute_Int + ConstV2I _ -> Attribute_V2I + ConstV3I _ -> Attribute_V3I + ConstV4I _ -> Attribute_V4I + ConstFloat _ -> Attribute_Float + ConstV2F _ -> Attribute_V2F + ConstV3F _ -> Attribute_V3F + ConstV4F _ -> Attribute_V4F + ConstM22F _ -> Attribute_M22F + ConstM23F _ -> Attribute_M23F + ConstM24F _ -> Attribute_M24F + ConstM32F _ -> Attribute_M32F + ConstM33F _ -> Attribute_M33F + ConstM34F _ -> Attribute_M34F + ConstM42F _ -> Attribute_M42F + ConstM43F _ -> Attribute_M43F + ConstM44F _ -> Attribute_M44F + Stream t _ _ _ _ -> t + +-- stream of index values (for index buffer) +data IndexStream b + = IndexStream + { indexBuffer :: b + , indexArrIdx :: Int + , indexStart :: Int + , indexLength :: Int + } + +newtype TextureData + = TextureData + { textureObject :: GLuint + } + deriving Storable + +data Primitive + = TriangleStrip + | TriangleList + | TriangleFan + | LineStrip + | LineList + | PointList + | TriangleStripAdjacency + | TriangleListAdjacency + | LineStripAdjacency + | LineListAdjacency + deriving (Eq,Ord,Bounded,Enum,Show) + +type StreamSetter = Stream Buffer -> IO () + +-- storable instances +instance Storable a => Storable (V2 a) where + sizeOf _ = 2 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + return $! (V2 x y) + + poke q (V2 x y) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + +instance Storable a => Storable (V3 a) where + sizeOf _ = 3 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + z <- peekByteOff p (k*2) + return $! (V3 x y z) + + poke q (V3 x y z) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + pokeByteOff p (k*2) z + +instance Storable a => Storable (V4 a) where + sizeOf _ = 4 * sizeOf (undefined :: a) + alignment _ = sizeOf (undefined :: a) + + peek q = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + x <- peek p + y <- peekByteOff p k + z <- peekByteOff p (k*2) + w <- peekByteOff p (k*3) + return $! (V4 x y z w) + + poke q (V4 x y z w) = do + let p = castPtr q :: Ptr a + k = sizeOf (undefined :: a) + poke p x + pokeByteOff p k y + pokeByteOff p (k*2) z + pokeByteOff p (k*3) w diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs new file mode 100644 index 0000000..2059415 --- /dev/null +++ b/src/LambdaCube/GL/Util.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE OverloadedStrings #-} +module LambdaCube.GL.Util ( + queryUniforms, + queryStreams, + mkUniformSetter, + setUniform, + setVertexAttrib, + compileShader, + printProgramLog, + glGetShaderiv1, + glGetProgramiv1, + Buffer(..), + ArrayDesc(..), + StreamSetter, + streamToInputType, + arrayTypeToGLType, + comparisonFunctionToGLType, + logicOperationToGLType, + blendEquationToGLType, + blendingFactorToGLType, + checkGL, + textureDataTypeToGLType, + textureDataTypeToGLArityType, + glGetIntegerv1, + setSampler, + checkFBO, + compileTexture, + primitiveToFetchPrimitive, + primitiveToGLType, + inputTypeToTextureTarget, + toTrie +) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.ByteString.Char8 (ByteString,pack,unpack) +import Data.IORef +import Data.List as L +import Data.Trie as T +import Foreign +import qualified Data.ByteString.Char8 as SB +import qualified Data.Vector as V +import Data.Vector.Unboxed.Mutable (IOVector) +import qualified Data.Vector.Unboxed.Mutable as MV +import Data.Map (Map) +import qualified Data.Map as Map + +import Graphics.GL.Core33 +import Linear +import IR +import LambdaCube.GL.Type + +toTrie :: Map String a -> Trie a +toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m] + +setSampler :: GLint -> Int32 -> IO () +setSampler i v = glUniform1i i $ fromIntegral v + +z2 = V2 0 0 :: V2F +z3 = V3 0 0 0 :: V3F +z4 = V4 0 0 0 0 :: V4F + +-- uniform functions +queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType) +queryUniforms po = do + ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH + let uNames = [n | (n,_,_,_) <- ul] + uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] + uLocation = [i | (_,i,_,_) <- ul] + return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes) + +b2w :: Bool -> GLuint +b2w True = 1 +b2w False = 0 + +mkUniformSetter :: InputType -> IO (GLUniform, InputSetter) +mkUniformSetter t@Bool = do {r <- newIORef 0; return $! (GLUniform t r, SBool $! writeIORef r . b2w)} +mkUniformSetter t@V2B = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2B $! writeIORef r . fmap b2w)} +mkUniformSetter t@V3B = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3B $! writeIORef r . fmap b2w)} +mkUniformSetter t@V4B = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4B $! writeIORef r . fmap b2w)} +mkUniformSetter t@Word = do {r <- newIORef 0; return $! (GLUniform t r, SWord $! writeIORef r)} +mkUniformSetter t@V2U = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2U $! writeIORef r)} +mkUniformSetter t@V3U = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3U $! writeIORef r)} +mkUniformSetter t@V4U = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4U $! writeIORef r)} +mkUniformSetter t@Int = do {r <- newIORef 0; return $! (GLUniform t r, SInt $! writeIORef r)} +mkUniformSetter t@V2I = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2I $! writeIORef r)} +mkUniformSetter t@V3I = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3I $! writeIORef r)} +mkUniformSetter t@V4I = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4I $! writeIORef r)} +mkUniformSetter t@Float = do {r <- newIORef 0; return $! (GLUniform t r, SFloat $! writeIORef r)} +mkUniformSetter t@V2F = do {r <- newIORef (V2 0 0); return $! (GLUniform t r, SV2F $! writeIORef r)} +mkUniformSetter t@V3F = do {r <- newIORef (V3 0 0 0); return $! (GLUniform t r, SV3F $! writeIORef r)} +mkUniformSetter t@V4F = do {r <- newIORef (V4 0 0 0 0); return $! (GLUniform t r, SV4F $! writeIORef r)} +mkUniformSetter t@M22F = do {r <- newIORef (V2 z2 z2); return $! (GLUniform t r, SM22F $! writeIORef r)} +mkUniformSetter t@M23F = do {r <- newIORef (V3 z2 z2 z2); return $! (GLUniform t r, SM23F $! writeIORef r)} +mkUniformSetter t@M24F = do {r <- newIORef (V4 z2 z2 z2 z2); return $! (GLUniform t r, SM24F $! writeIORef r)} +mkUniformSetter t@M32F = do {r <- newIORef (V2 z3 z3); return $! (GLUniform t r, SM32F $! writeIORef r)} +mkUniformSetter t@M33F = do {r <- newIORef (V3 z3 z3 z3); return $! (GLUniform t r, SM33F $! writeIORef r)} +mkUniformSetter t@M34F = do {r <- newIORef (V4 z3 z3 z3 z3); return $! (GLUniform t r, SM34F $! writeIORef r)} +mkUniformSetter t@M42F = do {r <- newIORef (V2 z4 z4); return $! (GLUniform t r, SM42F $! writeIORef r)} +mkUniformSetter t@M43F = do {r <- newIORef (V3 z4 z4 z4); return $! (GLUniform t r, SM43F $! writeIORef r)} +mkUniformSetter t@M44F = do {r <- newIORef (V4 z4 z4 z4 z4); return $! (GLUniform t r, SM44F $! writeIORef r)} +mkUniformSetter t@FTexture2D = do {r <- newIORef (TextureData 0); return $! (GLUniform t r, SFTexture2D $! writeIORef r)} + +-- sets value based uniforms only (does not handle textures) +setUniform :: Storable a => GLint -> InputType -> IORef a -> IO () +setUniform i ty ref = do + v <- readIORef ref + let false = fromIntegral GL_FALSE + with v $ \p -> case ty of + Bool -> glUniform1uiv i 1 (castPtr p) + V2B -> glUniform2uiv i 1 (castPtr p) + V3B -> glUniform3uiv i 1 (castPtr p) + V4B -> glUniform4uiv i 1 (castPtr p) + Word -> glUniform1uiv i 1 (castPtr p) + V2U -> glUniform2uiv i 1 (castPtr p) + V3U -> glUniform3uiv i 1 (castPtr p) + V4U -> glUniform4uiv i 1 (castPtr p) + Int -> glUniform1iv i 1 (castPtr p) + V2I -> glUniform2iv i 1 (castPtr p) + V3I -> glUniform3iv i 1 (castPtr p) + V4I -> glUniform4iv i 1 (castPtr p) + Float -> glUniform1fv i 1 (castPtr p) + V2F -> glUniform2fv i 1 (castPtr p) + V3F -> glUniform3fv i 1 (castPtr p) + V4F -> glUniform4fv i 1 (castPtr p) + M22F -> glUniformMatrix2fv i 1 false (castPtr p) + M23F -> glUniformMatrix2x3fv i 1 false (castPtr p) + M24F -> glUniformMatrix2x4fv i 1 false (castPtr p) + M32F -> glUniformMatrix3x2fv i 1 false (castPtr p) + M33F -> glUniformMatrix3fv i 1 false (castPtr p) + M34F -> glUniformMatrix3x4fv i 1 false (castPtr p) + M42F -> glUniformMatrix4x2fv i 1 false (castPtr p) + M43F -> glUniformMatrix4x3fv i 1 false (castPtr p) + M44F -> glUniformMatrix4fv i 1 false (castPtr p) + FTexture2D -> return () --putStrLn $ "TODO: setUniform FTexture2D" + _ -> fail $ "internal error (setUniform)! - " ++ show ty + +-- attribute functions +queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType) +queryStreams po = do + al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH + let aNames = [n | (n,_,_,_) <- al] + aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] + aLocation = [fromIntegral i | (_,i,_,_) <- al] + return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes) + +arrayTypeToGLType :: ArrayType -> GLenum +arrayTypeToGLType a = case a of + ArrWord8 -> GL_UNSIGNED_BYTE + ArrWord16 -> GL_UNSIGNED_SHORT + ArrWord32 -> GL_UNSIGNED_INT + ArrInt8 -> GL_BYTE + ArrInt16 -> GL_SHORT + ArrInt32 -> GL_INT + ArrFloat -> GL_FLOAT + ArrHalf -> GL_HALF_FLOAT + +setVertexAttrib :: GLuint -> Stream Buffer -> IO () +setVertexAttrib i val = case val of + ConstWord v -> with v $! \p -> glVertexAttribI1uiv i $! castPtr p + ConstV2U v -> with v $! \p -> glVertexAttribI2uiv i $! castPtr p + ConstV3U v -> with v $! \p -> glVertexAttribI3uiv i $! castPtr p + ConstV4U v -> with v $! \p -> glVertexAttribI4uiv i $! castPtr p + ConstInt v -> with v $! \p -> glVertexAttribI1iv i $! castPtr p + ConstV2I v -> with v $! \p -> glVertexAttribI2iv i $! castPtr p + ConstV3I v -> with v $! \p -> glVertexAttribI3iv i $! castPtr p + ConstV4I v -> with v $! \p -> glVertexAttribI4iv i $! castPtr p + ConstFloat v -> setAFloat i v + ConstV2F v -> setAV2F i v + ConstV3F v -> setAV3F i v + ConstV4F v -> setAV4F i v + ConstM22F (V2 x y) -> setAV2F i x >> setAV2F (i+1) y + ConstM23F (V3 x y z) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z + ConstM24F (V4 x y z w) -> setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w + ConstM32F (V2 x y) -> setAV3F i x >> setAV3F (i+1) y + ConstM33F (V3 x y z) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z + ConstM34F (V4 x y z w) -> setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w + ConstM42F (V2 x y) -> setAV4F i x >> setAV4F (i+1) y + ConstM43F (V3 x y z) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z + ConstM44F (V4 x y z w) -> setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w + _ -> fail "internal error (setVertexAttrib)!" + +setAFloat :: GLuint -> Float -> IO () +setAV2F :: GLuint -> V2F -> IO () +setAV3F :: GLuint -> V3F -> IO () +setAV4F :: GLuint -> V4F -> IO () +setAFloat i v = with v $! \p -> glVertexAttrib1fv i $! castPtr p +setAV2F i v = with v $! \p -> glVertexAttrib2fv i $! castPtr p +setAV3F i v = with v $! \p -> glVertexAttrib3fv i $! castPtr p +setAV4F i v = with v $! \p -> glVertexAttrib4fv i $! castPtr p + +-- result list: [(name string,location,gl type,component count)] +getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ()) + -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)] +getNameTypeSize o f g enum enumLen = do + nameLen <- glGetProgramiv1 enumLen o + allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do + n <- glGetProgramiv1 enum o + forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >> + (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep + +fromGLType :: (GLenum,GLint) -> InputType +fromGLType (t,1) + | t == GL_BOOL = Bool + | t == GL_BOOL_VEC2 = V2B + | t == GL_BOOL_VEC3 = V3B + | t == GL_BOOL_VEC4 = V4B + | t == GL_UNSIGNED_INT = Word + | t == GL_UNSIGNED_INT_VEC2 = V2U + | t == GL_UNSIGNED_INT_VEC3 = V3U + | t == GL_UNSIGNED_INT_VEC4 = V4U + | t == GL_INT = Int + | t == GL_INT_VEC2 = V2I + | t == GL_INT_VEC3 = V3I + | t == GL_INT_VEC4 = V4I + | t == GL_FLOAT = Float + | t == GL_FLOAT_VEC2 = V2F + | t == GL_FLOAT_VEC3 = V3F + | t == GL_FLOAT_VEC4 = V4F + | t == GL_FLOAT_MAT2 = M22F + | t == GL_FLOAT_MAT2x3 = M23F + | t == GL_FLOAT_MAT2x4 = M24F + | t == GL_FLOAT_MAT3x2 = M32F + | t == GL_FLOAT_MAT3 = M33F + | t == GL_FLOAT_MAT3x4 = M34F + | t == GL_FLOAT_MAT4x2 = M42F + | t == GL_FLOAT_MAT4x3 = M43F + | t == GL_FLOAT_MAT4 = M44F + | t == GL_SAMPLER_1D_ARRAY_SHADOW = STexture1DArray + | t == GL_SAMPLER_1D_SHADOW = STexture1D + | t == GL_SAMPLER_2D_ARRAY_SHADOW = STexture2DArray + | t == GL_SAMPLER_2D_RECT_SHADOW = STexture2DRect + | t == GL_SAMPLER_2D_SHADOW = STexture2D + | t == GL_SAMPLER_CUBE_SHADOW = STextureCube + | t == GL_INT_SAMPLER_1D = ITexture1D + | t == GL_INT_SAMPLER_1D_ARRAY = ITexture1DArray + | t == GL_INT_SAMPLER_2D = ITexture2D + | t == GL_INT_SAMPLER_2D_ARRAY = ITexture2DArray + | t == GL_INT_SAMPLER_2D_MULTISAMPLE = ITexture2DMS + | t == GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = ITexture2DMSArray + | t == GL_INT_SAMPLER_2D_RECT = ITexture2DRect + | t == GL_INT_SAMPLER_3D = ITexture3D + | t == GL_INT_SAMPLER_BUFFER = ITextureBuffer + | t == GL_INT_SAMPLER_CUBE = ITextureCube + | t == GL_SAMPLER_1D = FTexture1D + | t == GL_SAMPLER_1D_ARRAY = FTexture1DArray + | t == GL_SAMPLER_2D = FTexture2D + | t == GL_SAMPLER_2D_ARRAY = FTexture2DArray + | t == GL_SAMPLER_2D_MULTISAMPLE = FTexture2DMS + | t == GL_SAMPLER_2D_MULTISAMPLE_ARRAY = FTexture2DMSArray + | t == GL_SAMPLER_2D_RECT = FTexture2DRect + | t == GL_SAMPLER_3D = FTexture3D + | t == GL_SAMPLER_BUFFER = FTextureBuffer + | t == GL_SAMPLER_CUBE = FTextureCube + | t == GL_UNSIGNED_INT_SAMPLER_1D = UTexture1D + | t == GL_UNSIGNED_INT_SAMPLER_1D_ARRAY = UTexture1DArray + | t == GL_UNSIGNED_INT_SAMPLER_2D = UTexture2D + | t == GL_UNSIGNED_INT_SAMPLER_2D_ARRAY = UTexture2DArray + | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE = UTexture2DMS + | t == GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray + | t == GL_UNSIGNED_INT_SAMPLER_2D_RECT = UTexture2DRect + | t == GL_UNSIGNED_INT_SAMPLER_3D = UTexture3D + | t == GL_UNSIGNED_INT_SAMPLER_BUFFER = UTextureBuffer + | t == GL_UNSIGNED_INT_SAMPLER_CUBE = UTextureCube + | otherwise = error "Failed fromGLType" +fromGLUniformType _ = error "Failed fromGLType" + +printShaderLog :: GLuint -> IO () +printShaderLog o = do + i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o + when (i > 0) $ + alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do + glGetShaderInfoLog o (fromIntegral i) sizePtr ps + size <- peek sizePtr + log <- SB.packCStringLen (castPtr ps, fromIntegral size) + SB.putStrLn log + +glGetShaderiv1 :: GLenum -> GLuint -> IO GLint +glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi + +glGetProgramiv1 :: GLenum -> GLuint -> IO GLint +glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi + +printProgramLog :: GLuint -> IO () +printProgramLog o = do + i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o + when (i > 0) $ + alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do + glGetProgramInfoLog o (fromIntegral i) sizePtr ps + size <- peek sizePtr + log <- SB.packCStringLen (castPtr ps, fromIntegral size) + SB.putStrLn log + +compileShader :: GLuint -> [ByteString] -> IO () +compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do + glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr + glCompileShader o + printShaderLog o + status <- glGetShaderiv1 GL_COMPILE_STATUS o + when (status /= fromIntegral GL_TRUE) $ fail "compileShader failed!" + +checkGL :: IO ByteString +checkGL = do + let f e | e == GL_INVALID_ENUM = "INVALID_ENUM" + | e == GL_INVALID_VALUE = "INVALID_VALUE" + | e == GL_INVALID_OPERATION = "INVALID_OPERATION" + | e == GL_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION" + | e == GL_OUT_OF_MEMORY = "OUT_OF_MEMORY" + | e == GL_NO_ERROR = "OK" + | otherwise = "Unknown error" + e <- glGetError + return $ f e + +streamToInputType :: Stream Buffer -> InputType +streamToInputType s = case s of + ConstWord _ -> Word + ConstV2U _ -> V2U + ConstV3U _ -> V3U + ConstV4U _ -> V4U + ConstInt _ -> Int + ConstV2I _ -> V2I + ConstV3I _ -> V3I + ConstV4I _ -> V4I + ConstFloat _ -> Float + ConstV2F _ -> V2F + ConstV3F _ -> V3F + ConstV4F _ -> V4F + ConstM22F _ -> M22F + ConstM23F _ -> M23F + ConstM24F _ -> M24F + ConstM32F _ -> M32F + ConstM33F _ -> M33F + ConstM34F _ -> M34F + ConstM42F _ -> M42F + ConstM43F _ -> M43F + ConstM44F _ -> M44F + Stream t (Buffer a _) i _ _ + | 0 <= i && i < V.length a && + if elem t integralTypes then elem at integralArrTypes else True + -> fromStreamType t + | otherwise -> throw $ userError "streamToInputType failed" + where + at = arrType $! (a V.! i) + integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I] + integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32] + +comparisonFunctionToGLType :: ComparisonFunction -> GLenum +comparisonFunctionToGLType a = case a of + Always -> GL_ALWAYS + Equal -> GL_EQUAL + Gequal -> GL_GEQUAL + Greater -> GL_GREATER + Lequal -> GL_LEQUAL + Less -> GL_LESS + Never -> GL_NEVER + Notequal -> GL_NOTEQUAL + +logicOperationToGLType :: LogicOperation -> GLenum +logicOperationToGLType a = case a of + And -> GL_AND + AndInverted -> GL_AND_INVERTED + AndReverse -> GL_AND_REVERSE + Clear -> GL_CLEAR + Copy -> GL_COPY + CopyInverted -> GL_COPY_INVERTED + Equiv -> GL_EQUIV + Invert -> GL_INVERT + Nand -> GL_NAND + Noop -> GL_NOOP + Nor -> GL_NOR + Or -> GL_OR + OrInverted -> GL_OR_INVERTED + OrReverse -> GL_OR_REVERSE + Set -> GL_SET + Xor -> GL_XOR + +blendEquationToGLType :: BlendEquation -> GLenum +blendEquationToGLType a = case a of + FuncAdd -> GL_FUNC_ADD + FuncReverseSubtract -> GL_FUNC_REVERSE_SUBTRACT + FuncSubtract -> GL_FUNC_SUBTRACT + Max -> GL_MAX + Min -> GL_MIN + +blendingFactorToGLType :: BlendingFactor -> GLenum +blendingFactorToGLType a = case a of + ConstantAlpha -> GL_CONSTANT_ALPHA + ConstantColor -> GL_CONSTANT_COLOR + DstAlpha -> GL_DST_ALPHA + DstColor -> GL_DST_COLOR + One -> GL_ONE + OneMinusConstantAlpha -> GL_ONE_MINUS_CONSTANT_ALPHA + OneMinusConstantColor -> GL_ONE_MINUS_CONSTANT_COLOR + OneMinusDstAlpha -> GL_ONE_MINUS_DST_ALPHA + OneMinusDstColor -> GL_ONE_MINUS_DST_COLOR + OneMinusSrcAlpha -> GL_ONE_MINUS_SRC_ALPHA + OneMinusSrcColor -> GL_ONE_MINUS_SRC_COLOR + SrcAlpha -> GL_SRC_ALPHA + SrcAlphaSaturate -> GL_SRC_ALPHA_SATURATE + SrcColor -> GL_SRC_COLOR + Zero -> GL_ZERO + +textureDataTypeToGLType :: ImageSemantic -> TextureDataType -> GLenum +textureDataTypeToGLType Color a = case a of + FloatT Red -> GL_R32F + IntT Red -> GL_R32I + WordT Red -> GL_R32UI + FloatT RG -> GL_RG32F + IntT RG -> GL_RG32I + WordT RG -> GL_RG32UI + FloatT RGBA -> GL_RGBA32F + IntT RGBA -> GL_RGBA32I + WordT RGBA -> GL_RGBA32UI + a -> error $ "FIXME: This texture format is not yet supported" ++ show a +textureDataTypeToGLType Depth a = case a of + FloatT Red -> GL_DEPTH_COMPONENT32F + WordT Red -> GL_DEPTH_COMPONENT32 + a -> error $ "FIXME: This texture format is not yet supported" ++ show a +textureDataTypeToGLType Stencil a = case a of + a -> error $ "FIXME: This texture format is not yet supported" ++ show a + +textureDataTypeToGLArityType :: ImageSemantic -> TextureDataType -> GLenum +textureDataTypeToGLArityType Color a = case a of + FloatT Red -> GL_RED + IntT Red -> GL_RED + WordT Red -> GL_RED + FloatT RG -> GL_RG + IntT RG -> GL_RG + WordT RG -> GL_RG + FloatT RGBA -> GL_RGBA + IntT RGBA -> GL_RGBA + WordT RGBA -> GL_RGBA + a -> error $ "FIXME: This texture format is not yet supported" ++ show a +textureDataTypeToGLArityType Depth a = case a of + FloatT Red -> GL_DEPTH_COMPONENT + WordT Red -> GL_DEPTH_COMPONENT + a -> error $ "FIXME: This texture format is not yet supported" ++ show a +textureDataTypeToGLArityType Stencil a = case a of + a -> error $ "FIXME: This texture format is not yet supported" ++ show a +{- +Texture and renderbuffer color formats (R): + R11F_G11F_B10F + R16 + R16F + R16I + R16UI + R32F + R32I + R32UI + R8 + R8I + R8UI + RG16 + RG16F + RG16I + RG16UI + RG32F + RG32I + RG32UI + RG8 + RG8I + RG8UI + RGB10_A2 + RGB10_A2UI + RGBA16 + RGBA16F + RGBA16I + RGBA16UI + RGBA32F + RGBA32I + RGBA32UI + RGBA8 + RGBA8I + RGBA8UI + SRGB8_ALPHA8 +-} + +glGetIntegerv1 :: GLenum -> IO GLint +glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi + +checkFBO :: IO ByteString +checkFBO = do + let f e | e == GL_FRAMEBUFFER_UNDEFINED = "FRAMEBUFFER_UNDEFINED" + | e == GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT" + | e == GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER" + | e == GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER" + | e == GL_FRAMEBUFFER_UNSUPPORTED = "FRAMEBUFFER_UNSUPPORTED" + | e == GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE" + | e == GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS" + | e == GL_FRAMEBUFFER_COMPLETE = "FRAMEBUFFER_COMPLETE" + | otherwise = "Unknown error" + e <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER + return $ f e + +filterToGLType :: Filter -> GLenum +filterToGLType a = case a of + Nearest -> GL_NEAREST + Linear -> GL_LINEAR + NearestMipmapNearest -> GL_NEAREST_MIPMAP_NEAREST + NearestMipmapLinear -> GL_NEAREST_MIPMAP_LINEAR + LinearMipmapNearest -> GL_LINEAR_MIPMAP_NEAREST + LinearMipmapLinear -> GL_LINEAR_MIPMAP_LINEAR + +edgeModeToGLType :: EdgeMode -> GLenum +edgeModeToGLType a = case a of + Repeat -> GL_REPEAT + MirroredRepeat -> GL_MIRRORED_REPEAT + ClampToEdge -> GL_CLAMP_TO_EDGE + ClampToBorder -> GL_CLAMP_TO_BORDER + +setTextureSamplerParameters :: GLenum -> SamplerDescriptor -> IO () +setTextureSamplerParameters t s = do + glTexParameteri t GL_TEXTURE_WRAP_S $ fromIntegral $ edgeModeToGLType $ samplerWrapS s + case samplerWrapT s of + Nothing -> return () + Just a -> glTexParameteri t GL_TEXTURE_WRAP_T $ fromIntegral $ edgeModeToGLType a + case samplerWrapR s of + Nothing -> return () + Just a -> glTexParameteri t GL_TEXTURE_WRAP_R $ fromIntegral $ edgeModeToGLType a + glTexParameteri t GL_TEXTURE_MIN_FILTER $ fromIntegral $ filterToGLType $ samplerMinFilter s + glTexParameteri t GL_TEXTURE_MAG_FILTER $ fromIntegral $ filterToGLType $ samplerMagFilter s + + let setBColorV4F a = with a $ \p -> glTexParameterfv t GL_TEXTURE_BORDER_COLOR $ castPtr p + setBColorV4I a = with a $ \p -> glTexParameterIiv t GL_TEXTURE_BORDER_COLOR $ castPtr p + setBColorV4U a = with a $ \p -> glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR $ castPtr p + case samplerBorderColor s of + -- float, word, int, red, rg, rgb, rgba + VFloat a -> setBColorV4F $ V4 a 0 0 0 + VV2F (V2 a b) -> setBColorV4F $ V4 a b 0 0 + VV3F (V3 a b c) -> setBColorV4F $ V4 a b c 0 + VV4F a -> setBColorV4F a + + VInt a -> setBColorV4I $ V4 a 0 0 0 + VV2I (V2 a b) -> setBColorV4I $ V4 a b 0 0 + VV3I (V3 a b c) -> setBColorV4I $ V4 a b c 0 + VV4I a -> setBColorV4I a + + VWord a -> setBColorV4U $ V4 a 0 0 0 + VV2U (V2 a b) -> setBColorV4U $ V4 a b 0 0 + VV3U (V3 a b c) -> setBColorV4U $ V4 a b c 0 + VV4U a -> setBColorV4U a + _ -> fail "internal error (setTextureSamplerParameters)!" + + case samplerMinLod s of + Nothing -> return () + Just a -> glTexParameterf t GL_TEXTURE_MIN_LOD $ realToFrac a + case samplerMaxLod s of + Nothing -> return () + Just a -> glTexParameterf t GL_TEXTURE_MAX_LOD $ realToFrac a + glTexParameterf t GL_TEXTURE_LOD_BIAS $ realToFrac $ samplerLodBias s + case samplerCompareFunc s of + Nothing -> glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_NONE + Just a -> do + glTexParameteri t GL_TEXTURE_COMPARE_MODE $ fromIntegral GL_COMPARE_REF_TO_TEXTURE + glTexParameteri t GL_TEXTURE_COMPARE_FUNC $ fromIntegral $ comparisonFunctionToGLType a + +compileTexture :: TextureDescriptor -> IO GLTexture +compileTexture txDescriptor = do + to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto + let TextureDescriptor + { textureType = txType + , textureSize = txSize + , textureSemantic = txSemantic + , textureSampler = txSampler + , textureBaseLevel = txBaseLevel + , textureMaxLevel = txMaxLevel + } = txDescriptor + + txSetup txTarget dTy = do + let internalFormat = fromIntegral $ textureDataTypeToGLType txSemantic dTy + dataFormat = fromIntegral $ textureDataTypeToGLArityType txSemantic dTy + glBindTexture txTarget to + glTexParameteri txTarget GL_TEXTURE_BASE_LEVEL $ fromIntegral txBaseLevel + glTexParameteri txTarget GL_TEXTURE_MAX_LEVEL $ fromIntegral txMaxLevel + setTextureSamplerParameters txTarget txSampler + return (internalFormat,dataFormat) + + mipSize 0 x = [x] + mipSize n x = x : mipSize (n-1) (x `div` 2) + mipS = mipSize (txMaxLevel - txBaseLevel) + levels = [txBaseLevel..txMaxLevel] + target <- case txType of + Texture1D dTy layerCnt -> do + let VWord txW = txSize + txTarget = if layerCnt > 1 then GL_TEXTURE_1D_ARRAY else GL_TEXTURE_1D + (internalFormat,dataFormat) <- txSetup txTarget dTy + forM_ (zip levels (mipS txW)) $ \(l,w) -> case layerCnt > 1 of + True -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + False -> glTexImage1D txTarget (fromIntegral l) internalFormat (fromIntegral w) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + Texture2D dTy layerCnt -> do + let VV2U (V2 txW txH) = txSize + txTarget = if layerCnt > 1 then GL_TEXTURE_2D_ARRAY else GL_TEXTURE_2D + (internalFormat,dataFormat) <- txSetup txTarget dTy + forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> case layerCnt > 1 of + True -> glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + False -> glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + Texture3D dTy -> do + let VV3U (V3 txW txH txD) = txSize + txTarget = GL_TEXTURE_3D + (internalFormat,dataFormat) <- txSetup txTarget dTy + forM_ (zip4 levels (mipS txW) (mipS txH) (mipS txD)) $ \(l,w,h,d) -> + glTexImage3D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral d) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + TextureCube dTy -> do + let VV2U (V2 txW txH) = txSize + txTarget = GL_TEXTURE_CUBE_MAP + targets = + [ GL_TEXTURE_CUBE_MAP_POSITIVE_X + , GL_TEXTURE_CUBE_MAP_NEGATIVE_X + , GL_TEXTURE_CUBE_MAP_POSITIVE_Y + , GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + , GL_TEXTURE_CUBE_MAP_POSITIVE_Z + , GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + ] + (internalFormat,dataFormat) <- txSetup txTarget dTy + forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> + forM_ targets $ \t -> glTexImage2D t (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + TextureRect dTy -> do + let VV2U (V2 txW txH) = txSize + txTarget = GL_TEXTURE_RECTANGLE + (internalFormat,dataFormat) <- txSetup txTarget dTy + forM_ (zip3 levels (mipS txW) (mipS txH)) $ \(l,w,h) -> + glTexImage2D txTarget (fromIntegral l) internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + Texture2DMS dTy layerCnt sampleCount isFixedLocations -> do + let VV2U (V2 w h) = txSize + txTarget = if layerCnt > 1 then GL_TEXTURE_2D_MULTISAMPLE_ARRAY else GL_TEXTURE_2D_MULTISAMPLE + isFixed = fromIntegral $ if isFixedLocations then GL_TRUE else GL_FALSE + (internalFormat,dataFormat) <- txSetup txTarget dTy + case layerCnt > 1 of + True -> glTexImage3DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) isFixed + False -> glTexImage2DMultisample txTarget (fromIntegral sampleCount) internalFormat (fromIntegral w) (fromIntegral h) isFixed + return txTarget + TextureBuffer dTy -> do + fail "internal error: buffer texture is not supported yet" + -- TODO + let VV2U (V2 w h) = txSize + txTarget = GL_TEXTURE_2D + (internalFormat,dataFormat) <- txSetup txTarget dTy + glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE nullPtr + return txTarget + return $ GLTexture + { glTextureObject = to + , glTextureTarget = target + } + +primitiveToFetchPrimitive :: Primitive -> FetchPrimitive +primitiveToFetchPrimitive prim = case prim of + TriangleStrip -> Triangles + TriangleList -> Triangles + TriangleFan -> Triangles + LineStrip -> Lines + LineList -> Lines + PointList -> Points + TriangleStripAdjacency -> TrianglesAdjacency + TriangleListAdjacency -> TrianglesAdjacency + LineStripAdjacency -> LinesAdjacency + LineListAdjacency -> LinesAdjacency + +primitiveToGLType :: Primitive -> GLenum +primitiveToGLType p = case p 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 + +inputTypeToTextureTarget :: InputType -> GLenum +inputTypeToTextureTarget ty = case ty of + STexture1D -> GL_TEXTURE_1D + STexture2D -> GL_TEXTURE_2D + STextureCube -> GL_TEXTURE_CUBE_MAP + STexture1DArray -> GL_TEXTURE_1D_ARRAY + STexture2DArray -> GL_TEXTURE_2D_ARRAY + STexture2DRect -> GL_TEXTURE_RECTANGLE + + FTexture1D -> GL_TEXTURE_1D + FTexture2D -> GL_TEXTURE_2D + FTexture3D -> GL_TEXTURE_3D + FTextureCube -> GL_TEXTURE_CUBE_MAP + FTexture1DArray -> GL_TEXTURE_1D_ARRAY + FTexture2DArray -> GL_TEXTURE_2D_ARRAY + FTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE + FTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY + FTextureBuffer -> GL_TEXTURE_BUFFER + FTexture2DRect -> GL_TEXTURE_RECTANGLE + + ITexture1D -> GL_TEXTURE_1D + ITexture2D -> GL_TEXTURE_2D + ITexture3D -> GL_TEXTURE_3D + ITextureCube -> GL_TEXTURE_CUBE_MAP + ITexture1DArray -> GL_TEXTURE_1D_ARRAY + ITexture2DArray -> GL_TEXTURE_2D_ARRAY + ITexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE + ITexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY + ITextureBuffer -> GL_TEXTURE_BUFFER + ITexture2DRect -> GL_TEXTURE_RECTANGLE + + UTexture1D -> GL_TEXTURE_1D + UTexture2D -> GL_TEXTURE_2D + UTexture3D -> GL_TEXTURE_3D + UTextureCube -> GL_TEXTURE_CUBE_MAP + UTexture1DArray -> GL_TEXTURE_1D_ARRAY + UTexture2DArray -> GL_TEXTURE_2D_ARRAY + UTexture2DMS -> GL_TEXTURE_2D_MULTISAMPLE + UTexture2DMSArray -> GL_TEXTURE_2D_MULTISAMPLE_ARRAY + UTextureBuffer -> GL_TEXTURE_BUFFER + UTexture2DRect -> GL_TEXTURE_RECTANGLE + + _ -> error "internal error (inputTypeToTextureTarget)!" -- cgit v1.2.3