GPipe 1.3.2 → 1.4
raw patch · 8 files changed
+537/−679 lines, 8 filesdep ~Vecdep ~Vec-BooleanPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Vec, Vec-Boolean
API changes (from Hackage documentation)
- Graphics.GPipe.Stream.Fragment: data Fragment a
- Graphics.GPipe.Stream.Primitive: data Vertex a
+ Graphics.GPipe.Stream: data Shader c t
+ Graphics.GPipe.Stream.Fragment: data F
+ Graphics.GPipe.Stream.Fragment: type Fragment = Shader F
+ Graphics.GPipe.Stream.Primitive: data V
+ Graphics.GPipe.Stream.Primitive: type Vertex = Shader V
- Graphics.GPipe.Stream: class (Ord a, Floating a) => Real' a where rsqrt = (1 /) . sqrt exp2 = (2 **) log2 = logBase 2 clamp x a = min (max x a) saturate x = clamp x 0 1 mix x y a = x * (1 - a) + y * a step a x | x < a = 0 | otherwise = 1 smoothstep a b x = let t = saturate ((x - a) / (b - a)) in t * t * (3 - 2 * t) fract' x = x - floor' x mod' x y = x - y * floor' (x / y)
+ Graphics.GPipe.Stream: class Floating a => Real' a where rsqrt = (1 /) . sqrt exp2 = (2 **) log2 = logBase 2 saturate x = clamp x 0 1 mix x y a = x * (1 - a) + y * a smoothstep a b x = let t = saturate ((x - a) / (b - a)) in t * t * (3 - 2 * t) fract' x = x - floor' x mod' x y = x - y * floor' (x / y)
- Graphics.GPipe.Stream.Fragment: data Rasterizer a
+ Graphics.GPipe.Stream.Fragment: data Rasterizer a b
- Graphics.GPipe.Stream.Fragment: toFragment :: VertexOutput a => a -> Rasterizer (FragmentInput a)
+ Graphics.GPipe.Stream.Fragment: toFragment :: VertexOutput a => Rasterizer a (FragmentInput a)
- Graphics.GPipe.Stream.Primitive: data InputAssembler a
+ Graphics.GPipe.Stream.Primitive: data InputAssembler a b
- Graphics.GPipe.Stream.Primitive: toVertex :: VertexInput a => CPU a -> InputAssembler a
+ Graphics.GPipe.Stream.Primitive: toVertex :: VertexInput a => InputAssembler (CPU a) a
Files
- GPipe.cabal +3/−3
- src/Graphics/GPipe/Stream.hs +1/−0
- src/Graphics/GPipe/Stream/Fragment.hs +2/−1
- src/Graphics/GPipe/Stream/Primitive.hs +2/−1
- src/InputAssembler.hs +27/−33
- src/Rasterizer.hs +24/−25
- src/Shader.hs +466/−604
- src/Textures.hs +12/−12
GPipe.cabal view
@@ -1,5 +1,5 @@ name: GPipe-version: 1.3.2+version: 1.4 cabal-version: >= 1.8 build-type: Simple license: BSD3@@ -29,8 +29,8 @@ GLUT >=2.1.2.1, OpenGL >=2.2.3.0, Boolean == 0.0.1, - Vec == 0.9.9, - Vec-Boolean == 1.0.5, + Vec == 1.0.1, + Vec-Boolean == 1.0.6, base >= 4 && <5, transformers
src/Graphics/GPipe/Stream.hs view
@@ -19,6 +19,7 @@ module Graphics.GPipe.Stream ( -- * Common classes+ Shader(), GPU(..), Real'(..), Convert(..),
src/Graphics/GPipe/Stream/Fragment.hs view
@@ -36,7 +36,8 @@ module Graphics.GPipe.Stream.Fragment ( -- * Data types FragmentStream(),- Fragment(),+ F,+ Fragment, -- * Various fragment functions dFdx,
src/Graphics/GPipe/Stream/Primitive.hs view
@@ -35,7 +35,8 @@ module Graphics.GPipe.Stream.Primitive ( -- * Data types PrimitiveStream(),- Vertex(),+ V,+ Vertex, -- * Creating primitive streams VertexInput(..),
src/InputAssembler.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +{-# LANGUAGE Arrows, RankNTypes, TypeOperators, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : InputAssembler@@ -20,53 +20,47 @@ toIndexedGPUStream, ) where -import Control.Monad.Trans.State.Lazy import GPUStream import Shader import Data.Vec ((:.)(..), Vec2, Vec3, Vec4)---- | A monad in which CPU data gets converted to vertex data.--- Use 'toVertex' in the existing instances of 'VertexInput' to operate in this monad.-newtype InputAssembler a = InputAssembler {fromInputAssembler :: State [Float] a} deriving Monad+import Control.Arrow +import Control.Category (Category) +import Control.Monad.Trans.State.Lazy + +-- | An arrow by which CPU data gets converted to vertex data.+-- Use 'toVertex' in the existing instances of 'VertexInput' to operate in this arrow.+newtype InputAssembler a b = InputAssembler {fromInputAssembler :: Kleisli (State [Float]) a b} deriving (Category, Arrow) -- | The context of types that can be converted into vertices in 'PrimitiveStream's. -- Create your own instances in terms of the existing ones, e.g. convert your vertex data to 'Float's, -- turn them into 'Vertex' 'Float's with 'toVertex' and then convert them to your vertex data representation. class GPU a => VertexInput a where- -- | Turns an ordinary value into a vertex value in the 'InputAssembler' monad. The following rule must be satisfied:- -- - -- > toVertex undefined >> a = a- --- -- This ensures that its definition always use the same series of 'toVertex' calls to convert values of the same type.- -- This unfortunatly rules out ordinary lists (but instances for fixed length lists from the Vec package are however provided). - toVertex :: CPU a -> InputAssembler a+ -- | Turns an ordinary value into a vertex value in the 'InputAssembler' arrow.+ toVertex :: InputAssembler (CPU a) a instance VertexInput (Vertex Float) where- toVertex a = InputAssembler $ do x <- gets length- modify (a:)- return $ inputVertex x+ toVertex = InputAssembler $ Kleisli $ \ a -> do x <- gets length+ modify (a:)+ return $ inputVertex x instance VertexInput () where- toVertex ~() = return () + toVertex = proc () -> returnA -< () instance (VertexInput a,VertexInput b) => VertexInput (a,b) where- toVertex ~(a, b) = do a' <- toVertex a- b' <- toVertex b- return (a', b')+ toVertex = proc (a, b) -> do a' <- toVertex -< a+ b' <- toVertex -< b+ returnA -< (a', b') instance (VertexInput a,VertexInput b,VertexInput c) => VertexInput (a,b,c) where- toVertex ~(a, b, c) = do a' <- toVertex a- b' <- toVertex b- c' <- toVertex c- return (a', b', c')+ toVertex = proc (a, b, c) -> do (a', b') <- toVertex -< (a, b)+ c' <- toVertex -< c+ returnA -< (a', b', c') instance (VertexInput a,VertexInput b,VertexInput c,VertexInput d) => VertexInput (a,b,c,d) where- toVertex ~(a, b, c, d) = do a' <- toVertex a- b' <- toVertex b- c' <- toVertex c- d' <- toVertex d- return (a', b', c', d')+ toVertex = proc (a, b, c, d) -> do (a', b', c') <- toVertex -< (a, b, c)+ d' <- toVertex -< d+ returnA -< (a', b', c', d') instance (VertexInput a, VertexInput b) => VertexInput (a:.b) where- toVertex ~(a:.b) = do a' <- toVertex a- b' <- toVertex b- return $ a':.b'+ toVertex = proc (a:.b) -> do a' <- toVertex -< a+ b' <- toVertex -< b+ returnA -< a':.b' -- | Converts a list of values to a 'PrimitiveStream', using a specified 'Primitive' type. -- This function is lazy in the aspect that if parts of the values aren't used on the GPU, they won't@@ -99,6 +93,6 @@ getVertexInput :: forall a. VertexInput a => [CPU a] -> (a, [[Float]]) getVertexInput xs = let readInput :: CPU a -> (a, [Float])- readInput = flip runState [] . fromInputAssembler . toVertex+ readInput = flip runState [] . runKleisli (fromInputAssembler (toVertex :: InputAssembler (CPU a) a)) e = "The method toVertex of an instance of Graphics.GPipe.Stream.Primitive.VertexInput is strict in it's input. Remember that 'toVertex undefined >> a' must be equal to 'a'. Contact the GPipe author for more information." in (fst $ readInput (error e :: CPU a), map (reverse . snd . readInput) xs)
src/Rasterizer.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Arrows, TypeOperators, TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : Rasterizer@@ -25,10 +25,12 @@ import Data.Vec ((:.)(..), Vec2, Vec3, Vec4) import GPUStream import Data.Functor.Identity+import Control.Arrow (Arrow, returnA) +import Control.Category (Category) --- | 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 :: Identity a} deriving (Functor, Monad)+-- | An arrow by which vertex data gets converted to fragment data.+-- Use 'toFragment' in the existing instances of 'VertexOutput' to operate in this arrow.+newtype Rasterizer a b = Rasterizer {fromRasterizer :: a -> b} deriving (Category, Arrow) -- | 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,@@ -36,40 +38,37 @@ class GPU a => VertexOutput a where -- | The corresponding type in the 'FragmentStream' after rasterization. type FragmentInput a- -- | Turns a vertex value into a fragment value in the 'Rasterizer' monad. - toFragment :: a -> Rasterizer (FragmentInput a) + -- | Turns a vertex value into a fragment value in the 'Rasterizer' arrow. + toFragment :: Rasterizer a (FragmentInput a) instance VertexOutput (Vertex Float) where type FragmentInput (Vertex Float) = Fragment Float- toFragment = Rasterizer . return . rasterizeVertex+ toFragment = Rasterizer rasterizeVertex instance VertexOutput () where type FragmentInput () = ()- toFragment () = return () + toFragment = Rasterizer id instance (VertexOutput a,VertexOutput b) => VertexOutput (a,b) where type FragmentInput (a,b) = (FragmentInput a, FragmentInput b)- toFragment (a, b) = do a' <- toFragment a- b' <- toFragment b- return (a', b')+ toFragment = proc (a, b) -> do a' <- toFragment -< a+ b' <- toFragment -< b+ returnA -< (a', b') instance (VertexOutput a,VertexOutput b,VertexOutput c) => VertexOutput (a,b,c) where type FragmentInput (a,b,c) = (FragmentInput a, FragmentInput b, FragmentInput c)- toFragment (a, b, c) = do a' <- toFragment a- b' <- toFragment b- c' <- toFragment c- return (a', b', c')+ toFragment = proc (a, b, c) -> do (a', b') <- toFragment -< (a, b) + c' <- toFragment -< c + returnA -< (a', b', c') instance (VertexOutput a,VertexOutput b,VertexOutput c,VertexOutput d) => VertexOutput (a,b,c,d) where type FragmentInput (a,b,c,d) = (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d)- toFragment (a, b, c, d) = do a' <- toFragment a- b' <- toFragment b- c' <- toFragment c- d' <- toFragment d- return (a', b', c', d')+ toFragment = proc (a, b, c, d) -> do (a', b', c') <- toFragment -< (a, b, c) + d' <- toFragment -< d + returnA -< (a', b', c', d') instance (VertexOutput a, VertexOutput b) => VertexOutput (a:.b) where type FragmentInput (a:.b) = FragmentInput a :. FragmentInput b- toFragment (a:.b) = do a' <- toFragment a- b' <- toFragment b- return $ a':.b'+ toFragment = proc (a:.b) -> do a' <- toFragment -< a+ b' <- toFragment -< b+ returnA -< a':.b' -- | Rasterize front side of all types of primitives with vertices containing canonical view coordinates into fragments. rasterizeFront :: VertexOutput a@@ -105,5 +104,5 @@ -- Private -- -getFragmentInput :: VertexOutput a => a -> FragmentInput a-getFragmentInput = runIdentity . fromRasterizer . toFragment+getFragmentInput :: forall a. VertexOutput a => a -> FragmentInput a +getFragmentInput = fromRasterizer (toFragment :: Rasterizer a (FragmentInput a))
src/Shader.hs view
@@ -1,604 +1,466 @@-{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} ------------------------------------------------------------------------------------ Module : Shader--- Copyright : Tobias Bexelius--- License : BSD3------ Maintainer : Tobias Bexelius--- Stability : Experimental--- Portability : Portable------ |-----------------------------------------------------------------------------------module Shader (- GPU(..),- rasterizeVertex,- inputVertex,- fragmentFrontFacing,- Vertex(),- Fragment(),- ShaderInfo,- getShaders,- Real'(..),- Convert(..),- dFdx,- dFdy,- fwidth,- vSampleBinFunc,- fSampleBinFunc,- vSampleTernFunc,- fSampleTernFunc,- module Data.Boolean-) where--import Control.Monad.Trans.State.Lazy (put, get, StateT, runStateT) -import System.IO.Unsafe-import Data.Vec ((:.)(..), Vec2, Vec3, Vec4, norm, normalize, dot, cross)-import qualified Data.Vec as Vec-import Data.Unique-import Data.List-import Data.Maybe-import Data.Boolean-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.-class GPU a where- -- | The type on the CPU.- type CPU a- -- | Converts a value from the CPU to the GPU.- toGPU :: CPU a -> a--data ShaderTree = ShaderUniform !Uniform - | ShaderConstant !Const- | ShaderInput !Int- | ShaderInputTree ShaderTree- | ShaderOp !Op (String -> [String] -> String) [ShaderTree]-type ShaderDAG = ([Int],[(ShaderTree, [Int])])---- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'.-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 :: ShaderTree }--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) (length inputs) "v" vdag- vCodeFinish = setVaryings varyings' ++- "gl_Position = t" ++ show vpos' ++ ";\n"- fcodeAssigns = getCodeAssignments id (length varyings') "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 . ShaderUniform . UniformFloat-instance GPU (Vertex Int) where- type CPU (Vertex Int) = Int- toGPU = Vertex . ShaderUniform . UniformInt-instance GPU (Vertex Bool) where- type CPU (Vertex Bool) = Bool- toGPU = Vertex . ShaderUniform . UniformBool--instance GPU (Fragment Float) where- type CPU (Fragment Float) = Float- toGPU = Fragment . ShaderUniform . UniformFloat-instance GPU (Fragment Int) where- type CPU (Fragment Int) = Int- toGPU = Fragment . ShaderUniform . UniformInt-instance GPU (Fragment Bool) where- type CPU (Fragment Bool) = Bool- toGPU = Fragment . ShaderUniform . UniformBool--instance GPU () where- type CPU () = ()- toGPU = id-instance (GPU a, GPU b) => GPU (a,b) where- type CPU (a,b) = (CPU a, CPU b)- toGPU (a,b)= (toGPU a, toGPU b)-instance (GPU a, GPU b, GPU c) => GPU (a,b,c) where- type CPU (a,b,c) = (CPU a, CPU b, CPU c)- toGPU (a,b,c)= (toGPU a, toGPU b, toGPU c)-instance (GPU a, GPU b, GPU c, GPU d) => GPU (a,b,c,d) where- type CPU (a,b,c,d) = (CPU a, CPU b, CPU c, CPU d)- toGPU (a,b,c,d)= (toGPU a, toGPU b, toGPU c, toGPU d)--instance (GPU a, GPU b) => GPU (a:.b) where- type CPU (a:.b) = CPU a :. CPU b- toGPU (a:.b) = toGPU a :. toGPU b--instance Eq (Vertex a) where- (==) = noFun "(==)"- (/=) = noFun "(/=)" -instance Eq (Fragment a) where- (==) = noFun "(==)"- (/=) = noFun "(/=)"-instance Show (Vertex a) where- show = noFun "show"-instance Show (Fragment a) where- show = noFun "show"--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 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''.-class (Ord a, Floating a) => Real' a where- rsqrt :: a -> a- exp2 :: a -> a- log2 :: a -> a- floor' :: a -> a- ceiling' :: a -> a- fract' :: a -> a- mod' :: a -> a -> a- clamp :: a -> a -> a -> a- saturate :: a -> a- mix :: a -> a -> a-> a- step :: a -> a -> a- smoothstep :: a -> a -> a -> a-- rsqrt = (1/) . sqrt- exp2 = (2**)- log2 = logBase 2- clamp x a = min (max x a)- saturate x = clamp x 0 1- mix x y a = x*(1-a)+y*a- step a x | x < a = 0- | otherwise = 1- smoothstep a b x = let t = saturate ((x-a) / (b-a))- in t*t*(3-2*t)- fract' x = x - floor' x- mod' x y = x - y* floor' (x/y)- -instance Real' Float where- floor' = fromIntegral . floor- ceiling' = fromIntegral . ceiling--instance Real' Double where- floor' = fromIntegral . floor- ceiling' = fromIntegral . ceiling- -instance Real' (Vertex Float) where- 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 "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 $ ShaderConstant $ ConstBool True- false = Vertex $ ShaderConstant $ ConstBool False- notB = vUnaryPreOp "bool" "!"- (&&*) = vBinaryOp "bool" "&&"- (||*) = vBinaryOp "bool" "||"-instance Boolean (Fragment Bool) where- 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 "bool" "=="- (/=*) = vBinaryOp "bool" "!="-instance Eq a => EqB (Fragment Bool) (Fragment a) where- (==*) = fBinaryOp "bool" "=="- (/=*) = fBinaryOp "bool" "!="-instance Ord a => OrdB (Vertex Bool) (Vertex a) where- (<*) = vBinaryOp "bool" "<"- (>=*) = vBinaryOp "bool" ">="- (>*) = vBinaryOp "bool" ">"- (<=*) = vBinaryOp "bool" "<="-instance Ord a => OrdB (Fragment Bool) (Fragment a) where- (<*) = fBinaryOp "bool" "<"- (>=*) = fBinaryOp "bool" ">="- (>*) = fBinaryOp "bool" ">"- (<=*) = fBinaryOp "bool" "<="--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 "float" "dFdx"-dFdy = fUnaryFunc "float" "dFdy"-fwidth = fUnaryFunc "float" "fwidth"------------------------------------------- Vector specializations--{-# RULES "norm/F4" norm = normF4 #-}-{-# RULES "norm/F3" norm = normF3 #-}-{-# RULES "norm/F2" norm = normF2 #-}-normF4 :: Vec4 (Fragment Float) -> Fragment Float-normF4 = fUnaryFunc "float" "length" . fFromVec "vec4"-normF3 :: Vec3 (Fragment Float) -> Fragment Float-normF3 = fUnaryFunc "float" "length" . fFromVec "vec3"-normF2 :: Vec2 (Fragment Float) -> Fragment Float-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 "float" "length" . vFromVec "vec4"-normV3 :: Vec3 (Vertex Float) -> Vertex Float-normV3 = vUnaryFunc "float" "length" . vFromVec "vec3"-normV2 :: Vec2 (Vertex Float) -> Vertex Float-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 = fToVec "float" 4 . fUnaryFunc "vec4" "normalize" . fFromVec "vec4"-normalizeF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float)-normalizeF3 = fToVec "float" 3 . fUnaryFunc "vec3" "normalize" . fFromVec "vec3"-normalizeF2 :: Vec2 (Fragment Float) -> Vec2 (Fragment Float)-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 = vToVec "float" 4 . vUnaryFunc "vec4" "normalize" . vFromVec "vec4"-normalizeV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float)-normalizeV3 = vToVec "float" 3 . vUnaryFunc "vec3" "normalize" . vFromVec "vec3"-normalizeV2 :: Vec2 (Vertex Float) -> Vec2 (Vertex Float)-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 "float" "dot" (fFromVec "vec4" a) (fFromVec "vec4" b)-dotF3 :: Vec3 (Fragment Float) -> Vec3 (Fragment Float) -> Fragment Float-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 "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 "float" "dot" (vFromVec "vec4" a) (vFromVec "vec4" b)-dotV3 :: Vec3 (Vertex Float) -> Vec3 (Vertex Float) -> Vertex Float-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 "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 = 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 = vToVec "float" 3 $ vBinaryFunc "vec3" "cross" (vFromVec "vec3" a) (vFromVec "vec3" b)------------------------------------------- Private----noFun :: String -> a-noFun = error . (++ ": No overloading for Vertex/Fragment")--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--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"--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)--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----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) -> Int -> String -> ShaderDAG -> String-getCodeAssignments inF numIns 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) numIns) (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 = fromMaybe (var n) (Map.lookup n inlns)--inoutAccessor i tot = case divMod i 4 of (d,m) -> if i+1 == tot && m == 0 then show d else 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]]-+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, EmptyDataDecls, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : Shader +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- +----------------------------------------------------------------------------- + +module Shader ( + GPU(..), + rasterizeVertex, + inputVertex, + fragmentFrontFacing, + Shader(), + V, + F, + Vertex, + Fragment, + ShaderInfo, + getShaders, + Real'(..), + Convert(..), + dFdx, + dFdy, + fwidth, + sampleBinFunc, + sampleTernFunc, + module Data.Boolean +) where + +import Control.Monad.Trans.State.Lazy (put, get, StateT, runStateT) +import System.IO.Unsafe +import Data.Vec ((:.)(..), Vec2, Vec3, Vec4, norm, normalize, dot, cross) +import qualified Data.Vec as Vec +import Data.Unique +import Data.List +import Data.Maybe +import Data.Boolean +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. +class GPU a where + -- | The type on the CPU. + type CPU a + -- | Converts a value from the CPU to the GPU. + toGPU :: CPU a -> a + +data ShaderTree = ShaderUniform !Uniform + | ShaderConstant !Const + | ShaderInput !Int + | ShaderInputTree ShaderTree + | ShaderOp !Op (String -> [String] -> String) [ShaderTree] +type ShaderDAG = ([Int],[(ShaderTree, [Int])]) + +newtype Shader c t = Shader { fromS :: ShaderTree } + +data V +data F + +-- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'. +type Vertex = Shader V +-- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. +type Fragment = Shader F + +rasterizeVertex :: Vertex Float -> Fragment Float +rasterizeVertex = Shader . ShaderInputTree . fromS +inputVertex :: Int -> Vertex Float +inputVertex = Shader . ShaderInput +fragmentFrontFacing :: Fragment Bool +fragmentFrontFacing = Shader $ 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 (Shader ndisc) color mdepth = ((createShaderKey vdag,vstr,vuns),(createShaderKey fdag,fstr,funs), inputs) + where fcolor = fromS $ fromVec "vec4" color + (varyings, fdag@(fcolor':ndisc':mdepth',_)) = splitShaders (createDAG (fcolor:ndisc: map fromS (maybeToList mdepth))) + vpos = fromS $ fromVec "vec4" pos + vdag@(vpos':varyings',_) = createDAG (vpos:varyings) + inputs = extractInputs vdag + vcodeAssigns = getCodeAssignments (fromJust . flip elemIndex inputs) (length inputs) "v" vdag + vCodeFinish = setVaryings varyings' ++ + "gl_Position = t" ++ show vpos' ++ ";\n" + fcodeAssigns = getCodeAssignments id (length varyings') "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) + +sampleBinFunc f t s tex c = toColor $ toVec float 4 (binaryFunc "vec4" f (Shader $ ShaderUniform $ UniformSampler t s tex) (fromVec (tName c) c)) +sampleTernFunc f t s tex c x = toColor $ toVec float 4 (ternaryFunc "vec4" f (Shader $ ShaderUniform $ UniformSampler t s tex) (fromVec (tName c) c) x) + +instance GPU (Shader c Float) where + type CPU (Shader c Float) = Float + toGPU = Shader . ShaderUniform . UniformFloat +instance GPU (Shader c Int) where + type CPU (Shader c Int) = Int + toGPU = Shader . ShaderUniform . UniformInt +instance GPU (Shader c Bool) where + type CPU (Shader c Bool) = Bool + toGPU = Shader . ShaderUniform . UniformBool + +instance GPU () where + type CPU () = () + toGPU = id +instance (GPU a, GPU b) => GPU (a,b) where + type CPU (a,b) = (CPU a, CPU b) + toGPU (a,b)= (toGPU a, toGPU b) +instance (GPU a, GPU b, GPU c) => GPU (a,b,c) where + type CPU (a,b,c) = (CPU a, CPU b, CPU c) + toGPU (a,b,c)= (toGPU a, toGPU b, toGPU c) +instance (GPU a, GPU b, GPU c, GPU d) => GPU (a,b,c,d) where + type CPU (a,b,c,d) = (CPU a, CPU b, CPU c, CPU d) + toGPU (a,b,c,d)= (toGPU a, toGPU b, toGPU c, toGPU d) + +instance (GPU a, GPU b) => GPU (a:.b) where + type CPU (a:.b) = CPU a :. CPU b + toGPU (a:.b) = toGPU a :. toGPU b + + +instance Num (Shader c Float) where + negate = unaryPreOp float "-" + (+) = binaryOp float "+" + (*) = binaryOp float "*" + fromInteger = Shader . ShaderConstant . ConstFloat . fromInteger + abs = unaryFunc float "abs" + signum = unaryFunc float "sign" + + +instance Num (Shader c Int) where + negate = unaryPreOp int "-" + (+) = binaryOp int "+" + (*) = binaryOp int "*" + fromInteger = Shader . ShaderConstant . ConstInt . fromInteger + abs x = ifB (x <* 0) (-x) x + signum x = ifB (x <* 0) (-1) 1 + +instance Fractional (Shader c Float) where + (/) = binaryOp float "/" + fromRational = Shader . ShaderConstant . ConstFloat . fromRational +instance Floating (Shader c Float) where + pi = Shader $ ShaderConstant $ ConstFloat pi + sqrt = unaryFunc float "sqrt" + exp = unaryFunc float "exp" + log = unaryFunc float "log" + (**) = binaryFunc float "pow" + sin = unaryFunc float "sin" + cos = unaryFunc float "cos" + tan = unaryFunc float "tan" + asin = unaryFunc float "asin" + acos = unaryFunc float "acos" + atan = unaryFunc float "atan" + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x * x + 1)) + atanh x = log ((1 + x) / (1 - x)) / 2 + acosh x = log (x + sqrt (x * x - 1)) + +-- | 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''. +class Floating a => Real' a where + rsqrt :: a -> a + exp2 :: a -> a + log2 :: a -> a + floor' :: a -> a + ceiling' :: a -> a + fract' :: a -> a + mod' :: a -> a -> a + clamp :: a -> a -> a -> a + saturate :: a -> a + mix :: a -> a -> a-> a + step :: a -> a -> a + smoothstep :: a -> a -> a -> a + + rsqrt = (1/) . sqrt + exp2 = (2**) + log2 = logBase 2 + saturate x = clamp x 0 1 + mix x y a = x*(1-a)+y*a + smoothstep a b x = let t = saturate ((x-a) / (b-a)) + in t*t*(3-2*t) + fract' x = x - floor' x + mod' x y = x - y* floor' (x/y) + +instance Real' Float where + clamp x a = min (max x a) + step a x | x < a = 0 + | otherwise = 1 + floor' = fromIntegral . floor + ceiling' = fromIntegral . ceiling + +instance Real' Double where + clamp x a = min (max x a) + step a x | x < a = 0 + | otherwise = 1 + floor' = fromIntegral . floor + ceiling' = fromIntegral . ceiling + +instance Real' (Shader c Float) where + rsqrt = unaryFunc float "inversesqrt" + exp2 = unaryFunc float "exp2" + log2 = unaryFunc float "log2" + floor' = unaryFunc float "floor" + ceiling' = unaryFunc float "ceil" + fract' = unaryFunc float "fract" + mod' = binaryFunc float "mod" + clamp = ternaryFunc float "clamp" + mix = ternaryFunc float "mix" + step = binaryFunc float "step" + smoothstep = ternaryFunc float "smoothstep" + +instance Boolean (Shader c Bool) where + true = Shader $ ShaderConstant $ ConstBool True + false = Shader $ ShaderConstant $ ConstBool False + notB = unaryPreOp bool "!" + (&&*) = binaryOp bool "&&" + (||*) = binaryOp bool "||" +instance Eq a => EqB (Shader c Bool) (Shader c a) where + (==*) = binaryOp bool "==" + (/=*) = binaryOp bool "!=" +instance Ord a => OrdB (Shader c Bool) (Shader c a) where + (<*) = binaryOp bool "<" + (>=*) = binaryOp bool ">=" + (>*) = binaryOp bool ">" + (<=*) = binaryOp bool "<=" + +instance IfB (Shader c Bool) (Shader c Int) where + ifB c a b = Shader $ ShaderOp "if" (assign int (\[a,b,c]->a++"?"++b++":"++c)) [fromS c,fromS a,fromS b] +instance IfB (Shader c Bool) (Shader c Float) where + ifB c a b = Shader $ ShaderOp "if" (assign float (\[a,b,c]->a++"?"++b++":"++c)) [fromS c,fromS a,fromS b] +instance IfB (Shader c Bool) (Shader c Bool) where + ifB c a b = Shader $ ShaderOp "if" (assign bool (\[a,b,c]->a++"?"++b++":"++c)) [fromS c,fromS a,fromS 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 (Shader c Float) where + type ConvertFloat (Shader c Float) = Shader c Float + type ConvertInt (Shader c Float) = Shader c Int + toFloat = id + toInt = unaryFunc int int +instance Convert (Shader c Int) where + type ConvertFloat (Shader c Int) = Shader c Float + type ConvertInt (Shader c Int) = Shader c Int + toFloat = unaryFunc 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 = unaryFunc float "dFdx" +dFdy = unaryFunc float "dFdy" +fwidth = unaryFunc float "fwidth" + +-------------------------------------- +-- Vector specializations + +{-# RULES "norm/F4" norm = normF4 #-} +{-# RULES "norm/F3" norm = normF3 #-} +{-# RULES "norm/F2" norm = normF2 #-} +normF4 :: Vec4 (Shader c Float) -> Shader c Float +normF4 = unaryFunc float "length" . fromVec "vec4" +normF3 :: Vec3 (Shader c Float) -> Shader c Float +normF3 = unaryFunc float "length" . fromVec "vec3" +normF2 :: Vec2 (Shader c Float) -> Shader c Float +normF2 = unaryFunc float "length" . fromVec "vec2" + +{-# RULES "normalize/F4" normalize = normalizeF4 #-} +{-# RULES "normalize/F3" normalize = normalizeF3 #-} +{-# RULES "normalize/F2" normalize = normalizeF2 #-} +normalizeF4 :: Vec4 (Shader c Float) -> Vec4 (Shader c Float) +normalizeF4 = toVec float 4 . unaryFunc "vec4" "normalize" . fromVec "vec4" +normalizeF3 :: Vec3 (Shader c Float) -> Vec3 (Shader c Float) +normalizeF3 = toVec float 3 . unaryFunc "vec3" "normalize" . fromVec "vec3" +normalizeF2 :: Vec2 (Shader c Float) -> Vec2 (Shader c Float) +normalizeF2 = toVec float 2 . unaryFunc "vec2" "normalize" . fromVec "vec2" + +{-# RULES "dot/F4" dot = dotF4 #-} +{-# RULES "dot/F3" dot = dotF3 #-} +{-# RULES "dot/F2" dot = dotF2 #-} +dotF4 :: Vec4 (Shader c Float) -> Vec4 (Shader c Float) -> Shader c Float +dotF4 a b = binaryFunc float "dot" (fromVec "vec4" a) (fromVec "vec4" b) +dotF3 :: Vec3 (Shader c Float) -> Vec3 (Shader c Float) -> Shader c Float +dotF3 a b = binaryFunc float "dot" (fromVec "vec3" a) (fromVec "vec3" b) +dotF2 :: Vec2 (Shader c Float) -> Vec2 (Shader c Float) -> Shader c Float +dotF2 a b = binaryFunc float "dot" (fromVec "vec2" a) (fromVec "vec2" b) + +{-# RULES "cross/F3" cross = crossF3 #-} +crossF3 :: Vec3 (Shader c Float) -> Vec3 (Shader c Float) -> Vec3 (Shader c Float) +crossF3 a b = toVec float 3 $ binaryFunc "vec3" "cross" (fromVec "vec3" a) (fromVec "vec3" b) + + +{-# RULES "minB/F" minB = minS #-} +{-# RULES "maxB/F" maxB = maxS #-} +minS :: Shader a Float -> Shader a Float -> Shader a Float +minS = binaryFunc float "min" +maxS :: Shader a Float -> Shader a Float -> Shader a Float +maxS = binaryFunc float "max" + +-------------------------------------- +-- Private +-- + +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 + +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" + +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) + +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 + + + +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) -> Int -> String -> ShaderDAG -> String +getCodeAssignments inF numIns 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) numIns) (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 = fromMaybe (var n) (Map.lookup n inlns) + +inoutAccessor i tot = case divMod i 4 of (d,m) -> if i+1 == tot && m == 0 then show d else 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 + +binaryOp t s a b = Shader $ ShaderOp s (assign t (intercalate s)) [fromS a, fromS b] +unaryPreOp t s a = Shader $ ShaderOp s (assign t ((s ++) . head)) [fromS a] +unaryPostOp t s a = Shader $ ShaderOp s (assign t ((++ s) . head)) [fromS a] +unaryFunc t s a = Shader $ ShaderOp s (assign t (((s ++ "(") ++) . (++ ")") . head)) [fromS a] +binaryFunc t s a b = Shader $ ShaderOp s (assign t (binFunc s)) [fromS a, fromS b] +ternaryFunc t s a b c = Shader $ ShaderOp s (assign t (\[a,b,c]->s++"("++a++","++b++","++c++")")) [fromS a, fromS b, fromS c] +fromVec t = Shader . ShaderOp "" (assign t (((t ++ "(") ++) . (++ ")") . intercalate ",")) . map fromS . Vec.toList +toVec t n a = Vec.fromList $ map (\s -> Shader $ ShaderOp s (assign t (\[x]->x++"["++s++"]")) [fromS a]) [show n' | n' <-[0..n - 1]] + +float = "float" +int = "int" +bool = "bool"
src/Textures.hs view
@@ -161,9 +161,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 = 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+ sample s (Texture3D t) v = sampleBinFunc "texture3D" Sampler3D s t v+ sampleBias s (Texture3D t) v b = sampleTernFunc "texture3D" Sampler3D s t v b+ sampleLod s (Texture3D t) v m = sampleTernFunc "texture3DLod" Sampler3D s t v m instance ColorFormat f => Texture (Texture2D f) where type TextureFormat (Texture2D f) = f type TextureSize (Texture2D f) = Vec2 Int@@ -183,9 +183,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 = 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+ sample s (Texture2D t) v = sampleBinFunc "texture2D" Sampler2D s t v+ sampleBias s (Texture2D t) v b = sampleTernFunc "texture2D" Sampler2D s t v b+ sampleLod s (Texture2D t) v m = sampleTernFunc "texture2DLod" Sampler2D s t v m instance ColorFormat f => Texture (Texture1D f) where type TextureFormat (Texture1D f) = f type TextureSize (Texture1D f) = Int@@ -205,9 +205,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 = 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+ sample s (Texture1D t) v = sampleBinFunc "texture1D" Sampler1D s t (v:.())+ sampleBias s (Texture1D t) v b = sampleTernFunc "texture1D" Sampler1D s t (v:.()) b+ sampleLod s (Texture1D t) v m = sampleTernFunc "texture1DLod" Sampler1D s t (v:.()) m instance ColorFormat f => Texture (TextureCube f) where type TextureFormat (TextureCube f) = f type TextureSize (TextureCube f) = Vec2 Int@@ -231,9 +231,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 = 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+ sample s (TextureCube t) v = sampleBinFunc "textureCube" Sampler3D s t v+ sampleBias s (TextureCube t) v b = sampleTernFunc "textureCube" Sampler3D s t v b+ sampleLod s (TextureCube t) v m = sampleTernFunc "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'.