{-# LANGUAGE ScopedTypeVariables #-}
-- |Utilities for filling 'BufferObject's.
module Graphics.GLUtil.BufferObjects where
import Data.Word (Word32)
import Graphics.Rendering.OpenGL
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import Data.Array.Storable
import qualified Data.Vector.Storable as V
import Data.ByteString (ByteString, useAsCStringLen)

-- |Allocate and fill a 'BufferObject' from a list of 'Storable's.
makeBuffer :: Storable a => BufferTarget -> [a] -> IO BufferObject
makeBuffer :: BufferTarget -> [a] -> IO BufferObject
makeBuffer target :: BufferTarget
target elems :: [a]
elems = BufferTarget -> Int -> [a] -> IO BufferObject
forall a.
Storable a =>
BufferTarget -> Int -> [a] -> IO BufferObject
makeBufferLen BufferTarget
target ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
elems) [a]
elems

-- |Allocate and fill a 'BufferObject' from a list of 'Storable's
-- whose length is explicitly given. This is useful when the list is
-- of known length, as it avoids a traversal to find the length.
makeBufferLen :: forall a. Storable a => 
                 BufferTarget -> Int -> [a] -> IO BufferObject
makeBufferLen :: BufferTarget -> Int -> [a] -> IO BufferObject
makeBufferLen target :: BufferTarget
target len :: Int
len elems :: [a]
elems = 
    do [buffer :: BufferObject
buffer] <- Int -> IO [BufferObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
genObjectNames 1
       BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
target StateVar (Maybe BufferObject) -> Maybe BufferObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BufferObject -> Maybe BufferObject
forall a. a -> Maybe a
Just BufferObject
buffer
       let n :: GLsizeiptr
n = Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLsizeiptr) -> Int -> GLsizeiptr
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined::a)
       StorableArray Int a
arr <- (Int, Int) -> [a] -> IO (StorableArray Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (0, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [a]
elems
       StorableArray Int a -> (Ptr a -> IO ()) -> IO ()
forall i e a. StorableArray i e -> (Ptr e -> IO a) -> IO a
withStorableArray StorableArray Int a
arr ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr -> 
         BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
target StateVar (GLsizeiptr, Ptr a, BufferUsage)
-> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
n, Ptr a
ptr, BufferUsage
StaticDraw)
       BufferObject -> IO BufferObject
forall (m :: * -> *) a. Monad m => a -> m a
return BufferObject
buffer

-- |@replaceBuffer target elements@ replaces the buffer data attached
-- to the buffer object currently bound to @target@ with the supplied
-- list. Any previous data is deleted.
replaceBuffer :: forall a. Storable a => BufferTarget -> [a] -> IO ()
replaceBuffer :: BufferTarget -> [a] -> IO ()
replaceBuffer target :: BufferTarget
target elems :: [a]
elems = do StorableArray Int a
arr <- (Int, Int) -> [a] -> IO (StorableArray Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (0, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [a]
elems
                                StorableArray Int a -> (Ptr a -> IO ()) -> IO ()
forall i e a. StorableArray i e -> (Ptr e -> IO a) -> IO a
withStorableArray StorableArray Int a
arr ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr ->
                                  BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
target StateVar (GLsizeiptr, Ptr a, BufferUsage)
-> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
n, Ptr a
ptr, BufferUsage
StaticDraw)
  where len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
elems
        n :: GLsizeiptr
n = Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLsizeiptr) -> Int -> GLsizeiptr
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined::a)

-- |Allocate and fill a 'BufferObject' with the given number of bytes
-- from the supplied pointer.
fromPtr :: BufferTarget -> Int -> Ptr a -> IO BufferObject
fromPtr :: BufferTarget -> Int -> Ptr a -> IO BufferObject
fromPtr target :: BufferTarget
target numBytes :: Int
numBytes ptr :: Ptr a
ptr = 
  do [buffer :: BufferObject
buffer] <- Int -> IO [BufferObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
genObjectNames 1
     BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
target StateVar (Maybe BufferObject) -> Maybe BufferObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BufferObject -> Maybe BufferObject
forall a. a -> Maybe a
Just BufferObject
buffer
     BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
target StateVar (GLsizeiptr, Ptr a, BufferUsage)
-> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numBytes, Ptr a
ptr, BufferUsage
StaticDraw)
     BufferObject -> IO BufferObject
forall (m :: * -> *) a. Monad m => a -> m a
return BufferObject
buffer

-- |Fill a buffer with a 'ByteString'.
fromByteString :: BufferTarget -> ByteString -> IO BufferObject
fromByteString :: BufferTarget -> ByteString -> IO BufferObject
fromByteString target :: BufferTarget
target b :: ByteString
b = ByteString -> (CStringLen -> IO BufferObject) -> IO BufferObject
forall a. ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen ByteString
b ((Ptr CChar -> Int -> IO BufferObject)
-> CStringLen -> IO BufferObject
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Ptr CChar -> Int -> IO BufferObject)
 -> CStringLen -> IO BufferObject)
-> ((Int -> Ptr CChar -> IO BufferObject)
    -> Ptr CChar -> Int -> IO BufferObject)
