module LambdaCube.GL.Type where
import Data.IORef
import Data.Int
import Data.IntMap (IntMap)
import Data.Set (Set)
import Data.Map (Map)
import Data.Vector (Vector)
import Data.Word
import Foreign.Ptr
import Foreign.Storable
import Data.ByteString
import Graphics.GL.Core33
import LambdaCube.Linear
import LambdaCube.IR
import LambdaCube.PipelineSchema
type GLUniformName = ByteString
data Buffer
= Buffer
{ bufArrays :: Vector ArrayDesc
, bufGLObj :: GLuint
}
deriving (Show,Eq)
data ArrayDesc
= ArrayDesc
{ arrType :: ArrayType
, arrLength :: Int
, arrOffset :: Int
, arrSize :: Int
}
deriving (Show,Eq)
data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a)
instance Show GLUniform where
show (GLUniform t _) = "GLUniform " ++ show t
data OrderJob
= Generate
| Reorder
| Ordered
data GLSlot
= GLSlot
{ objectMap :: IntMap Object
, sortedObjects :: Vector (Int,Object)
, orderJob :: OrderJob
}
data GLStorage
= GLStorage
{ schema :: PipelineSchema
, slotMap :: Map String SlotName
, slotVector :: Vector (IORef GLSlot)
, objSeed :: IORef Int
, uniformSetter :: Map GLUniformName InputSetter
, uniformSetup :: Map String GLUniform
, screenSize :: IORef (Word,Word)
, pipelines :: IORef (Vector (Maybe GLRenderer))
}
data Object
= Object
{ objSlot :: SlotName
, objPrimitive :: Primitive
, objIndices :: Maybe (IndexStream Buffer)
, objAttributes :: Map String (Stream Buffer)
, objUniSetter :: Map GLUniformName InputSetter
, objUniSetup :: Map String GLUniform
, objOrder :: IORef Int
, objEnabled :: IORef Bool
, objId :: Int
, objCommands :: IORef (Vector (Vector [GLObjectCommand]))
}
data GLProgram
= GLProgram
{ shaderObjects :: [GLuint]
, programObject :: GLuint
, inputUniforms :: Map String GLint
, inputTextures :: Map String GLint
, inputTextureUniforms :: Set String
, inputStreams :: Map String (GLuint,String)
}
data GLTexture
= GLTexture
{ glTextureObject :: GLuint
, glTextureTarget :: GLenum
} deriving Eq
data InputConnection
= InputConnection
{ icId :: Int
, icInput :: GLStorage
, icSlotMapPipelineToInput :: Vector SlotName
, icSlotMapInputToPipeline :: Vector (Maybe SlotName)
}
data GLStream
= GLStream
{ glStreamCommands :: IORef [GLObjectCommand]
, glStreamPrimitive :: Primitive
, glStreamAttributes :: Map String (Stream Buffer)
, glStreamProgram :: ProgramName
}
data GLRenderer
= GLRenderer
{ glPrograms :: Vector GLProgram
, glTextures :: Vector GLTexture
, glSamplers :: Vector GLSampler
, glTargets :: Vector GLRenderTarget
, glCommands :: [GLCommand]
, glSlotPrograms :: Vector [ProgramName]
, glInput :: IORef (Maybe InputConnection)
, glSlotNames :: Vector String
, glVAO :: GLuint
, glTexUnitMapping :: Map String (IORef GLint)
, glStreams :: Vector GLStream
, glDrawContextRef :: IORef GLDrawContext
, glForceSetup :: IORef Bool
, glVertexBufferRef :: IORef GLuint
, glIndexBufferRef :: IORef GLuint
, glDrawCallCounterRef :: IORef Int
}
data GLSampler
= GLSampler
{ glSamplerObject :: GLuint
} deriving Eq
data GLRenderTarget
= GLRenderTarget
{ framebufferObject :: GLuint
, framebufferDrawbuffers :: Maybe [GLenum]
} deriving Eq
type GLTextureUnit = Int
type GLUniformBinding = GLint
data GLSamplerUniform
= GLSamplerUniform
{ glUniformBinding :: !GLUniformBinding
, glUniformBindingRef :: IORef GLUniformBinding
}
instance Eq GLSamplerUniform where
a == b = glUniformBinding a == glUniformBinding b
data GLDrawContext
= GLDrawContext
{ glRasterContext :: !RasterContext
, glAccumulationContext :: !AccumulationContext
, glRenderTarget :: !GLRenderTarget
, glProgram :: !GLuint
, glTextureMapping :: ![(GLTextureUnit,GLTexture)]
, glSamplerMapping :: ![(GLTextureUnit,GLSampler)]
, glSamplerUniformMapping :: ![(GLTextureUnit,GLSamplerUniform)]
}
data GLCommand
= GLRenderSlot !GLDrawContext !SlotName !ProgramName
| GLRenderStream !GLDrawContext !StreamName !ProgramName
| GLClearRenderTarget !GLRenderTarget ![ClearImage]
instance Show (IORef GLint) where
show _ = "(IORef GLint)"
data GLObjectCommand
= GLSetUniform !GLint !GLUniform
| GLBindTexture !GLenum !(IORef GLint) !GLUniform
| GLSetVertexAttribArray !GLuint !GLuint !GLint !GLenum !(Ptr ())
| GLSetVertexAttribIArray !GLuint !GLuint !GLint !GLenum !(Ptr ())
| GLSetVertexAttrib !GLuint !(Stream Buffer)
| GLDrawArrays !GLenum !GLint !GLsizei
| GLDrawElements !GLenum !GLsizei !GLenum !GLuint !(Ptr ())
deriving Show
type SetterFun a = a -> IO ()
data InputSetter
= SBool (SetterFun Bool)
| SV2B (SetterFun V2B)
| SV3B (SetterFun V3B)
| SV4B (SetterFun V4B)
| SWord (SetterFun Word32)
| SV2U (SetterFun V2U)
| SV3U (SetterFun V3U)
| SV4U (SetterFun V4U)
| SInt (SetterFun Int32)
| SV2I (SetterFun V2I)
| SV3I (SetterFun V3I)
| SV4I (SetterFun V4I)
| SFloat (SetterFun Float)
| SV2F (SetterFun V2F)
| SV3F (SetterFun V3F)
| SV4F (SetterFun V4F)
| SM22F (SetterFun M22F)
| SM23F (SetterFun M23F)
| SM24F (SetterFun M24F)
| SM32F (SetterFun M32F)
| SM33F (SetterFun M33F)
| SM34F (SetterFun M34F)
| SM42F (SetterFun M42F)
| SM43F (SetterFun M43F)
| SM44F (SetterFun M44F)
| SSTexture1D
| SSTexture2D
| SSTextureCube
| SSTexture1DArray
| SSTexture2DArray
| SSTexture2DRect
| SFTexture1D
| SFTexture2D (SetterFun TextureData)
| SFTexture3D
| SFTextureCube
| SFTexture1DArray
| SFTexture2DArray
| SFTexture2DMS
| SFTexture2DMSArray
| SFTextureBuffer
| SFTexture2DRect
| SITexture1D
| SITexture2D
| SITexture3D
| SITextureCube
| SITexture1DArray
| SITexture2DArray
| SITexture2DMS
| SITexture2DMSArray
| SITextureBuffer
| SITexture2DRect
| SUTexture1D
| SUTexture2D
| SUTexture3D
| SUTextureCube
| SUTexture1DArray
| SUTexture2DArray
| SUTexture2DMS
| SUTexture2DMSArray
| SUTextureBuffer
| SUTexture2DRect
type BufferSetter = (Ptr () -> IO ()) -> IO ()
data ArrayType
= ArrWord8
| ArrWord16
| ArrWord32
| ArrInt8
| ArrInt16
| ArrInt32
| ArrFloat
| ArrHalf
deriving (Show,Eq,Ord)
sizeOfArrayType :: ArrayType -> Int
sizeOfArrayType ArrWord8 = 1
sizeOfArrayType ArrWord16 = 2
sizeOfArrayType ArrWord32 = 4
sizeOfArrayType ArrInt8 = 1
sizeOfArrayType ArrInt16 = 2
sizeOfArrayType ArrInt32 = 4
sizeOfArrayType ArrFloat = 4
sizeOfArrayType ArrHalf = 2
data Array
= Array ArrayType Int BufferSetter
toStreamType :: InputType -> Maybe StreamType
toStreamType Word = Just Attribute_Word
toStreamType V2U = Just Attribute_V2U
toStreamType V3U = Just Attribute_V3U
toStreamType V4U = Just Attribute_V4U
toStreamType Int = Just Attribute_Int
toStreamType V2I = Just Attribute_V2I
toStreamType V3I = Just Attribute_V3I
toStreamType V4I = Just Attribute_V4I
toStreamType Float = Just Attribute_Float
toStreamType V2F = Just Attribute_V2F
toStreamType V3F = Just Attribute_V3F
toStreamType V4F = Just Attribute_V4F
toStreamType M22F = Just Attribute_M22F
toStreamType M23F = Just Attribute_M23F
toStreamType M24F = Just Attribute_M24F
toStreamType M32F = Just Attribute_M32F
toStreamType M33F = Just Attribute_M33F
toStreamType M34F = Just Attribute_M34F
toStreamType M42F = Just Attribute_M42F
toStreamType M43F = Just Attribute_M43F
toStreamType M44F = Just Attribute_M44F
toStreamType _ = Nothing
fromStreamType :: StreamType -> InputType
fromStreamType Attribute_Word = Word
fromStreamType Attribute_V2U = V2U
fromStreamType Attribute_V3U = V3U
fromStreamType Attribute_V4U = V4U
fromStreamType Attribute_Int = Int
fromStreamType Attribute_V2I = V2I
fromStreamType Attribute_V3I = V3I
fromStreamType Attribute_V4I = V4I
fromStreamType Attribute_Float = Float
fromStreamType Attribute_V2F = V2F
fromStreamType Attribute_V3F = V3F
fromStreamType Attribute_V4F = V4F
fromStreamType Attribute_M22F = M22F
fromStreamType Attribute_M23F = M23F
fromStreamType Attribute_M24F = M24F
fromStreamType Attribute_M32F = M32F
fromStreamType Attribute_M33F = M33F
fromStreamType Attribute_M34F = M34F
fromStreamType Attribute_M42F = M42F
fromStreamType Attribute_M43F = M43F
fromStreamType Attribute_M44F = M44F
data Stream b
= ConstWord Word32
| ConstV2U V2U
| ConstV3U V3U
| ConstV4U V4U
| ConstInt Int32
| ConstV2I V2I
| ConstV3I V3I
| ConstV4I V4I
| ConstFloat Float
| ConstV2F V2F
| ConstV3F V3F
| ConstV4F V4F
| ConstM22F M22F
| ConstM23F M23F
| ConstM24F M24F
| ConstM32F M32F
| ConstM33F M33F
| ConstM34F M34F
| ConstM42F M42F
| ConstM43F M43F
| ConstM44F M44F
| Stream
{ streamType :: StreamType
, streamBuffer :: b
, streamArrIdx :: Int
, streamStart :: Int
, streamLength :: Int
}
deriving Show
streamToStreamType :: Stream a -> StreamType
streamToStreamType s = case s of
ConstWord _ -> Attribute_Word
ConstV2U _ -> Attribute_V2U
ConstV3U _ -> Attribute_V3U
ConstV4U _ -> Attribute_V4U
ConstInt _ -> Attribute_Int
ConstV2I _ -> Attribute_V2I
ConstV3I _ -> Attribute_V3I
ConstV4I _ -> Attribute_V4I
ConstFloat _ -> Attribute_Float
ConstV2F _ -> Attribute_V2F
ConstV3F _ -> Attribute_V3F
ConstV4F _ -> Attribute_V4F
ConstM22F _ -> Attribute_M22F
ConstM23F _ -> Attribute_M23F
ConstM24F _ -> Attribute_M24F
ConstM32F _ -> Attribute_M32F
ConstM33F _ -> Attribute_M33F
ConstM34F _ -> Attribute_M34F
ConstM42F _ -> Attribute_M42F
ConstM43F _ -> Attribute_M43F
ConstM44F _ -> Attribute_M44F
Stream t _ _ _ _ -> t
data IndexStream b
= IndexStream
{ indexBuffer :: b
, indexArrIdx :: Int
, indexStart :: Int
, indexLength :: Int
}
newtype TextureData
= TextureData
{ textureObject :: GLuint
}
deriving Storable
data Primitive
= TriangleStrip
| TriangleList
| TriangleFan
| LineStrip
| LineList
| PointList
| TriangleStripAdjacency
| TriangleListAdjacency
| LineStripAdjacency
| LineListAdjacency
deriving (Eq,Ord,Bounded,Enum,Show)
type StreamSetter = Stream Buffer -> IO ()
instance Storable a => Storable (V2 a) where
sizeOf _ = 2 * sizeOf (undefined :: a)
alignment _ = sizeOf (undefined :: a)
peek q = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
x <- peek p
y <- peekByteOff p k
return $! (V2 x y)
poke q (V2 x y) = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
poke p x
pokeByteOff p k y
instance Storable a => Storable (V3 a) where
sizeOf _ = 3 * sizeOf (undefined :: a)
alignment _ = sizeOf (undefined :: a)
peek q = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
x <- peek p
y <- peekByteOff p k
z <- peekByteOff p (k*2)
return $! (V3 x y z)
poke q (V3 x y z) = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
poke p x
pokeByteOff p k y
pokeByteOff p (k*2) z
instance Storable a => Storable (V4 a) where
sizeOf _ = 4 * sizeOf (undefined :: a)
alignment _ = sizeOf (undefined :: a)
peek q = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
x <- peek p
y <- peekByteOff p k
z <- peekByteOff p (k*2)
w <- peekByteOff p (k*3)
return $! (V4 x y z w)
poke q (V4 x y z w) = do
let p = castPtr q :: Ptr a
k = sizeOf (undefined :: a)
poke p x
pokeByteOff p k y
pokeByteOff p (k*2) z
pokeByteOff p (k*3) w