diff --git a/src/Data/VectorSpace/OpenGL.hs b/src/Data/VectorSpace/OpenGL.hs --- a/src/Data/VectorSpace/OpenGL.hs +++ b/src/Data/VectorSpace/OpenGL.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,8 +20,6 @@ module Data.VectorSpace.OpenGL where -import Data.VectorSpace.OpenGL.TH - import Control.Applicative import qualified Data.Foldable as F @@ -31,52 +28,6 @@ import Data.VectorSpace import Graphics.Rendering.OpenGL - --------------------------------------------------------------------------------- --- Scalar instances - -deriveScalar [ ''GLbyte - , ''GLshort - , ''GLint - , ''GLfloat - , ''GLdouble - ] - -instance VectorSpace GLbyte where - type Scalar GLbyte = GLbyte; (*^) = (*) -instance VectorSpace GLshort where - type Scalar GLshort = GLshort; (*^) = (*) -instance VectorSpace GLint where - type Scalar GLint = GLint; (*^) = (*) -instance VectorSpace GLfloat where - type Scalar GLfloat = GLfloat; (*^) = (*) -instance VectorSpace GLdouble where - type Scalar GLdouble = GLdouble; (*^) = (*) - - -instance InnerSpace GLfloat where (<.>) = (*) -instance InnerSpace GLdouble where (<.>) = (*) - -instance AffineSpace GLbyte where - type Diff GLbyte = GLbyte - (.-.) = (-) - (.+^) = (+) -instance AffineSpace GLshort where - type Diff GLshort = GLshort - (.-.) = (-) - (.+^) = (+) -instance AffineSpace GLint where - type Diff GLint = GLint - (.-.) = (-) - (.+^) = (+) -instance AffineSpace GLfloat where - type Diff GLfloat = GLfloat - (.-.) = (-) - (.+^) = (+) -instance AffineSpace GLdouble where - type Diff GLdouble = GLdouble - (.-.) = (-) - (.+^) = (+) -------------------------------------------------------------------------------- -- Vector instances diff --git a/src/Data/VectorSpace/OpenGL/TH.hs b/src/Data/VectorSpace/OpenGL/TH.hs deleted file mode 100644 --- a/src/Data/VectorSpace/OpenGL/TH.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -ddump-splices #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module Data.VectorSpace.OpenGL.TH where - -import Control.Applicative -import Control.Monad -import Data.AdditiveGroup -import Data.VectorSpace - -import Language.Haskell.TH - -deriveScalar ts = concat <$> forM (map conT ts) (\t -> [d| - instance AdditiveGroup $t where zeroV = 0; (^+^) = (+); negateV = negate - |]) - -{- http://stackoverflow.com/questions/8410761/using-template-haskell-how-can-i-splice-the-same-type-into-multiple-locations - -deriveScalarVectorSpace ts = concat <$> forM (map conT ts) (\t -> [d| - instance VectorSpace $t where type Scalar $t = $t; (*^) = (*) - |]) --} diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.VectorSpace +import Graphics.Rendering.OpenGL.GL + +import Control.Applicative +import Data.AEq +import Data.Int +import Foreign.C.Types + +import Test.Framework +import Test.Framework.TH +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.All + +addAssoc a b c = (a ^+^ b) ^+^ c ~== a ^+^ (b ^+^ c) +addId a = (a ^+^ zeroV) ~== a +addNeg a = x ~== y && y ~== zeroV + where x = a ^+^ negateV a + y = negateV a ^+^ a +addComm a b = (a ^+^ b) ~== (b ^+^ a) + +prop_addAssocShort = addAssoc :: GLshort -> GLshort -> GLshort -> Bool +prop_addIdShort = addId :: GLshort -> Bool +prop_addNegShort = addNeg :: GLshort -> Bool +prop_addCommShort = addComm :: GLshort -> GLshort -> Bool + +prop_addAssocInt = addAssoc :: GLint -> GLint -> GLint -> Bool +prop_addIdInt = addId :: GLint -> Bool +prop_addNegInt = addNeg :: GLint -> Bool +prop_addCommInt = addComm :: GLint -> GLint -> Bool + +prop_addAssocFloat = addAssoc :: GLfloat -> GLfloat -> GLfloat -> Bool +prop_addIdFloat = addId :: GLfloat -> Bool +prop_addNegFloat = addNeg :: GLfloat -> Bool +prop_addCommFloat = addComm :: GLfloat -> GLfloat -> Bool + +prop_addAssocDouble = addAssoc :: GLdouble -> GLdouble -> GLdouble -> Bool +prop_addIdDouble = addId :: GLdouble -> Bool +prop_addNegDouble = addNeg :: GLdouble -> Bool +prop_addCommDouble = addComm :: GLdouble -> GLdouble -> Bool + +scMulDistr1 s v1 v2 = + s *^ (v1 ^+^ v2) ~== (s *^ v1) + (s *^ v2) +scMulDistr2 s1 s2 v = + (s1 + s2) *^ v ~== (s1 *^ v) + (s2 *^ v) +scMulRespect s1 s2 v = + s1 *^ (s2 *^ v) ~== (s1 * s2) *^ v +scMulId v = 1 *^ v ~== v + +prop_scMulDistr1Short = scMulDistr1 :: GLshort -> GLshort -> GLshort -> Bool +prop_scMulDistr2Short = scMulDistr2 :: GLshort -> GLshort -> GLshort -> Bool +prop_scMulRespectShort = scMulRespect :: GLshort -> GLshort -> GLshort -> Bool +prop_scMulIdShort = scMulId :: GLshort -> Bool + +prop_scMulDistr1Int = scMulDistr1 :: GLint -> GLint -> GLint -> Bool +prop_scMulDistr2Int = scMulDistr2 :: GLint -> GLint -> GLint -> Bool +prop_scMulRespectInt = scMulRespect :: GLint -> GLint -> GLint -> Bool +prop_scMulIdInt = scMulId :: GLint -> Bool + +prop_scMulDistr1Float = scMulDistr1 :: GLfloat -> GLfloat -> GLfloat -> Bool +prop_scMulDistr2Float = scMulDistr2 :: GLfloat -> GLfloat -> GLfloat -> Bool +prop_scMulRespectFloat = scMulRespect :: GLfloat -> GLfloat -> GLfloat -> Bool +prop_scMulIdFloat = scMulId :: GLfloat -> Bool + +prop_scMulDistr1Double = scMulDistr1 :: GLdouble -> GLdouble -> GLdouble -> Bool +prop_scMulDistr2Double = scMulDistr2 :: GLdouble -> GLdouble -> GLdouble -> Bool +prop_scMulRespectDouble = scMulRespect :: GLdouble -> GLdouble -> GLdouble -> Bool +prop_scMulIdDouble = scMulId :: GLdouble -> Bool + +innerSym x y = (x <.> y) ~== (y <.> x) +innerLinMul a x y = ((a *^ x) <.> y) ~== a * (x <.> y) +innerLinAdd x y z = ((x ^+^ y) <.> z) ~== (x <.> z) + (y <.> z) + +prop_innerSymFloat = innerSym :: GLfloat -> GLfloat -> Bool +prop_innerLinMulFloat = innerLinMul :: GLfloat -> GLfloat -> GLfloat -> Bool +prop_innerLinAddFloat = innerLinAdd :: GLfloat -> GLfloat -> GLfloat -> Bool + +prop_innerSymDouble = innerSym :: GLdouble -> GLdouble -> Bool +prop_innerLinMulDouble = innerLinMul :: GLdouble -> GLdouble -> GLdouble -> Bool +prop_innerLinAddDouble = innerLinAdd :: GLdouble -> GLdouble -> GLdouble -> Bool + + +instance Arbitrary CShort where + arbitrary = fromIntegral <$> (arbitrary :: Gen Int16) +instance Arbitrary CInt where + arbitrary = fromIntegral <$> (arbitrary :: Gen Int32) +instance Arbitrary CFloat where + arbitrary = realToFrac <$> (arbitrary :: Gen Float) +instance Arbitrary CDouble where + arbitrary = realToFrac <$> (arbitrary :: Gen Double) + +main :: IO () +main = $(defaultMainGenerator) diff --git a/vector-space-opengl.cabal b/vector-space-opengl.cabal --- a/vector-space-opengl.cabal +++ b/vector-space-opengl.cabal @@ -1,5 +1,5 @@ Name: vector-space-opengl -Version: 0.1 +Version: 0.2 Synopsis: Instances of vector-space classes for OpenGL types Description: Instances of classes for 'OpenGL' types. License: BSD3 @@ -12,10 +12,21 @@ Library exposed-modules: Data.VectorSpace.OpenGL - other-modules: Data.VectorSpace.OpenGL.TH hs-source-dirs: src - extensions: TemplateHaskell, TypeFamilies, UndecidableInstances - build-depends: base == 4.*, - OpenGL == 2.4.*, - template-haskell == 2.6.*, - vector-space == 0.8.* + extensions: TypeFamilies, UndecidableInstances + build-depends: base >= 4.0 && < 5, + OpenGL >= 2.6.0, + vector-space >= 0.8.0 + +Test-Suite test-vector-space-opengl + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Tests.hs + build-depends: base, + OpenGL, + ieee754, + vector-space, + QuickCheck >= 2.5, + test-framework >= 0.8, + test-framework-quickcheck2 >= 0.3, + test-framework-th >= 0.2