diff --git a/GPipe.cabal b/GPipe.cabal --- a/GPipe.cabal +++ b/GPipe.cabal @@ -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 diff --git a/src/Graphics/GPipe/Stream.hs b/src/Graphics/GPipe/Stream.hs --- a/src/Graphics/GPipe/Stream.hs +++ b/src/Graphics/GPipe/Stream.hs @@ -19,6 +19,7 @@ module Graphics.GPipe.Stream ( -- * Common classes + Shader(), GPU(..), Real'(..), Convert(..), diff --git a/src/Graphics/GPipe/Stream/Fragment.hs b/src/Graphics/GPipe/Stream/Fragment.hs --- a/src/Graphics/GPipe/Stream/Fragment.hs +++ b/src/Graphics/GPipe/Stream/Fragment.hs @@ -36,7 +36,8 @@ module Graphics.GPipe.Stream.Fragment ( -- * Data types FragmentStream(), - Fragment(), + F, + Fragment, -- * Various fragment functions dFdx, diff --git a/src/Graphics/GPipe/Stream/Primitive.hs b/src/Graphics/GPipe/Stream/Primitive.hs --- a/src/Graphics/GPipe/Stream/Primitive.hs +++ b/src/Graphics/GPipe/Stream/Primitive.hs @@ -35,7 +35,8 @@ module Graphics.GPipe.Stream.Primitive ( -- * Data types PrimitiveStream(), - Vertex(), + V, + Vertex, -- * Creating primitive streams VertexInput(..), diff --git a/src/InputAssembler.hs b/src/InputAssembler.hs --- a/src/InputAssembler.hs +++ b/src/InputAssembler.hs @@ -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) diff --git a/src/Rasterizer.hs b/src/Rasterizer.hs --- a/src/Rasterizer.hs +++ b/src/Rasterizer.hs @@ -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)) diff --git a/src/Shader.hs b/src/Shader.hs --- a/src/Shader.hs +++ b/src/Shader.hs @@ -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" diff --git a/src/Textures.hs b/src/Textures.hs --- a/src/Textures.hs +++ b/src/Textures.hs @@ -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'.