SGplus-1.1: Data/SG/Test.hs
-- SG library
-- Copyright (c) 2009, Neil Brown.
-- 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.
-- * The author's name may not 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.
-- | A test module (run main)
module Data.SG.Test where
import Control.Arrow
import qualified Data.List as List
import Test.HUnit
import Data.SG
newtype Float' = Float' Float deriving (Ord, Enum, Num, Fractional, Floating, Show)
newtype Double' = Double' Double deriving (Ord, Enum, Num, Fractional, Floating, Show)
instance Eq Float' where
a == b = abs (a - b) < 0.001
instance Eq Double' where
a == b = abs (a - b) < 0.001
class (Eq a, Floating a, Enum a, Ord a) => TestFloating a where
input :: [a]
input = [-10..10]
angs :: [a]
angs = map (*(50/pi)) [0..100]
testItems2 :: ((a,a) -> b) -> [b]
testItems2 f = [f (x, y) | x <- [-10..10], y <- [-10..10]]
testItems3 :: ((a,a,a) -> b) -> [b]
testItems3 f = [f (x, y, z) | x <- [-10..10], y <- [-10..10], z <- [-10..10]]
forRot2 :: ((b, b) -> IO ()) -> (((a,a) -> (a,a)) -> [(b,b)]) -> IO ()
forRot2 f g = mapM_ f (concatMap g $ map onPair ops)
where
ops :: [Pair a -> Pair a]
ops = [\p -> multMatrix (rotate2D a) p | a <- angs]
onPair f p = let Pair p' = f (Pair p) in p'
forRot3 :: ((b, b) -> IO ()) -> (((a,a,a) -> (a,a,a)) -> [(b,b)]) -> IO ()
forRot3 f g = mapM_ f (g id)
test_mag2 :: a -> ((a, a) -> a) -> IO ()
test_mag2 _ f = forRot2 (uncurry $ assertEqual "test_mag2")
$ \rot -> [(sqrt $ (x*x) + (y*y), f (rot (x,y))) | x <- input, y <- input]
test_unit2 :: (Eq (p a), Show (p a), VectorNum p, Coord p) =>
a -> ((a, a) -> p a) -> IO ()
test_unit2 _ f = forRot2 (uncurry $ assertEqual "test_unit2")
$ \rot -> [let v = f (rot p) in (v, (fmapNum1 (* mag v) $ unitVector v)) | p <- testItems2 id]
test_unit3 :: (Eq (p a), Show (p a), VectorNum p, Coord p) =>
a -> ((a, a, a) -> p a) -> IO ()
test_unit3 _ f = forRot3 (uncurry $ assertEqual "test_unit3")
$ \rot -> [let v = f (rot p) in (v, (fmapNum1 (* mag v) $ unitVector v)) | p <- testItems3 id]
testRotId :: (Eq (p a), Show (p a), IsomorphicVectors Pair p, IsomorphicVectors
p Pair) => a -> ((a, a) -> p a) -> IO ()
testRotId _ f = do mapM_ (uncurry $ assertEqual "testRotId")
$ map (id &&& (rotate2D 0 `multMatrix`)) $ testItems2 f
mapM_ (uncurry $ assertEqual "testRotId")
$ map (id &&& (rotate2D (2*pi) `multMatrix`)) $ testItems2 f
mapM_ (uncurry $ assertEqual "testRotId")
$ map (id &&& (rotate2D (4*pi) `multMatrix`)) $ testItems2 f
mapM_ (uncurry $ assertEqual "testRotId")
$ map (id &&& (rotate2D (-2*pi) `multMatrix`)) $ testItems2 f
mapM_ (uncurry $ assertEqual "testRotId-bothways")
[(rotate2D a `multMatrix` v
,rotate2D (negate (2*pi - a)) `multMatrix` v
)
| v <- testItems2 f, a <- angs]
mapM_ (uncurry $ assertEqual "testRotId-twice")
[(v,rotate2D a `multMatrix` (rotate2D (2*pi - a) `multMatrix` v))
| v <- testItems2 f, a <- angs]
testProject :: (VectorNum p, Coord p) => a -> ((a, a) -> p a) -> IO ()
testProject _ f = do
forRot2 (uncurry $ assertEqual "testProject") $
\rot -> [ let r = f $ rot (0 :: a, 1)
v = f (rot p)
in (snd p, v `projectOnto` r)
| p <- testItems2 id]
forRot2 (uncurry $ assertEqual "testProject") $
\rot -> [ let r = f $ rot (0 :: a, -1)
v = f (rot p)
in (negate $ snd p, v `projectOnto` r)
| p <- testItems2 id]
testReflect :: a -> IO ()
testReflect _ = do
forRot2 (uncurry $ assertEqual "testReflect0") $
\rot -> [ let r = makeRel2 $ rot (0 :: a, 1)
v = makeRel2 $ rot p
v' = makeRel2 $ rot $ second negate p
in (v', v `reflectAgainst2` r)
| p <- testItems2 id]
forRot2 (uncurry $ assertEqual "testReflect1") $
\rot -> [ let r = makeRel2 $ rot (0 :: a, -1)
v = makeRel2 $ rot p
v' = makeRel2 $ rot $ second negate p
in (v', v `reflectAgainst2` r)
| p <- testItems2 id]
forRot2 (uncurry $ assertEqual "testReflect2") $
\rot -> [ let r = makeRel2 $ rot (0 :: a, 1)
v = makeRel2 $ rot p
v' = makeRel2 $ rot $ second (\x -> if x > 0 then x else negate x) p
in (v', v `reflectAgainstIfNeeded2` r)
| p <- testItems2 id]
forRot2 (uncurry $ assertEqual "testReflect3") $
\rot -> [ let r = makeRel2 $ rot (0 :: a, -1)
v = makeRel2 $ rot p
v' = makeRel2 $ rot $ second (\x -> if x < 0 then x else negate x) p
in (v', v `reflectAgainstIfNeeded2` r)
| p <- testItems2 id]
testMatrixId :: (Matrix (SquareMatrix c), Num (SquareMatrix c a)) => SquareMatrix c a -> IO ()
testMatrixId x
= do let id = fromMatrixComponents [] `asTypeOf` x
size = length (matrixComponents id)
groupInto n xs = take n xs : groupInto n (drop n xs)
ns = fromMatrixComponents $ groupInto size [1..]
assertEqual "testMatrixId 0" id (transpose id)
assertEqual "testMatrixId 1" id (id*id)
assertEqual "testMatrixId 2" id (id*id*transpose id*id)
assertEqual "testMatrixId 3" ns (transpose $ transpose $ ns)
assertEqual "testMatrixId 4" (transpose ns)
(fromMatrixComponents $ List.transpose $ matrixComponents $ ns)
assertEqual "testMatrixId 5" ns (id * ns)
assertEqual "testMatrixId 6" ns (ns * id)
testAll :: a -> IO ()
testAll x
= do test_mag2 x (mag . makeRel2)
test_mag2 x (mag . Point2)
test_mag2 x (mag . Pair)
test_unit2 x Point2
test_unit2 x makeRel2
test_unit2 x Pair
test_unit3 x Point3
test_unit3 x makeRel3
test_unit3 x Triple
testRotId x Point2
testRotId x makeRel2
testRotId x Pair
testMatrixId (undefined :: Matrix22' a)
testMatrixId (undefined :: Matrix33' a)
testMatrixId (undefined :: Matrix44' a)
testProject x Point2
testProject x makeRel2
testProject x Pair
testReflect x
instance TestFloating Float'
instance TestFloating Double'
main :: IO ()
main = do testAll (0 :: Float')
testAll (0 :: Double')