diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Anthony Cowley + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anthony Cowley nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Vinyl/Reflect.hs b/src/Data/Vinyl/Reflect.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vinyl/Reflect.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds, TypeOperators, FlexibleContexts, FlexibleInstances, + ScopedTypeVariables #-} +-- | Reflection utilities for vinyl records. +module Data.Vinyl.Reflect where +import Data.Foldable (Foldable, foldMap) +import Data.Functor.Identity +import Data.Monoid (Sum(..)) +import Data.Vinyl (Rec, PlainRec, (:::)) +import Foreign.Storable (Storable(sizeOf)) +import GHC.TypeLits (SingI(..), fromSing, Sing) + +-- | List all field names in a record. +class HasFieldNames a where + fieldNames :: a -> [String] + +instance HasFieldNames (Rec '[] f) where + fieldNames _ = [] + +instance (SingI sy, HasFieldNames (Rec ts Identity)) + => HasFieldNames (Rec ((sy:::t) ': ts) Identity) where + fieldNames _ = fromSing (sing::Sing sy) : fieldNames (undefined::PlainRec ts) + +-- | Compute the size in bytes of of each field in a record. +class HasFieldSizes a where + fieldSizes :: a -> [Int] + +instance HasFieldSizes (Rec '[] f) where + fieldSizes _ = [] + +instance (HasFieldSizes (Rec ts Identity), Storable t) + => HasFieldSizes (Rec ((sy:::t) ': ts) Identity) where + fieldSizes _ = sizeOf (undefined::t) : fieldSizes (undefined::PlainRec ts) + +-- | Compute the dimensionality of each field in a record. This is +-- primarily useful for things like the small finite vector types +-- provided by "Linear". +class HasFieldDims a where + fieldDims :: a -> [Int] + +instance HasFieldDims (Rec '[] f) where + fieldDims _ = [] + +instance (HasFieldDims (PlainRec ts), Foldable v, Num (v a)) + => HasFieldDims (PlainRec (sy:::v a ': ts)) where + fieldDims _ = getSum (foldMap (const (Sum 1)) (0::v a)) + : fieldDims (undefined::PlainRec ts) diff --git a/src/Graphics/VinylGL.hs b/src/Graphics/VinylGL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/VinylGL.hs @@ -0,0 +1,5 @@ +module Graphics.VinylGL (module Graphics.VinylGL.Uniforms, + module Graphics.VinylGL.Vertex) + where +import Graphics.VinylGL.Uniforms +import Graphics.VinylGL.Vertex diff --git a/src/Graphics/VinylGL/Uniforms.hs b/src/Graphics/VinylGL/Uniforms.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/VinylGL/Uniforms.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds, TypeOperators, FlexibleContexts, FlexibleInstances, + GADTs, ScopedTypeVariables, ConstraintKinds #-} +-- | Tools for binding vinyl records to GLSL program uniform +-- parameters. The most common usage is to use the 'setUniforms' +-- function to set each field of a 'PlainRec' to the GLSL uniform +-- parameter with the same name. This verifies that each field of the +-- record corresponds to a uniform parameter of the given shader +-- program, and that the types all agree. +module Graphics.VinylGL.Uniforms (setAllUniforms, setSomeUniforms, setUniforms, + HasFieldGLTypes(..)) where +import Control.Applicative ((<$>)) +import Data.Foldable (traverse_) +import Data.Functor.Identity +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Data.Vinyl +import Graphics.GLUtil (HasVariableType(..), ShaderProgram(..), AsUniform(..)) +import Graphics.Rendering.OpenGL as GL +import Data.Vinyl.Reflect (HasFieldNames(..)) + +-- | Provide the 'GL.VariableType' of each field in a 'Rec'. The list +-- of types has the same order as the fields of the 'Rec'. +class HasFieldGLTypes a where + fieldGLTypes :: a -> [GL.VariableType] + +instance HasFieldGLTypes (Rec '[] f) where + fieldGLTypes _ = [] + +instance (HasVariableType t, HasFieldGLTypes (PlainRec ts)) + => HasFieldGLTypes (PlainRec (sy:::t ': ts)) where + fieldGLTypes _ = variableType (undefined::t) + : fieldGLTypes (undefined::PlainRec ts) + +type UniformFields a = (HasFieldNames a, HasFieldGLTypes a, SetUniformFields a) + +-- | Set GLSL uniform parameters from a 'PlainRec'. A check is +-- performed to verify that /all/ uniforms used by a program are +-- represented by the record type. In other words, the record is a +-- superset of the parameters used by the program. +setAllUniforms :: forall ts. UniformFields (PlainRec ts) + => ShaderProgram -> PlainRec ts -> IO () +setAllUniforms s x = case checks of + Left msg -> error msg + Right _ -> setUniformFields locs x + where fnames = fieldNames (undefined::PlainRec ts) + checks = do namesCheck "record" (M.keys $ uniforms s) fnames + typesCheck True (snd <$> uniforms s) fieldTypes + fieldTypes = M.fromList $ + zip fnames (fieldGLTypes (undefined::PlainRec ts)) + locs = map (fmap fst . (`M.lookup` uniforms s)) fnames +{-# INLINE setAllUniforms #-} + +-- | Set GLSL uniform parameters from a 'PlainRec' representing a +-- subset of all uniform parameters used by a program. +setUniforms :: forall ts. UniformFields (PlainRec ts) + => ShaderProgram -> PlainRec ts -> IO () +setUniforms s x = case checks of + Left msg -> error msg + Right _ -> setUniformFields locs x + where fnames = fieldNames (undefined::PlainRec ts) + checks = do namesCheck "GLSL program" fnames (M.keys $ uniforms s) + typesCheck False fieldTypes (snd <$> uniforms s) + fieldTypes = M.fromList $ + zip fnames (fieldGLTypes (undefined::PlainRec ts)) + locs = map (fmap fst . (`M.lookup` uniforms s)) fnames +{-# INLINE setUniforms #-} + +-- | Set GLSL uniform parameters from those fields of a 'PlainRec' +-- whose names correspond to uniform parameters used by a program. +setSomeUniforms :: forall ts. UniformFields (PlainRec ts) + => ShaderProgram -> PlainRec ts -> IO () +setSomeUniforms s x = case typesCheck' True (snd <$> uniforms s) fieldTypes of + Left msg -> error msg + Right _ -> setUniformFields locs x + where fnames = fieldNames (undefined::PlainRec ts) + {-# INLINE fnames #-} + fieldTypes = M.fromList . zip fnames $ + fieldGLTypes (undefined::PlainRec ts) + {-# INLINE fieldTypes #-} + locs = map (fmap fst . (`M.lookup` uniforms s)) fnames + {-# INLINE locs #-} +{-# INLINE setSomeUniforms #-} + +-- | @namesCheck blame little big@ checks that each name in @little@ is +-- an element of @big@. +namesCheck :: String -> [String] -> [String] -> Either String () +namesCheck blame little big = mapM_ aux little + where big' = S.fromList big + aux x | x `S.member` big' = Right () + | otherwise = Left $ "Field "++x++" not found in "++blame + +-- | @typesChecks blame little big@ checks that each (name,type) pair +-- in @little@ is a member of @big@. +typesCheck :: Bool + -> M.Map String GL.VariableType -> M.Map String GL.VariableType + -> Either String () +typesCheck blame little big = mapM_ aux $ M.toList little + where aux (n,t) + | Just True == (glTypeEquiv t <$> M.lookup n big) = return () + | otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big)) + msg n t t' = let (expected, actual) = if blame + then (t,t') + else (t',t) + in "Record and GLSL type disagreement on field "++n++ + ": GLSL expected "++expected++ + ", record provides "++actual + +-- | @typesCheck' blame little big@ checks that each (name,type) pair +-- in the intersection of @little@ and @big@ is consistent. +typesCheck' :: Bool + -> M.Map String GL.VariableType -> M.Map String GL.VariableType + -> Either String () +typesCheck' blame little big = mapM_ aux $ M.toList little + where aux (n,t) + | fromMaybe True (glTypeEquiv t <$> M.lookup n big) = return () + | otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big)) + msg n t t' = let (expected, actual) = if blame + then (t,t') + else (t',t) + in "Record and GLSL type disagreement on field "++n++ + ": GLSL expected "++expected++ + ", record provides "++actual + +-- The equivalence on 'GL.VariableType's we need identifies Samplers +-- with Ints because this is how GLSL represents samplers. +glTypeEquiv' :: GL.VariableType -> GL.VariableType -> Bool +glTypeEquiv' GL.Sampler1D GL.Int' = True +glTypeEquiv' GL.Sampler2D GL.Int' = True +glTypeEquiv' GL.Sampler3D GL.Int' = True +glTypeEquiv' x y = x == y + +-- We define our own equivalence relation on types because we don't +-- have unique Haskell representations for every GL type. For example, +-- the GLSL sampler types (e.g. Sampler2D) are just GLint in Haskell. +glTypeEquiv :: VariableType -> VariableType -> Bool +glTypeEquiv x y = glTypeEquiv' x y || glTypeEquiv' y x + +class SetUniformFields a where + setUniformFields :: [Maybe UniformLocation] -> a -> IO () + +instance SetUniformFields (Rec '[] f) where + setUniformFields _ _ = return () + {-# INLINE setUniformFields #-} + +instance (AsUniform t, SetUniformFields (PlainRec ts)) + => SetUniformFields (PlainRec ((sy:::t) ': ts)) where + setUniformFields [] _ = error "Ran out of UniformLocations" + setUniformFields (loc:locs) (Identity x :& xs) = + do traverse_ (asUniform x) loc + setUniformFields locs xs + {-# INLINABLE setUniformFields #-} diff --git a/src/Graphics/VinylGL/Vertex.hs b/src/Graphics/VinylGL/Vertex.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/VinylGL/Vertex.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators, GADTs, BangPatterns, + FlexibleInstances, FlexibleContexts, KindSignatures, RankNTypes, + ConstraintKinds #-} +-- | Utilities for working with vertex buffer objects (VBOs) filled +-- with vertices represented as vinyl records. +module Graphics.VinylGL.Vertex (bufferVertices, bindVertices, reloadVertices, + deleteVertices, enableVertices, enableVertices', + BufferedVertices(..), fieldToVAD) where +import Control.Applicative +import Control.Arrow (second) +import Data.Foldable (Foldable, foldMap) +import Data.List (find) +import qualified Data.Map as M +import Data.Monoid (Sum(..)) +import Data.Proxy (Proxy(..)) +import qualified Data.Vector.Storable as V +import Data.Vinyl ((:::)(..), PlainRec, Implicit(..), Elem) +import Foreign.Ptr (plusPtr) +import Foreign.Storable +import GHC.TypeLits (Sing, SingI(..), fromSing) +import Graphics.GLUtil hiding (Elem) +import Graphics.Rendering.OpenGL (VertexArrayDescriptor(..), bindBuffer, + ($=), BufferTarget(..)) +import qualified Graphics.Rendering.OpenGL as GL + +import Data.Vinyl.Reflect +import Graphics.VinylGL.Uniforms + +-- | Representation of a VBO whose type describes the vertices. +newtype BufferedVertices (fields::[*]) = + BufferedVertices { getVertexBuffer :: GL.BufferObject } + +-- | Load vertex data into a GPU-accessible buffer. +bufferVertices :: (Storable (PlainRec rs), BufferSource (v (PlainRec rs))) + => v (PlainRec rs) -> IO (BufferedVertices rs) +bufferVertices = fmap BufferedVertices . fromSource ArrayBuffer + +-- | Reload 'BufferedVertices' with a 'V.Vector' of new vertex data. +reloadVertices :: Storable (PlainRec rs) + => BufferedVertices rs -> V.Vector (PlainRec 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 + +-- | 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 f rs. ViableVertex (PlainRec rs) + => ShaderProgram -> f rs -> IO (Maybe String) +enableVertices s _ = enableAttribs s (Proxy::Proxy (PlainRec rs)) + +-- | Behaves like 'enableVertices', but raises an exception if the +-- supplied vertex record does not include a field required by the +-- shader. +enableVertices' :: forall f rs. ViableVertex (PlainRec rs) + => ShaderProgram -> f rs -> IO () +enableVertices' s _ = enableAttribs s (Proxy::Proxy (PlainRec rs)) >>= + maybe (return ()) error + +-- | Produce a 'GL.VertexArrayDescriptor' for a particular field of a +-- vertex record. +fieldToVAD :: forall sy v a r rs. + (r ~ (sy ::: v a), HasFieldNames (PlainRec rs), + HasFieldSizes (PlainRec rs), HasGLType a, Storable (PlainRec rs), + Num (v a), SingI sy, Foldable v, Implicit (Elem r rs)) => + r -> Proxy (PlainRec rs) -> GL.VertexArrayDescriptor a +fieldToVAD _ _ = GL.VertexArrayDescriptor dim + (glType (undefined::a)) + (fromIntegral $ + sizeOf (undefined::PlainRec rs)) + (offset0 `plusPtr` offset) + where dim = getSum $ foldMap (const (Sum 1)) (0::v a) + Just offset = lookup n $ namesAndOffsets (undefined::PlainRec rs) + n = fromSing (sing::Sing sy) + +-- Constraint alias capturing the requirements of a vertex type. +type ViableVertex t = (HasFieldNames t, HasFieldSizes t, HasFieldDims t, + HasFieldGLTypes t, Storable t) + +enableAttribs :: forall v. ViableVertex v + => ShaderProgram -> Proxy v -> IO (Maybe String) +enableAttribs s p = go (map (second snd) $ M.assocs (attribs s)) + where go [] = return Nothing + go ((n,t):ns) = case find ((== n) . fieldName) fs of + Nothing -> return (Just $ "GLSL expecting "++n) + Just fd + | fieldType fd == t -> + do enableAttrib s n + setAttrib s n GL.ToFloat $ + descriptorVAD p fd + go ns + | otherwise -> return . Just $ + "Type mismatch in "++n + fs = fieldDescriptors (undefined::v) + +namesAndOffsets :: (HasFieldNames t, HasFieldSizes t) => t -> [(String,Int)] +namesAndOffsets x = zip (fieldNames x) (scanl (+) 0 $ fieldSizes x) + +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 + +descriptorVAD :: forall t a. Storable t + => Proxy t -> FieldDescriptor -> VertexArrayDescriptor a +descriptorVAD _ fd = VertexArrayDescriptor (fromIntegral $ fieldDim fd) + (variableDataType $ fieldType fd) + (fromIntegral $ + sizeOf (undefined::t)) + (offset0 `plusPtr` fieldOffset fd) diff --git a/tests/BasicTest.hs b/tests/BasicTest.hs new file mode 100644 --- /dev/null +++ b/tests/BasicTest.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +import Data.Proxy +import Data.Vinyl +import Data.Word +import Foreign.Ptr (nullPtr, plusPtr) +import Graphics.Rendering.OpenGL (DataType(..), GLfloat, + VertexArrayDescriptor(..)) +import Graphics.VinylGL +import Linear (V1(..), V3(..)) +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (hUnitTestToTests) +import Test.HUnit (Test(..), (~=?)) + +type Pos = "vpos" ::: V3 GLfloat +type Tag = "tagByte" ::: V1 Word8 + +tag :: Tag +tag = Field + +type Vertex = PlainRec [Pos, Tag] + +--testVad :: VertexArrayDescriptor Word8 +testVad :: Test +testVad = TestLabel "Sample VAD Creation" $ + vad ~=? fieldToVAD tag (Proxy::Proxy Vertex) + where vad = VertexArrayDescriptor 1 UnsignedByte 13 (nullPtr `plusPtr` 12) + +main :: IO () +main = defaultMain . hUnitTestToTests $ testVad + + + diff --git a/vinyl-gl.cabal b/vinyl-gl.cabal new file mode 100644 --- /dev/null +++ b/vinyl-gl.cabal @@ -0,0 +1,43 @@ +name: vinyl-gl +version: 0.1.0.0 +synopsis: Utilities for working with OpenGL's GLSL shading language and vinyl records. +description: Using "Data.Vinyl" records (similar in spirit to @HList@) + to carry GLSL uniform parameters and vertex data enables + library code to reflect over the types of the data to + facilitate interaction between Haskell and GLSL. See the + @examples@ directory in the repository for more + information. +license: BSD3 +license-file: LICENSE +author: Anthony Cowley +maintainer: acowley@gmail.com +copyright: Copyright (C) 2013 Anthony Cowley +category: Graphics +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: http://github.com/acowley/vinyl-gl.git + +library + exposed-modules: Data.Vinyl.Reflect, + Graphics.VinylGL, + Graphics.VinylGL.Uniforms, + Graphics.VinylGL.Vertex + -- other-modules: + build-depends: base >= 4.6 && < 5, transformers >= 0.3, vinyl >= 0.1.3, + containers >= 0.5, GLUtil >= 0.6.4, OpenGL >= 2.8, + tagged >= 0.4, vector >= 0.10, linear >= 1.1.3 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: BasicTest.hs + ghc-options: -Wall -O2 + default-language: Haskell2010 + build-depends: base >= 4.6 && < 5, + test-framework, test-framework-hunit, HUnit, + linear, vinyl, vinyl-gl, OpenGL, tagged