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 --- Backend/GL.hs | 88 ------ Backend/GL/Backend.hs | 833 -------------------------------------------------- Backend/GL/Data.hs | 113 ------- Backend/GL/Input.hs | 387 ----------------------- Backend/GL/Mesh.hs | 238 --------------- Backend/GL/Type.hs | 541 -------------------------------- Backend/GL/Util.hs | 719 ------------------------------------------- 7 files changed, 2919 deletions(-) delete mode 100644 Backend/GL.hs delete mode 100644 Backend/GL/Backend.hs delete mode 100644 Backend/GL/Data.hs delete mode 100644 Backend/GL/Input.hs delete mode 100644 Backend/GL/Mesh.hs delete mode 100644 Backend/GL/Type.hs delete mode 100644 Backend/GL/Util.hs (limited to 'Backend') diff --git a/Backend/GL.hs b/Backend/GL.hs deleted file mode 100644 index 3edb4fa..0000000 --- a/Backend/GL.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Backend.GL ( - -- IR - V2(..),V3(..),V4(..), - -- Array, Buffer, Texture - Array(..), - ArrayType(..), - Buffer, - BufferSetter, - IndexStream(..), - Stream(..), - StreamSetter, - StreamType(..), - Primitive(..), - SetterFun, - TextureData, - InputSetter(..), - fromStreamType, - sizeOfArrayType, - toStreamType, - compileBuffer, - updateBuffer, - bufferSize, - arraySize, - arrayType, - compileTexture2DRGBAF, - compileTexture2DRGBAF', - - -- GL Pipeline Input, Object - GLPipeline, - GLPipelineInput, - Object, - PipelineSchema(..), - SlotSchema(..), - schema, - schemaFromPipeline, - allocPipeline, - disposePipeline, - setPipelineInput, - renderPipeline, - mkGLPipelineInput, - uniformSetter, - addObject, - removeObject, - enableObject, - setObjectOrder, - objectUniformSetter, - setScreenSize, - sortSlotObjects, - - uniformBool, - uniformV2B, - uniformV3B, - uniformV4B, - - uniformWord, - uniformV2U, - uniformV3U, - uniformV4U, - - uniformInt, - uniformV2I, - uniformV3I, - uniformV4I, - - uniformFloat, - uniformV2F, - uniformV3F, - uniformV4F, - - uniformM22F, - uniformM23F, - uniformM24F, - uniformM32F, - uniformM33F, - uniformM34F, - uniformM42F, - uniformM43F, - uniformM44F, - - uniformFTexture2D -) where - -import Backend.GL.Type -import Backend.GL.Backend -import Backend.GL.Data -import Backend.GL.Input -import IR -import Linear diff --git a/Backend/GL/Backend.hs b/Backend/GL/Backend.hs deleted file mode 100644 index 55ae443..0000000 --- a/Backend/GL/Backend.hs +++ /dev/null @@ -1,833 +0,0 @@ -{-# LANGUAGE TupleSections, MonadComprehensions, ViewPatterns, RecordWildCards #-} -module Backend.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.Rendering.OpenGL.Raw.Core33 -import Foreign - --- LC IR imports -import Linear -import IR hiding (streamType) -import qualified IR as IR - -import Backend.GL.Type -import Backend.GL.Util - -import Backend.GL.Data -import Backend.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 {} - -{- -data ImageIndex - = TextureImage TextureName Int (Maybe Int) -- Texture name, mip index, array index - | Framebuffer ImageSemantic - -data ImageSemantic - = Depth - | Stencil - | Color --} -{- - = RenderTarget - { renderTargets :: [(ImageSemantic,Maybe ImageIndex)] -- render texture or default framebuffer (semantic, render texture for the program output) - } --} -{- - glDrawBuffers - GL_NONE - --GL_FRONT_LEFT - --GL_FRONT_RIGHT - GL_BACK_LEFT - --GL_BACK_RIGHT - GL_COLOR_ATTACHMENTn --} -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 - TWord -> setIntAttrib 1 - TV2U -> setIntAttrib 2 - TV3U -> setIntAttrib 3 - TV4U -> setIntAttrib 4 - TInt -> setIntAttrib 1 - TV2I -> setIntAttrib 2 - TV3I -> setIntAttrib 3 - TV4I -> setIntAttrib 4 - TFloat -> setFloatAttrib 1 - TV2F -> setFloatAttrib 2 - TV3F -> setFloatAttrib 3 - TV4F -> setFloatAttrib 4 - TM22F -> setFloatAttrib 4 - TM23F -> setFloatAttrib 6 - TM24F -> setFloatAttrib 8 - TM32F -> setFloatAttrib 6 - TM33F -> setFloatAttrib 9 - TM34F -> setFloatAttrib 12 - TM42F -> setFloatAttrib 8 - TM43F -> setFloatAttrib 12 - TM44F -> 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 - -allocPipeline :: Pipeline -> IO GLPipeline -allocPipeline 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 $ GLPipeline - { 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 - } - -disposePipeline :: GLPipeline -> IO () -disposePipeline p = do - setPipelineInput 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 - ] --} -setPipelineInput :: GLPipeline -> Maybe GLPipelineInput -> IO () -setPipelineInput 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 - 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) -{- - 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 - -renderPipeline :: GLPipeline -> IO () -renderPipeline 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/Backend/GL/Data.hs b/Backend/GL/Data.hs deleted file mode 100644 index 2c6e596..0000000 --- a/Backend/GL/Data.hs +++ /dev/null @@ -1,113 +0,0 @@ -module Backend.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.Rendering.OpenGL.Raw.Core33 -import Data.Word -import Codec.Picture -import Codec.Picture.Types - -import Backend.GL.Type -import Backend.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 -compileTexture2DRGBAF :: Bool -> Bool -> DynamicImage -> IO TextureData -compileTexture2DRGBAF = compileTexture2DRGBAF' False - -compileTexture2DRGBAF' :: Bool -> Bool -> Bool -> DynamicImage -> IO TextureData -compileTexture2DRGBAF' 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 "compileTexture2DRGBAF: ImageCMYK16" - ImageCMYK8 _ -> error "compileTexture2DRGBAF: ImageCMYK8" - ImageRGBA16 _ -> error "compileTexture2DRGBAF: ImageRGBA16" - ImageRGBF _ -> error "compileTexture2DRGBAF: ImageRGBF" - ImageRGB16 _ -> error "compileTexture2DRGBAF: ImageRGB16" - ImageYA16 _ -> error "compileTexture2DRGBAF: ImageYA16" - ImageYA8 _ -> error "compileTexture2DRGBAF: ImageYA8" - ImageYF _ -> error "compileTexture2DRGBAF: ImageYF" - ImageY16 _ -> error "compileTexture2DRGBAF: ImageY16" - ImageY8 _ -> error "compileTexture2DRGBAF: ImageY8" - _ -> error "compileTexture2DRGBAF: 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/Backend/GL/Input.hs b/Backend/GL/Input.hs deleted file mode 100644 index f92a9c9..0000000 --- a/Backend/GL/Input.hs +++ /dev/null @@ -1,387 +0,0 @@ -module Backend.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.Rendering.OpenGL.Raw.Core33 - -import IR as IR -import Linear as IR -import Backend.GL.Type as T -import Backend.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) - -mkGLPipelineInput :: PipelineSchema -> IO GLPipelineInput -mkGLPipelineInput 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 $ GLPipelineInput - { schema = sch - , slotMap = sm - , slotVector = slotV - , objSeed = seed - , uniformSetter = setters - , uniformSetup = unis - , screenSize = size - , pipelines = ppls - } - --- object -addObject :: GLPipelineInput -> 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 :: GLPipelineInput -> 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 :: GLPipelineInput -> 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 :: GLPipelineInput -> Word -> Word -> IO () -setScreenSize p w h = writeIORef (screenSize p) (w,h) - -sortSlotObjects :: GLPipelineInput -> 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 - TWord -> setIntAttrib 1 - TV2U -> setIntAttrib 2 - TV3U -> setIntAttrib 3 - TV4U -> setIntAttrib 4 - TInt -> setIntAttrib 1 - TV2I -> setIntAttrib 2 - TV3I -> setIntAttrib 3 - TV4I -> setIntAttrib 4 - TFloat -> setFloatAttrib 1 - TV2F -> setFloatAttrib 2 - TV3F -> setFloatAttrib 3 - TV4F -> setFloatAttrib 4 - TM22F -> setFloatAttrib 4 - TM23F -> setFloatAttrib 6 - TM24F -> setFloatAttrib 8 - TM32F -> setFloatAttrib 6 - TM33F -> setFloatAttrib 9 - TM34F -> setFloatAttrib 12 - TM42F -> setFloatAttrib 8 - TM43F -> setFloatAttrib 12 - TM44F -> 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/Backend/GL/Mesh.hs b/Backend/GL/Mesh.hs deleted file mode 100644 index 4539622..0000000 --- a/Backend/GL/Mesh.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Backend.GL.Mesh ( - loadMesh', - loadMesh, - saveMesh, - addMesh, - compileMesh, - 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 Backend.GL -import Backend.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 = compileMesh =<< loadMesh' n - -saveMesh :: String -> Mesh -> IO () -saveMesh n m = LB.writeFile n (encode m) - -addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object -addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = 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 -addMesh _ _ _ _ = fail "addMesh: 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 TFloat b i 0 (V.length v) -meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v) -meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v) -meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v) -meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v) -meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v) -meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v) -meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v) -meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v) - -{- -updateBuffer :: Buffer -> [(Int,Array)] -> IO () - - | Stream - { streamType :: StreamType - , streamBuffer :: b - , streamArrIdx :: Int - , streamStart :: Int - , streamLength :: Int - } - --- stream of index values (for index buffer) -data IndexStream b - = IndexStream - { indexBuffer :: b - , indexArrIdx :: Int - , indexStart :: Int - , indexLength :: Int - } --} -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 --} - -compileMesh :: Mesh -> IO Mesh -compileMesh (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) - -compileMesh 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/Backend/GL/Type.hs b/Backend/GL/Type.hs deleted file mode 100644 index f420e74..0000000 --- a/Backend/GL/Type.hs +++ /dev/null @@ -1,541 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} -module Backend.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.Rendering.OpenGL.Raw.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 - - GLPipelineInput can be attached to GLPipeline --} - -{- - 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 GLPipelineInput - = GLPipelineInput - { 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 GLPipeline)) -- 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 :: GLPipelineInput - , icSlotMapPipelineToInput :: Vector SlotName -- GLPipeline to GLPipelineInput slot name mapping - , icSlotMapInputToPipeline :: Vector (Maybe SlotName) -- GLPipelineInput to GLPipeline slot name mapping - } - -data GLStream - = GLStream - { glStreamCommands :: IORef [GLObjectCommand] - , glStreamPrimitive :: Primitive - , glStreamAttributes :: Trie (Stream Buffer) - , glStreamProgram :: ProgramName - } - -data GLPipeline - = GLPipeline - { 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 - = TWord - | TV2U - | TV3U - | TV4U - | TInt - | TV2I - | TV3I - | TV4I - | TFloat - | TV2F - | TV3F - | TV4F - | TM22F - | TM23F - | TM24F - | TM32F - | TM33F - | TM34F - | TM42F - | TM43F - | TM44F - deriving (Show,Eq,Ord) - -toStreamType :: InputType -> Maybe StreamType -toStreamType Word = Just TWord -toStreamType V2U = Just TV2U -toStreamType V3U = Just TV3U -toStreamType V4U = Just TV4U -toStreamType Int = Just TInt -toStreamType V2I = Just TV2I -toStreamType V3I = Just TV3I -toStreamType V4I = Just TV4I -toStreamType Float = Just TFloat -toStreamType V2F = Just TV2F -toStreamType V3F = Just TV3F -toStreamType V4F = Just TV4F -toStreamType M22F = Just TM22F -toStreamType M23F = Just TM23F -toStreamType M24F = Just TM24F -toStreamType M32F = Just TM32F -toStreamType M33F = Just TM33F -toStreamType M34F = Just TM34F -toStreamType M42F = Just TM42F -toStreamType M43F = Just TM43F -toStreamType M44F = Just TM44F -toStreamType _ = Nothing - -fromStreamType :: StreamType -> InputType -fromStreamType TWord = Word -fromStreamType TV2U = V2U -fromStreamType TV3U = V3U -fromStreamType TV4U = V4U -fromStreamType TInt = Int -fromStreamType TV2I = V2I -fromStreamType TV3I = V3I -fromStreamType TV4I = V4I -fromStreamType TFloat = Float -fromStreamType TV2F = V2F -fromStreamType TV3F = V3F -fromStreamType TV4F = V4F -fromStreamType TM22F = M22F -fromStreamType TM23F = M23F -fromStreamType TM24F = M24F -fromStreamType TM32F = M32F -fromStreamType TM33F = M33F -fromStreamType TM34F = M34F -fromStreamType TM42F = M42F -fromStreamType TM43F = M43F -fromStreamType TM44F = 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 _ -> TWord - ConstV2U _ -> TV2U - ConstV3U _ -> TV3U - ConstV4U _ -> TV4U - ConstInt _ -> TInt - ConstV2I _ -> TV2I - ConstV3I _ -> TV3I - ConstV4I _ -> TV4I - ConstFloat _ -> TFloat - ConstV2F _ -> TV2F - ConstV3F _ -> TV3F - ConstV4F _ -> TV4F - ConstM22F _ -> TM22F - ConstM23F _ -> TM23F - ConstM24F _ -> TM24F - ConstM32F _ -> TM32F - ConstM33F _ -> TM33F - ConstM34F _ -> TM34F - ConstM42F _ -> TM42F - ConstM43F _ -> TM43F - ConstM44F _ -> TM44F - 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/Backend/GL/Util.hs b/Backend/GL/Util.hs deleted file mode 100644 index 75c2e3a..0000000 --- a/Backend/GL/Util.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Backend.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.Rendering.OpenGL.Raw.Core33 -import Linear -import IR -import Backend.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 = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I] - 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