GPipe 2.1.4 → 2.1.5
raw patch · 10 files changed
+506/−371 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- GPipe.cabal +1/−1
- src/Data/SNMap.hs +6/−6
- src/Graphics/GPipe/Internal/Buffer.hs +104/−89
- src/Graphics/GPipe/Internal/Context.hs +44/−44
- src/Graphics/GPipe/Internal/Expr.hs +130/−118
- src/Graphics/GPipe/Internal/FragmentStream.hs +57/−27
- src/Graphics/GPipe/Internal/FrameBuffer.hs +47/−35
- src/Graphics/GPipe/Internal/PrimitiveStream.hs +63/−32
- src/Graphics/GPipe/Internal/Uniform.hs +49/−19
CHANGELOG.md view
@@ -1,3 +1,8 @@+### 2.1.5 + +- Fixed bug in clear where masks weren't set +- Added up to 7-tuple instances + ### 2.1.4 - Fixed bug in dropVertices and dropIndices (#16)
GPipe.cabal view
@@ -1,5 +1,5 @@ name: GPipe -version: 2.1.4 +version: 2.1.5 cabal-version: >= 1.8 build-type: Simple author: Tobias Bexelius
src/Data/SNMap.hs view
@@ -5,13 +5,13 @@ SNMapReaderT, runSNMapReaderT, newSNMap, - memoize, + memoize, memoizeM, scopedM )where -import System.Mem.StableName -import qualified Data.HashTable.IO as HT +import System.Mem.StableName +import qualified Data.HashTable.IO as HT import Data.Functor import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Class @@ -27,12 +27,12 @@ memoize :: MonadIO m => m (SNMap m a) -> m a -> m a memoize getter m = do s <- liftIO $ makeStableName $! m - (SNMap h) <- getter + (SNMap h) <- getter x <- liftIO $ HT.lookup h s case x of Just a -> return a Nothing -> do a <- m - (SNMap h') <- getter --Need to redo because of scope + (SNMap h') <- getter --Need to redo because of scope liftIO $ HT.insert h' s a return a @@ -40,7 +40,7 @@ runSNMapReaderT :: MonadIO m => SNMapReaderT a m b -> m b runSNMapReaderT (SNMapReaderT m) = do h <- liftIO newSNMap - evalStateT m h + evalStateT m h instance MonadTrans (SNMapReaderT a) where lift = SNMapReaderT . lift
src/Graphics/GPipe/Internal/Buffer.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE Arrows, TypeFamilies, ScopedTypeVariables, FlexibleContexts, FlexibleInstances , TypeSynonymInstances #-} -module Graphics.GPipe.Internal.Buffer +module Graphics.GPipe.Internal.Buffer ( BufferFormat(..), BufferColor, @@ -52,24 +52,24 @@ -- | The class that constraints which types can live in a buffer. class BufferFormat f where - -- | The type a value of this format has when it lives on the host (i.e. normal Haskell world) + -- | The type a value of this format has when it lives on the host (i.e. normal Haskell world) type HostFormat f -- | An arrow action that turns a value from it's host representation to it's buffer representation. Use 'toBuffer' from -- the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value -- lazily, so ensure you use - -- - -- @proc ~pattern -> do ...@ + -- + -- @proc ~pattern -> do ...@ toBuffer :: ToBuffer (HostFormat f) f getGlType :: f -> GLenum peekPixel :: f -> Ptr () -> IO (HostFormat f) - getGlPaddedFormat :: f -> GLenum + getGlPaddedFormat :: f -> GLenum getGlType = error "This is only defined for BufferColor types" peekPixel = error "This is only defined for BufferColor types" getGlPaddedFormat = error "This is only defined for BufferColor types" --- | A @Buffer os b@ lives in the object space @os@ and contains elements of type @b@. +-- | A @Buffer os b@ lives in the object space @os@ and contains elements of type @b@. data Buffer os b = Buffer { - bufName :: BufferName, + bufName :: BufferName, bufElementSize :: Int, -- | Retrieve the number of elements in a buffer. bufferLength :: Int, @@ -86,7 +86,7 @@ type BufferName = IORef GLuint type Offset = Int type Stride = Int -type BufferStartPos = Int +type BufferStartPos = Int data BInput = BInput {bInSkipElems :: Int, bInInstanceDiv :: Int} @@ -100,30 +100,30 @@ data ToBuffer a b = ToBuffer (Kleisli (StateT Offset (WriterT [Int] (Reader (ToBufferInput, UniformAlignment, AlignmentMode)))) a b) -- Normal = aligned to 4 bytes (Kleisli (StateT (Ptr (), [Int]) IO) a b) -- Normal = aligned to 4 bytes - AlignmentMode + AlignmentMode instance Category ToBuffer where id = ToBuffer id id AlignUnknown ToBuffer a b m1 . ToBuffer x y m2 = ToBuffer (a.x) (b.y) (comb m1 m2) where - -- If only one uniform or one PackedIndices, use that, otherwise use Align4 + -- If only one uniform or one PackedIndices, use that, otherwise use Align4 comb AlignUniform AlignUnknown = AlignUniform comb AlignUnknown AlignUniform = AlignUniform - comb AlignUnknown AlignPackedIndices = AlignPackedIndices - comb AlignPackedIndices AlignUnknown = AlignPackedIndices - comb AlignUnknown AlignUnknown = AlignUnknown + comb AlignUnknown AlignPackedIndices = AlignPackedIndices + comb AlignPackedIndices AlignUnknown = AlignPackedIndices + comb AlignUnknown AlignUnknown = AlignUnknown comb _ _ = Align4 instance Arrow ToBuffer where arr f = ToBuffer (arr f) (arr f) AlignUnknown first (ToBuffer a b m) = ToBuffer (first a) (first b) m --- | The atomic buffer value that represents a host value of type 'a'. +-- | The atomic buffer value that represents a host value of type 'a'. data B a = B { bName :: IORef GLuint, bOffset :: Int, bStride :: Int, bSkipElems :: Int, bInstanceDiv :: Int} --- | An atomic buffer value that represents a vector of 2 'a's on the host. +-- | An atomic buffer value that represents a vector of 2 'a's on the host. newtype B2 a = B2 { unB2 :: B a } -- Internal --- | An atomic buffer value that represents a vector of 3 'a's on the host. +-- | An atomic buffer value that represents a vector of 3 'a's on the host. newtype B3 a = B3 { unB3 :: B a } -- Internal -- | An atomic buffer value that represents a vector of 4 'a's on the host. This works similar to '(B a, B a, B a, B a)' but has some performance advantage, especially when used -- in 'VertexArray's. @@ -155,12 +155,12 @@ -- signed or unsigned integer (i.e. 'Int' or 'Word'). newtype Normalized a = Normalized a --- | This works like a 'B a', but has an alignment smaller than 4 bytes that is the limit for vertex buffers, and thus cannot be used for those. --- Index buffers on the other hand need to be tightly packed, so you need to use this type for index buffers of 'Word8' or 'Word16'. -newtype BPacked a = BPacked (B a) +-- | This works like a 'B a', but has an alignment smaller than 4 bytes that is the limit for vertex buffers, and thus cannot be used for those. +-- Index buffers on the other hand need to be tightly packed, so you need to use this type for index buffers of 'Word8' or 'Word16'. +newtype BPacked a = BPacked (B a) toBufferBUnaligned :: forall a. Storable a => ToBuffer a (B a) -toBufferBUnaligned = ToBuffer +toBufferBUnaligned = ToBuffer (Kleisli $ const static) (Kleisli writer) Align4 @@ -176,8 +176,8 @@ return undefined toBufferB :: forall a. Storable a => ToBuffer a (B a) -toBufferB = toBufferBUnaligned -- Will always be 4 aligned, only 4 size types defined for B1 - +toBufferB = toBufferBUnaligned -- Will always be 4 aligned, only 4 size types defined for B1 + toBufferB2 :: forall a. Storable a => ToBuffer (V2 a) (B2 a) toBufferB2 = proc ~(V2 a b) -> do (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 2 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform @@ -186,15 +186,15 @@ returnA -< B2 a' -- Will always be 4 aligned, only 4 size types defined for B2 toBufferB3 :: forall a. Storable a => ToBuffer (V3 a) (B3 a) toBufferB3 = proc ~(V3 a b c) -> do - (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform + (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform a' <- toBufferBUnaligned -< a toBufferBUnaligned -< b toBufferBUnaligned -< c - (if sizeOf (undefined :: a) < 4 then alignWhen [(Align4, 4), (AlignUniform, 4)] else id) -< () -- For types smaller than 4 we need to pad + (if sizeOf (undefined :: a) < 4 then alignWhen [(Align4, 4), (AlignUniform, 4)] else id) -< () -- For types smaller than 4 we need to pad returnA -< B3 a' toBufferB4 :: forall a. Storable a => ToBuffer (V4 a) (B4 a) toBufferB4 = proc ~(V4 a b c d) -> do - (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform + (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform a' <- toBufferBUnaligned -< a toBufferBUnaligned -< b toBufferBUnaligned -< c @@ -203,7 +203,7 @@ instance BufferFormat a => BufferFormat (Uniform a) where type HostFormat (Uniform a) = HostFormat a - toBuffer = arr Uniform . ToBuffer + toBuffer = arr Uniform . ToBuffer (Kleisli elementBuilderA) (Kleisli writerA) AlignUniform @@ -211,14 +211,14 @@ ToBuffer (Kleisli elementBuilderA') (Kleisli writerA') _ = toBuffer :: ToBuffer (HostFormat a) a elementBuilderA a = do (_,x,_) <- lift $ lift ask a' <- elementBuilderA' a - setElemAlignM [(AlignUniform, x)] () + setElemAlignM [(AlignUniform, x)] () return a' writerA a = do a' <- writerA' a setWriterAlignM () return a' instance BufferFormat a => BufferFormat (Normalized a) where type HostFormat (Normalized a) = HostFormat a - toBuffer = arr Normalized . toBuffer + toBuffer = arr Normalized . toBuffer getGlType (Normalized a) = getGlType a getGlPaddedFormat (Normalized a) = case getGlPaddedFormat a of GL_RGBA_INTEGER -> GL_RGBA @@ -253,7 +253,7 @@ instance BufferFormat () where type HostFormat () = () - toBuffer = arr (const ()) + toBuffer = arr (const ()) instance (BufferFormat a, BufferFormat b) => BufferFormat (a, b) where type HostFormat (a,b) = (HostFormat a, HostFormat b) toBuffer = proc ~(a, b) -> do @@ -270,20 +270,35 @@ 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 b, BufferFormat c, BufferFormat d, BufferFormat e) => BufferFormat (a, b, c, d, e) where + type HostFormat (a,b,c,d,e) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e) + toBuffer = proc ~(a, b, c, d, e) -> do + ((a', b', c', d'), e') <- toBuffer -< ((a, b, c, d), e) + returnA -< (a', b', c', d', e') +instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d, BufferFormat e, BufferFormat f) => BufferFormat (a, b, c, d, e, f) where + type HostFormat (a,b,c,d,e,f) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e, HostFormat f) + toBuffer = proc ~(a, b, c, d, e, f) -> do + ((a', b', c', d', e'), f') <- toBuffer -< ((a, b, c, d, e), f) + returnA -< (a', b', c', d', e', f') +instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d, BufferFormat e, BufferFormat f, BufferFormat g) => BufferFormat (a, b, c, d, e, f, g) where + type HostFormat (a,b,c,d,e,f,g) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e, HostFormat f, HostFormat g) + toBuffer = proc ~(a, b, c, d, e, f, g) -> do + ((a', b', c', d', e', f'), g') <- toBuffer -< ((a, b, c, d, e, f), g) + returnA -< (a', b', c', d', e', f', g') + 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 @@ -297,22 +312,22 @@ -- | Create a buffer with a specified number of elements. newBuffer :: (MonadIO m, BufferFormat b) => Int -> ContextT w os f m (Buffer os b) -newBuffer elementCount | elementCount < 0 = error "newBuffer, length negative" +newBuffer elementCount | elementCount < 0 = error "newBuffer, length negative" | otherwise = do (buffer, nameRef, name) <- liftContextIO $ do - name <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) + name <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) nameRef <- newIORef name uniAl <- getUniformAlignment let buffer = makeBuffer nameRef elementCount uniAl bname <- readIORef $ bufName buffer - glBindBuffer GL_COPY_WRITE_BUFFER bname + glBindBuffer GL_COPY_WRITE_BUFFER bname glBufferData GL_COPY_WRITE_BUFFER (fromIntegral $ bufSize buffer) nullPtr GL_STREAM_DRAW return (buffer, nameRef, name) addContextFinalizer nameRef $ with name (glDeleteBuffers 1) addVAOBufferFinalizer nameRef - return buffer + return buffer -bufferWriteInternal :: Buffer os f -> Ptr () -> [HostFormat f] -> IO (Ptr ()) +bufferWriteInternal :: Buffer os f -> Ptr () -> [HostFormat f] -> IO (Ptr ()) bufferWriteInternal b ptr (x:xs) = do bufWriter b ptr x bufferWriteInternal b (ptr `plusPtr` bufElementSize b) xs bufferWriteInternal _ ptr [] = return ptr @@ -320,18 +335,18 @@ -- | Write a buffer from the host (i.e. the normal Haskell world). writeBuffer :: MonadIO m => Buffer os b -> BufferStartPos -> [HostFormat b] -> ContextT w os f m () writeBuffer buffer offset elems | offset < 0 || offset >= bufferLength buffer = error "writeBuffer, offset out of bounds" - | otherwise = + | otherwise = let maxElems = max 0 $ bufferLength buffer - offset elemSize = bufElementSize buffer off = fromIntegral $ offset * elemSize - - in liftContextIOAsync $ do + + in liftContextIOAsync $ do bname <- readIORef $ bufName buffer glBindBuffer GL_COPY_WRITE_BUFFER bname ptr <- glMapBufferRange GL_COPY_WRITE_BUFFER off (fromIntegral $maxElems * elemSize) (GL_MAP_WRITE_BIT + GL_MAP_FLUSH_EXPLICIT_BIT) end <- bufferWriteInternal buffer ptr (take maxElems elems) - glFlushMappedBufferRange GL_COPY_WRITE_BUFFER off (fromIntegral $ end `minusPtr` ptr) - void $ glUnmapBuffer GL_COPY_WRITE_BUFFER + glFlushMappedBufferRange GL_COPY_WRITE_BUFFER off (fromIntegral $ end `minusPtr` ptr) + void $ glUnmapBuffer GL_COPY_WRITE_BUFFER -- | Copies values from one buffer to another (of the same type). -- @@ -342,13 +357,13 @@ | len < 0 = error "writeBuffer, length negative" | len + from > bufferLength bFrom = error "writeBuffer, source buffer too small" | len + to > bufferLength bTo = error "writeBuffer, destination buffer too small" - | otherwise = liftContextIOAsync $ do + | otherwise = liftContextIOAsync $ do bnamef <- readIORef $ bufName bFrom bnamet <- readIORef $ bufName bTo glBindBuffer GL_COPY_READ_BUFFER bnamef glBindBuffer GL_COPY_WRITE_BUFFER bnamet let elemSize = bufElementSize bFrom -- same as for bTo - glCopyBufferSubData GL_COPY_READ_BUFFER GL_COPY_WRITE_BUFFER (fromIntegral $ from * elemSize) (fromIntegral $ to * elemSize) (fromIntegral $ len * elemSize) + glCopyBufferSubData GL_COPY_READ_BUFFER GL_COPY_WRITE_BUFFER (fromIntegral $ from * elemSize) (fromIntegral $ to * elemSize) (fromIntegral $ len * elemSize) ---------------------------------------------- @@ -366,17 +381,17 @@ put $ offset + pad return pad lift $ tell [pad] - return a + return a setWriterAlignM :: b -> StateT (Ptr a, [Int]) IO b setWriterAlignM a = do (ptr, pad:pads) <- get put (ptr `plusPtr` pad, pads) return a - + getUniformAlignment :: IO Int getUniformAlignment = fromIntegral <$> alloca (\ ptr -> glGetIntegerv GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT ptr >> peek ptr) - + makeBuffer :: forall os b. BufferFormat b => BufferName -> Int -> UniformAlignment -> Buffer os b makeBuffer name elementCount uniformAlignment = do let ToBuffer a b m = toBuffer :: ToBuffer (HostFormat b) b @@ -387,9 +402,9 @@ writer ptr x = void $ runStateT (runKleisli b x) (ptr,pads) Buffer name elementSize elementCount elementF writer --- | This type family restricts what host and buffer types a texture format may be converted into. +-- | This type family restricts what host and buffer types a texture format may be converted into. -- 'BufferColor t h' for a texture representation 't' and a host representation 'h' will evaluate to a buffer type used in the transfer. --- This family is closed, i.e. you cannot create additional instances to it. +-- This family is closed, i.e. you cannot create additional instances to it. type family BufferColor c h where BufferColor Float Int32 = Normalized (B Int32) BufferColor Float Word32 = Normalized (B Word32) @@ -400,10 +415,10 @@ BufferColor Word Word16 = BPacked Word16 BufferColor Word Word8 = BPacked Word8 - BufferColor (V2 Float) (V2 Int32) = Normalized (B2 Int32) - BufferColor (V2 Float) (V2 Int16) = Normalized (B2 Int16) - BufferColor (V2 Float) (V2 Word32) = Normalized (B2 Word32) - BufferColor (V2 Float) (V2 Word16) = Normalized (B2 Word16) + BufferColor (V2 Float) (V2 Int32) = Normalized (B2 Int32) + BufferColor (V2 Float) (V2 Int16) = Normalized (B2 Int16) + BufferColor (V2 Float) (V2 Word32) = Normalized (B2 Word32) + BufferColor (V2 Float) (V2 Word16) = Normalized (B2 Word16) BufferColor (V2 Float) (V2 Float) = B2 Float BufferColor (V2 Int) (V2 Int32) = B2 Int32 @@ -412,10 +427,10 @@ BufferColor (V2 Word) (V2 Word32) = B2 Word32 BufferColor (V2 Word) (V2 Word16) = B2 Word16 - BufferColor (V3 Float) (V3 Int32) = Normalized (B3 Int32) + BufferColor (V3 Float) (V3 Int32) = Normalized (B3 Int32) BufferColor (V3 Float) (V3 Int16) = Normalized (B3 Int16) BufferColor (V3 Float) (V3 Int8) = Normalized (B3 Int8) - BufferColor (V3 Float) (V3 Word32) = Normalized (B3 Word32) + BufferColor (V3 Float) (V3 Word32) = Normalized (B3 Word32) BufferColor (V3 Float) (V3 Word16) = Normalized (B3 Word16) BufferColor (V3 Float) (V3 Word8) = Normalized (B3 Word8) BufferColor (V3 Float) (V3 Float) = B3 Float @@ -445,191 +460,191 @@ BufferColor (V4 Word) (V4 Word8) = B4 Word8 peekPixel1 :: Storable a => t -> Ptr x -> IO a -peekPixel1 _ = peek . castPtr +peekPixel1 _ = peek . castPtr peekPixel2 :: (Storable a) => t -> Ptr x -> IO (V2 a) peekPixel2 _ ptr = do x <- peek (castPtr ptr) y <- peekElemOff (castPtr ptr ) 1 - return (V2 x y) + return (V2 x y) peekPixel3 :: (Storable a) => t -> Ptr x -> IO (V3 a) peekPixel3 _ ptr = do x <- peek (castPtr ptr) y <- peekElemOff (castPtr ptr ) 1 z <- peekElemOff (castPtr ptr ) 2 - return (V3 x y z) + return (V3 x y z) peekPixel4 :: (Storable a) => t -> Ptr x -> IO (V4 a) peekPixel4 _ ptr = do x <- peek (castPtr ptr) y <- peekElemOff (castPtr ptr ) 1 z <- peekElemOff (castPtr ptr ) 2 w <- peekElemOff (castPtr ptr ) 3 - return (V4 x y z w) + return (V4 x y z w) instance BufferFormat (B Int32) where type HostFormat (B Int32) = Int32 toBuffer = toBufferB getGlType _ = GL_INT - peekPixel = peekPixel1 + peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED_INTEGER instance BufferFormat (B Word32) where type HostFormat (B Word32) = Word32 toBuffer = toBufferB getGlType _ = GL_UNSIGNED_INT - peekPixel = peekPixel1 + peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED_INTEGER - + instance BufferFormat (BPacked Word16) where type HostFormat (BPacked Word16) = Word16 - toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b AlignPackedIndices + toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b AlignPackedIndices getGlType _ = GL_UNSIGNED_SHORT - peekPixel = peekPixel1 + peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED_INTEGER instance BufferFormat (BPacked Word8) where type HostFormat (BPacked Word8) = Word8 - toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b AlignPackedIndices + toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b AlignPackedIndices getGlType _ = GL_UNSIGNED_BYTE - peekPixel = peekPixel1 - getGlPaddedFormat _ = GL_RED_INTEGER + peekPixel = peekPixel1 + getGlPaddedFormat _ = GL_RED_INTEGER instance BufferFormat (B Float) where type HostFormat (B Float) = Float toBuffer = toBufferB getGlType _ = GL_FLOAT - peekPixel = peekPixel1 + peekPixel = peekPixel1 getGlPaddedFormat _ = GL_RED instance BufferFormat (B2 Int32) where type HostFormat (B2 Int32) = V2 Int32 toBuffer = toBufferB2 getGlType _ = GL_INT - peekPixel = peekPixel2 + peekPixel = peekPixel2 getGlPaddedFormat _ = GL_RG_INTEGER instance BufferFormat (B2 Int16) where type HostFormat (B2 Int16) = V2 Int16 toBuffer = toBufferB2 getGlType _ = GL_SHORT - peekPixel = peekPixel2 + peekPixel = peekPixel2 getGlPaddedFormat _ = GL_RG_INTEGER instance BufferFormat (B2 Word32) where type HostFormat (B2 Word32) = V2 Word32 toBuffer = toBufferB2 getGlType _ = GL_UNSIGNED_INT - peekPixel = peekPixel2 + peekPixel = peekPixel2 getGlPaddedFormat _ = GL_RG_INTEGER instance BufferFormat (B2 Word16) where type HostFormat (B2 Word16) = V2 Word16 toBuffer = toBufferB2 getGlType _ = GL_UNSIGNED_SHORT - peekPixel = peekPixel2 + peekPixel = peekPixel2 getGlPaddedFormat _ = GL_RG_INTEGER instance BufferFormat (B2 Float) where type HostFormat (B2 Float) = V2 Float toBuffer = toBufferB2 getGlType _ = GL_FLOAT - peekPixel = peekPixel2 + peekPixel = peekPixel2 getGlPaddedFormat _ = GL_RG instance BufferFormat (B3 Int32) where type HostFormat (B3 Int32) = V3 Int32 toBuffer = toBufferB3 getGlType _ = GL_INT - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGB_INTEGER instance BufferFormat (B3 Int16) where type HostFormat (B3 Int16) = V3 Int16 toBuffer = toBufferB3 getGlType _ = GL_SHORT - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B3 Int8) where type HostFormat (B3 Int8) = V3 Int8 toBuffer = toBufferB3 getGlType _ = GL_BYTE - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B3 Word32) where type HostFormat (B3 Word32) = V3 Word32 toBuffer = toBufferB3 getGlType _ = GL_UNSIGNED_INT - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGB_INTEGER instance BufferFormat (B3 Word16) where type HostFormat (B3 Word16) = V3 Word16 toBuffer = toBufferB3 getGlType _ = GL_UNSIGNED_SHORT - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B3 Word8) where type HostFormat (B3 Word8) = V3 Word8 toBuffer = toBufferB3 getGlType _ = GL_UNSIGNED_BYTE - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B3 Float) where type HostFormat (B3 Float) = V3 Float toBuffer = toBufferB3 getGlType _ = GL_FLOAT - peekPixel = peekPixel3 + peekPixel = peekPixel3 getGlPaddedFormat _ = GL_RGB instance BufferFormat (B4 Int32) where type HostFormat (B4 Int32) = V4 Int32 toBuffer = toBufferB4 getGlType _ = GL_INT - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Int16) where type HostFormat (B4 Int16) = V4 Int16 toBuffer = toBufferB4 getGlType _ = GL_SHORT - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Int8) where type HostFormat (B4 Int8) = V4 Int8 toBuffer = toBufferB4 getGlType _ = GL_BYTE - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Word32) where type HostFormat (B4 Word32) = V4 Word32 toBuffer = toBufferB4 getGlType _ = GL_UNSIGNED_INT - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Word16) where type HostFormat (B4 Word16) = V4 Word16 toBuffer = toBufferB4 getGlType _ = GL_UNSIGNED_SHORT - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Word8) where type HostFormat (B4 Word8) = V4 Word8 toBuffer = toBufferB4 getGlType _ = GL_UNSIGNED_BYTE - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA_INTEGER instance BufferFormat (B4 Float) where type HostFormat (B4 Float) = V4 Float toBuffer = toBufferB4 getGlType _ = GL_FLOAT - peekPixel = peekPixel4 + peekPixel = peekPixel4 getGlPaddedFormat _ = GL_RGBA - - + +
src/Graphics/GPipe/Internal/Context.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, GADTs, DeriveDataTypeable #-} -module Graphics.GPipe.Internal.Context +module Graphics.GPipe.Internal.Context ( ContextFactory, ContextHandle(..), @@ -30,13 +30,13 @@ import Graphics.GPipe.Internal.Format import Control.Monad.Exception (MonadException, Exception, MonadAsyncException,bracket) -import Control.Monad.Trans.Reader +import Control.Monad.Trans.Reader import Control.Monad.IO.Class 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 qualified Data.IntSet as Set +import qualified Data.Map.Strict as Map import Graphics.GL.Core33 import Graphics.GL.Types import Control.Concurrent.MVar @@ -53,26 +53,26 @@ 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. Called from same thread as created the initial 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 boolean argument will be @True@ if this call references this context's window, and @False@ if it only references shared objects - -- The thread calling this may not be the same creating the context. + -- The boolean argument will be @True@ if this call references this context's window, and @False@ if it only references shared objects + -- The thread calling this may not be the same creating the context. contextDoSync :: forall a. Bool ->IO a -> IO a, - -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. - -- The boolean argument will be @True@ if this call references this context's window, and @False@ if it only references shared objects + -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. + -- The boolean argument will be @True@ if this call references this context's window, and @False@ if it only references shared objects -- The thread calling this may not be the same creating the context (for finalizers it is most definetly not). contextDoAsync :: Bool -> IO () -> IO (), - -- | 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). Called from same thread as created context. + -- | 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). Called from same thread as created context. contextFrameBufferSize :: IO (Int, Int), - -- | Delete this context and close any associated window. Called from same thread as created 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 + -- | 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. contextWindow :: w -} +} -- | The monad transformer that encapsulates a GPipe context (which wraps an OpenGl context). -- @@ -80,28 +80,28 @@ -- -- [@w@] The type of the window that is bound to this context. It is defined by the window manager package and is probably an opaque type. -- --- [@os@] An abstract type that is used to denote the object space. This is an forall type defined by the 'runContextT' call which will restrict any objects created inside this context +-- [@os@] An abstract type that is used to denote the object space. This is an forall type defined by the 'runContextT' call which will restrict any objects created inside this context -- to be returned from it or used by another context (the same trick as the 'ST' monad uses). -- -- [@f@] The format of the context's default frame buffer, always an instance of 'ContextFormat'. -- -- [@m@] The monad this monad transformer wraps. Need to have 'IO' in the bottom for this 'ContextT' to be runnable. -- --- [@a@] The value returned from this monad action. +-- [@a@] The value returned from this monad action. -- -newtype ContextT w os f m a = - ContextT (ReaderT (ContextHandle w, (ContextData, SharedContextDatas)) m a) +newtype ContextT w os f m a = + ContextT (ReaderT (ContextHandle w, (ContextData, SharedContextDatas)) m a) deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException) - + instance MonadTrans (ContextT w os f) where - lift = ContextT . lift + lift = ContextT . lift -- | Run a 'ContextT' monad transformer, creating a window (unless the 'ContextFormat' is 'ContextFormatNone') that is later destroyed when the action returns. This function will --- also create a new object space. +-- also create a new object space. -- You need a 'ContextFactory', which is provided by an auxillary package, such as @GPipe-GLFW@. runContextT :: (MonadIO m, MonadAsyncException m) => ContextFactory c ds w -> ContextFormat c ds -> (forall os. ContextT w os (ContextFormat c ds) m a) -> m a -runContextT cf f (ContextT m) = - bracket +runContextT cf f (ContextT m) = + bracket (liftIO $ cf f) (liftIO . contextDelete) $ \ h -> do cds <- liftIO newContextDatas @@ -111,7 +111,7 @@ runReaderT (i >> m) rs -- | Run a 'ContextT' monad transformer inside another one, creating a window (unless the 'ContextFormat' is 'ContextFormatNone') that is later destroyed when the action returns. The inner 'ContextT' monad --- transformer will share object space with the outer one. The 'ContextFactory' of the outer context will be used in the creation of the inner context. +-- transformer will share object space with the outer one. The 'ContextFactory' of the outer context will be used in the creation of the inner context. runSharedContextT :: (MonadIO m, MonadAsyncException m) => ContextFormat c ds -> ContextT w os (ContextFormat c ds) (ContextT w os f m) a -> ContextT w os f m a runSharedContextT f (ContextT m) = bracket @@ -135,7 +135,7 @@ glPixelStorei GL_UNPACK_ALIGNMENT 1 liftContextIO :: MonadIO m => IO a -> ContextT w os f m a -liftContextIO m = do h <- ContextT (asks fst) +liftContextIO m = do h <- ContextT (asks fst) liftIO $ contextDoSync h False m addContextFinalizer :: MonadIO m => IORef a -> IO () -> ContextT w os f m () @@ -145,7 +145,7 @@ -- | This is only used to finalize nonShared objects such as VBOs and FBOs getContextFinalizerAdder :: MonadIO m => ContextT w os f m (IORef a -> IO () -> IO ()) getContextFinalizerAdder = do h <- ContextT (asks fst) - return $ \k m -> void $ mkWeakIORef k $ contextDoAsync h True m + return $ \k m -> void $ mkWeakIORef k $ contextDoAsync h True m liftContextIOAsync :: MonadIO m => IO () -> ContextT w os f m () liftContextIOAsync m = do h <- ContextT (asks fst) @@ -154,12 +154,12 @@ liftContextIOAsyncInWin :: MonadIO m => IO () -> ContextT w os f m () liftContextIOAsyncInWin m = do h <- ContextT (asks fst) liftIO $ contextDoAsync h True m - + -- | Run this action after a 'render' call to swap out the context windows back buffer with the front buffer, effectively showing the result. -- 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 $ contextSwap c) +swapContextBuffers = ContextT (asks fst) >>= (liftIO . contextSwap) type ContextDoAsync = Bool -> IO () -> IO () @@ -168,7 +168,7 @@ -- | 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 +-- 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) True $ runReaderT (evalStateT (runErrorT m) Set.empty) (contextDoAsync (fst c), snd c) @@ -177,9 +177,9 @@ _ -> return () registerRenderWriteTexture :: Int -> Render os f () -registerRenderWriteTexture x = Render $ lift $ modify $ Set.insert x +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. +-- | 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 $ contextFrameBufferSize c @@ -193,16 +193,16 @@ -- | This is only used to finalize nonShared objects such as VBOs and FBOs getRenderContextFinalizerAdder :: Render os f (IORef a -> IO () -> IO ()) getRenderContextFinalizerAdder = do f <- Render (lift $ lift $ asks fst) - return $ \k m -> void $ mkWeakIORef k (f True m) + return $ \k m -> void $ mkWeakIORef k (f True 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') +-- | 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') data GPipeException = GPipeException String deriving (Show, Typeable) instance Exception GPipeException --- TODO Add async rules +-- TODO Add async rules {-# RULES "liftContextIO >>= liftContextIO >>= x" forall m1 m2 x. liftContextIO m1 >>= (\_ -> liftContextIO m2 >>= x) = liftContextIO (m1 >> m2) >>= x "liftContextIO >>= liftContextIO" forall m1 m2. liftContextIO m1 >>= (\_ -> liftContextIO m2) = liftContextIO (m1 >> m2) @@ -214,7 +214,7 @@ type ContextData = MVar (VAOCache, FBOCache) data VAOKey = VAOKey { vaoBname :: !GLuint, vaoCombBufferOffset :: !Int, vaoComponents :: !GLint, vaoNorm :: !Bool, vaoDiv :: !Int } deriving (Eq, Ord) data FBOKey = FBOKey { fboTname :: !GLuint, fboTlayerOrNegIfRendBuff :: !Int, fboTlevel :: !Int } deriving (Eq, Ord) -data FBOKeys = FBOKeys { fboColors :: [FBOKey], fboDepth :: Maybe FBOKey, fboStencil :: Maybe FBOKey } deriving (Eq, Ord) +data FBOKeys = FBOKeys { fboColors :: [FBOKey], fboDepth :: Maybe FBOKey, fboStencil :: Maybe FBOKey } deriving (Eq, Ord) type VAOCache = Map.Map [VAOKey] (IORef GLuint) type FBOCache = Map.Map FBOKeys (IORef GLuint) @@ -225,7 +225,7 @@ newContextDatas = newMVar [] addContextData :: SharedContextDatas -> IO ContextData -addContextData r = do cd <- newMVar (Map.empty, Map.empty) +addContextData r = do cd <- newMVar (Map.empty, Map.empty) modifyMVar_ r $ return . (cd:) return cd @@ -235,16 +235,16 @@ addCacheFinalizer :: MonadIO m => (GLuint -> (VAOCache, FBOCache) -> (VAOCache, FBOCache)) -> IORef GLuint -> ContextT w os f m () addCacheFinalizer f r = ContextT $ do cds <- asks (snd . snd) liftIO $ do n <- readIORef r - void $ mkWeakIORef r $ do cs' <- readMVar cds + void $ mkWeakIORef r $ do cs' <- readMVar cds mapM_ (`modifyMVar_` (return . f n)) cs' addVAOBufferFinalizer :: MonadIO m => IORef GLuint -> ContextT w os f m () -addVAOBufferFinalizer = addCacheFinalizer deleteVAOBuf +addVAOBufferFinalizer = addCacheFinalizer deleteVAOBuf where deleteVAOBuf n (vao, fbo) = (Map.filterWithKey (\k _ -> all ((/=n) . vaoBname) k) vao, fbo) - + addFBOTextureFinalizer :: MonadIO m => Bool -> IORef GLuint -> ContextT w os f m () -addFBOTextureFinalizer isRB = addCacheFinalizer deleteVBOBuf +addFBOTextureFinalizer isRB = addCacheFinalizer deleteVBOBuf where deleteVBOBuf n (vao, fbo) = (vao, Map.filterWithKey (\ k _ -> all @@ -262,14 +262,14 @@ getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint)) getVAO cd k = do (vaos, _) <- readMVar cd - return (Map.lookup k vaos) + return (Map.lookup k vaos) setVAO :: ContextData -> [VAOKey] -> IORef GLuint -> IO () -setVAO cd k v = modifyMVar_ cd $ \ (vaos, fbos) -> return (Map.insert k v vaos, fbos) +setVAO cd k v = modifyMVar_ cd $ \ (vaos, fbos) -> return (Map.insert k v vaos, fbos) getFBO :: ContextData -> FBOKeys -> IO (Maybe (IORef GLuint)) getFBO cd k = do (_, fbos) <- readMVar cd return (Map.lookup k fbos) setFBO :: ContextData -> FBOKeys -> IORef GLuint -> IO () -setFBO cd k v = modifyMVar_ cd $ \(vaos, fbos) -> return (vaos, Map.insert k v fbos) +setFBO cd k v = modifyMVar_ cd $ \(vaos, fbos) -> return (vaos, Map.insert k v fbos)
src/Graphics/GPipe/Internal/Expr.hs view
@@ -34,7 +34,7 @@ type NextTempVar = Int type NextGlobal = Int -data SType = STypeFloat | STypeInt | STypeBool | STypeUInt | STypeDyn String | STypeMat Int Int | STypeVec Int | STypeIVec Int | STypeUVec Int +data SType = STypeFloat | STypeInt | STypeBool | STypeUInt | STypeDyn String | STypeMat Int Int | STypeVec Int | STypeIVec Int | STypeUVec Int stypeName :: SType -> String stypeName STypeFloat = "float" @@ -54,12 +54,12 @@ stypeSize _ = 4 type ExprM = SNMapReaderT [String] (StateT ExprState (WriterT String (StateT NextTempVar IO))) -- IO for stable names -data ExprState = ExprState { - shaderUsedUniformBlocks :: Map.IntMap (GlobDeclM ()), +data ExprState = ExprState { + shaderUsedUniformBlocks :: Map.IntMap (GlobDeclM ()), shaderUsedSamplers :: Map.IntMap (GlobDeclM ()), - shaderUsedInput :: Map.IntMap (GlobDeclM (), (ExprM (), GlobDeclM ())) -- For vertex shaders, the shaderM is always undefined and the int is the parameter name, for later shader stages it uses some name local to the transition instead + shaderUsedInput :: Map.IntMap (GlobDeclM (), (ExprM (), GlobDeclM ())) -- For vertex shaders, the shaderM is always undefined and the int is the parameter name, for later shader stages it uses some name local to the transition instead } - + runExprM :: GlobDeclM () -> ExprM () -> IO (String, [Int], [Int], [Int], GlobDeclM (), ExprM ()) runExprM d m = do (st, body) <- evalStateT (runWriterT (execStateT (runSNMapReaderT (m :: ExprM ())) (ExprState Map.empty Map.empty Map.empty))) 0 @@ -69,7 +69,7 @@ (inpDecls, prevDesc) = unzip inpDescs (prevSs, prevDecls) = unzip prevDesc decls = do d - sequence_ uniDecls + sequence_ uniDecls sequence_ sampDecls sequence_ inpDecls source = mconcat [ @@ -77,15 +77,15 @@ execWriter decls, "void main() {\n", body, - "}\n"] + "}\n"] return (source, unis, samps, inps, sequence_ prevDecls, sequence_ prevSs) type GlobDeclM = Writer String -newtype S x a = S { unS :: ExprM String } +newtype S x a = S { unS :: ExprM String } scalarS :: SType -> ExprM RValue -> S c a -scalarS typ = S . tellAssignment typ +scalarS typ = S . tellAssignment typ vec2S :: SType -> ExprM RValue -> V2 (S c a) vec2S typ s = let V4 x y _z _w = vec4S typ s @@ -100,7 +100,7 @@ scalarS' :: RValue -> S c a scalarS' = S . return - + vec2S' :: RValue -> V2 (S c a) vec2S' = vec2S'' . S . return vec3S' :: RValue -> V3 (S c a) @@ -118,10 +118,10 @@ vec4S'' s = let f p = S $ fmap (++ ('[': show (p :: Int) ++"]")) (unS s) in V4 (f 0) (f 1) (f 2) (f 3) --- | Phantom type used as first argument in @'S' 'V' a@ that denotes that the shader value is a vertex value +-- | Phantom type used as first argument in @'S' 'V' a@ that denotes that the shader value is a vertex value data V --data P --- | Phantom type used as first argument in @'S' 'F' a@ that denotes that the shader value is a fragment value +-- | Phantom type used as first argument in @'S' 'F' a@ that denotes that the shader value is a fragment value data F type VFloat = S V Float @@ -135,35 +135,35 @@ type FBool = S F Bool useVInput :: SType -> Int -> ExprM String -useVInput stype i = +useVInput stype i = do s <- T.lift get - T.lift $ put $ s { shaderUsedInput = Map.insert i (gDeclInput, undefined) $ shaderUsedInput s } + T.lift $ put $ s { shaderUsedInput = Map.insert i (gDeclInput, undefined) $ shaderUsedInput s } return $ "in" ++ show i where gDeclInput = do tellGlobal "in " - tellGlobal $ stypeName stype + tellGlobal $ stypeName stype tellGlobal " in" tellGlobalLn $ show i useFInput :: String -> String -> SType -> Int -> ExprM String -> ExprM String useFInput qual prefix stype i v = do s <- T.lift get - T.lift $ put $ s { shaderUsedInput = Map.insert i (gDecl (qual ++ " in "), (assignOutput, gDecl (qual ++ " out "))) $ shaderUsedInput s } + T.lift $ put $ s { shaderUsedInput = Map.insert i (gDecl (qual ++ " in "), (assignOutput, gDecl (qual ++ " out "))) $ shaderUsedInput s } return $ prefix ++ show i where assignOutput = do val <- v let name = prefix ++ show i tellAssignment' name val - + gDecl s = do tellGlobal s - tellGlobal $ stypeName stype + tellGlobal $ stypeName stype tellGlobal $ ' ':prefix tellGlobalLn $ show i - + useUniform :: GlobDeclM () -> Int -> Int -> ExprM String -useUniform decls blockI offset = - do T.lift $ modify $ \ s -> s { shaderUsedUniformBlocks = Map.insert blockI gDeclUniformBlock $ shaderUsedUniformBlocks s } +useUniform decls blockI offset = + do T.lift $ modify $ \ s -> s { shaderUsedUniformBlocks = Map.insert blockI gDeclUniformBlock $ shaderUsedUniformBlocks s } return $ 'u':show blockI ++ '.':'u': show offset -- "u8.u4" where gDeclUniformBlock = @@ -176,23 +176,23 @@ tellGlobalLn blockStr useSampler :: String -> String -> Int -> ExprM String -useSampler prefix str name = - do T.lift $ modify $ \ s -> s { shaderUsedSamplers = Map.insert name gDeclSampler $ shaderUsedSamplers s } +useSampler prefix str name = + do T.lift $ modify $ \ s -> s { shaderUsedSamplers = Map.insert name gDeclSampler $ shaderUsedSamplers s } return $ 's':show name where gDeclSampler = do tellGlobal "uniform " - tellGlobal prefix + tellGlobal prefix tellGlobal "sampler" tellGlobal str tellGlobal " s" - tellGlobalLn $ show name + tellGlobalLn $ show name getNext :: Monad m => StateT Int m Int getNext = do s <- get put $ s + 1 return s - + type RValue = String tellAssignment :: SType -> ExprM RValue -> ExprM String @@ -210,7 +210,7 @@ discard :: FBool -> ExprM () discard (S m) = do b <- m when (b /= "true") $ T.lift $ T.lift $ tell $ mconcat ["if (!(", b, ")) discard;\n"] - + -- tellGlobalLn :: String -> GlobDeclM () tellGlobalLn string = tell $ string `mappend` ";\n" @@ -222,12 +222,12 @@ -- | An opaque type data ShaderBase a x where - ShaderBaseFloat :: S x Float -> ShaderBase (S x Float) x - ShaderBaseInt :: S x Int -> ShaderBase (S x Int) x - ShaderBaseWord :: S x Word -> ShaderBase (S x Word) x - ShaderBaseBool :: S x Bool -> ShaderBase (S x Bool) x - ShaderBaseUnit :: ShaderBase () x - ShaderBaseProd :: ShaderBase a x -> ShaderBase b x -> ShaderBase (a,b) x + ShaderBaseFloat :: S x Float -> ShaderBase (S x Float) x + ShaderBaseInt :: S x Int -> ShaderBase (S x Int) x + ShaderBaseWord :: S x Word -> ShaderBase (S x Word) x + ShaderBaseBool :: S x Bool -> ShaderBase (S x Bool) x + ShaderBaseUnit :: ShaderBase () x + ShaderBaseProd :: ShaderBase a x -> ShaderBase b x -> ShaderBase (a,b) x shaderbaseDeclare :: ShaderBase a x -> WriterT [String] ExprM (ShaderBase a x) shaderbaseAssign :: ShaderBase a x -> StateT [String] ExprM () @@ -237,7 +237,7 @@ shaderbaseDeclare (ShaderBaseInt _) = ShaderBaseInt <$> shaderbaseDeclareDef STypeInt shaderbaseDeclare (ShaderBaseWord _) = ShaderBaseWord <$> shaderbaseDeclareDef STypeUInt shaderbaseDeclare (ShaderBaseBool _) = ShaderBaseBool <$> shaderbaseDeclareDef STypeBool -shaderbaseDeclare ShaderBaseUnit = return ShaderBaseUnit +shaderbaseDeclare ShaderBaseUnit = return ShaderBaseUnit shaderbaseDeclare (ShaderBaseProd a b) = do a' <- shaderbaseDeclare a b' <- shaderbaseDeclare b return $ ShaderBaseProd a' b' @@ -254,7 +254,7 @@ shaderbaseReturn (ShaderBaseInt _) = ShaderBaseInt <$> shaderbaseReturnDef shaderbaseReturn (ShaderBaseWord _) = ShaderBaseWord <$> shaderbaseReturnDef shaderbaseReturn (ShaderBaseBool _) = ShaderBaseBool <$> shaderbaseReturnDef -shaderbaseReturn ShaderBaseUnit = return ShaderBaseUnit +shaderbaseReturn ShaderBaseUnit = return ShaderBaseUnit shaderbaseReturn (ShaderBaseProd a b) = do a' <- shaderbaseReturn a b' <- shaderbaseReturn b return $ ShaderBaseProd a' b' @@ -277,15 +277,15 @@ return $ S $ fmap (!!i) m -- | Constraint for types that may pass in and out of shader control structures. Define your own instances in terms of others and make sure to --- make toBase as lazy as possible. +-- make toBase as lazy as possible. class ShaderType a x where - -- | A base type that this type can convert into. Use the 'ShaderBaseType' function on an existing instance of 'ShaderType' to define this in your instance. + -- | A base type that this type can convert into. Use the 'ShaderBaseType' function on an existing instance of 'ShaderType' to define this in your instance. type ShaderBaseType a -- | Convert this type to the shader base type. Make sure this is as lazy as possible (e.g. use tilde (@~@) on each pattern match). toBase :: x -> a -> ShaderBase (ShaderBaseType a) x - -- | Convert back from the shader base type to this type. + -- | Convert back from the shader base type to this type. fromBase :: x -> ShaderBase (ShaderBaseType a) x -> a - + instance ShaderType (S x Float) x where type ShaderBaseType (S x Float) = (S x Float) toBase _ = ShaderBaseFloat @@ -295,7 +295,7 @@ type ShaderBaseType (S x Int) = (S x Int) toBase _ = ShaderBaseInt fromBase _ (ShaderBaseInt a) = a - + instance ShaderType (S x Word) x where type ShaderBaseType (S x Word) = (S x Word) toBase _ = ShaderBaseWord @@ -305,7 +305,7 @@ type ShaderBaseType (S x Bool) = (S x Bool) toBase _ = ShaderBaseBool fromBase _ (ShaderBaseBool a) = a - + instance ShaderType () x where type ShaderBaseType () = () toBase _ _ = ShaderBaseUnit @@ -344,74 +344,86 @@ type ShaderBaseType (a,b,c,d) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, ShaderBaseType d))) toBase x ~(a,b,c,d) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (toBase x d))) fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c d))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d) - +instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x) => ShaderType (a,b,c,d,e) x where + type ShaderBaseType (a,b,c,d,e) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, ShaderBaseType e)))) + toBase x ~(a,b,c,d,e) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (toBase x e)))) + fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d e)))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e) +instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x, ShaderType f x) => ShaderType (a,b,c,d,e,f) x where + type ShaderBaseType (a,b,c,d,e,f) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, (ShaderBaseType e, ShaderBaseType f))))) + toBase x ~(a,b,c,d,e,f) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (ShaderBaseProd (toBase x e) (toBase x f))))) + fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d (ShaderBaseProd e f))))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e, fromBase x f) +instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x, ShaderType f x, ShaderType g x) => ShaderType (a,b,c,d,e,f,g) x where + type ShaderBaseType (a,b,c,d,e,f,g) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, (ShaderBaseType e, (ShaderBaseType f, ShaderBaseType g)))))) + toBase x ~(a,b,c,d,e,f,g) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (ShaderBaseProd (toBase x e) (ShaderBaseProd (toBase x f) (toBase x g)))))) + fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d (ShaderBaseProd e (ShaderBaseProd f g)))))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e, fromBase x f, fromBase x g) + -- | Works just like 'ifB', return second argument if first is 'true' otherwise return third argument. --- +-- -- The difference from 'ifB' is that it in most cases generate more efficient code when @a@ is a compound type (e.g. a tuple or a vector). --- For simple types such as @S x Float@, @ifThenElse' == ifB@. +-- For simple types such as @S x Float@, @ifThenElse' == ifB@. ifThenElse' :: forall a x. (ShaderType a x) => S x Bool -> a -> a -> a ifThenElse' b t e = ifThenElse b (const t) (const e) () --- | @ifThenElse c f g x@ will return @f x@ if @c@ evaluates to 'true' or @g x@ otherwise. +-- | @ifThenElse c f g x@ will return @f x@ if @c@ evaluates to 'true' or @g x@ otherwise. -- --- In most cases functionally equivalent to 'ifThenElse'' but +-- In most cases functionally equivalent to 'ifThenElse'' but -- usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@) ifThenElse :: forall a b x. (ShaderType a x, ShaderType b x) => S x Bool -> (a -> b) -> (a -> b) -> a -> b ifThenElse c t e i = fromBase x $ ifThenElse_ c (toBase x . t . fromBase x) (toBase x . e . fromBase x) (toBase x i) where x = undefined :: x ifThenElse_ :: S x Bool -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x) -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x - ifThenElse_ bool thn els a = + ifThenElse_ bool thn els a = let ifM = memoizeM $ do boolStr <- unS bool (lifted, aDecls) <- runWriterT $ shaderbaseDeclare (toBase x (errShaderType :: a)) void $ evalStateT (shaderbaseAssign a) aDecls decls <- execWriterT $ shaderbaseDeclare (toBase x (errShaderType :: b)) - tellIf boolStr - scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls - T.lift $ T.lift $ tell "} else {\n" + tellIf boolStr + scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls + T.lift $ T.lift $ tell "} else {\n" scopedM $ void $ evalStateT (shaderbaseAssign $ els lifted) decls - T.lift $ T.lift $ tell "}\n" + T.lift $ T.lift $ tell "}\n" return decls in evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: b))) ifM) 0 --- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise. +-- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise. -- --- In most cases functionally equivalent to 'ifThenElse'' but +-- In most cases functionally equivalent to 'ifThenElse'' but -- usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@) ifThen :: forall a x. (ShaderType a x) => S x Bool -> (a -> a) -> a -> a ifThen c t i = fromBase x $ ifThen_ c (toBase x . t . fromBase x) (toBase x i) where x = undefined :: x ifThen_ :: S x Bool -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x - ifThen_ bool thn a = + ifThen_ bool thn a = let ifM = memoizeM $ do boolStr <- unS bool (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (errShaderType :: a)) void $ evalStateT (shaderbaseAssign a) decls tellIf boolStr - scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls + scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls T.lift $ T.lift $ tell "}\n" return decls in evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) ifM) 0 - + tellIf :: RValue -> ExprM () tellIf boolStr = T.lift $ T.lift $ tell $ mconcat ["if(", boolStr, "){\n" ] -- | @while f g x@ will iteratively transform @x@ with @g@ as long as @f@ generates 'true'. while :: forall a x. (ShaderType a x) => (a -> S x Bool) -> (a -> a) -> a -> a -while c f i = fromBase x $ while_ (c . fromBase x) (toBase x . f . fromBase x) (toBase x i) +while c f i = fromBase x $ while_ (c . fromBase x) (toBase x . f . fromBase x) (toBase x i) where x = undefined :: x - while_ :: (ShaderBase (ShaderBaseType a) x -> S x Bool) -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x + while_ :: (ShaderBase (ShaderBaseType a) x -> S x Bool) -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x while_ bool loopF a = let whileM = memoizeM $ do (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (errShaderType :: a)) void $ evalStateT (shaderbaseAssign a) decls boolDecl <- tellAssignment STypeBool (unS $ bool a) - T.lift $ T.lift $ tell $ mconcat ["while(", boolDecl, "){\n" ] + T.lift $ T.lift $ tell $ mconcat ["while(", boolDecl, "){\n" ] let looped = loopF lifted scopedM $ do - void $ evalStateT (shaderbaseAssign looped) decls + void $ evalStateT (shaderbaseAssign looped) decls loopedBoolStr <- unS $ bool looped tellAssignment' boolDecl loopedBoolStr T.lift $ T.lift $ tell "}\n" @@ -427,7 +439,7 @@ -------------------------------------------------------------------------------------------------------------------------------- -bin :: SType -> String -> S c x -> S c y -> S c z +bin :: SType -> String -> S c x -> S c y -> S c z bin typ o (S a) (S b) = S $ tellAssignment typ $ do a' <- a b' <- b return $ '(' : a' ++ o ++ b' ++ ")" @@ -457,7 +469,7 @@ postop :: SType -> String -> S c x -> S c y postop typ f (S a) = S $ tellAssignment typ $ do a' <- a return $ '(' : a' ++ f ++ ")" - + preop :: SType -> String -> S c x -> S c y preop typ f (S a) = S $ tellAssignment typ $ do a' <- a return $ '(' : f ++ a' ++ ")" @@ -506,7 +518,7 @@ (*) = bini "*" fromInteger = S . return . show negate = preopi "-" - + instance Num (S a Word) where (+) = binu "+" (-) = binu "-" @@ -514,7 +526,7 @@ signum = fun1u "sign" (*) = binu "*" fromInteger x = S $ return $ show x ++ "u" - negate = preopu "-" + negate = preopu "-" instance Fractional (S a Float) where (/) = binf "/" @@ -550,25 +562,25 @@ mod' = mod instance Integral' (S a Int) where div' = bini "/" - mod' = bini "%" + mod' = bini "%" instance Integral' (S a Word) where div' = binu "/" - mod' = binu "%" + mod' = binu "%" instance Integral' a => Integral' (V0 a) where - div' = liftA2 div' - mod' = liftA2 mod' + div' = liftA2 div' + mod' = liftA2 mod' instance Integral' a => Integral' (V1 a) where - div' = liftA2 div' - mod' = liftA2 mod' + div' = liftA2 div' + mod' = liftA2 mod' instance Integral' a => Integral' (V2 a) where - div' = liftA2 div' - mod' = liftA2 mod' + div' = liftA2 div' + mod' = liftA2 mod' instance Integral' a => Integral' (V3 a) where - div' = liftA2 div' - mod' = liftA2 mod' + div' = liftA2 div' + mod' = liftA2 mod' instance Integral' a => Integral' (V4 a) where - div' = liftA2 div' - mod' = liftA2 mod' + div' = liftA2 div' + mod' = liftA2 mod' instance Floating (S a Float) where pi = S $ return $ show (pi :: Float) @@ -618,7 +630,7 @@ 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. class Floating a => Real' a where @@ -639,9 +651,9 @@ mod'' x y = x - y* floor' (x/y) floor' x = -ceiling' (-x) ceiling' x = -floor' (-x) - + {-# MINIMAL floor' | ceiling' #-} - + instance Real' Float where floor' = fromIntegral . floor ceiling' = fromIntegral . ceiling @@ -649,7 +661,7 @@ instance Real' Double where floor' = fromIntegral . floor ceiling' = fromIntegral . ceiling - + instance Real' (S x Float) where rsqrt = fun1f "inversesqrt" exp2 = fun1f "exp2" @@ -661,7 +673,7 @@ mix = fun3f "mix" instance (Real' a) => Real' (V0 a) where - rsqrt = liftA rsqrt + rsqrt = liftA rsqrt exp2 = liftA exp2 log2 = liftA log2 floor' = liftA floor' @@ -670,7 +682,7 @@ mod'' = liftA2 mod'' mix = liftA3 mix instance (Real' a) => Real' (V1 a) where - rsqrt = liftA rsqrt + rsqrt = liftA rsqrt exp2 = liftA exp2 log2 = liftA log2 floor' = liftA floor' @@ -679,7 +691,7 @@ mod'' = liftA2 mod'' mix = liftA3 mix instance (Real' a) => Real' (V2 a) where - rsqrt = liftA rsqrt + rsqrt = liftA rsqrt exp2 = liftA exp2 log2 = liftA log2 floor' = liftA floor' @@ -688,7 +700,7 @@ mod'' = liftA2 mod'' mix = liftA3 mix instance (Real' a) => Real' (V3 a) where - rsqrt = liftA rsqrt + rsqrt = liftA rsqrt exp2 = liftA exp2 log2 = liftA log2 floor' = liftA floor' @@ -697,7 +709,7 @@ mod'' = liftA2 mod'' mix = liftA3 mix instance (Real' a) => Real' (V4 a) where - rsqrt = liftA rsqrt + rsqrt = liftA rsqrt exp2 = liftA exp2 log2 = liftA log2 floor' = liftA floor' @@ -706,10 +718,10 @@ mod'' = liftA2 mod'' mix = liftA3 mix --- | This class provides various order comparing functions +-- | This class provides various order comparing functions class (IfB a, OrdB a, Floating a) => FloatingOrd a where clamp :: a -> a -> a -> a - saturate :: a -> a + saturate :: a -> a step :: a -> a -> a smoothstep :: a -> a -> a -> a clamp x a = minB (maxB x a) @@ -779,7 +791,7 @@ toFloat = fun1f "float" toInt = fun1i "int" toWord = id - + -- | The derivative in x using local differencing of the rasterized value. dFdx :: FFloat -> FFloat -- | The derivative in y using local differencing of the rasterized value. @@ -792,16 +804,16 @@ --------------------------------- fromV f s v = S $ do params <- mapM (unS . f) $ toList v - return $ s ++ '(' : intercalate "," params ++ ")" + return $ s ++ '(' : intercalate "," params ++ ")" fromVec4 :: V4 (S x Float) -> S x (V4 Float) -fromVec4 = fromV id "vec4" +fromVec4 = fromV id "vec4" fromVec3 :: V3 (S x Float) -> S x (V3 Float) -fromVec3 = fromV id "vec3" +fromVec3 = fromV id "vec3" fromVec2 :: V2 (S x Float) -> S x (V2 Float) -fromVec2 = fromV id "vec2" +fromVec2 = fromV id "vec2" --- FromMat will transpose to keep inner vectors packed +-- FromMat will transpose to keep inner vectors packed fromMat22 :: V2 (V2 (S x Float)) -> S x (V2 (V2 Float)) fromMat22 = fromV fromVec2 "mat2x2" fromMat23 :: V2 (V3 (S x Float)) -> S x (V2 (V3 Float)) @@ -840,10 +852,10 @@ ------------------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------------------ --------------------------------------------------- Rewrite rules for linear types -------------------------------------------------- +-------------------------------------------------- Rewrite rules for linear types -------------------------------------------------- ------------------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------------------ - + {-# RULES "norm/length4" norm = length4 #-} {-# RULES "norm/length3" norm = length3 #-} {-# RULES "norm/length2" norm = length2 #-} @@ -857,9 +869,9 @@ {-# RULES "signorm/normalize4" signorm = normalize4 #-} {-# RULES "signorm/normalize3" signorm = normalize3 #-} {-# RULES "signorm/normalize2" signorm = normalize2 #-} -normalize4 :: V4 (S x Float) -> V4 (S x Float) +normalize4 :: V4 (S x Float) -> V4 (S x Float) normalize4 = vec4S'' . fun1 (STypeVec 4) "normalize" . fromVec4 -normalize3 :: V3 (S x Float) -> V3 (S x Float) +normalize3 :: V3 (S x Float) -> V3 (S x Float) normalize3 = vec3S'' . fun1 (STypeVec 3) "normalize" . fromVec3 normalize2 :: V2 (S x Float) -> V2 (S x Float) normalize2 = vec2S'' . fun1 (STypeVec 2) "normalize" . fromVec2 @@ -884,9 +896,9 @@ {-# RULES "minB/S" minB = minS #-} {-# RULES "maxB/S" maxB = maxS #-} -minS :: S x Float -> S x Float -> S x Float +minS :: S x Float -> S x Float -> S x Float minS = binf "min" -maxS :: S x Float -> S x Float -> S x Float +maxS :: S x Float -> S x Float -> S x Float maxS = binf "max" -------------------------------------------------------------- @@ -894,7 +906,7 @@ -- Matrix*Matrix, Vector*Matrix, Matrix*Vextor and outer Vector*Vector multiplications have operands in flipped order since glsl is column major -- inner products are not flipped since why bother :) --- Also, special verions when explicit V1 matrices are used (so eg 4 version of each dot function: v*v, v*m, m*v, m*m ) +-- Also, special verions when explicit V1 matrices are used (so eg 4 version of each dot function: v*v, v*m, m*v, m*m ) -- No rules for scalar products with vectors or matrices (eg scalar * matrix), we hope the glsl compiler will manage to optimize that... @@ -1061,23 +1073,23 @@ {-# RULES "mul_43_31" (!*) = mul_43_31 #-} {-# RULES "mul_44_41" (!*) = mul_44_41 #-} mul_22_21 :: V2 (V2 (S x Float)) -> V2 (S x Float) -> V2 (S x Float) -mul_22_21 m v = mulToV2 (fromVec2 v) (fromMat22 m) +mul_22_21 m v = mulToV2 (fromVec2 v) (fromMat22 m) mul_23_31 :: V2 (V3 (S x Float)) -> V3 (S x Float) -> V2 (S x Float) -mul_23_31 m v = mulToV2 (fromVec3 v) (fromMat23 m) +mul_23_31 m v = mulToV2 (fromVec3 v) (fromMat23 m) mul_24_41 :: V2 (V4 (S x Float)) -> V4 (S x Float) -> V2 (S x Float) -mul_24_41 m v = mulToV2 (fromVec4 v) (fromMat24 m) +mul_24_41 m v = mulToV2 (fromVec4 v) (fromMat24 m) mul_32_21 :: V3 (V2 (S x Float)) -> V2 (S x Float) -> V3 (S x Float) -mul_32_21 m v = mulToV3 (fromVec2 v) (fromMat32 m) +mul_32_21 m v = mulToV3 (fromVec2 v) (fromMat32 m) mul_33_31 :: V3 (V3 (S x Float)) -> V3 (S x Float) -> V3 (S x Float) -mul_33_31 m v = mulToV3 (fromVec3 v) (fromMat33 m) +mul_33_31 m v = mulToV3 (fromVec3 v) (fromMat33 m) mul_34_41 :: V3 (V4 (S x Float)) -> V4 (S x Float) -> V3 (S x Float) -mul_34_41 m v = mulToV3 (fromVec4 v) (fromMat34 m) +mul_34_41 m v = mulToV3 (fromVec4 v) (fromMat34 m) mul_42_21 :: V4 (V2 (S x Float)) -> V2 (S x Float) -> V4 (S x Float) -mul_42_21 m v = mulToV4 (fromVec2 v) (fromMat42 m) +mul_42_21 m v = mulToV4 (fromVec2 v) (fromMat42 m) mul_43_31 :: V4 (V3 (S x Float)) -> V3 (S x Float) -> V4 (S x Float) -mul_43_31 m v = mulToV4 (fromVec3 v) (fromMat43 m) +mul_43_31 m v = mulToV4 (fromVec3 v) (fromMat43 m) mul_44_41 :: V4 (V4 (S x Float)) -> V4 (S x Float) -> V4 (S x Float) -mul_44_41 m v = mulToV4 (fromVec4 v) (fromMat44 m) +mul_44_41 m v = mulToV4 (fromVec4 v) (fromMat44 m) {-# RULES "mul_22_21m" (!*!) = mul_22_21m #-} {-# RULES "mul_23_31m" (!*!) = mul_23_31m #-} @@ -1089,23 +1101,23 @@ {-# RULES "mul_43_31m" (!*!) = mul_43_31m #-} {-# RULES "mul_44_41m" (!*!) = mul_44_41m #-} mul_22_21m :: V2 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V2 (V1 (S x Float)) -mul_22_21m m v = V1 <$> mulToV2 (fromVec2 $ fmap unV1 v) (fromMat22 m) +mul_22_21m m v = V1 <$> mulToV2 (fromVec2 $ fmap unV1 v) (fromMat22 m) mul_23_31m :: V2 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V2 (V1 (S x Float)) -mul_23_31m m v = V1 <$> mulToV2 (fromVec3 $ fmap unV1 v) (fromMat23 m) +mul_23_31m m v = V1 <$> mulToV2 (fromVec3 $ fmap unV1 v) (fromMat23 m) mul_24_41m :: V2 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V2 (V1 (S x Float)) -mul_24_41m m v = V1 <$> mulToV2 (fromVec4 $ fmap unV1 v) (fromMat24 m) +mul_24_41m m v = V1 <$> mulToV2 (fromVec4 $ fmap unV1 v) (fromMat24 m) mul_32_21m :: V3 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V3 (V1 (S x Float)) -mul_32_21m m v = V1 <$> mulToV3 (fromVec2 $ fmap unV1 v) (fromMat32 m) +mul_32_21m m v = V1 <$> mulToV3 (fromVec2 $ fmap unV1 v) (fromMat32 m) mul_33_31m :: V3 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V3 (V1 (S x Float)) -mul_33_31m m v = V1 <$> mulToV3 (fromVec3 $ fmap unV1 v) (fromMat33 m) +mul_33_31m m v = V1 <$> mulToV3 (fromVec3 $ fmap unV1 v) (fromMat33 m) mul_34_41m :: V3 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V3 (V1 (S x Float)) -mul_34_41m m v = V1 <$> mulToV3 (fromVec4 $ fmap unV1 v) (fromMat34 m) +mul_34_41m m v = V1 <$> mulToV3 (fromVec4 $ fmap unV1 v) (fromMat34 m) mul_42_21m :: V4 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V4 (V1 (S x Float)) -mul_42_21m m v = V1 <$> mulToV4 (fromVec2 $ fmap unV1 v) (fromMat42 m) +mul_42_21m m v = V1 <$> mulToV4 (fromVec2 $ fmap unV1 v) (fromMat42 m) mul_43_31m :: V4 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V4 (V1 (S x Float)) -mul_43_31m m v = V1 <$> mulToV4 (fromVec3 $ fmap unV1 v) (fromMat43 m) +mul_43_31m m v = V1 <$> mulToV4 (fromVec3 $ fmap unV1 v) (fromMat43 m) mul_44_41m :: V4 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V4 (V1 (S x Float)) -mul_44_41m m v = V1 <$> mulToV4 (fromVec4 $ fmap unV1 v) (fromMat44 m) +mul_44_41m m v = V1 <$> mulToV4 (fromVec4 $ fmap unV1 v) (fromMat44 m) ----------------------- {-# RULES "mul_22_22" (!*!) = mul_22_22 #-}
src/Graphics/GPipe/Internal/FragmentStream.hs view
@@ -2,7 +2,7 @@ module Graphics.GPipe.Internal.FragmentStream where import Control.Category hiding ((.)) -import Control.Arrow +import Control.Arrow import Graphics.GPipe.Internal.Expr import Graphics.GPipe.Internal.Shader import Graphics.GPipe.Internal.Compiler @@ -32,25 +32,25 @@ data FragmentStreamData = FragmentStreamData RasterizationName ExprPos PrimitiveStreamData FBool -- | A @'FragmentStream' a @ is a stream of fragments of type @a@. You may append 'FragmentStream's using the 'Monoid' instance, and you --- can operate a stream's values using the 'Functor' instance (this will result in a shader running on the GPU). +-- can operate a stream's values using the 'Functor' instance (this will result in a shader running on the GPU). newtype FragmentStream a = FragmentStream [(a, FragmentStreamData)] deriving Monoid instance Functor FragmentStream where fmap f (FragmentStream xs) = FragmentStream $ map (first f) xs - + -- | The arrow type for 'toFragment'. newtype ToFragment a b = ToFragment (Kleisli (State Int) a b) deriving (Category, Arrow) --- | This class constraints which vertex types can be turned into fragment values, and what type those values have. +-- | This class constraints which vertex types can be turned into fragment values, and what type those values have. class FragmentInput a where -- | The type the vertex value will be turned into once it becomes a fragment value. type FragmentFormat a -- | An arrow action that turns a value from it's vertex representation to it's fragment representation. Use 'toFragment' from -- the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value -- lazily, so ensure you use - -- - -- @proc ~pattern -> do ...@. - toFragment :: ToFragment a (FragmentFormat a) + -- + -- @proc ~pattern -> do ...@. + toFragment :: ToFragment a (FragmentFormat a) -- | Rasterize a stream of primitives into fragments, using a 'Side', 'Viewport' and 'DepthRange' from the shader environment. -- Primitives will be transformed from canonical view space, i.e. [(-1,-1,-1),(1,1,1)], to the 2D space defined by the 'ViewPort' parameter and the depth range @@ -58,12 +58,12 @@ rasterize:: forall p a s os f. FragmentInput a => (s -> (Side, ViewPort, DepthRange)) -> PrimitiveStream p (VPos, a) - -> Shader os f s (FragmentStream (FragmentFormat a)) + -> Shader os f s (FragmentStream (FragmentFormat a)) rasterize sf (PrimitiveStream xs) = Shader $ do n <- getName modifyRenderIO (\s -> s { rasterizationNameToRenderIO = insert n io (rasterizationNameToRenderIO s) } ) - return (FragmentStream $ map (f n) xs) - where + return (FragmentStream $ map (f n) xs) + where ToFragment (Kleisli m) = toFragment :: ToFragment a (FragmentFormat a) f n ((p, x),(ps, s)) = (evalState (m x) 0, FragmentStreamData n (makePos p >> makePointSize ps) s true) makePos (V4 (S x) (S y) (S z) (S w)) = do @@ -73,12 +73,12 @@ w' <- w tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")" makePointSize Nothing = return () - makePointSize (Just (S ps)) = ps >>= tellAssignment' "gl_PointSize" - io s = let (side, ViewPort (V2 x y) (V2 w h), DepthRange dmin dmax) = sf s in if w < 0 || h < 0 + makePointSize (Just (S ps)) = ps >>= tellAssignment' "gl_PointSize" + io s = let (side, ViewPort (V2 x y) (V2 w h), DepthRange dmin dmax) = sf s in if w < 0 || h < 0 then error "ViewPort, negative size" else do setGlCullFace side glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) glDepthRange (realToFrac dmin) (realToFrac dmax) setGLPointSize @@ -91,27 +91,27 @@ data Side = Front | Back | FrontAndBack -- | The viewport in pixel coordinates (where (0,0) is the lower left corner) in to which the canonical view volume [(-1,-1,-1),(1,1,1)] is transformed and clipped/scissored. data ViewPort = ViewPort { viewPortLowerLeft :: V2 Int, viewPortSize :: V2 Int } --- | The fragment depth range to map the canonical view volume's z-coordinate to. Depth values are clamped to [0,1], so @DepthRange 0 1@ gives maximum depth resolution. +-- | The fragment depth range to map the canonical view volume's z-coordinate to. Depth values are clamped to [0,1], so @DepthRange 0 1@ gives maximum depth resolution. data DepthRange = DepthRange { minDepth :: Float, maxDepth :: Float } - + -- | Filter out fragments from the stream where the predicate in the first argument evaluates to 'true', and discard all other fragments. -filterFragments :: (a -> FBool) -> FragmentStream a -> FragmentStream a +filterFragments :: (a -> FBool) -> FragmentStream a -> FragmentStream a filterFragments f (FragmentStream xs) = FragmentStream $ map g xs - where g (a,FragmentStreamData x y z w) = (a,FragmentStreamData x y z (w &&* f a)) + where g (a,FragmentStreamData x y z w) = (a,FragmentStreamData x y z (w &&* f a)) data RasterizedInfo = RasterizedInfo { rasterizedFragCoord :: V4 FFloat, rasterizedFrontFacing :: FBool, rasterizedPointCoord :: V2 FFloat - } + } --- | Like 'fmap', but where various auto generated information from the rasterization is provided for each vertex. +-- | Like 'fmap', but where various auto generated information from the rasterization is provided for each vertex. withRasterizedInfo :: (a -> RasterizedInfo -> b) -> FragmentStream a -> FragmentStream b withRasterizedInfo f = fmap (\a -> f a (RasterizedInfo (vec4S' "gl_FragCoord") (scalarS' "gl_FrontFacing") (vec2S' "gl_PointCoord"))) --- | A float value that is not interpolated (like integers), and all fragments will instead get the value of the primitive's last vertex +-- | A float value that is not interpolated (like integers), and all fragments will instead get the value of the primitive's last vertex data FlatVFloat = Flat VFloat --- | A float value that doesn't get divided by the interpolated position's w-component during interpolation. +-- | A float value that doesn't get divided by the interpolated position's w-component during interpolation. data NoPerspectiveVFloat = NoPerspective VFloat makeFragment :: String -> SType -> (a -> ExprM String) -> ToFragment a (S c a1) @@ -130,7 +130,7 @@ instance FragmentInput VFloat where type FragmentFormat VFloat = FFloat toFragment = makeFragment "" STypeFloat unS - + instance FragmentInput FlatVFloat where type FragmentFormat FlatVFloat = FFloat toFragment = makeFragment "flat" STypeFloat (unS . unFlat) @@ -138,7 +138,7 @@ instance FragmentInput NoPerspectiveVFloat where type FragmentFormat NoPerspectiveVFloat = FFloat toFragment = makeFragment "noperspective" STypeFloat (unS . unNPersp) - + instance FragmentInput VInt where type FragmentFormat VInt = FInt toFragment = makeFragment "flat" STypeInt unS @@ -151,7 +151,7 @@ type FragmentFormat VBool = FBool toFragment = proc b -> do i <- toFragment -< ifB b 1 0 :: VInt returnA -< i ==* 1 - + instance (FragmentInput a) => FragmentInput (V0 a) where type FragmentFormat (V0 a) = V0 (FragmentFormat a) toFragment = arr (const V0) @@ -181,7 +181,7 @@ c' <- toFragment -< c d' <- toFragment -< d returnA -< V4 a' b' c' d' - + instance (FragmentInput a, FragmentInput b) => FragmentInput (a,b) where type FragmentFormat (a,b) = (FragmentFormat a, FragmentFormat b) toFragment = proc ~(a,b) -> do a' <- toFragment -< a @@ -203,19 +203,49 @@ d' <- toFragment -< d returnA -< (a', b', c', d') +instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e) => FragmentInput (a,b,c,d,e) where + type FragmentFormat (a,b,c,d,e) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e) + toFragment = proc ~(a,b,c,d,e) -> do a' <- toFragment -< a + b' <- toFragment -< b + c' <- toFragment -< c + d' <- toFragment -< d + e' <- toFragment -< e + returnA -< (a', b', c', d', e') + +instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e, FragmentInput f) => FragmentInput (a,b,c,d,e,f) where + type FragmentFormat (a,b,c,d,e,f) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e, FragmentFormat f) + toFragment = proc ~(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 -< (a', b', c', d', e', f') + +instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e, FragmentInput f, FragmentInput g) => FragmentInput (a,b,c,d,e,f,g) where + type FragmentFormat (a,b,c,d,e,f,g) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e, FragmentFormat f, FragmentFormat g) + toFragment = proc ~(a,b,c,d,e,f,g) -> do a' <- toFragment -< a + b' <- toFragment -< b + c' <- toFragment -< c + d' <- toFragment -< d + e' <- toFragment -< e + f' <- toFragment -< f + g' <- toFragment -< g + returnA -< (a', b', c', d', e', f', g') + 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
src/Graphics/GPipe/Internal/FrameBuffer.hs view
@@ -29,7 +29,7 @@ import Foreign.Ptr (nullPtr) import Linear.V4 --- | A monad in which individual color images can be drawn. +-- | A monad in which individual color images can be drawn. newtype DrawColors os s a = DrawColors (StateT Int (Writer [Int -> (ExprM (), GlobDeclM (), s -> (IO FBOKey, IO (), IO ()))]) a) deriving (Functor, Applicative, Monad) runDrawColors :: DrawColors os s a -> (ExprM (), GlobDeclM (), s -> (IO [FBOKey], IO (), IO ())) @@ -42,7 +42,7 @@ return $ ns ++ [n] , b >> y, c >> z) --- | Draw color values into a color renderable texture image. +-- | Draw color values into a color renderable texture image. drawColor :: forall c s os. ColorRenderable c => (s -> (Image (Format c), ColorMask c, UseBlending)) -> FragColor c -> DrawColors os s () drawColor sf c = DrawColors $ do n <- get put $ n+1 @@ -59,13 +59,13 @@ -- | Draw all fragments in a 'FragmentStream' using the provided function that passes each fragment value into a 'DrawColors' monad. The first argument is a function -- that retrieves a 'Blending' setting from the shader environment, which will be used for all 'drawColor' actions in the 'DrawColors' monad where 'UseBlending' is 'True'. --- (OpenGl 3.3 unfortunately doesn't support having different blending settings for different color targets.) +-- (OpenGl 3.3 unfortunately doesn't support having different blending settings for different color targets.) draw :: forall a os f s. (s -> Blending) -> FragmentStream a -> (a -> DrawColors os s ()) -> Shader os f s () --- | Like 'draw', but performs a depth test on each fragment first. The 'DrawColors' monad is then only run for fragments where the depth test passes. +-- | Like 'draw', but performs a depth test on each fragment first. The 'DrawColors' monad is then only run for fragments where the depth test passes. drawDepth :: forall a os f s d. DepthRenderable d => (s -> (Blending, Image (Format d), DepthOption)) -> FragmentStream (a, FragDepth) -> (a -> DrawColors os s ()) -> Shader os f s () --- | Like 'draw', but performs a stencil test on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil test passes. +-- | Like 'draw', but performs a stencil test on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil test passes. drawStencil :: forall a os f s st. StencilRenderable st => (s -> (Blending, Image (Format st), StencilOptions)) -> FragmentStream a -> (a -> DrawColors os s ()) -> Shader os f s () --- | Like 'draw', but performs a stencil test and a depth test (in that order) on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil and depth test passes. +-- | Like 'draw', but performs a stencil test and a depth test (in that order) on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil and depth test passes. drawDepthStencil :: forall a os f s d st. (DepthRenderable d, StencilRenderable st) => (s -> (Blending, Image (Format d), Image (Format st), DepthStencilOption)) -> FragmentStream (a, FragDepth) -> (a -> DrawColors os s ()) -> Shader os f s () makeFBOKeys :: IO [FBOKey] -> IO (Maybe FBOKey) -> IO (Maybe FBOKey) -> IO FBOKeys @@ -252,7 +252,7 @@ -- target value. type UseBlending = Bool --- | Denotes how each fragment's color value should be blended with the target value. +-- | Denotes how each fragment's color value should be blended with the target value. data Blending = -- | The fragment's color will simply replace the target value. NoBlending @@ -298,7 +298,7 @@ usesConstantColor OneMinusConstantColor = True usesConstantColor ConstantAlpha = True usesConstantColor OneMinusConstantAlpha = True -usesConstantColor _ = False +usesConstantColor _ = False -- | A bitwise logical operation that will be used to combine colors that has an integral internal representation. data LogicOp = @@ -339,11 +339,11 @@ let fbokey = FBOKeys [key] Nothing Nothing mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ lift $ do + Just fbo -> Render $ lift $ lift $ lift $ do fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ 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,9 +353,10 @@ getImageBinding i GL_COLOR_ATTACHMENT0 withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1 getFBOerror - - Render $ lift $ lift $ lift $ do + + Render $ lift $ lift $ lift $ do glDisable GL_SCISSOR_TEST + glColorMask glTrue glTrue glTrue glTrue clearColor (undefined :: c) c glEnable GL_SCISSOR_TEST @@ -366,11 +367,11 @@ let fbokey = FBOKeys [] (Just key) Nothing mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ lift $ do + Just fbo -> Render $ lift $ lift $ lift $ do fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ 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) @@ -380,8 +381,9 @@ getImageBinding i GL_DEPTH_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ lift $ do + Render $ lift $ lift $ lift $ do glDisable GL_SCISSOR_TEST + glDepthMask glTrue with (realToFrac d) $ glClearBufferfv GL_DEPTH 0 glEnable GL_SCISSOR_TEST @@ -392,11 +394,11 @@ let fbokey = FBOKeys [] Nothing (Just key) mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ lift $ do + Just fbo -> Render $ lift $ lift $ lift $ do fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ 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) @@ -406,8 +408,9 @@ getImageBinding i GL_STENCIL_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ lift $ do - glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST + glStencilMask maxBound with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0 glEnable GL_SCISSOR_TEST @@ -419,11 +422,11 @@ let fbokey = FBOKeys [] Nothing (Just key) mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey case mfbo of - Just fbo -> Render $ lift $ lift $ lift $ do + Just fbo -> Render $ lift $ lift $ lift $ do fbo' <- readIORef fbo glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo' Nothing -> do fAdd <- getRenderContextFinalizerAdder - Render $ throwFromMaybe $ lift $ 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) @@ -433,44 +436,53 @@ getImageBinding i GL_DEPTH_STENCIL_ATTACHMENT glDrawBuffers 0 nullPtr getFBOerror - Render $ lift $ lift $ lift $ do - glDisable GL_SCISSOR_TEST + Render $ lift $ lift $ lift $ do + glDisable GL_SCISSOR_TEST + glDepthMask glTrue + glStencilMask maxBound glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s) - glEnable GL_SCISSOR_TEST + 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 $ lift $ do +clearContextColor c = Render $ lift $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 - glDisable GL_SCISSOR_TEST + glDisable GL_SCISSOR_TEST + glColorMask glTrue glTrue glTrue glTrue withArray (map realToFrac (fromColor (undefined :: c) c ++ replicate 3 0 :: [Float])) $ glClearBufferfv GL_COLOR 0 - glEnable GL_SCISSOR_TEST + glEnable GL_SCISSOR_TEST --- | Fill the context window's back depth buffer with a constant depth value (in the range [0,1]) +-- | 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 $ lift $ do +clearContextDepth d = Render $ lift $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 - glDisable GL_SCISSOR_TEST + glDisable GL_SCISSOR_TEST + glDepthMask glTrue with (realToFrac d) $ glClearBufferfv GL_DEPTH 0 - glEnable GL_SCISSOR_TEST + 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 $ lift $ do +clearContextStencil s = Render $ lift $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 - glDisable GL_SCISSOR_TEST + glDisable GL_SCISSOR_TEST + glStencilMask maxBound 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 $ lift $ do +clearContextDepthStencil d s = Render $ lift $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0 - glDisable GL_SCISSOR_TEST + glDisable GL_SCISSOR_TEST + glDepthMask glTrue + glStencilMask maxBound glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s) glEnable GL_SCISSOR_TEST --------------- +glTrue :: Num n => n +glTrue = fromBool True getGlBlendEquation :: BlendEquation -> GLenum
src/Graphics/GPipe/Internal/PrimitiveStream.hs view
@@ -31,6 +31,7 @@ import Linear.Plucker (Plucker(..)) import Linear.Quaternion (Quaternion(..)) import Linear.Affine (Point(..)) +import Data.Maybe (fromMaybe) type DrawCallName = Int data PrimitiveStreamData = PrimitiveStreamData DrawCallName @@ -38,38 +39,38 @@ -- | A @'PrimitiveStream' t a @ is a stream of primitives of type @t@ where the vertices are values of type @a@. You -- can operate a stream's vertex values using the 'Functor' instance (this will result in a shader running on the GPU). -- You may also append 'PrimitiveStream's using the 'Monoid' instance, but if possible append the origin 'PrimitiveArray's instead, as this will create more optimized --- draw calls. +-- draw calls. newtype PrimitiveStream t a = PrimitiveStream [(a, (Maybe PointSize, PrimitiveStreamData))] deriving Monoid instance Functor (PrimitiveStream t) where fmap f (PrimitiveStream xs) = PrimitiveStream $ map (first f) xs --- | This class constraints which buffer types can be turned into vertex values, and what type those values have. +-- | This class constraints which buffer types can be turned into vertex values, and what type those values have. class BufferFormat a => VertexInput a where -- | The type the buffer value will be turned into once it becomes a vertex value. type VertexFormat a -- | An arrow action that turns a value from it's buffer representation to it's vertex representation. Use 'toVertex' from -- the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value -- lazily, so ensure you use - -- - -- @proc ~pattern -> do ...@. - toVertex :: ToVertex a (VertexFormat a) + -- + -- @proc ~pattern -> do ...@. + toVertex :: ToVertex a (VertexFormat a) -- | The arrow type for 'toVertex'. newtype ToVertex a b = ToVertex (Kleisli (StateT Int (Writer [Binding -> (IO VAOKey, IO ())])) a b) deriving (Category, Arrow) --- | Create a primitive stream from a primitive array provided from the shader environment. -toPrimitiveStream :: forall os f s a p. VertexInput a => (s -> PrimitiveArray p a) -> Shader os f s (PrimitiveStream p (VertexFormat a)) +-- | Create a primitive stream from a primitive array provided from the shader environment. +toPrimitiveStream :: forall os f s a p. VertexInput a => (s -> PrimitiveArray p a) -> Shader os f s (PrimitiveStream p (VertexFormat a)) toPrimitiveStream sf = Shader $ do n <- getName uniAl <- askUniformAlignment let sampleBuffer = makeBuffer undefined undefined uniAl :: Buffer os a x = fst $ runWriter (evalStateT (mf $ bufBElement sampleBuffer $ BInput 0 0) 0) doForInputArray n (map drawcall . getPrimitiveArray . sf) - return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n))] - where + return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n))] + where ToVertex (Kleisli mf) = toVertex :: ToVertex a (VertexFormat a) - drawcall (PrimitiveArraySimple p l a) binds = (attribs a binds, glDrawArrays (toGLtopology p) 0 (fromIntegral l)) + drawcall (PrimitiveArraySimple p l a) binds = (attribs a binds, glDrawArrays (toGLtopology p) 0 (fromIntegral l)) drawcall (PrimitiveArrayIndexed p i a) binds = (attribs a binds, do bindIndexBuffer i glDrawElements (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i * glSizeOf (indexType i))) @@ -77,22 +78,22 @@ drawcall (PrimitiveArrayIndexedInstanced p i il a) binds = (attribs a binds, do bindIndexBuffer i glDrawElementsInstanced (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i * glSizeOf (indexType i)) (fromIntegral il)) - bindIndexBuffer i = do case restart i of Just x -> do glEnable GL_PRIMITIVE_RESTART + bindIndexBuffer i = do case restart i of Just x -> do glEnable GL_PRIMITIVE_RESTART glPrimitiveRestartIndex (fromIntegral x) Nothing -> glDisable GL_PRIMITIVE_RESTART bname <- readIORef (iArrName i) glBindBuffer GL_ELEMENT_ARRAY_BUFFER bname glSizeOf GL_UNSIGNED_INT = 4 glSizeOf GL_UNSIGNED_SHORT = 2 - glSizeOf GL_UNSIGNED_BYTE = 1 - glSizeOf _ = error "toPrimitiveStream: Unknown indexArray type" + glSizeOf GL_UNSIGNED_BYTE = 1 + glSizeOf _ = error "toPrimitiveStream: Unknown indexArray type" - assignIxs :: Int -> Binding -> [Int] -> [Binding -> (IO VAOKey, IO ())] -> [(IO VAOKey, IO ())] + assignIxs :: Int -> Binding -> [Int] -> [Binding -> (IO VAOKey, IO ())] -> [(IO VAOKey, IO ())] assignIxs n ix xxs@(x:xs) (f:fs) | x == n = f ix : assignIxs (n+1) (ix+1) xs fs | otherwise = assignIxs (n+1) ix xxs fs - assignIxs _ _ [] _ = [] + assignIxs _ _ [] _ = [] assignIxs _ _ _ _ = error "Too few attributes generated in toPrimitiveStream" - + attribs a binds = first sequence $ second sequence_ $ unzip $ assignIxs 0 0 binds $ execWriter (runStateT (mf a) 0) doForInputArray :: Int -> (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())]) -> ShaderM s () @@ -103,18 +104,18 @@ inputInstanceID :: VInt } --- | Like 'fmap', but where the vertex and instance IDs are provided as arguments as well. -withInputIndices :: (a -> InputIndices -> b) -> PrimitiveStream p a -> PrimitiveStream p b +-- | Like 'fmap', but where the vertex and instance IDs are provided as arguments as well. +withInputIndices :: (a -> InputIndices -> b) -> PrimitiveStream p a -> PrimitiveStream p b withInputIndices f = fmap (\a -> f a (InputIndices (scalarS' "gl_VertexID") (scalarS' "gl_InstanceID"))) type PointSize = VFloat -- | Like 'fmap', but where each point's size is provided as arguments as well, and a new point size is set for each point in addition to the new vertex value. -- -- When a 'PrimitiveStream' of 'Points' is created, all points will have the default size of 1. -withPointSize :: (a -> PointSize -> (b, PointSize)) -> PrimitiveStream Points a -> PrimitiveStream Points b -withPointSize f (PrimitiveStream xs) = PrimitiveStream $ map (\(a, (ps, d)) -> let (b, ps') = f a (maybe (scalarS' "1") id ps) in (b, (Just ps', d))) xs +withPointSize :: (a -> PointSize -> (b, PointSize)) -> PrimitiveStream Points a -> PrimitiveStream Points b +withPointSize f (PrimitiveStream xs) = PrimitiveStream $ map (\(a, (ps, d)) -> let (b, ps') = f a (fromMaybe (scalarS' "1") ps) in (b, (Just ps', d))) xs -makeVertexFx norm x f styp typ b = do +makeVertexFx norm x f styp typ b = do n <- get put $ n + 1 let combOffset = bStride b * bSkipElems b + bOffset b @@ -123,15 +124,15 @@ , do bn <- readIORef $ bName b let ix' = fromIntegral ix glEnableVertexAttribArray ix' - glBindBuffer GL_ARRAY_BUFFER bn + glBindBuffer GL_ARRAY_BUFFER bn glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) glVertexAttribPointer ix' x typ (fromBool norm) (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))] return (f styp $ useVInput styp n) -makeVertexFnorm = makeVertexFx True +makeVertexFnorm = makeVertexFx True makeVertexF = makeVertexFx False -makeVertexI x f styp typ b = do +makeVertexI x f styp typ b = do n <- get put $ n + 1 let combOffset = bStride b * bSkipElems b + bOffset b @@ -141,9 +142,9 @@ let ix' = fromIntegral ix glEnableVertexAttribArray ix' glBindBuffer GL_ARRAY_BUFFER bn - glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) + glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) glVertexAttribIPointer ix' x typ (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))] - return (f styp $ useVInput styp n) + return (f styp $ useVInput styp n) -- scalars @@ -166,7 +167,7 @@ type VertexFormat (B Word32) = VWord toVertex = ToVertex $ Kleisli $ makeVertexI 1 (const S) STypeUInt GL_UNSIGNED_INT - + -- B2 instance VertexInput (B2 Float) where @@ -284,7 +285,7 @@ instance VertexInput () where type VertexFormat () = () toVertex = arr (const ()) - + instance (VertexInput a, VertexInput b) => VertexInput (a,b) where type VertexFormat (a,b) = (VertexFormat a, VertexFormat b) toVertex = proc ~(a,b) -> do a' <- toVertex -< a @@ -306,6 +307,36 @@ d' <- toVertex -< d returnA -< (a', b', c', d') +instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d, VertexInput e) => VertexInput (a,b,c,d,e) where + type VertexFormat (a,b,c,d,e) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e) + toVertex = proc ~(a,b,c,d,e) -> do a' <- toVertex -< a + b' <- toVertex -< b + c' <- toVertex -< c + d' <- toVertex -< d + e' <- toVertex -< e + returnA -< (a', b', c', d', e') + +instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d, VertexInput e, VertexInput f) => VertexInput (a,b,c,d,e,f) where + type VertexFormat (a,b,c,d,e,f) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e, VertexFormat f) + toVertex = proc ~(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 -< (a', b', c', d', e', f') + +instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d, VertexInput e, VertexInput f, VertexInput g) => VertexInput (a,b,c,d,e,f,g) where + type VertexFormat (a,b,c,d,e,f,g) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e, VertexFormat f, VertexFormat g) + toVertex = proc ~(a,b,c,d,e,f,g) -> do a' <- toVertex -< a + b' <- toVertex -< b + c' <- toVertex -< c + d' <- toVertex -< d + e' <- toVertex -< e + f' <- toVertex -< f + g' <- toVertex -< g + returnA -< (a', b', c', d', e', f', g') + instance VertexInput a => VertexInput (V0 a) where type VertexFormat (V0 a) = V0 (VertexFormat a) toVertex = arr (const V0) @@ -336,20 +367,20 @@ d' <- toVertex -< 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 @@ -361,4 +392,4 @@ f' <- toVertex -< f returnA -< Plucker a' b' c' d' e' f' - +
src/Graphics/GPipe/Internal/Uniform.hs view
@@ -2,7 +2,7 @@ module Graphics.GPipe.Internal.Uniform where -import Graphics.GPipe.Internal.Buffer +import Graphics.GPipe.Internal.Buffer import Graphics.GPipe.Internal.Shader import Graphics.GPipe.Internal.Compiler import Graphics.GPipe.Internal.Expr @@ -26,28 +26,28 @@ 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. +-- | This class constraints which buffer types can be loaded as uniforms, and what type those values have. class BufferFormat a => UniformInput a where - -- | The type the buffer value will be turned into once it becomes a vertex or fragment value (the @x@ parameter is either 'V' or 'F'). + -- | The type the buffer value will be turned into once it becomes a vertex or fragment value (the @x@ parameter is either 'V' or 'F'). type UniformFormat a x -- | An arrow action that turns a value from it's buffer representation to it's vertex or fragment representation. Use 'toUniform' from -- the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value -- lazily, so ensure you use - -- - -- @proc ~pattern -> do ...@. - toUniform :: ToUniform x a (UniformFormat a x) + -- + -- @proc ~pattern -> do ...@. + toUniform :: ToUniform x a (UniformFormat a x) --- | Load a uniform value from a 'Buffer' into a 'Shader'. The argument function is used to retrieve the buffer and the index into this buffer from the shader environment. +-- | Load a uniform value from a 'Buffer' into a 'Shader'. The argument function is used to retrieve the buffer and the index into this buffer from the shader environment. getUniform :: forall os f s b x. (UniformInput b) => (s -> (Buffer os (Uniform b), Int)) -> Shader os f s (UniformFormat b x) getUniform sf = Shader $ do - uniAl <- askUniformAlignment + uniAl <- askUniformAlignment blockId <- getName let (u, offToStype) = shaderGen (useUniform (buildUDecl offToStype) blockId) sampleBuffer = makeBuffer undefined undefined uniAl :: Buffer os (Uniform b) shaderGen :: (Int -> ExprM String) -> (UniformFormat b x, OffsetToSType) -- Int is name of uniform block shaderGen = runReader $ runWriterT $ shaderGenF $ fromBUnifom $ bufBElement sampleBuffer $ BInput 0 0 - doForUniform blockId $ \s bind -> let (ub, i) = sf s - in if i < 0 || i >= bufferLength ub + doForUniform blockId $ \s bind -> let (ub, i) = sf s + in if i < 0 || i >= bufferLength ub then error "toUniformBlock, uniform buffer offset out of bounds" else do bname <- readIORef $ bufName ub @@ -61,7 +61,7 @@ doForUniform n io = modifyRenderIO (\s -> s { uniformNameToRenderIO = insert n io (uniformNameToRenderIO s) } ) buildUDecl :: OffsetToSType -> GlobDeclM () -buildUDecl = buildUDecl' 0 . Map.toAscList +buildUDecl = buildUDecl' 0 . Map.toAscList where buildUDecl' p xxs@((off, stype):xs) | off == p = do tellGlobal $ stypeName stype tellGlobal " u" tellGlobalLn $ show off @@ -72,10 +72,10 @@ | otherwise = error "buildUDecl: Expected all offsets to be multiple of 4" buildUDecl' _ [] = return () -type OffsetToSType = Map.IntMap SType - +type OffsetToSType = Map.IntMap SType + -- | The arrow type for 'toUniform'. -newtype ToUniform x a b = ToUniform (Kleisli (WriterT OffsetToSType (Reader (Int -> ExprM String))) a b) deriving (Category, Arrow) +newtype ToUniform x a b = ToUniform (Kleisli (WriterT OffsetToSType (Reader (Int -> ExprM String))) a b) deriving (Category, Arrow) makeUniform :: SType -> ToUniform x (B a) (S x b) makeUniform styp = ToUniform $ Kleisli $ \bIn -> do let offset = bOffset bIn @@ -160,12 +160,12 @@ b' <- toUniform -< b c' <- toUniform -< c d' <- toUniform -< d - returnA -< V4 a' b' c' d' + returnA -< V4 a' b' c' d' instance UniformInput () where type UniformFormat () x = () toUniform = arr (const ()) - + instance (UniformInput a, UniformInput b) => UniformInput (a,b) where type UniformFormat (a,b) x = (UniformFormat a x, UniformFormat b x) toUniform = proc ~(a,b) -> do a' <- toUniform -< a @@ -179,7 +179,7 @@ c' <- toUniform -< c returnA -< (a', b', c') -instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d) => UniformInput (a,b,c,d) where +instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d) => UniformInput (a,b,c,d) where type UniformFormat (a,b,c,d) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x) toUniform = proc ~(a,b,c,d) -> do a' <- toUniform -< a b' <- toUniform -< b @@ -187,14 +187,44 @@ d' <- toUniform -< d returnA -< (a', b', c', d') - +instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e) => UniformInput (a,b,c,d,e) where + type UniformFormat (a,b,c,d,e) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x) + toUniform = proc ~(a,b,c,d,e) -> do a' <- toUniform -< a + b' <- toUniform -< b + c' <- toUniform -< c + d' <- toUniform -< d + e' <- toUniform -< e + returnA -< (a', b', c', d', e') + +instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e, UniformInput f) => UniformInput (a,b,c,d,e,f) where + type UniformFormat (a,b,c,d,e,f) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x, UniformFormat f x) + toUniform = proc ~(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 -< (a', b', c', d', e', f') + +instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e, UniformInput f, UniformInput g) => UniformInput (a,b,c,d,e,f,g) where + type UniformFormat (a,b,c,d,e,f,g) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x, UniformFormat f x, UniformFormat g x) + toUniform = proc ~(a,b,c,d,e,f,g) -> do a' <- toUniform -< a + b' <- toUniform -< b + c' <- toUniform -< c + d' <- toUniform -< d + e' <- toUniform -< e + f' <- toUniform -< f + g' <- toUniform -< g + returnA -< (a', b', c', d', e', f', g') + + 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