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
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
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
convertOpenVertexOut :: Layout
-> H.VertexOut clipDistances t
-> 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)
convertOpenFragmentOut :: forall t.
Layout
-> H.FragmentOut t
-> 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
convertOpenGeometryOut :: forall i clipDistances t.
Layout
-> H.GeometryOut i clipDistances t
-> 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)
convertOpenInterpolatedFlatExp :: forall stage t.
Layout
-> H.InterpolatedFlatExp stage t
-> [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
-> H.FlatExp stage t
-> [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
-> H.Exp stage t
-> 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
-> H.Exp stage t
-> 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]
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