module Graphics.Luminance.Core.Buffer where
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.RWS ( RWS, ask, get, evalRWS, execRWS, put )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Data.Bits ( (.|.) )
import Data.Foldable ( toList )
import Data.Proxy ( Proxy(..) )
import Data.Word ( Word32 )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( peekArray, pokeArray )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( Ptr, castPtr, nullPtr )
#ifdef __GL45
import Foreign.Ptr ( plusPtr )
#endif
import Foreign.Storable ( Storable(..) )
import Graphics.GL
import Graphics.Luminance.Core.RW
mkBuffer :: (MonadIO m,MonadResource m)
=> GLbitfield
-> Int
-> m (GLuint,Ptr ())
#ifdef __GL45
mkBuffer flags size = do
(bid,mapped) <- liftIO . alloca $ \p -> do
glCreateBuffers 1 p
bid <- peek p
mapped <- createStorage bid flags size
pure (bid,mapped)
_ <- register . with bid $ glDeleteBuffers 1
pure (bid,mapped)
#elif defined(__GL33)
mkBuffer flags size = do
(bid,mapped) <- liftIO . alloca $ \p -> do
glGenBuffers 1 p
bid <- peek p
mapped <- createStorage bid flags size
pure (bid,mapped)
_ <- register . with bid $ glDeleteBuffers 1
pure (bid,mapped)
#endif
createStorage :: GLuint -> GLbitfield -> Int -> IO (Ptr ())
#ifdef __GL45
createStorage bid flags size = do
glNamedBufferStorage bid bytes nullPtr flags
ptr <- glMapNamedBufferRange bid 0 bytes flags
pure ptr
where
bytes = fromIntegral size
#elif defined(__GL33)
createStorage bid _ size = do
glBindBuffer GL_ARRAY_BUFFER bid
glBufferData GL_ARRAY_BUFFER bytes nullPtr GL_STREAM_DRAW
pure nullPtr
where
bytes = fromIntegral size
#endif
mkBufferWithRegions :: (MonadIO m,MonadResource m)
=> GLbitfield
-> BuildBuffer rw a
-> m (a,GLuint)
mkBufferWithRegions flags buildRegions = do
(buffer,mapped) <- mkBuffer flags bytes
pure (fst $ evalRWS built (buffer,mapped) 0,buffer)
where
built = runBuildBuffer buildRegions
(bytes,_) = execRWS built (0,nullPtr) 0
class BufferRW rw where
bufferFlagsFromRW :: proxy rw -> GLenum
instance BufferRW R where
bufferFlagsFromRW _ = GL_MAP_READ_BIT
instance BufferRW RW where
bufferFlagsFromRW _ = GL_MAP_READ_BIT .|. GL_MAP_WRITE_BIT
instance BufferRW W where
bufferFlagsFromRW _ = GL_MAP_WRITE_BIT
createBuffer :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m)
=> BuildBuffer rw a
-> m a
createBuffer = fmap fst . mkBufferWithRegions (bufferFlagsFromRW (Proxy :: Proxy rw) .|. persistentCoherentBits)
persistentCoherentBits :: GLbitfield
#ifdef __GL45
persistentCoherentBits = GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT
#elif defined(__GL33)
persistentCoherentBits = 0
#endif
#ifdef __GL45
data Buffer rw a = Buffer {
bufferPtr :: Ptr a
, bufferOffset :: Int
, bufferSize :: Int
, bufferID :: GLuint
} deriving (Eq,Show)
#elif defined(__GL33)
data Buffer rw a = Buffer {
bufferOffset :: Int
, bufferSize :: Int
, bufferID :: GLuint
} deriving (Eq,Show)
#endif
newtype BuildBuffer rw a = BuildBuffer {
runBuildBuffer :: RWS (GLuint,Ptr ()) () Int a
} deriving (Applicative,Functor,Monad)
newRegion :: forall rw a. (Storable a) => Word32 -> BuildBuffer rw (Buffer rw a)
newRegion size = BuildBuffer $ do
offset <- get
put $ offset + fromIntegral size * sizeOf (undefined :: a)
#ifdef __GL45
(buffer,ptr) <- ask
pure $ Buffer {
bufferPtr = (castPtr $ ptr `plusPtr` fromIntegral offset)
, bufferOffset = offset
, bufferSize = fromIntegral size
, bufferID = buffer
}
#elif defined(__GL33)
(buffer,_) <- ask
pure $ Buffer {
bufferOffset = offset
, bufferSize = fromIntegral size
, bufferID = buffer
}
#endif
readWhole :: (MonadIO m,Readable r,Storable a) => Buffer r a -> m [a]
#ifdef __GL45
readWhole r = liftIO $ peekArray (regionSize r) (regionPtr r)
#elif defined(__GL33)
readWhole r = liftIO $ do
glBindBuffer GL_ARRAY_BUFFER (bufferID r)
p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_READ_BIT
a <- peekArray (bufferSize r) (castPtr p)
_ <- glUnmapBuffer GL_ARRAY_BUFFER
pure a
#endif
writeWhole :: (Foldable f,MonadIO m,Storable a,Writable w)
=> Buffer w a
-> f a
-> m ()
#ifdef __GL45
writeWhole r values = liftIO . pokeArray (regionPtr r) . take (regionSize r) $ toList values
#elif defined(__GL33)
writeWhole r values = liftIO $ do
glBindBuffer GL_ARRAY_BUFFER (bufferID r)
p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_WRITE_BIT
pokeArray (castPtr p) . take (bufferSize r) $ toList values
() <$ glUnmapBuffer GL_ARRAY_BUFFER
#endif
fill :: (MonadIO m,Storable a,Writable w) => Buffer w a -> a -> m ()
fill r a = writeWhole r (replicate (bufferSize r) a)
(@?) :: (MonadIO m,Storable a,Readable r) => Buffer r a -> Word32 -> m (Maybe a)
r @? i
| i >= fromIntegral (bufferSize r) = pure Nothing
| otherwise = fmap Just (r @! i)
(@!) :: (MonadIO m,Storable a,Readable r) => Buffer r a -> Word32 -> m a
#ifdef __GL45
r @! i = liftIO $ peekElemOff (bufferPtr r) (fromIntegral i)
#elif defined(__GL33)
r @! i = liftIO $ do
glBindBuffer GL_ARRAY_BUFFER (bufferID r)
p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_READ_BIT
a <- peekElemOff (castPtr p) (fromIntegral i)
_ <- glUnmapBuffer GL_ARRAY_BUFFER
pure a
#endif
writeAt :: (MonadIO m,Storable a,Writable w) => Buffer w a -> Word32 -> a -> m ()
writeAt r i a
| i >= fromIntegral (bufferSize r) = pure ()
| otherwise = writeAt' r i a
writeAt' :: (MonadIO m,Storable a,Writable w) => Buffer w a -> Word32 -> a -> m ()
#ifdef __GL45
writeAt' r i a = liftIO $ pokeElemOff (bufferPtr r) (fromIntegral i) a
#elif defined(__GL33)
writeAt' r i a = liftIO $ do
glBindBuffer GL_ARRAY_BUFFER (bufferID r)
p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_WRITE_BIT
pokeElemOff (castPtr p) (fromIntegral i) a
() <$ glUnmapBuffer GL_ARRAY_BUFFER
#endif