puzzle-draw-0.1.0.4: tests/tests.hs
import Test.Tasty
import Test.Tasty.HUnit
import Data.Yaml
import Data.List (sort)
import qualified Data.Map as Map
import Control.DeepSeq
import Text.Puzzles.Puzzle
import Data.Puzzles.Elements (Thermometer, MasyuPearl(..))
import Text.Puzzles.Util
(parseChar, parseMultiOutsideClues, parseEdgeGrid)
import Text.Puzzles.PuzzleTypes
import qualified Data.Puzzles.Grid as Grid
import Data.Puzzles.Pyramid (PyramidSol(..))
import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..))
import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..))
import Diagrams.Puzzles.PuzzleGrids
import Diagrams.Prelude
import Diagrams.Backend.SVG
import Text.Blaze.Svg.Renderer.Text (renderSvg)
import Data
import Util
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Tests"
[ parseUtilTests, parseTests, parseDataTests, renderTests, dataTests ]
testParsePzl, testParseSol, testNonparsePzl, testNonparseSol ::
(Show a, Show b) => String -> ParsePuzzle a b -> Value -> TestTree
testParsePzl name parser yaml =
testCase ("parse " ++ name) $ testParse (fst parser) yaml
testParseSol name parser yaml =
testCase ("parse " ++ name ++ " (sol)") $ testParse (snd parser) yaml
testNonparsePzl name parser yaml =
testCase ("don't parse broken " ++ name) $ testNonparse (fst parser) yaml
testNonparseSol name parser yaml =
testCase ("don't parse broken " ++ name ++ " (sol)") $
testNonparse (snd parser) yaml
parseUtilTests :: TestTree
parseUtilTests = testGroup "Parsing infrastructure tests (parseChar)"
[ testCase "parse digit" $
(parseMaybe parseChar '5' :: Maybe Int) @=? Just 5
, testCase "don't parse hex chars" $
(parseMaybe parseChar 'a' :: Maybe Int) @=? Nothing
, testCase "don't break on non-digits" $
(parseMaybe parseChar ' ' :: Maybe Int) @=? Nothing
]
parseTests :: TestTree
parseTests = testGroup "Parsing tests (full puzzles, no details)"
[ testParsePzl "geradeweg" geradeweg geradeweg_1
, testParseSol "geradeweg" geradeweg geradeweg_1_sol
, testParsePzl "tightfit" tightfitskyscrapers tightfit_1
, testParseSol "tightfit" tightfitskyscrapers tightfit_1_sol
, testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_1
, testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_2
, testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken
, testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken_2
, testNonparseSol "slalom" slalom slalom_sol_broken
, testParsePzl "kpyramid" kpyramid kpyramid_1
, testParseSol "kpyramid" kpyramid kpyramid_1_sol
, testNonparsePzl "kpyramid" kpyramid kpyramid_broken_1
, testNonparsePzl "kpyramid" kpyramid kpyramid_broken_2
, testNonparsePzl "kpyramid" kpyramid kpyramid_broken_3
, testParsePzl "compass" compass compass_1
, testNonparsePzl "compass" compass compass_broken_1
, testNonparsePzl "compass" compass compass_broken_2
, testNonparsePzl "compass" compass compass_broken_3
, testNonparsePzl "compass" compass compass_broken_4
, testNonparsePzl "compass" compass compass_broken_5
, testParsePzl "thermosudoku" thermosudoku thermo_1
, testParsePzl "thermosudoku" thermosudoku thermo_2
, testNonparsePzl "thermosudoku" thermosudoku thermo_broken_1
, testNonparsePzl "thermosudoku" thermosudoku thermo_broken_2
, testParsePzl "boxof2or3" boxof2or3 boxof2or3_1
]
test_thermo_1 :: [Thermometer]
test_thermo_1 = either (const []) snd $
parseEither (fst thermosudoku) thermo_1
-- two neighbouring a's, should be fine
test_thermo_2 :: [Thermometer]
test_thermo_2 = either (const []) snd $
parseEither (fst thermosudoku) thermo_2
testThermo :: [Thermometer] -> [Thermometer] -> Assertion
testThermo t expect = sort t @?= expect
test_tightfit_1 :: Bool
test_tightfit_1 = either (const False) test_both res
where
res = parseEither (fst tightfitskyscrapers) tightfit_1
test_both (o, g) = test_size g && test_clues o
test_size g = Grid.size g == (3, 3)
test_clues (Grid.OC l r b t) = l == [Nothing, Nothing, Just 3] &&
r == [Nothing, Just 4, Nothing] &&
b == [Just 3, Just 5, Nothing] &&
t == [Nothing, Nothing, Nothing]
test_pyramid_sol :: Bool
test_pyramid_sol = either (const False) test_content res
where
res = parseEither (snd kpyramid) kpyramid_1_sol
test_content (PyramidSol rs) =
rs == [[3], [8,5], [1,9,4], [3,2,7,3], [1,2,4,3,6]]
test_multioutside :: Assertion
test_multioutside = Right oc @=? res
where
res = parseEither parseMultiOutsideClues multioutside
oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]]
:: OutsideClues [Int]
test_edge_grid :: Assertion
test_edge_grid = Right (gn, gc, es) @=? res
where
res = parseEither parseEdgeGrid edgeGrid_1
gn = Grid.Grid (Square 4 2) $ Map.fromList
[((0,0),Just MBlack),((0,1),Just MWhite),((1,0),Just MWhite),((1,1),Just MBlack),
((2,0),Nothing),((2,1),Just MBlack),((3,0),Nothing),((3,1),Just MWhite)]
gc :: Grid.SGrid Int
gc = Grid.Grid (Square 3 1) $ Map.fromList
[((0,0),1),((1,0),2),((2,0),3)]
es = [E (0,0) H, E (0,1) H, E (1,1) H, E (2,1) H, E (0,0) V, E (1,0) V]
parseDataTests :: TestTree
parseDataTests = testGroup "Parsing tests (full puzzles, result checks)"
[ testCase "parse tightfit, correct size" $ test_tightfit_1 @? "error in puzzle"
, testCase "parse kpyramid sol properly" $ test_pyramid_sol @? "wrong solution"
, testCase "parse thermos" $ testThermo test_thermo_1
[ [(0, 4), (1, 5), (2, 4), (1, 3)]
, [(4, 0), (3, 1), (4, 2), (5, 1)] ]
, testCase "parse thermos" $ testThermo test_thermo_2
[ [(0, 1), (1, 0), (2, 0)]
, [(0, 2), (1, 3), (2, 4)]
, [(4, 0), (4, 1), (3, 2)] ]
, testCase "parse multioutsideclues" $ test_multioutside
, testCase "parse edge grid" $ test_edge_grid
]
-- this used to cause a rendering crash, though it's
-- caught by parsing by now
testBreakSlalom :: Bool
testBreakSlalom =
case parseMaybe (snd slalom) slalom_sol_broken of
Nothing -> True
Just s -> let d = drawSlalomDiags s
svg = renderDia SVG (SVGOptions (Width 100) Nothing) d
svgt = renderSvg svg
in (show svgt) `deepseq` True
renderTests :: TestTree
renderTests = testGroup "Rendering tests"
[ testCase "don't break rendering invalid slalom solution"
$ testBreakSlalom @? "just testing against errors"
]
testMultiOutsideClues :: Assertion
testMultiOutsideClues = multiOutsideClues (OC l r b t) `sorteq` res
where
sorteq xs ys = sort xs @?= sort ys
l = [[1, 2], [3]]
r = [[], [1, 0]]
b = [[0, 0, 1]]
t = [[1, -1]]
res = [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3),
((1,1), 1), ((2,1), 0), ((0,-1), 0), ((0,-2), 0), ((0,-3), 1),
((0,2), 1), ((0,3), -1) ] :: [((Int, Int), Int)]
dataTests :: TestTree
dataTests = testGroup "Generic tests for the Data modules"
[ testCase "multiOutsideClues" testMultiOutsideClues
]