From: Michael Orlitzky Date: Thu, 4 Aug 2011 17:01:03 +0000 (-0400) Subject: Fix all orphan instances. X-Git-Tag: 0.0.1~246 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=ecb77f944fcba8c8cfe60ca782bc5d9c8ab68cf9;p=spline3.git Fix all orphan instances. --- diff --git a/src/Cardinal.hs b/src/Cardinal.hs index 9032fbd..3bff38f 100644 --- a/src/Cardinal.hs +++ b/src/Cardinal.hs @@ -6,7 +6,9 @@ module Cardinal where +import Control.Monad (liftM, liftM2) import Prelude hiding (LT) +import Test.QuickCheck (Arbitrary(..), oneof) data Cardinal = F -- ^ Front | B -- ^ Back @@ -68,6 +70,46 @@ instance Fractional Cardinal where fromRational x = Scalar (fromRational x) + +instance Arbitrary Cardinal where + arbitrary = oneof [f,b,l,r,d,t,fl,fr,fd,ft,bl,br,bd,bt,ld,lt, + rd,rt,fld,flt,frd,frt,bld,blt,brd,brt,i, + scalar,csum,cdiff,cprod,cquot] + where + f = return F + b = return B + l = return L + r = return R + d = return D + t = return T + fl = return FL + fr = return FR + fd = return FD + ft = return FT + bl = return BL + br = return BR + bd = return BD + bt = return BT + ld = return LD + lt = return LT + rd = return RD + rt = return RT + fld = return FLD + flt = return FLT + frd = return FRD + frt = return FRT + bld = return BLD + blt = return BLT + brd = return BRD + brt = return BRT + i = return I + scalar = liftM Scalar arbitrary + csum = liftM2 Sum arbitrary arbitrary + cdiff = liftM2 Difference arbitrary arbitrary + cprod = liftM2 Product arbitrary arbitrary + cquot = liftM2 Quotient arbitrary arbitrary + + -- | Rotate a cardinal direction counter-clockwise about the x-axis. ccwx :: Cardinal -> Cardinal ccwx F = F diff --git a/src/Cube.hs b/src/Cube.hs index 2ec9e48..6941425 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -1,6 +1,8 @@ module Cube where +import Test.QuickCheck (Arbitrary(..), Gen, Positive(..), choose) + import Cardinal import qualified Face (Face(Face, v0, v1, v2, v3)) import FunctionValues @@ -16,6 +18,19 @@ data Cube = Cube { h :: Double, deriving (Eq) +instance Arbitrary Cube where + arbitrary = do + (Positive h') <- arbitrary :: Gen (Positive Double) + i' <- choose (coordmin, coordmax) + j' <- choose (coordmin, coordmax) + k' <- choose (coordmin, coordmax) + fv' <- arbitrary :: Gen FunctionValues + return (Cube h' i' j' k' fv') + where + coordmin = -268435456 -- -(2^29 / 2) + coordmax = 268435456 -- +(2^29 / 2) + + instance Show Cube where show c = "Cube_" ++ subscript ++ "\n" ++ diff --git a/src/FunctionValues.hs b/src/FunctionValues.hs index 681a23b..1fbc044 100644 --- a/src/FunctionValues.hs +++ b/src/FunctionValues.hs @@ -4,6 +4,7 @@ module FunctionValues where import Prelude hiding (LT) +import Test.QuickCheck (Arbitrary(..), choose) import Cardinal @@ -41,6 +42,78 @@ data FunctionValues = interior :: Double } deriving (Eq, Show) + +instance Arbitrary FunctionValues where + arbitrary = do + front' <- choose (min_double, max_double) + back' <- choose (min_double, max_double) + left' <- choose (min_double, max_double) + right' <- choose (min_double, max_double) + top' <- choose (min_double, max_double) + down' <- choose (min_double, max_double) + front_left' <- choose (min_double, max_double) + front_right' <- choose (min_double, max_double) + front_top' <- choose (min_double, max_double) + front_down' <- choose (min_double, max_double) + back_left' <- choose (min_double, max_double) + back_right' <- choose (min_double, max_double) + back_top' <- choose (min_double, max_double) + back_down' <- choose (min_double, max_double) + left_top' <- choose (min_double, max_double) + left_down' <- choose (min_double, max_double) + right_top' <- choose (min_double, max_double) + right_down' <- choose (min_double, max_double) + front_left_top' <- choose (min_double, max_double) + front_left_down' <- choose (min_double, max_double) + front_right_top' <- choose (min_double, max_double) + front_right_down' <- choose (min_double, max_double) + back_left_top' <- choose (min_double, max_double) + back_left_down' <- choose (min_double, max_double) + back_right_top' <- choose (min_double, max_double) + back_right_down' <- choose (min_double, max_double) + interior' <- choose (min_double, max_double) + + return empty_values { front = front', + back = back', + left = left', + right = right', + top = top', + down = down', + front_left = front_left', + front_right = front_right', + front_top = front_top', + front_down = front_down', + back_left = back_left', + back_right = back_right', + back_top = back_top', + back_down = back_down', + left_top = left_top', + left_down = left_down', + right_top = right_top', + right_down = right_down', + front_left_top = front_left_top', + front_left_down = front_left_down', + front_right_top = front_right_top', + front_right_down = front_right_down', + back_left_top = back_left_top', + back_left_down = back_left_down', + back_right_top = back_right_top', + back_right_down = back_right_down', + interior = interior' } + where + -- | We perform addition with the function values contained in a + -- FunctionValues object. If we choose random doubles near the machine + -- min/max, we risk overflowing or underflowing the 'Double'. This + -- places a reasonably safe limit on the maximum size of our generated + -- 'Double' members. + max_double :: Double + max_double = 10000.0 + + -- | See 'max_double'. + min_double :: Double + min_double = (-1) * max_double + + -- | Return a 'FunctionValues' with a bunch of zeros for data points. empty_values :: FunctionValues empty_values = diff --git a/src/Grid.hs b/src/Grid.hs index 1a436ac..efa6341 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -4,6 +4,8 @@ module Grid where +import Test.QuickCheck (Arbitrary(..), Gen, Positive(..)) + import Cube (Cube(Cube)) import FunctionValues import Misc (flatten) @@ -20,6 +22,13 @@ data Grid = Grid { h :: Double, -- MUST BE GREATER THAN ZERO! deriving (Eq, Show) +instance Arbitrary Grid where + arbitrary = do + (Positive h') <- arbitrary :: Gen (Positive Double) + fvs <- arbitrary :: Gen [[[Double]]] + return (make_grid h' fvs) + + -- | The constructor that we want people to use. If we're passed a -- non-positive grid size, we throw an error. make_grid :: Double -> [[[Double]]] -> Grid diff --git a/src/Tests/Cardinal.hs b/src/Tests/Cardinal.hs index 1786021..7d4cfde 100644 --- a/src/Tests/Cardinal.hs +++ b/src/Tests/Cardinal.hs @@ -1,54 +1,12 @@ module Tests.Cardinal where -import Control.Monad (liftM, liftM2) import Prelude hiding (LT) import Test.HUnit -import Test.QuickCheck +import Test.QuickCheck (Property, (==>)) import Cardinal - - -instance Arbitrary Cardinal where - arbitrary = oneof [f,b,l,r,d,t,fl,fr,fd,ft,bl,br,bd,bt,ld,lt, - rd,rt,fld,flt,frd,frt,bld,blt,brd,brt,i, - scalar,csum,cdiff,cprod,cquot] - where - f = return F - b = return B - l = return L - r = return R - d = return D - t = return T - fl = return FL - fr = return FR - fd = return FD - ft = return FT - bl = return BL - br = return BR - bd = return BD - bt = return BT - ld = return LD - lt = return LT - rd = return RD - rt = return RT - fld = return FLD - flt = return FLT - frd = return FRD - frt = return FRT - bld = return BLD - blt = return BLT - brd = return BRD - brt = return BRT - i = return I - scalar = liftM Scalar arbitrary - csum = liftM2 Sum arbitrary arbitrary - cdiff = liftM2 Difference arbitrary arbitrary - cprod = liftM2 Product arbitrary arbitrary - cquot = liftM2 Quotient arbitrary arbitrary - - -- | We know what (c t6 2 1 0 0) should be from Sorokina and -- Zeilfelder, p. 87. This test checks that the directions are -- rotated properly. The order of the letters has to be just right diff --git a/src/Tests/Cube.hs b/src/Tests/Cube.hs index 150faef..6d0f864 100644 --- a/src/Tests/Cube.hs +++ b/src/Tests/Cube.hs @@ -2,7 +2,6 @@ module Tests.Cube where import Prelude hiding (LT) -import Test.QuickCheck import Cardinal import Comparisons @@ -13,17 +12,6 @@ import Tests.FunctionValues () import Tetrahedron (b0, b1, b2, b3, c, fv, v0, v1, v2, v3, volume) -instance Arbitrary Cube where - arbitrary = do - (Positive h') <- arbitrary :: Gen (Positive Double) - i' <- choose (coordmin, coordmax) - j' <- choose (coordmin, coordmax) - k' <- choose (coordmin, coordmax) - fv' <- arbitrary :: Gen FunctionValues - return (Cube h' i' j' k' fv') - where - coordmin = -268435456 -- -(2^29 / 2) - coordmax = 268435456 -- +(2^29 / 2) -- Quickcheck tests. diff --git a/src/Tests/FunctionValues.hs b/src/Tests/FunctionValues.hs index 40d2502..9cada35 100644 --- a/src/Tests/FunctionValues.hs +++ b/src/Tests/FunctionValues.hs @@ -2,86 +2,11 @@ module Tests.FunctionValues where import Test.HUnit -import Test.QuickCheck import Assertions import Examples import FunctionValues --- | We perform addition with the function values contained in a --- FunctionValues object. If we choose random doubles near the machine --- min/max, we risk overflowing or underflowing the 'Double'. This --- places a reasonably safe limit on the maximum size of our generated --- 'Double' members. -max_double :: Double -max_double = 10000.0 - --- | See 'max_double'. -min_double :: Double -min_double = (-1) * max_double - - -instance Arbitrary FunctionValues where - arbitrary = do - front' <- choose (min_double, max_double) - back' <- choose (min_double, max_double) - left' <- choose (min_double, max_double) - right' <- choose (min_double, max_double) - top' <- choose (min_double, max_double) - down' <- choose (min_double, max_double) - front_left' <- choose (min_double, max_double) - front_right' <- choose (min_double, max_double) - front_top' <- choose (min_double, max_double) - front_down' <- choose (min_double, max_double) - back_left' <- choose (min_double, max_double) - back_right' <- choose (min_double, max_double) - back_top' <- choose (min_double, max_double) - back_down' <- choose (min_double, max_double) - left_top' <- choose (min_double, max_double) - left_down' <- choose (min_double, max_double) - right_top' <- choose (min_double, max_double) - right_down' <- choose (min_double, max_double) - front_left_top' <- choose (min_double, max_double) - front_left_down' <- choose (min_double, max_double) - front_right_top' <- choose (min_double, max_double) - front_right_down' <- choose (min_double, max_double) - back_left_top' <- choose (min_double, max_double) - back_left_down' <- choose (min_double, max_double) - back_right_top' <- choose (min_double, max_double) - back_right_down' <- choose (min_double, max_double) - interior' <- choose (min_double, max_double) - - return empty_values { front = front', - back = back', - left = left', - right = right', - top = top', - down = down', - front_left = front_left', - front_right = front_right', - front_top = front_top', - front_down = front_down', - back_left = back_left', - back_right = back_right', - back_top = back_top', - back_down = back_down', - left_top = left_top', - left_down = left_down', - right_top = right_top', - right_down = right_down', - front_left_top = front_left_top', - front_left_down = front_left_down', - front_right_top = front_right_top', - front_right_down = front_right_down', - back_left_top = back_left_top', - back_left_down = back_left_down', - back_right_top = back_right_top', - back_right_down = back_right_down', - interior = interior' } - - - - test_directions :: Assertion test_directions = assertTrue "all direction functions work" (and equalities) diff --git a/src/Tests/Grid.hs b/src/Tests/Grid.hs index 15bbc98..ad7bab9 100644 --- a/src/Tests/Grid.hs +++ b/src/Tests/Grid.hs @@ -3,7 +3,6 @@ where import Data.Maybe (fromJust) import Test.HUnit -import Test.QuickCheck import Assertions import Comparisons @@ -14,13 +13,6 @@ import Grid import Tetrahedron -instance Arbitrary Grid where - arbitrary = do - (Positive h') <- arbitrary :: Gen (Positive Double) - fvs <- arbitrary :: Gen [[[Double]]] - return (make_grid h' fvs) - - -- | Check the value of c0030 for tetrahedron0 belonging to the -- cube centered on (1,1,1) with a grid constructed from the -- trilinear values. See example one in the paper. diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index 393b960..a2a7b6e 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -2,25 +2,15 @@ module Tests.Tetrahedron where import Test.HUnit -import Test.QuickCheck +import Test.QuickCheck (Property, (==>)) import Cardinal import Comparisons -import Point import FunctionValues import Tests.FunctionValues() import Tetrahedron import ThreeDimensional -instance Arbitrary Tetrahedron where - arbitrary = do - rnd_v0 <- arbitrary :: Gen Point - rnd_v1 <- arbitrary :: Gen Point - rnd_v2 <- arbitrary :: Gen Point - rnd_v3 <- arbitrary :: Gen Point - rnd_fv <- arbitrary :: Gen FunctionValues - return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3) - -- HUnit Tests diff --git a/src/Tetrahedron.hs b/src/Tetrahedron.hs index bcf9a0b..eefbe11 100644 --- a/src/Tetrahedron.hs +++ b/src/Tetrahedron.hs @@ -3,6 +3,7 @@ where import Numeric.LinearAlgebra hiding (i, scale) import Prelude hiding (LT) +import Test.QuickCheck (Arbitrary(..), Gen) import Cardinal import FunctionValues @@ -18,6 +19,17 @@ data Tetrahedron = Tetrahedron { fv :: FunctionValues, v3 :: Point } deriving (Eq) + +instance Arbitrary Tetrahedron where + arbitrary = do + rnd_v0 <- arbitrary :: Gen Point + rnd_v1 <- arbitrary :: Gen Point + rnd_v2 <- arbitrary :: Gen Point + rnd_v3 <- arbitrary :: Gen Point + rnd_fv <- arbitrary :: Gen FunctionValues + return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3) + + instance Show Tetrahedron where show t = "Tetrahedron:\n" ++ " fv: " ++ (show (fv t)) ++ "\n" ++