TwoD.hs

-- |

module Diagrams.Test.TwoD where

import           Diagrams.Prelude
import           Diagrams.Trail        (linePoints)
import           Instances
import           Test.Tasty
import           Test.Tasty.QuickCheck

newtype SmallAngle = SmallAngle (Angle Double)
  deriving (Eq, Ord, Show)

-- Generate random angles within a reasonably small range (+/- 5
-- turns).
instance Arbitrary SmallAngle where
  arbitrary = SmallAngle . (@@turn) <$> choose (-5, 5)

tests :: TestTree
tests = testGroup "TwoD"
    [ testGroup "TwoD.Arc" [
           testProperty "arc start point is at radius 1 in the starting direction" $ \d (SmallAngle a) ->
               pathVertices (arc d a :: Path V2 Double) ^? _head . _head =~ Just (origin .+^ fromDirection d )
           , testProperty "arc end point is at radius 1 in the ending direction" $ \d (SmallAngle a) ->
               pathVertices (arc d a :: Path V2 Double) ^? _head . _last =~ Just (origin .+^ fromDirection (rotate a d))
         ]
    , testGroup "TwoD.Types" [
         testProperty "R2 vector addition is commutative" $
           \u v -> (u :: V2 Double) ^+^ v =~ v ^+^ u
         , testProperty "R2 subtraction is the inverse of addition" $
           \u v -> u ^+^ v ^-^ v =~ (u :: V2 Double)
         , testProperty "R2 vector negation squared is identity" $
           \u -> negated (negated (u :: V2 Double)) =~ u
         ]
      , testGroup "cubicSpline" [
         testProperty "Open cubic spline interpolates all points" $
         \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline False pts :: [P2 Double]))
         , testProperty "Closed cubic spline interpolates all points" $
           \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline True pts :: [P2 Double]))
    ]
      , testGroup "Trail" [
         testProperty "glueLine . cutLoop === id" $
         \l -> glueLine (cutLoop l :: Trail' Line V2 Double) =~ l
         , testProperty "cutLoop ends at starting point" $
           \l -> let ps = linePoints (cutLoop (l :: Trail' Loop V2 Double) `at` origin) in (ps ^? _head) =~ (ps ^? _last)
         , testProperty "cutTrail makes a Line" $
           \t -> isLine (cutTrail (t :: Trail V2 Double))
          , testProperty "fromSegments . lineSegments === id" $
            \l -> fromSegments (lineSegments l) =~ (l :: Trail' Line V2 Double)
          , testProperty "lineSegments . fromSegments === id" $
            \segs -> lineSegments (fromSegments segs) =~ (segs :: [Segment Closed V2 Double])
          ]
      ]