diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,9 @@ +0.1.0.1: 20140409 +----------------- + +* add new puzzle type: Tapa + +0.1.0.0 +------- + +* first release diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +[![Build Status](https://api.travis-ci.org/robx/puzzle-draw.png)][travis] + +puzzle-draw +=========== + +puzzle-draw is a library for drawing pencil puzzles using +[Diagrams][diagrams]. It aims to provide a utility layer on top of +Diagrams to help with drawing arbitrary puzzles, as well as supporting +several specific puzzle types directly. In addition, it includes +functionality for parsing puzzle data from a YAML file format. + +See [puzzle-draw-cmdline][cmdline] for a command line tool that +uses this. + +Examples +-------- + +A [liar slitherlink][liarslither] with solution: + +![Liar Slitherlink](doc/slitherlink-liar-example.png) + +This was rendered from the following YAML document: + +``` +type: slitherlinkliar +puzzle: | + 1..0.3 + .03222 + 0....1 + 3....3 + 32202. + 3.3..3 +solution: + loop: | + .┌──┐┌┐ + .│┌─┘││ + .│└──┘│ + ┌┘.┌─┐│ + └┐┌┘.││ + ┌┘│..││ + └─┘..└┘ + liars: | + ...X.. + .X.... + X..... + .....X + ....X. + ..X... +``` + +Or see a [puzzle set][twentyfour] that covers the puzzle types +that are supported currently. + +[travis]: http://travis-ci.org/robx/puzzle-draw +[cmdline]: http://github.com/robx/puzzle-draw-cmdline +[liarslither]: http://maybepuzzles.wordpress.com/types/liar-slither-link/ +[twentyfour]: http://maybepuzzles.wordpress.com/2014/03/29/puzzle-set-24-hour-marathon/ +[diagrams]: http://projects.haskell.org/diagrams/ diff --git a/puzzle-draw.cabal b/puzzle-draw.cabal --- a/puzzle-draw.cabal +++ b/puzzle-draw.cabal @@ -1,21 +1,6 @@ --- Initial puzzle-draw.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. name: puzzle-draw - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.0.0 - --- A short (one-line) description of the package. +version: 0.1.0.1 synopsis: Creating graphics for pencil puzzles. - --- A longer description of the package. description: puzzle-draw is a library for drawing pencil puzzles using Diagrams. It aims to provide a utility layer on top of Diagrams to help with drawing arbitrary @@ -23,35 +8,18 @@ puzzle types directly. In addition, it includes functionality for parsing puzzle data from a YAML file format. - --- The license under which the package is released. license: MIT - --- The file containing the license text. license-file: LICENSE - --- The package author(s). author: Robert Vollmert - --- An email address to which users can send suggestions, bug reports, and --- patches. maintainer: rfvollmert@gmail.com - --- A copyright notice. --- copyright: - category: Graphics - build-type: Simple - --- Constraint on the version of Cabal needed to build this package. +Extra-source-files: README.md, CHANGES.md cabal-version: >=1.8 Source-repository head type: git location: http://github.com/robx/puzzle-draw.git - library - -- Modules exported by the library. exposed-modules: Data.Puzzles.Grid Data.Puzzles.GridShape Data.Puzzles.Elements @@ -70,11 +38,6 @@ Diagrams.Puzzles.PuzzleGrids Diagrams.Puzzles.PuzzleTypes Diagrams.Puzzles.Draw - - -- Modules included in this library but not exported. - -- other-modules: - - -- Other library packages from which modules are imported. build-depends: base >= 4.2 && < 4.8, diagrams-lib >= 1.1 && < 1.2, parsec >= 3.1 && < 3.2, diff --git a/src/Data/Puzzles/Compose.hs b/src/Data/Puzzles/Compose.hs --- a/src/Data/Puzzles/Compose.hs +++ b/src/Data/Puzzles/Compose.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} -- | -- Helpers to string together parser and renderer by puzzle type. @@ -60,6 +60,7 @@ handle f BoxOf2Or3 = f R.boxof2or3 D.boxof2or3 handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers handle f CountNumbers = f R.countnumbers D.countnumbers +handle f Tapa = f R.tapa D.tapa -- | Handler that parses a puzzle from a YAML value, and renders. drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2)) diff --git a/src/Data/Puzzles/Elements.hs b/src/Data/Puzzles/Elements.hs --- a/src/Data/Puzzles/Elements.hs +++ b/src/Data/Puzzles/Elements.hs @@ -52,3 +52,6 @@ data KropkiDot = None | Black | White deriving Show + +newtype TapaClue = TapaClue [Int] + deriving Show diff --git a/src/Data/Puzzles/Grid.hs b/src/Data/Puzzles/Grid.hs --- a/src/Data/Puzzles/Grid.hs +++ b/src/Data/Puzzles/Grid.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, GADTs, StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, + GADTs, StandaloneDeriving #-} -- | Puzzle grids. module Data.Puzzles.Grid where diff --git a/src/Data/Puzzles/PuzzleTypes.hs b/src/Data/Puzzles/PuzzleTypes.hs --- a/src/Data/Puzzles/PuzzleTypes.hs +++ b/src/Data/Puzzles/PuzzleTypes.hs @@ -34,6 +34,7 @@ | BoxOf2Or3 | AfternoonSkyscrapers | CountNumbers + | Tapa deriving (Show, Eq) typeNames :: [(PuzzleType, String)] @@ -60,6 +61,7 @@ , (BoxOf2Or3, "boxof2or3") , (AfternoonSkyscrapers, "afternoonskyscrapers") , (CountNumbers, "countnumbers") + , (Tapa, "tapa") ] -- | Look up a puzzle type by name. diff --git a/src/Diagrams/Puzzles/Draw.hs b/src/Diagrams/Puzzles/Draw.hs --- a/src/Diagrams/Puzzles/Draw.hs +++ b/src/Diagrams/Puzzles/Draw.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} module Diagrams.Puzzles.Draw ( PuzzleSol, diff --git a/src/Diagrams/Puzzles/Elements.hs b/src/Diagrams/Puzzles/Elements.hs --- a/src/Diagrams/Puzzles/Elements.hs +++ b/src/Diagrams/Puzzles/Elements.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} -- | Module: Diagrams.TwoD.Puzzles.Elements -- @@ -141,3 +141,18 @@ [ (0, 0), (1/4, 1/4), (1, 1/4), (1, 0), (0, 0) ] south = strokeLocLoop shape # lw 0 # fc gray west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south + +drawTapaClue :: (Backend b R2, Renderable (Path R2) b) => + TapaClue -> Diagram b R2 +drawTapaClue (TapaClue [x]) = drawInt x +drawTapaClue (TapaClue xs) = fit 0.8 + . decoratePath (p (length xs)) + . map drawInt + $ xs + where + p n = centerXY (p' n) + p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4) + p' 3 = reflectX . rotate (1/6 @@ turn) $ triangle 0.8 + p' 4 = rotate (1/8 @@ turn) $ square 0.7 + p' 1 = error "singleton clues handled separately" + p' _ = error "invalid tapa clue" diff --git a/src/Diagrams/Puzzles/Grid.hs b/src/Diagrams/Puzzles/Grid.hs --- a/src/Diagrams/Puzzles/Grid.hs +++ b/src/Diagrams/Puzzles/Grid.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} module Diagrams.Puzzles.Grid where diff --git a/src/Diagrams/Puzzles/Lib.hs b/src/Diagrams/Puzzles/Lib.hs --- a/src/Diagrams/Puzzles/Lib.hs +++ b/src/Diagrams/Puzzles/Lib.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} module Diagrams.Puzzles.Lib where diff --git a/src/Diagrams/Puzzles/PuzzleGrids.hs b/src/Diagrams/Puzzles/PuzzleGrids.hs --- a/src/Diagrams/Puzzles/PuzzleGrids.hs +++ b/src/Diagrams/Puzzles/PuzzleGrids.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/Puzzles/PuzzleTypes.hs b/src/Diagrams/Puzzles/PuzzleTypes.hs --- a/src/Diagrams/Puzzles/PuzzleTypes.hs +++ b/src/Diagrams/Puzzles/PuzzleTypes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module Diagrams.Puzzles.PuzzleTypes ( @@ -5,7 +6,7 @@ sudoku, thermosudoku, pyramid, kpyramid, slither, liarslither, tightfitskyscrapers, wordloop, wordsearch, curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, countnumbers, + afternoonskyscrapers, countnumbers, tapa, ) where import Diagrams.Prelude hiding (Loop) @@ -177,3 +178,11 @@ countnumbers = (,) drawAreaGrid (drawIntGrid . snd <> drawAreaGrid . fst) + +tapa :: (Backend b R2, Renderable (Path R2) b) => + RenderPuzzle b (SGrid TapaClue) ShadedGrid +tapa = (,) + tapaGrid + (tapaGrid . fst <> drawShadedGrid . snd) + where + tapaGrid = atCentres drawTapaClue . values <> grid . size diff --git a/src/Diagrams/Puzzles/Pyramid.hs b/src/Diagrams/Puzzles/Pyramid.hs --- a/src/Diagrams/Puzzles/Pyramid.hs +++ b/src/Diagrams/Puzzles/Pyramid.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module Diagrams.Puzzles.Pyramid where diff --git a/src/Text/Puzzles/PuzzleTypes.hs b/src/Text/Puzzles/PuzzleTypes.hs --- a/src/Text/Puzzles/PuzzleTypes.hs +++ b/src/Text/Puzzles/PuzzleTypes.hs @@ -5,7 +5,7 @@ sudoku, thermosudoku, pyramid, kpyramid, slither, liarslither, tightfitskyscrapers, wordloop, wordsearch, curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, countnumbers, + afternoonskyscrapers, countnumbers, tapa, ) where import Prelude hiding (sequence) @@ -121,3 +121,7 @@ -- this should be changed to support clue numbers countnumbers :: ParsePuzzle AreaGrid IntGrid countnumbers = (parseGrid, parseGrid) + +tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid +tapa = (\v -> unRG <$> parseJSON v, + parseShadedGrid) diff --git a/src/Text/Puzzles/Util.hs b/src/Text/Puzzles/Util.hs --- a/src/Text/Puzzles/Util.hs +++ b/src/Text/Puzzles/Util.hs @@ -126,15 +126,19 @@ parseChar _ = empty data Blank = Blank +data Blank' = Blank' instance FromChar Blank where parseChar '.' = pure Blank - parseChar '-' = pure Blank parseChar _ = empty +instance FromChar Blank' where + parseChar '.' = pure Blank' + parseChar '-' = pure Blank' + parseChar _ = empty + instance FromString Blank where parseString "." = pure Blank - parseString "-" = pure Blank parseString _ = empty instance FromChar SlalomDiag where @@ -308,7 +312,7 @@ SGrid (Tightfit ())) parseTightOutside v = do BorderedRect w h ls b <- parseJSON v - :: Parser (BorderedRect Tight (Either Blank Int)) + :: Parser (BorderedRect Tight (Either Blank' Int)) return (outside . fmap (either (const Nothing) Just) $ b, fmap unTight . rectToSGrid $ Rect w h ls) where outside (Border l r b t) = OC l r b t @@ -393,4 +397,7 @@ splitBorder (Square w h) = Map.partitionWithKey (\(x, y) _ -> x < w - 1 && y < h - 1) - +instance FromJSON TapaClue where + parseJSON v = do xs <- parseJSON v + guard $ length xs > 0 && length xs <= 4 + return $ TapaClue xs diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -2,12 +2,11 @@ import Test.Tasty.HUnit import Data.Yaml -import qualified Data.ByteString.Char8 as B -import Data.Maybe (fromJust) import Data.List (sort) import Control.DeepSeq +import Text.Puzzles.Puzzle import Data.Puzzles.Elements (Thermometer) import Text.Puzzles.Util (parseChar) import Text.Puzzles.PuzzleTypes @@ -19,251 +18,78 @@ import Diagrams.Backend.SVG import Text.Blaze.Svg.Renderer.Text (renderSvg) -import qualified Data.Text as T +import Data +import Util + main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [unitTests] - -decodeLines :: [String] -> Value -decodeLines = fromJust . decode . B.pack . unlines - -packLine :: String -> Value -packLine = String . T.pack - -packLines :: [String] -> Value -packLines = String . T.pack . unlines - -geradeweg_1 :: Value -geradeweg_1 = packLines $ - [ "..... " - , ".211." - , "..2.. " - , "3...4" - , "....." - ] - -geradeweg_1_sol :: Value -geradeweg_1_sol = packLines $ - [ "┌┐┌─┐" - , "││└┐│ " - , "│└─┘│" - , "└──┐│" - , " .└┘ " - ] - -tightfit_1 :: Value -tightfit_1 = packLines $ - [ " --- " - , "3/\\.-" - , "-\\.\\4" - , "-.\\/-" - , " 35-" - ] - -tightfit_broken_1 :: Value -tightfit_broken_1 = packLines $ - [ " --- " - , "3/\\.-" - , "-\\x\\4" - , "-.\\/-" - , " 35-" - ] - -tightfit_broken_2 :: Value -tightfit_broken_2 = packLines $ - [ "3/\\.-" - , "-\\x\\4" - , "-.\\/-" - , " 35-" - ] - -tightfit_1_sol :: Value -tightfit_1_sol = packLines $ - [ "2/1 4\\5 3" - , " 4\\5 3 2\\1 " - , " 3 1\\2 5/4" - ] - -tightfit_sol_broken :: Value -tightfit_sol_broken = packLine "2/1 4 /5" - -tightfit_sol_broken_2 :: Value -tightfit_sol_broken_2 = packLine "2/x 4 3/5" - -slalom_sol_broken :: Value -slalom_sol_broken = packLine "//\\ /\\x5 " - -kpyramid_1 :: Value -kpyramid_1 = packLines $ - [ "G 3" - , "G . ." - , "G . . ." - , "W .o. . ." - , "G 1*.*.o.*6" - ] - -kpyramid_1_sol :: Value -kpyramid_1_sol = packLines $ - [ " 3" - , " 8 5" - , " 1 9 4" - , " 3 2 7 3" - , "1 2 4 3 6" - ] - -kpyramid_broken_1 :: Value -kpyramid_broken_1 = packLines $ - [ " G 3" - , " G . 22" - , " H . aa ." - , " W .o. .|. " - , " G 1*.*.o.*6" - ] - -kpyramid_broken_2 :: Value -kpyramid_broken_2 = packLines $ - [ "G 3" - , "G . 22" - , "H . aa ." - , "W .o. .|. " - , "G 1*.*.o.*6" - ] - -kpyramid_broken_3 :: Value -kpyramid_broken_3 = packLines $ - [ "G 3" - , "G . ." - , "G . . ." - , "W .o. . ." - , "G a*.*.o.*6" - ] - -compass_1 :: Value -compass_1 = decodeLines $ - [ "grid: |" - , " ..." - , " a.b" - , "clues:" - , " a: 2 1 . 2" - , " b: 21 . . 0" - ] - -compass_broken_1 :: Value -compass_broken_1 = decodeLines $ - [ "grid: |" - , " a.b" - , "clues:" - , " b: 21 . . 0" - ] - -compass_broken_2 :: Value -compass_broken_2 = decodeLines $ - [ "grid: |" - , " a.b" - , "clues:" - , " a: x . . 0" - , " b: 21 . . 0" - ] - -compass_broken_3 :: Value -compass_broken_3 = decodeLines $ - [ "grid: |" - , " a.b" - , "clues:" - , " a: 1 . ." - , " b: 21 . . 0" - ] +tests = testGroup "Tests" + [ parseUtilTests, parseTests, parseDataTests, renderTests ] -compass_broken_4 :: Value -compass_broken_4 = decodeLines $ - [ "grid: |" - , " a.b" - , "clues:" - , " a: 1 . . 2 3" - , " b: 21 . . 0" - ] +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 -compass_broken_5 :: Value -compass_broken_5 = decodeLines $ - [ "grid: |" - , " a3b" - , "clues:" - , " a: 1 . . 2 3" - , " b: 21 . . 0" +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 ] -thermo_1 :: Value -thermo_1 = packLines $ - [ ".b..2." - , "a.c5.1" - , ".d..6." - , ".4..c." - , "5.3b.d" - , ".2..a." +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 ] test_thermo_1 :: [Thermometer] -test_thermo_1 = either (const []) snd res - where - res = parseEither (fst thermosudoku) thermo_1 +test_thermo_1 = either (const []) snd $ + parseEither (fst thermosudoku) thermo_1 -- two neighbouring a's, should be fine -thermo_2 :: Value -thermo_2 = packLines $ - [ "....2." - , "..c5.1" - , ".b..6." - , "a..c.." - , "a...b." - , ".bc.a." - ] - test_thermo_2 :: [Thermometer] -test_thermo_2 = either (const []) snd res - where - res = parseEither (fst thermosudoku) thermo_2 - -thermo_broken_1 :: Value -thermo_broken_1 = packLines $ - [ ".." - , "a." - ] - -thermo_broken_2 :: Value -thermo_broken_2 = packLines $ - [ "bb" - , "a." - ] - -justShow :: Show a => Maybe a -> Bool -justShow Nothing = False -justShow (Just x) = show x `deepseq` True - -eitherShow :: Show a => Either e a -> Bool -eitherShow (Left _) = False -eitherShow (Right x) = show x `deepseq` True - -testParse :: Show a => (Value -> Parser a) -> Value -> Assertion -testParse p t = eitherShow res @? "bad parse: " ++ err - where - res = parseEither p t - err = either id (const "no error") res - -testNonparse :: Show a => (Value -> Parser a) -> Value -> Assertion -testNonparse p t = (not . justShow . parseMaybe p $ t) - @? "parsed but shouldn't" +test_thermo_2 = either (const []) snd $ + parseEither (fst thermosudoku) thermo_2 -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 +testThermo :: [Thermometer] -> [Thermometer] -> Assertion +testThermo t expect = sort t @?= expect test_tightfit_1 :: Bool test_tightfit_1 = either (const False) test_both res @@ -280,46 +106,35 @@ 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_content (PyramidSol rs) = + rs == [[3], [8,5], [1,9,4], [3,2,7,3], [1,2,4,3,6]] -unitTests :: TestTree -unitTests = testGroup "Unit tests" - [ testCase "parse geradeweg" $ testParse (fst geradeweg) geradeweg_1 - , testCase "parse geradeweg solution" $ testParse (snd geradeweg) geradeweg_1_sol - , testCase "parse tightfit" $ testParse (fst tightfitskyscrapers) tightfit_1 - , testCase "parse tightfit, correct size" $ test_tightfit_1 @? "error in puzzle" - , testCase "parse tightfit solution" $ testParse (snd tightfitskyscrapers) tightfit_1_sol - , testCase "don't parse broken tighfit" $ testNonparse (fst tightfitskyscrapers) tightfit_broken_1 - , testCase "don't parse broken tighfit" $ testNonparse (fst tightfitskyscrapers) tightfit_broken_2 - , testCase "don't parse broken tightfit solution" $ - testNonparse (snd tightfitskyscrapers) tightfit_sol_broken - , testCase "don't parse broken tightfit solution" $ - testNonparse (snd tightfitskyscrapers) tightfit_sol_broken_2 - , 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 - , testCase "don't parse invalid slalom solution" $ testNonparse (snd slalom) slalom_sol_broken - , testCase "don't break rendering invalid slalom solution" - $ testBreakSlalom @? "just testing against errors" - , testCase "parse kpyramid" $ testParse (fst kpyramid) kpyramid_1 - , testCase "parse kpyramid sol" $ testParse (snd kpyramid) kpyramid_1_sol +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 "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_1 - , testCase "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_2 - , testCase "don't parse broken kpyramid" $ testNonparse (fst kpyramid) kpyramid_broken_3 - , testCase "parse compass" $ testParse (fst compass) compass_1 - , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_1 - , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_2 - , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_3 - , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_4 - , testCase "don't parse borken compass" $ testNonparse (fst compass) compass_broken_5 - , testCase "parse thermo" $ testParse (fst thermosudoku) thermo_1 - , testCase "parse thermo" $ testParse (fst thermosudoku) thermo_2 - , testCase "parse thermo, thermometers" $ sort test_thermo_1 @?= [ [(0, 4), (1, 5), (2, 4), (1, 3)] - , [(4, 0), (3, 1), (4, 2), (5, 1)] ] - , testCase "parse thermo, thermometers" $ sort test_thermo_2 @?= [ [(0, 1), (1, 0), (2, 0)] - , [(0, 2), (1, 3), (2, 4)] - , [(4, 0), (4, 1), (3, 2)] ] - , testCase "don't parse broken thermo" $ testNonparse (fst thermosudoku) thermo_broken_1 - , testCase "don't parse broken thermo" $ testNonparse (fst thermosudoku) thermo_broken_2 + , 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)] ] + ] + +-- 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" ]