puzzle-draw (empty) → 0.1.0.0
raw patch · 22 files changed
+2297/−0 lines, 22 filesdep +SVGFontsdep +aesondep +basesetup-changed
Dependencies added: SVGFonts, aeson, base, blaze-svg, bytestring, containers, deepseq, diagrams-lib, diagrams-svg, hashable, parsec, puzzle-draw, tasty, tasty-hunit, text, unordered-containers, yaml
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- puzzle-draw.cabal +106/−0
- src/Data/Puzzles/Compose.hs +113/−0
- src/Data/Puzzles/Elements.hs +54/−0
- src/Data/Puzzles/Grid.hs +102/−0
- src/Data/Puzzles/GridShape.hs +51/−0
- src/Data/Puzzles/PuzzleTypes.hs +67/−0
- src/Data/Puzzles/Pyramid.hs +129/−0
- src/Data/Puzzles/Sudoku.hs +36/−0
- src/Diagrams/Puzzles/Draw.hs +26/−0
- src/Diagrams/Puzzles/Elements.hs +143/−0
- src/Diagrams/Puzzles/Grid.hs +148/−0
- src/Diagrams/Puzzles/Lib.hs +95/−0
- src/Diagrams/Puzzles/PuzzleGrids.hs +85/−0
- src/Diagrams/Puzzles/PuzzleTypes.hs +179/−0
- src/Diagrams/Puzzles/Pyramid.hs +49/−0
- src/Diagrams/Puzzles/Widths.hs +21/−0
- src/Text/Puzzles/Puzzle.hs +27/−0
- src/Text/Puzzles/PuzzleTypes.hs +123/−0
- src/Text/Puzzles/Util.hs +396/−0
- tests/tests.hs +325/−0
+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2014 Robert Vollmert++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ puzzle-draw.cabal view
@@ -0,0 +1,106 @@+-- 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.+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+ puzzles, as well as supporting several specific+ 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.+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+ Data.Puzzles.Pyramid+ Data.Puzzles.Sudoku+ Data.Puzzles.Compose+ Data.Puzzles.PuzzleTypes+ Text.Puzzles.Util+ Text.Puzzles.Puzzle+ Text.Puzzles.PuzzleTypes+ Diagrams.Puzzles.Grid+ Diagrams.Puzzles.Lib+ Diagrams.Puzzles.Elements+ Diagrams.Puzzles.Widths+ Diagrams.Puzzles.Pyramid+ 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,+ yaml >= 0.8.4 && < 0.9,+ aeson >= 0.7 && < 0.8,+ unordered-containers >= 0.2 && < 0.3,+ containers >= 0.5 && < 0.6,+ hashable >= 1.2 && < 1.3,+ text >= 1.1 && < 1.2,+ SVGFonts >= 1.4 && < 1.5+ hs-source-dirs: src+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: tests.hs+ build-depends: base >= 4.2 && < 4.8,+ tasty >= 0.8 && < 0.9,+ tasty-hunit >= 0.8 && < 0.9,+ yaml >= 0.8.4 && < 0.9,+ text >= 1.1 && < 1.2,+ deepseq >= 1.3 && < 1.4,+ blaze-svg >= 0.3 && < 0.4,+ diagrams-lib >= 1.1 && < 1.2,+ diagrams-svg >= 1.0 && < 1.1,+ bytestring >= 0.10 && < 0.11,+ puzzle-draw+ ghc-options: -Wall
+ src/Data/Puzzles/Compose.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++-- |+-- Helpers to string together parser and renderer by puzzle type.++module Data.Puzzles.Compose (+ PuzzleHandler,+ handle,+ -- * Handlers+ drawPuzzle,+ drawPuzzleSol,+ drawPuzzleMaybeSol,+ drawPuzzle',+ drawSolution',+ drawExample'+ ) where++import Data.Maybe+import Diagrams.Prelude+import Data.Yaml (Parser, Value)+import Data.Traversable (traverse)++import Text.Puzzles.Puzzle+import Diagrams.Puzzles.Draw+import Data.Puzzles.PuzzleTypes++import qualified Text.Puzzles.PuzzleTypes as R+import qualified Diagrams.Puzzles.PuzzleTypes as D++-- | A function to compose an arbitrary matching pair of parser and renderer.+-- In @PuzzleHandler b a@, @b@ is the rendering backend type, while @a@ is+-- the result type of the composition.+type PuzzleHandler b a = forall p q.+ ParsePuzzle p q -> RenderPuzzle b p q -> a++-- | @handle h t@ composes the parser and renderer for the puzzle+-- type @t@ with the handler @h@.+handle :: (Backend b R2, Renderable (Path R2) b) =>+ PuzzleHandler b a -> PuzzleType -> a+handle f LITS = f R.lits D.lits+handle f LITSPlus = f R.litsplus D.litsplus+handle f Geradeweg = f R.geradeweg D.geradeweg+handle f Fillomino = f R.fillomino D.fillomino+handle f Masyu = f R.masyu D.masyu+handle f Nurikabe = f R.nurikabe D.nurikabe+handle f LatinTapa = f R.latintapa D.latintapa+handle f Sudoku = f R.sudoku D.sudoku+handle f ThermoSudoku = f R.thermosudoku D.thermosudoku+handle f Pyramid = f R.pyramid D.pyramid+handle f RowKropkiPyramid = f R.kpyramid D.kpyramid+handle f SlitherLink = f R.slither D.slither+handle f SlitherLinkLiar = f R.liarslither D.liarslither+handle f TightfitSkyscrapers = f R.tightfitskyscrapers D.tightfitskyscrapers+handle f WordLoop = f R.wordloop D.wordloop+handle f WordSearch = f R.wordsearch D.wordsearch+handle f CurveData = f R.curvedata D.curvedata+handle f DoubleBack = f R.doubleback D.doubleback+handle f Slalom = f R.slalom D.slalom+handle f Compass = f R.compass D.compass+handle f BoxOf2Or3 = f R.boxof2or3 D.boxof2or3+handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers+handle f CountNumbers = f R.countnumbers D.countnumbers++-- | Handler that parses a puzzle from a YAML value, and renders.+drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2))+drawPuzzle (pp, _) (dp, _) p = do+ p' <- pp p+ return $ dp p'++-- | Handler that parses puzzle and solution from a pair of corresponding+-- YAML values, and renders both individually.+drawPuzzleSol :: PuzzleHandler b ((Value, Value)+ -> Parser (Diagram b R2, Diagram b R2))+drawPuzzleSol (pp, ps) (dp, ds) (p, s) = do+ p' <- pp p+ s' <- ps s+ return (dp p', ds (p', s'))++-- | Handler that parses puzzle and an optional solution from a pair of+-- corresponding YAML values, and renders both individually, optionally+-- for the solution.+drawPuzzleMaybeSol :: PuzzleHandler b ((Value, Maybe Value)+ -> Parser (Diagram b R2, Maybe (Diagram b R2)))+drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do+ p' <- pp p+ s' <- traverse ps $ s+ let mps = case s' of Nothing -> Nothing+ Just s'' -> Just (p', s'')+ return (dp p', ds <$> mps)++-- | Variant of 'drawPuzzle' that accepts a pair of puzzle YAML value and+-- optional solution YAML value.+drawPuzzle' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))+drawPuzzle' (pp, _) (dp, _) (p, _) = do+ p' <- pp p+ return $ dp p'++-- | Handler that accepts a pair of puzzle YAML value and optional solution+-- YAML value, and renders the solution, failing if the solution is not+-- provided.+drawSolution' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))+drawSolution' (pp, ps) (_, ds) (p, ms) = do+ p' <- pp p+ s' <- maybe (fail "no solution provided") ps ms+ return $ ds (p', s')++-- | Like 'drawSolution'', but renders puzzle and solution in example layout.+drawExample' :: (Backend b R2, Renderable (Path R2) b) =>+ PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))+drawExample' (pp, ps) (dp, ds) (p, ms) = do+ p' <- pp p+ s' <- maybe (fail "no solution provided") ps ms+ return . fromJust $ draw (dp p', Just $ ds (p', s')) DrawExample
+ src/Data/Puzzles/Elements.hs view
@@ -0,0 +1,54 @@+-- | Types for a variety of puzzle elements.+module Data.Puzzles.Elements where++import Data.Puzzles.GridShape (Coord, Edge)++type Clue a = Maybe a++data MasyuPearl = MWhite | MBlack+type MasyuClue = Clue MasyuPearl++type IntClue = Clue Int++-- | A Compass clue, specifiying optional numbers in the+-- four cardinal directions.+data CompassC = CC (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int)+ deriving Show++type CompassClue = Clue CompassC++-- | A cell that is optionally bisected by a diagonal+-- (up-right or down-right).+data Tightfit a = Single a | UR a a | DR a a++instance Show a => Show (Tightfit a) where+ show c = "(" ++ show' c ++ ")"+ where show' (Single x) = show x+ show' (UR x y) = show x ++ "/" ++ show y+ show' (DR x y) = show x ++ "\\" ++ show y++-- | A marked word in a letter grid, by its start and end+-- coordinates.+data MarkedWord = MW { mwstart :: Coord, mwend :: Coord }++-- | A loop of edges.+type Loop = [Edge]++-- | A thermometer, as a list of coordinates from bulb to end.+-- There should be at least two entries, entries should be distinct,+-- and successive entries should be neighbours (diagonal neighbours+-- are fine).+type Thermometer = [Coord]++-- | A forward or backward diagonal as occurring in the solution+-- of a slalom puzzle.+data SlalomDiag = SlalomForward | SlalomBackward+ deriving Show++-- | Shadow along from the western and southern side, as used for+-- afternoon skyscrapers.+data Shade = Shade Bool Bool+ deriving Show++data KropkiDot = None | Black | White+ deriving Show
+ src/Data/Puzzles/Grid.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts, GADTs, StandaloneDeriving #-}++-- | Puzzle grids.+module Data.Puzzles.Grid where++import Data.Maybe+import qualified Data.Map as Map+import Data.Foldable (Foldable, fold)+import Data.Traversable (Traversable, traverse)+import Control.Applicative ((<$>))++import Data.Puzzles.GridShape hiding (size, cells)+import qualified Data.Puzzles.GridShape as GS+import Data.Puzzles.Elements++-- | A generic grid, with the given shape and contents.+data Grid s a where+ Grid :: { shape :: s+ , contents :: Map.Map (Cell s) a} -> Grid s a++deriving instance (Show a, Show s, GridShape s) => Show (Grid s a)++-- | Standard square grid.+type SGrid = Grid Square++type CharGrid = SGrid Char+type AreaGrid = CharGrid+type ShadedGrid = SGrid Bool+type CharClueGrid = SGrid (Maybe Char)+type IntGrid = SGrid (Clue Int)++-- | Lookup a grid value at a given cell. Unsafe.+(!) :: (GridShape s, Ord (Cell s)) => Grid s a -> Cell s -> a+(!) (Grid _ m) = (m Map.!)++instance Functor (Grid s) where+ fmap f (Grid s m) = Grid s (fmap f m)++instance Foldable (Grid s) where+ fold (Grid _ m) = fold m++instance Traversable (Grid s) where+ traverse f (Grid s m) = Grid s <$> (traverse f m)++-- | Initialize a square grid from a list of lists. The grid+-- might be incomplete if some rows are shorter.+fromListList :: [[a]] -> Grid Square a+fromListList g = Grid s m+ where+ w = maximum . map length $ g+ h = length g+ s = Square w h+ m = Map.fromList . concat+ . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]+ $ g++size :: GridShape s => Grid s a -> GridSize s+size = GS.size . shape++cells :: GridShape s => Grid s a -> [Cell s]+cells = GS.cells . shape++inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool+inBounds g c = c `elem` cells g++-- | For a grid with value type @Maybe a@, return an association+-- list of cells and @Just@ values.+clues :: GridShape s => Grid s (Maybe a) -> [(Cell s, a)]+clues g = [ (k, v) | (k, Just v) <- values g ]++-- | Association list of cells and values.+values :: GridShape s => Grid s a -> [(Cell s, a)]+values (Grid _ m) = Map.toList m++-- | The inner edges of a grid that separate unequal cells.+borders :: Eq a => Grid Square a -> [Edge]+borders g = [ E p V | p <- vborders ] ++ [ E p H | p <- hborders ]+ where+ borders' f (sx, sy) = [ (x + 1, y) | x <- [0 .. sx - 2]+ , y <- [0 .. sy - 1]+ , f (x, y) /= f (x + 1, y) ]+ vborders = borders' (g !) (size g)+ hborders = map swap $ borders' ((g !) . swap) (swap . size $ g)+ swap (x, y) = (y, x)++-- | Clues along the outside of a square grid.+data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }+ deriving Show++-- | Convert outside clues to association list mapping coordinate to value.+outsideclues :: OutsideClues (Maybe a) -> [((Int, Int), a)]+outsideclues (OC l r b t) = mapMaybe liftMaybe . concat $+ [ zipWith (\ y c -> ((-1, y), c)) [0..h-1] l+ , zipWith (\ y c -> (( w, y), c)) [0..h-1] r+ , zipWith (\ x c -> (( x,-1), c)) [0..w-1] b+ , zipWith (\ x c -> (( x, h), c)) [0..w-1] t+ ]+ where+ w = length b+ h = length l+ liftMaybe (p, Just x) = Just (p, x)+ liftMaybe (_, Nothing) = Nothing
+ src/Data/Puzzles/GridShape.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}++-- | Grid shapes.+module Data.Puzzles.GridShape where++-- | The geometry of a grid.+class Show (Cell a) => GridShape a where+ type GridSize a :: *+ type Cell a :: *+ type Vertex a :: *++ size :: a -> GridSize a+ cells :: a -> [Cell a]+ vertices :: a -> [Vertex a]+ neighbours :: a -> Cell a -> [Cell a]++-- | A standard square grid, with cells and vertices+-- indexed by pairs of integers in mathematical coordinates.+-- The bottom-left corner is vertex (0, 0), the bottom-left+-- cell is cell (0, 0).+data Square = Square !Int !Int+ deriving Show++instance GridShape Square where+ type GridSize Square = (Int, Int)+ type Cell Square = (Int, Int)+ type Vertex Square = (Int, Int)++ size (Square w h) = (w, h)+ cells (Square w h) = [(x, y) | x <- [0..w-1], y <- [0..h-1]]+ vertices (Square w h) = [(x, y) | x <- [0..w], y <- [0..h]]+ neighbours (Square w h) c = filter inBounds . map (add c) $ deltas+ where+ inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h+ deltas = [ (dx, dy)+ | dx <- [-1..1], dy <- [-1..1]+ , dx /= 0 || dy /= 0+ ]+ add (x, y) (x', y') = (x + x', y + y')++-- | Edge direction in a square grid, vertical or horizontal.+data Dir = V | H+ deriving (Eq, Ord, Show)++-- | An edge in a square grid, going up or right from the given cell+-- centre.+data Edge = E (Cell Square) Dir+ deriving (Show, Eq, Ord)++type Coord = Cell Square+type Size = GridSize Square
+ src/Data/Puzzles/PuzzleTypes.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++-- |+-- List of specific puzzle types.++module Data.Puzzles.PuzzleTypes (+ PuzzleType(..),+ lookupType,+ ) where++import Data.Tuple (swap)++-- | The list of specific puzzle types we can handle.+data PuzzleType = LITS+ | LITSPlus+ | Geradeweg+ | Fillomino+ | Masyu+ | Nurikabe+ | LatinTapa+ | Sudoku+ | ThermoSudoku+ | Pyramid+ | RowKropkiPyramid+ | SlitherLink+ | SlitherLinkLiar+ | TightfitSkyscrapers+ | WordLoop+ | WordSearch+ | CurveData+ | DoubleBack+ | Slalom+ | Compass+ | BoxOf2Or3+ | AfternoonSkyscrapers+ | CountNumbers+ deriving (Show, Eq)++typeNames :: [(PuzzleType, String)]+typeNames = [ (LITS, "lits")+ , (LITSPlus, "litsplus")+ , (Geradeweg, "geradeweg")+ , (Fillomino, "fillomino")+ , (Masyu, "masyu")+ , (Nurikabe, "nurikabe")+ , (LatinTapa, "latintapa")+ , (Sudoku, "sudoku")+ , (ThermoSudoku, "thermosudoku")+ , (Pyramid, "pyramid")+ , (RowKropkiPyramid, "rowkropkipyramid")+ , (SlitherLink, "slitherlink")+ , (SlitherLinkLiar, "slitherlinkliar")+ , (TightfitSkyscrapers, "skyscrapers-tightfit")+ , (WordLoop, "wordloop")+ , (WordSearch, "wordsearch")+ , (CurveData, "curvedata")+ , (DoubleBack, "doubleback")+ , (Slalom, "slalom")+ , (Compass, "compass")+ , (BoxOf2Or3, "boxof2or3")+ , (AfternoonSkyscrapers, "afternoonskyscrapers")+ , (CountNumbers, "countnumbers")+ ]++-- | Look up a puzzle type by name.+lookupType :: String -> Maybe PuzzleType+lookupType t = lookup t (map swap typeNames)
+ src/Data/Puzzles/Pyramid.hs view
@@ -0,0 +1,129 @@+-- | Data types and parsing for pyramid puzzles.+module Data.Puzzles.Pyramid (+ Row(..),+ Pyramid(..),+ PyramidSol(..),+ KropkiRow(..),+ RowKropkiPyramid(..),+ mergepyramidsol,+ mergekpyramidsol,+ plainpyramid,+ psize+ ) where++import Data.Char (digitToInt)+import Text.ParserCombinators.Parsec hiding ((<|>), many)+import Control.Monad (liftM2, mplus)+import Data.Yaml hiding (Parser)+import qualified Data.Yaml as Yaml+import qualified Data.Text as T+import Control.Applicative++import Data.Puzzles.Elements++data Row = R { entries :: [Maybe Int]+ , shaded :: Bool+ }++newtype Pyramid = Pyr {unPyr :: [Row]}++newtype PyramidSol = PyramidSol [[Int]]+ deriving Show++-- | The size (number of rows) of a pyramid.+psize :: Pyramid -> Int+psize (Pyr rows) = length rows++-- | Merge a solution into a pyramid.+mergepyramidsol :: Pyramid -> PyramidSol -> Pyramid+mergepyramidsol (Pyr rs) (PyramidSol qs)+ | length rs /= length qs = error "can't merge differently sized pyramids"+ | otherwise = Pyr (zipWith mergerow rs qs)+ where mergerow (R es s) es' = R (zipWith mplus es (map Just es')) s++-- | Merge a solution into a kropki pyramid.+mergekpyramidsol :: RowKropkiPyramid -> PyramidSol -> RowKropkiPyramid+mergekpyramidsol (KP rs) (PyramidSol qs)+ | length rs /= length qs = error "can't merge differently sized pyramids"+ | otherwise = KP (zipWith mergerow rs qs)+ where mergerow (KR es s ds) es' =+ KR (zipWith mplus es (map Just es')) s ds++prow :: GenParser Char st Row+prow = do s <- pshaded+ spaces+ es <- pclues+ return (R es s)++pplainrow :: GenParser Char st [Int]+pplainrow = many (spaces >> fmap digitToInt digit)++pshaded :: GenParser Char st Bool+pshaded = (char 'G' >> return True) <|> (char 'W' >> return False)++pclues :: GenParser Char st [Maybe Int]+pclues = do c <- pclue+ cs <- many (spaces >> pclue)+ return (c:cs)++pclue :: GenParser Char st (Maybe Int)+pclue = fmap (Just . digitToInt) digit+ <|> (char '.' >> return Nothing)++showClues :: [Maybe Int] -> String+showClues = map showClue+ where showClue = maybe '.' (head . show)++instance Show Row where+ show (R c True) = 'G' : showClues c+ show (R c False) = 'W' : showClues c++instance Show Pyramid where+ show = unlines . map show . unPyr++data KropkiRow = KR { entriesk :: [Maybe Int]+ , shadedk :: Bool+ , dotsk :: [KropkiDot]+ }+ deriving Show++newtype RowKropkiPyramid = KP {unKP :: [KropkiRow]}+ deriving Show++-- | Forget the kropki dots.+plainpyramid :: RowKropkiPyramid -> Pyramid+plainpyramid (KP rows) = Pyr (map r rows)+ where r x = R (entriesk x) (shadedk x)++pkropkirow :: GenParser Char st KropkiRow+pkropkirow = do s <- pshaded+ spaces+ (ks, cs) <- pkropkiclues+ return (KR cs s ks)++pkropkiclues :: GenParser Char st ([KropkiDot], [Maybe Int])+pkropkiclues = do c <- pclue+ kcs <- many (liftM2 (,) pkropki pclue)+ let (ks, cs) = unzip kcs in return (ks, c:cs)++pkropki :: GenParser Char st KropkiDot+pkropki = (char '*' >> return Black)+ <|> (char 'o' >> return White)+ <|> (char ' ' >> return None)++toParser :: GenParser a () b -> [a] -> Yaml.Parser b+toParser p v = case parse p "(unknown)" v of Left e -> fail (show e)+ Right x -> pure x++instance FromJSON Pyramid where+ parseJSON (String t) = Pyr <$> (mapM (toParser prow . T.unpack) $ T.lines t)+ parseJSON _ = empty++instance FromJSON RowKropkiPyramid where+ parseJSON (String t) = KP <$> (mapM (toParser pkropkirow . T.unpack) $ T.lines t)+ parseJSON _ = empty++instance FromJSON PyramidSol where+ parseJSON (String t) = PyramidSol <$>+ (mapM (toParser pplainrow . T.unpack) $ T.lines t)+ parseJSON _ = empty
+ src/Data/Puzzles/Sudoku.hs view
@@ -0,0 +1,36 @@+module Data.Puzzles.Sudoku (+ sudokuborders,+ sudokubordersg+ ) where++import Data.Puzzles.Grid+import Data.Puzzles.GridShape hiding (size)++msqrt :: Integral a => a -> Maybe a+msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing+ where r = round . (sqrt :: Double -> Double) . fromIntegral $ x++mhalf :: Integral a => a -> Maybe a+mhalf x = if even x then Just (x `div` 2) else Nothing++-- | Determine the internal borders of a standard sudoku of the+-- given size.+sudokuborders :: Int -> [Edge]+sudokuborders s =+ case msqrt s of+ Just r -> squareborders r+ Nothing -> case mhalf s of+ Just h -> rectborders h+ Nothing -> error "no sudoku layout of this size"+ where squareborders r = [ E (r*x, y) V | x <- [1..r-1], y <- [0..r*r-1] ]+ ++ [ E (x, r*y) H | x <- [0..r*r-1], y <- [1..r-1] ]+ rectborders h = [ E (h, y) V | y <- [0..2*h-1] ]+ ++ [ E (x, 2*y) H | x <- [0..2*h-1], y <- [1..h-1] ]++-- | Determine the internal borders of a standard sudoku of the+-- on the given grid.+sudokubordersg :: SGrid a -> [Edge]+sudokubordersg g = sudokuborders s+ where (w, h) = size g+ s | w == h = w+ | otherwise = error "non-square sudoku grid?"
+ src/Diagrams/Puzzles/Draw.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}++module Diagrams.Puzzles.Draw (+ PuzzleSol,+ RenderPuzzle,+ OutputChoice(..),+ draw+ ) where++import Diagrams.Prelude++type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2)++type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2))++data OutputChoice = DrawPuzzle | DrawSolution | DrawExample+ deriving Show++-- | Optionally render the puzzle, its solution, or a side-by-side+-- example with puzzle and solution.+draw :: (Backend b R2, Renderable (Path R2) b) =>+ PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2)+draw (p, ms) = fmap (bg white) . d+ where d DrawPuzzle = Just p+ d DrawSolution = ms+ d DrawExample = ms >>= \s -> return $ p ||| strutX 2.0 ||| s
+ src/Diagrams/Puzzles/Elements.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module: Diagrams.TwoD.Puzzles.Elements+--+-- Tools to draw individual puzzle components. In particular+-- contents and decorations for individual cells.++module Diagrams.Puzzles.Elements where++import Diagrams.Prelude+import Diagrams.TwoD.Offset++import Data.Puzzles.Elements+import Data.Puzzles.GridShape++import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Widths+import Diagrams.Puzzles.Grid++pearl :: (Renderable (Path R2) b, Backend b R2) =>+ MasyuPearl -> Diagram b R2+pearl m = circle 0.35 # lw 0.05 # fc (c m)+ where+ c MWhite = white+ c MBlack = black++smallPearl :: (Renderable (Path R2) b, Backend b R2) =>+ MasyuPearl -> Diagram b R2+smallPearl = scale 0.4 . pearl++-- | The up-right diagonal of a centered unit square.+ur :: Path R2+ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)]++-- | The down-right diagonal of a centered unit square.+dr :: Path R2+dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]++-- | Both diagonals of a centered unit square.+cross :: Path R2+cross = ur <> dr++-- | Draw a cross.+drawCross :: Renderable (Path R2) b => Diagram b R2+drawCross = stroke cross # scale 0.8 # lw edgewidth++-- | Draw a Compass clue.+drawCompassClue :: (Renderable (Path R2) b, Backend b R2) =>+ CompassC -> Diagram b R2+drawCompassClue (CC n e s w) = texts <> stroke cross # lw onepix+ where tx Nothing _ = mempty+ tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v)+ texts = mconcat . zipWith tx [n, e, s, w] $+ [(0,f), (f,0), (0,-f), (-f,0)]+ f = 3/10++-- | Draw a thermometer, given by a list of bottom-left corners+-- of square cells.+thermo :: Renderable (Path R2) b => [P2] -> QDiagram b R2 Any+thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5))+ where bulb = circle 0.4 # moveTo v+ line = strokeLocLine (fromVertices vs)+ # lw 0.55 # lineCap LineCapSquare+ col = lc gr . fc gr+ gr = blend 0.6 white black+thermo [] = error "invalid empty thermometer"++-- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell+-- coordinates.+drawThermos :: Renderable (Path R2) b => [Thermometer] -> QDiagram b R2 Any+drawThermos = mconcat . map (thermo . map p2i)++-- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to+-- draw the components.+drawTight :: (Renderable (Path R2) b, Backend b R2) =>+ (a -> Diagram b R2) -> Tightfit a -> Diagram b R2+drawTight d (Single x) = d x+drawTight d (UR x y) = stroke ur # lw onepix+ <> d x # scale s # translate (r2 (-t,t))+ <> d y # scale s # translate (r2 (t,-t))+ where t = 1/5+ s = 2/3+drawTight d (DR x y) = stroke dr # lw onepix+ <> d x # scale s # translate (r2 (-t,-t))+ <> d y # scale s # translate (r2 (t,t))+ where t = 1/5+ s = 2/3++-- | Stack the given words, left-justified.+stackWords :: (Backend b R2, Renderable (Path R2) b) => [String] -> QDiagram b R2 Any+stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text')++-- | Mark a word in a grid of letters.+drawMarkedWord :: (Renderable (Path R2) b) => MarkedWord -> QDiagram b R2 Any+drawMarkedWord (MW s e) = lw onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t+ where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2))++-- | Apply 'drawMarkedWord' to a list of words.+drawMarkedWords :: (Renderable (Path R2) b) => [MarkedWord] -> QDiagram b R2 Any+drawMarkedWords = mconcat . map drawMarkedWord++-- | Draw a slalom clue.+drawSlalomClue :: (Show a, Renderable (Path R2) b, Backend b R2) =>+ a -> Diagram b R2+drawSlalomClue x = text' (show x) # scale 0.75+ <> circle 0.4 # fc white # lw onepix++-- | Draw text. Shouldn't be more than two characters or so to fit a cell.+drawText :: (Backend b R2, Renderable (Path R2) b) => String -> QDiagram b R2 Any+drawText = text'++-- | Draw an @Int@.+drawInt :: (Renderable (Path R2) b, Backend b R2) =>+ Int -> Diagram b R2+drawInt s = drawText (show s)++-- | Draw a character.+drawChar :: (Renderable (Path R2) b, Backend b R2) =>+ Char -> Diagram b R2+drawChar c = drawText [c]++-- | Stack a list of words into a unit square. Scaled such that at least+-- three words will fit.+drawWords :: (Renderable (Path R2) b, Backend b R2) =>+ [String] -> Diagram b R2+drawWords ws = spread (-1.0 *^ unitY)+ (map (centerXY . scale 0.4 . drawText) ws)+ # centerY++-- | Fit a line drawing into a unit square.+-- For example, a Curve Data clue.+drawCurve :: Renderable (Path R2) b => [Edge] -> Diagram b R2+drawCurve = lw onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge)++-- | Draw a shadow in the style of Afternoon Skyscrapers.+drawShade :: Renderable (Path R2) b => Shade -> Diagram b R2+drawShade (Shade s w) = (if s then south else mempty) <>+ (if w then west else mempty)+ where+ shape = translate (r2 (-1/2, -1/2)) . fromVertices . map p2 $+ [ (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
+ src/Diagrams/Puzzles/Grid.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module Diagrams.Puzzles.Grid where++import Data.Char (isUpper)++import Diagrams.Prelude++import Data.Puzzles.Grid+import Data.Puzzles.GridShape hiding (size, cells)++import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Widths++-- | Draw a small black dot with no envelope.+dot :: (Renderable (Path R2) b, Backend b R2) => Diagram b R2+dot = circle 0.05 # fc black # smash++-- | Draw a Slither Link style grid of dots of the specified size.+slithergrid :: (Backend b R2, Renderable (Path R2) b) =>+ Size -> Diagram b R2+slithergrid s@(x, y) = dots <> phantom' (border s)+ where dots = hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot++-- | The inner grid lines of a square grid of the specified size.+gridlines :: Size -> Path R2+gridlines (w, h) = (decoratePath xaxis . repeat . alignB . vrule . fromIntegral $ h)+ <> (decoratePath yaxis . repeat . alignL . hrule . fromIntegral $ w)+ where xaxis = fromVertices [ p2 (fromIntegral x, 0) | x <- [1..w-1] ]+ yaxis = fromVertices [ p2 (0, fromIntegral y) | y <- [1..h-1] ]++-- | Draw a frame around the outside of a rectangle.+outframe :: Renderable (Path R2) b => Size -> Diagram b R2+outframe (w, h) = strokePointLoop r # lw fw+ where wd = fromIntegral w+ hd = fromIntegral h+ strokePointLoop = strokeLocTrail . mapLoc (wrapLoop . closeLine)+ . fromVertices . map p2+ fw = framewidthfactor * gridwidth+ e = fw / 2 - gridwidth / 2+ r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)]++-- | Draw a square grid, applying the given style to the grid lines.+grid' :: (Backend b R2, Renderable (Path R2) b) =>+ (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2+grid' gridstyle s =+ outframe s+ <> stroke (gridlines s) # lw gridwidth # gridstyle+ <> phantom' (border s)++-- | Draw a square grid with default grid line style.+grid :: (Backend b R2, Renderable (Path R2) b) =>+ Size -> Diagram b R2+grid = grid' id++bgdashing :: (Semigroup a, HasStyle a) =>+ [Double] -> Double -> Colour Double -> a -> a+bgdashing ds offs c x = x # dashing ds offs <> x # lc c++dashes :: [Double]+dashes = [5 / 40, 3 / 40]++dashoffset :: Double+dashoffset = 2.5 / 40++-- | Draw a square grid with dashed grid lines. The gaps+-- between dashes are off-white to aid in using filling+-- tools.+dashedgrid :: (Backend b R2, Renderable (Path R2) b) =>+ Size -> Diagram b R2+dashedgrid = grid' $ bgdashing dashes dashoffset white'+ where+ white' = blend 0.95 white black++-- | In a square grid, use the first argument to draw things at the centres+-- of cells given by coordinates.+atCentres :: (Transformable a, Monoid a, V a ~ R2) =>+ (t -> a) -> [(Coord, t)] -> a+atCentres dc = translate (r2 (0.5, 0.5)) . atVertices dc++atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a]+atCentres' = translate (r2 (1/2, 1/2)) . atVertices'++-- | In a square grid, use the first argument to draw things+-- at the grid vertices given by coordinates.+atVertices :: (Transformable a, Monoid a, V a ~ R2) =>+ (t -> a) -> [(Coord, t)] -> a+atVertices dc = mconcat . map (\ (p, c) -> dc c # translatep p)++atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a]+atVertices' g = [ (g ! c) # translatep c | c <- cells g ]++-- | Frame a rectangle of the given size with a border of width+-- 'borderwidth'.+border :: (Backend b R2, Renderable (Path R2) b) => Size -> Diagram b R2+border (w, h) = stroke . translate (r2 (-bw, -bw)) . alignBL+ $ rect (fromIntegral w + 2 * bw) (fromIntegral h + 2 * bw)+ where+ bw = borderwidth++edge :: Edge -> Path R2+edge (E c d) = rule d # translate (r2i c)+ where+ rule V = vrule 1.0 # alignB+ rule H = hrule 1.0 # alignL++dualEdge :: Edge -> Path R2+dualEdge = translate (r2 (1/2, 1/2)) . edge++edgeStyle :: HasStyle a => a -> a+edgeStyle = lineCap LineCapSquare . lw edgewidth++thinEdgeStyle :: HasStyle a => a -> a+thinEdgeStyle = lineCap LineCapSquare . lw onepix++drawEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2+drawEdges = edgeStyle . stroke . mconcat . map edge++drawDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2+drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge++drawThinDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2+drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge++drawAreaGrid :: (Backend b R2, Renderable (Path R2) b, Eq a) =>+ SGrid a -> Diagram b R2+drawAreaGrid = drawEdges . borders <> grid . size++fillBG :: (Backend b R2, Renderable (Path R2) b) => Colour Double -> Diagram b R2+fillBG c = square 1 # fc c++shadeGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Maybe (Colour Double)) -> Diagram b R2+shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG)++drawShadedGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid Bool -> Diagram b R2+drawShadedGrid = shadeGrid . fmap f+ where+ f True = Just gray+ f False = Nothing++drawAreaGridGray :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid Char -> Diagram b R2+drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols+ where+ cols c | isUpper c = Just (blend 0.1 black white)+ | otherwise = Nothing
+ src/Diagrams/Puzzles/Lib.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++module Diagrams.Puzzles.Lib where++import Diagrams.Prelude++import Graphics.SVGFonts.ReadFont++import Control.Arrow ((***))++-- | Vertical/horizontal stroked line of given length.+vline, hline :: Renderable (Path R2) b => Double -> Diagram b R2+vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)]+hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)]++-- | Variant of 'hcat'' that spreads with distance @1@.+hcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a+hcatsep = hcat' with {_sep = 1}++-- | Variant of 'vcat'' that spreads with distance @1@,+-- and stacks towards the top.+vcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a+vcatsep = cat' (r2 (0,1)) with {_sep = 1}++-- | Collapse the envelope to a point.+smash :: Backend b R2 => QDiagram b R2 Any -> QDiagram b R2 Any+smash = withEnvelope (vrule 0 :: D R2)++-- | Helper to translate by a point given as @(Int, Int)@.+translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t+translatep = translate . r2i++-- | Convert pair of @Int@ to vector.+r2i :: (Int, Int) -> R2+r2i = r2 . (fromIntegral *** fromIntegral)++-- | Convert pair of @Int@ to point.+p2i :: (Int, Int) -> P2+p2i = p2 . (fromIntegral *** fromIntegral)++-- | Interleave two lists.+interleave :: [a] -> [a] -> [a]+interleave [] _ = []+interleave (x:xs) ys = x : interleave ys xs++-- | Spread diagrams evenly along the given vector.+spread :: (Backend b R2) => R2 -> [Diagram b R2] -> Diagram b R2+spread v things = cat v . interleave (repeat (strut vgap)) $ things+ where ds = map (diameter v) things+ gap' = (magnitude v - sum ds) / fromIntegral (length things + 1)+ vgap = (gap' / magnitude v) *^ v++dmid :: (Enveloped a, V a ~ R2) => a -> Double+dmid a = (dtop + dbot) / 2 - dbot+ where menv v = magnitude . envelopeV v+ dtop = menv unitY a+ dbot = menv ((-1) *^ unitY) a++-- | Place the second diagram to the right of the first, aligning both+-- vertically. The origin is the origin of the left diagram.+besidesL :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) =>+ QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m+besidesL a b = a ||| strutX 0.5 ||| b'+ where b' = b # centerY # translate (dmid a *^ unitY)++-- | Variant of 'besidesL' where the origin is that of the right diagram.+besidesR :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) =>+ QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m+besidesR b a = b' ||| strutX 0.5 ||| a+ where b' = b # centerY # translate (dmid a *^ unitY)++-- | @fit f a@ scales @a@ to fit into a square of size @f@.+fit :: (Transformable t, Enveloped t, V t ~ R2) =>+ Double -> t -> t+fit f a = scale (f / m) a+ where m = max (magnitude (diameter unitX a))+ (magnitude (diameter unitY a))++-- | Write text that is centered both vertically and horizontally and that+-- has an envelope. Sized such that single capital characters fit nicely+-- into a square of size @1@.+text' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2+text' t = stroke (textSVG' $ TextOpts t bit INSIDE_H KERN False 1 1)+ # lw 0 # fc black # scale 0.8++-- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07))+-- <> phantom' (textrect t)+--textrect :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2+--textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red+--text'' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2+--text'' t = text' t `atop` textrect t++-- | Variant of 'phantom' that forces the argument backend type.+phantom' :: (Backend b R2) => D R2 -> Diagram b R2+phantom' = phantom
+ src/Diagrams/Puzzles/PuzzleGrids.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Diagrams.Puzzles.PuzzleGrids where++import Diagrams.Prelude++import Data.Puzzles.Grid+import Data.Puzzles.Elements+import Data.Puzzles.Sudoku++import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Grid+import Diagrams.Puzzles.Widths+import Diagrams.Puzzles.Elements++drawFillo :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Int) -> Diagram b R2+drawFillo = drawIntClues <> dashedgrid . size++drawClueGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Char) -> Diagram b R2+drawClueGrid = atCentres drawChar . clues <> grid . size++drawIntClues :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Int) -> Diagram b R2+drawIntClues = atCentres drawInt . clues++drawInts :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid Int -> Diagram b R2+drawInts = atCentres drawInt . values++drawIntGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Int) -> Diagram b R2+drawIntGrid = drawIntClues <> grid . size++drawSlitherGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Int) -> Diagram b R2+drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size++drawMasyuGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid MasyuClue -> Diagram b R2+drawMasyuGrid = atCentres pearl . clues <> grid . size++drawCompassClues :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid CompassClue -> Diagram b R2+drawCompassClues = atCentres drawCompassClue . clues++drawCompassGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid CompassClue -> Diagram b R2+drawCompassGrid = drawCompassClues <> grid . size++sudokugrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid a -> Diagram b R2+sudokugrid = drawEdges . sudokubordersg <> grid . size++drawWordsClues :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue [String]) -> Diagram b R2+drawWordsClues = atCentres drawWords . clues++drawTightGrid :: (Backend b R2, Renderable (Path R2) b) =>+ (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2+drawTightGrid d g = atCentres (drawTight d) (values g)+ <> grid (size g)+ <> phantom' (border (sx + 2, sy + 2) # translate (r2 (-1,-1)))+ where (sx, sy) = size g++drawSlalomGrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Clue Int) -> Diagram b R2+drawSlalomGrid g = atVertices drawSlalomClue (clues g)+ <> grid (w-1, h-1)+ <> phantom' (border (size g)) # translate (r2 (-1/2,-1/2))+ where (w, h) = size g++drawSlalomDiags :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid SlalomDiag -> Diagram b R2+drawSlalomDiags = atCentres diag . clues . fmap Just+ where diag SlalomForward = stroke ur # lw edgewidth+ diag SlalomBackward = stroke dr # lw edgewidth++drawCrosses :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid Bool -> Diagram b R2+drawCrosses = atCentres (if' drawCross mempty) . values+ where+ if' a b x = if x then a else b
+ src/Diagrams/Puzzles/PuzzleTypes.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleContexts #-}++module Diagrams.Puzzles.PuzzleTypes (+ lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,+ sudoku, thermosudoku, pyramid, kpyramid, slither,+ liarslither, tightfitskyscrapers, wordloop, wordsearch,+ curvedata, doubleback, slalom, compass, boxof2or3,+ afternoonskyscrapers, countnumbers,+ ) where++import Diagrams.Prelude hiding (Loop)++import Diagrams.Puzzles.PuzzleGrids+import Diagrams.Puzzles.Draw+import Diagrams.Puzzles.Grid+import qualified Diagrams.Puzzles.Pyramid as DPyr+import Diagrams.Puzzles.Elements+import Diagrams.Puzzles.Lib++import Data.Puzzles.Grid+import Data.Puzzles.GridShape (Edge)+import Data.Puzzles.Elements+import qualified Data.Puzzles.Pyramid as Pyr++lits :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid+lits = (,)+ drawAreaGridGray+ (drawAreaGrid . fst <> drawShadedGrid . snd)++litsplus :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid+litsplus = lits++solstyle :: HasStyle a => a -> a+solstyle = lc (blend 0.8 black white)++geradeweg :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid Loop+geradeweg = (,)+ drawIntGrid+ (drawIntClues . fst+ <> solstyle . drawDualEdges . snd+ <> grid . size . fst)++fillomino :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid IntGrid+fillomino = (,)+ drawFillo+ (drawFillo . snd)++masyu :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop+masyu = (,)+ drawMasyuGrid+ (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst)++nurikabe :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b IntGrid ShadedGrid+nurikabe = (,)+ drawIntGrid+ (drawIntGrid . fst <> drawShadedGrid . snd)++latintapa :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid (Clue [String])) CharClueGrid+latintapa = (,)+ l+ (l . fst <> atCentres drawChar . clues . snd)+ where+ l = grid . size <> drawWordsClues++sudoku :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b IntGrid IntGrid+sudoku = (,)+ (drawIntClues <> sudokugrid)+ ((drawIntClues <> sudokugrid) . snd)++thermosudoku :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid+thermosudoku = (,)+ (drawInts . fst <> sudokugrid . fst <> drawThermos . snd)+ (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst)++pyramid :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol+pyramid = (,)+ DPyr.pyramid+ (DPyr.pyramid . merge)+ where+ merge (p, q) = Pyr.mergepyramidsol p q++kpyramid :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b Pyr.RowKropkiPyramid Pyr.PyramidSol+kpyramid = (,)+ DPyr.kpyramid+ (DPyr.kpyramid . merge)+ where+ merge (p, q) = Pyr.mergekpyramidsol p q++slither :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b IntGrid Loop+slither = (,)+ drawSlitherGrid+ (drawSlitherGrid . fst <> solstyle . drawEdges . snd)++liarslither :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b IntGrid (Loop, SGrid Bool)+liarslither = (,)+ drawSlitherGrid+ (solstyle . drawCrosses . snd . snd+ <> drawSlitherGrid . fst+ <> solstyle . drawEdges . fst . snd)++tightfitskyscrapers :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ()))+ (SGrid (Tightfit Int))+tightfitskyscrapers = (,)+ (atCentres drawInt . outsideclues . fst+ <> drawTightGrid (const mempty) . snd)+ (atCentres drawInt . outsideclues . fst . fst+ <> drawTightGrid drawInt . snd)++wordgrid :: (Backend b R2, Renderable (Path R2) b) =>+ SGrid (Maybe Char) -> [String] -> Diagram b R2+wordgrid g ws = stackWords ws `besidesR` drawClueGrid g++wordloop :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (CharClueGrid, [String]) CharClueGrid+wordloop = (,)+ (uncurry wordgrid)+ (drawClueGrid . snd)++wordsearch :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])+wordsearch = (,)+ (uncurry wordgrid) + (solstyle . drawMarkedWords . snd . snd+ <> drawClueGrid . fst . snd)++curvedata :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid (Clue [Edge])) [Edge]+curvedata = (,)+ cd+ ((solstyle . drawDualEdges . snd) <> cd . fst)+ where cd = (atCentres drawCurve . clues <> grid . size)++doubleback :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b AreaGrid Loop+doubleback = (,)+ drawAreaGridGray+ (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst)++slalom :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b IntGrid (SGrid SlalomDiag)+slalom = (,)+ drawSlalomGrid+ (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd)++compass :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid+compass = (,)+ drawCompassGrid+ (drawCompassClues . fst <> drawAreaGridGray . snd)++boxof2or3 :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid MasyuPearl, [Edge]) ()+boxof2or3 = (,)+ (atCentres smallPearl . values . fst+ <> phantom' . grid . size . fst+ <> drawThinDualEdges . snd)+ (error "boxof2or3 solution not implemented")++afternoonskyscrapers :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b (SGrid Shade) IntGrid+afternoonskyscrapers = (,)+ (grid . size <> atCentres drawShade . values)+ (drawIntGrid . snd <> atCentres drawShade . values . fst)++countnumbers :: (Backend b R2, Renderable (Path R2) b) =>+ RenderPuzzle b AreaGrid IntGrid+countnumbers = (,)+ drawAreaGrid+ (drawIntGrid . snd <> drawAreaGrid . fst)
+ src/Diagrams/Puzzles/Pyramid.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}++module Diagrams.Puzzles.Pyramid where++import Diagrams.Prelude++import Data.Puzzles.Elements+import Data.Puzzles.Pyramid+import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Widths+import Diagrams.Puzzles.Grid (border)++pgray :: Colour Double+pgray = blend 0.6 white black++cell :: (Backend b R2, Renderable (Path R2) b) => Bool -> Diagram b R2+cell s = square 1 # lw onepix # if s then fc pgray else id++clue :: (Backend b R2, Renderable (Path R2) b) => Maybe Int -> Diagram b R2+clue Nothing = mempty+clue (Just c) = text' (show c)++cellc :: (Backend b R2, Renderable (Path R2) b) => Bool -> Maybe Int -> Diagram b R2+cellc s c = clue c `atop` cell s++row :: (Backend b R2, Renderable (Path R2) b) => Row -> Diagram b R2+row (R cs s) = centerX . hcat . map (cellc s) $ cs++pyramid :: (Backend b R2, Renderable (Path R2) b) => Pyramid -> Diagram b R2+pyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map row . unPyr $ p)+ where s = psize p++kropki :: (Backend b R2, Renderable (Path R2) b) => KropkiDot -> Diagram b R2+kropki None = mempty+kropki c = circle 0.1 # lw 0.03 # fc (col c) # smash+ where col White = white+ col Black = blend 0.98 black white+ col None = error "can't reach"++krow :: (Backend b R2, Renderable (Path R2) b) => KropkiRow -> Diagram b R2+krow (KR cs s ks) = ccat dots <> ccat clues+ where ccat = centerX . hcat+ clues = map (cellc s) cs+ clues' = map (cellc s) cs :: [D R2]+ dots = interleave (map phantom' clues') (map kropki ks)++kpyramid :: (Backend b R2, Renderable (Path R2) b) => RowKropkiPyramid -> Diagram b R2+kpyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map krow . unKP $ p)+ where s = psize (plainpyramid p)
+ src/Diagrams/Puzzles/Widths.hs view
@@ -0,0 +1,21 @@+module Diagrams.Puzzles.Widths where++gridres :: Int+gridres = 40++onepix :: Double+onepix = 1 / fromIntegral gridres++twopix, fourpix :: Double+twopix = 2 * onepix+fourpix = 4 * onepix++gridwidth :: Double+gridwidth = onepix++framewidthfactor :: Double+framewidthfactor = 4++edgewidth, borderwidth :: Double+edgewidth = 3 * onepix+borderwidth = 1 / 4 + onepix / 2
+ src/Text/Puzzles/Puzzle.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Puzzles.Puzzle where++import Data.Yaml+import Control.Applicative++import Data.Puzzles.PuzzleTypes++data TypedPuzzle = TP (Maybe String) Value (Maybe Value)+ deriving Show++instance FromJSON TypedPuzzle where+ parseJSON (Object v) = TP <$>+ v .:? "type" <*>+ v .: "puzzle" <*>+ v .:? "solution"+ parseJSON _ = empty++-- | A pair of parsers for a puzzle type.+-- First parses the puzzle, second the solution.+type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b)++parseType :: String -> Parser PuzzleType+parseType t = case lookupType t of+ Nothing -> fail $ "unknown puzzle type: " ++ t+ Just p -> return p
+ src/Text/Puzzles/PuzzleTypes.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Puzzles.PuzzleTypes (+ lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,+ sudoku, thermosudoku, pyramid, kpyramid, slither,+ liarslither, tightfitskyscrapers, wordloop, wordsearch,+ curvedata, doubleback, slalom, compass, boxof2or3,+ afternoonskyscrapers, countnumbers,+ ) where++import Prelude hiding (sequence)++import Control.Applicative+import Control.Monad hiding (sequence)++import Data.Yaml++import Text.Puzzles.Util+import Text.Puzzles.Puzzle+import Data.Puzzles.Grid+import Data.Puzzles.GridShape hiding (size)+import qualified Data.Puzzles.Pyramid as Pyr+import Data.Puzzles.Elements++lits :: ParsePuzzle AreaGrid ShadedGrid+lits = (parseGrid, parseShadedGrid)++litsplus :: ParsePuzzle AreaGrid ShadedGrid+litsplus = lits++geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop+geradeweg = (parseClueGrid, parseEdges)++fillomino :: ParsePuzzle IntGrid IntGrid+fillomino = (parseClueGrid, parseClueGrid)++masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop+masyu = (parseClueGrid, parseEdges)++nurikabe :: ParsePuzzle IntGrid ShadedGrid+nurikabe = (parseSpacedClueGrid, parseShadedGrid)++latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char))+latintapa = ((unRG <$>) . parseJSON, parseClueGrid)++sudoku :: ParsePuzzle IntGrid IntGrid+sudoku = (parseClueGrid, parseClueGrid)++thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid+thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid)++pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol+pyramid = (parseJSON, parseJSON)++kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol+kpyramid = (parseJSON, parseJSON)++slither :: ParsePuzzle (SGrid (Clue Int)) Loop+slither = (parseClueGrid, parseEdges)++newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) }+instance FromJSON LSol where+ parseJSON (Object v) = LSol <$> ((,) <$>+ (parseEdges =<< v .: "loop") <*>+ (parseShadedGrid =<< v .: "liars"))+ parseJSON _ = mzero++liarslither :: ParsePuzzle (SGrid (Clue Int)) (Loop, SGrid Bool)+liarslither = (parseClueGrid, (unLSol <$>) . parseJSON)++tightfitskyscrapers :: ParsePuzzle+ (OutsideClues (Maybe Int), SGrid (Tightfit ()))+ (SGrid (Tightfit Int))+tightfitskyscrapers = (parseTightOutside, parseTightIntGrid)++newtype GridWords = GW { unGW :: (CharClueGrid, [String]) }++instance FromJSON GridWords where+ parseJSON (Object v) = GW <$> ((,) <$>+ (parseClueGrid =<< v .: "grid") <*>+ v .: "words")+ parseJSON _ = empty++wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid+wordloop = ((unGW <$>) . parseJSON, parseClueGrid)++newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) }++instance FromJSON GridMarked where+ parseJSON (Object v) = GM <$> ((,) <$>+ (parseClueGrid =<< v .: "grid") <*>+ (map unPMW <$> v .: "words"))+ parseJSON _ = mzero++wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])+wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON)++newtype Curve = Curve { unCurve :: [Edge] }++instance FromJSON Curve where+ parseJSON v = Curve <$> parsePlainEdges v++curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge]+curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges)++doubleback :: ParsePuzzle AreaGrid Loop+doubleback = (parseGrid, parseEdges)++slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag)+slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v)++compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid+compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid)++boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) ()+boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented")++afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid+afternoonskyscrapers = (parseAfternoonGrid, parseGrid)++-- this should be changed to support clue numbers+countnumbers :: ParsePuzzle AreaGrid IntGrid+countnumbers = (parseGrid, parseGrid)
+ src/Text/Puzzles/Util.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Puzzles.Util where++import Prelude hiding (sequence)++import Control.Applicative+import Control.Arrow+import Control.Monad hiding (sequence)++import Data.Hashable+import Data.Maybe (catMaybes)+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap+import Data.Traversable (traverse, sequence, sequenceA, Traversable)+import Data.Foldable (Foldable, fold)+import Data.Monoid ((<>))+import Data.List (intersect)++import Data.Char (digitToInt, isAlpha, isDigit)+import Text.Read (readMaybe)+import qualified Data.Text as T++import Data.Yaml++import Data.Puzzles.Grid+import Data.Puzzles.GridShape hiding (size)+import Data.Puzzles.Elements++class FromChar a where+ parseChar :: Char -> Parser a++instance FromChar Char where+ parseChar = pure++class FromString a where+ parseString :: String -> Parser a++instance FromChar Int where+ parseChar c+ | isDigit c = digitToInt <$> parseChar c+ | otherwise = fail $ "expected a digit, got '" ++ [c] ++ "'"++newtype Alpha = Alpha { unAlpha :: Char }+ deriving (Show, Ord, Eq)++instance FromChar Alpha where+ parseChar c+ | isAlpha c = Alpha <$> parseChar c+ | otherwise = empty++-- | A rectangle. Each row has length `w`.+data Rect a = Rect !Int !Int [[a]]+ deriving Show++instance Functor Rect where+ fmap f (Rect w h ls) = Rect w h (map (map f) ls)++instance FromChar a => FromJSON (Rect a) where+ parseJSON (String t) = Rect w h <$> filled+ where+ ls = map T.stripEnd . T.lines $ t+ w = maximum . map T.length $ ls+ h = length ls+ filledc = map (T.unpack . T.justifyLeft w ' ') ls+ filled = sequence . map (mapM parseChar) $ filledc+ parseJSON _ = empty++data Border a = Border [a] [a] [a] [a]+ deriving Show++-- | This instance might be a lie.+instance Foldable Border where+ fold (Border l r b t) = fold l <> fold r <> fold b <> fold t++instance Traversable Border where+ sequenceA (Border l r b t) = Border <$> sequenceA l+ <*> sequenceA r+ <*> sequenceA b+ <*> sequenceA t++instance Functor Border where+ f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t)++data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b)+ deriving Show++instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where+ parseJSON v = do+ Rect w h ls <- parseJSON v+ let b = Border (reverse . map head . middle h $ ls)+ (reverse . map last . middle h $ ls)+ (middle w . last $ ls)+ (middle w . head $ ls)+ ls' = map (middle w) . middle h $ ls+ mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls)+ [head . head, head . last, last . head, last . last]+ lsparsed <- sequence . map (mapM parseChar) $ ls'+ bparsed <- sequenceA . fmap parseChar $ b+ return $ BorderedRect (w-2) (h-2) lsparsed bparsed+ where+ middle len = take (len - 2) . drop 1++newtype SpacedRect a = SpacedRect { unSpaced :: Rect a }++instance FromString a => FromJSON (SpacedRect a) where+ parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p+ else empty+ where+ ls = map T.words . T.lines $ t+ w = maximum . map length $ ls+ wmin = minimum . map length $ ls+ h = length ls+ p = sequence . map (mapM (parseString . T.unpack)) $ ls+ parseJSON _ = empty++instance FromChar MasyuPearl where+ parseChar '*' = pure MBlack+ parseChar 'o' = pure MWhite+ parseChar _ = empty++data Space = Space++instance FromChar Space where+ parseChar ' ' = pure Space+ parseChar _ = empty++data Blank = Blank++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+ parseChar '/' = pure SlalomForward+ parseChar '\\' = pure SlalomBackward+ parseChar _ = empty++instance (FromChar a, FromChar b) => FromChar (Either a b) where+ parseChar c = Left <$> parseChar c <|> Right <$> parseChar c++instance (FromString a, FromString b) => FromString (Either a b) where+ parseString c = Left <$> parseString c <|> Right <$> parseString c++instance FromChar a => FromChar (Maybe a) where+ parseChar = optional . parseChar++listListToMap :: [[a]] -> Map.Map (Cell Square) a+listListToMap ls = Map.fromList . concat+ . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]+ $ ls+ where+ h = length ls++rectToSGrid :: Rect a -> SGrid a+rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls)++rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a)+rectToClueGrid = fmap (either (const Nothing) Just) . rectToSGrid++newtype Shaded = Shaded { unShaded :: Bool }++instance FromChar Shaded where+ parseChar 'x' = pure . Shaded $ True+ parseChar 'X' = pure . Shaded $ True+ parseChar _ = pure . Shaded $ False++parseShadedGrid :: Value -> Parser (SGrid Bool)+parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v++parseGrid :: FromChar a => Value -> Parser (SGrid a)+parseGrid v = rectToSGrid <$> parseJSON v++parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a))+parseClueGrid v = rectToClueGrid <$> parseJSON v++parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a))+parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v++-- parses a string like+-- o-o-o+-- | |+-- o-o o+-- | |+-- o-o+parsePlainEdges :: Value -> Parser [Edge]+parsePlainEdges v = readEdges <$> parseGrid v++readEdges :: SGrid Char -> [Edge]+readEdges g = horiz ++ vert+ where (w, h) = size g+ w' = w `div` 2+ h' = h `div` 2+ isHoriz (x, y) = g ! (2 * x + 1, 2 * y) == '-'+ isVert (x, y) = g ! (2 * x, 2 * y + 1) == '|'+ horiz = [ E (x, y) H | x <- [0 .. w' - 1]+ , y <- [0 .. h']+ , isHoriz (x, y)+ ]+ vert = [ E (x, y) V | x <- [0 .. w']+ , y <- [0 .. h' - 1]+ , isVert (x, y)+ ]++parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a)+parseGridChars = traverse parseChar++-- | Parse a grid of edges with values at the nodes.+--+-- E.g. o-*-*-o+-- | |+-- *-o+-- to a grid of masyu pearls and some edges.+parseNodeEdges :: FromChar a =>+ Value -> Parser (SGrid a, [Edge])+parseNodeEdges v = (,) <$>+ (parseGridChars =<< halveGrid =<< parseGrid v) <*>+ parsePlainEdges v+ where+ halveGrid (Grid (Square w h) m)+ | odd w && odd h = pure $ Grid s' m'+ | otherwise = empty+ where+ s' = Square ((w + 1) `div` 2) ((h + 1) `div` 2)+ m' = Map.mapKeys (both (`div` 2))+ . Map.filterWithKey (const . (uncurry (&&) . both even))+ $ m+ both f (x, y) = (f x, f y)++data HalfDirs = HalfDirs {unHalfDirs :: [Dir]}++instance FromChar HalfDirs where+ parseChar c | c == '└' = pure . HalfDirs $ [V, H]+ | c `elem` "│┘" = pure . HalfDirs $ [V]+ | c `elem` "─└┌" = pure . HalfDirs $ [H]+ | otherwise = pure . HalfDirs $ []++-- parses a string like+-- ┌┐┌─┐+-- ││└┐│+-- │└─┘│+-- └──┐│+-- └┘+parseEdges :: Value -> Parser [Edge]+parseEdges v = do+ Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v+ return [ E p d | (p, ds) <- Map.toList m, d <- ds ]++type ThermoRect = Rect (Either Blank (Either Int Alpha))++partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b)+partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty)+ where+ insertEither k = either (first . Map.insert k) (second . Map.insert k)++parseThermos :: SGrid Alpha -> Parser [Thermometer]+parseThermos (Grid s m) = catMaybes <$> mapM parseThermo (Map.keys m)+ where+ m' = fmap unAlpha m+ parseThermo :: Cell Square -> Parser (Maybe Thermometer)+ parseThermo p | not (isStart p) = pure Nothing+ | not (isAlmostIsolated p) = fail $ show p ++ " not almost isolated"+ | otherwise = Just <$> parseThermo' p+ parseThermo' :: Cell Square -> Parser Thermometer+ parseThermo' p = do+ q <- next p+ maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q+ parseThermo'' :: Cell Square -> Parser Thermometer+ parseThermo'' p = do+ q <- next p+ maybe (pure [p]) (fmap (p:) . parseThermo'') q+ next :: Cell Square -> Parser (Maybe (Cell Square))+ next p = case succs p of+ [] -> pure Nothing+ [q] -> pure (Just q)+ _ -> fail "multiple successors"+ succs p = filter (test ((==) . succ) p) . neighbours s $ p+ isStart p = not . any (test ((==) . pred) p) . neighbours s $ p+ test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m')+ isAlmostIsolated p = all disjointSucc . neighbours s $ p+ where+ disjointSucc q = null $ intersect (succs p) (succs' q)+ succs' q = maybe [] (const $ succs q) (Map.lookup q m')++parseThermoGrid :: ThermoRect -> Parser (SGrid Int, [Thermometer])+parseThermoGrid (Rect w h ls) = (,) (Grid s ints) <$>+ (parseThermos $ Grid s alphas)+ where+ s = Square w h+ (ints, alphas) = partitionEithers . snd . partitionEithers $+ listListToMap ls++newtype Tight = Tight { unTight :: Tightfit () }++instance FromChar Tight where+ parseChar '.' = pure . Tight $ Single ()+ parseChar '/' = pure . Tight $ UR () ()+ parseChar '\\' = pure . Tight $ DR () ()+ parseChar _ = empty++parseTightOutside :: Value -> Parser (OutsideClues (Maybe Int),+ SGrid (Tightfit ()))+parseTightOutside v = do+ BorderedRect w h ls b <- parseJSON v+ :: 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++instance FromChar a => FromString (Tightfit a) where+ parseString [c] = Single <$> parseChar c+ parseString (c: '/':d:[]) = UR <$> parseChar c <*> parseChar d+ parseString (c:'\\':d:[]) = DR <$> parseChar c <*> parseChar d+ parseString _ = empty++parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int))+parseTightIntGrid v = rectToSGrid . unSpaced <$> parseJSON v++newtype PMarkedWord = PMW {unPMW :: MarkedWord}++parseNWords :: Int -> String -> Parser [String]+parseNWords n s | length ws == n = pure ws+ | otherwise = empty+ where+ ws = words s++instance FromJSON PMarkedWord where+ parseJSON v = PMW <$> (MW <$>+ ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*>+ ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)))+ where x = parseJSON v >>= parseNWords 4 >>= mapM parseString++instance FromString Int where+ parseString s = maybe empty pure $ readMaybe s++newtype PCompassC = PCC {unPCC :: CompassC}++instance FromJSON PCompassC where+ parseJSON (String t) = comp . map T.unpack . T.words $ t+ where c "." = pure Nothing+ c x = Just <$> parseString x+ comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w)+ comp _ = empty+ parseJSON _ = empty++newtype RefGrid a = RefGrid { unRG :: SGrid a }++data Ref = Ref { unRef :: Char }+ deriving Show++instance FromChar Ref where+ parseChar c | isAlpha c = pure (Ref c)+ parseChar _ = empty++hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b+hashmaptomap = Map.fromList . HMap.toList++compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c)+compose m1 m2 = sequence . Map.map (flip Map.lookup m2) $ m1++instance FromJSON a => FromJSON (RefGrid a) where+ parseJSON (Object v) = RefGrid <$> do+ Grid s refs <- fmap (fmap ((:[]) . unRef)) . rectToClueGrid <$>+ (v .: "grid" :: Parser (Rect (Either Blank Ref)))+ m <- hashmaptomap <$> v .: "clues"+ case compose (Map.mapMaybe id refs) m of+ Nothing -> mzero+ Just m' -> return $ Grid s m'+ parseJSON _ = empty++parseAfternoonGrid :: Value -> Parser (SGrid Shade)+parseAfternoonGrid v = do+ (Grid s _ , es) <- parseNodeEdges v :: Parser (SGrid Char, [Edge])+ let (m, b) = splitBorder s $ toMap es+ guard $ Map.null b+ return $ Grid (shrink s) m+ where+ shrink (Square w h) = Square (w-1) (h-1)+ toShade V = Shade False True+ toShade H = Shade True False+ merge (Shade a b) (Shade c d)+ | a && c || b && d = error "shading collision"+ | otherwise = Shade (a || c) (b || d)+ toMap es = Map.fromListWith+ merge+ [(p, toShade d) | E p d <- es]+ splitBorder (Square w h) = Map.partitionWithKey+ (\(x, y) _ -> x < w - 1 && y < h - 1)++
+ tests/tests.hs view
@@ -0,0 +1,325 @@+import Test.Tasty+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 Data.Puzzles.Elements (Thermometer)+import Text.Puzzles.Util (parseChar)+import Text.Puzzles.PuzzleTypes+import qualified Data.Puzzles.Grid as Grid+import Data.Puzzles.Pyramid (PyramidSol(..))++import Diagrams.Puzzles.PuzzleGrids+import Diagrams.Prelude+import Diagrams.Backend.SVG++import Text.Blaze.Svg.Renderer.Text (renderSvg)+import qualified Data.Text as T++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"+ ]++compass_broken_4 :: Value+compass_broken_4 = decodeLines $+ [ "grid: |"+ , " a.b"+ , "clues:"+ , " a: 1 . . 2 3"+ , " b: 21 . . 0"+ ]++compass_broken_5 :: Value+compass_broken_5 = decodeLines $+ [ "grid: |"+ , " a3b"+ , "clues:"+ , " a: 1 . . 2 3"+ , " b: 21 . . 0"+ ]++thermo_1 :: Value+thermo_1 = packLines $+ [ ".b..2."+ , "a.c5.1"+ , ".d..6."+ , ".4..c."+ , "5.3b.d"+ , ".2..a."+ ]++test_thermo_1 :: [Thermometer]+test_thermo_1 = either (const []) snd res+ where+ res = 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"++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++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]]++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+ , 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+ ]