GPipe 1.0.4 → 1.1.0
raw patch · 11 files changed
+563/−434 lines, 11 filesdep +Vec-Booleandep +list-triesPVP ok
version bump matches the API change (PVP)
Dependencies added: Vec-Boolean, list-tries
API changes (from Hackage documentation)
+ Graphics.GPipe.Stream: class Convert a where { type family ConvertFloat a; type family ConvertInt a; }
+ Graphics.GPipe.Stream: toFloat :: (Convert a) => a -> ConvertFloat a
+ Graphics.GPipe.Stream: toInt :: (Convert a) => a -> ConvertInt a
Files
- GPipe.cabal +2/−2
- src/Formats.hs +24/−10
- src/GPUStream.hs +11/−22
- src/Graphics/GPipe/Format.hs +1/−1
- src/Graphics/GPipe/Stream.hs +3/−1
- src/InputAssembler.hs +1/−2
- src/OutputMerger.hs +1/−1
- src/Rasterizer.hs +8/−24
- src/Resources.hs +62/−46
- src/Shader.hs +438/−313
- src/Textures.hs +12/−12
GPipe.cabal view
@@ -1,5 +1,5 @@ name: GPipe-version: 1.0.4+version: 1.1.0 cabal-version: >= 1.2.3 build-type: Simple license: BSD3@@ -7,7 +7,7 @@ copyright: Tobias Bexelius maintainer: Tobias Bexelius build-depends: Boolean -any, GLUT >=2.2.2.0, OpenGL >=2.4.0.1,- Vec -any, base == 4.1.0.0, containers -any, mtl -any+ Vec -any, Vec-Boolean -any, base == 4.1.0.0, containers -any, mtl -any, list-tries -any stability: Experimental homepage: http://www.haskell.org/haskellwiki/GPipe package-url: http://hackage.haskell.org/package/GPipe
src/Formats.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- -- Module : Formats @@ -38,6 +39,7 @@ import Data.Vec ((:.)(..), Vec3, Vec4, zipWith) import Prelude hiding (zipWith) import Data.Boolean +import Data.Vec.Boolean -- | A GPU format with only an alpha value. -- These are the associated types in 'GPUFormat' and 'ColorFormat':@@ -49,40 +51,40 @@ -- | A GPU format with a single color component. -- These are the associated types in 'GPUFormat' and 'ColorFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+-- [@CPUFormat LuminanceFormat@] 'CPUFormat1Comp' ----- [@Color AlphaFormat a@] @Luminance a@+-- [@Color LuminanceFormat a@] @Luminance a@ data LuminanceFormat = Luminance4 | Luminance8 | Luminance12 | Luminance16 | SLuminance8 deriving (Eq,Ord,Bounded,Enum,Show) -- | A GPU format with a single color component and an alpha value. -- These are the associated types in 'GPUFormat' and 'ColorFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat2Comp'+-- [@CPUFormat LuminanceAlphaFormat@] 'CPUFormat2Comp' ----- [@Color AlphaFormat a@] @LuminanceAlpha a a@+-- [@Color LuminanceAlphaFormat a@] @LuminanceAlpha a a@ data LuminanceAlphaFormat = Luminance4Alpha4 | Luminance6Alpha2 | Luminance8Alpha8 | Luminance12Alpha4 | Luminance12Alpha12 | Luminance16Alpha16 | SLuminance8Alpha8 deriving (Eq,Ord,Bounded,Enum,Show) -- | A GPU format with color components for red, green and blue. -- These are the associated types in 'GPUFormat' and 'ColorFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat3Comp'+-- [@CPUFormat RGBFormat@] 'CPUFormat3Comp' ----- [@Color AlphaFormat a@] @RGB (@'Vec3'@ a)@+-- [@Color RGBFormat a@] @RGB (@'Vec3'@ a)@ data RGBFormat = R3G3B2 | RGB4 | RGB5 | RGB8 | RGB10 | RGB12 | RGB16 | SRGB8 deriving (Eq,Ord,Bounded,Enum,Show) -- | A GPU format with color components for red, green and blue, and an alpha value. -- These are the associated types in 'GPUFormat' and 'ColorFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat4Comp'+-- [@CPUFormat RGBAFormat@] 'CPUFormat4Comp' ----- [@Color AlphaFormat a@] @RGBA (@'Vec3'@ a) a@+-- [@Color RGBAFormat a@] @RGBA (@'Vec3'@ a) a@ data RGBAFormat = RGBA2 | RGBA4 | RGB5A1 | RGBA8 | RGB10A2 | RGBA12 | RGBA16 | SRGBA8 deriving (Eq,Ord,Bounded,Enum,Show) -- | A GPU format for a depth buffer value. -- This is the associated type in 'GPUFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+-- [@CPUFormat DepthFormat@] 'CPUFormat1Comp' data DepthFormat = Depth16 | Depth24 | Depth32 deriving (Eq,Ord,Bounded,Enum,Show) -- | A GPU format for a stencil buffer value. -- This is the associated type in 'GPUFormat': ----- [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'+-- [@CPUFormat StencilFormat@] 'CPUFormat1Comp' data StencilFormat = StencilFormat deriving (Eq,Ord,Bounded,Enum,Show) -- | A CPU format for 4 components (i.e. a RGBA color). @@ -273,3 +275,15 @@ data Color RGBAFormat a = RGBA (Vec3 a) a deriving (Eq,Ord,Show) fromColor _ _ (RGBA (a:.b:.c:.()) d) = a:.b:.c:.d:.() toColor (a:.b:.c:.d:.()) = RGBA (a:.b:.c:.()) d + +instance IfB bool a => IfB bool (Color AlphaFormat a) where + ifB c (Alpha t) (Alpha e) = Alpha (ifB c t e) +instance IfB bool a => IfB bool (Color LuminanceFormat a) where + ifB c (Luminance t) (Luminance e) = Luminance (ifB c t e) +instance IfB bool a => IfB bool (Color LuminanceAlphaFormat a) where + ifB c (LuminanceAlpha t1 t2) (LuminanceAlpha e1 e2) = LuminanceAlpha (ifB c t1 e1) (ifB c t2 e2) +instance IfB bool a => IfB bool (Color RGBFormat a) where + ifB c (RGB t) (RGB e) = RGB (ifB c t e) +instance IfB bool a => IfB bool (Color RGBAFormat a) where + ifB c (RGBA t1 t2) (RGBA e1 e2) = RGBA (ifB c t1 e1) (ifB c t2 e2) +
src/GPUStream.hs view
@@ -21,7 +21,6 @@ Line(..), Point(..), VertexSetup(..), - FragmentSetup, PrimitiveStreamDesc, FragmentStreamDesc, filterFragments, @@ -50,9 +49,8 @@ type VertexPosition = Vec4 (Vertex Float) data CullMode = CullNone | CullFront | CullBack deriving (Eq,Ord,Bounded,Enum,Show) data VertexSetup = VertexSetup [[Float]] | IndexedVertexSetup [[Float]] [Int] deriving (Eq,Ord,Show) -type FragmentSetup = [Shader String] type PrimitiveStreamDesc = (GL.PrimitiveMode, VertexSetup) -type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, FragmentSetup, Shader String) +type FragmentStreamDesc = (PrimitiveStreamDesc, CullMode, Vec4 (Vertex Float)) instance Functor (PrimitiveStream p) where fmap f (PrimitiveStream a) = PrimitiveStream $ map (second f) a @@ -111,28 +109,19 @@ layerMapM_ f (x:xs) io = layerMapM_ f xs (f x io) layerMapM_ _ [] io = io -drawCallColor (((p, vs), cull, rast, vPos), nd, c) io = - let (fp, funs, fins) = fragmentProgram $ colorFragmentShader nd c - (vp, vuns, vins) = vertexProgram vPos rast fins - in drawCall p cull vins vs vp fp vuns funs io - -drawCallColorDepth (((p, vs), cull, rast, vPos), nd, cd) io = - let (fp, funs, fins) = fragmentProgram $ colorDepthFragmentShader nd cd - (vp, vuns, vins) = vertexProgram vPos rast fins - in drawCall p cull vins vs vp fp vuns funs io - +drawCallColor (((p, vs), cull, vPos), nd, c) io = drawCall p cull vs io $ getShaders vPos nd c Nothing +drawCallColorDepth (((p, vs), cull, vPos), nd, (c,d)) io = drawCall p cull vs io $ getShaders vPos nd c (Just d) mapSelect = map . select where select (x:xs) ys = let (a:b) = drop x ys in a: select (map (\t-> t-x-1) xs) b select [] _ = [] - -drawCall p cull ins (VertexSetup v) vp fp vuns funs io = do +drawCall p cull (VertexSetup v) io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do xs <- ioEvaluate (mapSelect ins v) ins' <- ioEvaluate ins - vp' <- ioEvaluate vp - fp' <- ioEvaluate fp + vkey' <- ioEvaluate vkey + fkey' <- ioEvaluate fkey s <- ioEvaluate (length ins) vs <- ioEvaluate (length v) vuns'<-ioEvaluate vuns @@ -140,7 +129,7 @@ cull'<-ioEvaluate cull p'<-ioEvaluate p io - (pr, (vu, fu)) <- createProgramResource vp' fp' s + (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s vb <- createVertexBuffer xs ins' v useProgramResource pr useUniforms vu vuns' @@ -148,12 +137,12 @@ liftIO $ do useCull cull' drawVertexBuffer p' vb vs -drawCall p cull ins (IndexedVertexSetup v i) vp fp vuns funs io = do +drawCall p cull (IndexedVertexSetup v i) io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do i' <- ioEvaluate i xs <- ioEvaluate (mapSelect ins v) ins' <- ioEvaluate ins - vp' <- ioEvaluate vp - fp' <- ioEvaluate fp + vkey' <- ioEvaluate vkey + fkey' <- ioEvaluate fkey s <- ioEvaluate (length ins) vs <- ioEvaluate (length v) vuns'<-ioEvaluate vuns @@ -161,7 +150,7 @@ cull'<-ioEvaluate cull p'<-ioEvaluate p io - (pr, (vu, fu)) <- createProgramResource vp' fp' s + (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s ib <- createIndexBuffer i' vs vb <- createVertexBuffer xs ins' v useProgramResource pr
src/Graphics/GPipe/Format.hs view
@@ -9,7 +9,7 @@ -- Portability : Portable -- -- | This module defines the various formats that are used by 'FrameBuffer's and textures, both--- in the GPU and the CPU.+-- on the GPU and the CPU. ----------------------------------------------------------------------------- module Graphics.GPipe.Format (
src/Graphics/GPipe/Stream.hs view
@@ -21,13 +21,15 @@ -- * Common classes GPU(..), Real'(..),+ Convert(..), -- * Reexports (:.)(..),Vec2,Vec3,Vec4, module Data.Vec.LinAlg, - module Data.Boolean, + module Data.Boolean ) where import Shader import Data.Boolean import Data.Vec import Data.Vec.LinAlg+import Data.Vec.Boolean()
src/InputAssembler.hs view
@@ -40,8 +40,7 @@ instance VertexInput (Vertex Float) where toVertex a = InputAssembler $ do x <- gets length modify (a:) - return $ Vertex $ do addInput x - return $ "va" ++ show x + return $ inputVertex x instance VertexInput () where toVertex () = return () instance (VertexInput a,VertexInput b) => VertexInput (a,b) where
src/OutputMerger.hs view
@@ -71,7 +71,7 @@ type DepthFunction = ComparisonFunction -- | Sets how the painted colors are blended with the 'FrameBuffer's previous value. -data Blending = NoBlending -- ^ The painted fragment completely overwrites the previous value .+data Blending = NoBlending -- ^ The painted fragment completely overwrites the previous value. | Blend (BlendEquation, BlendEquation) ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) (Color RGBAFormat Float) -- ^ Use blending equations to combine the fragment with the previous value.
src/Rasterizer.hs view
@@ -23,11 +23,11 @@ import Shader import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) import GPUStream -import Control.Monad.State +import Control.Monad.Identity -- | A monad in which vertex data gets converted to fragment data. -- Use 'toFragment' in the existing instances of 'VertexOutput' to operate in this monad. -newtype Rasterizer a = Rasterizer {fromRasterizer :: State [Shader String] a} deriving Monad +newtype Rasterizer a = Rasterizer {fromRasterizer :: Identity a} deriving (Functor, Monad) -- | The context of types that can be rasterized from vertices in 'PrimitiveStream's to fragments in 'FragmentStream's. -- Create your own instances in terms of the existing ones, e.g. convert your vertex data to 'Vertex' 'Float's, @@ -42,10 +42,7 @@ instance VertexOutput (Vertex Float) where type FragmentInput (Vertex Float) = Fragment Float - toFragment (Vertex a) = Rasterizer $ do x <- gets length - modify (a:) - return $ Fragment $ do addInput x - return $ "fa" ++ show x + toFragment = Rasterizer . return . rasterizeVertex instance VertexOutput () where type FragmentInput () = () @@ -81,8 +78,7 @@ -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. rasterizeFront (PrimitiveStream []) = FragmentStream [] rasterizeFront (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, fs, getPositionCode pos), true, fa) - where (fa, fs) = getFragmentInput va + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullBack, pos), true, getFragmentInput va) -- | Rasterize both sides of triangles with vertices containing canonical view coordinates into fragments, also returning the primitives side in the fragments. rasterizeFrontAndBack :: VertexOutput a@@ -90,8 +86,7 @@ -> FragmentStream (Fragment Bool, FragmentInput a) -- ^ The resulting fragment stream with fragments containing a bool saying if the primitive was front facing and the interpolated values. rasterizeFrontAndBack (PrimitiveStream []) = FragmentStream [] rasterizeFrontAndBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, fs, getPositionCode pos), true, (Fragment $ return "gl_FrontFacing", fa)) - where (fa, fs) = getFragmentInput va + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullNone, pos), true, (fragmentFrontFacing, getFragmentInput va)) -- | Rasterize back side of triangles with vertices containing canonical view coordinates into fragments. rasterizeBack :: VertexOutput a@@ -99,22 +94,11 @@ -> FragmentStream (FragmentInput a) -- ^ The resulting fragment stream with fragments containing the interpolated values. rasterizeBack (PrimitiveStream []) = FragmentStream [] rasterizeBack (PrimitiveStream xs) = FragmentStream $ map rasterizeOne xs - where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, fs, getPositionCode pos), true, fa) - where (fa, fs) = getFragmentInput va + where rasterizeOne (pdesc, (pos, va)) = ((pdesc, CullFront, pos), true, getFragmentInput va) -------------------------------------- -- Private -- -getPositionCode (Vertex x :. Vertex y :. Vertex z :. Vertex w :. ()) = do x' <- x - y' <- y - z' <- z - w' <- w - return $ "vec4(" ++ x' ++ "," ++ y' ++ "," ++ z' ++ "," ++ w' ++ ")" - -getFragmentInput :: VertexOutput a => a -> (FragmentInput a, [Shader String]) -getFragmentInput = flip runState [] . revState . fromRasterizer . toFragment - where - revState m = do x <- m - modify reverse - return x +getFragmentInput :: VertexOutput a => a -> FragmentInput a +getFragmentInput = runIdentity . fromRasterizer . toFragment
src/Resources.hs view
@@ -23,7 +23,7 @@ VertexBuffer(..), IndexBuffer(..), UniformLocationSet, - UniformState(..), + UniformSet, ContextCacheIO, ContextCache(contextWindow,contextViewPort), newContextCache, @@ -44,16 +44,21 @@ getCurrentOrSetHiddenContext, ioEvaluate, evaluateDeep, - evaluatePtr + evaluatePtr, + ShaderInfo, + ShaderKey, + ShaderKeyNode(..), + Op, + Const(..), + Uniform(..) ) where -import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp) +import Graphics.Rendering.OpenGL hiding (Sampler3D, Sampler2D, Sampler1D, SamplerCube, Point, Linear, Clamp, Uniform) import qualified Data.HashTable as HT import qualified Graphics.UI.GLUT as GLUT import Data.Map (Map) import qualified Data.Map as Map import System.Mem.StableName- (makeStableName, hashStableName, StableName) import Data.Bits import Control.Monad.Reader import Control.Monad@@ -69,24 +74,33 @@ import Foreign.ForeignPtr import System.Mem.Weak (addFinalizer) import Data.Unique - +import Data.ListTrie.Patricia.Map (TrieMap) +import qualified Data.ListTrie.Patricia.Map as TrieMap +import Data.ListTrie.Base.Map (WrappedIntMap) data VertexBuffer = VertexBuffer BufferObject Int data IndexBuffer = IndexBuffer BufferObject Int DataType type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation) data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded) +type UniformSet = ([Float],[Int],[Bool],Map SamplerType [(Sampler, WinMappedTexture)]) -data UniformState = UniformState - { - floatUniforms :: Map Unique Float, - intUniforms :: Map Unique Int, - boolUniforms :: Map Unique Bool, - sampler3DUniforms :: Map Unique (Sampler, WinMappedTexture), - sampler2DUniforms :: Map Unique (Sampler, WinMappedTexture), - sampler1DUniforms :: Map Unique (Sampler, WinMappedTexture), - samplerCubeUniforms :: Map Unique (Sampler, WinMappedTexture) - } deriving Eq +type ShaderInfo = (ShaderKey, String, UniformSet) +type ShaderKey = ([Int], [(ShaderKeyNode, [Int])]) +data ShaderKeyNode = ShaderKeyUniform + | ShaderKeyConstant !Const + | ShaderKeyInput !Int + | ShaderKeyOp !Op + deriving (Eq, Ord) +type Op = String +data Const = ConstFloat Float + | ConstInt Int + | ConstBool Bool + deriving (Eq, Ord) +data Uniform = UniformFloat Float + | UniformInt Int + | UniformBool Bool + | UniformSampler SamplerType Sampler WinMappedTexture -- | A structure describing how a texture is sampled data Sampler = Sampler Filter EdgeMode deriving (Eq, Ord) @@ -103,7 +117,20 @@ toGLWrap Mirror = (Mirrored, Repeat) toGLWrap Clamp = (Repeated, ClampToEdge) -type ProgramCache = HT.HashTable (String, String) (Program, (UniformLocationSet,UniformLocationSet)) +type ProgramCacheValue = (Program, (UniformLocationSet,UniformLocationSet)) +type ProgramCacheMap = TrieMap Map (ShaderKeyNode, [Int]) (TrieMap Map (ShaderKeyNode, [Int]) (TrieMap WrappedIntMap Int (TrieMap WrappedIntMap Int ProgramCacheValue))) +type ProgramCache = IORef ProgramCacheMap -- (Map (ShaderKey, ShaderKey) (Program, (UniformLocationSet,UniformLocationSet))) +pCacheLookup :: ShaderKey -> ShaderKey -> ProgramCacheMap -> Maybe ProgramCacheValue +pCacheLookup (k3, k1) (k4, k2) m1 = TrieMap.lookup k1 m1 >>= TrieMap.lookup k2 >>= TrieMap.lookup k3 >>= TrieMap.lookup k4 +pCacheInsert :: ShaderKey -> ShaderKey -> ProgramCacheValue -> ProgramCacheMap -> ProgramCacheMap +pCacheInsert (k3, k1) (k4, k2) v m1 = TrieMap.alter' ins2 k1 m1 + where ins2 Nothing = Just $ TrieMap.singleton k2 $ TrieMap.singleton k3 $ TrieMap.singleton k4 v + ins2 (Just m2) = Just $ TrieMap.alter' ins3 k2 m2 + ins3 Nothing = Just $ TrieMap.singleton k3 $ TrieMap.singleton k4 v + ins3 (Just m3) = Just $ TrieMap.alter' ins4 k3 m3 + ins4 Nothing = Just $ TrieMap.singleton k4 v + ins4 (Just m4) = Just $ TrieMap.insert k4 v m4 + type VBCache = HT.HashTable ([Int], StableName [[Float]]) VertexBuffer type IBCache = HT.HashTable (StableName [Int]) IndexBuffer data ContextCache = ContextCache {programCache :: ProgramCache, @@ -113,7 +140,7 @@ contextViewPort :: Size} newContextCache :: GLUT.Window -> IO ContextCache newContextCache w = do - pc <- HT.new (==) (\(a,b)-> HT.hashString a `xor` HT.hashString b) + pc <- newIORef TrieMap.empty vbc <- HT.new (==) (\(a,b) -> HT.hashString (map toEnum a) `xor` HT.hashInt (hashStableName b)) ibc <- HT.new (==) (HT.hashInt . hashStableName) let cache = ContextCache pc vbc ibc w (Size 0 0) @@ -139,11 +166,11 @@ else do e <- get $ shaderInfoLog s error $ e ++ "\nSource:\n\n" ++ str -createProgramResource :: (String,String) -> (String,String) -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet)) -createProgramResource (vstr,vsig) (fstr,fsig) s = do +createProgramResource :: ShaderKey -> String -> ShaderKey -> String -> Int -> ContextCacheIO (Program, (UniformLocationSet,UniformLocationSet)) +createProgramResource vkey vstr fkey fstr s = do cache <- asks programCache - test <- liftIO $ HT.lookup cache (vsig,fsig) - case test of + m <- liftIO $ readIORef cache + case pCacheLookup vkey fkey m of Just p -> return p Nothing -> liftIO $ do [p] <- genObjectNames 1 @@ -152,7 +179,7 @@ fs <- createShaderResource fstr attachedShaders p $= ([vs],[fs]) mapM_ - (\i -> attribLocation p ("attr" ++ show i) $= AttribLocation i) + (\i -> attribLocation p ("v" ++ show i) $= AttribLocation i) [0..fromIntegral ((s-1) `div` 4)] linkProgram p b <- get $ linkStatus p @@ -160,18 +187,18 @@ e <- get $ programInfoLog p error e let allSamplers = [minBound..maxBound :: SamplerType] - fvu <- get $ uniformLocation p "fvu" - ivu <- get $ uniformLocation p "ivu" - bvu <- get $ uniformLocation p "bvu" - svus' <- mapM (\ s -> get $ uniformLocation p $ "s" ++ show (fromEnum s) ++"vu") allSamplers + fvu <- get $ uniformLocation p "vuf" + ivu <- get $ uniformLocation p "vui" + bvu <- get $ uniformLocation p "vub" + svus' <- mapM (\ s -> get $ uniformLocation p $ "vus" ++ show (fromEnum s)) allSamplers let svus = Map.fromAscList $ zip allSamplers svus' - ffu <- get $ uniformLocation p "ffu" - ifu <- get $ uniformLocation p "ifu" - bfu <- get $ uniformLocation p "bfu" - sfus' <- mapM (\ s -> get $ uniformLocation p $ "s" ++ show (fromEnum s) ++"fu") allSamplers + ffu <- get $ uniformLocation p "fuf" + ifu <- get $ uniformLocation p "fui" + bfu <- get $ uniformLocation p "fub" + sfus' <- mapM (\ s -> get $ uniformLocation p $ "fus" ++ show (fromEnum s)) allSamplers let sfus = Map.fromAscList $ zip allSamplers sfus' let p' = (p, ((fvu,ivu,bvu,svus),(ffu,ifu,bfu,sfus))) - HT.insert cache (vsig,fsig) p' + atomicModifyIORef cache (flip (,) () . pCacheInsert vkey fkey p') return p' createVertexBuffer :: [[Float]] -> [Int] -> [[Float]] -> ContextCacheIO VertexBuffer @@ -232,27 +259,16 @@ useProgramResource :: Program -> ContextCacheIO () useProgramResource p = liftIO $ currentProgram $= Just p -useUniforms :: UniformLocationSet -> UniformState -> ContextCacheIO () -useUniforms (fu,iu,bu,su) uns = do +useUniforms :: UniformLocationSet -> UniformSet -> ContextCacheIO () +useUniforms (fu,iu,bu,su) (f,i,b,s) = do w <- asks contextWindow liftIO $ do unless (null f) $ withArray (map (TexCoord1 . realToFrac) f :: [TexCoord1 GLfloat]) $ uniformv fu (fromIntegral $ length f) unless (null i) $ withArray (map (TexCoord1 . fromIntegral) i :: [TexCoord1 GLint]) $ uniformv iu (fromIntegral $ length i) unless (null b) $ withArray (map (TexCoord1 . fromBool) b :: [TexCoord1 GLint]) $ uniformv bu (fromIntegral $ length b) - unless (null s3) $ useSampler w Sampler3D s3 - unless (null s2) $ useSampler w Sampler2D s2 - unless (null s1) $ useSampler w Sampler1D s1 - unless (null sc) $ useSampler w SamplerCube sc + mapM_ (useSampler w) $ Map.toList s where - f = Map.elems $ floatUniforms uns - i = Map.elems $ intUniforms uns - b = Map.elems $ boolUniforms uns - s3 = Map.elems $ sampler3DUniforms uns - s2 = Map.elems $ sampler2DUniforms uns - s1 = Map.elems $ sampler1DUniforms uns - sc = Map.elems $ samplerCubeUniforms uns - - useSampler w t xs = do + useSampler w (t, xs) = do let texs = nub xs samplers <- mapM (createSampler w t) $ zip texs [0..] let texToSamp = zip texs samplers
src/Shader.hs view
@@ -14,23 +14,22 @@ module Shader ( GPU(..), - Shader, - addInput, - runShader, - vertexProgram, - fragmentProgram, - colorFragmentShader, - colorDepthFragmentShader, - addVertexSamplerUniform, - addFragmentSamplerUniform, - Vertex(Vertex), - Fragment(Fragment), + rasterizeVertex, + inputVertex, + fragmentFrontFacing, + Vertex(), + Fragment(), + ShaderInfo, + getShaders, Real'(..), + Convert(..), dFdx, dFdy, fwidth, - vSampleFunc, - fSampleFunc, + vSampleBinFunc, + fSampleBinFunc, + vSampleTernFunc, + fSampleTernFunc, module Data.Boolean ) where @@ -39,16 +38,22 @@ import qualified Data.Vec as Vec import Data.Unique import Data.List +import Data.Maybe import Data.Boolean import Control.Monad.State import Data.Map (Map) import qualified Data.Map as Map hiding (Map) +import qualified Data.HashTable as HT +import Control.Exception (evaluate)+import System.Mem.StableName import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet hiding (IntSet) import Control.Arrow (first, second) import Resources import Formats +infixl 7 `mod'` + -- | Denotes a type on the GPU, that can be moved there from the CPU (through the internal use of uniforms). -- Use the existing instances of this class to create new ones. Note that 'toGPU' should not be strict on its argument. -- Its definition should also always use the same series of 'toGPU' calls to convert values of the same type. This unfortunatly@@ -59,154 +64,72 @@ -- | Converts a value from the CPU to the GPU. toGPU :: CPU a -> a -type Shader = State (UniformState, IntSet) - - -setFloatUniforms a = modify $ first $ \ u -> u{floatUniforms=a} -setIntUniforms a = modify $ first $ \ u -> u{intUniforms=a} -setBoolUniforms a = modify $ first $ \ u -> u{boolUniforms=a} -setSampler3DUniforms a = modify $ first $ \ u -> u{sampler3DUniforms=a} -setSampler2DUniforms a = modify $ first $ \ u -> u{sampler2DUniforms=a} -setSampler1DUniforms a = modify $ first $ \ u -> u{sampler1DUniforms=a} -setSamplerCubeUniforms a = modify $ first $ \ u -> u{samplerCubeUniforms=a} - - -vertexProgram vPos rast fins = let ((pos, outs), uns, ins) = runShader $ do vPos' <- vPos - rast' <- selectM fins rast - return (vPos', rast') - sig = shaderInputSplits "attr" "va" ins ++ - vertexOutputSets fins outs ++ - "gl_Position = " ++ pos ++ ";\n" - in (("#version 120\n" ++ - uniformDecls "vu" uns ++ - attributeDecls ins ++ - varyingDecls outs ++ - "void main(){\n" ++ - sig ++ - "}\n", sig), uns, ins) - -fragmentProgram m = let (outs, uns,ins) = runShader m - sig = shaderInputSplits "var" "fa" ins ++outs - in (("#version 120\n" ++ - uniformDecls "fu" uns ++ - varyingDecls ins ++ - "void main(){\n" ++ - sig ++ - "}\n", sig), uns, ins) - -selectM (x:xs) ys = let (a:b) = drop x ys in do a' <- a - b' <- selectM (map (\t -> t-x-1) xs) b - return (a':b') -selectM [] _ = return [] --colorFragmentShader :: Fragment Bool -> Vec4 (Fragment Float) -> Shader String -colorFragmentShader (Fragment nDisc) (Fragment r :. Fragment g :. Fragment b :. Fragment a :. ()) = - do r' <- r - g' <- g - b' <- b - a' <- a - nDisc' <- nDisc - return $ "if (!" ++ nDisc' ++ ") discard;\n" - ++ "gl_FragColor=vec4(" ++ r' ++ "," ++ g' ++ "," ++ b' ++ "," ++ a' ++ ");\n" - -colorDepthFragmentShader :: Fragment Bool -> (Vec4 (Fragment Float), Fragment Float) -> Shader String -colorDepthFragmentShader (Fragment nDisc) ((Fragment r :. Fragment g :. Fragment b :. Fragment a :. ()), Fragment d) = - do r' <- r - g' <- g - b' <- b - a' <- a - d' <- d - nDisc' <- nDisc - return $ "if (!" ++ nDisc' ++ ") discard;\n" - ++ "gl_FragDepth=" ++ d' ++ ";\n" ++ - "gl_FragColor=vec4(" ++ r' ++ "," ++ g' ++ "," ++ b' ++ "," ++ a' ++ ");\n" - -uniformDecls :: String -> UniformState -> String -uniformDecls p uns = makeU "float f" floatUniforms ++ - makeU "int i" intUniforms ++ - makeU "bool b" boolUniforms ++ - makeU ("sampler3D s" ++ show (fromEnum Sampler3D)) sampler3DUniforms ++ - makeU ("sampler2D s" ++ show (fromEnum Sampler2D)) sampler2DUniforms ++ - makeU ("sampler1D s" ++ show (fromEnum Sampler1D)) sampler1DUniforms ++ - makeU ("samplerCube sc" ++ show (fromEnum SamplerCube)) samplerCubeUniforms - where makeU tn f = if Map.null (f uns) - then "" - else "uniform " ++ tn ++ p ++ "[" ++ show (Map.size (f uns)) ++ "];\n" - --- Generates e.g. [(0,4), (1,4), (2,3)] from [x,x,x,x,x,x,x,x,x,x,x] (length 11) -inputVecs ins = [(i,min (length ins - i*4) 4) | i <- [0..(length ins - 1) `div` 4]] - -attributeDecls ins = concat [ "attribute " ++ tName v ++ " attr" ++ show i ++ ";\n" | (i,v) <- inputVecs ins] -varyingDecls ins = concat [ "varying " ++ tName v ++ " var" ++ show i ++ ";\n" | (i,v) <- inputVecs ins] --shaderInputSplits :: String -> String -> [Int] -> String -shaderInputSplits from to ins = concat [ "float " ++ to ++ show i ++ " = " ++ from ++ show a ++ subElem c e ++ ";\n" | i <- ins | (a,e) <- inputVecs ins, c <- [0..3]] -vertexOutputSets ins outs = concat [ "var" ++ show v ++ subElem c e ++ " = " ++ outs!!i ++ ";\n" | i <- ins | (v,e) <- inputVecs ins, c <- [0..3]] --subElem :: Int -> Int -> String -subElem _ 1 = "" -subElem x _ = ['.', (['x','y','z','w']!!x)] --tName :: Int -> String -tName 1 = "float" -tName x = "vec" ++ show x - --vSampleFunc f t s tex c xs = toColor $ fromVVec 4 (vListFunc f $ [addVertexSamplerUniform t s tex, vVec c] ++ xs) -fSampleFunc f t s tex c xs = toColor $ fromFVec 4 (fListFunc f $ [addFragmentSamplerUniform t s tex, fVec c] ++ xs) +data ShaderTree = ShaderUniform !Uniform + | ShaderConstant !Const + | ShaderInput !Int + | ShaderInputTree ShaderTree + | ShaderOp !Op (String -> [String] -> String) [ShaderTree] +type ShaderDAG = ([Int],[(ShaderTree, [Int])]) -addVertexSamplerUniform Sampler3D s t = Vertex $ addUniform ("s" ++ show (fromEnum Sampler3D) ++ "vu") sampler3DUniforms setSampler3DUniforms (s,t) -addVertexSamplerUniform Sampler2D s t = Vertex $ addUniform ("s" ++ show (fromEnum Sampler2D) ++ "vu") sampler2DUniforms setSampler2DUniforms (s,t) -addVertexSamplerUniform Sampler1D s t = Vertex $ addUniform ("s" ++ show (fromEnum Sampler1D) ++ "vu") sampler1DUniforms setSampler1DUniforms (s,t) -addVertexSamplerUniform SamplerCube s t = Vertex $ addUniform ("s" ++ show (fromEnum SamplerCube) ++ "vu") samplerCubeUniforms setSamplerCubeUniforms (s,t) -addFragmentSamplerUniform Sampler3D s t = Fragment $ addUniform ("s" ++ show (fromEnum Sampler3D) ++ "fu") sampler3DUniforms setSampler3DUniforms (s,t) -addFragmentSamplerUniform Sampler2D s t = Fragment $ addUniform ("s" ++ show (fromEnum Sampler2D) ++ "fu") sampler2DUniforms setSampler2DUniforms (s,t) -addFragmentSamplerUniform Sampler1D s t = Fragment $ addUniform ("s" ++ show (fromEnum Sampler1D) ++ "fu") sampler1DUniforms setSampler1DUniforms (s,t) -addFragmentSamplerUniform SamplerCube s t = Fragment $ addUniform ("s" ++ show (fromEnum SamplerCube) ++ "fu") samplerCubeUniforms setSamplerCubeUniforms (s,t) - -- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'.-newtype Vertex a = Vertex { fromVertex :: Shader String } +newtype Vertex a = Vertex { fromVertex :: ShaderTree } -- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. -newtype Fragment a = Fragment { fromFragment :: Shader String } - -runShader :: Shader a -> (a, UniformState, [Int]) -runShader m = (a, fst s, IntSet.toAscList $ snd s) - where (a,s) = runState m (UniformState Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty, IntSet.empty) --addInput :: Int -> Shader () -addInput = modify . second . IntSet.insert+newtype Fragment a = Fragment { fromFragment :: ShaderTree } -addUniform p getter setter u = do x <- gets (getter . fst) - case Map.lookupIndex n x of - Nothing -> do let x' = Map.insert n u' x - s = Map.findIndex n x' - setter x' - return $ p ++ "[" ++ show s ++ "]" - Just i -> return $ p ++ "[" ++ show i ++ "]" - where (n,u') = unsafePerformIO $ do n <- newUnique - return (n,u) --wire u to make it happen as often as we want... - +rasterizeVertex :: Vertex Float -> Fragment Float +rasterizeVertex = Fragment . ShaderInputTree . fromVertex +inputVertex :: Int -> Vertex Float +inputVertex = Vertex . ShaderInput +fragmentFrontFacing :: Fragment Bool+fragmentFrontFacing = Fragment $ ShaderOp "gl_ff" (assign "bool" (const "gl_FrontFacing")) [] +getShaders :: Vec4 (Vertex Float) -> Fragment Bool -> Vec4 (Fragment Float) -> Maybe (Fragment Float) -> (ShaderInfo, ShaderInfo, [Int]) +getShaders pos (Fragment ndisc) color mdepth = ((createShaderKey vdag,vstr,vuns),(createShaderKey fdag,fstr,funs), inputs) + where fcolor = fromFragment $ fFromVec "vec4" color + (varyings, fdag@(fcolor':ndisc':mdepth',_)) = splitShaders (createDAG (fcolor:ndisc: map fromFragment (maybeToList mdepth))) + vpos = fromVertex $ vFromVec "vec4" pos + vdag@(vpos':varyings',_) = createDAG (vpos:varyings) + inputs = extractInputs vdag + vcodeAssigns = getCodeAssignments (fromJust . flip elemIndex inputs) "v" vdag + vCodeFinish = setVaryings varyings' ++ + "gl_Position = t" ++ show vpos' ++ ";\n" + fcodeAssigns = getCodeAssignments id "f" fdag + depthAssign = case mdepth' of [d] -> "gl_FragDepth = t" ++ show d ++ ";\n" + [] -> "" + fcodeFinish = "if (!t" ++ show ndisc' ++ ") discard;\n" ++ + depthAssign ++ + "gl_FragColor = t" ++ show fcolor' ++ ";\n" + vuns = extractUniforms vdag + funs = extractUniforms fdag + attributeDecl = inoutDecls "attribute" "v" (length inputs) + varyingDecl = inoutDecls "varying" "f" (length varyings') + vstr = makeShader (attributeDecl ++ varyingDecl ++ uniformDecls "v" vuns) (vcodeAssigns ++ vCodeFinish) + fstr = makeShader (varyingDecl ++ uniformDecls "f" funs) (fcodeAssigns ++ fcodeFinish) + +vSampleBinFunc f t s tex c = toColor $ vToVec "float" 4 (vBinaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c)) +fSampleBinFunc f t s tex c = toColor $ fToVec "float" 4 (fBinaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c)) +vSampleTernFunc f t s tex c x = toColor $ vToVec "float" 4 (vTernaryFunc "vec4" f (Vertex $ ShaderUniform $ UniformSampler t s tex) (vFromVec (tName c) c) x) +fSampleTernFunc f t s tex c x = toColor $ fToVec "float" 4 (fTernaryFunc "vec4" f (Fragment $ ShaderUniform $ UniformSampler t s tex) (fFromVec (tName c) c) x) + instance GPU (Vertex Float) where type CPU (Vertex Float) = Float - toGPU = Vertex . addUniform "fvu" floatUniforms setFloatUniforms + toGPU = Vertex . ShaderUniform . UniformFloat instance GPU (Vertex Int) where type CPU (Vertex Int) = Int - toGPU = Vertex . addUniform "ivu" intUniforms setIntUniforms + toGPU = Vertex . ShaderUniform . UniformInt instance GPU (Vertex Bool) where type CPU (Vertex Bool) = Bool - toGPU = Vertex . addUniform "bvu" boolUniforms setBoolUniforms + toGPU = Vertex . ShaderUniform . UniformBool instance GPU (Fragment Float) where type CPU (Fragment Float) = Float - toGPU = Fragment . addUniform "ffu" floatUniforms setFloatUniforms + toGPU = Fragment . ShaderUniform . UniformFloat instance GPU (Fragment Int) where type CPU (Fragment Int) = Int - toGPU = Fragment . addUniform "ifu" intUniforms setIntUniforms + toGPU = Fragment . ShaderUniform . UniformInt instance GPU (Fragment Bool) where type CPU (Fragment Bool) = Bool - toGPU = Fragment . addUniform "bfu" boolUniforms setBoolUniforms - + toGPU = Fragment . ShaderUniform . UniformBool instance GPU () where type CPU () = () @@ -231,79 +154,100 @@ instance Eq (Fragment a) where (==) = noFun "(==)" (/=) = noFun "(/=)" - -instance Ord a => Ord (Vertex a) where - (<=) = noFun "(<=)" - min = vBinaryFunc "min" - max = vBinaryFunc "max" -instance Ord a => Ord (Fragment a) where - (<=) = noFun "(<=)" - min = fBinaryFunc "min" - max = fBinaryFunc "max" - instance Show (Vertex a) where show = noFun "show" instance Show (Fragment a) where show = noFun "show" -instance Num a => Num (Vertex a) where - negate = vUnaryPreOp "-" - (+) = vBinaryOp "+" - (*) = vBinaryOp "*" - fromInteger a = Vertex $ return $ show (fromInteger a :: a) - abs = vUnaryFunc "abs" - signum = vUnaryFunc "sign" -instance Num a => Num (Fragment a) where - negate = fUnaryPreOp "-" - (+) = fBinaryOp "+" - (*) = fBinaryOp "*" - fromInteger a = Fragment $ return $ show (fromInteger a :: a) - abs = fUnaryFunc "abs" - signum = fUnaryFunc "sign" - -instance Fractional a => Fractional (Vertex a) where - (/) = vBinaryOp "/" - fromRational a = Vertex $ return $ show (fromRational a :: a) -instance Fractional a => Fractional (Fragment a) where - (/) = fBinaryOp "/" - fromRational a = Fragment $ return $ show (fromRational a :: a) - -instance Floating a => Floating (Vertex a) where - pi = fromRational (toRational (pi :: Double)) - sqrt = vUnaryFunc "sqrt" - exp = vUnaryFunc "exp" - log = vUnaryFunc "log" - (**) = vBinaryFunc "pow" - sin = vUnaryFunc "sin" - cos = vUnaryFunc "cos" - tan = vUnaryFunc "tan" - asin = vUnaryFunc "asin" - acos = vUnaryFunc "acos" - atan = vUnaryFunc "atan" - sinh = noFun "sinh" - cosh = noFun "cosh" - asinh = noFun "asinh" - atanh = noFun "atanh" - acosh = noFun "acosh" +instance Ord (Vertex Float) where + (<=) = noFun "(<=)" + min = vBinaryFunc "float" "min" + max = vBinaryFunc "float" "max" +instance Ord (Fragment Float) where + (<=) = noFun "(<=)" + min = fBinaryFunc "float" "min" + max = fBinaryFunc "float" "max" +instance Num (Vertex Float) where + negate = vUnaryPreOp "float" "-" + (+) = vBinaryOp "float" "+" + (*) = vBinaryOp "float" "*" + fromInteger = Vertex . ShaderConstant . ConstFloat . fromInteger + abs = vUnaryFunc "float" "abs" + signum = vUnaryFunc "float" "sign" +instance Num (Fragment Float) where + negate = fUnaryPreOp "float" "-" + (+) = fBinaryOp "float" "+" + (*) = fBinaryOp "float" "*" + fromInteger = Fragment . ShaderConstant . ConstFloat . fromInteger + abs = fUnaryFunc "float" "abs" + signum = fUnaryFunc "float" "sign" + -instance Floating a => Floating (Fragment a) where - pi = fromRational (toRational (pi :: Double)) - sqrt = fUnaryFunc "sqrt" - exp = fUnaryFunc "exp" - log = fUnaryFunc "log" - (**) = fBinaryFunc "pow" - sin = fUnaryFunc "sin" - cos = fUnaryFunc "cos" - tan = fUnaryFunc "tan" - asin = fUnaryFunc "asin" - acos = fUnaryFunc "acos" - atan = fUnaryFunc "atan" +instance Ord (Vertex Int) where + (<=) = noFun "(<=)" + min = noFun "min" + max = noFun "max" +instance Ord (Fragment Int) where + (<=) = noFun "(<=)" + min = noFun "min" + max = noFun "max" +instance Num (Vertex Int) where + negate = vUnaryPreOp "int" "-" + (+) = vBinaryOp "int" "+" + (*) = vBinaryOp "int" "*" + fromInteger = Vertex . ShaderConstant . ConstInt . fromInteger + abs = noFun "abs" + signum = noFun "sign" +instance Num (Fragment Int) where + negate = fUnaryPreOp "int" "-" + (+) = fBinaryOp "int" "+" + (*) = fBinaryOp "int" "*" + fromInteger = Fragment . ShaderConstant . ConstInt . fromInteger + abs = noFun "abs" + signum = noFun "sign" + + +instance Fractional (Vertex Float) where + (/) = vBinaryOp "float" "/" + fromRational = Vertex . ShaderConstant . ConstFloat . fromRational +instance Fractional (Fragment Float) where + (/) = fBinaryOp "float" "/" + fromRational = Fragment . ShaderConstant . ConstFloat . fromRational +instance Floating (Vertex Float) where + pi = Vertex $ ShaderConstant $ ConstFloat pi + sqrt = vUnaryFunc "float" "sqrt" + exp = vUnaryFunc "float" "exp" + log = vUnaryFunc "float" "log" + (**) = vBinaryFunc "float" "pow" + sin = vUnaryFunc "float" "sin" + cos = vUnaryFunc "float" "cos" + tan = vUnaryFunc "float" "tan" + asin = vUnaryFunc "float" "asin" + acos = vUnaryFunc "float" "acos" + atan = vUnaryFunc "float" "atan" + sinh = noFun "float" "sinh" + cosh = noFun "float" "cosh" + asinh = noFun "float" "asinh" + atanh = noFun "float" "atanh" + acosh = noFun "float" "acosh" +instance Floating (Fragment Float) where + pi = Fragment $ ShaderConstant $ ConstFloat pi + sqrt = fUnaryFunc "float" "sqrt" + exp = fUnaryFunc "float" "exp" + log = fUnaryFunc "float" "log" + (**) = fBinaryFunc "float" "pow" + sin = fUnaryFunc "float" "sin" + cos = fUnaryFunc "float" "cos" + tan = fUnaryFunc "float" "tan" + asin = fUnaryFunc "float" "asin" + acos = fUnaryFunc "float" "acos" + atan = fUnaryFunc "float" "atan" sinh = noFun "sinh" cosh = noFun "cosh" asinh = noFun "asinh" atanh = noFun "atanh" acosh = noFun "acosh" -+ -- | 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. -- Minimal complete definition: 'floor'' and 'ceiling''.@@ -343,85 +287,123 @@ ceiling' = fromIntegral . ceiling instance Real' (Vertex Float) where - rsqrt = vUnaryFunc "inversesqrt" - exp2 = vUnaryFunc "exp2" - log2 = vUnaryFunc "log2" - floor' = vUnaryFunc "floor" - ceiling' = vUnaryFunc "ceil" - fract' = vUnaryFunc "fract" - mod' = vBinaryFunc "mod" - clamp x a b = vListFunc "clamp" [x,a,b] - mix x y a = vListFunc "mix" [x,y,a] - step = vBinaryFunc "step" - smoothstep a b x = vListFunc "smoothstep" [a,b,x] + rsqrt = vUnaryFunc "float" "inversesqrt" + exp2 = vUnaryFunc "float" "exp2" + log2 = vUnaryFunc "float" "log2" + floor' = vUnaryFunc "float" "floor" + ceiling' = vUnaryFunc "float" "ceil" + fract' = vUnaryFunc "float" "fract" + mod' = vBinaryFunc "float" "mod" + clamp = vTernaryFunc "float" "clamp" + mix = vTernaryFunc "float" "mix" + step = vBinaryFunc "float" "step" + smoothstep = vTernaryFunc "float" "smoothstep" instance Real' (Fragment Float) where - rsqrt = fUnaryFunc "inversesqrt" - exp2 = fUnaryFunc "exp2" - log2 = fUnaryFunc "log2" - floor' = fUnaryFunc "floor" - ceiling' = fUnaryFunc "ceil" - fract' = fUnaryFunc "fract" - mod' = fBinaryFunc "mod" - clamp x a b = fListFunc "clamp" [x,a,b] - mix x y a = fListFunc "mix" [x,y,a] - step = fBinaryFunc "step" - smoothstep a b x = fListFunc "smoothstep" [a,b,x] + rsqrt = fUnaryFunc "float" "inversesqrt" + exp2 = fUnaryFunc "float" "exp2" + log2 = fUnaryFunc "float" "log2" + floor' = fUnaryFunc "float" "floor" + ceiling' = fUnaryFunc "float" "ceil" + fract' = fUnaryFunc "float" "fract" + mod' = fBinaryFunc "float" "mod" + clamp = fTernaryFunc "float" "clamp" + mix = fTernaryFunc "float" "mix" + step = fBinaryFunc "float" "step" + smoothstep = fTernaryFunc "float" "smoothstep" instance Boolean (Vertex Bool) where - true = Vertex $ return "true" - false = Vertex $ return "false" - notB = vUnaryPreOp "!" - (&&*) = vBinaryOp "&&" - (||*) = vBinaryOp "||" - + true = Vertex $ ShaderConstant $ ConstBool True + false = Vertex $ ShaderConstant $ ConstBool False + notB = vUnaryPreOp "bool" "!" + (&&*) = vBinaryOp "bool" "&&" + (||*) = vBinaryOp "bool" "||" instance Boolean (Fragment Bool) where - true = Fragment $ return "true" - false = Fragment $ return "false" - notB = fUnaryPreOp "!" - (&&*) = fBinaryOp "&&" - (||*) = fBinaryOp "||" - + true = Fragment $ ShaderConstant $ ConstBool True + false = Fragment $ ShaderConstant $ ConstBool False + notB = fUnaryPreOp "bool" "!" + (&&*) = fBinaryOp "bool" "&&" + (||*) = fBinaryOp "bool" "||" instance Eq a => EqB (Vertex Bool) (Vertex a) where - (==*) = vBinaryOp "==" - (/=*) = vBinaryOp "!=" - + (==*) = vBinaryOp "bool" "==" + (/=*) = vBinaryOp "bool" "!=" instance Eq a => EqB (Fragment Bool) (Fragment a) where - (==*) = fBinaryOp "==" - (/=*) = fBinaryOp "!=" - + (==*) = fBinaryOp "bool" "==" + (/=*) = fBinaryOp "bool" "!=" instance Ord a => OrdB (Vertex Bool) (Vertex a) where - (<*) = vBinaryOp "<" - (>=*) = vBinaryOp ">=" - (>*) = vBinaryOp ">" - (<=*) = vBinaryOp "<=" + (<*) = vBinaryOp "bool" "<" + (>=*) = vBinaryOp "bool" ">=" + (>*) = vBinaryOp "bool" ">" + (<=*) = vBinaryOp "bool" "<=" instance Ord a => OrdB (Fragment Bool) (Fragment a) where - (<*) = fBinaryOp "<" - (>=*) = fBinaryOp ">=" - (>*) = fBinaryOp ">" - (<=*) = fBinaryOp "<=" - -instance IfB (Vertex Bool) (Vertex a) where - ifB c a b = Vertex $ do c' <- fromVertex c - a' <- fromVertex a - b' <- fromVertex b - return $ "(" ++ c' ++ "?" ++ a' ++ ":" ++ b' ++ ")" + (<*) = fBinaryOp "bool" "<" + (>=*) = fBinaryOp "bool" ">=" + (>*) = fBinaryOp "bool" ">" + (<=*) = fBinaryOp "bool" "<=" -instance IfB (Fragment Bool) (Fragment a) where - ifB c a b = Fragment $ do c' <- fromFragment c - a' <- fromFragment a - b' <- fromFragment b - return $ "(" ++ c' ++ "?" ++ a' ++ ":" ++ b' ++ ")" +instance IfB (Vertex Bool) (Vertex Int) where + ifB c a b = Vertex $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] +instance IfB (Vertex Bool) (Vertex Float) where + ifB c a b = Vertex $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] +instance IfB (Vertex Bool) (Vertex Bool) where + ifB c a b = Vertex $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromVertex c,fromVertex a,fromVertex b] + +instance IfB (Fragment Bool) (Fragment Int) where + ifB c a b = Fragment $ ShaderOp "if" (assign "int" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] +instance IfB (Fragment Bool) (Fragment Float) where + ifB c a b = Fragment $ ShaderOp "if" (assign "float" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] +instance IfB (Fragment Bool) (Fragment Bool) where + ifB c a b = Fragment $ ShaderOp "if" (assign "bool" (\[a,b,c]->a++"?"++b++":"++c)) [fromFragment c,fromFragment a,fromFragment b] +-- | Provides a common way to convert numeric types to integer and floating point representations.+class Convert a where+ type ConvertFloat a+ type ConvertInt a+ -- | Convert to a floating point number.+ toFloat :: a -> ConvertFloat a+ -- | Convert to an integral number, using truncation if necessary.+ toInt :: a -> ConvertInt a++instance Convert Float where+ type ConvertFloat Float = Float+ type ConvertInt Float = Int+ toFloat = id+ toInt = truncate+instance Convert Int where+ type ConvertFloat Int = Float+ type ConvertInt Int = Int+ toFloat = fromIntegral+ toInt = id+instance Convert (Vertex Float) where+ type ConvertFloat (Vertex Float) = Vertex Float+ type ConvertInt (Vertex Float) = Vertex Int+ toFloat = id+ toInt = vUnaryFunc "int" "int"+instance Convert (Vertex Int) where+ type ConvertFloat (Vertex Int) = Vertex Float+ type ConvertInt (Vertex Int) = Vertex Int+ toFloat = vUnaryFunc "float" "float"+ toInt = id+instance Convert (Fragment Float) where+ type ConvertFloat (Fragment Float) = Fragment Float+ type ConvertInt (Fragment Float) = Fragment Int+ toFloat = id+ toInt = fUnaryFunc "int" "int"+instance Convert (Fragment Int) where+ type ConvertFloat (Fragment Int) = Fragment Float+ type ConvertInt (Fragment Int) = Fragment Int+ toFloat = fUnaryFunc "float" "float"+ toInt = id+ -- | The derivative in x using local differencing of the rasterized value. dFdx :: Fragment Float -> Fragment Float -- | The derivative in y using local differencing of the rasterized value. dFdy :: Fragment Float -> Fragment Float -- | The sum of the absolute derivative in x and y using local differencing of the rasterized value. fwidth :: Fragment Float -> Fragment Float -dFdx = fUnaryFunc "dFdx" -dFdy = fUnaryFunc "dFdy" -fwidth = fUnaryFunc "fwidth" +dFdx = fUnaryFunc "float" "dFdx" +dFdy = fUnaryFunc "float" "dFdy" +fwidth = fUnaryFunc "float" "fwidth" -------------------------------------- -- Vector specializations @@ -430,65 +412,65 @@ {-# RULES "norm/F3" norm = normF3 #-} {-# RULES "norm/F2" norm = normF2 #-} normF4 :: Vec4 (Fragment Float) -> Fragment Float -normF4 = fUnaryFunc "length" . fVec +normF4 = fUnaryFunc "float" "length" . fFromVec "vec4" normF3 :: Vec3 (Fragment Float) -> Fragment Float -normF3 = fUnaryFunc "length" . fVec +normF3 = fUnaryFunc "float" "length" . fFromVec "vec3" normF2 :: Vec2 (Fragment Float) -> Fragment Float -normF2 = fUnaryFunc "length" . fVec +normF2 = fUnaryFunc "float" "length" . fFromVec "vec2" {-# RULES "norm/V4" norm = normV4 #-} {-# RULES "norm/V3" norm = normV3 #-} {-# RULES "norm/V2" norm = normV2 #-} normV4 :: Vec4 (Vertex Float) -> Vertex Float -normV4 = vUnaryFunc "length" . vVec +normV4 = vUnaryFunc "float" "length" . vFromVec "vec4" normV3 :: Vec3 (Vertex Float) -> Vertex Float -normV3 = vUnaryFunc "length" . vVec +normV3 = vUnaryFunc "float" "length" . vFromVec "vec3" normV2 :: Vec2 (Vertex Float) -> Vertex Float -normV2 = vUnaryFunc "length" . vVec +normV2 = vUnaryFunc "float" "length" . vFromVec "vec3" {-# RULES "normalize/F4" normalize = normalizeF4 #-} {-# RULES "normalize/F3" normalize = normalizeF3 #-} {-# RULES "normalize/F2" normalize = normalizeF2 #-} normalizeF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float) -normalizeF4 = fromFVec 4 . fUnaryFunc "normalize" . fVec +normalizeF4 = fToVec "float" 4 . fUnaryFunc "vec4" "normalize" . fFromVec "vec4" normalizeF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -normalizeF3 = fromFVec 3 . fUnaryFunc "normalize" . fVec +normalizeF3 = fToVec "float" 3 . fUnaryFunc "vec3" "normalize" . fFromVec "vec3" normalizeF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -normalizeF2 = fromFVec 2 . fUnaryFunc "normalize" . fVec +normalizeF2 = fToVec "float" 2 . fUnaryFunc "vec2" "normalize" . fFromVec "vec2" {-# RULES "normalize/V4" normalize = normalizeV4 #-} {-# RULES "normalize/V3" normalize = normalizeV3 #-} {-# RULES "normalize/V2" normalize = normalizeV2 #-} normalizeV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float) -normalizeV4 = fromVVec 4 . vUnaryFunc "normalize" . vVec +normalizeV4 = vToVec "float" 4 . vUnaryFunc "vec4" "normalize" . vFromVec "vec4" normalizeV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -normalizeV3 = fromVVec 3 . vUnaryFunc "normalize" . vVec +normalizeV3 = vToVec "float" 3 . vUnaryFunc "vec3" "normalize" . vFromVec "vec3" normalizeV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -normalizeV2 = fromVVec 2 . vUnaryFunc "normalize" . vVec +normalizeV2 = vToVec "float" 2 . vUnaryFunc "vec2" "normalize" . vFromVec "vec2" {-# RULES "dot/F4" dot = dotF4 #-} {-# RULES "dot/F3" dot = dotF3 #-} {-# RULES "dot/F2" dot = dotF2 #-} dotF4 :: Vec4 (Fragment Float) -> Vec4 (Fragment Float) -> Fragment Float -dotF4 a b = fBinaryFunc "dot" (fVec a) (fVec b) +dotF4 a b = fBinaryFunc "float" "dot" (fFromVec "vec4" a) (fFromVec "vec4" b) dotF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Fragment Float -dotF3 a b = fBinaryFunc "dot" (fVec a) (fVec b) +dotF3 a b = fBinaryFunc "float" "dot" (fFromVec "vec3" a) (fFromVec "vec3" b) dotF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float) -> Fragment Float -dotF2 a b = fBinaryFunc "dot" (fVec a) (fVec b) +dotF2 a b = fBinaryFunc "float" "dot" (fFromVec "vec2" a) (fFromVec "vec2" b) {-# RULES "dot/V4" dot = dotV4 #-} {-# RULES "dot/V3" dot = dotV3 #-} {-# RULES "dot/V2" dot = dotV2 #-} dotV4 :: Vec4 (Vertex Float) -> Vec4 (Vertex Float) -> Vertex Float -dotV4 a b = vBinaryFunc "dot" (vVec a) (vVec b) +dotV4 a b = vBinaryFunc "float" "dot" (vFromVec "vec4" a) (vFromVec "vec4" b) dotV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vertex Float -dotV3 a b = vBinaryFunc "dot" (vVec a) (vVec b) +dotV3 a b = vBinaryFunc "float" "dot" (vFromVec "vec3" a) (vFromVec "vec3" b) dotV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float) -> Vertex Float -dotV2 a b = vBinaryFunc "dot" (vVec a) (vVec b) +dotV2 a b = vBinaryFunc "float" "dot" (vFromVec "vec2" a) (vFromVec "vec2" b) {-# RULES "cross/F3" cross = crossF3 #-} crossF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Vec3 (Fragment Float) -crossF3 a b = fromFVec 3 $ fBinaryFunc "cross" (fVec a) (fVec b) +crossF3 a b = fToVec "float" 3 $ fBinaryFunc "vec3" "cross" (fFromVec "vec3" a) (fFromVec "vec3" b) {-# RULES "cross/V3" cross = crossV3 #-} crossV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) ->Vec3 (Vertex Float) -crossV3 a b = fromVVec 3 $ vBinaryFunc "cross" (vVec a) (vVec b) +crossV3 a b = vToVec "float" 3 $ vBinaryFunc "vec3" "cross" (vFromVec "vec3" a) (vFromVec "vec3" b) -------------------------------------- -- Private @@ -496,34 +478,177 @@ noFun :: String -> a noFun = error . (++ ": No overloading for Vertex/Fragment") -vListFunc s xs = Vertex $ do xs' <- mapM fromVertex xs - return $ s ++ "(" ++ intercalate "," xs' ++ ")" -fListFunc s xs = Fragment $ do xs' <- mapM fromFragment xs - return $ s ++ "(" ++ intercalate "," xs' ++ ")" -vUnaryFunc s a = vListFunc s [a] -fUnaryFunc s a = fListFunc s [a] -vBinaryFunc s a b = vListFunc s [a,b] -fBinaryFunc s a b = fListFunc s [a,b] +setVaryings xs = setVaryings' 0 $ map (('t':) . show) xs + where + setVaryings' _ [] = "" + setVaryings' n xs = case splitAt 4 xs of (ys,rest) -> "f" ++ show n ++ " = " ++ tName' (length ys) ++ "(" ++ intercalate "," ys ++ ");\n" ++ setVaryings' (n+1) rest -vUnaryPreOp s a = Vertex $ do a' <- fromVertex a - return $ "(" ++ s ++ a' ++ ")" -fUnaryPreOp s a = Fragment $ do a' <- fromFragment a - return $ "(" ++ s ++ a' ++ ")" +inoutDecls t n i = inoutDecls' i 0 + where inoutDecls' i x | i >= 4 = t ++ " vec4 " ++ n ++ show x ++ ";\n" ++ inoutDecls' (i-4) (x+1) + | i == 0 = "" + | otherwise = t ++ " " ++ tName' i ++ " " ++ n ++ show x ++ ";\n" + +uniformDecls :: String -> UniformSet -> String +uniformDecls p (f,i,b,s) = makeU "float" "f" (length f) ++ + makeU "int" "i" (length i) ++ + makeU "bool" "b" (length b) ++ + concatMap (\(t,xs) -> makeU (sampName t) ('s':show (fromEnum t)) (length xs)) (Map.toList s) + where makeU t n 0 = "" + makeU t n i = "uniform " ++ t ++ " " ++ p ++ "u" ++ n ++ "[" ++ show i ++ "];\n" + +makeShader init assignments = "#version 120\n" ++ + init ++ + "void main(){\n" ++ + assignments ++ + "}\n" + +createShaderKey :: ShaderDAG -> ShaderKey +createShaderKey (a,xs) = (a,map (first toShaderKeyNode) xs) + where toShaderKeyNode (ShaderUniform _) = ShaderKeyUniform + toShaderKeyNode (ShaderInput a) = ShaderKeyInput a + toShaderKeyNode (ShaderConstant a) = ShaderKeyConstant a + toShaderKeyNode (ShaderOp a _ _) = ShaderKeyOp a + toShaderKeyNode (ShaderInputTree _) = error "Use splitShaders first" -vBinaryOp s a b = Vertex $ do a' <- fromVertex a - b' <- fromVertex b - return $ "(" ++ a' ++ s ++ b' ++ ")" -fBinaryOp s a b = Fragment $ do a' <- fromFragment a - b' <- fromFragment b - return $ "(" ++ a' ++ s ++ b' ++ ")" +splitShaders :: ShaderDAG -> ([ShaderTree], ShaderDAG) -- ^ (previous, current) +splitShaders (a,xs) = case mapAccumL splitNode [] xs of (trees, xs2) -> (reverse trees, (a,xs2)) + where splitNode ts (ShaderInputTree a, ys) = (a:ts, (ShaderInput (length ts), ys)) + splitNode ts a = (ts, a) -vVec v = let xs = Vec.toList v in vListFunc (tName $ length xs) xs -fVec v = let xs = Vec.toList v in fListFunc (tName $ length xs) xs +createDAG :: [ShaderTree] -> ShaderDAG +createDAG = second reverse . unsafePerformIO . startDAG + where startDAG xs = do ht <- HT.new (==) (fromIntegral . hashStableName) + runStateT (mapM (createDAG' ht) xs) [] + createDAG' :: HT.HashTable (StableName ShaderTree) Int -> ShaderTree -> StateT [(ShaderTree, [Int])] IO Int + createDAG' ht n = do n' <- liftIO $ evaluate n -- To make makeStableName "stable" + k <- liftIO $ makeStableName n' + m <- liftIO $ HT.lookup ht k + case m of + Just i -> return i + Nothing -> do xs' <- case n' of + ShaderOp _ _ xs -> mapM (createDAG' ht) xs + _ -> return [] + ys <- get + let y = length ys + liftIO $ HT.insert ht k y + put $ (n',xs'):ys + return y -fromVVec e v = Vec.fromList $ map (\n -> Vertex $ do v' <- fromVertex v - return (v' ++ subElem n e)) - [0..(e-1)] -fromFVec e v = Vec.fromList $ map (\n -> Fragment $ do v' <- fromFragment v - return (v' ++ subElem n e)) - [0..(e-1)] + +extractUniforms :: ShaderDAG -> UniformSet +extractUniforms (_,xs) = foldl' extractUniform ([],[],[],Map.empty) $ reverse $ map fst xs + where extractUniform (a,b,c,m) (ShaderUniform (UniformFloat x)) = (x:a,b,c,m) + extractUniform (a,b,c,m) (ShaderUniform (UniformInt x)) = (a,x:b,c,m) + extractUniform (a,b,c,m) (ShaderUniform (UniformBool x)) = (a,b,x:c,m) + extractUniform (a,b,c,m) (ShaderUniform (UniformSampler t s tex)) = (a,b,c,Map.insertWith' (++) t [(s,tex)] m) + extractUniform x _ = x + +extractInputs :: ShaderDAG -> [Int] +extractInputs (_,xs) = IntSet.toAscList $ foldl' extractIn (IntSet.empty) $ map fst xs + where extractIn s (ShaderInput a) = IntSet.insert a s + extractIn x _ = x + +getCodeAssignments :: (Int -> Int) -> String -> ShaderDAG -> String +getCodeAssignments inF inName (_,xs) = concat $ snd $ mapAccumL getCode ((0,0,0,Map.empty),Map.empty) $ zip [0..] xs + where getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformFloat _), _)) = (((f+1,i,b,s),inlns), assign "float" (const $ inName ++ "uf[" ++ show f ++ "]") (var n) []) + getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformInt _), _)) = (((f,i+1,b,s),inlns), assign "int" (const $ inName ++ "ui[" ++ show i ++ "]") (var n) []) + getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformBool _), _)) = (((f,i,b+1,s),inlns), assign "bool" (const $ inName ++ "ub[" ++ show b ++ "]") (var n) []) + getCode ((f,i,b,s),inlns) (n, (ShaderUniform (UniformSampler t _ _), _)) = + case first (fromMaybe 0) $ Map.insertLookupWithKey (const $ const (+1)) t 1 s of + (x, s') -> (((f,i,b,s'),Map.insert n (inName ++ "us" ++ show (fromEnum t) ++ "[" ++ show x ++ "]") inlns), "") + getCode x (n, (ShaderConstant (ConstFloat f), _)) = (x, assign "float" (const $ show f) (var n) []) + getCode x (n, (ShaderConstant (ConstInt i), _)) = (x, assign "int" (const $ show i) (var n) []) + getCode x (n, (ShaderConstant (ConstBool b), _)) = (x, assign "bool" (const $ if b then "true" else "false") (var n) []) + getCode x (n, (ShaderInput i, _)) = (x, assign "float" (const $ inName ++ inoutAccessor (inF i)) (var n) []) + getCode x@(_,inlns) (n, (ShaderOp _ f _, xs)) = (x, f (var n) (map (varMaybeInline inlns) xs)) + getCode _ (_, (ShaderInputTree _, _)) = error "Shader.getCodeAssignments: Use splitShaders first!" + var n = 't' : show n + varMaybeInline inlns n = case Map.lookup n inlns of Just str -> str + Nothing -> var n + +inoutAccessor i = case divMod i 4 of (d,m) -> show d ++ "." ++ (["x","y","z","w"]!!m) + +sampName Sampler3D = "sampler3D" +sampName Sampler2D = "sampler2D" +sampName Sampler1D = "sampler1D" +sampName SamplerCube = "samplerCube" + +tName v = tName' $ Vec.length v +tName' 1 = "float" +tName' x = "vec" ++ show x + +assign :: String -> ([String] -> String) -> String -> [String] -> String +assign t f x ys = t ++ " " ++ x ++ "=" ++ f ys ++ ";\n" +binFunc :: String -> [String] -> String +binFunc s = head . binFunc' + where + binFunc' (a:b:xs) = binFunc' $ (s ++ "(" ++ a ++ "," ++ b ++ ")"):binFunc' xs + binFunc' x = x + +vBinaryOp t s a b = Vertex $ ShaderOp s (assign t (intercalate s)) [fromVertex a, fromVertex b] +vUnaryPreOp t s a = Vertex $ ShaderOp s (assign t ((s ++) . head)) [fromVertex a] +vUnaryPostOp t s a = Vertex $ ShaderOp s (assign t ((++ s) . head)) [fromVertex a] +vUnaryFunc t s a = Vertex $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromVertex a] +vBinaryFunc t s a b = Vertex $ ShaderOp s (assign t (binFunc s)) [fromVertex a, fromVertex b] +vTernaryFunc t s a b c = Vertex $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromVertex a, fromVertex b, fromVertex c] +vFromVec t = Vertex . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromVertex . Vec.toList +vToVec t n a = Vec.fromList $ map (\s -> Vertex $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromVertex a]) [show n' | n' <-[0..n - 1]] + +fBinaryOp t s a b = Fragment $ ShaderOp s (assign t (intercalate s)) [fromFragment a, fromFragment b] +fUnaryPreOp t s a = Fragment $ ShaderOp s (assign t ((s ++) . head)) [fromFragment a] +fUnaryPostOp t s a = Fragment $ ShaderOp s (assign t ((++ s) . head)) [fromFragment a] +fUnaryFunc t s a = Fragment $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromFragment a] +fBinaryFunc t s a b = Fragment $ ShaderOp s (assign t (binFunc s)) [fromFragment a, fromFragment b] +fTernaryFunc t s a b c = Fragment $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromFragment a, fromFragment b, fromFragment c] +fFromVec t = Fragment . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromFragment . Vec.toList +fToVec t n a = Vec.fromList $ map (\s -> Fragment $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromFragment a]) [show n' | n' <-[0..n - 1]] + + +------------------------- +-- Lifted list +{- +data MaybeB bool a = Never | Sometimes bool a + +nothing :: MaybeB bool a +nothing = Never +just :: a -> MaybeB bool a +just a = Sometimes true a + +maybeB :: b -> (a -> b) -> MaybeB bool a -> b +maybeB b f Never = b +maybeB b f (Sometimes bool a) = ifB bool (f a) b + +isJustB :: MaybeB bool a -> bool +isJustB Never = false +isJustB (Sometimes bool a) = bool + +isNothingB :: MaybeB bool a -> bool +isNothingB Never = true +isNothingB (Sometimes bool a) = notB bool + +fromMaybeB :: a -> Maybe a -> a +fromMaybeB a = maybeB a id + +instance (EqB bool, IfB bool a) => IfB bool (MaybeB bool a) where + ifB c (Sometimes boola a) (Sometimes boolb b) = Sometimes ((c &&* boola) ||* (notB c &&* boolb)) (ifB c a b) + ifB c (Sometimes bool a) Never = Sometimes (c &&* bool) a + ifB c Never (Sometimes bool a) = Sometimes (notB c &&* bool) a + ifB c Never Never = Never + + +newtype ListB bool a = ListB [MaybeB bool a] + +(.:) :: a -> ListB bool a -> ListB bool a +a .: (ListB b) = ListB (just a:b) + +maxLength :: ListB bool a -> Int +maxLength (ListB a) = length a + +lengthB :: (Num i, IfB bool i) => ListB bool a -> i +lengthB (ListB a) + +(.!!) :: ListB bool a -> Int -> a +ListB xs .!! i = getElem xs i + where getElem a@(Never:xs) i = ifB (i ==* 0) (ifB ) + -}
src/Textures.hs view
@@ -158,9 +158,9 @@ [(i,p) | i<- [0..] | p<- ps'] GL.textureLevelRange GL.Texture3D $= (0, fromIntegral $ length ps' - 1) textureCPUFormatByteSize f (x:.y:.z:.()) = map (\(x,y,z)-> y*z*formatRowByteSize f x) [(x',y',z') | x' <- mipLevels x | y' <- mipLevels y | z' <- mipLevels z | _ <- mipLevels' (max x (max y z))] - sample s (Texture3D t) v = fSampleFunc "texture3D" Sampler3D s t v [] - sampleBias s (Texture3D t) v b = fSampleFunc "texture3D" Sampler3D s t v [b] - sampleLod s (Texture3D t) v m = vSampleFunc "texture3DLod" Sampler3D s t v [m] + sample s (Texture3D t) v = fSampleBinFunc "texture3D" Sampler3D s t v + sampleBias s (Texture3D t) v b = fSampleTernFunc "texture3D" Sampler3D s t v b + sampleLod s (Texture3D t) v m = vSampleTernFunc "texture3DLod" Sampler3D s t v m instance ColorFormat f => Texture (Texture2D f) where type TextureFormat (Texture2D f) = f type TextureSize (Texture2D f) = Vec2 Int @@ -180,9 +180,9 @@ [(i,p) | i<- [0..] | p<- ps'] GL.textureLevelRange GL.Texture2D $= (0, fromIntegral $ length ps' - 1) textureCPUFormatByteSize f (x:.y:.()) = map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)] - sample s (Texture2D t) v = fSampleFunc "texture2D" Sampler2D s t v [] - sampleBias s (Texture2D t) v b = fSampleFunc "texture2D" Sampler2D s t v [b] - sampleLod s (Texture2D t) v m = vSampleFunc "texture2DLod" Sampler2D s t v [m] + sample s (Texture2D t) v = fSampleBinFunc "texture2D" Sampler2D s t v + sampleBias s (Texture2D t) v b = fSampleTernFunc "texture2D" Sampler2D s t v b + sampleLod s (Texture2D t) v m = vSampleTernFunc "texture2DLod" Sampler2D s t v m instance ColorFormat f => Texture (Texture1D f) where type TextureFormat (Texture1D f) = f type TextureSize (Texture1D f) = Int @@ -202,9 +202,9 @@ [(i,p) | i<- [0..] | p<- ps'] GL.textureLevelRange GL.Texture1D $= (0, fromIntegral $ length ps' - 1) textureCPUFormatByteSize f x = map (\x-> formatRowByteSize f x) [x' | x' <- mipLevels' x] - sample s (Texture1D t) v = fSampleFunc "texture1D" Sampler1D s t (v:.()) [] - sampleBias s (Texture1D t) v b = fSampleFunc "texture1D" Sampler1D s t (v:.()) [b] - sampleLod s (Texture1D t) v m = vSampleFunc "texture1DLod" Sampler1D s t (v:.()) [m] + sample s (Texture1D t) v = fSampleBinFunc "texture1D" Sampler1D s t (v:.()) + sampleBias s (Texture1D t) v b = fSampleTernFunc "texture1D" Sampler1D s t (v:.()) b + sampleLod s (Texture1D t) v m = vSampleTernFunc "texture1DLod" Sampler1D s t (v:.()) m instance ColorFormat f => Texture (TextureCube f) where type TextureFormat (TextureCube f) = f type TextureSize (TextureCube f) = Vec2 Int @@ -228,9 +228,9 @@ [(t,ps'') | t <- cubeMapTargets | ps'' <- splitIn 6 ps'] GL.textureLevelRange GL.TextureCubeMap $= (0, fromIntegral $ length ps' - 1) textureCPUFormatByteSize f (x:.y:.()) = concat $ replicate 6 $ map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)] - sample s (TextureCube t) v = fSampleFunc "textureCube" Sampler3D s t v [] - sampleBias s (TextureCube t) v b = fSampleFunc "textureCube" Sampler3D s t v [b] - sampleLod s (TextureCube t) v m = vSampleFunc "textureCubeLod" Sampler3D s t v [m] + sample s (TextureCube t) v = fSampleBinFunc "textureCube" Sampler3D s t v + sampleBias s (TextureCube t) v b = fSampleTernFunc "textureCube" Sampler3D s t v b + sampleLod s (TextureCube t) v m = vSampleTernFunc "textureCubeLod" Sampler3D s t v m -- | The formats that is instances of this class may be used as depth textures, i.e. created with -- 'newDepthTexture', 'fromFrameBufferDepth' and 'fromFrameBufferCubeDepth'.