GPipe 1.1.7 → 1.2.0
raw patch · 6 files changed
+144/−123 lines, 6 filesdep ~GLUTdep ~OpenGLdep ~Vec-BooleanPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: GLUT, OpenGL, Vec-Boolean, base, containers, list-tries
API changes (from Hackage documentation)
- Graphics.GPipe.FrameBuffer: newWindow :: String -> Vec2 Int -> Vec2 Int -> (IO (FrameBuffer c d s)) -> (Window -> IO ()) -> IO ()
+ Graphics.GPipe.FrameBuffer: newWindow :: String -> Vec2 Int -> Vec2 Int -> (Vec2 Int -> IO (FrameBuffer c d s)) -> (Window -> IO ()) -> IO ()
Files
- GPipe.cabal +58/−41
- src/GPUStream.hs +37/−36
- src/InputAssembler.hs +31/−31
- src/OutputMerger.hs +4/−3
- src/Rasterizer.hs +13/−9
- src/Shader.hs +1/−3
GPipe.cabal view
@@ -1,14 +1,11 @@ name: GPipe-version: 1.1.7+version: 1.2.0 cabal-version: >= 1.2.3 build-type: Simple license: BSD3-license-file: "" copyright: Tobias Bexelius maintainer: Tobias Bexelius-build-depends: containers == 0.2.0.1, mtl -any, list-tries -any,- GLUT >=2.2.2.0, OpenGL >=2.4.0.1,- Boolean == 0.0.1, Vec == 0.9.6, Vec-Boolean >= 1.0.2, base >= 4 && < 5+ stability: Experimental homepage: http://www.haskell.org/haskellwiki/GPipe package-url: http://hackage.haskell.org/package/GPipe@@ -20,41 +17,61 @@ instances of GPipes classes, it's possible to use additional datatypes on the GPU. . You'll need full OpenGL 2.1 support, including GLSL 1.20 to use GPipe. Thanks to OpenGLRaw, you may still build GPipe programs on machines lacking this support.+ .+ Note on installation: If you have cabal installed list-tries with flag containers03 (you should) then use the same flag when installing GPipe. This flag is false by default since it's+ false for list-tries as well, and I want Hackage to be able to build it.+ category: Graphics author: Tobias Bexelius-tested-with: GHC ==6.10.3-data-files:-data-dir: ""-extra-source-files:-extra-tmp-files:-exposed-modules: Graphics.GPipe Graphics.GPipe.Format- Graphics.GPipe.FrameBuffer Graphics.GPipe.Stream- Graphics.GPipe.Texture Graphics.GPipe.Stream.Fragment- Graphics.GPipe.Stream.Primitive-exposed: True-buildable: True-build-tools:-cpp-options:-cc-options:-ld-options:-pkgconfig-depends:-frameworks:-c-sources:-extensions: ParallelListComp MultiParamTypeClasses- NoMonomorphismRestriction ScopedTypeVariables FlexibleContexts- FlexibleInstances EmptyDataDecls GeneralizedNewtypeDeriving- TypeFamilies TypeOperators-extra-libraries:-extra-lib-dirs:-includes:-install-includes:-include-dirs:-hs-source-dirs: src-other-modules: Formats GPUStream InputAssembler OutputMerger- Rasterizer Resources Shader Textures-ghc-prof-options:-ghc-shared-options:-ghc-options:-hugs-options:-nhc98-options:-jhc-options:++Flag containers03+ Default: False++Library+ if flag(containers03)+ build-depends: containers >= 0.3 && < 0.4, + mtl -any, + list-tries >= 0.1 && < 0.2,+ GLUT ==2.2.2.0,+ OpenGL ==2.4.0.1,+ Boolean == 0.0.1,+ Vec == 0.9.6, + Vec-Boolean == 1.0.2,+ base >= 3 && < 5+ else+ build-depends: containers >= 0.2 && < 0.3,+ mtl -any, + list-tries >= 0.1 && < 0.2,+ GLUT ==2.2.2.0,+ OpenGL ==2.4.0.1,+ Boolean == 0.0.1,+ Vec == 0.9.6, + Vec-Boolean == 1.0.2,+ base >= 3 && < 5+ + exposed-modules: Graphics.GPipe+ Graphics.GPipe.Stream+ Graphics.GPipe.Stream.Primitive+ Graphics.GPipe.Stream.Fragment+ Graphics.GPipe.FrameBuffer+ Graphics.GPipe.Texture+ Graphics.GPipe.Format+ other-modules: Formats + GPUStream + InputAssembler + OutputMerger+ Rasterizer + Resources + Shader + Textures+ extensions: ParallelListComp+ MultiParamTypeClasses+ NoMonomorphismRestriction + ScopedTypeVariables + FlexibleContexts+ FlexibleInstances + EmptyDataDecls + GeneralizedNewtypeDeriving+ TypeFamilies + TypeOperators+ hs-source-dirs: src
src/GPUStream.hs view
@@ -41,7 +41,7 @@ -- | A stream of primitives built by vertices on the GPU. The first parameter is the primitive type (currently 'Triangle', 'Line' or 'Point') and the second the -- the type of each primitives' vertices' type (built up of atoms of type 'Vertex'). -newtype PrimitiveStream p a = PrimitiveStream [(PrimitiveStreamDesc, a)] +data PrimitiveStream p a = PrimitiveStreamNoShader PrimitiveStreamDesc a | PrimitiveStreamShader [(PrimitiveStreamDesc, a)] -- | A stream of fragments on the GPU, parameterized on the fragments type -- (built up of atoms of type 'Fragment'). newtype FragmentStream a = FragmentStream [(FragmentStreamDesc, Fragment Bool, a)] @@ -49,17 +49,24 @@ type VertexPosition = Vec4 (Vertex Float) data CullMode = CullNone | CullFront | CullBack deriving (Eq,Ord,Bounded,Enum,Show) data VertexSetup = VertexSetup [[Float]] | IndexedVertexSetup [[Float]] [Int] deriving (Eq,Ord,Show) -type PrimitiveStreamDesc = (GL.PrimitiveMode, VertexSetup) +type PrimitiveStreamDesc = [(GL.PrimitiveMode, VertexSetup)] type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, Vec4 (Vertex Float)) instance Functor (PrimitiveStream p) where - fmap f (PrimitiveStream a) = PrimitiveStream $ map (second f) a + fmap f (PrimitiveStreamNoShader [] a) = PrimitiveStreamNoShader [] $ f a + fmap f (PrimitiveStreamNoShader xs a) = PrimitiveStreamShader [(xs, f a)] + fmap f (PrimitiveStreamShader xs) = PrimitiveStreamShader $ map (second f) xs instance Functor FragmentStream where fmap f (FragmentStream a) = FragmentStream $ map (\(x,y,z) -> (x, y, f z)) a instance Monoid (PrimitiveStream p a) where - mempty = PrimitiveStream [] - PrimitiveStream a `mappend` PrimitiveStream b = PrimitiveStream (a ++ b) + mempty = PrimitiveStreamNoShader [] undefined + PrimitiveStreamNoShader [] _ `mappend` a = a + a `mappend` PrimitiveStreamNoShader [] _ = a + PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamNoShader ys _ = PrimitiveStreamNoShader (xs ++ ys) a -- Optimization! + PrimitiveStreamShader xs `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ xs ++ ys + PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ (xs, a):ys + PrimitiveStreamShader xs `mappend` PrimitiveStreamNoShader ys a = PrimitiveStreamShader $ xs ++ [(ys, a)] instance Monoid (FragmentStream a) where mempty = FragmentStream [] FragmentStream a `mappend` FragmentStream b = FragmentStream (a ++ b) @@ -109,55 +116,49 @@ layerMapM_ f (x:xs) io = layerMapM_ f xs (f x io) layerMapM_ _ [] io = io -drawCallColor (((p, vs), cull, vPos), nd, c) io = drawCall p cull vs io $ getShaders vPos nd c Nothing -drawCallColorDepth (((p, vs), cull, vPos), nd, (c,d)) io = drawCall p cull vs io $ getShaders vPos nd c (Just d) +drawCallColor ((vss, cull, vPos), nd, c) io = drawCall vss cull io $ getShaders vPos nd c Nothing +drawCallColorDepth ((vss, cull, vPos), nd, (c,d)) io = drawCall vss cull io $ getShaders vPos nd c (Just d) mapSelect = map . select where select (x:xs) ys = let (a:b) = drop x ys in a: select (map (\t-> t-x-1) xs) b select [] _ = [] -drawCall p cull (VertexSetup v) io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do - xs <- ioEvaluate (mapSelect ins v) - ins' <- ioEvaluate ins +drawCall vss cull io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do + vss' <- mapM (evalVertexSetups ins) vss vkey' <- ioEvaluate vkey fkey' <- ioEvaluate fkey s <- ioEvaluate (length ins) - vs <- ioEvaluate (length v) - vuns'<-ioEvaluate vuns - funs'<-ioEvaluate funs - cull'<-ioEvaluate cull - p'<-ioEvaluate p + vuns' <- ioEvaluate vuns + funs' <- ioEvaluate funs + cull' <- ioEvaluate cull io (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s - vb <- createVertexBuffer xs ins' v useProgramResource pr useUniforms vu vuns' useUniforms fu funs' - liftIO $ do useCull cull' - drawVertexBuffer p' vb vs + liftIO $ useCull cull' + mapM_ (drawVertexSetups ins) vss' -drawCall p cull (IndexedVertexSetup v i) io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do - i' <- ioEvaluate i +evalVertexSetups ins (p, VertexSetup v) = do xs <- ioEvaluate (mapSelect ins v) - ins' <- ioEvaluate ins - vkey' <- ioEvaluate vkey - fkey' <- ioEvaluate fkey - s <- ioEvaluate (length ins) vs <- ioEvaluate (length v) - vuns'<-ioEvaluate vuns - funs'<-ioEvaluate funs - cull'<-ioEvaluate cull - p'<-ioEvaluate p - io - (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s + p' <- ioEvaluate p + return (v, xs, p', vs, Nothing) +evalVertexSetups ins (p, IndexedVertexSetup v i) = do + xs <- ioEvaluate (mapSelect ins v) + i' <- ioEvaluate i + vs <- ioEvaluate (length v) + p' <- ioEvaluate p + return (v, xs, p', vs, Just i') + +drawVertexSetups ins (v, xs, p', vs, Nothing) = do + vb <- createVertexBuffer xs ins v + liftIO $ drawVertexBuffer p' vb vs +drawVertexSetups ins (v, xs, p', vs, Just i') = do ib <- createIndexBuffer i' vs - vb <- createVertexBuffer xs ins' v - useProgramResource pr - useUniforms vu vuns' - useUniforms fu funs' - liftIO $ do useCull cull' - drawIndexVertexBuffer p' vb ib + vb <- createVertexBuffer xs ins v + liftIO $ drawIndexVertexBuffer p' vb ib useCull CullNone = cullFace $= Nothing useCull CullFront = cullFace $= Just Front
src/InputAssembler.hs view
@@ -32,9 +32,12 @@ -- Create your own instances in terms of the existing ones, e.g. convert your vertex data to 'Float's, -- turn them into 'Vertex' 'Float's with 'toVertex' and then convert them to your vertex data representation. class GPU a => VertexInput a where - -- | Turns an ordinary value into a vertex value in the 'InputAssembler' monad. This should not be strict on its argument.- -- Its definition should also always use the same series of 'toVertex' calls to convert values of the same type. This unfortunatly- -- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). + -- | Turns an ordinary value into a vertex value in the 'InputAssembler' monad. The following rule must be satisfied:+ -- + -- > toVertex undefined >> a = a + -- + -- This ensures that its definition always use the same series of 'toVertex' calls to convert values of the same type.+ -- This unfortunatly rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). toVertex :: CPU a -> InputAssembler a instance VertexInput (Vertex Float) where @@ -42,27 +45,27 @@ modify (a:) return $ inputVertex x instance VertexInput () where - toVertex () = return () + toVertex ~() = return () instance (VertexInput a,VertexInput b) => VertexInput (a,b) where - toVertex (a, b) = do a' <- toVertex a - b' <- toVertex b - return (a', b') + toVertex ~(a, b) = do a' <- toVertex a + b' <- toVertex b + return (a', b') instance (VertexInput a,VertexInput b,VertexInput c) => VertexInput (a,b,c) where - toVertex (a, b, c) = do a' <- toVertex a - b' <- toVertex b - c' <- toVertex c - return (a', b', c') + toVertex ~(a, b, c) = do a' <- toVertex a + b' <- toVertex b + c' <- toVertex c + return (a', b', c') instance (VertexInput a,VertexInput b,VertexInput c,VertexInput d) => VertexInput (a,b,c,d) where - toVertex (a, b, c, d) = do a' <- toVertex a - b' <- toVertex b - c' <- toVertex c - d' <- toVertex d - return (a', b', c', d')+ toVertex ~(a, b, c, d) = do a' <- toVertex a + b' <- toVertex b + c' <- toVertex c + d' <- toVertex d + return (a', b', c', d') instance (VertexInput a, VertexInput b) => VertexInput (a:.b) where- toVertex (a:.b) = do a' <- toVertex a - b' <- toVertex b - return $ a':.b'+ toVertex ~(a:.b) = do a' <- toVertex a + b' <- toVertex b + return $ a':.b' -- | Converts a list of values to a 'PrimitiveStream', using a specified 'Primitive' type. -- This function is lazy in the aspect that if parts of the values aren't used on the GPU, they won't@@ -71,9 +74,9 @@ => p -- ^ The primitive type. -> [CPU a] -- ^ A list of vertices, with the layout specified by the primitive type. -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'. -toGPUStream _ [] = PrimitiveStream [] +toGPUStream _ [] = PrimitiveStreamNoShader [] undefined toGPUStream p xs = let (a, fs) = getVertexInput xs - in PrimitiveStream [((getPrimitiveMode p, VertexSetup fs), a)] + in PrimitiveStreamNoShader [(getPrimitiveMode p, VertexSetup fs)] a -- | Converts a list of values to a 'PrimitiveStream', using a specified 'Primitive' type and an index list. -- This will use index buffer objects on the GPU, and is recommended if several primitives share vertices.@@ -82,11 +85,11 @@ toIndexedGPUStream :: (VertexInput a, Primitive p) => p -- ^ The primitive type. -> [CPU a] -- ^ A list of vertices.- -> [Int] -- ^A list of indexes into the vertex list, with the layout specified by the primitive type.+ -> [Int] -- ^ A list of indexes into the vertex list, with the layout specified by the primitive type. -> PrimitiveStream p a -- ^ The resulting 'PrimitiveStream'. -toIndexedGPUStream _ [] _ = PrimitiveStream [] +toIndexedGPUStream _ [] _ = PrimitiveStreamNoShader [] undefined toIndexedGPUStream p xs i = let (a, fs) = getVertexInput xs - in PrimitiveStream [((getPrimitiveMode p, IndexedVertexSetup fs i), a)] + in PrimitiveStreamNoShader [(getPrimitiveMode p, IndexedVertexSetup fs i)] a -------------------------------------- @@ -94,10 +97,7 @@ -- getVertexInput :: forall a. VertexInput a => [CPU a] -> (a, [[Float]]) -getVertexInput (x:xs) = let (a, s) = readInput x - readInput :: CPU a -> (a, [Float]) - readInput = flip runState [] . revState . fromInputAssembler . toVertex - revState m = do x <- m - modify reverse - return x - in (a, s : map (snd . readInput) xs) +getVertexInput xs = let readInput :: CPU a -> (a, [Float]) + readInput = flip runState [] . fromInputAssembler . toVertex + e = "The method toVertex of an instance of Graphics.GPipe.Stream.Primitive.VertexInput is strict in it's input. Remember that 'toVertex undefined >> a' must be equal to 'a'. Contact the GPipe author for more information." + in (fst $ readInput (error e :: CPU a), map (reverse . snd . readInput) xs)
src/OutputMerger.hs view
@@ -405,7 +405,7 @@ newWindow :: String -- ^ The window title -> Vec2 Int -- ^ The window position -> Vec2 Int -- ^ The window size- -> (IO (FrameBuffer c d s)) -- ^ This 'IO' action will be run every time the window needs to be redrawn, and the resulting 'FrameBuffer' will be drawn in the window.+ -> (Vec2 Int -> IO (FrameBuffer c d s)) -- ^ This function is evaluated every time the window needs to be redrawn, and the resulting 'FrameBuffer' will be drawn in the window. The parameter is the current size of the window. -> (Window -> IO ()) -- ^ Extra optional initialization of the window. The provided 'Window' should not be used outside this function. -> IO () newWindow name (x:.y:.()) (w:.h:.()) f xio = @@ -415,8 +415,9 @@ w <- GLUT.createWindow name xio w newContextCache w - displayCallback $= do FrameBuffer io <- f - cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size + displayCallback $= do cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size + let Size x y = contextViewPort cache + FrameBuffer io <- f (fromIntegral x :. fromIntegral y :. ()) runReaderT io cache GLUT.swapBuffers reshapeCallback $= Just (changeContextSize w)
src/Rasterizer.hs view
@@ -35,9 +35,7 @@ class GPU a => VertexOutput a where -- | The corresponding type in the 'FragmentStream' after rasterization. type FragmentInput a- -- | Turns a vertex value into a fragment value in the 'Rasterizer' monad. This should not be strict on its argument.- -- Its definition should also always use the same series of 'toFragment' calls to convert values of the same type. This unfortunatly- -- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). + -- | Turns a vertex value into a fragment value in the 'Rasterizer' monad. toFragment :: a -> Rasterizer (FragmentInput a) instance VertexOutput (Vertex Float) where @@ -76,24 +74,30 @@ rasterizeFront :: VertexOutput a => PrimitiveStream p (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated. -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. -rasterizeFront (PrimitiveStream []) = FragmentStream [] -rasterizeFront (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs +rasterizeFront x = case x of + (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs + (PrimitiveStreamNoShader [] _) -> FragmentStream [] + (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, pos), true, getFragmentInput va) -- | Rasterize both sides of triangles with vertices containing canonical view coordinates into fragments, also returning the primitives side in the fragments. rasterizeFrontAndBack :: VertexOutput a => PrimitiveStream Triangle (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated. -> FragmentStream (Fragment Bool, FragmentInput a) -- ^ The resulting fragment stream with fragments containing a bool saying if the primitive was front facing and the interpolated values. -rasterizeFrontAndBack (PrimitiveStream []) = FragmentStream [] -rasterizeFrontAndBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs +rasterizeFrontAndBack x = case x of + (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs + (PrimitiveStreamNoShader [] _) -> FragmentStream [] + (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, pos), true, (fragmentFrontFacing, getFragmentInput va)) -- | Rasterize back side of triangles with vertices containing canonical view coordinates into fragments. rasterizeBack :: VertexOutput a => PrimitiveStream Triangle (VertexPosition, a) -- ^ The primitive stream with vertices containing canonical view coordinates and data to be interpolated. -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. -rasterizeBack (PrimitiveStream []) = FragmentStream [] -rasterizeBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs +rasterizeBack x = case x of + (PrimitiveStreamShader xs) -> FragmentStream $ map rasterizeOne xs + (PrimitiveStreamNoShader [] _) -> FragmentStream [] + (PrimitiveStreamNoShader xs a) -> FragmentStream [rasterizeOne (xs, a)] where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, pos), true, getFragmentInput va) --------------------------------------
src/Shader.hs view
@@ -55,9 +55,7 @@ infixl 7 `mod'` -- | Denotes a type on the GPU, that can be moved there from the CPU (through the internal use of uniforms).--- Use the existing instances of this class to create new ones. Note that 'toGPU' should not be strict on its argument.--- Its definition should also always use the same series of 'toGPU' calls to convert values of the same type. This unfortunatly--- rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided).+-- Use the existing instances of this class to create new ones. class GPU a where -- | The type on the CPU. type CPU a