module Graphics.OpenGLES.Buffer (
Buffer,
GLArray,
MakeArray(..),
glLoad, glReload, glRead, glModify, glMap,
unsafeWithLen,
BufferUsage, app2gl, app2glDyn, app2glStream,
gl2app, gl2appDyn, gl2appStream, gl2gl, gl2glDyn, gl2glStream,
bindBuffer, bindBufferRange, bindBufferBase,
bufferData, bufferSubData,
unmapBuffer,
mapBufferRange, flashMappedBufferRange,
map_read_bit, map_write_bit, map_invalidate_range_bit,
map_invalidate_buffer_bit, map_flush_explicit_bit, map_unsynchronized_bit,
copyBufferSubData,
BufferSlot, array_buffer, element_array_buffer,
pixel_pack_buffer, pixel_unpack_buffer,
uniform_buffer, transform_feedback_buffer,
copy_read_buffer, copy_write_buffer
) where
import Control.Applicative
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.IORef
import qualified Data.Vector.Storable as V
import Graphics.OpenGLES.Base
import Graphics.OpenGLES.Caps
import Graphics.OpenGLES.Internal
import Graphics.OpenGLES.Types
import Foreign
class Storable (Element a) => MakeArray a where
type Element a :: *
makeAref :: a -> GL (Either (GLArray (Element a)) Int)
makeWriter :: a -> (Ptr (Element a) -> GL (), Int)
newtype Zeros a = Zeros { unZeros :: Int }
class Storable a => MemZero a where memZero :: a
instance MemZero Int where memZero = 0
instance MemZero Bool where memZero = False
--etc
instance MemZero a => MakeArray (Zeros a) where
type Element (Zeros a) = a
makeAref = return . Right . unZeros
makeWriter (Zeros len) = (\ptr -> B.memset (castPtr ptr) 0
(fromIntegral $ len * sizeOf (undefined :: a))
>> return (), len)
newtype CycleTakeN a = CycleTakeN { unCycleTakeN :: ([a], Int) }
instance Storable a => MakeArray (CycleTakeN a) where
type Element (CycleTakeN a) = a
makeAref (CycleTakeN (xs, len)) = return . Left $ V.fromListN len (cycle xs)
makeWriter (CycleTakeN (xs, len)) = (\ptr -> pokeArray ptr xs, len)
instance Storable a => MakeArray [a] where
type Element [a] = a
makeAref xs = return . Left $ V.fromList xs
makeWriter xs = (\ptr -> pokeArray ptr xs, length xs)
newtype FromBS a = FromBS { unFromBS :: B.ByteString }
instance Storable a => MakeArray (FromBS a) where
type Element (FromBS a) = a
makeAref (FromBS bs@(B.PS foreignPtr offset len)) = do
let fp | offset == 0 = foreignPtr
| otherwise = case B.copy bs of (B.PS f _ _) -> f
let elems = (len `div` sizeOf (undefined :: a))
let vec = V.unsafeFromForeignPtr0 (castForeignPtr fp) elems
return (Left vec)
makeWriter (FromBS (B.PS fp offset len)) = (\dst ->
withForeignPtr fp $ \src ->
B.memcpy (castPtr dst) (advancePtr (castPtr src) offset) len
, len `div` sizeOf (undefined :: a))
instance Storable a => MakeArray (GLArray a) where
type Element (GLArray a) = a
makeAref = return . Left
makeWriter vec =
(\dst -> withForeignPtr fp $ \src ->
B.memcpy (castPtr dst) (castPtr src)
(len * sizeOf (undefined :: a))
, len)
where (fp, len) = V.unsafeToForeignPtr0 vec
glLoad :: forall a. MakeArray a => BufferUsage -> a -> GL (Buffer (Element a))
glLoad usage src = do
aref <- newIORef =<< makeAref src
Buffer aref <$> newBuffer (do
array <- readIORef aref
case array of
Left vector ->
unsafeWithLen vector (bufferData array_buffer usage)
Right elems ->
bufferData array_buffer usage (elems * unit) nullPtr
void $ showError "glBufferData"
) where unit = sizeOf (undefined :: Element a)
newBuffer init = newGLO glGenBuffers glDeleteBuffers
(\i -> glBindBuffer 0x8892 i >> init)
newVector :: Storable a => Int -> Int -> IO (GLArray a)
newVector elems unit = do
let B.PS fp _ _ = B.replicate (elems * unit) 0
return $ V.unsafeFromForeignPtr0 (castForeignPtr fp) elems
glReload
:: forall a. MakeArray a
=> Buffer (Element a)
-> Int
-> a
-> GL ()
glReload buf@(Buffer aref glo) offsetIx src = do
bindBuffer array_buffer buf
aref' <- readIORef aref
let unit = sizeOf (undefined :: Element a)
let (fillSubArray, size') = makeWriter src
let size = size' * unit
if hasES3 then do
ptr <- mapBufferRange array_buffer (offsetIx * unit) size
(map_write_bit + map_invalidate_range_bit + map_unsynchronized_bit)
showError "glMapBufferRange"
fillSubArray ptr
unmapBuffer array_buffer
showError "glUnmapBuffer"
case aref' of
Left vec ->
writeIORef aref (Right (V.length vec * unit))
else do
vector <- case aref' of
Left array -> return array
Right elems -> newVector elems unit
V.unsafeWith vector $ \p -> do
let ptr = advancePtr p (offsetIx * unit)
fillSubArray ptr
bufferSubData array_buffer (offsetIx * unit) size ptr
showError "glBufferSubData"
writeIORef aref (Left vector)
glRead
:: forall a. Storable a
=> Buffer a
-> Int
-> Int
-> GL (GLArray a)
glRead buf@(Buffer aref glo) offsetIx len = do
bindBuffer array_buffer buf
array <- readIORef aref
case array of
Left vector ->
return vector
Right elems -> do
vec <- newVector (min len (elems offsetIx)) unit
if hasES3 then do
src <- mapBufferRange array_buffer (offsetIx * unit) (len * unit)
(map_read_bit )
V.unsafeWith vec $ \dst ->
B.memcpy (castPtr dst) src (len * unit)
unmapBuffer array_buffer
writeIORef aref (Left vec)
return vec
else return vec
where unit = sizeOf (undefined :: a)
glModify
:: forall a. Storable a
=> Buffer a
-> Int
-> Int
-> (V.Vector a -> GL ())
-> GL ()
glModify buf@(Buffer aref glo) offsetIx len f = do
bindBuffer array_buffer buf
if hasES3 then do
a <- readIORef aref
let elems = case a of
Right elems -> elems
Left vector -> V.length vector
ptr <- mapBufferRange array_buffer 0 (len * unit)
(map_read_bit + map_write_bit )
fp <- newForeignPtr_ ptr
f $ V.unsafeFromForeignPtr0 fp elems
unmapBuffer array_buffer
writeIORef aref (Right elems)
else do
a <- readIORef aref
case a of
Left vector -> do
f vector
unsafeWithLen vector (bufferSubData array_buffer 0)
Right elems -> do
vec <- newVector elems unit
f vec
unsafeWithLen vec (bufferSubData array_buffer 0)
where unit = sizeOf (undefined :: a)
glMap
:: Storable a
=> (a -> GL a)
-> Buffer a
-> Int
-> Int
-> GL ()
glMap f buffer off len = glModify buffer off len (V.mapM_ f)
unsafeWithLen
:: forall a b. Storable a
=> GLArray a -> (Int -> Ptr a -> IO b) -> IO b
unsafeWithLen vector f = do
let (fp, len) = V.unsafeToForeignPtr0 vector
let size = len * sizeOf (undefined :: a)
withForeignPtr fp (f size)
app2gl = BufferUsage 0x88E4
app2glDyn = BufferUsage 0x88E8
app2glStream = BufferUsage 0x88E0
gl2app = BufferUsage 0x88E5
gl2appDyn = BufferUsage 0x88E9
gl2appStream = BufferUsage 0x88E1
gl2gl = BufferUsage 0x88E6
gl2glDyn = BufferUsage 0x88EA
gl2glStream = BufferUsage 0x88E2
bindBuffer :: BufferSlot -> Buffer a -> GL ()
bindBuffer (BufferSlot target) (Buffer _ glo) =
glBindBuffer target =<< getObjId glo
bindBufferRange :: BufferSlot -> GLuint -> Buffer a -> Int -> Int -> GL ()
bindBufferRange (BufferSlot t) index (Buffer _ glo) offset size = do
buf <- getObjId glo
glBindBufferRange t index buf offset size
bindBufferBase :: BufferSlot -> GLuint -> Buffer a -> GL ()
bindBufferBase (BufferSlot t) index (Buffer _ glo) = do
glBindBufferBase t index =<< getObjId glo
bufferData :: BufferSlot -> BufferUsage -> Int -> Ptr a -> GL ()
bufferData (BufferSlot target) (BufferUsage usage) size ptr =
glBufferData target size (castPtr ptr) usage
bufferSubData :: BufferSlot -> Int -> Int -> Ptr a -> GL ()
bufferSubData (BufferSlot target) offset size ptr =
glBufferSubData target offset size (castPtr ptr)
unmapBuffer :: BufferSlot -> GL Bool
unmapBuffer (BufferSlot target) =
glUnmapBuffer target >>= return . (/= 0)
mapBufferRange :: BufferSlot -> Int -> Int -> GLbitfield -> GL (Ptr a)
mapBufferRange (BufferSlot target) offset size access =
fmap castPtr $ glMapBufferRange target offset size access
flashMappedBufferRange :: BufferSlot -> Int -> Int -> GL ()
flashMappedBufferRange (BufferSlot target) offset size =
glFlushMappedBufferRange target offset size
map_read_bit = 1 :: GLbitfield
map_write_bit = 2 :: GLbitfield
map_invalidate_range_bit = 4 :: GLbitfield
map_invalidate_buffer_bit = 8 :: GLbitfield
map_flush_explicit_bit = 16 :: GLbitfield
map_unsynchronized_bit = 32 :: GLbitfield
copyBufferSubData :: BufferSlot -> BufferSlot -> Int -> Int -> Int -> GL ()
copyBufferSubData (BufferSlot read) (BufferSlot write) roffset woffset size =
glCopyBufferSubData read write roffset woffset size
array_buffer = BufferSlot 0x8892
element_array_buffer = BufferSlot 0x8893
pixel_pack_buffer = BufferSlot 0x88EB
pixel_unpack_buffer = BufferSlot 0x88EC
uniform_buffer = BufferSlot 0x8A11
transform_feedback_buffer = BufferSlot 0x8C8E
copy_read_buffer = BufferSlot 0x8F36
copy_write_buffer = BufferSlot 0x8F37