diff --git a/GPipe.cabal b/GPipe.cabal --- a/GPipe.cabal +++ b/GPipe.cabal @@ -1,5 +1,5 @@ name: GPipe -version: 2.0.1 +version: 2.0.2 cabal-version: >= 1.8 build-type: Simple author: Tobias Bexelius @@ -10,6 +10,7 @@ stability: Experimental synopsis: Typesafe functional GPU graphics programming homepage: http://tobbebex.blogspot.se/ +bug-reports: https://github.com/tobbebex/GPipe-Core/issues description: A typesafe API based on the conceptual model of OpenGl, but without the imperative state machine. Aims to be as close to the raw OpenGl performance as possible, without compromising type safety or functional style. @@ -26,7 +27,7 @@ Boolean >= 0.2 && <0.3, hashtables >= 1.2 && < 1.3, gl >= 0.7 && < 0.8, - linear >= 1.18 && < 1.20 + linear >= 1.18 && < 1.21 exposed-modules: Graphics.GPipe, Graphics.GPipe.Buffer, diff --git a/src/Graphics/GPipe/Internal/Buffer.hs b/src/Graphics/GPipe/Internal/Buffer.hs --- a/src/Graphics/GPipe/Internal/Buffer.hs +++ b/src/Graphics/GPipe/Internal/Buffer.hs @@ -46,6 +46,9 @@ import Linear.V2 import Linear.V1 import Linear.V0 +import Linear.Plucker (Plucker(..)) +import Linear.Quaternion (Quaternion(..)) +import Linear.Affine (Point(..)) -- | The class that constraints which types can live in a buffer. class BufferFormat f where @@ -265,6 +268,30 @@ toBuffer = proc ~(a, b, c, d) -> do ((a', b', c'), d') <- toBuffer -< ((a, b, c), d) returnA -< (a', b', c', d') + +instance BufferFormat a => BufferFormat (Quaternion a) where + type HostFormat (Quaternion a) = Quaternion (HostFormat a) + toBuffer = proc ~(Quaternion a v) -> do + a' <- toBuffer -< a + v' <- toBuffer -< v + returnA -< Quaternion a' v' + +instance (BufferFormat (f a), BufferFormat a, HostFormat (f a) ~ f (HostFormat a)) => BufferFormat (Point f a) where + type HostFormat (Point f a) = Point f (HostFormat a) + toBuffer = proc ~(P a) -> do + a' <- toBuffer -< a + returnA -< P a' + +instance BufferFormat a => BufferFormat (Plucker a) where + type HostFormat (Plucker a) = Plucker (HostFormat a) + toBuffer = proc ~(Plucker a b c d e f) -> do + a' <- toBuffer -< a + b' <- toBuffer -< b + c' <- toBuffer -< c + d' <- toBuffer -< d + e' <- toBuffer -< e + f' <- toBuffer -< f + returnA -< Plucker a' b' c' d' e' f' -- | Create a buffer with a specified number of elements. newBuffer :: (MonadIO m, BufferFormat b) => Int -> ContextT w os f m (Buffer os b) diff --git a/src/Graphics/GPipe/Internal/Compiler.hs b/src/Graphics/GPipe/Internal/Compiler.hs --- a/src/Graphics/GPipe/Internal/Compiler.hs +++ b/src/Graphics/GPipe/Internal/Compiler.hs @@ -46,8 +46,8 @@ data RenderIOState s = RenderIOState { - uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()), - samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()), + uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()), -- TODO: Return buffer name here when we start writing to buffers during rendering (transform feedback, buffer textures) + samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO Int), -- IO returns texturename for validating that it isnt used as render target rasterizationNameToRenderIO :: Map.IntMap (s -> IO ()), inputArrayToRenderIOs :: Map.IntMap (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())]) } @@ -66,7 +66,7 @@ -- | May throw a GPipeException -compile :: (Monad m, MonadIO m, MonadException m) => [IO (Drawcall s)] -> RenderIOState s -> ContextT w os f m (ContextData -> s -> IO (Maybe String)) +compile :: (Monad m, MonadIO m, MonadException m) => [IO (Drawcall s)] -> RenderIOState s -> ContextT w os f m (ContextData -> s -> Asserter Int -> IO (Maybe String)) compile dcs s = do drawcalls <- liftIO $ sequence dcs -- IO only for SNMap (maxUnis, @@ -111,8 +111,9 @@ fAdd <- getContextFinalizerAdder let (errs, ret) = partitionEithers compRet (pnames, fs) = unzip ret - fr cd x = foldl (\ io f -> do mErr <- io - mErr2 <- f x cd fAdd + fr cd x asserter = foldl (\ io f -> do + mErr <- io + mErr2 <- f x asserter cd fAdd return $ mErr <> mErr2) (return Nothing) fs @@ -170,12 +171,12 @@ glUniform1i six (fromIntegral bind) pNameRef <- newIORef pName - return $ Right (pNameRef, \x cd fAdd -> do + return $ Right (pNameRef, \x asserter cd fAdd -> do -- Drawing with program -- pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef glUseProgram pName' - bindUni x - bindSamp x + bindUni x return + bindSamp x asserter bindRast x let (mfbokeyio, blendio) = fboSetup x blendio @@ -247,16 +248,18 @@ orderedUnion xs [] = xs orderedUnion [] ys = ys +type Asserter x = x -> IO () -- Used to assert we may use textures + -- Optimization, save gl calls to already bound buffers/samplers -makeBind :: Map.IntMap Int -> Map.IntMap (s -> Binding -> IO ()) -> [(Int, Int)] -> (s -> IO (), Map.IntMap Int) +makeBind :: Map.IntMap Int -> Map.IntMap (s -> Binding -> IO x) -> [(Int, Int)] -> (s -> Asserter x -> IO (), Map.IntMap Int) makeBind m iom ((n,b):xs) = (g, m'') where (f, m') = makeBind m iom xs (io, m'') = case Map.lookup b m' of - Just x | x == n -> (const $ return (), m') - _ -> (\s -> (iom ! n) s b, Map.insert b n m') + Just x | x == n -> (\_ _ -> return (), m') + _ -> (\s asserter -> (iom ! n) s b >>= asserter, Map.insert b n m') g s = f s >> io s -makeBind m _ [] = (const $ return (), m) +makeBind m _ [] = (\_ _ -> return (), m) allocate :: Int -> [[Int]] -> [[Int]] allocate mx = allocate' Map.empty [] diff --git a/src/Graphics/GPipe/Internal/Context.hs b/src/Graphics/GPipe/Internal/Context.hs --- a/src/Graphics/GPipe/Internal/Context.hs +++ b/src/Graphics/GPipe/Internal/Context.hs @@ -23,7 +23,8 @@ getFBO, setFBO, ContextData, VAOKey(..), FBOKey(..), FBOKeys(..), - Render(..), render, getContextBuffersSize + Render(..), render, getContextBuffersSize, + registerRenderWriteTexture ) where @@ -34,6 +35,7 @@ import Control.Monad.Trans.Class import Control.Applicative (Applicative, (<$>)) import Data.Typeable (Typeable) +import qualified Data.IntSet as Set import qualified Data.Map.Strict as Map import Graphics.GL.Core33 import Graphics.GL.Types @@ -46,21 +48,22 @@ import Linear.V2 (V2(V2)) import Control.Monad.Trans.Error import Control.Exception (throwIO) +import Control.Monad.Trans.State.Strict type ContextFactory c ds w = ContextFormat c ds -> IO (ContextHandle w) data ContextHandle w = ContextHandle { - -- | Like a 'ContextFactory' but creates a context that shares the object space of this handle's context + -- | Like a 'ContextFactory' but creates a context that shares the object space of this handle's context. Called from same thread as created the initial context. newSharedContext :: forall c ds. ContextFormat c ds -> IO (ContextHandle w), -- | Run an OpenGL IO action in this context, returning a value to the caller. The thread calling this may not be the same creating the context. contextDoSync :: forall a. IO a -> IO a, -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. The thread calling this may not be the same creating the context (for finalizers it is most definetly not). contextDoAsync :: IO () -> IO (), - -- | Swap the front and back buffers in the context's default frame buffer. This will be called as an argument to 'contextDoSync' so you can assume it is run on the right GL thread. + -- | Swap the front and back buffers in the context's default frame buffer. Called from same thread as created context. contextSwap :: IO (), - -- | Get the current size of the context's default framebuffer (which may change if the window is resized). This will be called as an argument to 'contextDoSync' so you can assume it is run on the right GL thread. + -- | Get the current size of the context's default framebuffer (which may change if the window is resized). Called from same thread as created context. contextFrameBufferSize :: IO (Int, Int), - -- | Delete this context and close any associated window. The thread calling this may not be the same creating the context. + -- | Delete this context and close any associated window. Called from same thread as created context. contextDelete :: IO (), -- | A value representing the context's window. It is recommended that this is an opaque type that doesn't have any exported functions. Instead, provide 'ContextT' actions -- that are implemented in terms of 'withContextWindow' to expose any functionality to the user that need a reference the context's window. @@ -114,8 +117,8 @@ return (h,cd) ) (\(h,cd) -> do cds <- ContextT $ asks (snd . snd) - liftIO $ removeContextData cds cd - liftIO $ contextDelete h) + liftIO $ do removeContextData cds cd + contextDelete h) $ \(h,cd) -> do cds <- ContextT $ asks (snd . snd) let ContextT i = initGlState rs = (h, (cd, cds)) @@ -144,27 +147,30 @@ -- This call may block if vsync is enabled in the system and/or too many frames are outstanding. -- After this call, the context window content is undefined and should be cleared at earliest convenience using 'clearContextColor' and friends. swapContextBuffers :: MonadIO m => ContextT w os f m () -swapContextBuffers = ContextT (asks fst) >>= (\c -> liftIO $ contextDoSync c $ contextSwap c) +swapContextBuffers = ContextT (asks fst) >>= (\c -> liftIO $ contextSwap c) type ContextDoAsync = IO () -> IO () -- | A monad in which shaders are run. -newtype Render os f a = Render (ErrorT String (ReaderT (ContextDoAsync, (ContextData, SharedContextDatas)) IO) a) deriving (Monad, Applicative, Functor) +newtype Render os f a = Render (ErrorT String (StateT Set.IntSet (ReaderT (ContextDoAsync, (ContextData, SharedContextDatas)) IO)) a) deriving (Monad, Applicative, Functor) -- | Run a 'Render' monad, that may have the effect of the context window or textures being drawn to. -- -- May throw a 'GPipeException' if a combination of draw images (FBO) used by this render call is unsupported by the graphics driver render :: (MonadIO m, MonadException m) => Render os f () -> ContextT w os f m () render (Render m) = do c <- ContextT ask - eError <- liftIO $ contextDoSync (fst c) $ runReaderT (runErrorT m) (contextDoAsync (fst c), snd c) + eError <- liftIO $ contextDoSync (fst c) $ runReaderT (evalStateT (runErrorT m) Set.empty) (contextDoAsync (fst c), snd c) case eError of Left s -> liftIO $ throwIO $ GPipeException s _ -> return () +registerRenderWriteTexture :: Int -> Render os f () +registerRenderWriteTexture x = Render $ lift $ modify $ Set.insert x + -- | Return the current size of the context frame buffer. This is needed to set viewport size and to get the aspect ratio to calculate projection matrices. getContextBuffersSize :: MonadIO m => ContextT w os f m (V2 Int) getContextBuffersSize = ContextT $ do c <- asks fst - (x,y) <- liftIO $ contextDoSync c $ contextFrameBufferSize c + (x,y) <- liftIO $ contextFrameBufferSize c return $ V2 x y -- | Use the context window handle, which type is specific to the window system used. This handle shouldn't be returned from this function @@ -173,7 +179,7 @@ liftIO $ contextDoSync c $ f (contextWindow c) getRenderContextFinalizerAdder :: Render os f (IORef a -> IO () -> IO ()) -getRenderContextFinalizerAdder = do f <- Render (lift $ asks fst) +getRenderContextFinalizerAdder = do f <- Render (lift $ lift $ asks fst) return $ \k m -> void $ mkWeakIORef k (f m) -- | This kind of exception may be thrown from GPipe when a GPU hardware limit is reached (for instance, too many textures are drawn to from the same 'FragmentStream') @@ -239,7 +245,7 @@ getContextData = ContextT $ asks (fst . snd) getRenderContextData :: Render os f ContextData -getRenderContextData = Render $ lift $ asks (fst . snd) +getRenderContextData = Render $ lift $ lift $ asks (fst . snd) getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint)) getVAO cd k = do (vaos, _) <- readMVar cd diff --git a/src/Graphics/GPipe/Internal/Expr.hs b/src/Graphics/GPipe/Internal/Expr.hs --- a/src/Graphics/GPipe/Internal/Expr.hs +++ b/src/Graphics/GPipe/Internal/Expr.hs @@ -27,6 +27,7 @@ import Linear.Metric import Linear.Matrix import Linear.Vector +import Linear.Conjugate import Data.Foldable (toList, Foldable) type NextTempVar = Int @@ -590,6 +591,13 @@ ifB q (V3 a b c) (V3 x y z) = V3 (ifB q a x) (ifB q b y) (ifB q c z) instance IfB a => IfB (V4 a) where ifB q (V4 a b c d) (V4 x y z w) = V4 (ifB q a x) (ifB q b y) (ifB q c z) (ifB q d w) + +instance Conjugate (S a Float) +instance Conjugate (S a Int) +instance Conjugate (S a Word) +instance TrivialConjugate (S a Float) +instance TrivialConjugate (S a Int) +instance TrivialConjugate (S a Word) -- | This class provides the GPU functions either not found in Prelude's numerical classes, or that has wrong types. -- Instances are also provided for normal 'Float's and 'Double's. diff --git a/src/Graphics/GPipe/Internal/FragmentStream.hs b/src/Graphics/GPipe/Internal/FragmentStream.hs --- a/src/Graphics/GPipe/Internal/FragmentStream.hs +++ b/src/Graphics/GPipe/Internal/FragmentStream.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows #-} +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows, FlexibleContexts #-} module Graphics.GPipe.Internal.FragmentStream where import Control.Category hiding ((.)) @@ -17,6 +17,9 @@ import Linear.V2 import Linear.V1 import Linear.V0 +import Linear.Plucker (Plucker(..)) +import Linear.Quaternion (Quaternion(..)) +import Linear.Affine (Point(..)) import Graphics.GL.Core33 @@ -194,3 +197,26 @@ d' <- toFragment -< d returnA -< (a', b', c', d') +instance FragmentInput a => FragmentInput (Quaternion a) where + type FragmentFormat (Quaternion a) = Quaternion (FragmentFormat a) + toFragment = proc ~(Quaternion a v) -> do + a' <- toFragment -< a + v' <- toFragment -< v + returnA -< Quaternion a' v' + +instance (FragmentInput (f a), FragmentInput a, FragmentFormat (f a) ~ f (FragmentFormat a)) => FragmentInput (Point f a) where + type FragmentFormat (Point f a) = Point f (FragmentFormat a) + toFragment = proc ~(P a) -> do + a' <- toFragment -< a + returnA -< P a' + +instance FragmentInput a => FragmentInput (Plucker a) where + type FragmentFormat (Plucker a) = Plucker (FragmentFormat a) + toFragment = proc ~(Plucker a b c d e f) -> do + a' <- toFragment -< a + b' <- toFragment -< b + c' <- toFragment -< c + d' <- toFragment -< d + e' <- toFragment -< e + f' <- toFragment -< f + returnA -< Plucker a' b' c' d' e' f' diff --git a/src/Graphics/GPipe/Internal/FrameBuffer.hs b/src/Graphics/GPipe/Internal/FrameBuffer.hs --- a/src/Graphics/GPipe/Internal/FrameBuffer.hs +++ b/src/Graphics/GPipe/Internal/FrameBuffer.hs @@ -335,14 +335,15 @@ -- | Fill a color image with a constant color value clearColorImage :: forall c os f. ColorRenderable c => Image c -> Color c (ColorElement c) -> Render os f () clearColorImage i c = do cd <- getRenderContextData - key <- Render $ lift $ lift $ getImageFBOKey i + key <- Render $ lift $ lift $ lift $ getImageFBOKey i let fbokey = FBOKeys [key] Nothing Nothing - mfbo <- Render $ lift $ lift $ getFBO cd fbokey + mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo + Just fbo -> Render $ lift $ lift $ lift $ do + fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ lift $ do + Render $ throwFromMaybe $ lift $ lift $ lift $ do fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr) fbo <- newIORef fbo' void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1) @@ -353,21 +354,23 @@ withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1 getFBOerror - Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST clearColor (undefined :: c) c glEnable GL_SCISSOR_TEST -- | Fill a depth image with a constant depth value (in the range [0,1]) clearDepthImage :: DepthRenderable d => Image d -> Float -> Render os f () clearDepthImage i d = do cd <- getRenderContextData - key <- Render $ lift $ lift $ getImageFBOKey i + key <- Render $ lift $ lift $ lift $ getImageFBOKey i let fbokey = FBOKeys [] (Just key) Nothing - mfbo <- Render $ lift $ lift $ getFBO cd fbokey + mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo + Just fbo -> Render $ lift $ lift $ lift $ do + fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ lift $ do + Render $ throwFromMaybe $ lift $ lift $ lift $ do fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr) fbo <- newIORef fbo' void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1) @@ -377,21 +380,23 @@ getImageBinding i GL_DEPTH_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST with (realToFrac d) $ glClearBufferfv GL_DEPTH 0 glEnable GL_SCISSOR_TEST -- | Fill a depth image with a constant stencil value clearStencilImage :: StencilRenderable s => Image s -> Int -> Render os f () clearStencilImage i s = do cd <- getRenderContextData - key <- Render $ lift $ lift $ getImageFBOKey i + key <- Render $ lift $ lift $ lift $ getImageFBOKey i let fbokey = FBOKeys [] Nothing (Just key) - mfbo <- Render $ lift $ lift $ getFBO cd fbokey + mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo + Just fbo -> Render $ lift $ lift $ lift $ do + fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ lift $ do + Render $ throwFromMaybe $ lift $ lift $ lift $ do fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr) fbo <- newIORef fbo' void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1) @@ -401,7 +406,8 @@ getImageBinding i GL_STENCIL_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0 glEnable GL_SCISSOR_TEST @@ -409,14 +415,15 @@ clearDepthStencilImage :: Image DepthStencil -> Float -> Int -> Render os f () clearDepthStencilImage i d s = do cd <- getRenderContextData - key <- Render $ lift $ lift $ getImageFBOKey i + key <- Render $ lift $ lift $ lift $ getImageFBOKey i let fbokey = FBOKeys [] Nothing (Just key) - mfbo <- Render $ lift $ lift $ getFBO cd fbokey + mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo + Just fbo -> Render $ lift $ lift $ lift $ do + fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ lift $ do + Render $ throwFromMaybe $ lift $ lift $ lift $ do fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr) fbo <- newIORef fbo' void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1) @@ -426,34 +433,39 @@ getImageBinding i GL_DEPTH_STENCIL_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s) glEnable GL_SCISSOR_TEST -- | Fill the context window's back buffer with a constant color value clearContextColor :: forall os c ds. ContextColorFormat c => Color c Float -> Render os (ContextFormat c ds) () -clearContextColor c = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 +clearContextColor c = Render $ lift $ lift $ lift $ do + glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 glDisable GL_SCISSOR_TEST withArray (map realToFrac (fromColor (undefined :: c) c ++ replicate 3 0 :: [Float])) $ glClearBufferfv GL_COLOR 0 glEnable GL_SCISSOR_TEST -- | Fill the context window's back depth buffer with a constant depth value (in the range [0,1]) clearContextDepth :: DepthRenderable ds => Float -> Render os (ContextFormat c ds) () -clearContextDepth d = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 +clearContextDepth d = Render $ lift $ lift $ lift $ do + glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 glDisable GL_SCISSOR_TEST with (realToFrac d) $ glClearBufferfv GL_DEPTH 0 glEnable GL_SCISSOR_TEST -- | Fill the context window's back stencil buffer with a constant stencil value clearContextStencil :: StencilRenderable ds => Int -> Render os (ContextFormat c ds) () -clearContextStencil s = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 +clearContextStencil s = Render $ lift $ lift $ lift $ do + glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 glDisable GL_SCISSOR_TEST with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0 glEnable GL_SCISSOR_TEST -- | Fill the context window's back depth and stencil buffers with a constant depth value (in the range [0,1]) and a constant stencil value clearContextDepthStencil :: Float -> Int -> Render os (ContextFormat c DepthStencil) () -clearContextDepthStencil d s = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 +clearContextDepthStencil d s = Render $ lift $ lift $ lift $ do + glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 glDisable GL_SCISSOR_TEST glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s) glEnable GL_SCISSOR_TEST diff --git a/src/Graphics/GPipe/Internal/PrimitiveStream.hs b/src/Graphics/GPipe/Internal/PrimitiveStream.hs --- a/src/Graphics/GPipe/Internal/PrimitiveStream.hs +++ b/src/Graphics/GPipe/Internal/PrimitiveStream.hs @@ -28,6 +28,9 @@ import Linear.V2 import Linear.V1 import Linear.V0 +import Linear.Plucker (Plucker(..)) +import Linear.Quaternion (Quaternion(..)) +import Linear.Affine (Point(..)) type DrawCallName = Int data PrimitiveStreamData = PrimitiveStreamData DrawCallName @@ -317,4 +320,31 @@ b' <- toVertex -< b c' <- toVertex -< c d' <- toVertex -< d - returnA -< V4 a' b' c' d' + returnA -< V4 a' b' c' d' + + +instance VertexInput a => VertexInput (Quaternion a) where + type VertexFormat (Quaternion a) = Quaternion (VertexFormat a) + toVertex = proc ~(Quaternion a v) -> do + a' <- toVertex -< a + v' <- toVertex -< v + returnA -< Quaternion a' v' + +instance (VertexInput (f a), VertexInput a, HostFormat (f a) ~ f (HostFormat a), VertexFormat (f a) ~ f (VertexFormat a)) => VertexInput (Point f a) where + type VertexFormat (Point f a) = Point f (VertexFormat a) + toVertex = proc ~(P a) -> do + a' <- toVertex -< a + returnA -< P a' + +instance VertexInput a => VertexInput (Plucker a) where + type VertexFormat (Plucker a) = Plucker (VertexFormat a) + toVertex = proc ~(Plucker a b c d e f) -> do + a' <- toVertex -< a + b' <- toVertex -< b + c' <- toVertex -< c + d' <- toVertex -< d + e' <- toVertex -< e + f' <- toVertex -< f + returnA -< Plucker a' b' c' d' e' f' + + diff --git a/src/Graphics/GPipe/Internal/Shader.hs b/src/Graphics/GPipe/Internal/Shader.hs --- a/src/Graphics/GPipe/Internal/Shader.hs +++ b/src/Graphics/GPipe/Internal/Shader.hs @@ -27,14 +27,15 @@ import Graphics.GPipe.Internal.Context import Graphics.GPipe.Internal.Buffer import Control.Monad.Trans.State +import qualified Control.Monad.Trans.State.Strict as StrictState import Control.Monad.IO.Class - +import qualified Data.IntSet as Set import Control.Monad.Trans.Writer.Lazy (tell, WriterT(..), runWriterT) import Control.Monad.Exception (MonadException) import Control.Applicative (Applicative, Alternative, (<|>)) import Control.Monad.Trans.Class (lift) import Data.Maybe (fromJust, isJust, isNothing) -import Control.Monad (MonadPlus) +import Control.Monad (MonadPlus, when) import Control.Monad.Trans.List (ListT(..)) import Data.Monoid (All(..), mempty) import Data.Either @@ -113,13 +114,15 @@ compileShader (Shader (ShaderM m)) = do uniAl <- liftContextIO getUniformAlignment let (adcs, ShaderState _ s) = runState (runListT (runWriterT (runReaderT m uniAl))) newShaderState - f ((disc, runF):ys) e@(cd, env) = if getAll (disc env) then runF cd env else f ys e + f ((disc, runF):ys) e@(cd, env, asserter) = if getAll (disc env) then runF cd env asserter else f ys e f [] _ = error "render: Shader evaluated to mzero\n" xs <- mapM (\(_,(dcs, disc)) -> do runF <- compile dcs s return (disc, runF)) adcs - return $ \ s -> Render $ do cd <- lift $ asks $ fst . snd - throwFromMaybe $ lift $ lift $ f xs (cd, s) + return $ \ s -> Render $ do cd <- lift $ lift $ asks $ fst . snd + texmap <- lift StrictState.get + let asserter x = when (Set.member x texmap) $ error "render: Running shader that samples from texture that currently has an image borrowed from it. Try run this shader from a separate render call where no images from the same texture are drawn to or cleared." + throwFromMaybe $ lift $ lift $ lift $ f xs (cd, s, asserter) throwFromMaybe m = do mErr <- m case mErr of diff --git a/src/Graphics/GPipe/Internal/Texture.hs b/src/Graphics/GPipe/Internal/Texture.hs --- a/src/Graphics/GPipe/Internal/Texture.hs +++ b/src/Graphics/GPipe/Internal/Texture.hs @@ -26,6 +26,7 @@ import Linear.V3 import Linear.V2 import Control.Exception (throwIO) +import Control.Monad.Trans.Class (lift) data Texture1D os a = Texture1D TexName Size1 MaxLevels data Texture1DArray os a = Texture1DArray TexName Size2 MaxLevels @@ -236,14 +237,15 @@ addFBOTextureFinalizer True tex return tex -useTex :: Integral a => TexName -> GLenum -> a -> IO () +useTex :: Integral a => TexName -> GLenum -> a -> IO Int useTex texNameRef t bind = do glActiveTexture (GL_TEXTURE0 + fromIntegral bind) n <- readIORef texNameRef glBindTexture t n + return (fromIntegral n) useTexSync :: TexName -> GLenum -> IO () useTexSync tn t = do maxUnits <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS ptr >> peek ptr) -- Use last for all sync actions, keeping 0.. for async drawcalls - useTex tn t (maxUnits-1) + void $ useTex tn t (maxUnits-1) type Level = Int @@ -781,90 +783,101 @@ newSampler1D sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec)) = sf s - in do useTex tn GL_TEXTURE_1D bind + in do n <- useTex tn GL_TEXTURE_1D bind setNoShadowMode GL_TEXTURE_1D setSamplerFilter GL_TEXTURE_1D filt setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D ec) + return n return $ Sampler1D sampId False (samplerPrefix (undefined :: c)) newSampler1DArray sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec)) = sf s - in do useTex tn GL_TEXTURE_1D_ARRAY bind + in do n <- useTex tn GL_TEXTURE_1D_ARRAY bind setNoShadowMode GL_TEXTURE_1D_ARRAY setSamplerFilter GL_TEXTURE_1D_ARRAY filt setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D_ARRAY ec) + return n return $ Sampler1DArray sampId False (samplerPrefix (undefined :: c)) newSampler2D sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec)) = sf s - in do useTex tn GL_TEXTURE_2D bind + in do n <- useTex tn GL_TEXTURE_2D bind setNoShadowMode GL_TEXTURE_2D setSamplerFilter GL_TEXTURE_2D filt setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D ec) + return n return $ Sampler2D sampId False (samplerPrefix (undefined :: c)) newSampler2DArray sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec)) = sf s - in do useTex tn GL_TEXTURE_2D_ARRAY bind + in do n <- useTex tn GL_TEXTURE_2D_ARRAY bind setNoShadowMode GL_TEXTURE_2D_ARRAY setSamplerFilter GL_TEXTURE_2D_ARRAY filt setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D_ARRAY ec) + return n return $ Sampler2DArray sampId False (samplerPrefix (undefined :: c)) newSampler3D sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture3D tn _ _, filt, (V3 ex ey ez, ec)) = sf s - in do useTex tn GL_TEXTURE_3D bind + in do n <- useTex tn GL_TEXTURE_3D bind setNoShadowMode GL_TEXTURE_3D setSamplerFilter GL_TEXTURE_3D filt setEdgeMode GL_TEXTURE_3D (Just ex, Just ey, Just ez) (setBorderColor (undefined :: c) GL_TEXTURE_3D ec) + return n return $ Sampler3D sampId False (samplerPrefix (undefined :: c)) newSamplerCube sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt) = sf s - in do useTex tn GL_TEXTURE_CUBE_MAP bind + in do n <- useTex tn GL_TEXTURE_CUBE_MAP bind setNoShadowMode GL_TEXTURE_CUBE_MAP setSamplerFilter GL_TEXTURE_CUBE_MAP filt + return n return $ SamplerCube sampId False (samplerPrefix (undefined :: c)) newSampler1DShadow sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec), cf) = sf s - in do useTex tn GL_TEXTURE_1D bind + in do n <- useTex tn GL_TEXTURE_1D bind setShadowFunc GL_TEXTURE_1D cf setSamplerFilter GL_TEXTURE_1D filt setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D ec) + return n return $ Sampler1D sampId True "" newSampler1DArrayShadow sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec), cf) = sf s - in do useTex tn GL_TEXTURE_1D_ARRAY bind + in do n <- useTex tn GL_TEXTURE_1D_ARRAY bind setShadowFunc GL_TEXTURE_1D_ARRAY cf setSamplerFilter GL_TEXTURE_1D_ARRAY filt setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D_ARRAY ec) + return n return $ Sampler1DArray sampId True "" newSampler2DShadow sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec), cf) = sf s - in do useTex tn GL_TEXTURE_2D bind + in do n <- useTex tn GL_TEXTURE_2D bind setShadowFunc GL_TEXTURE_2D cf setSamplerFilter GL_TEXTURE_2D filt setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D ec) + return n return $ Sampler2D sampId True "" newSampler2DArrayShadow sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec), cf) = sf s - in do useTex tn GL_TEXTURE_2D_ARRAY bind + in do n <- useTex tn GL_TEXTURE_2D_ARRAY bind setShadowFunc GL_TEXTURE_2D_ARRAY cf setSamplerFilter GL_TEXTURE_2D_ARRAY filt setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D_ARRAY ec) + return n return $ Sampler2DArray sampId True "" newSamplerCubeShadow sf = Shader $ do sampId <- getName doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt, cf) = sf s - in do useTex tn GL_TEXTURE_CUBE_MAP bind + in do n <- useTex tn GL_TEXTURE_CUBE_MAP bind setShadowFunc GL_TEXTURE_CUBE_MAP cf setSamplerFilter GL_TEXTURE_CUBE_MAP filt + return n return $ SamplerCube sampId True "" setNoShadowMode :: GLenum -> IO () @@ -910,7 +923,7 @@ -doForSampler :: Int -> (s -> Binding -> IO()) -> ShaderM s () +doForSampler :: Int -> (s -> Binding -> IO Int) -> ShaderM s () doForSampler n io = modifyRenderIO (\s -> s { samplerNameToRenderIO = insert n io (samplerNameToRenderIO s) } ) -- | Used instead of 'Format' for shadow samplers. These samplers have specialized sampler values, see 'sample1DShadow' and friends. @@ -1162,22 +1175,30 @@ getTexture3DImage :: Texture3D os f -> Level -> Int -> Render os f' (Image f) getTextureCubeImage :: TextureCube os f -> Level -> CubeSide -> Render os f' (Image f) -getTexture1DImage t@(Texture1D tn _ ls) l' = let l = min ls l' in return $ Image tn 0 l (V2 (texture1DSizes t !! l) 1) $ \attP -> do { n <- readIORef tn; glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_1D n (fromIntegral l) } +registerRenderWriteTextureName tn = Render (lift $ lift $ lift $ readIORef tn) >>= registerRenderWriteTexture . fromIntegral + +getTexture1DImage t@(Texture1D tn _ ls) l' = let l = min ls l' in do registerRenderWriteTextureName tn + return $ Image tn 0 l (V2 (texture1DSizes t !! l) 1) $ \attP -> do { n <- readIORef tn; glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_1D n (fromIntegral l) } getTexture1DArrayImage t@(Texture1DArray tn _ ls) l' y' = let l = min ls l' V2 x y = texture1DArraySizes t !! l - in return $ Image tn y' l (V2 x 1) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min y' (y-1)) } -getTexture2DImage t@(Texture2D tn _ ls) l' = let l = min ls l' in return $ Image tn 0 l (texture2DSizes t !! l) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_2D n (fromIntegral l) } + in do registerRenderWriteTextureName tn + return $ Image tn y' l (V2 x 1) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min y' (y-1)) } +getTexture2DImage t@(Texture2D tn _ ls) l' = let l = min ls l' in do registerRenderWriteTextureName tn + return $ Image tn 0 l (texture2DSizes t !! l) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_2D n (fromIntegral l) } getTexture2DImage t@(RenderBuffer2D tn _) _ = return $ Image tn (-1) 0 (head $ texture2DSizes t) $ \attP -> do { n <- readIORef tn; glFramebufferRenderbuffer GL_DRAW_FRAMEBUFFER attP GL_RENDERBUFFER n } getTexture2DArrayImage t@(Texture2DArray tn _ ls) l' z' = let l = min ls l' V3 x y z = texture2DArraySizes t !! l - in return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) } + in do registerRenderWriteTextureName tn + return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) } getTexture3DImage t@(Texture3D tn _ ls) l' z' = let l = min ls l' V3 x y z = texture3DSizes t !! l - in return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) } + in do registerRenderWriteTextureName tn + return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) } getTextureCubeImage t@(TextureCube tn _ ls) l' s = let l = min ls l' x = textureCubeSizes t !! l s' = getGlCubeSide s - in return $ Image tn (fromIntegral s') l (V2 x x) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP s' n (fromIntegral l) } + in do registerRenderWriteTextureName tn + return $ Image tn (fromIntegral s') l (V2 x x) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP s' n (fromIntegral l) } getGlCubeSide :: CubeSide -> GLenum getGlCubeSide CubePosX = GL_TEXTURE_CUBE_MAP_POSITIVE_X diff --git a/src/Graphics/GPipe/Internal/Uniform.hs b/src/Graphics/GPipe/Internal/Uniform.hs --- a/src/Graphics/GPipe/Internal/Uniform.hs +++ b/src/Graphics/GPipe/Internal/Uniform.hs @@ -23,6 +23,8 @@ import Linear.V2 import Linear.V1 import Linear.V0 +import Linear.Plucker (Plucker(..)) +import Linear.Quaternion (Quaternion(..)) -- | This class constraints which buffer types can be loaded as uniforms, and what type those values have. class BufferFormat a => UniformInput a where @@ -179,4 +181,25 @@ b' <- toUniform -< b c' <- toUniform -< c d' <- toUniform -< d - returnA -< (a', b', c', d') + returnA -< (a', b', c', d') + + +instance UniformInput a => UniformInput (Quaternion a) where + type UniformFormat (Quaternion a) x = Quaternion (UniformFormat a x) + toUniform = proc ~(Quaternion a v) -> do + a' <- toUniform -< a + v' <- toUniform -< v + returnA -< Quaternion a' v' + +instance UniformInput a => UniformInput (Plucker a) where + type UniformFormat (Plucker a) x = Plucker (UniformFormat a x) + toUniform = proc ~(Plucker a b c d e f) -> do + a' <- toUniform -< a + b' <- toUniform -< b + c' <- toUniform -< c + d' <- toUniform -< d + e' <- toUniform -< e + f' <- toUniform -< f + returnA -< Plucker a' b' c' d' e' f' + +