diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} + import Criterion.Main import Data.Vector.Generic as VG @@ -7,6 +7,7 @@ import Data.Vector.Unboxed as VU import Data.Vec3 +import qualified Data.Vec3.Unboxed.Contiguous as C oXYZ :: (Double, Double, Double) @@ -20,64 +21,55 @@ n :: Int n = 1000000 + bigN :: Int bigN = n * 10 -foo :: Vec3 v => v -> v -> Double -foo v1 v2 = x1 + x2 - where - (x1, _, _) = toXYZ v1 - (x2, _, _) = toXYZ v2 -{-# INLINE foo #-} - -- Access to whole elements -test :: (Show a, Vec3 a, VG.Vector v a) => v a -> v a -> IO () -test v v2 = do - let !vr = VG.zipWith (<+>) v v - return () -{-# INLINE test #-} +testWhole :: (Vec3 a, VG.Vector v a) => v a -> v a -> Benchmarkable +testWhole v v2 = whnf (uncurry $ VG.zipWith (<+>)) (v, v2) -- Access to x components of elements -testComp :: (Show a, Vec3 a, VG.Vector v a, VG.Vector v Double) => v a -> v a -> IO () -testComp v v2 = do - let !vr = VG.zipWith (foo) v v - return () -{-# INLINE testComp #-} +testComp :: (Vec3 a, VG.Vector v a, VG.Vector v Double) => v a -> v a -> Benchmarkable +testComp v v' = whnf (uncurry $ VG.zipWith foo) (v, v') + where + foo v1 v2 = x1 + x2 + where + (x1, _, _) = toXYZ v1 + (x2, _, _) = toXYZ v2 -- zipWith using generic dot product -testDotM :: (Show a, Vec3 a, VG.Vector v a, VG.Vector v Double) => v a -> v a -> IO () -testDotM v v2 = do - let o = fromXYZ oXYZ - m = fromRows (o, o, o) - dotM' e1 e2 = dotM e1 e2 m - !vr = VG.zipWith dotM' v v2 - return () -{-# INLINE testDotM #-} +testDotM :: (Vec3 a, VG.Vector v a, VG.Vector v Double) => v a -> v a -> Benchmarkable +testDotM v v2 = whnf (uncurry $ VG.zipWith dotM') (v, v2) + where + o = fromXYZ oXYZ + m = fromRows (o, o, o) + dotM' e1 e2 = dotM e1 e2 m -- Note that source arrays are not forced in test functions. -tv :: VU.Vector TUVec3 +tv :: VU.Vector UVec3 tv = VG.replicate n $ fromXYZ oXYZ -uv :: VU.Vector UVec3 -uv = VG.replicate n $ fromXYZ oXYZ +cv :: VU.Vector C.UVec3 +cv = VG.replicate n $ fromXYZ oXYZ sv :: VS.Vector SVec3 sv = VG.replicate n $ fromXYZ oXYZ -tv' :: VU.Vector TUVec3 +tv' :: VU.Vector UVec3 tv' = VG.replicate n $ fromXYZ oXYZ' -uv' :: VU.Vector UVec3 -uv' = VG.replicate n $ fromXYZ oXYZ' +cv' :: VU.Vector C.UVec3 +cv' = VG.replicate n $ fromXYZ oXYZ' sv' :: VS.Vector SVec3 @@ -88,11 +80,11 @@ bsv = VG.replicate bigN $ fromXYZ oXYZ -buv :: VU.Vector UVec3 -buv = VG.replicate bigN $ fromXYZ oXYZ +bcv :: VU.Vector C.UVec3 +bcv = VG.replicate bigN $ fromXYZ oXYZ -btv :: VU.Vector TUVec3 +btv :: VU.Vector UVec3 btv = VG.replicate bigN $ fromXYZ oXYZ @@ -100,43 +92,44 @@ bsv' = VG.replicate bigN $ fromXYZ oXYZ' -buv' :: VU.Vector UVec3 -buv' = VG.replicate bigN $ fromXYZ oXYZ' +bcv' :: VU.Vector C.UVec3 +bcv' = VG.replicate bigN $ fromXYZ oXYZ' -btv' :: VU.Vector TUVec3 +btv' :: VU.Vector UVec3 btv' = VG.replicate bigN $ fromXYZ oXYZ' +main :: IO () main = defaultMain [ bgroup "zipWith" - [ bench "Storable" $ test sv sv' - , bench "Unboxed (contiguous)" $ test uv uv' - , bench "Unboxed (tuples)" $ test tv tv' + [ bench "SVec/Storable" $ testWhole sv sv' + , bench "UVec/Unboxed" $ testWhole tv tv' + , bench "UVec/Unboxed/Contiguous" $ testWhole cv cv' ] , bgroup "zipWith-by-x" - [ bench "Storable" $ testComp sv sv' - , bench "Unboxed (contiguous)" $ testComp uv uv' - , bench "Unboxed (tuples)" $ testComp tv tv' + [ bench "SVec/Storable" $ testComp sv sv' + , bench "UVec/Unboxed" $ testComp tv tv' + , bench "UVec/Unboxed/Contiguous" $ testComp cv cv' ] , bgroup "zipWith-dotM" - [ bench "Storable" $ testDotM sv sv' - , bench "Unboxed (contiguous)" $ testDotM uv uv' - , bench "Unboxed (tuples)" $ testDotM tv tv' + [ bench "SVec/Storable" $ testDotM sv sv' + , bench "UVec/Unboxed" $ testDotM tv tv' + , bench "UVec/Unboxed/Contiguous" $ testDotM cv cv' ] , bgroup "zipWith 10M" - [ bench "Storable" $ test bsv bsv' - , bench "Unboxed (contiguous)" $ test buv buv' - , bench "Unboxed (tuples)" $ test btv btv' + [ bench "SVec/Storable" $ testWhole bsv bsv' + , bench "UVec/Unboxed" $ testWhole btv btv' + , bench "UVec/Unboxed/Contiguous" $ testWhole bcv bcv' ] , bgroup "zipWith-by-x 10M" - [ bench "Storable" $ testComp bsv bsv' - , bench "Unboxed (contiguous)" $ testComp buv buv' - , bench "Unboxed (tuples)" $ testComp btv btv' + [ bench "SVec/Storable" $ testComp bsv bsv' + , bench "UVec/Unboxed" $ testComp btv btv' + , bench "UVec/Unboxed/Contiguous" $ testComp bcv bcv' ] , bgroup "zipWith-dotM 10M" - [ bench "Storable" $ testDotM bsv bsv' - , bench "Unboxed (contiguous)" $ testDotM buv buv' - , bench "Unboxed (tuples)" $ testDotM btv btv' + [ bench "SVec/Storable" $ testDotM bsv bsv' + , bench "UVec/Unboxed" $ testDotM btv btv' + , bench "UVec/Unboxed/Contiguous" $ testDotM bcv bcv' ] ] diff --git a/simple-vec3.cabal b/simple-vec3.cabal --- a/simple-vec3.cabal +++ b/simple-vec3.cabal @@ -1,53 +1,63 @@ -name: simple-vec3 -version: 0.1.0.1 - -synopsis: Three-dimensional vectors of doubles with basic operations - -description: A class of 3-vectors with a set of basic methods for - geometry operations on vectors and an associated - matrix type. Several instances are provided for - use with "Data.Vector.Unboxed" and - "Data.Vector.Storable" as container types. - -homepage: http://github.com/dzhus/simple-vec3/ -license: BSD3 -license-file: LICENSE -author: Dmitry Dzhus -maintainer: -category: Math, Numerical - -build-type: Simple -cabal-version: >=1.8 -tested-with: GHC == 7.6.1 +name: simple-vec3 +version: 0.2 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: +homepage: https://github.com/dzhus/simple-vec3#readme +bug-reports: https://github.com/dzhus/simple-vec3/issues +synopsis: Three-dimensional vectors of doubles with basic operations +description: + A class of 3-vectors with a set of basic methods for geometry operations on vectors and an associated matrix type. Instances are provided for use with "Data.Vector.Unboxed" and "Data.Vector.Storable" as container types. +category: Math, Numerical +author: Dmitry Dzhus source-repository head - type: git - location: http://github.com/dzhus/simple-vec3/ + type: git + location: https://github.com/dzhus/simple-vec3 library - hs-source-dirs: src - - ghc-options: -Wall -O2 -fllvm - - exposed-modules: - Data.Vec3 - Data.Vec3.Class - Data.Vec3.Storable - Data.Vec3.TUnboxed - Data.Vec3.Unboxed + exposed-modules: + Data.Vec3 + Data.Vec3.Class + Data.Vec3.Unboxed + Data.Vec3.Unboxed.Contiguous + build-depends: + base >=4.9.0.0 && <5, + QuickCheck >=2.8.2, + vector >=0.11.0.0, + vector-th-unbox >=0.2.1.6 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall - build-depends: - base == 4.6.*, - vector == 0.10.* +test-suite pythia-recommender-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + base >=4.9.0.0 && <5, + QuickCheck >=2.8.2, + vector >=0.11.0.0, + vector-th-unbox >=0.2.1.6, + simple-vec3 >=0.2, + tasty >=0.11.0.4, + tasty-quickcheck >=0.8.4, + tasty-th >=0.1.4 + default-language: Haskell2010 + hs-source-dirs: tests + ghc-options: -Wall benchmark simple-vec3-benchmark - type: exitcode-stdio-1.0 - main-is: benchmark/Benchmark.hs - - ghc-options: -Wall -O2 -fllvm -rtsopts - - build-depends: - base == 4.6.*, - criterion == 0.6.*, - simple-vec3, - vector == 0.10.* + type: exitcode-stdio-1.0 + main-is: Benchmark.hs + build-depends: + base >=4.9.0.0 && <5, + QuickCheck >=2.8.2, + vector >=0.11.0.0, + vector-th-unbox >=0.2.1.6, + criterion >=1.1.1.0, + simple-vec3 >=0.2 + default-language: Haskell2010 + hs-source-dirs: benchmark + ghc-options: -Wall diff --git a/src/Data/Vec3.hs b/src/Data/Vec3.hs --- a/src/Data/Vec3.hs +++ b/src/Data/Vec3.hs @@ -1,13 +1,91 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-| + +'Vec3' class and implementations. + +-} + module Data.Vec3 ( Vec3(..) - , UVec3(..) , SVec3(..) - , TUVec3(..) + , UVec3(..) ) where +import Prelude hiding (reverse) + +import Foreign +import Foreign.C.Types + import Data.Vec3.Class -import Data.Vec3.Storable -import Data.Vec3.TUnboxed import Data.Vec3.Unboxed + +import Test.QuickCheck + + +-- | 'Vec3' implementation with 'Foreign.Storable.Storable' instance +-- based on a single contiguous array storage scheme, suitable for use +-- with "Data.Vector.Storable". +-- +-- 'Unbox' instance provides the required index transformations. +-- +-- @ +-- interface: [d1 x y z ; d2 x y z ...], length = N = M / 3 +-- | | | | | | +-- storage: [ d1x d2y d2z ; d2x d2y d2z ...], length = M +-- @ +data SVec3 = SVec3 !CDouble !CDouble !CDouble + deriving (Eq, Show) + + +instance Storable SVec3 where + sizeOf _ = sizeOf (undefined :: CDouble) * 3 + alignment _ = alignment (undefined :: CDouble) + + peek p = do + x <- peekElemOff q 0 + y <- peekElemOff q 1 + z <- peekElemOff q 2 + return $ SVec3 x y z + where + q = castPtr p + {-# INLINE peek #-} + + poke p (SVec3 x y z) = do + pokeElemOff q 0 x + pokeElemOff q 1 y + pokeElemOff q 2 z + where + q = castPtr p + {-# INLINE poke #-} + + +instance Vec3 SVec3 where + newtype Matrix SVec3 = SMatrix (SVec3, SVec3, SVec3) + deriving (Eq, Show) + + fromXYZ (x, y, z) = SVec3 (CDouble x) (CDouble y) (CDouble z) + {-# INLINE fromXYZ #-} + + toXYZ (SVec3 (CDouble x) (CDouble y) (CDouble z)) = (x, y, z) + {-# INLINE toXYZ #-} + + fromRows (r1, r2, r3) = SMatrix (r1, r2, r3) + {-# INLINE fromRows #-} + + toRows (SMatrix (r1, r2, r3)) = (r1, r2, r3) + {-# INLINE toRows #-} + + +instance Arbitrary SVec3 where + arbitrary = do + x <- arbitrary + y <- arbitrary + z <- arbitrary + return $ fromXYZ (x, y, z) + + shrink (SVec3 (CDouble x) (CDouble y) (CDouble z)) = + map fromXYZ $ shrink (x, y, z) diff --git a/src/Data/Vec3/Class.hs b/src/Data/Vec3/Class.hs --- a/src/Data/Vec3/Class.hs +++ b/src/Data/Vec3/Class.hs @@ -34,12 +34,12 @@ -- | Add two vectors. (<+>) :: v -> v -> v - (<+>) v1 v2 = zipWith (+) v1 v2 + (<+>) = zipWith (+) {-# INLINE (<+>) #-} -- | Subtract two vectors. (<->) :: v -> v -> v - (<->) v1 v2 = zipWith (-) v1 v2 + (<->) = zipWith (-) {-# INLINE (<->) #-} -- | Cross product. @@ -140,7 +140,7 @@ -- | Transpose a vector and multiply it by another vector, -- producing a matrix. - -- + -- -- @ -- [ v1x ] [ r11 r12 r13 ] -- [ ] [ ] diff --git a/src/Data/Vec3/Storable.hs b/src/Data/Vec3/Storable.hs deleted file mode 100644 --- a/src/Data/Vec3/Storable.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Vec3.Storable - ( SVec3(..) - ) - -where - -import Prelude hiding (reverse) - -import Foreign -import Foreign.C.Types - ---import Data.Vector.Storable as VS - -import Data.Vec3.Class - - --- | 'Vec3' implementation with 'Foreign.Storable.Storable' instance, --- suitable for use with "Data.Vector.Storable". -data SVec3 = SVec3 !CDouble !CDouble !CDouble - deriving (Eq, Show) - - -instance Storable SVec3 where - sizeOf _ = sizeOf (undefined :: CDouble) * 3 - alignment _ = alignment (undefined :: CDouble) - - peek p = do - x <- peekElemOff q 0 - y <- peekElemOff q 1 - z <- peekElemOff q 2 - return $ SVec3 x y z - where - q = castPtr p - {-# INLINE peek #-} - - poke p (SVec3 x y z) = do - pokeElemOff q 0 x - pokeElemOff q 1 y - pokeElemOff q 2 z - where - q = castPtr p - {-# INLINE poke #-} - - -instance Vec3 SVec3 where - newtype Matrix SVec3 = SMatrix (SVec3, SVec3, SVec3) - - fromXYZ (x, y, z) = SVec3 (CDouble x) (CDouble y) (CDouble z) - {-# INLINE fromXYZ #-} - - toXYZ (SVec3 (CDouble x) (CDouble y) (CDouble z)) = (x, y, z) - {-# INLINE toXYZ #-} - - fromRows (r1, r2, r3) = SMatrix (r1, r2, r3) - {-# INLINE fromRows #-} - - toRows (SMatrix (r1, r2, r3)) = (r1, r2, r3) - {-# INLINE toRows #-} diff --git a/src/Data/Vec3/TUnboxed.hs b/src/Data/Vec3/TUnboxed.hs deleted file mode 100644 --- a/src/Data/Vec3/TUnboxed.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Vec3.TUnboxed - ( TUVec3(..) - ) - -where - -import Prelude hiding (reverse) - -import Data.Vector.Unboxed as VU -import Data.Vector.Generic as VG -import Data.Vector.Generic.Mutable as VG - -import Data.Vec3.Class - - --- | 'Vec3' implementation with 'Data.Vector.Unboxed.Unbox' instance --- based on tuples, suitable for use with "Data.Vector.Unboxed". --- --- This represents 3-vector as a triple of doubles, using the default --- Unbox instance for tuples as provided by "Data.Vector.Unboxed", --- which wraps a vector of tuples as a tuple of vectors. --- --- @ --- interface: [d1 (x, y, z); d2 (x, y, z) ...], length = N --- | | | | | | --- storage(x): [d1x-+ | | ; d2x-+ | | ...], length = N --- storage(y): [d1y----+ | ; d2y----+ | ...], length = N --- storage(z): [d1z-------+ ; d2z-------+ ...], length = N --- @ -newtype TUVec3 = TUVec3 (Double, Double, Double) - deriving (Eq, Show, - VG.Vector VU.Vector, - VG.MVector VU.MVector, - VU.Unbox) - - -instance Vec3 TUVec3 where - newtype Matrix TUVec3 = TUMatrix (TUVec3, TUVec3, TUVec3) - deriving (Eq, Show, - VG.Vector VU.Vector, - VG.MVector VU.MVector, - VU.Unbox) - - - fromXYZ v = TUVec3 v - {-# INLINE fromXYZ #-} - - toXYZ (TUVec3 v) = v - {-# INLINE toXYZ #-} - - fromRows (r1, r2, r3) = TUMatrix (r1, r2, r3) - {-# INLINE fromRows #-} - - toRows (TUMatrix (r1, r2, r3)) = (r1, r2, r3) - {-# INLINE toRows #-} diff --git a/src/Data/Vec3/Unboxed.hs b/src/Data/Vec3/Unboxed.hs --- a/src/Data/Vec3/Unboxed.hs +++ b/src/Data/Vec3/Unboxed.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Data.Vec3.Unboxed @@ -10,41 +11,44 @@ import Prelude hiding (reverse) -import Control.Monad - -import Data.Vector.Unboxed as VU -import Data.Vector.Generic as VG -import Data.Vector.Generic.Mutable as VGM +import Data.Vector.Unboxed.Deriving import Data.Vec3.Class -- | 'Vec3' implementation with 'Data.Vector.Unboxed.Unbox' instance --- based on a single contiguous array storage scheme, suitable for use --- with "Data.Vector.Unboxed". +-- based on tuples, suitable for use with "Data.Vector.Unboxed". -- --- 'Unbox' instance provides the required index transformations. +-- This represents 3-vector as a triple of doubles, using the default +-- Unbox instance for tuples as provided by "Data.Vector.Unboxed", +-- which wraps a vector of tuples as a tuple of vectors. -- -- @ --- interface: [d1 x y z ; d2 x y z ...], length = N = M / 3 --- | | | | | | --- storage: [ d1x d2y d2z ; d2x d2y d2z ...], length = M +-- interface: [d1 (x, y, z); d2 (x, y, z) ...], length = N +-- | | | | | | +-- storage(x): [d1x-+ | | ; d2x-+ | | ...], length = N +-- storage(y): [d1y----+ | ; d2y----+ | ...], length = N +-- storage(z): [d1z-------+ ; d2z-------+ ...], length = N -- @ --- --- Thanks to dense packing scheme the performance of this --- implementation should generally be on par with 'Storable'-based --- 'Data.Vec3.SVec3'. -data UVec3 = UVec3 !Double !Double !Double - deriving (Eq, Show) +newtype UVec3 = UVec3 (Double, Double, Double) + deriving (Eq, Show) +derivingUnbox "UVec3" + [t|UVec3 -> (Double, Double, Double)|] + [|\(UVec3 v) -> v|] + [|UVec3|] + + instance Vec3 UVec3 where newtype Matrix UVec3 = UMatrix (UVec3, UVec3, UVec3) + deriving (Eq, Show) - fromXYZ (x, y, z) = UVec3 x y z + + fromXYZ = UVec3 {-# INLINE fromXYZ #-} - toXYZ (UVec3 x y z) = (x, y, z) + toXYZ (UVec3 v) = v {-# INLINE toXYZ #-} fromRows (r1, r2, r3) = UMatrix (r1, r2, r3) @@ -54,72 +58,7 @@ {-# INLINE toRows #-} -newtype instance VU.MVector s UVec3 = MV_UVec3 (VU.MVector s Double) -newtype instance VU.Vector UVec3 = V_UVec3 (VU.Vector Double) - - -instance VGM.MVector VU.MVector UVec3 where - basicLength (MV_UVec3 v) = - VGM.basicLength v `quot` 3 - {-# INLINE basicLength #-} - - basicUnsafeSlice s l (MV_UVec3 v) = - MV_UVec3 $ VGM.basicUnsafeSlice (s * 3) (l * 3) v - {-# INLINE basicUnsafeSlice #-} - - basicOverlaps (MV_UVec3 v1) (MV_UVec3 v2) = - VGM.basicOverlaps v1 v2 - {-# INLINE basicOverlaps #-} - - basicUnsafeNew n = - MV_UVec3 `liftM` VGM.basicUnsafeNew (n * 3) - {-# INLINE basicUnsafeNew #-} - - basicUnsafeRead (MV_UVec3 v) i = do - x <- VGM.basicUnsafeRead v j - y <- VGM.basicUnsafeRead v (j + 1) - z <- VGM.basicUnsafeRead v (j + 2) - return $ UVec3 x y z - where - j = i * 3 - {-# INLINE basicUnsafeRead #-} - - basicUnsafeWrite (MV_UVec3 v) i (UVec3 x y z) = - VGM.basicUnsafeWrite v j x >> - VGM.basicUnsafeWrite v (j + 1) y >> - VGM.basicUnsafeWrite v (j + 2) z - where - j = i * 3 - {-# INLINE basicUnsafeWrite #-} - - -instance VG.Vector VU.Vector UVec3 where - basicUnsafeFreeze (MV_UVec3 v) = - V_UVec3 `liftM` VG.basicUnsafeFreeze v - {-# INLINE basicUnsafeFreeze #-} - - basicUnsafeThaw (V_UVec3 v) = - MV_UVec3 `liftM` VG.basicUnsafeThaw v - {-# INLINE basicUnsafeThaw #-} - - basicLength (V_UVec3 v) = VG.basicLength v `quot` 3 - {-# INLINE basicLength #-} - - basicUnsafeSlice s l (V_UVec3 v) = - V_UVec3 $ VG.basicUnsafeSlice (s * 3) (l * 3) v - {-# INLINE basicUnsafeSlice #-} - - basicUnsafeIndexM (V_UVec3 v) i = do - x <- VG.basicUnsafeIndexM v j - y <- VG.basicUnsafeIndexM v (j + 1) - z <- VG.basicUnsafeIndexM v (j + 2) - return $ UVec3 x y z - where - j = i * 3 - {-# INLINE basicUnsafeIndexM #-} - - basicUnsafeCopy (MV_UVec3 mv) (V_UVec3 v) - = VG.basicUnsafeCopy mv v - {-# INLINE basicUnsafeCopy #-} - -instance Unbox UVec3 +derivingUnbox "UMatrix" + [t|Matrix UVec3 -> (UVec3, UVec3, UVec3)|] + [|\(UMatrix v) -> v|] + [|UMatrix|] diff --git a/src/Data/Vec3/Unboxed/Contiguous.hs b/src/Data/Vec3/Unboxed/Contiguous.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vec3/Unboxed/Contiguous.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-| + +'Vec3' implementation with 'Data.Vector.Unboxed.Unbox' instance based +on single array storage scheme, suitable for use with +"Data.Vector.Unboxed". + +-} + +module Data.Vec3.Unboxed.Contiguous + ( UVec3(..) + ) + + +where + +import Prelude hiding (reverse) + +import Control.Monad + +import Data.Vector.Unboxed as VU +import Data.Vector.Generic as VG +import Data.Vector.Generic.Mutable as VGM + +import Data.Vec3.Class + + +-- | 'Vec3' implementation with 'Data.Vector.Unboxed.Unbox' instance +-- based on a single contiguous array storage scheme, suitable for use +-- with "Data.Vector.Unboxed". +-- +-- 'Unbox' instance provides the required index transformations. +-- +-- @ +-- interface: [d1 x y z ; d2 x y z ...], length = N = M / 3 +-- | | | | | | +-- storage: [ d1x d2y d2z ; d2x d2y d2z ...], length = M +-- @ +data UVec3 = UVec3 !Double !Double !Double + deriving (Eq, Show) + + +instance Vec3 UVec3 where + newtype Matrix UVec3 = UMatrix (UVec3, UVec3, UVec3) + + fromXYZ (x, y, z) = UVec3 x y z + {-# INLINE fromXYZ #-} + + toXYZ (UVec3 x y z) = (x, y, z) + {-# INLINE toXYZ #-} + + fromRows (r1, r2, r3) = UMatrix (r1, r2, r3) + {-# INLINE fromRows #-} + + toRows (UMatrix (r1, r2, r3)) = (r1, r2, r3) + {-# INLINE toRows #-} + + +newtype instance VU.MVector s UVec3 = MV_UVec3 (VU.MVector s Double) +newtype instance VU.Vector UVec3 = V_UVec3 (VU.Vector Double) + + +instance VGM.MVector VU.MVector UVec3 where + basicInitialize (MV_UVec3 v) = + VGM.basicInitialize v + {-# INLINE basicInitialize #-} + + basicLength (MV_UVec3 v) = + VGM.basicLength v `quot` 3 + {-# INLINE basicLength #-} + + basicUnsafeSlice s l (MV_UVec3 v) = + MV_UVec3 $ VGM.basicUnsafeSlice (s * 3) (l * 3) v + {-# INLINE basicUnsafeSlice #-} + + basicOverlaps (MV_UVec3 v1) (MV_UVec3 v2) = + VGM.basicOverlaps v1 v2 + {-# INLINE basicOverlaps #-} + + basicUnsafeNew n = + MV_UVec3 `liftM` VGM.basicUnsafeNew (n * 3) + {-# INLINE basicUnsafeNew #-} + + basicUnsafeRead (MV_UVec3 v) i = do + x <- VGM.basicUnsafeRead v j + y <- VGM.basicUnsafeRead v (j + 1) + z <- VGM.basicUnsafeRead v (j + 2) + return $ UVec3 x y z + where + j = i * 3 + {-# INLINE basicUnsafeRead #-} + + basicUnsafeWrite (MV_UVec3 v) i (UVec3 x y z) = + VGM.basicUnsafeWrite v j x >> + VGM.basicUnsafeWrite v (j + 1) y >> + VGM.basicUnsafeWrite v (j + 2) z + where + j = i * 3 + {-# INLINE basicUnsafeWrite #-} + + +instance VG.Vector VU.Vector UVec3 where + basicUnsafeFreeze (MV_UVec3 v) = + V_UVec3 `liftM` VG.basicUnsafeFreeze v + {-# INLINE basicUnsafeFreeze #-} + + basicUnsafeThaw (V_UVec3 v) = + MV_UVec3 `liftM` VG.basicUnsafeThaw v + {-# INLINE basicUnsafeThaw #-} + + basicLength (V_UVec3 v) = VG.basicLength v `quot` 3 + {-# INLINE basicLength #-} + + basicUnsafeSlice s l (V_UVec3 v) = + V_UVec3 $ VG.basicUnsafeSlice (s * 3) (l * 3) v + {-# INLINE basicUnsafeSlice #-} + + basicUnsafeIndexM (V_UVec3 v) i = do + x <- VG.basicUnsafeIndexM v j + y <- VG.basicUnsafeIndexM v (j + 1) + z <- VG.basicUnsafeIndexM v (j + 2) + return $ UVec3 x y z + where + j = i * 3 + {-# INLINE basicUnsafeIndexM #-} + + basicUnsafeCopy (MV_UVec3 mv) (V_UVec3 v) + = VG.basicUnsafeCopy mv v + {-# INLINE basicUnsafeCopy #-} + +instance Unbox UVec3 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Data.Vec3 + + +infix 4 <~=> +(<~=>) :: SVec3 -> SVec3 -> Bool +(<~=>) a b = ax ~= bx && + ay ~= by && + az ~= bz + where + (ax, ay, az) = toXYZ (a :: SVec3) + (bx, by, bz) = toXYZ (b :: SVec3) + + +infix 4 ~= +(~=) :: Double -> Double -> Bool +(~=) a b | a == b = True + | a == 0 || b == 0 || isDenormalized absDiff = absDiff < maxError + | otherwise = absDiff / (abs a + abs b) < maxError + where + absDiff = abs $ a - b + maxError = 1e-13 + + +tests :: [TestTree] +tests = + [ testProperty + "Commutativity of addition: a + b = b + a" + (\(a :: SVec3) b -> a <+> b <~=> b <+> a) + , testProperty + "Associativity of addition: (a + b) + c = a + (b + c)" + (\(a :: SVec3) b c -> (a <+> b) <+> c <~=> a <+> (b <+> c)) + , testProperty + "Identity element of addition (zero): v + 0 = v" + (\(v :: SVec3) -> (v <+> origin <~=> v)) + , testProperty + "Inverse elements of addition: v + (-v) = 0" + (\(v :: SVec3) -> (v <+> invert v <~=> origin)) + , testProperty + "Compatibility of scalar and field multiplication" + (\(v :: SVec3) p q -> (v .^ p .^ q <~=> v .^ (p * q))) + , testProperty + "Identity of scalar multiplication" + (\(v :: SVec3) -> (v .^ 1 <~=> v)) + , testProperty + "Distributivity wrt vector addition" + (\(a :: SVec3) b p -> ((a <+> b) .^ p) <~=> (a .^ p) <+> (b .^ p)) + , testProperty + "Distributivity wrt scalar addition" + (\(a :: SVec3) p q -> (a .^ (p + q) <~=> (a .^ p) <+> (a .^ q))) + , testProperty + "Subtraction definition" + (\(a :: SVec3) b -> (a <+> invert b <~=> a <-> b)) + , testProperty + "Normalization" + (\(v :: SVec3) -> (v <~=> origin || norm (normalize v) ~= 1)) + , testProperty + "Triangle inequality" + (\(a :: SVec3) b c -> (distance a b + distance b c >= distance a c)) + ] + + +main :: IO () +main = defaultMain $ testGroup "Tests" tests