Rasterific-0.5.0.1: exec-src/Arbitrary.hs

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Arbitrary( randomTests ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<*>), pure )
#endif

import Control.DeepSeq
import Control.Applicative( (<$>) )
import Test.QuickCheck
import Codec.Picture
import Graphics.Rasterific
import Graphics.Rasterific.Texture

instance Arbitrary a => Arbitrary (V2 a) where
    arbitrary = V2 <$> arbitrary <*> arbitrary

instance Arbitrary PathCommand where
    arbitrary = oneof
        [ PathLineTo <$> arbitrary
        , PathQuadraticBezierCurveTo <$> arbitrary <*> arbitrary
        , PathCubicBezierCurveTo <$> arbitrary <*> arbitrary <*> arbitrary
        ]

instance Arbitrary Path where
    arbitrary = Path <$> arbitrary <*> pure True <*> arbitrary

instance Arbitrary SamplerRepeat where
    arbitrary = oneof $ map pure [toEnum 0 ..]

instance Arbitrary FillMethod where
    arbitrary = oneof $ map pure [toEnum 0 ..]

instance Arbitrary Join where
    arbitrary = oneof [pure JoinRound, JoinMiter <$> arbitrary]

instance Arbitrary Cap where
    arbitrary = oneof [pure CapRound, CapStraight <$> arbitrary]

newtype StrokeTest = StrokeTest (Drawing PixelRGBA8 ())

instance Show StrokeTest where
    show (StrokeTest sub) =
        "StrokeTest " ++ dumpDrawing sub

instance Arbitrary StrokeTest where
    arbitrary = StrokeTest <$>
        (stroke <$> (getPositive <$> arbitrary)
                <*> arbitrary
                <*> arbitrary
                <*> (pathToPrimitives <$> arbitrary))

newtype DashedStrokeTest = DashedStrokeTest (Drawing PixelRGBA8 ())

instance Show DashedStrokeTest where
    show (DashedStrokeTest sub) =
        "StrokeTest " ++ dumpDrawing sub


instance Arbitrary DashedStrokeTest where
    arbitrary = DashedStrokeTest <$>
        (dashedStroke <$> (fmap getPositive <$> arbitrary)
                      <*> (getPositive <$> arbitrary)
                      <*> arbitrary <*> arbitrary
                      <*> (pathToPrimitives <$> arbitrary))

backgroundColor :: PixelRGBA8
backgroundColor = PixelRGBA8 255 255 255 255

frontTexture :: Texture PixelRGBA8
frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255

fillTest :: Path -> Bool
fillTest path = deepseq img True
  where img = renderDrawing 200 200 backgroundColor $
                    withTexture frontTexture $
                        fill $ pathToPrimitives path

strokeTest :: StrokeTest -> Bool
strokeTest (StrokeTest test) = deepseq img True
  where img = renderDrawing 200 200 backgroundColor $
                    withTexture frontTexture test

dashedStrokeTest :: DashedStrokeTest -> Bool
dashedStrokeTest (DashedStrokeTest test) = deepseq img True
  where img = renderDrawing 200 200 backgroundColor $
                    withTexture frontTexture test

randomTests :: IO ()
randomTests = do
    quickCheck fillTest
    quickCheck strokeTest
    quickCheck dashedStrokeTest