module Graphics.OpenGLES.Buffer (
Buffer,
GLArray,
GLSource(..),
glLoad, glReload, glUnsafeRead, glModify, glMap,
withStorableArraySize,
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 Data.Array.Storable
import Data.Array.Storable.Internals
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.IORef
import Graphics.OpenGLES.Base
import Graphics.OpenGLES.Internal
import Graphics.OpenGLES.Env
import Graphics.OpenGLES.Types
import Foreign hiding (newArray)
type GLArray a = StorableArray Int a
type family Content a x :: *
type instance Content Int x = x
type instance Content B.ByteString x = x
type instance Content [a] x = a
type instance Content ([a], Int) x = a
type instance Content (GLArray a) x = a
class (Storable b, b ~ Content a b) => GLSource a b where
makeAref :: a -> GL (Either (GLArray (Content a b)) Int)
makeWriter :: a -> (Ptr (Content a b) -> GL (), Int)
instance Storable b => GLSource Int b where
makeAref = return . Right
makeWriter len = (\ptr -> B.memset (castPtr ptr) 0
(fromIntegral $ len * sizeOf (undefined :: b))
>> return (), len)
instance Storable a => GLSource ([a], Int) a where
makeAref (xs, len) = Left <$> newListArray (0, len 1) (cycle xs)
makeWriter (xs, len) = (\ptr -> pokeArray ptr xs, len)
instance Storable a => GLSource [a] a where
makeAref xs = Left <$> newListArray (0, length xs 1) xs
makeWriter xs = (\ptr -> pokeArray ptr xs, length xs)
instance Storable b => GLSource B.ByteString b where
makeAref 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 :: b))
let array = StorableArray 0 (elems1) elems (castForeignPtr fp)
return (Left array)
makeWriter (B.PS fp offset len) = (\dst ->
withForeignPtr fp $ \src ->
B.memcpy (castPtr dst) (advancePtr (castPtr src) offset) len
, len `div` sizeOf (undefined :: b))
instance Storable a => GLSource (GLArray a) a where
makeAref = return . Left
makeWriter sa@(StorableArray _ _ len fp) =
(\dst -> withForeignPtr fp $ \src ->
B.memcpy (castPtr dst) (castPtr src)
(len * sizeOf (undefined :: a))
, len)
glLoad :: forall a b. GLSource a b => BufferUsage -> a -> GL (Buffer b)
glLoad usage src = do
aref <- newIORef =<< makeAref src
Buffer aref <$> newBuffer (do
array <- readIORef aref
case array of
Left sa ->
withStorableArraySize sa (bufferData array_buffer usage)
Right elems ->
bufferData array_buffer usage (elems * unit) nullPtr
void $ showError "glBufferData"
) where unit = sizeOf (undefined :: b)
newBuffer init = newGLO glGenBuffers glDeleteBuffers
(\i -> glBindBuffer 0x8892 i >> init)
newArrayLen elems unit = do
sa@(StorableArray _ _ _ fp) <- newArray_ (0, elems 1)
withForeignPtr fp $ \dst ->
B.memset (castPtr dst) 0 (fromIntegral $ elems * unit)
return sa
glReload :: forall a b. GLSource a b => Buffer b -> Int -> a -> GL ()
glReload buf@(Buffer aref glo) offsetIx src = do
bindBuffer array_buffer buf
aref' <- readIORef aref
let unit = sizeOf (undefined :: b)
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 (StorableArray _ _ len _) ->
writeIORef aref (Right (len * unit))
else do
sa@(StorableArray _ _ len fp) <- case aref' of
Left array -> return array
Right elems -> newArrayLen elems unit
withForeignPtr fp $ \p -> do
let ptr = advancePtr p (offsetIx * unit)
fillSubArray ptr
bufferSubData array_buffer (offsetIx * unit) size ptr
showError "glBufferSubData"
writeIORef aref (Left sa)
glUnsafeRead :: forall a. Storable a => Buffer a -> (Int, Int) -> GL (GLArray a)
glUnsafeRead buf@(Buffer aref glo) (offsetIx, len) = do
bindBuffer array_buffer buf
array <- readIORef aref
case array of
Left (StorableArray s e l fp) ->
return (StorableArray s e l fp)
Right elems -> do
sa <- newArrayLen (min len (elems offsetIx)) unit
if hasES3 then do
src <- mapBufferRange array_buffer (offsetIx * unit) (len * unit)
(map_read_bit )
withStorableArray sa $ \dst ->
B.memcpy (castPtr dst) src (len * unit)
unmapBuffer array_buffer
writeIORef aref (Left sa)
return sa
else return sa
where unit = sizeOf (undefined :: a)
glModify :: forall a. Storable a => Buffer a -> (Int, Int) -> (GLArray 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 (StorableArray _ _ elems _) -> elems
ptr <- mapBufferRange array_buffer 0 (len * unit)
(map_read_bit + map_write_bit )
fp <- newForeignPtr_ ptr
f $ StorableArray 0 (elems1) elems fp
unmapBuffer array_buffer
writeIORef aref (Right elems)
else do
a <- readIORef aref
case a of
Left sa -> do
f sa
withStorableArraySize sa (bufferSubData array_buffer 0)
Right elems -> do
sa <- newArrayLen elems unit
f sa
withStorableArraySize sa (bufferSubData array_buffer 0)
where unit = sizeOf (undefined :: a)
glMap :: Storable a => (a -> GL a) -> Buffer a -> (Int, Int) -> GL ()
glMap f buffer offLen = glModify buffer offLen $
\(StorableArray _ _ len fp) ->
withForeignPtr fp $ \ptr ->
sequence_
[ peekElemOff ptr i >>= f >>= pokeElemOff ptr i
| i <- [0..len1] ]
withStorableArraySize
:: forall i e a. Storable e
=> StorableArray i e -> (Int -> Ptr e -> IO a) -> IO a
withStorableArraySize (StorableArray _ _ n fp) f =
withForeignPtr fp (f size)
where size = n * sizeOf (undefined :: e)
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