--------------------------------------------------------------------------------- Module : GPUStream-- Copyright : Tobias Bexelius-- License : BSD3---- Maintainer : Tobias Bexelius-- Stability : Experimental-- Portability : Portable---- |-----------------------------------------------------------------------------moduleGPUStream(PrimitiveStream(..),FragmentStream(..),VertexPosition,CullMode(..),Primitive(..),Triangle(..),Line(..),Point(..),VertexSetup(..),PrimitiveStreamDesc,FragmentStreamDesc,filterFragments,loadFragmentColorStream,loadFragmentDepthStream,loadFragmentColorDepthStream,loadFragmentAnyStream)whereimportShaderimportFormatsimportData.MonoidimportData.Vec(Vec4)importResourcesimportqualifiedGraphics.Rendering.OpenGLasGL(PrimitiveMode(..))importGraphics.Rendering.OpenGL(cullFace,($=),Face(..))importControl.Arrow(first,second)-- | A stream of primitives built by vertices on the GPU. The first parameter is the primitive type (currently 'Triangle', 'Line' or 'Point') and the second the-- the type of each primitives' vertices' type (built up of atoms of type 'Vertex').newtypePrimitiveStreampa=PrimitiveStream[(PrimitiveStreamDesc,a)]-- | A stream of fragments on the GPU, parameterized on the fragments type-- (built up of atoms of type 'Fragment').newtypeFragmentStreama=FragmentStream[(FragmentStreamDesc,FragmentBool,a)]typeVertexPosition=Vec4(VertexFloat)dataCullMode=CullNone|CullFront|CullBackderiving(Eq,Ord,Bounded,Enum,Show)dataVertexSetup=VertexSetup[[Float]]|IndexedVertexSetup[[Float]][Int]deriving(Eq,Ord,Show)typePrimitiveStreamDesc=(GL.PrimitiveMode,VertexSetup)typeFragmentStreamDesc=(PrimitiveStreamDesc,CullMode,Vec4(VertexFloat))instanceFunctor(PrimitiveStreamp)wherefmapf(PrimitiveStreama)=PrimitiveStream$map(secondf)ainstanceFunctorFragmentStreamwherefmapf(FragmentStreama)=FragmentStream$map(\(x,y,z)->(x,y,fz))ainstanceMonoid(PrimitiveStreampa)wheremempty=PrimitiveStream[]PrimitiveStreama`mappend`PrimitiveStreamb=PrimitiveStream(a++b)instanceMonoid(FragmentStreama)wheremempty=FragmentStream[]FragmentStreama`mappend`FragmentStreamb=FragmentStream(a++b)-- | Filters out fragments in a stream where the provided function returns 'true'.filterFragments::(a->FragmentBool)->FragmentStreama->FragmentStreamafilterFragmentsf(FragmentStreamxs)=FragmentStream$mapfilterOnexswherefilterOne(fdesc,b,a)=(fdesc,b&&*fa,a)-----------------------------------------classPrimitivepwheregetPrimitiveMode::p->GL.PrimitiveModedataTriangle=TriangleStrip|TriangleList|TriangleFanderiving(Eq,Ord,Bounded,Enum,Show)dataLine=LineStrip|LineListderiving(Eq,Ord,Bounded,Enum,Show)dataPoint=PointListderiving(Eq,Ord,Bounded,Enum,Show)instancePrimitiveTrianglewheregetPrimitiveModeTriangleStrip=GL.TriangleStripgetPrimitiveModeTriangleList=GL.TrianglesgetPrimitiveModeTriangleFan=GL.TriangleFaninstancePrimitiveLinewheregetPrimitiveModeLineStrip=GL.LineStripgetPrimitiveModeLineList=GL.LinesinstancePrimitivePointwheregetPrimitiveModePointList=GL.Points-----------------------------------------loadFragmentColorStream::ColorFormatf=>FragmentStream(Colorf(FragmentFloat))->ContextCacheIO()->ContextCacheIO()loadFragmentColorStream=loadFragmentColorStream'.fmap(fromColor01)whereloadFragmentColorStream'(FragmentStreamxs)=layerMapM_drawCallColorxsloadFragmentDepthStream::FragmentStream(FragmentFloat)->ContextCacheIO()->ContextCacheIO()loadFragmentDepthStream(FragmentStreamxs)=layerMapM_(drawCallColorDepth.setDefaultColor)xswheresetDefaultColor(desc,notDisc,d)=(desc,notDisc,(0,d))loadFragmentColorDepthStream::ColorFormatf=>FragmentStream(Colorf(FragmentFloat),FragmentFloat)->ContextCacheIO()->ContextCacheIO()loadFragmentColorDepthStream=loadFragmentColorDepthStream'.fmap(first(fromColor01))whereloadFragmentColorDepthStream'(FragmentStreamxs)=layerMapM_drawCallColorDepthxsloadFragmentAnyStream::FragmentStreama->ContextCacheIO()->ContextCacheIO()loadFragmentAnyStream(FragmentStreamxs)=layerMapM_(drawCallColor.setDefaultColor)xswheresetDefaultColor(desc,notDisc,_)=(desc,notDisc,0)layerMapM_f(x:xs)io=layerMapM_fxs(fxio)layerMapM__[]io=iodrawCallColor(((p,vs),cull,vPos),nd,c)io=drawCallpcullvsio$getShadersvPosndcNothingdrawCallColorDepth(((p,vs),cull,vPos),nd,(c,d))io=drawCallpcullvsio$getShadersvPosndc(Justd)mapSelect=map.selectwhereselect(x:xs)ys=let(a:b)=dropxysina:select(map(\t->t-x-1)xs)bselect[]_=[]drawCallpcull(VertexSetupv)io((vkey,vstr,vuns),(fkey,fstr,funs),ins)=doxs<-ioEvaluate(mapSelectinsv)ins'<-ioEvaluateinsvkey'<-ioEvaluatevkeyfkey'<-ioEvaluatefkeys<-ioEvaluate(lengthins)vs<-ioEvaluate(lengthv)vuns'<-ioEvaluatevunsfuns'<-ioEvaluatefunscull'<-ioEvaluatecullp'<-ioEvaluatepio(pr,(vu,fu))<-createProgramResourcevkey'vstrfkey'fstrsvb<-createVertexBufferxsins'vuseProgramResourcepruseUniformsvuvuns'useUniformsfufuns'liftIO$douseCullcull'drawVertexBufferp'vbvsdrawCallpcull(IndexedVertexSetupvi)io((vkey,vstr,vuns),(fkey,fstr,funs),ins)=doi'<-ioEvaluateixs<-ioEvaluate(mapSelectinsv)ins'<-ioEvaluateinsvkey'<-ioEvaluatevkeyfkey'<-ioEvaluatefkeys<-ioEvaluate(lengthins)vs<-ioEvaluate(lengthv)vuns'<-ioEvaluatevunsfuns'<-ioEvaluatefunscull'<-ioEvaluatecullp'<-ioEvaluatepio(pr,(vu,fu))<-createProgramResourcevkey'vstrfkey'fstrsib<-createIndexBufferi'vsvb<-createVertexBufferxsins'vuseProgramResourcepruseUniformsvuvuns'useUniformsfufuns'liftIO$douseCullcull'drawIndexVertexBufferp'vbibuseCullCullNone=cullFace$=NothinguseCullCullFront=cullFace$=JustFrontuseCullCullBack=cullFace$=JustBack