module Graphics.Caramia.VAO
(
newVAO
, VAO()
, sourceVertexData
, Sourcing(..)
, defaultSourcing
, defaultSourcingType
, SourceableType(..)
, SourceType(..)
, sourceTypeSize )
where
import Graphics.Caramia.Prelude
import Graphics.Caramia.VAO.Internal
import Graphics.Caramia.Resource
import qualified Graphics.Caramia.Buffer.Internal as Buf
import Graphics.Caramia.Internal.OpenGLCApi
import Control.Exception
newVAO :: IO VAO
newVAO = mask_ $ do
res <- newResource create
(\(VAO_ vao) -> mglDeleteVertexArray vao)
(return ())
ref <- newIORef []
return VAO { resource = res
, boundBuffers = ref }
where
create = VAO_ <$> mglGenVertexArray
data SourceType =
SWord8
| SWord16
| SWord32
| SInt8
| SInt16
| SInt32
| SHalfFloat
| SFloat
| SDouble
deriving ( Eq, Ord, Show, Read )
sourceTypeSize :: SourceType -> Int
sourceTypeSize SWord8 = 1
sourceTypeSize SWord16 = 2
sourceTypeSize SWord32 = 4
sourceTypeSize SInt8 = 1
sourceTypeSize SInt16 = 2
sourceTypeSize SInt32 = 4
sourceTypeSize SHalfFloat = 2
sourceTypeSize SFloat = 4
sourceTypeSize SDouble = 8
isIntegerType :: SourceType -> Bool
isIntegerType SWord8 = True
isIntegerType SWord16 = True
isIntegerType SWord32 = True
isIntegerType SInt8 = True
isIntegerType SInt16 = True
isIntegerType SInt32 = True
isIntegerType SHalfFloat = False
isIntegerType SFloat = False
isIntegerType SDouble = False
toConstant :: SourceType -> GLenum
toConstant SWord8 = gl_UNSIGNED_BYTE
toConstant SWord16 = gl_UNSIGNED_SHORT
toConstant SWord32 = gl_UNSIGNED_INT
toConstant SInt8 = gl_BYTE
toConstant SInt16 = gl_SHORT
toConstant SInt32 = gl_INT
toConstant SHalfFloat = gl_HALF_FLOAT
toConstant SFloat = gl_FLOAT
toConstant SDouble = gl_DOUBLE
class SourceableType a where
reifyType :: a -> SourceType
instance SourceableType Word8 where
reifyType _ = SWord8
instance SourceableType Word16 where
reifyType _ = SWord16
instance SourceableType Word32 where
reifyType _ = SWord32
instance SourceableType Int8 where
reifyType _ = SInt8
instance SourceableType Int16 where
reifyType _ = SInt16
instance SourceableType Int32 where
reifyType _ = SInt32
instance SourceableType Float where
reifyType _ = SFloat
instance SourceableType Double where
reifyType _ = SDouble
data Sourcing = Sourcing
{ offset :: Int
, attributeIndex :: Int
, components :: Int
, stride :: Int
, normalize :: Bool
, integerMapping :: Bool
, instancingDivisor :: Int
, sourceType :: SourceType
}
defaultSourcing :: Sourcing
defaultSourcing = Sourcing
{ offset = 0
, components =
error "defaultSourcing: number of components is not set."
, stride = 0
, instancingDivisor = 0
, attributeIndex =
error "defaultSourcing: attribute index is not set."
, integerMapping =
error "defaultSourcing: whether to do integer mapping is not set."
, normalize =
error "defaultSourcing: normalize is not set for an integer type."
, sourceType =
error "defaultSourcing: source type is not set." }
defaultSourcingType :: SourceableType a
=> a
-> Sourcing
defaultSourcingType x =
defaultSourcing { sourceType = reifyType x }
sourceVertexData :: Buf.Buffer
-> Sourcing
-> VAO
-> IO ()
sourceVertexData buffer sourcing vao = mask_ $
withResource (resource vao) $ \(VAO_ name) ->
withResource (Buf.resource buffer) $ \(Buf.Buffer_ bufname) -> do
errorChecking
if isIntegerType stype && integerMapping sourcing
then doIntegerMapping name bufname
else doOrdinaryMapping name bufname
mglVertexArrayVertexAttribDivisor
name
(safeFromIntegral $ attributeIndex sourcing)
(safeFromIntegral $ instancingDivisor sourcing)
atomicModifyIORef' (boundBuffers vao) $ \old ->
( addIfNotUnique buffer old, () )
where
addIfNotUnique new old =
maybe (new:old)
(const old)
(find (new ==) old)
stype = sourceType sourcing
ncomponents = components sourcing
doIntegerMapping name bufname =
mglVertexArrayVertexAttribIOffsetAndEnable
name
bufname
(safeFromIntegral $ attributeIndex sourcing)
(safeFromIntegral ncomponents)
(toConstant stype)
(safeFromIntegral $ stride sourcing)
(safeFromIntegral $ offset sourcing)
doOrdinaryMapping name bufname =
mglVertexArrayVertexAttribOffsetAndEnable
name
bufname
(safeFromIntegral $ attributeIndex sourcing)
(safeFromIntegral ncomponents)
(toConstant stype)
(fromIntegral $ if isIntegerType stype && normalize sourcing
then gl_TRUE
else gl_FALSE)
(safeFromIntegral $ stride sourcing)
(safeFromIntegral $ offset sourcing)
errorChecking = do
when (isIntegerType stype) $
unless (integerMapping sourcing) $
let x = normalize sourcing
in x `seq` return ()
attributeIndex sourcing `seq` return ()
when (stride sourcing < 0) $
error "sourceVertexData: stride is negative."
when (offset sourcing < 0) $
error "sourceVertexData: offset is negative."
when (ncomponents < 1 ||
ncomponents > 4) $ error $
"sourceVertexData: number of components must be between " <>
"1 and 4. I was given " <> show ncomponents