module DiagramGoldenTests
( diagramGoldenTests
) where
import Test.Tasty (TestTree, TestName, testGroup)
import Test.Tasty.Golden.Advanced (goldenTest)
import Text.XML.Light as XML
import DarkModeSVG (darkModeSVG)
import qualified Graphics.Svg as Svg
import Data.Maybe (fromMaybe)
import Waterfall.Diagram (Diagram)
import qualified Waterfall.Diagram as Diagram
import qualified Waterfall.TwoD.Transforms as TwoD.Transforms
import Waterfall.Solids (Solid)
import qualified Waterfall.Solids as Solids
import qualified Waterfall.Transforms as Transforms
import Linear
import qualified CsgExample
import Control.Monad.Except (runExceptT, liftEither)
import qualified Data.ByteString.Char8 as BSC8
import qualified Graphics.Rasterific.Svg as RSvg
import qualified Graphics.Text.TrueType as FF
import Control.Monad.IO.Class (liftIO)
import Control.Monad (unless, join)
import qualified Codec.Picture as JP
import Control.Lens
import Data.Function (on)
import Data.Monoid (Sum (getSum))
import System.FilePath (takeBaseName, (</>))
import qualified FilletExample
import qualified GearExample
import qualified RevolutionExample
import qualified SweepExample
import qualified OffsetExample
import qualified TextExample
import qualified BoundingBoxExample
import qualified LoftExample
import qualified TwoDBooleansExample
import qualified PlatonicSolidsExample
import qualified TakePathFractionExample
import qualified Paths_waterfall_cad_examples as Paths
xmlToSvg :: String -> XML.Element -> Either String Svg.Document
xmlToSvg fileDesc = maybe (Left $ "failed to parse " <> fileDesc) Right . Svg.parseSvgFile "file.svg" . BSC8.pack . XML.showTopElement
-- this is unlawful - it assumes the two images have the same size
zippingTraversal :: JP.Pixel px => Traversal' (JP.Image px, JP.Image px) (px, px)
zippingTraversal =
alongside (partsOf JP.imagePixels) (partsOf JP.imagePixels)
. iso (uncurry zip) unzip
. traverse
pixelDiffThreshold :: Integer
pixelDiffThreshold = 16
pixelCountThreshold :: Integer
pixelCountThreshold = 64
comparePixels :: JP.PixelRGBA8 -> JP.PixelRGBA8 -> Bool
comparePixels (JP.PixelRGBA8 r1 g1 b1 a1) (JP.PixelRGBA8 r2 g2 b2 a2) =
let c x y = abs (fromIntegral x - fromIntegral y)
in (c r1 r2 + c g1 g2 + c b1 b2 + c a1 a2 ) < pixelDiffThreshold
size :: JP.Image px -> (Int, Int)
size a = (JP.imageWidth a, JP.imageHeight a)
similarSizes :: JP.Image px -> JP.Image px -> Bool
similarSizes a b =
let within1 a b = abs (a - b) <= 1
in (within1 `on` JP.imageWidth) a b
&& (within1 `on` JP.imageHeight) a b
render :: Svg.Document -> IO (JP.Image JP.PixelRGBA8, RSvg.LoadedElements)
render = RSvg.renderSvgDocument
FF.emptyFontCache
Nothing -- Document Size
72 -- DPI, a so-so DPI for screens, higher would just mean making the test less sensitive
countMismatchedPixel :: (JP.PixelRGBA8, JP.PixelRGBA8) -> Sum Integer
countMismatchedPixel (x, y) = if comparePixels x y then 0 else 1
colourMismatchedPixel :: (JP.PixelRGBA8, JP.PixelRGBA8) -> JP.PixelRGBA8
colourMismatchedPixel (x, y) = if comparePixels x y then x else JP.PixelRGBA8 255 0 0 255
dup :: a -> (a, a)
dup = join (,)
cropToSmallest :: JP.Pixel a => JP.Image a -> JP.Image a -> (JP.Image a, JP.Image a)
cropToSmallest a b =
if size a == size b
then (a, b)
else
let w = (min `on` JP.imageWidth) a b
h = (min `on` JP.imageHeight) a b
crop img = JP.generateImage (JP.pixelAt img) w h
in (crop a, crop b)
compareOutput :: FilePath -> XML.Element -> XML.Element -> IO (Maybe String)
compareOutput inputPath expected actual =
let extract (Left s) = Just s
extract (Right ()) = Nothing
in fmap extract . runExceptT $ do
expectedSvg <- liftEither $ xmlToSvg "expected" expected
actualSvg <- liftEither $ xmlToSvg "actual" actual
(expectedRendered, _) <- liftIO $ render expectedSvg
(actualRendered, _) <- liftIO $ render actualSvg
projectRoot <- liftIO Paths.getDataDir
let makePath kind = projectRoot </> "test-results" </> takeBaseName inputPath <> "." <> kind <> ".png"
let expectedPath = makePath "expected"
let diffPath = makePath "diff"
let actualPath = makePath "actual"
unless (similarSizes expectedRendered actualRendered) $ do
liftIO $ JP.writePng expectedPath expectedRendered
liftIO $ JP.writePng actualPath actualRendered
liftEither . Left $
( "incompatible sizes, expected: "
<> show (size expectedRendered)
<> ", actual "
<> show (size actualRendered)
<> ", actual written to "
<> actualPath)
let (expectedRenderedCropped, actualRenderedCropped) = cropToSmallest expectedRendered actualRendered
(width, height) = size expectedRenderedCropped
let mismatchedCount = getSum $
foldMapOf
zippingTraversal
countMismatchedPixel
(expectedRenderedCropped, actualRenderedCropped)
unless (mismatchedCount < pixelCountThreshold) $ do
let totalPixels = width * height
let diffImage =
(expectedRenderedCropped, actualRenderedCropped)
& zippingTraversal %~ (dup . colourMismatchedPixel)
& (^. _1)
liftIO $ JP.writePng expectedPath expectedRendered
liftIO $ JP.writePng diffPath diffImage
liftIO $ JP.writePng actualPath actualRendered
liftEither . Left $
( show mismatchedCount <> "/" <> show totalPixels
<> " pixels didn't match, diff written to "
<> diffPath
)
doTest :: TestName -> FilePath -> IO Diagram -> TestTree
doTest testName goldenPath makeDiagram =
let qualifyGoldenPath = (</> "test-data" </> goldenPath) <$> Paths.getDataDir
readGoldenFile = fromMaybe (error $ "failed to read " <> goldenPath) . parseXMLDoc <$> (readFile =<< qualifyGoldenPath)
-- most paths are relative to Paths_waterfall_cad_examples.getDataDir
-- however when updating the file, we want to modify the source file
-- therefore this is sensitive to the cwd
updateGoldenFile = writeFile ("test-data" </> goldenPath) . ppTopElement
in goldenTest
testName
readGoldenFile
(darkModeSVG <$> makeDiagram)
(\a b -> do
path <- qualifyGoldenPath
compareOutput path a b
)
updateGoldenFile
standardSolidDiagram :: Solid -> Diagram
standardSolidDiagram = withWidth 800 . Diagram.solidDiagram (V3 2 3 1)
normalizeSize :: (V2 Double -> Double) -> Double -> Diagram -> Diagram
normalizeSize getter target d =
case Diagram.diagramBoundingBox d of
Just (lo, hi) ->
let s = getter (hi - lo)
in TwoD.Transforms.uScale2D (target / s) d
Nothing -> d
withHeight :: Double -> Diagram -> Diagram
withHeight = normalizeSize (^. _y)
withWidth :: Double -> Diagram -> Diagram
withWidth = normalizeSize (^. _x)
solidTest :: TestName -> FilePath -> Solid -> TestTree
solidTest name filepath solid =
doTest name filepath (pure . standardSolidDiagram $ solid)
smallSolidTest :: TestName -> FilePath -> Solid -> TestTree
smallSolidTest name filepath solid =
doTest name filepath (pure . withHeight 200 . standardSolidDiagram $ solid)
diagramGoldenTests :: TestTree
diagramGoldenTests = testGroup "Diagram Golden Tests"
[ smallSolidTest "CSG" "csg.svg" CsgExample.csgExample
, solidTest "Gear" "gear.svg" $ GearExample.gearExample 1 5 20 (20*pi/180)
, smallSolidTest "Revolution" "revolution.svg" RevolutionExample.revolutionExample
, smallSolidTest "Sweep" "sweep.svg" SweepExample.sweepExample
, solidTest "Offset" "offset.svg" OffsetExample.offsetExample
, doTest "Text" "text.svg" $ do
projectRoot <- Paths.getDataDir
standardSolidDiagram <$> TextExample.textExample
(projectRoot </> "test-data/fonts/varela/VarelaRound-Regular.ttf")
12.0
"Waterfall-CAD"
10
, smallSolidTest "Bound" "bounding-boxes.svg" BoundingBoxExample.boundingBoxExample
, solidTest "Loft" "loft.svg" LoftExample.loftExample
, solidTest "Fillet" "fillet.svg" FilletExample.filletExample
, smallSolidTest "2D Booleans" "2d-booleans.svg" TwoDBooleansExample.twoDBooleansExample
, solidTest "Platonic Solids" "platonic.svg" PlatonicSolidsExample.platonicSolidsExample
, solidTest "Take Path Fraction" "takePathFraction.svg" TakePathFractionExample.takePathFractionExample
, solidTest "Negative Scaled Cube" "negativeScaledCube.svg"
(Transforms.scale (V3 (negate 1) 1 1) Solids.unitCube)
, solidTest "Negative Scaled Cube II" "negativeScaledCube-II.svg"
(Transforms.scale (negate $ V3 1 1 1) Solids.unitCube)
, solidTest "Negative Scaled Cube III" "negativeScaledCube-III.svg"
(Transforms.scale (V3 (negate 10) (negate 10) 10) Solids.unitCube)
, solidTest "Negative Scaled Cuboid" "negativeScaledCuboid.svg"
(Transforms.scale (V3 (negate 1) 2 3) Solids.unitCube)
]