<commit_before>{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- |

module Graphics.RecordGL.Vertex (bufferVertices, BufferedVertices(..)) where

import           Foreign.Storable          (Storable)
import           GHC.TypeLits
import           Graphics.GLUtil           hiding (Elem, throwError)
import           Graphics.RecordGL.Util
import           Graphics.Rendering.OpenGL (BufferTarget (..),
                                            VertexArrayDescriptor (..),
                                            bindBuffer, ($=))
import qualified Graphics.Rendering.OpenGL as GL

-- | Representation of a VBO whose type describes the vertices.
data BufferedVertices a  =
  BufferedVertices {getVertexBuffer :: GL.BufferObject}

bufferVertices :: (Storable rs, BufferSource (v rs)) => v rs -> IO (BufferedVertices rs)
bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer
<commit_msg>Added rest of vertex utility functions.<commit_after>{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- | Utilities for working with vertex buffer objects (VBOs) filled
-- with vertices represented as `Records`.
module Graphics.RecordGL.Vertex (bufferVertices, bindVertices, reloadVertices
                                , deleteVertices, enableVertices, enableVertices'
                                , enableVertexFields, ViableVertex, BufferedVertices(..)) where

import           Graphics.RecordGL.Uniforms

import           BasePrelude
import qualified Data.Map                   as M
import qualified Data.Vector.Storable       as V
import           Foreign.Ptr                (plusPtr)
import           Foreign.Storable
import           GHC.TypeLits
import           Graphics.GLUtil            hiding (Elem, throwError)
import           Graphics.RecordGL.Util
import           Graphics.Rendering.OpenGL  (BufferTarget (..),
                                             VertexArrayDescriptor (..),
                                             bindBuffer, ($=))
import qualified Graphics.Rendering.OpenGL  as GL

-- | Representation of a VBO whose type describes the vertices.
data BufferedVertices a  =
  BufferedVertices {getVertexBuffer :: GL.BufferObject}

-- | Load vertex data into a GPU-accessible buffer.
bufferVertices :: (Storable rs, BufferSource (v rs)) => v rs -> IO (BufferedVertices rs)
bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer

-- | Reload 'BufferedVertices' with a 'V.Vector' of new vertex data.
reloadVertices :: Storable rs
               => BufferedVertices rs
               -> V.Vector rs
               -> IO ()
reloadVertices b v = do
  bindBuffer ArrayBuffer $= Just (getVertexBuffer b)
  replaceVector ArrayBuffer v

-- | Delete the object name associated with 'BufferedVertices'
deleteVertices :: BufferedVertices a -> IO ()
deleteVertices = GL.deleteObjectNames . (: []) . getVertexBuffer

-- | Bind previously-buffered vertex data.
bindVertices :: BufferedVertices a -> IO ()
bindVertices = (bindBuffer ArrayBuffer $=) . Just . getVertexBuffer

-- | Constraint alias capturing the requirements of a vertex type.
type ViableVertex t = (HasFields t, HasFieldSizes t, HasFieldDims t,
                       HasFieldGLTypes t, Storable t)

-- | Line up a shader's attribute inputs with a vertex record. This
-- maps vertex fields to GLSL attributes on the basis of record field names
-- on the Haskell side, and variable names on the GLSL side.
enableVertices :: forall r. ViableVertex r
               => ShaderProgram -> r -> IO (Maybe String)
enableVertices = enableAttribs

-- | Behaves like 'enableVertices', but raises an exception if the
-- supplied vertex record does not include a field required by the
-- shader.
enableVertices' :: forall r. ViableVertex r
               => ShaderProgram -> r -> IO ()
enableVertices' s r = enableAttribs s r >>=
                      maybe (return ()) error

data FieldDescriptor = FieldDescriptor { fieldName   :: String
                                       , fieldOffset :: Int
                                       , fieldDim    :: Int
                                       , fieldType   :: GL.VariableType }
                       deriving Show

fieldDescriptors :: ViableVertex t => t -> [FieldDescriptor]
fieldDescriptors x = getZipList $
                     FieldDescriptor <$> zl (fieldNames x)
                                     <*> zl (scanl (+) 0 $ fieldSizes x)
                                     <*> zl (fieldDims x)
                                     <*> zl (fieldGLTypes x)
  where zl = ZipList

-- | Bind some of a shader's attribute inputs to a vertex record. This
-- is useful when the inputs of a shader are split across multiple
-- arrays.
enableVertexFields :: forall r. ViableVertex r
                   => ShaderProgram -> r -> IO ()
enableVertexFields s r = enableSomeAttribs s r >>= maybe (return ()) error

-- | Do not raise an error is some of a shader's inputs are not bound
-- by a vertex record.
enableSomeAttribs :: forall v. ViableVertex v
                  => ShaderProgram -> v -> IO (Maybe String)
enableSomeAttribs s p = go $ fieldDescriptors (undefined::v)
  where go [] = return Nothing
        go (fd:fds) =
          let n = fieldName fd
              shaderAttribs = attribs s
          in case M.lookup n shaderAttribs of
               Nothing -> return (Just $ "Unexpected attribute " ++ n)
               Just (_,t)
                 | fieldType fd == t -> do enableAttrib s n
                                           setAttrib s n GL.ToFloat $
                                             descriptorVAD p fd
                                           go fds
                 | otherwise -> return . Just $ "Type mismatch in " ++ n

enableAttribs :: forall v. ViableVertex v
              => ShaderProgram -> v -> IO (Maybe String)
enableAttribs s p = go (map (second snd) $ M.assocs (attribs s))
  where
    go [] = return Nothing
    go ((l, t):as) = case find ((== l) . fieldName) fs of
                       Nothing -> return (Just $ "GLSL expecting " ++ l)
                       Just fd
                         | fieldType fd == t -> do
                           enableAttrib s l
                           setAttrib s l GL.ToFloat $
                             descriptorVAD p fd
                           go as
                         | otherwise -> return . Just $ "Type mismatch in " ++ l
    fs = fieldDescriptors p

descriptorVAD :: forall t a. Storable t
              => t -> FieldDescriptor -> VertexArrayDescriptor a
descriptorVAD _ fd = VertexArrayDescriptor (fromIntegral $ fieldDim fd)
                                           (variableDataType $ fieldType fd)
                                           (fromIntegral $
                                            sizeOf (undefined::t))
                                           (offset0 `plusPtr` fieldOffset fd)

{'fraction_non_alphanumeric': 0.08732989826925618, 'fraction_numerical': 0.0002642356982428326, 'mean_word_length': 1.7318657524359438, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 46, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 36, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4988397', 'n_tokens_mistral': 1975, 'n_tokens_neox': 1939, 'n_words': 632}