1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Diagrams.Test.Transform where
import Test.Tasty
import Test.Tasty.QuickCheck
import Diagrams.Prelude
import Diagrams.Direction
import Instances
tests :: TestTree
tests = testGroup "Transform" [
testProperty "rotating a vector by a number then its additive inverse will yield the original vector" $
\θ a -> rotate ((θ * (-1)) @@ deg) (rotate ((θ :: Double) @@ deg) (a :: V2 Double)) =~ a
, testProperty "under rotated allows scaling along an angle" $
\θ f a -> under (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (negated (θ @@ deg)) . (scaleX f) . rotate (θ @@ deg)) a
, testProperty "a rotation of 0 does nothing" $
\a -> rotate (0 @@ deg) (a :: V2 Double) =~ a
, testProperty "adding 360 degrees to a turn does nothing" $
\c a -> rotate (((c :: Double) + 360) @@ deg) (a :: V2 Double) =~ rotate (c @@ deg) a
, testProperty "over rotated allows scaling along x of a rotated shape" $
\θ f a -> over (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (θ @@ deg) . (scaleX f) . rotate (negated (θ @@ deg))) a
, testProperty "scaleX" $
\f a b -> (scaleX (f :: Double)) (V2 (a :: Double) b) =~ V2 (a * f) b
, testProperty "scaleY" $
\f a b -> (scaleY (f :: Double)) (V2 (a :: Double) b) =~ V2 a (f * b)
, testProperty "reflectX" $
\a b -> reflectX (V2 (a :: Double) b) =~ V2 (a * (-1)) b
, testProperty "reflectY" $
\a b -> reflectY (V2 (a :: Double) b) =~ V2 a ((-1) * b)
, testProperty "reflectXY" $
\a b -> reflectXY (V2 (a :: Double) b) =~ V2 b a
, testProperty "translate" $
\a b c d -> translateX (a :: Double) (translateY b (P (V2 c d ))) =~ P (V2 (a + c) (b + d))
, testProperty "shear" $
\a b c d -> shearX (a :: Double) (shearY b (V2 c d)) =~ V2 ((c*b + d) * a + c) (c*b + d)
, testProperty "(1,0) rotateTo some dir will return normalised dir" $
\(NonZero a) b -> rotateTo (dir (V2 (a :: Double) b)) (V2 1 0) =~ signorm (V2 a b)
, testProperty "rotates" $
\a c -> rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate'' ((a :: Double)@@ deg) (c :: V2 Double) && rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate' ((a :: Double)@@ deg) (c :: V2 Double)
, testProperty "reflectAbout works for a vector" $
\a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (V2 e f) =~ over (rotated (atan2A' d c)) reflectY (V2 e f)
, testProperty "reflectAbout works for a point" $
\a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (P (V2 e f)) =~ translate (V2 a b) ((over (rotated (atan2A' d c)) reflectY) ((translate (V2 (-a) (-b)) ) (P (V2 e f))))
]
--the original " '' " and a secondary " ' " rotate function for testing
rotation'' :: Floating n => Angle n -> T2 n
rotation'' theta = fromLinear r (linv r)
where
r = rot theta <-> rot (negated theta)
rot th (V2 x y) = V2 (cosA th * x - sinA th * y)
(sinA th * x + cosA th * y)
rotate'' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t
rotate'' = transform . rotation''
rotation' :: Floating n => Angle n -> T2 n
rotation' theta = fromLinear r (linv r)
where
r = rot theta <-> rot (negated theta)
rot th (V2 x y) = V2 (c * x - s * y)
(s * x + c * y)
where
c = cosA th
s = sinA th
rotate' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t
rotate' = transform . rotation'
|