-> (Int -> Ptr CChar -> IO BufferObject)
-> CStringLen
-> IO BufferObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Ptr CChar -> IO BufferObject)
-> Ptr CChar -> Int -> IO BufferObject
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> Ptr CChar -> IO BufferObject)
 -> CStringLen -> IO BufferObject)
-> (Int -> Ptr CChar -> IO BufferObject)
-> CStringLen
-> IO BufferObject
forall a b. (a -> b) -> a -> b
$ BufferTarget -> Int -> Ptr CChar -> IO BufferObject
forall a. BufferTarget -> Int -> Ptr a -> IO BufferObject
fromPtr BufferTarget
target)

-- |Fill a buffer with data from a 'ForeignPtr'. The application
-- @fromForeignPtr target len fptr@ fills a @target@ 'BufferTarget'
-- with @len@ elements starting from @fptr@.
fromForeignPtr :: forall a. Storable a => 
                  BufferTarget -> Int -> ForeignPtr a -> IO BufferObject
fromForeignPtr :: BufferTarget -> Int -> ForeignPtr a -> IO BufferObject
fromForeignPtr target :: BufferTarget
target len :: Int
len fptr :: ForeignPtr a
fptr = ForeignPtr a -> (Ptr a -> IO BufferObject) -> IO BufferObject
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fptr ((Ptr a -> IO BufferObject) -> IO BufferObject)
-> (Ptr a -> IO BufferObject) -> IO BufferObject
forall a b. (a -> b) -> a -> b
$ BufferTarget -> Int -> Ptr a -> IO BufferObject
forall a. BufferTarget -> Int -> Ptr a -> IO BufferObject
fromPtr BufferTarget
target Int
numBytes
  where numBytes :: Int
numBytes = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined::a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
len

-- |Fill a buffer with data from a 'V.Vector'.
fromVector :: forall a. Storable a => 
              BufferTarget -> V.Vector a -> IO BufferObject
fromVector :: BufferTarget -> Vector a -> IO BufferObject
fromVector target :: BufferTarget
target v :: Vector a
v = Vector a -> (Ptr a -> IO BufferObject) -> IO BufferObject
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector a
v ((Ptr a -> IO BufferObject) -> IO BufferObject)
-> (Ptr a -> IO BufferObject) -> IO BufferObject
forall a b. (a -> b) -> a -> b
$ BufferTarget -> Int -> Ptr a -> IO BufferObject
forall a. BufferTarget -> Int -> Ptr a -> IO BufferObject
fromPtr BufferTarget
target Int
numBytes
  where numBytes :: Int
numBytes = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Vector a -> Int
forall a. Storable a => Vector a -> Int
V.length Vector a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined::a)

-- |@replaceVector target v@ replaces the buffer data attached to the
-- buffer object currently bound to @target@ with the supplied
-- 'V.Vector'. Any previous data is deleted.
replaceVector :: forall a. Storable a => BufferTarget -> V.Vector a -> IO ()
replaceVector :: BufferTarget -> Vector a -> IO ()
replaceVector target :: BufferTarget
target v :: Vector a
v = Vector a -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector a
v ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr ->
                           BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
target StateVar (GLsizeiptr, Ptr a, BufferUsage)
-> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
numBytes, Ptr a
ptr, BufferUsage
StaticDraw)
  where numBytes :: GLsizeiptr
numBytes = Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLsizeiptr) -> Int -> GLsizeiptr
forall a b. (a -> b) -> a -> b
$ Vector a -> Int
forall a. Storable a => Vector a -> Int
V.length Vector a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined::a)

-- |Produce a 'Ptr' value to be used as an offset of the given number
-- of bytes.
offsetPtr :: Int -> Ptr a
offsetPtr :: Int -> Ptr a
offsetPtr = WordPtr -> Ptr a
forall a. WordPtr -> Ptr a
wordPtrToPtr (WordPtr -> Ptr a) -> (Int -> WordPtr) -> Int -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> WordPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- |A zero-offset 'Ptr'.
offset0 :: Ptr a
offset0 :: Ptr a
offset0 = Int -> Ptr a
forall a. Int -> Ptr a
offsetPtr 0

-- | A class for things we know how to serialize into an OpenGL
-- buffer.
class BufferSource v where
  fromSource :: BufferTarget -> v -> IO BufferObject

instance Storable a => BufferSource [a] where
  fromSource :: BufferTarget -> [a] -> IO BufferObject
fromSource = BufferTarget -> [a] -> IO BufferObject
forall a. Storable a => BufferTarget -> [a] -> IO BufferObject
makeBuffer

instance Storable a => BufferSource (V.Vector a) where
  fromSource :: BufferTarget -> Vector a -> IO BufferObject
fromSource = BufferTarget -> Vector a -> IO BufferObject
forall a. Storable a => BufferTarget -> Vector a -> IO BufferObject
fromVector

-- | Create an 'ElementArrayBuffer' from a source of 'Word32's.
bufferIndices :: BufferSource (v Word32) => v Word32 -> IO BufferObject
bufferIndices :: v Word32 -> IO BufferObject
bufferIndices = BufferTarget -> v Word32 -> IO BufferObject
forall v. BufferSource v => BufferTarget -> v -> IO BufferObject
fromSource BufferTarget
ElementArrayBuffer