module Graphics.Luminance.Core.Geometry where
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Data.DList as DL ( empty, snoc )
import Data.Foldable ( toList )
import Data.Map as M ( empty, insert, lookup, size )
import Data.Proxy ( Proxy(..) )
import Data.Word ( Word32 )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Utils ( with )
import Foreign.Storable ( Storable(..) )
import Graphics.GL
import Graphics.Luminance.Core.Buffer
import Graphics.Luminance.Core.RW ( W )
import Graphics.Luminance.Core.Vertex
data VertexArray = VertexArray {
vertexArrayID :: GLuint
, vertexArrayMode :: GLenum
, vertexArrayCount :: GLsizei
} deriving (Eq,Show)
data Geometry
= DirectGeometry VertexArray
| IndexedGeometry VertexArray
deriving (Eq,Show)
data GeometryMode
= Point
| Line
| Triangle
deriving (Eq,Show)
fromGeometryMode :: GeometryMode -> GLenum
fromGeometryMode m = case m of
Point -> GL_POINTS
Line -> GL_LINES
Triangle -> GL_TRIANGLES
createGeometry :: forall f m v. (Foldable f,MonadResource m,Storable v,Vertex v)
=> f v
-> Maybe (f Word32)
-> GeometryMode
-> m Geometry
#ifdef __GL45
createGeometry vertices indices mode = do
vid <- liftIO . alloca $ \p -> do
glCreateVertexArrays 1 p
peek p
_ <- register . with vid $ glDeleteVertexArrays 1
(vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb)
writeWhole vreg vertices
liftIO $ glVertexArrayVertexBuffer vid vertexBindingIndex (bufferID vbo) 0 (fromIntegral $ sizeOf (undefined :: v))
_ <- setFormatV vid 0 0 (Proxy :: Proxy v)
case indices of
Just indices' -> do
let ixNb = length indices'
(ireg :: Region W Word32,ibo) <- createBuffer_ $ newRegion (fromIntegral ixNb)
writeWhole ireg indices'
glVertexArrayElementBuffer vid (bufferID ibo)
pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb)
Nothing -> pure . DirectGeometry $ VertexArray vid mode' (fromIntegral vertNb)
where
vertNb = length vertices
mode' = fromGeometryMode mode
#elif defined(__GL33)
createGeometry vertices indices mode = do
vid <- liftIO . alloca $ \p -> do
glGenVertexArrays 1 p
peek p
_ <- register . with vid $ glDeleteVertexArrays 1
glBindVertexArray vid
(vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb)
writeWhole vreg vertices
liftIO $ glBindBuffer GL_ARRAY_BUFFER (bufferID vbo)
_ <- setFormatV vid 0 0 (Proxy :: Proxy v)
case indices of
Just indices' -> do
let ixNb = length indices'
(ireg :: Region W Word32,ibo) <- createBuffer_ $ newRegion (fromIntegral ixNb)
writeWhole ireg indices'
glBindBuffer GL_ELEMENT_ARRAY_BUFFER(bufferID ibo)
glBindVertexArray 0
pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb)
Nothing -> do
glBindVertexArray 0
pure . DirectGeometry $ VertexArray vid mode' (fromIntegral vertNb)
where
vertNb = length vertices
mode' = fromGeometryMode mode
#endif
nubDirect :: (Foldable f,Ord a,Integral i) => f a -> ([a],[i])
nubDirect dvertices = (toList uvertices,toList indices)
where
(uvertices,indices,_) = foldl rmDup (DL.empty,DL.empty,M.empty) dvertices
rmDup (uverts,inds,seen) v =
case M.lookup v seen of
Just i -> (uverts,inds `snoc` i,seen)
Nothing ->
let s = fromIntegral (size seen)
in (uverts `snoc` v,inds `snoc` s,insert v s seen)