diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009-2012, Csaba Hruska +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lambdacube-edsl.cabal b/lambdacube-edsl.cabal new file mode 100644 --- /dev/null +++ b/lambdacube-edsl.cabal @@ -0,0 +1,71 @@ +Name: lambdacube-edsl +Version: 0.2.0 +Cabal-Version: >= 1.10 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Author: Csaba Hruska, Gergely Patai +Maintainer: csaba (dot) hruska (at) gmail (dot) com +Stability: experimental +Homepage: http://lambdacube3d.wordpress.com/ +Bug-Reports: https://github.com/csabahruska/lc-dsl/issues +Category: Graphics +Tested-With: GHC == 7.6.3 +Synopsis: LambdaCube 3D EDSL definition + +Library + Build-Depends: + base >=4.6 && <5, + containers >=0.5 && <0.6, + mtl >=2.2 && <2.3, + bytestring >=0.10 && <0.11, + bytestring-trie >=0.2 && <0.3, + vector >=0.10 && <0.11, + ghc-prim, + --data-reify >= 0.6 && <0.7, + lambdacube-core == 0.2.0 + + default-language: Haskell2010 + hs-source-dirs: src/lib + Exposed-modules: + LambdaCube.Convert.PrimFun + LambdaCube.Convert.ToDeBruijn + --LambdaCube.Convert.ToDeBruijnRec + LambdaCube.Language + LambdaCube.Language.HOAS + LambdaCube.Language.PrimFun + LambdaCube.Language.ReifyType + LambdaCube.Language.Sampler + LambdaCube.Language.Type + + GHC-options: +-- -Werror + -Wall + -fno-warn-missing-signatures + -fno-warn-name-shadowing + -fno-warn-orphans + -fno-warn-unused-binds + -fno-warn-unused-do-bind + -fspec-constr-count=10 + -funbox-strict-fields + -O0 +-- for profiling +-- -auto-all +-- -caf-all + + default-extensions: + ConstraintKinds + DataKinds + DeriveDataTypeable + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + KindSignatures + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeOperators + TypeSynonymInstances + PolyKinds diff --git a/src/lib/LambdaCube/Convert/PrimFun.hs b/src/lib/LambdaCube/Convert/PrimFun.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Convert/PrimFun.hs @@ -0,0 +1,167 @@ +module LambdaCube.Convert.PrimFun where + +import qualified LambdaCube.Language.PrimFun as T +import LambdaCube.Core.PrimFun + +convertPrimFun :: T.PrimFun a b -> PrimFun +convertPrimFun a = case a of + -- Vec/Mat (de)construction + T.PrimTupToV2 -> PrimTupToV2 + T.PrimTupToV3 -> PrimTupToV3 + T.PrimTupToV4 -> PrimTupToV4 + T.PrimV2ToTup -> PrimV2ToTup + T.PrimV3ToTup -> PrimV3ToTup + T.PrimV4ToTup -> PrimV4ToTup + + -- Arithmetic Functions (componentwise) + T.PrimAdd -> PrimAdd + T.PrimAddS -> PrimAddS + T.PrimSub -> PrimSub + T.PrimSubS -> PrimSubS + T.PrimMul -> PrimMul + T.PrimMulS -> PrimMulS + T.PrimDiv -> PrimDiv + T.PrimDivS -> PrimDivS + T.PrimNeg -> PrimNeg + T.PrimMod -> PrimMod + T.PrimModS -> PrimModS + + -- Bit-wise Functions + T.PrimBAnd -> PrimBAnd + T.PrimBAndS -> PrimBAndS + T.PrimBOr -> PrimBOr + T.PrimBOrS -> PrimBOrS + T.PrimBXor -> PrimBXor + T.PrimBXorS -> PrimBXorS + T.PrimBNot -> PrimBNot + T.PrimBShiftL -> PrimBShiftL + T.PrimBShiftLS -> PrimBShiftLS + T.PrimBShiftR -> PrimBShiftR + T.PrimBShiftRS -> PrimBShiftRS + + -- Logic Functions + T.PrimAnd -> PrimAnd + T.PrimOr -> PrimOr + T.PrimXor -> PrimXor + T.PrimNot -> PrimNot + T.PrimAny -> PrimAny + T.PrimAll -> PrimAll + + -- Angle and Trigonometry Functions + T.PrimACos -> PrimACos + T.PrimACosH -> PrimACosH + T.PrimASin -> PrimASin + T.PrimASinH -> PrimASinH + T.PrimATan -> PrimATan + T.PrimATan2 -> PrimATan2 + T.PrimATanH -> PrimATanH + T.PrimCos -> PrimCos + T.PrimCosH -> PrimCosH + T.PrimDegrees -> PrimDegrees + T.PrimRadians -> PrimRadians + T.PrimSin -> PrimSin + T.PrimSinH -> PrimSinH + T.PrimTan -> PrimTan + T.PrimTanH -> PrimTanH + + -- Exponential Functions + T.PrimPow -> PrimPow + T.PrimExp -> PrimExp + T.PrimLog -> PrimLog + T.PrimExp2 -> PrimExp2 + T.PrimLog2 -> PrimLog2 + T.PrimSqrt -> PrimSqrt + T.PrimInvSqrt -> PrimInvSqrt + + -- Common Functions + T.PrimIsNan -> PrimIsNan + T.PrimIsInf -> PrimIsInf + T.PrimAbs -> PrimAbs + T.PrimSign -> PrimSign + T.PrimFloor -> PrimFloor + T.PrimTrunc -> PrimTrunc + T.PrimRound -> PrimRound + T.PrimRoundEven -> PrimRoundEven + T.PrimCeil -> PrimCeil + T.PrimFract -> PrimFract + T.PrimModF -> PrimModF + T.PrimMin -> PrimMin + T.PrimMinS -> PrimMinS + T.PrimMax -> PrimMax + T.PrimMaxS -> PrimMaxS + T.PrimClamp -> PrimClamp + T.PrimClampS -> PrimClampS + T.PrimMix -> PrimMix + T.PrimMixS -> PrimMixS + T.PrimMixB -> PrimMixB + T.PrimStep -> PrimStep + T.PrimStepS -> PrimStepS + T.PrimSmoothStep -> PrimSmoothStep + T.PrimSmoothStepS -> PrimSmoothStepS + + -- Integer/Float Conversion Functions + T.PrimFloatBitsToInt -> PrimFloatBitsToInt + T.PrimFloatBitsToUInt -> PrimFloatBitsToUInt + T.PrimIntBitsToFloat -> PrimIntBitsToFloat + T.PrimUIntBitsToFloat -> PrimUIntBitsToFloat + + -- Geometric Functions + T.PrimLength -> PrimLength + T.PrimDistance -> PrimDistance + T.PrimDot -> PrimDot + T.PrimCross -> PrimCross + T.PrimNormalize -> PrimNormalize + T.PrimFaceForward -> PrimFaceForward + T.PrimReflect -> PrimReflect + T.PrimRefract -> PrimRefract + + -- Matrix Functions + T.PrimTranspose -> PrimTranspose + T.PrimDeterminant -> PrimDeterminant + T.PrimInverse -> PrimInverse + T.PrimOuterProduct -> PrimOuterProduct + T.PrimMulMatVec -> PrimMulMatVec + T.PrimMulVecMat -> PrimMulVecMat + T.PrimMulMatMat -> PrimMulMatMat + + -- Vector and Scalar Relational Functions + T.PrimLessThan -> PrimLessThan + T.PrimLessThanEqual -> PrimLessThanEqual + T.PrimGreaterThan -> PrimGreaterThan + T.PrimGreaterThanEqual -> PrimGreaterThanEqual + T.PrimEqualV -> PrimEqualV + T.PrimEqual -> PrimEqual + T.PrimNotEqualV -> PrimNotEqualV + T.PrimNotEqual -> PrimNotEqual + + -- Fragment Processing Functions + T.PrimDFdx -> PrimDFdx + T.PrimDFdy -> PrimDFdy + T.PrimFWidth -> PrimFWidth + + -- Noise Functions + T.PrimNoise1 -> PrimNoise1 + T.PrimNoise2 -> PrimNoise2 + T.PrimNoise3 -> PrimNoise3 + T.PrimNoise4 -> PrimNoise4 + + -- Texture Lookup Functions + T.PrimTextureSize -> PrimTextureSize + T.PrimTexture -> PrimTexture + T.PrimTextureB -> PrimTexture + T.PrimTextureProj -> PrimTextureProj + T.PrimTextureProjB -> PrimTextureProj + T.PrimTextureLod -> PrimTextureLod + T.PrimTextureOffset -> PrimTextureOffset + T.PrimTextureOffsetB -> PrimTextureOffset + T.PrimTexelFetch -> PrimTexelFetch + T.PrimTexelFetchOffset -> PrimTexelFetchOffset + T.PrimTextureProjOffset -> PrimTextureProjOffset + T.PrimTextureProjOffsetB -> PrimTextureProjOffset + T.PrimTextureLodOffset -> PrimTextureLodOffset + T.PrimTextureProjLod -> PrimTextureProjLod + T.PrimTextureProjLodOffset -> PrimTextureProjLodOffset + T.PrimTextureGrad -> PrimTextureGrad + T.PrimTextureGradOffset -> PrimTextureGradOffset + T.PrimTextureProjGrad -> PrimTextureProjGrad + T.PrimTextureProjGradOffset -> PrimTextureProjGradOffset diff --git a/src/lib/LambdaCube/Convert/ToDeBruijn.hs b/src/lib/LambdaCube/Convert/ToDeBruijn.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Convert/ToDeBruijn.hs @@ -0,0 +1,272 @@ +module LambdaCube.Convert.ToDeBruijn (convertGPOutput) where + +import GHC.TypeLits + +import Debug.Trace + +import LambdaCube.Language.Type (FlatTuple(..),Frequency(..)) +import LambdaCube.Language.ReifyType (GPU,Tuple(..),TupleIdx(..)) +import qualified LambdaCube.Language.Type as T +import qualified LambdaCube.Language.ReifyType as T hiding (Shadow) +import qualified LambdaCube.Language.PrimFun as T +import qualified LambdaCube.Language.HOAS as H +import LambdaCube.Core.DeBruijn +import LambdaCube.Core.Type +import LambdaCube.Convert.PrimFun +import LambdaCube.Core.Type as G + +toInt :: KnownNat n => T.NatNum n -> Int +toInt (a :: T.NatNum n) = fromInteger $ natVal a + +prjIdx i lyt = i--length lyt - i - 1 + + +prjToInt :: TupleIdx t e -> Int +prjToInt ZeroTupIdx = 0 +prjToInt (SuccTupIdx i) = 1 + prjToInt i + +genTupLen :: GPU a => Int -> a -> Int +genTupLen i a = sum $ map tySize $ take i rt + where + rt = reverse t + Tuple t = genTy a + +type Layout = [[Ty]] + +genTy :: GPU a => a -> Ty +genTy = T.tupleType + +convertGPOutput :: H.GPOutput o -> N +convertGPOutput (H.SamplerOut a b) = samplerOut a $ convertExp [] b +convertGPOutput (H.ScreenOut a) = screenOut $ convertGP a +convertGPOutput (H.MultiOut a) = multiOut $ map convertGPOutput a + +-- GP +convertGP :: H.Exp T.Obj t -> N +convertGP = convertOpenGP [] + +convertOpenGP :: Layout -> H.Exp T.Obj t -> N +convertOpenGP = cvt + where + cvt :: Layout -> H.Exp T.Obj t -> N + cvt lyt (H.Fetch n p i) = fetch n (convertFetchPrimitive p) (T.toInputList i) + cvt lyt (H.Transform vs ps) = transform (convertFun1Vert lyt vs) (cvt lyt ps) + cvt lyt (H.Reassemble sh ps) = reassemble (convertGeometryShader lyt sh) (cvt lyt ps) + cvt lyt (H.Rasterize ctx ps) = rasterize (convertRasterContext ctx) $ cvt lyt ps + cvt lyt (H.FrameBuffer fb) = frameBuffer (convertFrameBuffer fb) + cvt lyt (H.Accumulate ctx f sh fs fb) = accumulate (convertAccumulationContext lyt ctx) (convertFragmentFilter lyt f) + (convertFun1Frag lyt sh) + (cvt lyt fs) + (cvt lyt fb) + cvt lyt (H.PrjFrameBuffer n idx fb) = prjFrameBuffer n (prjToInt idx) $ convertGP fb + cvt lyt (H.PrjImage n idx img) = prjImage n (toInt idx) $ convertGP img + +-- Vertex +convertOpenVertexOut :: Layout -- environment + -> H.VertexOut clipDistances t -- expression to be converted + -> N +convertOpenVertexOut lyt = cvt + where + cvt :: H.VertexOut clipDistances t' -> N + cvt (H.VertexOut e1 e2 e3 ie :: H.VertexOut clipDistances t') = vertexOut (convertOpenExp lyt e1) (convertOpenExp lyt e2) (convertOpenFlatExp lyt e3) (convertOpenInterpolatedFlatExp lyt ie) + +-- Fragment +convertOpenFragmentOut :: forall t. + Layout -- environment + -> H.FragmentOut t -- expression to be converted + -> N +convertOpenFragmentOut lyt = cvt + where + cvt :: H.FragmentOut t' -> N + cvt (H.FragmentOut fe :: H.FragmentOut t') = fragmentOut $ convertOpenFlatExp lyt fe + cvt (H.FragmentOutDepth e fe :: H.FragmentOut t') = fragmentOutDepth (convertOpenExp lyt e) (convertOpenFlatExp lyt fe) + cvt (H.FragmentOutRastDepth fe :: H.FragmentOut t') = fragmentOutRastDepth $ convertOpenFlatExp lyt fe + +convertFragmentFilter :: (GPU a) + => Layout + -> H.FragmentFilter a + -> N +convertFragmentFilter = cvt + where + cvt :: (GPU a) => Layout -> H.FragmentFilter a -> N + cvt lyt H.PassAll = passAll + cvt lyt (H.Filter f) = filter_ $ convertFun1Exp lyt f + +-- Geometry +convertOpenGeometryOut :: forall i clipDistances t. + Layout -- environment + -> H.GeometryOut i clipDistances t -- expression to be converted + -> N +convertOpenGeometryOut lyt = cvt + where + cvt :: H.GeometryOut i clipDistances t' -> N + cvt (H.GeometryOut e1 e2 e3 e4 ie :: H.GeometryOut i clipDistances t') = geometryOut (convertOpenExp lyt e1) + (convertOpenExp lyt e2) + (convertOpenExp lyt e3) + (convertOpenFlatExp lyt e4) + (convertOpenInterpolatedFlatExp lyt ie) + +convertGeometryShader :: Layout + -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b + -> N +convertGeometryShader = cvt + where + cvt :: Layout -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b -> N + cvt lyt (H.GeometryShader a b c e1 e2 e3) = geometryShader (toInt a) (convertOutputPrimitive b) c (convertFun1Exp lyt e1) + (convertFun1Exp lyt e2) + (convertFun1Geom lyt e3) + +-- Common +convertOpenInterpolatedFlatExp :: forall stage t. + Layout -- environment + -> H.InterpolatedFlatExp stage t -- expression to be converted + -> [N] +convertOpenInterpolatedFlatExp lyt = cvt + where + cvt :: H.InterpolatedFlatExp stage t' -> [N] + cvt (ZT) = [] + cvt (e:.xs) = cvt' e : cvt xs + + cvt' :: T.Interpolated (H.Exp stage) t' -> N + cvt' (T.Flat e) = flat $ convertOpenExp lyt e + cvt' (T.Smooth e) = smooth $ convertOpenExp lyt e + cvt' (T.NoPerspective e) = noPerspective $ convertOpenExp lyt e + +convertOpenFlatExp :: forall stage t. + Layout -- environment + -> H.FlatExp stage t -- expression to be converted + -> [N] +convertOpenFlatExp lyt = cvt + where + cvt :: H.FlatExp stage t' -> [N] + cvt (ZT) = [] + cvt (e:.xs) = convertOpenExp lyt e : cvt xs + +convertOpenExp :: forall stage t. + Layout -- environment + -> H.Exp stage t -- expression to be converted + -> N +convertOpenExp lyt = cvt + where + cvt :: forall stage t' . H.Exp stage t' -> N + cvt (H.Tag i li :: H.Exp stage t') = var (genTy (undefined :: t')) (prjIdx i lyt) li + cvt (H.Const v :: H.Exp stage t') = const_ (genTy (undefined :: t')) (T.toValue v) + cvt (H.PrimVar v :: H.Exp stage t') = primVar (genTy (undefined :: t')) (fst $ T.toInput v) + cvt (H.Uni v :: H.Exp stage t') = uni (genTy (undefined :: t')) (fst $ T.toInput v) + cvt (H.Tup tupl :: H.Exp stage t') = tup (genTy (undefined :: t')) $ convertTuple lyt tupl + cvt (H.Prj idx (e :: H.Exp stage e') :: H.Exp stage' t') = prj (genTy (undefined :: t')) (genTupLen (prjToInt idx) (undefined :: e')) $ cvt e + cvt (H.Cond e1 e2 e3 :: H.Exp stage t') = cond (genTy (undefined :: t')) (cvt e1) (cvt e2) (cvt e3) + cvt (H.PrimApp p e :: H.Exp stage t') = primApp (genTy (undefined :: t')) (convertPrimFun p) $ cvt e + cvt (H.Sampler f em t :: H.Exp stage t') = sampler (genTy (undefined :: t')) f em $ cvt t + cvt (H.TextureSlot n t :: H.Exp stage t') = textureSlot n (convertTextureType t) + cvt (H.Texture t s m d :: H.Exp stage t') = texture (convertTextureType t) (T.toValue s) (convertMipMap m) (map convertGP d) + cvt (H.Loop e1 e2 e3 s :: H.Exp stage t') = loop (genTy (undefined :: t')) (convertFun1Exp lyt e1) (convertFun1Exp lyt e2) (convertFun1Exp lyt e3) (cvt s) + cvt (H.Let v fn) = let_ (convertOpenExp lyt v) (convertOpenExp lyt . fn . H.Shr) + cvt (H.Shr e) = e + +convertFun1Vert :: forall a b clipDistances. GPU a + => Layout + -> (H.Exp V a -> H.VertexOut clipDistances b) + -> N +convertFun1Vert = convertFun1 convertOpenVertexOut + +convertFun1Geom :: (GPU a, GPU i, GPU b, GPU clipDistances) + => Layout + -> (H.Exp G a -> H.GeometryOut i clipDistances b) + -> N +convertFun1Geom = convertFun1 convertOpenGeometryOut + +convertFun1Frag :: forall a b. GPU a + => Layout + -> (H.Exp F a -> H.FragmentOut b) + -> N +convertFun1Frag = convertFun1 convertOpenFragmentOut + +convertFun1Exp :: forall stage a b. GPU a + => Layout + -> (H.Exp stage a -> H.Exp stage b) + -> N +convertFun1Exp = convertFun1 convertOpenExp + +convertFun1 :: (GPU a) + => (Layout -> b -> N) -> Layout -> (H.Exp stage a -> b) -> N +convertFun1 cvt lyt (f :: H.Exp stage t' -> b) = lam (genTy (undefined :: t')) $ body $ cvt lyt' (f a) + where + lyt' = []:lyt + a = case f of + (fv :: H.Exp stage t -> t2) -> H.Tag (length lyt) (show $ genTy (undefined :: t)) + +convertExp :: Layout -- array environment + -> H.Exp stage t -- expression to be converted + -> N +convertExp lyt = convertOpenExp lyt + +convertTuple :: Layout + -> Tuple (H.Exp stage) t + -> [N] +convertTuple _lyt NilTup = [] +convertTuple lyt (es `SnocTup` e) = convertTuple lyt es ++ [convertOpenExp lyt e] + +-- data type conversion +convertTextureDataType :: T.TextureDataType t ar -> TextureDataType +convertTextureDataType (T.Float a) = FloatT (T.toColorArity a) +convertTextureDataType (T.Int a) = IntT (T.toColorArity a) +convertTextureDataType (T.Word a) = WordT (T.toColorArity a) +convertTextureDataType T.Shadow = ShadowT + +convertTextureType :: T.TextureType dim mip arr layerCount t ar -> TextureType +convertTextureType (T.Texture1D a b) = Texture1D (convertTextureDataType a) (toInt b) +convertTextureType (T.Texture2D a b) = Texture2D (convertTextureDataType a) (toInt b) +convertTextureType (T.Texture3D a) = Texture3D (convertTextureDataType a) +convertTextureType (T.TextureCube a) = TextureCube (convertTextureDataType a) +convertTextureType (T.TextureRect a) = TextureRect (convertTextureDataType a) +convertTextureType (T.Texture2DMS a b) = Texture2DMS (convertTextureDataType a) (toInt b) +convertTextureType (T.TextureBuffer a) = TextureBuffer (convertTextureDataType a) + +convertMipMap :: T.MipMap t -> MipMap +convertMipMap (T.NoMip) = NoMip +convertMipMap (T.Mip a b) = Mip a b +convertMipMap (T.AutoMip a b) = AutoMip a b + +convertRasterContext :: T.RasterContext p -> RasterContext +convertRasterContext (T.PointCtx a b c) = PointCtx a b c +convertRasterContext (T.LineCtx a b) = LineCtx a b +convertRasterContext (T.TriangleCtx a b c d) = TriangleCtx a b c d + +convertBlending :: T.Blending c -> Blending +convertBlending T.NoBlending = NoBlending +convertBlending (T.BlendLogicOp a) = BlendLogicOp a +convertBlending (T.Blend a b c) = Blend a b c + +convertFetchPrimitive :: T.FetchPrimitive a -> FetchPrimitive +convertFetchPrimitive v = case v of + T.Points -> Points + T.Lines -> Lines + T.Triangles -> Triangles + T.LinesAdjacency -> LinesAdjacency + T.TrianglesAdjacency -> TrianglesAdjacency + +convertOutputPrimitive :: T.OutputPrimitive a -> OutputPrimitive +convertOutputPrimitive v = case v of + T.TrianglesOutput -> TrianglesOutput + T.LinesOutput -> LinesOutput + T.PointsOutput -> PointsOutput + +convertAccumulationContext :: Layout -> H.AccumulationContext b -> N +convertAccumulationContext lyt (H.AccumulationContext vpSize ops) = accumulationContext (fmap (convertOpenExp []) vpSize) $ cvt ops + where + cvt :: FlatTuple T.NoConstraint T.FragmentOperation b -> [FragmentOperation] + cvt ZT = [] + cvt (T.DepthOp a b:.xs) = DepthOp a b : cvt xs + cvt (T.StencilOp a b c :. xs) = StencilOp a b c : cvt xs + cvt (T.ColorOp a b :. xs) = ColorOp (convertBlending a) (T.toValue b) : cvt xs + +convertFrameBuffer :: T.FrameBuffer layerCount t -> [Image] +convertFrameBuffer = cvt + where + cvt :: T.FrameBuffer layerCount t -> [Image] + cvt ZT = [] + cvt (T.DepthImage a b:.xs) = DepthImage (toInt a) b : cvt xs + cvt (T.StencilImage a b:.xs) = StencilImage (toInt a) b : cvt xs + cvt (T.ColorImage a b:.xs) = ColorImage (toInt a) (T.toValue b) : cvt xs + cvt (T.UnclearedImage a:.xs) = UnclearedImage (toInt a) : cvt xs diff --git a/src/lib/LambdaCube/Language.hs b/src/lib/LambdaCube/Language.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances, OverloadedStrings #-} +module LambdaCube.Language where + +import Data.Int +import Data.Word + +import LambdaCube.Core.Type +import LambdaCube.Language.Type +import LambdaCube.Language.ReifyType +import LambdaCube.Language.PrimFun +import LambdaCube.Language.HOAS +{- + all operatiors with @<>?,./\';""|:}{+_)0-=§±!@#$%^&*()_+ + <+> <+.> <.+> -- good, conflict: <*> + [+] [+.] [.+] -- good, conflict with lists + |+| |+.| |.+| -- medium + @+ @+. @.+ -- bad + :+: :+.: :.+: -- bad + [*] +-} +{- +infixl 7 .*., ./., .%. +infixl 6 .+., .-. +infix 4 .==., ./=., .<., .<=., .>=., .>. + +infixr 3 .&&. +infixr 2 .||. + +infixl 8 .>>., .<<. +infixl 7 .&. +infixl 6 .^. +infixl 5 .|. +-} + +infixl 7 @*, @/, @% +infixl 6 @+, @- +infix 4 @==, @/=, @<, @<=, @>=, @> + +infixr 3 @&& +infixr 2 @|| + +infixl 8 @>>, @<< +infixl 7 @& +infixl 6 @^ +infixl 5 @| + +infix 7 @. -- dot +infix 7 @# -- cross +infixr 7 @*. -- mulmv +infixl 7 @.* -- mulvm +infixl 7 @.*. -- mulmm + +-- TODO: we should use template haskell or a preprocessor to generate the instances +class OperatorArithmetic a b where + (@+) :: a -> b -> a + (@-) :: a -> b -> a + (@*) :: a -> b -> a + +instance (GPU (V2 t), IsNumComponent t, IsMatVec (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage (V2 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU (V3 t), IsNumComponent t, IsMatVec (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage (V3 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU (V4 t), IsNumComponent t, IsMatVec (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage (V4 t)) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU c, GPU (V2 t), IsNumComponent t, IsMatVecScalar (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU c, GPU (V3 t), IsNumComponent t, IsMatVecScalar (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU c, GPU (V4 t), IsNumComponent t, IsMatVecScalar (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage c) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) + +{- +instance (GPU a, IsNum t, IsMatVec a t) => OperatorArithmetic (Exp stage a) (Exp stage a) (Exp stage a) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) (Exp stage a) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) +-} +{- +instance OperatorArithmetic (Exp stage V4F) (Exp stage V4F) (Exp stage V4F) where + a @+ b = PrimApp PrimAdd $! tup2 (a,b) + a @- b = PrimApp PrimSub $! tup2 (a,b) + a @* b = PrimApp PrimMul $! tup2 (a,b) + +instance OperatorArithmetic (Exp stage V4F) (Exp stage Float) (Exp stage V4F) where + a @+ b = PrimApp PrimAddS $! tup2 (a,b) + a @- b = PrimApp PrimSubS $! tup2 (a,b) + a @* b = PrimApp PrimMulS $! tup2 (a,b) +-} + +-- FIXME: modulus % is defined only for integral types +class OperatorDivide a b where + (@/) :: a -> b -> a + (@%) :: a -> b -> a + +instance (GPU a, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage a) where + a @/ b = PrimApp PrimDiv $! tup2 (a,b) + a @% b = PrimApp PrimMod $! tup2 (a,b) + +instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage t) where + a @/ b = PrimApp PrimDivS $! tup2 (a,b) + a @% b = PrimApp PrimModS $! tup2 (a,b) + +class OperatorBit a b where + (@&) :: a -> b -> a + (@|) :: a -> b -> a + (@^) :: a -> b -> a + +instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage a) where + a @& b = PrimApp PrimBAnd $! tup2 (a,b) + a @| b = PrimApp PrimBOr $! tup2 (a,b) + a @^ b = PrimApp PrimBXor $! tup2 (a,b) + +instance (GPU a, GPU t, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage t) where + a @& b = PrimApp PrimBAndS $! tup2 (a,b) + a @| b = PrimApp PrimBOrS $! tup2 (a,b) + a @^ b = PrimApp PrimBXorS $! tup2 (a,b) + +class OperatorShift a b where + (@>>) :: a -> b -> a + (@<<) :: a -> b -> a + +instance (GPU a, GPU b, IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => OperatorShift (Exp stage a) (Exp stage b) where + a @>> b = PrimApp PrimBShiftR $! tup2 (a,b) + a @<< b = PrimApp PrimBShiftL $! tup2 (a,b) + +instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorShift (Exp stage a) (Exp stage Word32) where + a @>> b = PrimApp PrimBShiftRS $! tup2 (a,b) + a @<< b = PrimApp PrimBShiftLS $! tup2 (a,b) + +class OperatorEq a b where + (@==) :: a -> a -> b + (@/=) :: a -> a -> b + +instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorEq (Exp stage a) (Exp stage b) where + a @== b = PrimApp PrimEqualV $! tup2 (a,b) + a @/= b = PrimApp PrimNotEqualV $! tup2 (a,b) + +instance (GPU a, IsMatVecScalar a t) => OperatorEq (Exp stage a) (Exp stage Bool) where + a @== b = PrimApp PrimEqual $! tup2 (a,b) + a @/= b = PrimApp PrimNotEqual $! tup2 (a,b) + +class OperatorRelational a b where + (@<=) :: a -> a -> b + (@>=) :: a -> a -> b + (@<) :: a -> a -> b + (@>) :: a -> a -> b + +instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorRelational (Exp stage a) (Exp stage b) where + a @<= b = PrimApp PrimLessThanEqual $! tup2 (a,b) + a @>= b = PrimApp PrimGreaterThanEqual $! tup2 (a,b) + a @< b = PrimApp PrimLessThan $! tup2 (a,b) + a @> b = PrimApp PrimGreaterThan $! tup2 (a,b) + +a @&& b = PrimApp PrimAnd $! tup2 (a,b) +a @|| b = PrimApp PrimOr $! tup2 (a,b) + +xor' a b = PrimApp PrimXor $! tup2 (a,b) +not' a = PrimApp PrimNot a +any' a = PrimApp PrimAny a +all' a = PrimApp PrimAll a + +acos' a = PrimApp PrimACos a +acosh' a = PrimApp PrimACosH a +asin' a = PrimApp PrimASin a +asinh' a = PrimApp PrimASinH a +atan' a = PrimApp PrimATan a +atan2' a b = PrimApp PrimATan2 $! tup2 (a,b) +atanh' a = PrimApp PrimATanH a +cos' a = PrimApp PrimCos a +cosh' a = PrimApp PrimCosH a +degrees' a = PrimApp PrimDegrees a +radians' a = PrimApp PrimRadians a +sin' a = PrimApp PrimSin a +sinh' a = PrimApp PrimSinH a +tan' a = PrimApp PrimTan a +tanh' a = PrimApp PrimTanH a + +pow' a b = PrimApp PrimPow $! tup2 (a,b) +exp' a = PrimApp PrimExp a +log' a = PrimApp PrimLog a +exp2' a = PrimApp PrimExp2 a +log2' a = PrimApp PrimLog2 a +sqrt' a = PrimApp PrimSqrt a +invsqrt' a = PrimApp PrimInvSqrt a + +isnan' a = PrimApp PrimIsNan a +isinf' a = PrimApp PrimIsInf a +abs' a = PrimApp PrimAbs a +sign' a = PrimApp PrimSign a +floor' a = PrimApp PrimFloor a +trunc' a = PrimApp PrimTrunc a +round' a = PrimApp PrimRound a +roundEven' a = PrimApp PrimRoundEven a +ceil' a = PrimApp PrimCeil a +fract' a = PrimApp PrimFract a + +floatBitsToInt' a = PrimApp PrimFloatBitsToInt a +floatBitsToUint' a = PrimApp PrimFloatBitsToUInt a +intBitsToFloat' a = PrimApp PrimIntBitsToFloat a +uintBitsToFloat' a = PrimApp PrimUIntBitsToFloat a + +length' a = PrimApp PrimLength a +distance' a b = PrimApp PrimDistance $! tup2 (a,b) +dot' a b = PrimApp PrimDot $! tup2 (a,b) +cross' a b = PrimApp PrimCross $! tup2 (a,b) +normalize' a = PrimApp PrimNormalize a +faceforward' a b c = PrimApp PrimFaceForward $! tup3 (a,b,c) +reflect' a b = PrimApp PrimReflect $! tup2 (a,b) +refract' a b c = PrimApp PrimRefract $! tup3 (a,b,c) + +transpose' a = PrimApp PrimTranspose a +determinant' a = PrimApp PrimDeterminant a +inverse' a = PrimApp PrimInverse a +outerProduct' a b = PrimApp PrimOuterProduct $! tup2 (a,b) + +dFdx' a = PrimApp PrimDFdx a +dFdy' a = PrimApp PrimDFdy a +fwidth' a = PrimApp PrimFWidth a + +noise1' a = PrimApp PrimNoise1 a +noise2' a = PrimApp PrimNoise2 a +noise3' a = PrimApp PrimNoise3 a +noise4' a = PrimApp PrimNoise4 a + +textureSize' a b = PrimApp PrimTextureSize $! tup2 (a,b) +texture' a b = PrimApp PrimTexture $! tup2 (a,b) +textureB' a b c = PrimApp PrimTextureB $! tup3 (a,b,c) +textureProj' a b = PrimApp PrimTextureProj $! tup2 (a,b) +textureProjB' a b c = PrimApp PrimTextureProjB $! tup3 (a,b,c) +textureLod' a b c = PrimApp PrimTextureLod $! tup3 (a,b,c) +textureOffset' a b c = PrimApp PrimTextureOffset $! tup3 (a,b,c) +textureOffsetB' a b c d = PrimApp PrimTextureOffsetB $! tup4 (a,b,c,d) +texelFetch' a b c = PrimApp PrimTexelFetch $! tup3 (a,b,c) +texelFetchOffset' a b c d = PrimApp PrimTexelFetchOffset $! tup4 (a,b,c,d) +textureProjOffset' a b c = PrimApp PrimTextureProjOffset $! tup3 (a,b,c) +textureProjOffsetB' a b c d = PrimApp PrimTextureProjOffsetB $! tup4 (a,b,c,d) +textureLodOffset' a b c d = PrimApp PrimTextureLodOffset $! tup4 (a,b,c,d) +textureProjLod' a b c = PrimApp PrimTextureProjLod $! tup3 (a,b,c) +textureProjLodOffset' a b c d = PrimApp PrimTextureProjLodOffset $! tup4 (a,b,c,d) +textureGrad' a b c d = PrimApp PrimTextureGrad $! tup4 (a,b,c,d) +textureGradOffset' a b c d e = PrimApp PrimTextureGradOffset $! tup5 (a,b,c,d,e) +textureProjGrad' a b c d = PrimApp PrimTextureProjGrad $! tup4 (a,b,c,d) +textureProjGradOffset' a b c d e = PrimApp PrimTextureProjGradOffset $! tup5 (a,b,c,d,e) + +class BuiltinCommon a b where + min' :: a -> b -> a + max' :: a -> b -> a + clamp' :: a -> b -> b -> a + +instance (GPU a, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage a) where + min' a b = PrimApp PrimMin $! tup2 (a,b) + max' a b = PrimApp PrimMax $! tup2 (a,b) + clamp' a b c = PrimApp PrimClamp $! tup3 (a,b,c) + +instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage t) where + min' a b = PrimApp PrimMinS $! tup2 (a,b) + max' a b = PrimApp PrimMaxS $! tup2 (a,b) + clamp' a b c = PrimApp PrimClampS $! tup3 (a,b,c) + +class BuiltinMix a b where + mix' :: a -> a -> b -> a + +instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage a) where + mix' a b c = PrimApp PrimMix $! tup3 (a,b,c) + +instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage Float) where + mix' a b c = PrimApp PrimMixS $! tup3 (a,b,c) + +instance (GPU a, GPU b, IsVecScalar d a Float, IsVecScalar d b Bool) => BuiltinMix (Exp stage a) (Exp stage b) where + mix' a b c = PrimApp PrimMixB $! tup3 (a,b,c) + +class BuiltinStep a b where + step' :: b -> a -> a + smoothstep' :: b -> b -> a -> a + +instance BuiltinStep (Exp stage V2F) (Exp stage V2F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance BuiltinStep (Exp stage V3F) (Exp stage V3F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance BuiltinStep (Exp stage V4F) (Exp stage V4F) where + step' a b = PrimApp PrimStep $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c) + +instance (GPU a, IsVecScalar d a Float) => BuiltinStep (Exp stage a) (Exp stage Float) where + step' a b = PrimApp PrimStepS $! tup2 (a,b) + smoothstep' a b c = PrimApp PrimSmoothStepS $! tup3 (a,b,c) + +a @. b = dot' a b +a @# b = cross' a b +a @*. b = PrimApp PrimMulMatVec $! tup2 (a,b) +a @.* b = PrimApp PrimMulVecMat $! tup2 (a,b) +a @.*. b = PrimApp PrimMulMatMat $! tup2 (a,b) + +complement' a = PrimApp PrimBNot a +neg' a = PrimApp PrimNeg a +modf' a = PrimApp PrimModF a + +{- +data PrimFun sig where + + -- Vec/Mat (de)construction + PrimTupToV2 :: IsComponent a => PrimFun ((a,a) -> V2 a) + PrimTupToV3 :: IsComponent a => PrimFun ((a,a,a) -> V3 a) + PrimTupToV4 :: IsComponent a => PrimFun ((a,a,a,a) -> V4 a) + PrimV2ToTup :: IsComponent a => PrimFun (V2 a -> (a,a)) + PrimV3ToTup :: IsComponent a => PrimFun (V3 a -> (a,a,a)) + PrimV4ToTup :: IsComponent a => PrimFun (V4 a -> (a,a,a,a)) +-} +--mkV2 a b = +--mkV3 +--mkV4 + +class SpecialConstant a where + zero' :: a + one' :: a + +instance SpecialConstant Bool where + zero' = False + one' = True + +instance SpecialConstant Int32 where + zero' = 0 + one' = 1 + +instance SpecialConstant Word32 where + zero' = 0 + one' = 1 + +instance SpecialConstant Float where + zero' = 0 + one' = 1 + +instance (SpecialConstant a) => SpecialConstant (V2 a) where + zero' = V2 zero' zero' + one' = V2 one' one' + +instance (SpecialConstant a) => SpecialConstant (V3 a) where + zero' = V3 zero' zero' zero' + one' = V3 one' one' one' + +instance (SpecialConstant a) => SpecialConstant (V4 a) where + zero' = V4 zero' zero' zero' zero' + one' = V4 one' one' one' one' + +class IdentityMatrix a where + idmtx' :: a + +instance IdentityMatrix M22F where + idmtx' = V2 (V2 1 0) (V2 0 1) + +instance IdentityMatrix M33F where + idmtx' = V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1) + +instance IdentityMatrix M44F where + idmtx' = V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1) +{- + TODO: + extendZero + extendWith + trim +-} + +class PkgVec v where + unpack' :: (GPU a, GPU (v a), IsComponent a) + => Exp stage (v a) -> v (Exp stage a) + + pack' :: (GPU a, GPU (v a), IsComponent a) + => v (Exp stage a) -> Exp stage (v a) + +instance PkgVec V2 where + unpack' v = let (x,y) = untup2 $! PrimApp PrimV2ToTup v in V2 x y + pack' (V2 x y) = PrimApp PrimTupToV2 $! tup2 (x,y) + +instance PkgVec V3 where + unpack' v = let (x,y,z) = untup3 $! PrimApp PrimV3ToTup v in V3 x y z + pack' (V3 x y z) = PrimApp PrimTupToV3 $! tup3 (x,y,z) + +instance PkgVec V4 where + unpack' v = let (x,y,z,w) = untup4 $! PrimApp PrimV4ToTup v in V4 x y z w + pack' (V4 x y z w) = PrimApp PrimTupToV4 $! tup4 (x,y,z,w) + +-- Smart constructor and destructors for tuples +-- +tup0 :: Exp freq () +tup0 = Tup NilTup + +tup2 :: (GPU a, GPU b) + => (Exp stage a, Exp stage b) -> Exp stage (a, b) +tup2 (x1, x2) = Tup (NilTup `SnocTup` x1 `SnocTup` x2) + +tup3 :: (GPU a, GPU b, GPU c) + => (Exp stage a, Exp stage b, Exp stage c) -> Exp stage (a, b, c) +tup3 (x1, x2, x3) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3) + +tup4 :: (GPU a, GPU b, GPU c, GPU d) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d) -> Exp stage (a, b, c, d) +tup4 (x1, x2, x3, x4) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4) + +tup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) -> Exp stage (a, b, c, d, e) +tup5 (x1, x2, x3, x4, x5) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 + +tup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) -> Exp stage (a, b, c, d, e, f) +tup6 (x1, x2, x3, x4, x5, x6) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 + +tup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) -> Exp stage (a, b, c, d, e, f, g) +tup7 (x1, x2, x3, x4, x5, x6, x7) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 + +tup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) -> Exp stage (a, b, c, d, e, f, g, h) +tup8 (x1, x2, x3, x4, x5, x6, x7, x8) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 + +tup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) + => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) -> Exp stage (a, b, c, d, e, f, g, h, i) +tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9) + = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9 + +untup2 :: (GPU a, GPU b) + => Exp stage (a, b) -> (Exp stage a, Exp stage b) +untup2 e = (tix1 `Prj` e, tix0 `Prj` e) + +untup3 :: (GPU a, GPU b, GPU c) + => Exp stage (a, b, c) -> (Exp stage a, Exp stage b, Exp stage c) +untup3 e = (tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup4 :: (GPU a, GPU b, GPU c, GPU d) + => Exp stage (a, b, c, d) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d) +untup4 e = (tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e) + => Exp stage (a, b, c, d, e) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) +untup5 e = (tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) + => Exp stage (a, b, c, d, e, f) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) +untup6 e = (tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) + => Exp stage (a, b, c, d, e, f, g) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) +untup7 e = (tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) + => Exp stage (a, b, c, d, e, f, g, h) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) +untup8 e = (tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +untup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) + => Exp stage (a, b, c, d, e, f, g, h, i) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) +untup9 e = (tix8 `Prj` e, tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e) + +-- builtin variables +-- vertex shader +vertexID' :: Exp V Int32 +vertexID' = PrimVar $ IInt "gl_VertexID" + +instanceID' :: Exp V Int32 +instanceID' = PrimVar $ IInt "gl_InstanceID" + +-- geometry shader +primitiveIDIn' :: Exp G Int32 +primitiveIDIn' = PrimVar $ IInt "gl_PrimitiveIDIn" + +-- fragment shader +fragCoord' :: Exp F V4F +fragCoord' = PrimVar $ IV4F "gl_FragCoord" + +frontFacing' :: Exp F Bool +frontFacing' = PrimVar $ IBool "gl_FrontFacing" + +pointCoord' :: Exp F V2F +pointCoord' = PrimVar $ IV2F "gl_PointCoord" + +primitiveID' :: Exp F Int32 +primitiveID' = PrimVar $ IInt "gl_PrimitiveID" diff --git a/src/lib/LambdaCube/Language/HOAS.hs b/src/lib/LambdaCube/Language/HOAS.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language/HOAS.hs @@ -0,0 +1,270 @@ +module LambdaCube.Language.HOAS where + +import GHC.TypeLits + +import Data.ByteString.Char8 +import Data.Int + +import LambdaCube.Core.Type hiding (FetchPrimitive, OutputPrimitive, Blending, RasterContext, Blend, TriangleCtx, Image, FragmentOperation, MipMap, TextureDataType, TextureType) +import LambdaCube.Language.Type +import LambdaCube.Language.ReifyType +import LambdaCube.Language.PrimFun +import Data.Typeable +import Data.Dynamic +import qualified LambdaCube.Core.DeBruijn as U (N) + +-- Common Exp, describes shader functions +data Exp :: Frequency -> * -> * where + + Tag :: GPU t + => Int + -> String + -> Exp stage t + + -- Needed for Let conversion + Shr :: U.N + -> Exp stage t + + Let :: (GPU a, GPU b) + => Exp stage a + -> (Exp stage a -> Exp stage b) + -> Exp stage b + + -- Needed for conversion to de Bruijn form + Var :: GPU t + => Dynamic + -> Exp stage t + -- environment size at defining occurrence +{- + -- function support + Lam :: (GPU a, GPU b) + => (Exp stage a -> Exp stage b) + -> Exp stage (a -> b) + + App :: (GPU a, GPU b) + => Exp stage a + -> Exp stage (a -> b) + -> Exp stage b +-} + -- constant value + Const :: (GPU t,IsScalar t) + => t + -> Exp stage t + + -- builtin variable + PrimVar :: GPU t + => Input t + -> Exp stage t + + -- uniform value + Uni :: GPU t + => Input t + -> Exp stage t + + -- conditional expression + Cond :: GPU t + => Exp stage Bool + -> Exp stage t + -> Exp stage t + -> Exp stage t + + PrimApp :: (GPU a, GPU r) + => PrimFun stage (a -> r) + -> Exp stage a + -> Exp stage r + + -- tuple support + Tup :: (GPU t, IsTuple t) + => Tuple (Exp stage) (TupleRepr t) + -> Exp stage t + + Prj :: (GPU e, GPU t, IsTuple t) + => TupleIdx (TupleRepr t) e + -> Exp stage t + -> Exp stage e + + -- sampler support + Sampler :: GPU (Sampler dim arr t ar) + => Filter + -> EdgeMode + -> Exp Obj (Texture dim arr t ar) + -> Exp stage (Sampler dim arr t ar) + + TextureSlot :: (IsValidTextureSlot t) + => ByteString -- texture slot name + -> TextureType dim mip arr layerCount t ar + -> Exp Obj (Texture dim arr t ar) + -- TODO: + -- add texture internal format specification + Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip {- ,Typeable (TexDataRepr ar t), Typeable (TextureType dim canMip arr layerCount t ar), Typeable (Image layerCount (TexDataRepr ar t))-}) + => TextureType dim canMip arr layerCount t ar + -> TexSizeRepr dim + -> MipMap mip +-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type + -> [Exp Obj (Image layerCount (TexDataRepr ar t))] + -> Exp Obj (Texture dim arr t ar) + + -- loop support + Loop :: (GPU s, GPU a{-, Typeable stage-}) + => (Exp stage s -> Exp stage s) -- state transform function + -> (Exp stage s -> Exp stage Bool) -- loop condition function + -> (Exp stage s -> Exp stage a) -- state to result transform function + -> Exp stage s -- initial state + -> Exp stage a -- result + -- GP + -- hint: GP stands for Graphics Pipeline + Fetch :: (InputTuple a, SGPU (InputTupleRepr a)) + => ByteString + -> FetchPrimitive primitive + -> a + -> Exp Obj (VertexStream primitive (InputTupleRepr a)) + + Transform :: (GPU a, GPU b{-, Typeable clipDistances-}) + => (Exp V a -> VertexOut clipDistances b) -- vertex shader + -> Exp Obj (VertexStream primitive a) + -> Exp Obj (PrimitiveStream primitive clipDistances 1 V b) + + Reassemble :: GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b + -> Exp Obj (PrimitiveStream inputPrimitive inputClipDistances 1 V a) + -> Exp Obj (PrimitiveStream outputPrimitive outputClipDistances layerCount G b) + + Rasterize :: RasterContext primitive + -> Exp Obj (PrimitiveStream primitive clipDistances layerCount freq a) + -> Exp Obj (FragmentStream layerCount a) + + FrameBuffer :: FrameBuffer layerCount t + -> Exp Obj (FrameBuffer layerCount (FTRepr' t)) + + Accumulate :: ({-Typeable (NoStencilRepr b), -}GPU a, GPU (FTRepr' b), IsValidOutput b) -- restriction: depth and stencil optional, arbitrary color component + => AccumulationContext b + -> FragmentFilter a + -> (Exp F a -> FragmentOut (NoStencilRepr b)) -- fragment shader + -> Exp Obj (FragmentStream layerCount a) + -> Exp Obj (FrameBuffer layerCount (FTRepr' b)) + -> Exp Obj (FrameBuffer layerCount (FTRepr' b)) + + PrjFrameBuffer :: ByteString -- internal image output (can be allocated on request) + -> TupleIdx (EltRepr b) t + -> Exp Obj (FrameBuffer layerCount b) + -> Exp Obj (Image layerCount t) + + PrjImage :: ((idx + 1) <= layerCount, 2 <= layerCount, KnownNat idx) + => ByteString -- internal image output (can be allocated on request) + -> NatNum idx + -> Exp Obj (Image layerCount t) + -> Exp Obj (Image 1 t) +{- + -- dynamic extension support + AccumulateSet :: GPU a + => ByteString + -> Exp Obj (FrameBuffer layerCount a) + -> Exp Obj (FrameBuffer layerCount a) +-} + +type InterpolatedFlatExp stage a = FlatTuple GPU (Interpolated (Exp stage)) a +type FlatExp stage a = FlatTuple GPU (Exp stage) a + +-- Vertex +{- + Vertex shader builtin output: + gl_PerVertex { + vec4 gl_Position + float gl_PointSize + float gl_ClipDistance[] + } +-} +-- result of a vertex or geometry shader function +data VertexOut clipDistances t where + VertexOut :: IsFloatTuple clipDistances + => Exp V V4F -- position + -> Exp V Float -- point size + -> FlatExp V clipDistances -- clip distance [] + -> InterpolatedFlatExp V a + -> VertexOut (FTRepr clipDistances) (FTRepr a) +-- Geometry +-- describes a geometry shader +data GeometryShader (inPrimitive :: PrimitiveType) (outPrimitive :: PrimitiveType) inClipDistances outClipDistances (layerCount :: Nat) a b where + GeometryShader :: (GPU j, GPU i, GPU b, GPU outputClipDistances, GPU input, KnownNat layerCount + , inputVertex ~ (V4F,Float,inputClipDistances,a) + , input ~ PrimitiveVertices inputPrimitive inputVertex + ) + => NatNum layerCount -- geometry shader: + -> OutputPrimitive outputPrimitive -- output primitive + -> Int -- max amount of generated vertices + -> (Exp G input -> Exp G (i,Int32)) -- how many primitives? + -> (Exp G i -> Exp G (Int32,Int32,i,j,Int32)) -- how many vertices? primtive loop, out: + -- gl_PrimitiveID; gl_Layer; loop var; vertex loop seed; vertex loop iteration count) + -> (Exp G j -> GeometryOut j outputClipDistances b) -- generate vertices + -> GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b +{- + GeometryShader :: (GPU (PrimitiveVertices primIn a), GPU i, GPU j, GPU b, IsPrimitive primIn, IsPrimitive primOut, KnownNat layerNum) + => NatNum layerNum -- geometry shader: + -> primOut -- output primitive + -> Int -- max amount of generated vertices + -> (Exp G (PrimitiveVertices primIn a) -> Exp G (i,Int32)) -- how many primitives? + -> (Exp G i -> Exp G (i,j,Int32)) -- how many vertices? + -> (Exp G j -> GeometryOut (j,b)) -- generate vertices + -> GeometryShader primIn primOut layerNum a b +-} + +{- + Geometry shader builtin output: + gl_PerVertex { + vec4 gl_Position + float gl_PointSize + float gl_ClipDistance[] + } + int gl_PrimitiveID + int gl_Layer +-} +-- result of a geometry shader function +data GeometryOut i clipDistances t where + GeometryOut :: IsFloatTuple clipDistances + => Exp G i + -> Exp G V4F -- position + -> Exp G Float -- point size + -> FlatExp G clipDistances -- clip distance [] + -> InterpolatedFlatExp G a + -> GeometryOut i (FTRepr clipDistances) (FTRepr a) + +-- Fragment +{- + Fragment shader builtin output: + float gl_FragDepth -- Optional +-} +-- result of a fragment shader function +data FragmentOut t where + FragmentOut :: FlatExp F a + -> FragmentOut (ColorRepr a) + + FragmentOutDepth :: Exp F Float + -> FlatExp F a + -> FragmentOut (Depth Float :+: ColorRepr a) + + FragmentOutRastDepth :: FlatExp F a + -> FragmentOut (Depth Float :+: ColorRepr a) + +-- fragment filter function, we express discard using a filter function +data FragmentFilter a where + PassAll :: FragmentFilter a + + Filter :: (Exp F a -> Exp F Bool) + -> FragmentFilter a + +data GPOutput (o :: OutputType) where + SamplerOut :: GPU (Sampler dim arr t ar) + => ByteString + -> Exp Obj (Sampler dim arr t ar) + -> GPOutput SingleOutput + + ScreenOut :: Exp Obj (Image 1 t) + -> GPOutput SingleOutput + + MultiOut :: [GPOutput SingleOutput] + -> GPOutput MultiOutput + +data AccumulationContext t + = AccumulationContext + { accViewportSize :: Maybe (Exp Obj V4U) + , accOperations :: FlatTuple NoConstraint FragmentOperation t + } diff --git a/src/lib/LambdaCube/Language/PrimFun.hs b/src/lib/LambdaCube/Language/PrimFun.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language/PrimFun.hs @@ -0,0 +1,172 @@ +module LambdaCube.Language.PrimFun where + +import Data.Int +import Data.Word + +import LambdaCube.Core.Type +import LambdaCube.Language.Sampler +import LambdaCube.Language.Type + +data PrimFun stage sig where + + -- Vec/Mat (de)construction + PrimTupToV2 :: IsComponent a => PrimFun stage ((a,a) -> V2 a) + PrimTupToV3 :: IsComponent a => PrimFun stage ((a,a,a) -> V3 a) + PrimTupToV4 :: IsComponent a => PrimFun stage ((a,a,a,a) -> V4 a) + PrimV2ToTup :: IsComponent a => PrimFun stage (V2 a -> (a,a)) + PrimV3ToTup :: IsComponent a => PrimFun stage (V3 a -> (a,a,a)) + PrimV4ToTup :: IsComponent a => PrimFun stage (V4 a -> (a,a,a,a)) + + -- Arithmetic Functions (componentwise) + PrimAdd :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimAddS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimSub :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimSubS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimMul :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a) + PrimMulS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a) + PrimDiv :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimDivS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimNeg :: (IsSigned t, IsMatVecScalar a t) => PrimFun stage (a -> a) + PrimMod :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimModS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + + -- Bit-wise Functions + PrimBAnd :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBAndS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBOr :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBOrS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBXor :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimBXorS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimBNot :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimBShiftL :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a) + PrimBShiftLS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a) + PrimBShiftR :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a) + PrimBShiftRS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a) + + -- Logic Functions + PrimAnd :: PrimFun stage ((Bool,Bool) -> Bool) + PrimOr :: PrimFun stage ((Bool,Bool) -> Bool) + PrimXor :: PrimFun stage ((Bool,Bool) -> Bool) + PrimNot :: IsVecScalar d a Bool => PrimFun stage (a -> a) + PrimAny :: IsVecScalar d a Bool => PrimFun stage (a -> Bool) + PrimAll :: IsVecScalar d a Bool => PrimFun stage (a -> Bool) + + -- Angle and Trigonometry Functions + PrimACos :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimACosH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimASin :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimASinH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimATan :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimATan2 :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimATanH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCos :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCosH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimDegrees :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRadians :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSin :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSinH :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTan :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTanH :: IsVecScalar d a Float => PrimFun stage (a -> a) + + -- Exponential Functions + PrimPow :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimExp :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimLog :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimExp2 :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimLog2 :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimInvSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a) + + -- Common Functions + PrimIsNan :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b) + PrimIsInf :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b) + PrimAbs :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimSign :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a) + PrimFloor :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimTrunc :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRound :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimRoundEven :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimCeil :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimFract :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimModF :: IsVecScalar d a Float => PrimFun stage (a -> (a,a)) + PrimMin :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimMinS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimMax :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a) + PrimMaxS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a) + PrimClamp :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a,a) -> a) + PrimClampS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t,t) -> a) + PrimMix :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + PrimMixS :: IsVecScalar d a Float => PrimFun stage ((a,a,Float) -> a) + PrimMixB :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage ((a,a,b) -> a) + PrimStep :: IsVec d a Float => PrimFun stage ((a,a) -> a) + PrimStepS :: IsVecScalar d a Float => PrimFun stage ((Float,a) -> a) + PrimSmoothStep :: IsVec d a Float => PrimFun stage ((a,a,a) -> a) + PrimSmoothStepS :: IsVecScalar d a Float => PrimFun stage ((Float,Float,a) -> a) + + -- Integer/Float Conversion Functions + PrimFloatBitsToInt :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (fv -> iv) + PrimFloatBitsToUInt :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (fv -> uv) + PrimIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (iv -> fv) + PrimUIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (uv -> fv) + + -- Geometric Functions + PrimLength :: IsVecScalar d a Float => PrimFun stage (a -> Float) + PrimDistance :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float) + PrimDot :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float) + PrimCross :: IsVecScalar 3 a Float => PrimFun stage ((a,a) -> a) + PrimNormalize :: IsVecScalar d a Float => PrimFun stage (a -> a) + PrimFaceForward :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + PrimReflect :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a) + PrimRefract :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a) + + -- Matrix Functions + PrimTranspose :: (IsMat a h w, IsMat b w h) => PrimFun stage (a -> b) + PrimDeterminant :: IsMat m s s => PrimFun stage (m -> Float) + PrimInverse :: IsMat m h w => PrimFun stage (m -> m) + PrimOuterProduct :: IsMat m h w => PrimFun stage ((w,h) -> m) + PrimMulMatVec :: IsMat m h w => PrimFun stage ((m,w) -> h) + PrimMulVecMat :: IsMat m h w => PrimFun stage ((h,m) -> w) + PrimMulMatMat :: (IsMat a i j, IsMat b j k, IsMat c i k) => PrimFun stage ((a,b) -> c) + + -- Vector and Scalar Relational Functions + PrimLessThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimLessThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimGreaterThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimGreaterThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool) + PrimNotEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b) + PrimNotEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool) + + -- Fragment Processing Functions + PrimDFdx :: IsVecScalar d a Float => PrimFun F (a -> a) + PrimDFdy :: IsVecScalar d a Float => PrimFun F (a -> a) + PrimFWidth :: IsVecScalar d a Float => PrimFun F (a -> a) + + -- Noise Functions + PrimNoise1 :: IsVecScalar d a Float => PrimFun stage (a -> Float) + PrimNoise2 :: (IsVecScalar d a Float, IsVecScalar 2 b Float) => PrimFun stage (a -> b) + PrimNoise3 :: (IsVecScalar d a Float, IsVecScalar 3 b Float) => PrimFun stage (a -> b) + PrimNoise4 :: (IsVecScalar d a Float, IsVecScalar 4 b Float) => PrimFun stage (a -> b) + + -- Texture Lookup Functions + PrimTextureSize :: IsTextureSize sampler lod size => PrimFun stage ((sampler,lod) -> size) + PrimTexture :: IsTexture sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler) + PrimTextureB :: IsTexture sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler) + PrimTextureProj :: IsTextureProj sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler) + PrimTextureProjB :: IsTextureProj sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler) + PrimTextureLod :: IsTextureLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTextureOffset :: IsTextureOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler) + PrimTextureOffsetB :: IsTextureOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler) + PrimTexelFetch :: IsTexelFetch sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTexelFetchOffset :: IsTexelFetchOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureProjOffset :: IsTextureProjOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler) + PrimTextureProjOffsetB :: IsTextureProjOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler) + PrimTextureLodOffset :: IsTextureLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureProjLod :: IsTextureProjLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler) + PrimTextureProjLodOffset :: IsTextureProjLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler) + PrimTextureGrad :: IsTextureGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler) + PrimTextureGradOffset :: IsTextureGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler) + PrimTextureProjGrad :: IsTextureProjGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler) + PrimTextureProjGradOffset :: IsTextureProjGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler) + diff --git a/src/lib/LambdaCube/Language/ReifyType.hs b/src/lib/LambdaCube/Language/ReifyType.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language/ReifyType.hs @@ -0,0 +1,640 @@ +module LambdaCube.Language.ReifyType where + +import Data.Int +import Data.Word +import Data.Typeable + +import LambdaCube.Core.Type +import qualified LambdaCube.Core.Type as U + +data TextureShape + = Tex1D + | Tex2D + | Tex3D + | TexRect + +deriving instance Typeable Tex1D +deriving instance Typeable Tex2D +deriving instance Typeable Tex3D +deriving instance Typeable TexRect + +data Red = Red deriving (Typeable,Eq,Ord) +data RG = RG deriving (Typeable,Eq,Ord) +data RGB = RGB deriving (Typeable,Eq,Ord) +data RGBA = RGBA deriving (Typeable,Eq,Ord) + +data TextureSemantics a + = Regular a + | Shadow a + | MultiSample a + | Buffer a + +deriving instance Typeable Regular +deriving instance Typeable Shadow +deriving instance Typeable MultiSample +deriving instance Typeable Buffer + +data TextureArray + = SingleTex -- singleton texture + | ArrayTex -- array texture + | CubeTex -- cube texture = array with size 6 + +deriving instance Typeable SingleTex +deriving instance Typeable ArrayTex +deriving instance Typeable CubeTex + +--data Sampler dim layerCount t ar +data Sampler :: TextureShape -> TextureArray -> TextureSemantics * -> * -> * + +deriving instance Typeable Sampler + +-- IsScalar means here that the related type is not a tuple, but a GPU primitive type +class GPU a => IsScalar a where + toValue :: a -> Value + toType :: a -> InputType +{- +instance Nat sh => IsScalar (Sampler dim sh t ar) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = error "toType Sampler is not implemented yet" -- TODO +-} +-- Float +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture1D +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2D +instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture3D +instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTextureCube +instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture1DArray +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DArray +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DMS +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DMSArray +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTextureBuffer +instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.FTexture2DRect + +-- Int +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture1D +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2D +instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture3D +instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITextureCube +instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture1DArray +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DArray +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DMS +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DMSArray +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITextureBuffer +instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Int) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.ITexture2DRect + +-- Word +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture1D +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2D +instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture3D +instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTextureCube +instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture1DArray +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DArray +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DMS +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DMSArray +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTextureBuffer +instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Word) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.UTexture2DRect + +-- Shadow +instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture1D +instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2D +instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STextureCube +instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture1DArray +instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2DArray +instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Shadow Float) a) where + toValue v = error "toValue Sampler is not implemented yet" -- TODO + toType _ = U.STexture2DRect + +instance IsScalar Int32 where + toValue v = VInt v + toType _ = U.Int +instance IsScalar Word32 where + toValue v = VWord v + toType _ = U.Word +instance IsScalar Float where + toValue v = VFloat v + toType _ = U.Float +instance IsScalar Bool where + toValue v = VBool v + toType _ = U.Bool +instance IsScalar M22F where + toValue v = VM22F v + toType _ = U.M22F +instance IsScalar M23F where + toValue v = VM23F v + toType _ = U.M23F +instance IsScalar M24F where + toValue v = VM24F v + toType _ = U.M24F +instance IsScalar M32F where + toValue v = VM32F v + toType _ = U.M32F +instance IsScalar M33F where + toValue v = VM33F v + toType _ = U.M33F +instance IsScalar M34F where + toValue v = VM34F v + toType _ = U.M34F +instance IsScalar M42F where + toValue v = VM42F v + toType _ = U.M42F +instance IsScalar M43F where + toValue v = VM43F v + toType _ = U.M43F +instance IsScalar M44F where + toValue v = VM44F v + toType _ = U.M44F +instance IsScalar V2F where + toValue v = VV2F v + toType _ = U.V2F +instance IsScalar V3F where + toValue v = VV3F v + toType _ = U.V3F +instance IsScalar V4F where + toValue v = VV4F v + toType _ = U.V4F +instance IsScalar V2I where + toValue v = VV2I v + toType _ = U.V2I +instance IsScalar V3I where + toValue v = VV3I v + toType _ = U.V3I +instance IsScalar V4I where + toValue v = VV4I v + toType _ = U.V4I +instance IsScalar V2U where + toValue v = VV2U v + toType _ = U.V2U +instance IsScalar V3U where + toValue v = VV3U v + toType _ = U.V3U +instance IsScalar V4U where + toValue v = VV4U v + toType _ = U.V4U +instance IsScalar V2B where + toValue v = VV2B v + toType _ = U.V2B +instance IsScalar V3B where + toValue v = VV3B v + toType _ = U.V3B +instance IsScalar V4B where + toValue v = VV4B v + toType _ = U.V4B + +instance Show (Sampler dim layerCount t ar) where + show _ = "Sampler dim layerCount t ar" + +-- GPU type restriction, the functions are used in shader codegen +class (Show a, Typeable a) => GPU a where + tupleType :: a -> Ty + +-- Float +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Float) a) where + tupleType v = Single $ toType v + +-- Int +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Int) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Int) a) where + tupleType v = Single $ toType v + +-- Word +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Word) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Word) a) where + tupleType v = Single $ toType v + +-- Shadow +instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Shadow Float) a) where + tupleType v = Single $ toType v +instance (Typeable a) => GPU (Sampler TexRect SingleTex (Shadow Float) a) where + tupleType v = Single $ toType v + +instance GPU () where + tupleType v = Tuple [] +instance GPU Bool where + tupleType v = Single $ toType v +instance GPU Float where + tupleType v = Single $ toType v +instance GPU Int32 where + tupleType v = Single $ toType v +instance GPU Word32 where + tupleType v = Single $ toType v +instance GPU V2B where + tupleType v = Single $ toType v +instance GPU V2F where + tupleType v = Single $ toType v +instance GPU V2I where + tupleType v = Single $ toType v +instance GPU V2U where + tupleType v = Single $ toType v +instance GPU V3B where + tupleType v = Single $ toType v +instance GPU V3F where + tupleType v = Single $ toType v +instance GPU V3I where + tupleType v = Single $ toType v +instance GPU V3U where + tupleType v = Single $ toType v +instance GPU V4B where + tupleType v = Single $ toType v +instance GPU V4F where + tupleType v = Single $ toType v +instance GPU V4I where + tupleType v = Single $ toType v +instance GPU V4U where + tupleType v = Single $ toType v +instance GPU M22F where + tupleType v = Single $ toType v +instance GPU M23F where + tupleType v = Single $ toType v +instance GPU M24F where + tupleType v = Single $ toType v +instance GPU M32F where + tupleType v = Single $ toType v +instance GPU M33F where + tupleType v = Single $ toType v +instance GPU M34F where + tupleType v = Single $ toType v +instance GPU M42F where + tupleType v = Single $ toType v +instance GPU M43F where + tupleType v = Single $ toType v +instance GPU M44F where + tupleType v = Single $ toType v +instance (GPU a, GPU b) => GPU (a, b) where + tupleType (v :: (a,b)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + ] +instance (GPU a, GPU b, GPU c) => GPU (a, b, c) where + tupleType (v :: (a,b,c)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + ] +instance (GPU a, GPU b, GPU c, GPU d) => GPU (a, b, c, d) where + tupleType (v :: (a,b,c,d)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e) => GPU (a, b, c, d, e) where + tupleType (v :: (a,b,c,d,e)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) => GPU (a, b, c, d, e, f) where + tupleType (v :: (a,b,c,d,e,f)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) => GPU (a, b, c, d, e, f, g) where + tupleType (v :: (a,b,c,d,e,f,g)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) => GPU (a, b, c, d, e, f, g, h) where + tupleType (v :: (a,b,c,d,e,f,g,h)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + , tupleType (undefined :: h) + ] +instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) => GPU (a, b, c, d, e, f, g, h, i) where + tupleType (v :: (a,b,c,d,e,f,g,h,i)) = Tuple + [ tupleType (undefined :: a) + , tupleType (undefined :: b) + , tupleType (undefined :: c) + , tupleType (undefined :: d) + , tupleType (undefined :: e) + , tupleType (undefined :: f) + , tupleType (undefined :: g) + , tupleType (undefined :: h) + , tupleType (undefined :: i) + ] + +-- stream type restriction, these types can be used in vertex shader input +class GPU a => SGPU a +instance SGPU Int32 +instance SGPU Word32 +instance SGPU Float +instance SGPU M22F +instance SGPU M23F +instance SGPU M24F +instance SGPU M32F +instance SGPU M33F +instance SGPU M34F +instance SGPU M42F +instance SGPU M43F +instance SGPU M44F +instance SGPU V2F +instance SGPU V3F +instance SGPU V4F +instance SGPU V2I +instance SGPU V3I +instance SGPU V4I +instance SGPU V2U +instance SGPU V3U +instance SGPU V4U +instance (SGPU a, SGPU b) => SGPU (a, b) +instance (SGPU a, SGPU b, SGPU c) => SGPU (a, b, c) +instance (SGPU a, SGPU b, SGPU c, SGPU d) => SGPU (a, b, c, d) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e) => SGPU (a, b, c, d, e) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f) => SGPU (a, b, c, d, e, f) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g) => SGPU (a, b, c, d, e, f, g) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h) => SGPU (a, b, c, d, e, f, g, h) +instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h, SGPU i) => SGPU (a, b, c, d, e, f, g, h, i) + +-- uniform type restriction +-- hint: EltRepr stands for Elementary Type Representation +type family EltRepr a :: * +type instance EltRepr (Sampler dim sh t ar) = ((), Sampler dim sh t ar) +type instance EltRepr () = () +type instance EltRepr Int32 = ((), Int32) +type instance EltRepr Word32 = ((), Word32) +type instance EltRepr Float = ((), Float) +type instance EltRepr Bool = ((), Bool) +type instance EltRepr V2F = ((), V2F) +type instance EltRepr V2I = ((), V2I) +type instance EltRepr V2U = ((), V2U) +type instance EltRepr V2B = ((), V2B) +type instance EltRepr M22F = ((), M22F) +type instance EltRepr M23F = ((), M23F) +type instance EltRepr M24F = ((), M24F) +type instance EltRepr V3F = ((), V3F) +type instance EltRepr V3I = ((), V3I) +type instance EltRepr V3U = ((), V3U) +type instance EltRepr V3B = ((), V3B) +type instance EltRepr M32F = ((), M32F) +type instance EltRepr M33F = ((), M33F) +type instance EltRepr M34F = ((), M34F) +type instance EltRepr V4F = ((), V4F) +type instance EltRepr V4I = ((), V4I) +type instance EltRepr V4U = ((), V4U) +type instance EltRepr V4B = ((), V4B) +type instance EltRepr M42F = ((), M42F) +type instance EltRepr M43F = ((), M43F) +type instance EltRepr M44F = ((), M44F) +type instance EltRepr (a, b) = (EltRepr a, EltRepr' b) +type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c) +type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d) +type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e) +type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) +type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) +type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) +type instance EltRepr (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) + +type family EltRepr' a :: * +type instance EltRepr' (Sampler dim sh t ar) = Sampler dim sh t ar +type instance EltRepr' () = () +type instance EltRepr' Int32 = Int32 +type instance EltRepr' Word32 = Word32 +type instance EltRepr' Float = Float +type instance EltRepr' Bool = Bool +type instance EltRepr' V2F = V2F +type instance EltRepr' V2I = V2I +type instance EltRepr' V2U = V2U +type instance EltRepr' V2B = V2B +type instance EltRepr' M22F = M22F +type instance EltRepr' M23F = M23F +type instance EltRepr' M24F = M24F +type instance EltRepr' V3F = V3F +type instance EltRepr' V3I = V3I +type instance EltRepr' V3U = V3U +type instance EltRepr' V3B = V3B +type instance EltRepr' M32F = M32F +type instance EltRepr' M33F = M33F +type instance EltRepr' M34F = M34F +type instance EltRepr' V4F = V4F +type instance EltRepr' V4I = V4I +type instance EltRepr' V4U = V4U +type instance EltRepr' V4B = V4B +type instance EltRepr' M42F = M42F +type instance EltRepr' M43F = M43F +type instance EltRepr' M44F = M44F +type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b) +type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c) +type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d) +type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e) +type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f) +type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g) +type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h) +type instance EltRepr' (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i) + +-- |Conversion between surface n-tuples and our tuple representation. +-- +-- our language uses nested tuple representation +class IsTuple tup where + type TupleRepr tup + +instance IsTuple () where + type TupleRepr () = () + +instance IsTuple (a, b) where + type TupleRepr (a, b) = (((), a), b) + +instance IsTuple (a, b, c) where + type TupleRepr (a, b, c) = (TupleRepr (a, b), c) + +instance IsTuple (a, b, c, d) where + type TupleRepr (a, b, c, d) = (TupleRepr (a, b, c), d) + +instance IsTuple (a, b, c, d, e) where + type TupleRepr (a, b, c, d, e) = (TupleRepr (a, b, c, d), e) + +instance IsTuple (a, b, c, d, e, f) where + type TupleRepr (a, b, c, d, e, f) = (TupleRepr (a, b, c, d, e), f) + +instance IsTuple (a, b, c, d, e, f, g) where + type TupleRepr (a, b, c, d, e, f, g) = (TupleRepr (a, b, c, d, e, f), g) + +instance IsTuple (a, b, c, d, e, f, g, h) where + type TupleRepr (a, b, c, d, e, f, g, h) = (TupleRepr (a, b, c, d, e, f, g), h) + +instance IsTuple (a, b, c, d, e, f, g, h, i) where + type TupleRepr (a, b, c, d, e, f, g, h, i) = (TupleRepr (a, b, c, d, e, f, g, h), i) + +-- Tuple representation +-- -------------------- + +-- |We represent tuples as heterogenous lists, typed by a type list. +-- +data Tuple c t where + NilTup :: Tuple c () + SnocTup :: GPU t => Tuple c s -> c t -> Tuple c (s, t) + +-- |Type-safe projection indicies for tuples. +-- +-- NB: We index tuples by starting to count from the *right*! +-- +data TupleIdx t e where + ZeroTupIdx :: GPU s => TupleIdx (t, s) s + SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e + +-- Auxiliary tuple index constants +-- +tix0 :: GPU s => TupleIdx (t, s) s +tix0 = ZeroTupIdx +tix1 :: GPU s => TupleIdx ((t, s), s1) s +tix1 = SuccTupIdx tix0 +tix2 :: GPU s => TupleIdx (((t, s), s1), s2) s +tix2 = SuccTupIdx tix1 +tix3 :: GPU s => TupleIdx ((((t, s), s1), s2), s3) s +tix3 = SuccTupIdx tix2 +tix4 :: GPU s => TupleIdx (((((t, s), s1), s2), s3), s4) s +tix4 = SuccTupIdx tix3 +tix5 :: GPU s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s +tix5 = SuccTupIdx tix4 +tix6 :: GPU s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s +tix6 = SuccTupIdx tix5 +tix7 :: GPU s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s +tix7 = SuccTupIdx tix6 +tix8 :: GPU s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s +tix8 = SuccTupIdx tix7 + +deriving instance Typeable (,,,,,,,) +deriving instance Typeable (,,,,,,,,) diff --git a/src/lib/LambdaCube/Language/Sampler.hs b/src/lib/LambdaCube/Language/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language/Sampler.hs @@ -0,0 +1,263 @@ +module LambdaCube.Language.Sampler where + +import Data.Int + +import LambdaCube.Core.Type +import LambdaCube.Language.ReifyType + +{- +-- shadow samplers +type Sampler1DShadow = Sampler DIM1 Z Depth Mip Shadow +type Sampler2DShadow = Sampler DIM2 Z Depth Mip Shadow +type SamplerCubeShadow = Sampler DIM2 C Depth Mip Array Shadow +type Sampler1DArrayShadow = Sampler DIM1 A Depth Mip Array Shadow +type Sampler2DArrayShadow = Sampler DIM2 A Depth Mip Array Shadow +type Sampler2DRectShadow = Sampler Rect Z Depth NoMip Shadow + +-- float,int,word samplers +type Sampler1D = Sampler DIM1 Z Float Mip Regular +type Sampler2D = Sampler DIM2 Z Float Mip Regular +type Sampler3D = Sampler DIM3 Z Float Mip Regular +type SamplerCube = Sampler DIM2 C Float Mip Regular Array +type Sampler1DArray = Sampler DIM1 A Float Mip Regular Array +type Sampler2DArray = Sampler DIM2 A Float Mip Regular Array +type Sampler2DRect = Sampler Rect Z Float NoMip Regular + +type Sampler2DMS = Sampler DIM2 Z FloatMS NoMip -- from previous render pass only +type Sampler2DMSArray = Sampler DIM2 A FloatMS NoMip Array -- from previous render pass only +type SamplerBuffer = Sampler DIM1 Z BufferFloat NoMip +-} + +type GSampler1D t ar = Sampler Tex1D SingleTex t ar +type GSampler2D t ar = Sampler Tex2D SingleTex t ar +type GSampler3D t ar = Sampler Tex3D SingleTex t ar +type GSamplerCube t ar = Sampler Tex2D CubeTex t ar +type GSampler1DArray t ar = Sampler Tex1D ArrayTex t ar +type GSampler2DArray t ar = Sampler Tex2D ArrayTex t ar +type GSampler2DRect t ar = Sampler TexRect SingleTex t ar + +type family TexelRepr sampler +type instance TexelRepr (Sampler dim arr (v t) Red) = t +type instance TexelRepr (Sampler dim arr (v t) RG) = V2 t +type instance TexelRepr (Sampler dim arr (v t) RGB) = V3 t +type instance TexelRepr (Sampler dim arr (v t) RGBA) = V4 t + +-- shadow samplers +type Sampler1DShadow = GSampler1D (Shadow Float) Red +type Sampler2DShadow = GSampler2D (Shadow Float) Red +type SamplerCubeShadow = GSamplerCube (Shadow Float) Red +type Sampler1DArrayShadow = GSampler1DArray (Shadow Float) Red +type Sampler2DArrayShadow = GSampler2DArray (Shadow Float) Red +type Sampler2DRectShadow = GSampler2DRect (Shadow Float) Red + +-- float samplers +type Sampler1D t ar = GSampler1D (Regular t) ar +type Sampler2D t ar = GSampler2D (Regular t) ar +type Sampler3D t ar = GSampler3D (Regular t) ar +type SamplerCube t ar = GSamplerCube (Regular t) ar +type Sampler1DArray t ar = GSampler1DArray (Regular t) ar +type Sampler2DArray t ar = GSampler2DArray (Regular t) ar +type Sampler2DRect t ar = GSampler2DRect (Regular t) ar +type Sampler2DMS t ar = GSampler2D (MultiSample t) ar +type Sampler2DMSArray t ar = GSampler2DArray (MultiSample t) ar +type SamplerBuffer t ar = GSampler1D (Buffer t) ar + +-- brute force +-- arity problem: lod +-- restriction: NONE +class IsTextureSize sampler lod size | sampler -> lod size +instance IsTextureSize (Sampler1D t ar) Int32 Int32 +instance IsTextureSize (Sampler1DArray t ar) Int32 V2I +instance IsTextureSize (Sampler2D t ar) Int32 V2I +instance IsTextureSize (Sampler2DArray t ar) Int32 V3I +instance IsTextureSize (Sampler2DMS t ar) () V2I +instance IsTextureSize (Sampler2DMSArray t ar) () V3I +instance IsTextureSize (Sampler2DRect t ar) () V2I +instance IsTextureSize (Sampler3D t ar) Int32 V3I +instance IsTextureSize (SamplerCube t ar) Int32 V2I +instance IsTextureSize (SamplerBuffer t ar) () Int32 +instance IsTextureSize Sampler1DArrayShadow Int32 V2I +instance IsTextureSize Sampler1DShadow Int32 Int32 +instance IsTextureSize Sampler2DArrayShadow Int32 V3I +instance IsTextureSize Sampler2DRectShadow () V2I +instance IsTextureSize Sampler2DShadow Int32 V2I +instance IsTextureSize SamplerCubeShadow Int32 V2I + +-- arity problem: bias +-- restriction: Regular union Shadow +class IsTexture sampler coord bias | sampler -> coord bias +instance IsTexture (Sampler1D t ar) Float Float +instance IsTexture (Sampler1DArray t ar) V2F Float +instance IsTexture (Sampler2D t ar) V2F Float +instance IsTexture (Sampler2DArray t ar) V3F Float +instance IsTexture (Sampler2DRect t ar) V2F () +instance IsTexture (Sampler3D t ar) V3F Float +instance IsTexture (SamplerCube t ar) V3F Float +instance IsTexture Sampler1DShadow V3F Float +instance IsTexture Sampler1DArrayShadow V3F Float +instance IsTexture Sampler2DShadow V3F Float +instance IsTexture Sampler2DArrayShadow V4F () +instance IsTexture Sampler2DRectShadow V3F () +instance IsTexture SamplerCubeShadow V4F Float + +-- arity problem: bias +-- restriction: (Regular union Shadow) exclude Array +class IsTextureProj sampler coord bias | sampler coord -> bias +instance IsTextureProj (Sampler1D t ar) V2F Float +instance IsTextureProj (Sampler1D t ar) V4F Float +instance IsTextureProj (Sampler2D t ar) V3F Float +instance IsTextureProj (Sampler2D t ar) V4F Float +instance IsTextureProj (Sampler2DRect t ar) V3F () +instance IsTextureProj (Sampler2DRect t ar) V4F () +instance IsTextureProj (Sampler3D t ar) V4F Float +instance IsTextureProj Sampler1DShadow V4F Float +instance IsTextureProj Sampler2DRectShadow V4F () +instance IsTextureProj Sampler2DShadow V4F Float + +-- arity ok +-- restriction: ((Regular union Shadow) intersection Mip) exclude (2D Shadow Array) +class IsTextureLod sampler coord lod | sampler -> coord lod +instance IsTextureLod (Sampler1D t ar) Float Float +instance IsTextureLod (Sampler1DArray t ar) V2F Float +instance IsTextureLod (Sampler2D t ar) V2F Float +instance IsTextureLod (Sampler2DArray t ar) V3F Float +instance IsTextureLod (Sampler3D t ar) V3F Float +instance IsTextureLod (SamplerCube t ar) V3F Float +instance IsTextureLod Sampler1DShadow V3F Float +instance IsTextureLod Sampler1DArrayShadow V3F Float +instance IsTextureLod Sampler2DShadow V3F Float + +-- arity problem: bias +-- restriction: (Regular union Shadow) excluding (Cube, 2D Shadow Array) +class IsTextureOffset sampler coord offset bias | sampler -> coord offset bias +instance IsTextureOffset (Sampler1D t ar) Float Int32 Float +instance IsTextureOffset (Sampler1DArray t ar) V2F Int32 Float +instance IsTextureOffset (Sampler2D t ar) V2F V2I Float +instance IsTextureOffset (Sampler2DArray t ar) V3F V2I Float +instance IsTextureOffset (Sampler2DRect t ar) V2F V2I () +instance IsTextureOffset (Sampler3D t ar) V3F V3I Float +instance IsTextureOffset Sampler1DShadow V3F Int32 Float +instance IsTextureOffset Sampler1DArrayShadow V3F Int32 Float +instance IsTextureOffset Sampler2DShadow V3F V2I Float +instance IsTextureOffset Sampler2DRectShadow V3F V2I () + +-- arity problem: lod, sample +class IsTexelFetch sampler coord lod | sampler -> coord lod +instance IsTexelFetch (Sampler1D t ar) Int32 Int32 +instance IsTexelFetch (Sampler1DArray t ar) V2I Int32 +instance IsTexelFetch (Sampler2D t ar) V2I Int32 +instance IsTexelFetch (Sampler2DArray t ar) V3I Int32 +instance IsTexelFetch (Sampler2DMS t ar) V2I Int32 +instance IsTexelFetch (Sampler2DMSArray t ar) V3I Int32 +instance IsTexelFetch (Sampler2DRect t ar) V2I () +instance IsTexelFetch (Sampler3D t ar) V3I Int32 +instance IsTexelFetch (SamplerBuffer t ar) Int32 () + +-- arity problem: lod +class IsTexelFetchOffset sampler coord lod offset | sampler -> coord lod offset +instance IsTexelFetchOffset (Sampler1D t ar) Int32 Int32 Int32 +instance IsTexelFetchOffset (Sampler1DArray t ar) V2I Int32 Int32 +instance IsTexelFetchOffset (Sampler2D t ar) V2I Int32 V2I +instance IsTexelFetchOffset (Sampler2DArray t ar) V3I Int32 V2I +instance IsTexelFetchOffset (Sampler2DRect t ar) V2I () V2I +instance IsTexelFetchOffset (Sampler3D t ar) V3I Int32 V3I + +-- arity problem: bias +class IsTextureProjOffset sampler coord offset bias | sampler coord -> offset bias +instance IsTextureProjOffset (Sampler1D t ar) V2F Int32 Float +instance IsTextureProjOffset (Sampler1D t ar) V4F Int32 Float +instance IsTextureProjOffset (Sampler2D t ar) V3F V2I Float +instance IsTextureProjOffset (Sampler2D t ar) V4F V2I Float +instance IsTextureProjOffset (Sampler3D t ar) V4F V3I Float +instance IsTextureProjOffset (Sampler2DRect t ar) V3F V2I () +instance IsTextureProjOffset (Sampler2DRect t ar) V4F V2I () +instance IsTextureProjOffset Sampler1DShadow V4F Int32 Float +instance IsTextureProjOffset Sampler2DShadow V4F V2I Float +instance IsTextureProjOffset Sampler2DRectShadow V4F V2I Float + +-- arity ok +class IsTextureLodOffset sampler coord lod offset | sampler -> coord lod offset +instance IsTextureLodOffset (Sampler1D t ar) Float Float Int32 +instance IsTextureLodOffset (Sampler1DArray t ar) V2F Float Int32 +instance IsTextureLodOffset (Sampler2D t ar) V2F Float V2I +instance IsTextureLodOffset (Sampler2DArray t ar) V3F Float V2I +instance IsTextureLodOffset (Sampler3D t ar) V3F Float V3I +instance IsTextureLodOffset Sampler1DShadow V3F Float Int32 +instance IsTextureLodOffset Sampler1DArrayShadow V3F Float Int32 +instance IsTextureLodOffset Sampler2DShadow V3F Float V2I + +-- arity ok +class IsTextureProjLod sampler coord lod | sampler coord -> lod +instance IsTextureProjLod (Sampler1D t ar) V2F Float +instance IsTextureProjLod (Sampler1D t ar) V4F Float +instance IsTextureProjLod (Sampler2D t ar) V3F Float +instance IsTextureProjLod (Sampler2D t ar) V4F Float +instance IsTextureProjLod (Sampler3D t ar) V4F Float +instance IsTextureProjLod Sampler1DShadow V4F Float +instance IsTextureProjLod Sampler2DShadow V4F Float + +-- arity ok +class IsTextureProjLodOffset sampler coord lod offset | sampler coord -> lod offset +instance IsTextureProjLodOffset (Sampler1D t ar) V2F Float Int32 +instance IsTextureProjLodOffset (Sampler1D t ar) V4F Float Int32 +instance IsTextureProjLodOffset (Sampler2D t ar) V3F Float V2I +instance IsTextureProjLodOffset (Sampler2D t ar) V4F Float V2I +instance IsTextureProjLodOffset (Sampler3D t ar) V4F Float V3I +instance IsTextureProjLodOffset Sampler1DShadow V4F Float Int32 +instance IsTextureProjLodOffset Sampler2DShadow V4F Float V2F + +-- arity ok +class IsTextureGrad sampler coord dx dy | sampler -> coord dx dy +instance IsTextureGrad (Sampler1D t ar) Float Float Float +instance IsTextureGrad (Sampler1DArray t ar) V2F Float Float +instance IsTextureGrad (Sampler2D t ar) V2F V2F V2F +instance IsTextureGrad (Sampler2DArray t ar) V3F V2F V2F +instance IsTextureGrad (Sampler2DRect t ar) V2F V2F V2F +instance IsTextureGrad (Sampler3D t ar) V3F V3F V3F +instance IsTextureGrad (SamplerCube t ar) V3F V3F V3F +instance IsTextureGrad Sampler1DArrayShadow V3F Float Float +instance IsTextureGrad Sampler1DShadow V3F Float Float +instance IsTextureGrad Sampler2DArrayShadow V4F V2F V2F +instance IsTextureGrad Sampler2DRectShadow V3F V2F V2F +instance IsTextureGrad Sampler2DShadow V3F V2F V2F +instance IsTextureGrad SamplerCubeShadow V4F V3F V3F + +-- arity ok +class IsTextureGradOffset sampler coord dx dy offset | sampler -> coord dx dy offset +instance IsTextureGradOffset (Sampler1D t ar) Float Float Float Int32 +instance IsTextureGradOffset (Sampler1DArray t ar) V2F Float Float Int32 +instance IsTextureGradOffset (Sampler2D t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DArray t ar) V3F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DRect t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler3D t ar) V3F V3F V3F V3I +instance IsTextureGradOffset Sampler1DArrayShadow V3F Float Float Int32 +instance IsTextureGradOffset Sampler1DShadow V3F Float Float Int32 +instance IsTextureGradOffset Sampler2DArrayShadow V4F V2F V2F V2I +instance IsTextureGradOffset Sampler2DRectShadow V3F V2F V2F V2I +instance IsTextureGradOffset Sampler2DShadow V3F V2F V2F V2I + +-- arity ok +class IsTextureProjGrad sampler coord dx dy | sampler coord -> dx dy +instance IsTextureProjGrad (Sampler1D t ar) V2F Float Float +instance IsTextureProjGrad (Sampler1D t ar) V4F Float Float +instance IsTextureProjGrad (Sampler2D t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2D t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler3D t ar) V4F V3F V3F +instance IsTextureProjGrad Sampler1DShadow V4F Float Float +instance IsTextureProjGrad Sampler2DRectShadow V4F V2F V2F +instance IsTextureProjGrad Sampler2DShadow V4F V2F V2F + +-- arity ok +class IsTextureProjGradOffset sampler coord dx dy offset | sampler coord -> dx dy offset +instance IsTextureProjGradOffset (Sampler1D t ar) V2F Float Float Int32 +instance IsTextureProjGradOffset (Sampler1D t ar) V4F Float Float Int32 +instance IsTextureProjGradOffset (Sampler2D t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2D t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler3D t ar) V4F V3F V3F V3I +instance IsTextureProjGradOffset Sampler1DShadow V4F Float Float Int32 +instance IsTextureProjGradOffset Sampler2DRectShadow V4F V2F V2F V2I +instance IsTextureProjGradOffset Sampler2DShadow V4F V2F V2F V2I diff --git a/src/lib/LambdaCube/Language/Type.hs b/src/lib/LambdaCube/Language/Type.hs new file mode 100644 --- /dev/null +++ b/src/lib/LambdaCube/Language/Type.hs @@ -0,0 +1,687 @@ +module LambdaCube.Language.Type where + +import GHC.TypeLits + +import Data.ByteString.Char8 +import Data.Int +import Data.Word +import Data.Typeable + +import qualified LambdaCube.Core.Type as U +import LambdaCube.Core.Type hiding (FetchPrimitive, OutputPrimitive, Blending, RasterContext, Blend, TriangleCtx, Image, FragmentOperation, MipMap, TextureDataType, TextureType) +import LambdaCube.Language.ReifyType hiding (Shadow) +import qualified LambdaCube.Language.ReifyType as T + +data NatNum :: Nat -> * where + N0 :: NatNum 0 + N1 :: NatNum 1 + N2 :: NatNum 2 + N3 :: NatNum 3 + N4 :: NatNum 4 + N5 :: NatNum 5 + N6 :: NatNum 6 + N7 :: NatNum 7 + N8 :: NatNum 8 + N9 :: NatNum 9 + +deriving instance Typeable NatNum + +n0 = N0 +n1 = N1 +n2 = N2 +n3 = N3 +n4 = N4 +n5 = N5 +n6 = N6 +n7 = N7 +n8 = N8 +n9 = N9 + +-- user can define stream input using InputTuple type class +class InputTuple tup where + type InputTupleRepr tup + toInputList :: tup -> [(ByteString,InputType)] + +instance InputTuple (Input a) where + type InputTupleRepr (Input a) = a + toInputList a = [toInput a] + +instance InputTuple (Input a, Input b) where + type InputTupleRepr (Input a, Input b) = (a, b) + toInputList (a, b) = [toInput a, toInput b] + +instance InputTuple (Input a, Input b, Input c) where + type InputTupleRepr (Input a, Input b, Input c) = (a, b, c) + toInputList (a, b, c) = [toInput a, toInput b, toInput c] + +instance InputTuple (Input a, Input b, Input c, Input d) where + type InputTupleRepr (Input a, Input b, Input c, Input d) = (a, b, c, d) + toInputList (a, b, c, d) = [toInput a, toInput b, toInput c, toInput d] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e) = (a, b, c, d, e) + toInputList (a, b, c, d, e) = [toInput a, toInput b, toInput c, toInput d, toInput e] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f) = (a, b, c, d, e, f) + toInputList (a, b, c, d, e, f) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g) = (a, b, c, d, e, f, g) + toInputList (a, b, c, d, e, f, g) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) = (a, b, c, d, e, f, g, h) + toInputList (a, b, c, d, e, f, g, h) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h] + +instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) where + type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) = (a, b, c, d, e, f, g, h, i) + toInputList (a, b, c, d, e, f, g, h, i) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h, toInput i] + +-- we should define all of input types +-- supported stream input types (the ByteString argument is the input slot name) +data Input a where + IBool :: ByteString -> Input Bool + IV2B :: ByteString -> Input V2B + IV3B :: ByteString -> Input V3B + IV4B :: ByteString -> Input V4B + IWord :: ByteString -> Input Word32 + IV2U :: ByteString -> Input V2U + IV3U :: ByteString -> Input V3U + IV4U :: ByteString -> Input V4U + IInt :: ByteString -> Input Int32 + IV2I :: ByteString -> Input V2I + IV3I :: ByteString -> Input V3I + IV4I :: ByteString -> Input V4I + IFloat :: ByteString -> Input Float + IV2F :: ByteString -> Input V2F + IV3F :: ByteString -> Input V3F + IV4F :: ByteString -> Input V4F + IM22F :: ByteString -> Input M22F + IM23F :: ByteString -> Input M23F + IM24F :: ByteString -> Input M24F + IM32F :: ByteString -> Input M32F + IM33F :: ByteString -> Input M33F + IM34F :: ByteString -> Input M34F + IM42F :: ByteString -> Input M42F + IM43F :: ByteString -> Input M43F + IM44F :: ByteString -> Input M44F + +toInput :: Input a -> (ByteString,InputType) +toInput (IBool n) = (n, U.Bool) +toInput (IV2B n) = (n, U.V2B) +toInput (IV3B n) = (n, U.V3B) +toInput (IV4B n) = (n, U.V4B) +toInput (IWord n) = (n, U.Word) +toInput (IV2U n) = (n, U.V2U) +toInput (IV3U n) = (n, U.V3U) +toInput (IV4U n) = (n, U.V4U) +toInput (IInt n) = (n, U.Int) +toInput (IV2I n) = (n, U.V2I) +toInput (IV3I n) = (n, U.V3I) +toInput (IV4I n) = (n, U.V4I) +toInput (IFloat n) = (n, U.Float) +toInput (IV2F n) = (n, U.V2F) +toInput (IV3F n) = (n, U.V3F) +toInput (IV4F n) = (n, U.V4F) +toInput (IM22F n) = (n, U.M22F) +toInput (IM23F n) = (n, U.M23F) +toInput (IM24F n) = (n, U.M24F) +toInput (IM32F n) = (n, U.M32F) +toInput (IM33F n) = (n, U.M33F) +toInput (IM34F n) = (n, U.M34F) +toInput (IM42F n) = (n, U.M42F) +toInput (IM43F n) = (n, U.M43F) +toInput (IM44F n) = (n, U.M44F) + +-- primitive types +data PrimitiveType + = Triangle + | Line + | Point + | TriangleAdjacency + | LineAdjacency + +data FetchPrimitive :: PrimitiveType -> * where + Points :: FetchPrimitive Point + Lines :: FetchPrimitive Line + Triangles :: FetchPrimitive Triangle + LinesAdjacency :: FetchPrimitive LineAdjacency + TrianglesAdjacency :: FetchPrimitive TriangleAdjacency + +data OutputPrimitive :: PrimitiveType -> * where + TrianglesOutput :: OutputPrimitive Triangle + LinesOutput :: OutputPrimitive Line + PointsOutput :: OutputPrimitive Point + +data Blending c where + NoBlending :: Blending c + + BlendLogicOp :: IsIntegral c + => LogicOperation + -> Blending c + + -- FIXME: restrict BlendingFactor at some BlendEquation + Blend :: (BlendEquation, BlendEquation) + -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) + -> V4F + -> Blending Float + +blend = Blend (FuncAdd,FuncAdd) ((SrcAlpha,OneMinusSrcAlpha),(SrcAlpha,OneMinusSrcAlpha)) (V4 1 1 1 1) + +-- abstract types, used in language AST +data VertexStream (primitive :: PrimitiveType) t +data PrimitiveStream (primitive :: PrimitiveType) clipDistances (layerCount :: Nat) (freq :: Frequency) t +data FragmentStream (layerCount :: Nat) t + + +-- flat tuple, another internal tuple representation + +-- means unit +data ZZ = ZZ deriving (Show,Typeable) + +-- used for tuple type description +infixr 1 :+: +data tail :+: head = !tail :+: !head deriving (Show,Typeable) + +-- used for tuple value description +infixr 1 :. +data FlatTuple c a t where + ZT :: FlatTuple c a ZZ + + (:.) :: c t + => a t + -> FlatTuple c a t' + -> FlatTuple c a (t :+: t') + +class IsFloatTuple a +instance IsFloatTuple ZZ +instance IsFloatTuple l => IsFloatTuple (Float :+: l) + +-- vertex attribute interpolation +data Interpolated e a where + Flat :: e a -> Interpolated e a + + Smooth :: IsFloating a + => e a -> Interpolated e a + + NoPerspective :: IsFloating a + => e a -> Interpolated e a + +-- framebuffer data / fragment output semantic +data Color a +data Depth a +data Stencil a + +-- describe geometry shader input +type family PrimitiveVertices (primitive :: PrimitiveType) a +type instance PrimitiveVertices Point a = a +type instance PrimitiveVertices Line a = (a,a) +type instance PrimitiveVertices LineAdjacency a = (a,a,a,a) +type instance PrimitiveVertices Triangle a = (a,a,a) +type instance PrimitiveVertices TriangleAdjacency a = (a,a,a,a,a,a) + +-- raster context description +data RasterContext t where + PointCtx :: + { ctxPointSize :: PointSize + , ctxFadeThresholdSize :: Float + , ctxSpriteCoordOrigin :: PointSpriteCoordOrigin + } -> RasterContext Point + + LineCtx :: + { ctxLineWidth :: Float + , ctxProvokingVertex' :: ProvokingVertex + } -> RasterContext Line + + TriangleCtx :: + { ctxCullMode :: CullMode + , ctxPolygonMode :: PolygonMode + , ctxPolygonOffset :: PolygonOffset + , ctxProvokingVertex :: ProvokingVertex + } -> RasterContext Triangle + +-- default triangle raster context +triangleCtx :: RasterContext Triangle +triangleCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex + +class NoConstraint a +instance NoConstraint a + +type FrameBuffer layerCount t = FlatTuple NoConstraint (Image layerCount) t + +-- Fragment Operation +data FragmentOperation ty where + DepthOp :: DepthFunction + -> Bool -- depth write + -> FragmentOperation (Depth Float) + + StencilOp :: StencilTests + -> StencilOps + -> StencilOps + -> FragmentOperation (Stencil Int32) + + ColorOp :: (IsVecScalar d mask Bool, IsVecScalar d color c, IsNum c, IsScalar mask) + => Blending c -- blending type + -> mask -- write mask + -> FragmentOperation (Color color) + +-- specifies an empty image (pixel rectangle) +-- hint: framebuffer is composed from images +data Image (layerCount :: Nat) t where + DepthImage :: KnownNat layerCount + => NatNum layerCount + -> Float -- initial value + -> Image layerCount (Depth Float) + + StencilImage :: KnownNat layerCount + => NatNum layerCount + -> Int32 -- initial value + -> Image layerCount (Stencil Int32) + + ColorImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount) + => NatNum layerCount + -> color -- initial value + -> Image layerCount (Color color) + + UnclearedImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount) + => NatNum layerCount + -> Image layerCount (Color color) + + + +-- restriction for framebuffer structure according content semantic +-- supported configurations: optional stencil + optional depth + [zero or more color] +class IsColorOutput a +instance IsColorOutput ZZ +instance (IsColorOutput b) => IsColorOutput (Color c :+: b) + +class IsValidOutput a +instance (IsColorOutput a) => IsValidOutput (Color c :+: a) +instance (IsColorOutput a) => IsValidOutput (Depth d :+: a) +instance (IsColorOutput a) => IsValidOutput (Stencil s :+: a) +instance (IsColorOutput a) => IsValidOutput (Stencil s :+: Depth d :+: a) + +-- helper class (type level function), used in language AST +-- converts FlatTuple type to ordinary tuple type +type family FTRepr a :: * +type instance FTRepr ZZ = () +type instance FTRepr (a :+: ZZ) = a +type instance FTRepr (a :+: b :+: ZZ) = (a, b) +type instance FTRepr (a :+: b :+: c :+: ZZ) = (a, b, c) +type instance FTRepr (a :+: b :+: c :+: d :+: ZZ) = (a, b, c, d) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: ZZ) = (a, b, c, d, e) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: ZZ) = (a, b, c, d, e, f) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: ZZ) = (a, b, c, d, e, f, g) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: ZZ) = (a, b, c, d, e, f, g, h) +type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: i :+: ZZ) = (a, b, c, d, e, f, g, h, i) + +-- helper type level function, used in language AST +type family FTRepr' a :: * +type instance FTRepr' (i1 a :+: ZZ) = a +type instance FTRepr' (i1 a :+: i2 b :+: ZZ) = (a, b) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: ZZ) = (a, b, c) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: ZZ) = (a, b, c, d) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: ZZ) = (a, b, c, d, e) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: ZZ) = (a, b, c, d, e, f) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: ZZ) = (a, b, c, d, e, f, g) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: ZZ) = (a, b, c, d, e, f, g, h) +type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: i9 i :+: ZZ) = (a, b, c, d, e, f, g, h ,i) + +-- helper type level function, used in language AST +type family ColorRepr a :: * +type instance ColorRepr ZZ = ZZ +type instance ColorRepr (a :+: b) = Color a :+: (ColorRepr b) + +-- helper type level function, used in language AST +type family NoStencilRepr a :: * +type instance NoStencilRepr ZZ = ZZ +type instance NoStencilRepr (Stencil a :+: b) = NoStencilRepr b +type instance NoStencilRepr (Color a :+: b) = Color a :+: (NoStencilRepr b) +type instance NoStencilRepr (Depth a :+: b) = Depth a :+: (NoStencilRepr b) + +-- sampler and texture specification +data TextureMipMap + = TexMip + | TexNoMip + +deriving instance Typeable TexMip +deriving instance Typeable TexNoMip + +deriving instance Typeable MipMap + + +data MipMap (t :: TextureMipMap) where + NoMip :: MipMap TexNoMip + + Mip :: Int -- base level + -> Int -- max level + -> MipMap TexMip + + AutoMip :: Int -- base level + -> Int -- max level + -> MipMap TexMip + +-- helper type level function, used in language AST +type family TexDataRepr arity (t :: TextureSemantics *) +type instance TexDataRepr Red (v a) = a +type instance TexDataRepr RG (v a) = V2 a +type instance TexDataRepr RGB (v a) = V3 a +type instance TexDataRepr RGBA (v a) = V4 a + +-- describes texel (texture component) type +data TextureDataType (kind :: TextureSemantics *) arity where + Float :: IsColorArity a + => a + -> TextureDataType (Regular Float) a + + Int :: IsColorArity a + => a + -> TextureDataType (Regular Int) a + + Word :: IsColorArity a + => a + -> TextureDataType (Regular Word) a + + Shadow :: TextureDataType (T.Shadow Float) Red -- TODO: add params required by shadow textures + + +-- helper type level function for texture specification +-- tells whether a texture is a single or an array texture +type family TexArrRepr (a :: Nat) :: TextureArray +{- +type instance TexArrRepr 1 = SingleTex +type instance TexArrRepr ((2 <= t) => t) = ArrayTex +-} +-- FIXME: implement properly +type instance TexArrRepr 1 = SingleTex +type instance TexArrRepr 2 = ArrayTex +type instance TexArrRepr 3 = ArrayTex +type instance TexArrRepr 4 = ArrayTex +type instance TexArrRepr 5 = ArrayTex +type instance TexArrRepr 6 = ArrayTex +type instance TexArrRepr 7 = ArrayTex +type instance TexArrRepr 8 = ArrayTex +type instance TexArrRepr 9 = ArrayTex + +-- supported texture component arities +class IsColorArity a where + toColorArity :: a -> U.ColorArity + +instance IsColorArity Red where + toColorArity _ = U.Red +instance IsColorArity RG where + toColorArity _ = U.RG +instance IsColorArity RGB where + toColorArity _ = U.RGB +instance IsColorArity RGBA where + toColorArity _ = U.RGBA + +-- component arity specification (Red,RG,RGB,RGBA) +-- hint: there is an interference with Shadow component format +-- alternatives: +-- A: move Shadow from TextureDataType to TextureType, this will introduce some new TextureType constructors (1D,2D,Cube,Rect) +-- B: restrict ColorArity for Shadow +-- C: add color arity definition to TextureDataType, this will solve the problem (best solution) + +-- fully describes a texture type +data TextureType :: TextureShape -> TextureMipMap -> TextureArray -> Nat -> TextureSemantics * -> * -> * where -- hint: arr - single or array texture, ar - arity (Red,RG,RGB,..) + Texture1D :: KnownNat layerCount + => TextureDataType t ar + -> NatNum layerCount + -> TextureType Tex1D TexMip (TexArrRepr layerCount) layerCount t ar + + Texture2D :: KnownNat layerCount + => TextureDataType t ar + -> NatNum layerCount + -> TextureType Tex2D TexMip (TexArrRepr layerCount) layerCount t ar + + Texture3D :: TextureDataType (Regular t) ar + -> TextureType Tex3D TexMip SingleTex 1 (Regular t) ar + + TextureCube :: TextureDataType t ar + -> TextureType Tex2D TexMip CubeTex 6 t ar + + TextureRect :: TextureDataType t ar + -> TextureType TexRect TexNoMip SingleTex 1 t ar + + Texture2DMS :: KnownNat layerCount + => TextureDataType (Regular t) ar + -> NatNum layerCount + -> TextureType Tex2D TexNoMip (TexArrRepr layerCount) layerCount (MultiSample t) ar + + TextureBuffer :: TextureDataType (Regular t) ar + -> TextureType Tex1D TexNoMip SingleTex 1 (Buffer t) ar + + +-- defines a texture +data Texture (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar +{- +data Texture (gp :: * -> *) (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar where + TextureSlot :: (IsValidTextureSlot t) + => ByteString -- texture slot name + -> TextureType dim mip arr layerCount t ar + -> Texture gp dim arr t ar + -- TODO: + -- add texture internal format specification + Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip, Typeable (TexDataRepr ar t), Typeable (TextureType dim canMip arr layerCount t ar), Typeable (Image layerCount (TexDataRepr ar t))) + => TextureType dim canMip arr layerCount t ar + -> TexSizeRepr dim + -> MipMap mip +-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type + -> [gp (Image layerCount (TexDataRepr ar t))] + -> Texture gp dim arr t ar +-} +{- + -- TODO: + -- swizzling (arity conversion) + -- integral -> floating casting (floating -> integral casting if possible) + ConvertTexture :: Texture gp dim arr t ar + -> Texture gp dim arr t' ar' +-} + +-- MipMap validation +class IsMipValid (canMip :: TextureMipMap) (mip :: TextureMipMap) +instance IsMipValid TexMip TexMip +instance IsMipValid TexMip TexNoMip +instance IsMipValid TexNoMip TexNoMip + +-- restriction for texture types what can be specified as texture slots, e.g. multisample textures cannot be created im this way +class IsValidTextureSlot (a :: TextureSemantics *) +instance IsValidTextureSlot (Regular a) +instance IsValidTextureSlot (T.Shadow a) +instance IsValidTextureSlot (Buffer a) + +-- type level hepler function, used for texture specification +type family TexSizeRepr (a :: TextureShape) +type instance TexSizeRepr (Tex1D) = Word32 +type instance TexSizeRepr (Tex2D) = V2U +type instance TexSizeRepr (TexRect) = V2U +type instance TexSizeRepr (Tex3D) = V3U +{- +-- type level hepler function, used for texture specification +type family TexRepr dim mip (gp :: * -> *) layerCount t :: * +type instance TexRepr DIM1 NoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM1 AutoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM1 Mip gp layerCount t = [gp (Image layerCount t)] + +type instance TexRepr DIM2 NoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM2 AutoMip gp layerCount t = gp (Image layerCount t) +type instance TexRepr DIM2 Mip gp layerCount t = [gp (Image layerCount t)] + +type instance TexRepr DIM3 NoMip gp layerCount t = [gp (Image layerCount t)] +type instance TexRepr DIM3 AutoMip gp layerCount t = [gp (Image layerCount t)] +type instance TexRepr DIM3 Mip gp layerCount t = [[gp (Image layerCount t)]] -- 3D layers contain mipmap +-} + +-- shader stage tags: vertex, geometry, fragment +-- used in language AST, for primfun restriction and in shader codegen +data Frequency + = Obj + | V + | G + | F + +data OutputType + = SingleOutput + | MultiOutput + +deriving instance Typeable Color +deriving instance Typeable Depth +deriving instance Typeable Stencil +deriving instance Typeable Interpolated +deriving instance Typeable Obj +deriving instance Typeable V +deriving instance Typeable G +deriving instance Typeable F +deriving instance Typeable Image +deriving instance Typeable Texture +deriving instance Typeable TextureType +deriving instance Typeable SingleOutput +deriving instance Typeable MultiOutput +deriving instance Typeable TextureDataType + +-- vector types: V2, V3, V4 +class IsVec (dim :: Nat) vec component | vec -> dim component, dim component -> vec +instance IsVec 2 (V2 Float) Float +instance IsVec 3 (V3 Float) Float +instance IsVec 4 (V4 Float) Float +instance IsVec 2 (V2 Int32) Int32 +instance IsVec 3 (V3 Int32) Int32 +instance IsVec 4 (V4 Int32) Int32 +instance IsVec 2 (V2 Word32) Word32 +instance IsVec 3 (V3 Word32) Word32 +instance IsVec 4 (V4 Word32) Word32 +instance IsVec 2 (V2 Bool) Bool +instance IsVec 3 (V3 Bool) Bool +instance IsVec 4 (V4 Bool) Bool + +-- scalar and vector types: scalar, V2, V3, V4 +class IsVecScalar (dim :: Nat) vec component | vec -> dim component, dim component -> vec +instance IsVecScalar 1 Float Float +instance IsVecScalar 2 (V2 Float) Float +instance IsVecScalar 3 (V3 Float) Float +instance IsVecScalar 4 (V4 Float) Float +instance IsVecScalar 1 Int32 Int32 +instance IsVecScalar 2 (V2 Int32) Int32 +instance IsVecScalar 3 (V3 Int32) Int32 +instance IsVecScalar 4 (V4 Int32) Int32 +instance IsVecScalar 1 Word32 Word32 +instance IsVecScalar 2 (V2 Word32) Word32 +instance IsVecScalar 3 (V3 Word32) Word32 +instance IsVecScalar 4 (V4 Word32) Word32 +instance IsVecScalar 1 Bool Bool +instance IsVecScalar 2 (V2 Bool) Bool +instance IsVecScalar 3 (V3 Bool) Bool +instance IsVecScalar 4 (V4 Bool) Bool + +-- matrix types of dimension [2..4] x [2..4] +class IsMat mat h w | mat -> h w +instance IsMat M22F V2F V2F +instance IsMat M23F V2F V3F +instance IsMat M24F V2F V4F +instance IsMat M32F V3F V2F +instance IsMat M33F V3F V3F +instance IsMat M34F V3F V4F +instance IsMat M42F V4F V2F +instance IsMat M43F V4F V3F +instance IsMat M44F V4F V4F + +-- matrix, vector and scalar types +class IsMatVecScalar a t | a -> t +instance IsMatVecScalar Float Float +instance IsMatVecScalar (V2 Float) Float +instance IsMatVecScalar (V3 Float) Float +instance IsMatVecScalar (V4 Float) Float +instance IsMatVecScalar Int32 Int32 +instance IsMatVecScalar (V2 Int32) Int32 +instance IsMatVecScalar (V3 Int32) Int32 +instance IsMatVecScalar (V4 Int32) Int32 +instance IsMatVecScalar Word32 Word32 +instance IsMatVecScalar (V2 Word32) Word32 +instance IsMatVecScalar (V3 Word32) Word32 +instance IsMatVecScalar (V4 Word32) Word32 +instance IsMatVecScalar Bool Bool +instance IsMatVecScalar (V2 Bool) Bool +instance IsMatVecScalar (V3 Bool) Bool +instance IsMatVecScalar (V4 Bool) Bool +instance IsMatVecScalar M22F Float +instance IsMatVecScalar M23F Float +instance IsMatVecScalar M24F Float +instance IsMatVecScalar M32F Float +instance IsMatVecScalar M33F Float +instance IsMatVecScalar M34F Float +instance IsMatVecScalar M42F Float +instance IsMatVecScalar M43F Float +instance IsMatVecScalar M44F Float + +-- matrix and vector types +class IsMatVec a t | a -> t +instance IsMatVec (V2 Float) Float +instance IsMatVec (V3 Float) Float +instance IsMatVec (V4 Float) Float +instance IsMatVec (V2 Int32) Int32 +instance IsMatVec (V3 Int32) Int32 +instance IsMatVec (V4 Int32) Int32 +instance IsMatVec (V2 Word32) Word32 +instance IsMatVec (V3 Word32) Word32 +instance IsMatVec (V4 Word32) Word32 +instance IsMatVec (V2 Bool) Bool +instance IsMatVec (V3 Bool) Bool +instance IsMatVec (V4 Bool) Bool +instance IsMatVec M22F Float +instance IsMatVec M23F Float +instance IsMatVec M24F Float +instance IsMatVec M32F Float +instance IsMatVec M33F Float +instance IsMatVec M34F Float +instance IsMatVec M42F Float +instance IsMatVec M43F Float +instance IsMatVec M44F Float + +-- matrix or vector component type +class IsComponent a +instance IsComponent Float +instance IsComponent Int32 +instance IsComponent Word32 +instance IsComponent Bool +instance IsComponent V2F +instance IsComponent V3F +instance IsComponent V4F + +-- matrix or vector number component type +class IsNumComponent a +instance IsNumComponent Float +instance IsNumComponent Int32 +instance IsNumComponent Word32 +instance IsNumComponent V2F +instance IsNumComponent V3F +instance IsNumComponent V4F + +class IsSigned a +instance IsSigned Float +instance IsSigned Int + +class Real a => IsNum a +instance IsNum Float +instance IsNum Int32 +instance IsNum Word32 + +class IsIntegral a +instance IsIntegral Int32 +instance IsIntegral Word32 + +class IsFloating a +instance IsFloating Float +instance IsFloating V2F +instance IsFloating V3F +instance IsFloating V4F +instance IsFloating M22F +instance IsFloating M23F +instance IsFloating M24F +instance IsFloating M32F +instance IsFloating M33F +instance IsFloating M34F +instance IsFloating M42F +instance IsFloating M43F +instance IsFloating M44F