puzzle-draw 0.1.0.4 → 0.2.0.0

raw patch · 39 files changed

+3302/−974 lines, 39 filesdep +hspecdep +lineardep +processdep ~basedep ~diagrams-cairodep ~diagrams-libnew-component:exe:checkpuzzlenew-component:exe:test-comparePVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, linear, process, tasty-golden, tasty-hspec

Dependency ranges changed: base, diagrams-cairo, diagrams-lib, diagrams-svg, optparse-applicative

API changes (from Hackage documentation)

Files

• CHANGES.md +7/−0
• README.md +2/−1
• puzzle-draw.cabal +55/−15
• src/Data/Puzzles/CmdLine.hs +27/−0
• src/Data/Puzzles/Code.hs +13/−0
• src/Data/Puzzles/Compose.hs +47/−47
• src/Data/Puzzles/Elements.hs +38/−4
• src/Data/Puzzles/Grid.hs +165/−124
• src/Data/Puzzles/GridShape.hs +176/−57
• src/Data/Puzzles/PuzzleTypes.hs +90/−0
• src/Data/Puzzles/Sudoku.hs +11/−11
• src/Data/Puzzles/Util.hs +32/−0
• src/Diagrams/Puzzles/CmdLine.hs +6/−28
• src/Diagrams/Puzzles/Code.hs +53/−0
• src/Diagrams/Puzzles/Draw.hs +25/−13
• src/Diagrams/Puzzles/Elements.hs +210/−38
• src/Diagrams/Puzzles/Grid.hs +112/−152
• src/Diagrams/Puzzles/Lib.hs +80/−33
• src/Diagrams/Puzzles/PuzzleGrids.hs +62/−62
• src/Diagrams/Puzzles/PuzzleTypes.hs +595/−95
• src/Diagrams/Puzzles/Pyramid.hs +10/−16
• src/Diagrams/Puzzles/Style.hs +50/−0
• src/Diagrams/Puzzles/Widths.hs +3/−1
• src/Text/Puzzles/Code.hs +22/−0
• src/Text/Puzzles/Parsec.hs +30/−0
• src/Text/Puzzles/Puzzle.hs +3/−2
• src/Text/Puzzles/PuzzleTypes.hs +316/−42
• src/Text/Puzzles/Util.hs +358/−181
• src/tools/checkpuzzle.hs +94/−0
• src/tools/drawpuzzle.hs +24/−5
• tests/Data.hs +244/−0
• tests/Data/Puzzles/GridShapeSpec.hs +11/−0
• tests/Data/Puzzles/GridSpec.hs +22/−0
• tests/Diagrams/Puzzles/GridSpec.hs +32/−0
• tests/Text/Puzzles/PuzzleTypesSpec.hs +54/−0
• tests/Text/Puzzles/UtilSpec.hs +68/−0
• tests/Util.hs +29/−0
• tests/compare.hs +27/−0
• tests/tests.hs +99/−47

@@ -1,3 +1,10 @@+0.2.0.0: 20161211+-----------------++* Upgrade diagrams version.+* Add various new puzzle types.+* Add solution code markers.+ 0.1.0.4: 20141115 ----------------- 

@@ -45,7 +45,8 @@     ..X... ``` -There is a demo web application at [demo] that provides some more+There is a demo web application at+[puzzle-draw-demo.herokuapp.com][demo] that provides some more examples and that can be used to generate SVG images from such puzzle descriptions. 

@@ -1,5 +1,5 @@ name:                puzzle-draw-version:             0.1.0.4+version:             0.2.0.0 synopsis:            Creating graphics for pencil puzzles. description:         puzzle-draw is a library and tool for drawing pencil                      puzzles using Diagrams. It aims to provide a utility@@ -28,14 +28,20 @@ library   exposed-modules:     Data.Puzzles.Grid                        Data.Puzzles.GridShape+                       Data.Puzzles.Util                        Data.Puzzles.Elements                        Data.Puzzles.Pyramid                        Data.Puzzles.Sudoku                        Data.Puzzles.Compose                        Data.Puzzles.PuzzleTypes+                       Data.Puzzles.Code+                       Data.Puzzles.CmdLine                        Text.Puzzles.Util+                       Text.Puzzles.Parsec                        Text.Puzzles.Puzzle                        Text.Puzzles.PuzzleTypes+                       Text.Puzzles.Code+                       Diagrams.Puzzles.Style                        Diagrams.Puzzles.Grid                        Diagrams.Puzzles.Lib                        Diagrams.Puzzles.Elements@@ -44,11 +50,12 @@                        Diagrams.Puzzles.PuzzleGrids                        Diagrams.Puzzles.PuzzleTypes                        Diagrams.Puzzles.Draw+                       Diagrams.Puzzles.Code                        Diagrams.Puzzles.CmdLine   -- For access to the font files in the data directory.   other-modules:       Paths_puzzle_draw-  build-depends:       base >= 4.2 && < 5,-                       diagrams-lib >= 1.2,+  build-depends:       base >= 4.8 && < 5,+                       diagrams-lib >= 1.3.1,                        parsec >= 3.1,                        yaml >= 0.8.4,                        aeson >= 0.7,@@ -59,47 +66,80 @@                        SVGFonts >= 1.4,                        vector-space >= 0.8,                        mtl >= 2.1,-                       optparse-applicative >= 0.7,-                       filepath >= 1.3+                       optparse-applicative >= 0.12 && < 0.13,+                       filepath >= 1.3,+                       linear   if flag(cairo)     cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.1+    build-depends:     diagrams-cairo >= 1.3   else-    build-depends:     diagrams-svg >= 1.1+    build-depends:     diagrams-svg >= 1.3   hs-source-dirs:      src   ghc-options:         -Wall  executable drawpuzzle   main-is:          drawpuzzle.hs   hs-source-dirs:   src/tools-  build-depends:       base >= 4.2,+  build-depends:       base >= 4.8 && < 5,                        puzzle-draw,-                       diagrams-lib >= 1.2,+                       diagrams-lib >= 1.3,                        yaml >= 0.8.4,-                       optparse-applicative >= 0.7,+                       optparse-applicative >= 0.12,                        aeson >= 0.7,                        filepath >= 1.3   if flag(cairo)     cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.1+    build-depends:     diagrams-cairo >= 1.3   else-    build-depends:     diagrams-svg >= 1.1+    build-depends:     diagrams-svg >= 1.3   ghc-options:         -Wall +executable checkpuzzle+  main-is:          checkpuzzle.hs+  hs-source-dirs:   src/tools+  build-depends:       base >= 4.8 && < 5,+                       puzzle-draw,+                       yaml >= 0.8.4,+                       optparse-applicative >= 0.12,+                       aeson >= 0.7,+                       filepath >= 1.3+  ghc-options:         -Wall+ test-suite test   type:                exitcode-stdio-1.0   hs-source-dirs:      tests   main-is:             tests.hs-  build-depends:       base >= 4.2,+  other-modules:       Data,+                       Util,+                       Data.Puzzles.GridSpec,+                       Data.Puzzles.GridShapeSpec,+                       Diagrams.Puzzles.GridSpec,+                       Text.Puzzles.PuzzleTypesSpec,+                       Text.Puzzles.UtilSpec+  build-depends:       base >= 4.8 && < 5,                        tasty >= 0.8,+                       tasty-hspec,                        tasty-hunit >= 0.8,+                       hspec,                        yaml >= 0.8.4,                        text >= 1.1,                        deepseq >= 1.3,                        containers >= 0.5,                        blaze-svg >= 0.3,-                       diagrams-lib >= 1.2,-                       diagrams-svg >= 1.1,+                       diagrams-lib >= 1.3,+                       diagrams-svg >= 1.3,                        bytestring >= 0.10,                        puzzle-draw+  ghc-options:         -Wall++-- This should depend on the executable `drawpuzzle`+-- and not the library.+executable test-compare+  hs-source-dirs:      tests+  main-is:             compare.hs+  build-depends:       base >= 4.8 && < 5,+                       tasty >= 0.8,+                       tasty-golden >= 2.0,+                       filepath >= 1.3,+                       process >= 1.2   ghc-options:         -Wall

@@ -0,0 +1,27 @@+module Data.Puzzles.CmdLine+    ( checkType+    , exitErr+    , readPuzzle+    ) where++import Text.Puzzles.Puzzle+import Data.Puzzles.PuzzleTypes++import qualified Data.Yaml as Y+import System.Exit++checkType :: Maybe String -> IO PuzzleType+checkType mt = do+    t <- maybe errno return mt+    maybe (errunk t) return (lookupType t)+  where+    errno    = exitErr "no puzzle type given"+    errunk t = exitErr $ "unknown puzzle type: " ++ t++readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle)+readPuzzle = Y.decodeFileEither++exitErr :: String -> IO a+exitErr e = putStrLn e >> exitFailure++

@@ -0,0 +1,13 @@+module Data.Puzzles.Code where++import Data.Puzzles.Grid+import Data.Puzzles.GridShape++type Code = [CodePart]++data CodePart =+      Rows'  [Int] -- ^ Rows of cells, counted from the bottom.+    | Cols   [Int] -- ^ Cols of cells, counted from the left.+    | RowsN' [Int] -- ^ Rows of nodes, counted from the bottom.+    | ColsN  [Int] -- ^ Cols of nodes, counted from the left.+    | LabelsN (Grid N (Maybe Char)) -- ^ Nodes, labeld by letters.

@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}  -- | -- Helpers to string together parser and renderer by puzzle type.@@ -8,18 +9,11 @@     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@@ -41,6 +35,7 @@         PuzzleHandler b a -> PuzzleType -> a handle f LITS                 = f R.lits                D.lits handle f LITSPlus             = f R.litsplus            D.litsplus+handle f LITSSym              = f R.lits                D.litssym handle f Geradeweg            = f R.geradeweg           D.geradeweg handle f Fillomino            = f R.fillomino           D.fillomino handle f Masyu                = f R.masyu               D.masyu@@ -69,55 +64,60 @@ handle f PrimePlace           = f R.primeplace          D.primeplace handle f Labyrinth            = f R.labyrinth           D.labyrinth handle f Bahnhof              = f R.bahnhof             D.bahnhof+handle f BlackoutDominos      = f R.blackoutDominos     D.blackoutDominos+handle f TwilightTapa         = f R.tapa                D.tapa+handle f TapaCave             = f R.tapa                D.tapa+handle f DominoPillen         = f R.dominoPills         D.dominoPills+handle f SlitherLinkMulti     = f R.slithermulti        D.slithermulti+handle f AngleLoop            = f R.angleLoop           D.angleLoop+handle f Shikaku              = f R.shikaku             D.shikaku+handle f SlovakSums           = f R.slovaksums          D.slovaksums+handle f Anglers              = f R.anglers             D.anglers+handle f Dominos              = f R.dominos             D.dominos+handle f FillominoCheckered   = f R.fillomino           D.fillominoCheckered+handle f FillominoLoop        = f R.fillominoLoop       D.fillominoLoop handle f Cave                 = f R.cave                D.cave---- | 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'))+handle f Numberlink           = f R.numberlink          D.numberlink+handle f Skyscrapers          = f R.skyscrapers         D.skyscrapers+handle f SkyscrapersStars     = f R.skyscrapersStars    D.skyscrapersStars+handle f SkyscrapersFrac      = f R.tightfitskyscrapers D.tightfitskyscrapers+handle f TurningFences        = f R.slither             D.slither+handle f Summon               = f R.summon              D.summon+handle f Baca                 = f R.baca                D.baca+handle f Buchstabensalat      = f R.buchstabensalat     D.buchstabensalat+handle f Doppelblock          = f R.doppelblock         D.doppelblock+handle f SudokuDoppelblock    = f R.sudokuDoppelblock   D.sudokuDoppelblock+handle f Loopki               = f R.loopki              D.loopki+handle f Scrabble             = f R.scrabble            D.scrabble+handle f Neighbors            = f R.neighbors           D.neighbors+handle f Starwars             = f R.starwars            D.starwars+handle f Starbattle           = f R.starbattle          D.starbattle+handle f Heyawake             = f R.heyawake            D.heyawake+handle f Wormhole             = f R.wormhole            D.wormhole+handle f Pentominous          = f R.pentominous         D.pentominous+handle f ColorAkari           = f R.colorakari          D.colorakari+handle f PersistenceOfMemory  = f R.persistenceOfMemory D.persistenceOfMemory+handle f ABCtje               = f R.abctje              D.abctje+handle f Kropki               = f R.kropki              D.kropki+handle f StatuePark           = f R.statuepark          D.statuepark+handle f PentominousBorders   = f R.pentominousBorders  D.pentominousBorders+handle f NanroSignpost        = f R.nanroSignpost       D.nanroSignpost+handle f TomTom               = f R.tomTom              D.tomTom+handle f HorseSnake           = f R.horseSnake          D.horseSnake+handle f Illumination         = f R.illumination        D.illumination+handle f Pentopia             = f R.pentopia            D.pentopia+handle f PentominoPipes       = f R.pentominoPipes      D.pentominoPipes+handle f GreaterWall          = f R.greaterWall         D.greaterWall+handle f Galaxies             = f R.galaxies            D.galaxies  -- | 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)))+                      -> Parser (Diagram b, Maybe (Diagram b))) 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 =>-                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

@@ -1,7 +1,7 @@ -- | Types for a variety of puzzle elements. module Data.Puzzles.Elements where -import Data.Puzzles.GridShape (Coord, Edge)+import Data.Puzzles.GridShape  type Clue a = Maybe a @@ -19,6 +19,8 @@  type CompassClue = Clue CompassC +data SlovakClue = SlovakClue !Int !Int+ -- | 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@@ -29,18 +31,25 @@               show' (UR x y)   = show x ++ "/" ++ show y               show' (DR x y)   = show x ++ "\\" ++ show y +-- | A marked line in a grid, given by start and end points.+data MarkedLine a = MarkedLine a a+ -- | 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]+type Loop a = [Edge a] +-- | A loop consisting of straight segments of arbitrary+-- angles between vertices.+type VertexLoop = [N]+ -- | 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]+type Thermometer = [C]  -- | A forward or backward diagonal as occurring in the solution --   of a slalom puzzle.@@ -62,7 +71,32 @@ newtype PrimeDiag = PrimeDiag (Bool, Bool)  data Black = Black-+data Fish = Fish+data Star = Star data Crossing = Crossing  type BahnhofClue = Either Int Crossing++data DigitRange = DigitRange !Int !Int+    deriving (Show, Eq)++digitList :: DigitRange -> [Int]+digitList (DigitRange a b) = [a..b]++data MEnd = MEnd++data Fraction =+    FComp String String String  -- a b/c+  | FFrac String String         -- a/b+  | FInt String                 -- a++data PlainNode = PlainNode++type Myopia = [Dir']++data Relation = RGreater | RLess | REqual | RUndetermined+    deriving (Show, Eq)++type GreaterClue = [Relation]++data GalaxyCentre = GalaxyCentre

@@ -1,166 +1,207 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts,-             GADTs, StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}  -- | Puzzle grids.-module Data.Puzzles.Grid where+module Data.Puzzles.Grid+    (+      Grid+    , AreaGrid+    , ShadedGrid+    , nodes+    , size+    , sizeGrid+    , clues+    , nodeGrid+    , cellGrid -import Data.Maybe+    , dominoGrid++    , borders+    , edgesGen+    , colour+    , collectLines++    , OutsideClues(..)+    , outsideSize+    , outsideClues+    , multiOutsideClues+    , outsideGrid+    ) where+ import qualified Data.Map as Map-import Data.Foldable (Foldable, foldMap)-import Data.Traversable (Traversable, traverse)-import Control.Applicative ((<$>))+import qualified Data.Set as Set+import Data.AffineSpace import Data.VectorSpace+import Control.Monad.State -import Data.Puzzles.GridShape hiding (size, cells)-import qualified Data.Puzzles.GridShape as GS import Data.Puzzles.Elements+import Data.Puzzles.GridShape --- | 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+type Grid k a = Map.Map k a -deriving instance (Show a, Show s, GridShape s) => Show (Grid s a)-deriving instance (Eq s, Eq (Cell s), Eq a) => Eq (Grid s a)+type AreaGrid = Grid C Char+type ShadedGrid = Grid C Bool --- | Standard square grid.-type SGrid = Grid Square+-- | For a grid with value type @Maybe a@, return an association+--   list of cells and @Just@ values.+clues :: Grid k (Maybe a) -> Grid k a+clues = Map.mapMaybe id -type CharGrid = SGrid Char-type AreaGrid = CharGrid-type ShadedGrid = SGrid Bool-type CharClueGrid = SGrid (Maybe Char)-type IntGrid = SGrid (Clue Int)+edgesGen :: Dual' k+         => (a -> a -> Bool) -> (a -> Bool) -> Map.Map k a -> [Edge (Dual k)]+edgesGen p n m = filter (uncurry p' . ends . dualE) es+  where+    (outer, inner) = edgesM m+    es = map unorient outer ++ inner+    p' c d = p'' (Map.lookup c m)+                 (Map.lookup d m)+    p'' (Just e) (Just f) = p e f+    p'' (Just e) Nothing  = n e+    p'' Nothing (Just e)  = n e+    p'' _        _        = False --- | 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)+nodes :: Grid N a -> Set.Set N+nodes = Map.keysSet -instance Foldable (Grid s) where-    foldMap f (Grid _ m) = foldMap f m+-- | The inner edges of a grid that separate unequal cells.+borders :: Eq a => Grid C a -> [Edge N]+borders = edgesGen (/=) (const False) -instance Traversable (Grid s) where-    traverse f (Grid s m) = Grid s <$> traverse f m+corners :: C -> [N]+corners c = map (.+^ (c .-. C 0 0)) [N 0 0, N 1 0, N 0 1, N 1 1] -filterG :: (a -> Bool) -> Grid s a -> Grid s a-filterG p (Grid s m) = Grid s (Map.filter p m)+-- | A grid of empty nodes with all nodes of the cells of the+-- first grid.+nodeGrid :: Grid C a -> Grid N ()+nodeGrid = Map.unions . map cornersM . Map.keys+  where+    cornersM = Map.fromList . map (flip (,) ()) . corners --- | 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+cellGrid :: Grid N a -> Grid C ()+cellGrid m = Map.fromList+           . map (flip (,) ())+           . filter (all (`Map.member` m) . corners)+           . map cellUpRight+           . Map.keys+           $ 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+    cellUpRight :: N -> C+    cellUpRight = fromCoord . toCoord -size :: GridShape s => Grid s a -> GridSize s-size = GS.size . shape+-- | Colour a graph.+colourM :: (Ord k, Eq a) => (k -> [k]) -> Map.Map k a -> Map.Map k Int+colourM nbrs m = fmap fromRight . execState colour' $ start+  where+    fromRight (Right r) = r+    fromRight (Left _)  = error "expected Right" -cells :: GridShape s => Grid s a -> [Cell s]-cells = Map.keys . contents+    start = fmap (const $ Left [1..]) m+    colour' = mapM_ pickAndFill (Map.keys m) -inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool-inBounds g c = c `elem` cells g+    -- choose a colour for the given node, and spread it to+    -- equal neighbours, removing it from unequal neighbours+    pickAndFill x = do+        v <- (Map.! x) <$> get+        case v of+            Left (c:_) -> fill (m Map.! x) c x+            Left _     -> error "empty set of candidates"+            Right _    -> return () --- | 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 ]+    fill a c x = do+        v <- (Map.! x) <$> get+        case v of+            Left _     -> if m Map.! x == a+                    then do modify (Map.insert x (Right c))+                            mapM_ (fill a c) (nbrs x)+                    else modify (del x c)+            Right _    -> return () --- | Association list of cells and values.-values :: GridShape s => Grid s a -> [(Cell s, a)]-values (Grid _ m) = Map.toList m+    -- remove the given colour from the list of candidates+    del x c = Map.adjust f x+      where+        f (Left cs) = Left $ filter (/= c) cs+        f (Right c') = Right c' -edgesGen :: (a -> a -> Bool) -> (a -> Bool) -> Grid Square a -> [Edge]-edgesGen p n g = [ E pt V | pt <- vedges ] ++ [ E pt H | pt <- hedges ]+colour :: Eq a => Grid C a -> Grid C Int+colour m = colourM edgeNeighbours' m   where-    edges' f (sx, sy) = [ (x + 1, y) | x <- [-1 .. sx - 1]-                                     , y <- [-1 .. sy]-                                     , p' (f (x, y)) (f (x + 1, y)) ]+    edgeNeighbours' p = [ q | q <- edgeNeighbours p+                            , q `Map.member` m ] -    vedges = edges' id (size g)-    hedges = map swap $ edges' swap (swap . size $ g)-    swap (x, y) = (y, x)-    p' c d = p'' (Map.lookup c (contents g))-                 (Map.lookup d (contents g))-    p'' (Just e) (Just f) = p e f-    p'' (Just e) Nothing  = n e-    p'' Nothing (Just e)  = n e-    p'' _        _        = False+-- | Clues along the outside of a square grid.+-- Ordered such that coordinates increase.+data OutsideClues k a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }+    deriving (Show, Eq) -edgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge]-edgesP p g = edgesGen p (const False) g+instance Functor (OutsideClues k) where+    fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t) -dualEdgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge]-dualEdgesP p g = [ E pt H | pt <- hedges ] ++-                 [ E pt V | pt <- vedges ]+outsideSize :: OutsideClues k a -> Size+outsideSize (OC l r b t) = (w, h)   where-    edges' f (sx, sy) = [ (x, y) | x <- [0 .. sx - 2]-                                 , y <- [0 .. sy - 1]-                                 , p' (f (x, y)) (f (x + 1, y)) ]+    w = max (length t) (length b)+    h = max (length l) (length r) -    hedges = edges' id (size g)-    vedges = map swap $ edges' swap (swap . size $ g)-    swap (x, y) = (y, x)-    p' c d = p'' (Map.lookup c (contents g))-                 (Map.lookup d (contents g))-    p'' (Just e) (Just f) = p e f-    p'' _        _        = False+-- | Create a dummy grid matching the given outside clues in size.+outsideGrid :: (Ord k, FromCoord k) => OutsideClues k a -> Grid k ()+outsideGrid = sizeGrid . outsideSize --- | The inner edges of a grid that separate unequal cells.-borders :: Eq a => Grid Square a -> [Edge]-borders = edgesP (/=)+-- | Create a dummy grid of the given size.+sizeGrid :: (Ord k, FromCoord k) => Size -> Grid k ()+sizeGrid (w, h) = Map.mapKeys fromCoord+                . Map.fromList+                $ [ ((x, y), ()) | x <- [0..w-1], y <- [0..h-1] ] --- | Clues along the outside of a square grid.-data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }-    deriving (Show, Eq)+data OClue = OClue+    { ocBase :: (Int, Int)+    , _ocDir :: (Int, Int)+    }+  deriving (Show, Eq, Ord) -instance Functor OutsideClues where-    fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t)+oClues :: OutsideClues k a -> Map.Map OClue a+oClues ocs@(OC l r b t) = Map.fromList . concat $+    [ zipWith (\y c -> (OClue (-1, y) (-1, 0), c)) [0..h-1] l+    , zipWith (\y c -> (OClue ( w, y) ( 1, 0), c)) [0..h-1] r+    , zipWith (\x c -> (OClue ( x,-1) ( 0,-1), c)) [0..w-1] b+    , zipWith (\x c -> (OClue ( x, h) ( 0, 1), c)) [0..w-1] t+    ]+  where+    (w, h) = outsideSize ocs -outsideSize :: OutsideClues a -> (Int, Int)-outsideSize (OC l r b t) = ( max (length t) (length b)-                           , max (length l) (length r)-                           )+outsideClues :: (Ord k, FromCoord k) => OutsideClues k a -> Map.Map k a+outsideClues = Map.mapKeys (fromCoord . ocBase) . oClues -data OutsideClue a = OClue-    { ocBase  :: (Int, Int)-    , ocDir   :: (Int, Int)-    , ocValue :: a-    }+multiOutsideClues :: (Ord k, FromCoord k) => OutsideClues k [a] -> Map.Map k a+multiOutsideClues = Map.mapKeys fromCoord+                  . Map.fromList . concatMap distrib . Map.toList+                  . oClues+  where+    distrib (OClue o d, xs) = zip [o ^+^ i *^ d | i <- [0..]] xs -instance Functor OutsideClue where-    fmap f (OClue b d x) = OClue b d (f x)+dualEdgesP :: Key k+           => (a -> a -> Bool) -> Grid k a -> [Edge k]+dualEdgesP p m = concatMap f (Map.keys m)+  where+    f c = [ edge c d | d <- map (c .+^) [(0,1), (1,0)]+                     , d `Map.member` m && p (m Map.! c) (m Map.! d) ] -outsideClueList :: OutsideClues a -> [OutsideClue a]-outsideClueList o@(OC l r b t) =-    concat-       [ zipWith (\ y c -> OClue (0,y)   (-1, 0) c) [0..h-1] l-       , zipWith (\ y c -> OClue (w-1,y) ( 1, 0) c) [0..h-1] r-       , zipWith (\ x c -> OClue (x,0)   ( 0,-1) c) [0..w-1] b-       , zipWith (\ x c -> OClue (x,h-1) ( 0, 1) c) [0..w-1] t-       ]+collectLines :: (Key k, Eq a) => Grid k (Maybe a) -> [Edge k]+collectLines = dualEdgesP eq   where-    (w, h) = outsideSize o+    eq (Just x) (Just y) = x == y+    eq _        _        = False --- | Convert outside clues to association list mapping coordinate to value.-outsideClues :: OutsideClues (Maybe a) -> [((Int, Int), a)]-outsideClues = mapMaybe (liftMaybe . toCell) . outsideClueList+dominoGrid :: DigitRange -> Grid C (Int, Int)+dominoGrid (DigitRange x y) =+    Map.mapKeys fromCoord . Map.fromList $+        [ ((a, s - b), (b + x, a + x))+        | a <- [0..s], b <- [0..s], b <= a ]   where-    toCell (OClue (bx, by) (dx, dy) v) = ((bx + dx, by + dy), v)-    liftMaybe (p, Just x)  = Just (p, x)-    liftMaybe (_, Nothing) = Nothing+    s = y - x -multiOutsideClues :: OutsideClues [a] -> [((Int, Int), a)]-multiOutsideClues = concatMap distrib . outsideClues . fmap Just . dired+size :: Grid Coord a -> Size+size m = foldr (both max) (0, 0) (Map.keys m) ^+^ (1, 1)   where-    dired (OC l r b t) = OC (z (-1,0) l) (z (1,0) r) (z (0,-1) b) (z (0,1) t)-    z x ys = zip (repeat x) ys-    distrib (o, (d, xs)) = zip [o ^+^ i *^ d | i <- [0..]] xs+    both f (x, y) (x', y') = (f x x', f y y')

@@ -1,100 +1,219 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}  -- | Grid shapes.-module Data.Puzzles.GridShape where+module Data.Puzzles.GridShape+    (+      Coord+    , Size+    , Square(..)+    , Dir(..)+    , Edge(..)+    , Dir'(..)+    , Edge'(..)+    , Dual2D(..)+    , Key+    , Dual'+    , C(..)+    , N(..)+    , FromCoord(..)+    , ToCoord(..) -import Data.Foldable (Foldable)+    , edge+    , edge'+    , edgeBetween+    , edgeBetween'+    , orient+    , ends'+    , revEdge+    , edges+    , edgesM+    , ends+    , edgeSize+    , unorient+    , dualE+    , vertexNeighbours+    , edgeNeighbours+    ) where+ import qualified Data.Foldable as F import Data.List (partition)-import Data.VectorSpace ((^+^))+import qualified Data.Map as Map+import Data.AffineSpace --- | The geometry of a grid.-class Show (Cell a) => GridShape a where-    type GridSize a :: *-    type Cell     a :: *-    type Vertex   a :: *+type Coord = (Int, Int) -    size :: a -> GridSize a-    cells :: a -> [Cell a]-    vertices :: a -> [Vertex a]-    vertexNeighbours :: a -> Cell a -> [Cell a]-    edgeNeighbours :: a -> Cell a -> [Cell a]+class FromCoord a where+    fromCoord :: Coord -> a +class ToCoord a where+    toCoord :: a -> Coord++data C = C !Int !Int+    deriving (Show, Eq, Ord)++instance FromCoord C where+    fromCoord = uncurry C++instance ToCoord C where+    toCoord (C x y) = (x, y)++instance AffineSpace C where+    type Diff C = (Int, Int)++    (C x y) .-. (C x' y') = (x - x', y - y')+    (C x y) .+^ (x',y') = C (x + x') (y + y')++data N = N !Int !Int+    deriving (Show, Eq, Ord)++instance FromCoord N where+    fromCoord = uncurry N++instance ToCoord N where+    toCoord (N x y) = (x, y)++instance AffineSpace N where+    type Diff N = (Int, Int)++    (N x y) .-. (N x' y') = (x - x', y - y')+    (N x y) .+^ (x',y') = N (x + x') (y + y')+ -- | 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+data Square = Square     deriving (Show, Eq) -squareNeighbours :: [(Int, Int)] -> Square -> Cell Square -> [Cell Square]-squareNeighbours deltas (Square w h) c = filter inBounds . map (add c) $ deltas-  where-    inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h-    add (x, y) (x', y') = (x + x', y + y')+squareNeighbours :: [(Int,Int)] -> C -> [C]+squareNeighbours deltas c = map (c .+^) deltas -instance GridShape Square where-    type GridSize Square = (Int, Int)-    type Cell Square     = (Int, Int)-    type Vertex Square   = (Int, Int)+vertexNeighbours :: C -> [C]+vertexNeighbours = squareNeighbours [ (dx, dy)+                                    | dx <- [-1..1], dy <- [-1..1]+                                    , dx /= 0 || dy /= 0+                                    ] -    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]]-    vertexNeighbours = squareNeighbours [ (dx, dy)-                                        | dx <- [-1..1], dy <- [-1..1]-                                        , dx /= 0 || dy /= 0-                                        ]-    edgeNeighbours = squareNeighbours [ (dx, dy)-                                      | dx <- [-1..1], dy <- [-1..1]-                                      , dx /= 0 || dy /= 0-                                      , dx == 0 || dy == 0-                                      ]+edgeNeighbours :: C -> [C]+edgeNeighbours = squareNeighbours [ (1, 0), (-1,0), (0,1), (0,-1) ]  -- | Edge direction in a square grid, vertical or horizontal.-data Dir = V | H+data Dir = Vert | Horiz     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+data Edge a = E a Dir     deriving (Show, Eq, Ord) -type Coord = Cell Square-type Size = GridSize Square+type Size = (Int, Int)  -- | Oriented edge direction in a square grid. data Dir' = U | D | L | R     deriving (Eq, Ord, Show) +toDir' :: (Int, Int) -> Dir'+toDir' ( 1, 0) = R+toDir' ( 0, 1) = U+toDir' (-1, 0) = L+toDir' ( 0,-1) = D+toDir' _       = error "non-primitive vector"+ -- | An oriented edge in a square grid.---   @a@ should be @Cell Square@ or @Vertex Square@. data Edge' a = E' a Dir'     deriving (Eq, Ord, Show) --- | The edge between two neighbouring cells, with the first cell---   on the left.-orientedEdge :: Cell Square -> Cell Square -> Edge' (Vertex Square)-orientedEdge (x,y) (x',y')-    | x' == x && y' == y+1  = E' (x,y+1) R-    | x' == x && y' == y-1  = E' (x+1,y) L-    | x' == x+1 && y' == y  = E' (x+1,y+1) D-    | x' == x-1 && y' == y  = E' (x,y) U-    | otherwise             = error $ "not neighbours: " ++-                                      show (x,y) ++ " " ++  show (x',y')+edge' :: (AffineSpace a, Diff a ~ (Int, Int)) => a -> a -> Edge' a+edge' p q = E' p (toDir' (q .-. p)) +edge :: (AffineSpace a, Diff a ~ (Int, Int)) => a -> a -> Edge a+edge p q = unorient $ edge' p q++class Dual2D a where+    type Dual a :: *++    dualE' :: Edge' a -> Edge' (Dual a)++dualE :: Dual' a => Edge a -> Edge (Dual a)+dualE = unorient . dualE' . orient++type Key k = (AffineSpace k, Diff k ~ (Int, Int), Ord k, FromCoord k)+type Dual' k = (Key k, Dual2D k, Key (Dual k), Dual2D (Dual k),+                Dual (Dual k) ~ k)++instance Dual2D N where+    type Dual N = C++    dualE' (E' (N x y) R) = E' (C x (y-1)) U+    dualE' (E' (N x y) U) = E' (C x y) L+    dualE' (E' (N x y) L) = E' (C (x-1) y) D+    dualE' (E' (N x y) D) = E' (C (x-1) (y-1)) R++instance Dual2D C where+    type Dual C = N++    dualE' (E' (C x y) R) = E' (N (x+1) y) U+    dualE' (E' (C x y) U) = E' (N (x+1) (y+1)) L+    dualE' (E' (C x y) L) = E' (N x (y+1)) D+    dualE' (E' (C x y) D) = E' (N x y) R+++ends :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge a -> (a, a)+ends (E x Vert) = (x, x .+^ (0, 1))+ends (E x Horiz) = (x, x .+^ (1, 0))++ends' :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> (a, a)+ends' (E' x U) = (x, x .+^ (0, 1))+ends' (E' x R) = (x, x .+^ (1, 0))+ends' (E' x D) = (x, x .+^ (0, -1))+ends' (E' x L) = (x, x .+^ (-1, 0))++edgeSize :: [Edge N] -> Size+edgeSize es = (maximum (map fst ps), maximum (map snd ps))+  where+      ps = map toCoord+         . concatMap ((\(x, y) -> [x, y]) . ends)+         $ es++revEdge :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> Edge' a+revEdge = uncurry edge' . swap . ends'+  where+    swap (x, y) = (y, x)++unorient :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> Edge a+unorient (E' x U) = E x Vert+unorient (E' x R) = E x Horiz+unorient (E' x D) = E (x .-^ (0,1)) Vert+unorient (E' x L) = E (x .-^ (1,0)) Horiz++orient :: Edge a -> Edge' a+orient (E x Vert)  = E' x U+orient (E x Horiz) = E' x R++edgeBetween' :: Dual' k => k -> k -> Edge' (Dual k)+edgeBetween' p q = dualE' (edge' p q)++edgeBetween :: Dual' k => k -> k -> Edge (Dual k)+edgeBetween p q = unorient $ edgeBetween' p q+ -- | @edges@ computes the outer and inner edges of a set of cells. --   The set is given via fold and membership predicate, the result --   is a pair @(outer, inner)@ of lists of edges, where the outer --   edges are oriented such that the outside is to the left.-edges :: Foldable f =>-           f (Cell Square) -> (Cell Square -> Bool) ->-           ([Edge' (Vertex Square)], [Edge' (Vertex Square)])+edges :: (Dual' k, Foldable f) =>+         f k -> (k -> Bool) ->+         ([Edge' (Dual k)], [Edge (Dual k)]) edges cs isc = F.foldr f ([], []) cs   where     f c (outer, inner) = (newout ++ outer, newin ++ inner)       where-        nbrs = [ c ^+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ]+        nbrs = [ c .+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ]         (ni, no) = partition isc nbrs-        newout = map (orientedEdge c) no-        newin = map (orientedEdge c) . filter (c >=) $ ni+        newout = [ edgeBetween' q c | q <- no ]+        newin  = [ edgeBetween q c | q <- ni, c >= q ]++edgesM :: Dual' k+       => Map.Map k a -> ([Edge' (Dual k)], [Edge (Dual k)])+edgesM m = edges (Map.keysSet m) (`Map.member` m)

@@ -14,6 +14,7 @@ -- | The list of specific puzzle types we can handle. data PuzzleType = LITS                 | LITSPlus+                | LITSSym                 | Geradeweg                 | Fillomino                 | Masyu@@ -42,12 +43,57 @@                 | PrimePlace                 | Labyrinth                 | Bahnhof+                | BlackoutDominos+                | TwilightTapa+                | TapaCave+                | DominoPillen+                | SlitherLinkMulti+                | AngleLoop+                | Shikaku+                | SlovakSums+                | Anglers+                | Dominos+                | FillominoCheckered+                | FillominoLoop                 | Cave+                | Numberlink+                | Skyscrapers+                | SkyscrapersStars+                | SkyscrapersFrac+                | TurningFences+                | Summon+                | Baca+                | Buchstabensalat+                | Doppelblock+                | SudokuDoppelblock+                | Loopki+                | Scrabble+                | Neighbors+                | Starwars+                | Starbattle+                | Heyawake+                | Wormhole+                | Pentominous+                | ColorAkari+                | PersistenceOfMemory+                | ABCtje+                | Kropki+                | StatuePark+                | PentominousBorders+                | NanroSignpost+                | TomTom+                | HorseSnake+                | Illumination+                | Pentopia+                | PentominoPipes+                | GreaterWall+                | Galaxies     deriving (Show, Eq)  typeNames :: [(PuzzleType, String)] typeNames = [ (LITS, "lits")             , (LITSPlus, "litsplus")+            , (LITSSym, "lits-symmetry")             , (Geradeweg, "geradeweg")             , (Fillomino, "fillomino")             , (Masyu, "masyu")@@ -76,7 +122,51 @@             , (PrimePlace, "primeplace")             , (Labyrinth, "magiclabyrinth")             , (Bahnhof, "bahnhof")+            , (BlackoutDominos, "blackout-dominos")+            , (TwilightTapa, "twilight-tapa")+            , (TapaCave, "tapa-cave")+            , (DominoPillen, "domino-pillen")+            , (SlitherLinkMulti, "slitherlink-multi")+            , (AngleLoop, "angleloop")+            , (Shikaku, "shikaku")+            , (SlovakSums, "slovaksums")+            , (Anglers, "anglers")+            , (Dominos, "dominos")+            , (FillominoCheckered, "fillomino-checkered")+            , (FillominoLoop, "fillomino-loop")             , (Cave, "cave")+            , (Numberlink, "numberlink")+            , (Skyscrapers, "skyscrapers")+            , (SkyscrapersStars, "skyscrapers-doppelstern")+            , (SkyscrapersFrac, "skyscrapers-fractional")+            , (TurningFences, "turning-fences")+            , (Summon, "summon")+            , (Baca, "baca")+            , (Buchstabensalat, "buchstabensalat")+            , (Doppelblock, "doppelblock")+            , (SudokuDoppelblock, "sudoku-doppelblock")+            , (Loopki, "loopki")+            , (Scrabble, "scrabble")+            , (Neighbors, "neighbors")+            , (Starwars, "starwars")+            , (Starbattle, "starbattle")+            , (Heyawake, "heyawake")+            , (Wormhole, "wormhole")+            , (Pentominous, "pentominous")+            , (ColorAkari, "color-akari")+            , (PersistenceOfMemory, "persistenceofmemory")+            , (ABCtje, "abctje")+            , (Kropki, "kropki")+            , (StatuePark, "statuepark")+            , (PentominousBorders, "pentominous-borders")+            , (NanroSignpost, "nanro-signpost")+            , (TomTom, "tomtom")+            , (HorseSnake, "horsesnake")+            , (Illumination, "illumination")+            , (Pentopia, "pentopia")+            , (PentominoPipes, "pentomino-pipes")+            , (GreaterWall, "greaterwall")+            , (Galaxies, "galaxies")             ]  -- | Look up a puzzle type by name.

@@ -3,8 +3,10 @@     sudokubordersg   ) where +import qualified Data.Map as Map+ import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)+import Data.Puzzles.GridShape  msqrt :: Integral a => a -> Maybe a msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing@@ -15,22 +17,20 @@  -- | Determine the internal borders of a standard sudoku of the --   given size.-sudokuborders :: Int -> [Edge]+sudokuborders :: Int -> [Edge N] 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] ]+    where squareborders r = [ E (N (r*x) y) Vert  | x <- [1..r-1], y <- [0..r*r-1] ]+                         ++ [ E (N x (r*y)) Horiz | x <- [0..r*r-1], y <- [1..r-1] ]+          rectborders h = [ E (N h y) Vert | y <- [0..2*h-1] ]+                       ++ [ E (N x (2*y)) Horiz | 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?"+sudokubordersg :: Grid C a -> [Edge N]+sudokubordersg = sudokuborders+               . fst . size . Map.mapKeys toCoord

@@ -0,0 +1,32 @@+module Data.Puzzles.Util+    ( paths+    , loops+    ) where++import Data.List (partition)+import Control.Monad (guard)++paths :: Eq a => [(a, a)] -> Maybe [[a]]+paths [] = Just []+paths ((a,b):segs) = do+    (p, segs') <- collect b segs+    (p', segs'') <- collect a segs'+    ps <- paths segs''+    return ((reverse p' ++ p) : ps)+  where+    collect x sgs = case withx of+        []      -> Just ([x], withoutx)+        [(y,z)] -> do+            (xs, sgs') <- collect (if x == y then z else y) withoutx+            Just (x:xs, sgs')+        _       -> Nothing+      where+        (withx, withoutx) = partition (\s -> fst s == x || snd s == x) sgs++loops :: Eq a => [(a, a)] -> Maybe [[a]]+loops segs = do+    ps <- paths segs+    mapM_ (guard . isLoop) ps+    return ps+  where+    isLoop p = head p == last p

@@ -6,13 +6,13 @@     , RenderOpts(..)     , formats     , checkFormat-    , checkType-    , exitErr-    , readPuzzle     )   where +import Data.Puzzles.CmdLine (exitErr)+ import Diagrams.Prelude hiding (value, option, (<>), Result)+import Control.Monad (unless)  #ifdef CAIRO import Diagrams.Backend.Cairo (B, renderCairo)@@ -20,17 +20,9 @@ import Diagrams.Backend.SVG (B, renderSVG) #endif -import Text.Puzzles.Puzzle-import Data.Puzzles.PuzzleTypes--import System.Exit--import Control.Monad (unless)-import qualified Data.Yaml as Y- data RenderOpts = RenderOpts { _file :: FilePath, _w :: Double } -renderB :: FilePath -> SizeSpec2D -> Diagram B R2 -> IO ()+renderB :: FilePath -> SizeSpec V2 Double -> Diagram B -> IO () renderB = #ifdef CAIRO     renderCairo@@ -38,8 +30,8 @@     renderSVG #endif -renderToFile :: RenderOpts -> Diagram B R2 -> IO ()-renderToFile ropts = renderB (_file ropts) (Width $ _w ropts)+renderToFile :: RenderOpts -> Diagram B -> IO ()+renderToFile ropts = renderB (_file ropts) (mkWidth $ _w ropts)  formats :: [String] #ifdef CAIRO@@ -51,17 +43,3 @@ checkFormat :: String -> IO () checkFormat f = unless (f `elem` formats) $                     exitErr $ "unknown format: " ++ f--checkType :: Maybe String -> IO PuzzleType-checkType mt = do-    t <- maybe errno return mt-    maybe (errunk t) return (lookupType t)-  where-    errno    = exitErr "no puzzle type given"-    errunk t = exitErr $ "unknown puzzle type: " ++ t--readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle)-readPuzzle = Y.decodeFileEither--exitErr :: String -> IO a-exitErr e = putStrLn e >> exitFailure

@@ -0,0 +1,53 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Diagrams.Puzzles.Code+    (+      CodeDiagrams (..)+    , drawCode+    ) where++import Data.Puzzles.Code+import Data.Puzzles.GridShape+import Data.Puzzles.Grid+import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Grid+import Diagrams.Puzzles.Elements++import Diagrams.Prelude++import qualified Data.Map as Map++data CodeDiagrams a = CodeDiagrams { _cdLeft :: a, _cdTop :: a, _cdOver :: a }++instance Monoid a => Monoid (CodeDiagrams a) where+    mempty = CodeDiagrams mempty mempty mempty+    (CodeDiagrams x y z) `mappend` (CodeDiagrams x' y' z') =+        CodeDiagrams (x `mappend` x') (y `mappend` y') (z `mappend` z')++drawCode :: Backend' b => Code -> CodeDiagrams (Diagram b)+drawCode cs = mconcat (map drawCodePart cs)++drawCodePart :: Backend' b => CodePart -> CodeDiagrams (Diagram b)+drawCodePart (Rows'  rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty+  where+    g = Map.fromList [ (C 0 r, arrowRight) | r <- rs ]+drawCodePart (Cols   cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty+  where+    g = Map.fromList [ (C c 0, arrowDown)  | c <- cs ]+drawCodePart (RowsN' rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty+  where+    g = Map.fromList [ (N 0 r, arrowRight) | r <- rs ]+drawCodePart (ColsN  cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty+  where+    g = Map.fromList [ (N c 0, arrowDown)  | c <- cs ]+drawCodePart (LabelsN g) = CodeDiagrams mempty mempty (placeGrid . fmap label . clues $ g)+  where+    label c = drawChar c # scale 0.5 # fc gray # translate (r2 (1/3, -1/3))++arrowDown :: Backend' b => Diagram b+arrowDown = triangle 0.7 # lwG 0 # fc (blend 0.7 white black) # rotateBy (1/2)++arrowRight :: Backend' b => Diagram b+arrowRight = arrowDown # rotateBy (1/4)

@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}  module Diagrams.Puzzles.Draw (@@ -13,35 +14,46 @@   ) where  import Diagrams.Prelude-import Diagrams.BoundingBox  import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths+import Diagrams.Puzzles.Code -type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2)+type RenderPuzzle b p s = (p -> Diagram b, (p, s) -> Diagram b) -type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2))+type PuzzleSol b = (Diagram b, Maybe (Diagram b))  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 =>-        PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2)-draw (p, ms) = fmap (bg white) . d+draw :: Backend' b+     => Maybe (CodeDiagrams (Diagram b))+     -> PuzzleSol b -> OutputChoice -> Maybe (Diagram b)+draw mc (p, ms) = fmap (bg white) . d   where     fixup = alignPixel . border borderwidth-    d DrawPuzzle   = Just (fixup p)-    d DrawSolution = fixup <$> ms-    d DrawExample  = ms >>= \s -> return $ fixup p ||| strutX 2.0 ||| fixup s+    addCode x = case mc of+        Nothing                              -> x+        Just (CodeDiagrams cleft ctop cover) ->+            ((cover <> x) =!= top ctop) |!| lft cleft+    (=!=) = beside unitY+    (|!|) = beside (negated unitX)+    top c = if isEmpty c then mempty else strutY 0.5 =!= c+    lft c = if isEmpty c then mempty else strutX 0.5 |!| c+    isEmpty c = diameter unitX c == 0+    d DrawPuzzle   = fixup . addCode <$> Just p+    d DrawSolution = fixup . addCode <$> ms+    d DrawExample  = sideBySide <$> d DrawPuzzle <*> d DrawSolution+    sideBySide x y = x ||| strutX 2.0 ||| y  data Unit = Pixels | Points  cmtopoint :: Double -> Double cmtopoint = (* 28.3464567) -diagramWidth :: Diagram b R2 -> Double+diagramWidth :: Backend' b => Diagram b -> Double diagramWidth = fst . unr2 . boxExtents . boundingBox  toOutputWidth :: Unit -> Double -> Double@@ -49,9 +61,9 @@                               Points -> wpt   where     wpix = round (gridresd * w) :: Int  -- grid square size 40px-    wpt = cmtopoint (0.8 * w)     -- grid square size 0.8cm+    wpt = cmtopoint w     -- grid square size 1.0cm -alignPixel :: Backend' b => Diagram b R2 -> Diagram b R2+alignPixel :: Backend' b => Diagram b -> Diagram b alignPixel = scale (1/gridresd) . align' . scale gridresd   where     align' d = maybe id grow (getCorners $ boundingBox d) d@@ -62,6 +74,6 @@     phantoml p q = phantom' $ p ~~ q  -- | Add a phantom border of the given width around a diagram.-border :: Backend' b => Double -> Diagram b R2 -> Diagram b R2+border :: Backend' b => Double -> Diagram b -> Diagram b border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX)          . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY)

@@ -10,46 +10,55 @@  module Diagrams.Puzzles.Elements where -import Diagrams.Prelude+import Diagrams.Prelude hiding (N) import Diagrams.TwoD.Offset -import Data.Puzzles.Elements-import Data.Puzzles.GridShape+import qualified Data.Map as Map +import Data.Puzzles.Grid+import Data.Puzzles.Elements hiding (Loop)+import Data.Puzzles.GridShape hiding (edge)+ import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Style import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Grid  pearl :: Backend' b =>-         MasyuPearl -> Diagram b R2+         MasyuPearl -> Diagram b pearl m = circle 0.35 # lwG 0.05 # fc (c m)   where     c MWhite = white     c MBlack = black  smallPearl :: Backend' b =>-              MasyuPearl -> Diagram b R2+              MasyuPearl -> Diagram b smallPearl = scale 0.4 . pearl +drawEnd :: Backend' b =>+       MEnd -> Diagram b+drawEnd MEnd = smallPearl MBlack+ -- | The up-right diagonal of a centered unit square.-ur :: Path R2+ur :: Path V2 Double 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 :: Path V2 Double dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]  -- | Both diagonals of a centered unit square.-cross :: Path R2+cross :: Path V2 Double cross = ur <> dr  -- | Draw a cross.-drawCross :: Backend' b => Diagram b R2-drawCross = stroke cross # scale 0.8 # lwG edgewidth+drawCross :: Backend' b => Bool -> Diagram b+drawCross True = stroke cross # scale 0.8 # lwG edgewidth+drawCross False = mempty  -- | Draw a Compass clue. drawCompassClue :: Backend' b =>-                   CompassC -> Diagram b R2+                   CompassC -> Diagram b drawCompassClue (CC n e s w) = texts <> stroke cross # lwG onepix     where tx Nothing _ = mempty           tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v)@@ -57,10 +66,17 @@                   [(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 :: Backend' b => [P2] -> QDiagram b R2 Any-thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5))+drawSlovakClue :: Backend' b =>+                  SlovakClue -> Diagram b+drawSlovakClue (SlovakClue s c) =+    centerY (drawInt s === strutY 0.1 === dots c) <> fillBG gray+  where+    dots n = centerX $ hcat' with {_sep = 0.04} (replicate n $ d)+    d = circle 0.1 # lwG 0.02 # fc white++-- | Draw a thermometer.+thermo :: Backend' b => [P2 Double] -> Diagram b+thermo vs@(v:_) = (bulb `atop` line) # col     where bulb = circle 0.4 # moveTo v           line = strokeLocLine (fromVertices vs)                  # lwG 0.55 # lineCap LineCapSquare@@ -70,13 +86,13 @@  -- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell -- coordinates.-drawThermos :: Backend' b => [Thermometer] -> QDiagram b R2 Any-drawThermos = mconcat . map (thermo . map p2i)+drawThermos :: Backend' b => [Thermometer] -> Diagram b+drawThermos = mconcat . map (thermo . map toPoint)  -- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to -- draw the components. drawTight :: Backend' b =>-             (a -> Diagram b R2) -> Tightfit a -> Diagram b R2+             (a -> Diagram b) -> Tightfit a -> Diagram b drawTight d (Single x) = d x drawTight d (UR x y) = stroke ur # lwG onepix                        <> d x # scale s # translate (r2 (-t,t))@@ -90,72 +106,107 @@           s = 2/3  -- | Stack the given words, left-justified.-stackWords :: Backend' b => [String] -> QDiagram b R2 Any-stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text')+stackWords :: Backend' b => [String] -> Diagram b+stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . textFixed) +-- | Stack the given words, left-justified, a bit more generous, nice font+stackWordsLeft :: Backend' b => [String] -> Diagram b+stackWordsLeft = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignL . text')++-- | Stack the given words, left-justified, a bit more generous, nice font+stackWordsRight :: Backend' b => [String] -> Diagram b+stackWordsRight = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignR . text')+ -- | Mark a word in a grid of letters.-drawMarkedWord :: Backend' b => MarkedWord -> QDiagram b R2 Any+drawMarkedWord :: Backend' b => MarkedWord -> Diagram b drawMarkedWord (MW s e) = lwG 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 :: Backend' b => [MarkedWord] -> QDiagram b R2 Any+drawMarkedWords :: Backend' b => [MarkedWord] -> Diagram b drawMarkedWords = mconcat . map drawMarkedWord +drawMarkedLine :: (ToPoint a, Backend' b) => MarkedLine a -> Diagram b+drawMarkedLine (MarkedLine s e) = strokePath (toPoint s ~~ toPoint e) # lwG edgewidth # lc gray++drawMarkedLines :: (ToPoint a, Backend' b) => [MarkedLine a] -> Diagram b+drawMarkedLines = mconcat . map drawMarkedLine+ -- | Draw a slalom clue. drawSlalomClue :: (Show a, Backend' b) =>-                  a -> Diagram b R2+                  a -> Diagram b drawSlalomClue x = text' (show x) # scale 0.75                    <> circle 0.4 # fc white # lwG onepix +drawSlalomDiag :: Backend' b+               => SlalomDiag -> Diagram b+drawSlalomDiag d = stroke (v d) # lwG edgewidth+  where+    v SlalomForward = ur+    v SlalomBackward = dr+ -- | Draw text. Shouldn't be more than two characters or so to fit a cell.-drawText :: Backend' b => String -> QDiagram b R2 Any+drawText :: Backend' b => String -> Diagram b drawText = text' +drawTextFixed :: Backend' b => String -> Diagram b+drawTextFixed = textFixed+ -- | Draw an @Int@. drawInt :: Backend' b =>-           Int -> Diagram b R2+           Int -> Diagram b drawInt s = drawText (show s)  -- | Draw a character. drawChar :: Backend' b =>-            Char -> Diagram b R2+            Char -> Diagram b drawChar c = drawText [c] +drawCharFixed :: Backend' b =>+                 Char -> Diagram b+drawCharFixed c = drawTextFixed [c]++drawCharOpaque :: Backend' b =>+                  Char -> Diagram b+drawCharOpaque c = drawChar c <> circle 0.5 # lwG 0 # fc white++hintTL :: Backend' b => String -> Diagram b+hintTL = moveTo (p2 (-0.4,0.4)) . scale 0.5 . alignTL . drawText+ -- | Stack a list of words into a unit square. Scaled such that at least -- three words will fit. drawWords :: Backend' b =>-             [String] -> Diagram b R2+             [String] -> Diagram b 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 :: Backend' b => [Edge] -> Diagram b R2+drawCurve :: Backend' b => [Edge N] -> Diagram b drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge)  -- | Draw a shadow in the style of Afternoon Skyscrapers.-drawShade :: Backend' b => Shade -> Diagram b R2-drawShade (Shade s w) = (if s then south else mempty) <>-                        (if w then west else mempty)+drawShadow :: Backend' b => Shade -> Diagram b+drawShadow (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 # lwG 0 # fc gray-    west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south+    west = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) south  -- | Draws the digits of a tapa clue, ordered --   left to right, top to bottom. drawTapaClue :: Backend' b =>-                TapaClue -> Diagram b R2+                TapaClue -> Diagram b drawTapaClue (TapaClue [x]) = drawInt x drawTapaClue (TapaClue xs)  = fit 0.8-                            . decoratePath (p (length xs))+                            . atPoints (p (length xs))                             . map drawInt                             $ xs   where-    p n = centerXY (p' n)+    p n = mconcat . pathVertices $ centerXY (p' n)     p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4)     p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8     p' 4 = reflectX . rotateBy (3/8) $ square 0.7@@ -163,7 +214,7 @@     p' _ = error "invalid tapa clue"  drawPrimeDiag :: Backend' b =>-                 PrimeDiag -> Diagram b R2+                 PrimeDiag -> Diagram b drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white)   where     p = case d of (False, False) -> mempty@@ -171,8 +222,129 @@                   (False, True)  -> dr                   (True,  True)  -> ur <> dr -drawCrossing :: Backend' b => Crossing -> Diagram b R2+drawAnglePoly :: Backend' b =>+                 Int -> Diagram b+drawAnglePoly 3 = strokePath (triangle 0.3) # fc black+drawAnglePoly 4 = strokePath (square 0.25) # fc gray+drawAnglePoly 5 = strokePath (pentagon 0.2) # fc white+drawAnglePoly _ = error "expected 3..5"++fish :: Double -> Angle Double -> Trail' Loop V2 Double+fish off startAngle = closeLine $ half <> half # reverseLine # reflectY+  where+    half = arc (angleDir startAngle) endAngle # translateY (-off)+    endAngle = acosA off ^+^ (90 @@ deg)++drawFish :: Backend' b =>+            Fish -> Diagram b+drawFish Fish = fit 0.6 . centerXY . fc black . strokeLoop $+                fish 0.7 (30 @@ deg)++drawStar :: Backend' b =>+            Star -> Diagram b+drawStar Star = fc black . stroke . star (StarSkip 2) $ pentagon 0.3++vertexLoop :: VertexLoop -> Located (Trail' Loop V2 Double)+vertexLoop = mapLoc closeLine . fromVertices . map toPoint++note :: Backend' b =>+        Diagram b -> Diagram b+note d = d # frame 0.2 # bg (blend 0.2 black white)++placeNote :: Backend' b =>+             Size -> Diagram b -> Diagram b+placeNote sz d = note d # alignBL # translatep sz # translate (r2 (0.6,0.6))++placeNoteTL :: Backend' b =>+             Size -> Diagram b -> Diagram b+placeNoteTL sz d = note d # alignBR # translatep sz # translate (r2 (-0.6,0.6))++placeNoteBR :: Backend' b =>+             Size -> Diagram b -> Diagram b+placeNoteBR (x,_) d = note d # alignTL # translatep (x,0) # translate (r2 (0.6,-0.6))++miniloop :: Backend' b => Diagram b+miniloop = (drawThinEdges (map unorient out) <> grid gSlither g)+           # centerXY # scale 0.4+  where+    g = sizeGrid (1, 1)+    (out, _) = edgesM g++dominoBG :: Colour Double+dominoBG = blend 0.3 black white++drawDomino :: Backend' b => (Int, Int) -> Diagram b+drawDomino (x, y) =+    (drawInt x # smash ||| strutX 0.65 ||| drawInt y # smash) # centerXY # scale 0.6+    <> strokePath (rect 0.8 0.5) # lwG 0 # fc dominoBG++newtype DominoC = DominoC C+  deriving (Ord, Eq)++instance ToPoint DominoC where+    toPoint (DominoC (C x y)) = p2 ((1.0 * fromIntegral x),+                                    (0.7 * fromIntegral y))++drawDominos :: Backend' b => DigitRange -> Diagram b+drawDominos = centerXY . placeGrid+            . Map.mapKeys DominoC . fmap drawDomino . dominoGrid++drawPill :: Backend' b => Int -> Diagram b+drawPill x = drawInt x # scale 0.6+             <> strokePath (roundedRect 0.8 0.5 0.2) # lwG 0 # fc dominoBG++drawPills :: Backend' b => DigitRange -> Diagram b+drawPills (DigitRange a b) = centerXY . onGrid 1.0 0.7 drawPill $ placed+  where+    n = b - a + 1+    root = head [ x | x <- [n,n-1..], x*x <= n ]+    placed = zip [(x, y) | x <- [0..root], y <- [root,root-1..0]] [a..b]++drawCrossing :: Backend' b => Crossing -> Diagram b drawCrossing = const $ drawChar '+' -drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b R2+drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b drawBahnhofClue = either drawInt drawCrossing++kropkiDot :: Backend' b => KropkiDot -> Diagram b+kropkiDot KNone = mempty+kropkiDot c = circle 0.1 # lwG 0.03 # fc (col c) # smash+    where col KWhite = white+          col KBlack = blend 0.98 black white+          col KNone  = error "can't reach"++drawFraction :: Backend' b => Fraction -> Diagram b+drawFraction f = centerX $ case f of+    FInt a      -> drawText a # scale 0.8+    FFrac a b   -> frac a b+    FComp a b c -> (drawText a # scale 0.8) ||| strutX (1/10) ||| frac b c+  where+    frac b c = stroke slash # scale (1/4) # lwG onepix+               <> drawText b # scale s # translate (r2 (-t,t))+               <> drawText c # scale s # translate (r2 (t,-t))+      where t = 1/6+            s = 1/2+            slash :: Path V2 Double+            slash = fromVertices [p2 (-1/3,-1/2), p2 (1/3,1/2)]++drawMyopia :: Backend' b => Myopia -> Diagram b+drawMyopia = foldMap d'+  where+    d' = lwG onepix . scale (1/3) . d+    d U = a (0, 0) (0, 1)+    d R = a (0, 0) (1, 0)+    d D = a (0, 0) (0, -1)+    d L = a (0, 0) (-1, 0)+    a p q = arrowBetween' (with & arrowHead .~ tri & lengths .~ verySmall) (p2 p) (p2 q)++greaterClue :: Backend' b => GreaterClue -> [Diagram b]+greaterClue [] = mempty+greaterClue (_:rs) = g rs+  where+    g [] = [placeholder]+    g (r:rs') = placeholder : drawRel r : g rs'+    drawRel RUndetermined = mempty+    drawRel RLess = drawText "<"+    drawRel RGreater = drawText ">"+    drawRel REqual = drawText "="+    placeholder = circle 0.35 # lwG onepix # dashingG [0.05, 0.05] 0

@@ -5,76 +5,68 @@  import Data.Char (isUpper) import qualified Data.Map as M+import qualified Data.Set as S -import Diagrams.Prelude+import Diagrams.Prelude hiding (size, E, N, dot, outer)+import Diagrams.TwoD.Offset (offsetPath) +import qualified Data.AffineSpace as AS++import Data.Puzzles.Util import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size, cells)+import Data.Puzzles.GridShape hiding (edge) +import Diagrams.Puzzles.Style import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths --- | Draw a small black dot with no envelope.-dot :: Backend' b => 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 =>-               Size -> Diagram b R2-slithergrid (x, y) =-    hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot--fence :: [Double] -> Double -> Path R2-fence xs h = decoratePath xspath (repeat v)-  where-    xspath = fromVertices [ p2 (x, 0) | x <- xs ]-    v = alignB (vrule h)+(.--.) :: AS.AffineSpace p => p -> p -> AS.Diff p+(.--.) = (AS..-.) --- | The inner grid lines of a square grid of the specified size.-gridlines :: Size -> Path R2-gridlines (w, h) = fence' w h <> mirror (fence' h w)-  where-    fence' n l = fence (map fromIntegral [1..n-1]) (fromIntegral l)+class ToPoint a where+    toPoint :: a -> P2 Double -fullgridlines :: Size -> Path R2-fullgridlines (w, h) = fence' w h <> mirror (fence' h w)-  where-    fence' n l = fence (map fromIntegral [0..n]) (fromIntegral l)+instance ToPoint C where+    toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0) --- | Draw a frame around the outside of a rectangle.-outframe' :: Backend' b => Double -> Size -> Diagram b R2-outframe' f (w, h) = strokePointLoop r # lwG fw-    where wd = fromIntegral w-          hd = fromIntegral h-          strokePointLoop = strokeLocTrail . mapLoc (wrapLoop . closeLine)-                            . fromVertices . map p2-          fw = f * gridwidth-          e = fw / 2 - gridwidth / 2-          r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)]+instance ToPoint N where+    toPoint c = origin .+^ r2i (c .--. N 0 0) -outframe :: Backend' b => Size -> Diagram b R2-outframe = outframe' framewidthfactor+-- | Draw a small black dot with no envelope.+dot :: Backend' b => Diagram b+dot = circle 0.05 # fc black # smash --- | Draw a square grid, applying the given style to the grid lines.-grid' :: Backend' b =>-         (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2-grid' gridstyle s =-    outframe s-    <> stroke (gridlines s) # lwG gridwidth # gridstyle+grid :: Backend' b+     => GridStyle -> Grid C a -> Diagram b+grid s g =+    (placeGrid . fmap (const vertex) . nodeGrid $ g)+    <> stroke inner # linestyle (_line s)+    <> stroke outer # linestyle (_border s)+    <> frm+  where+    vertex = case _vertex s of+        VertexDot    -> dot+        VertexNone   -> mempty+    linestyle LineNone   = const mempty+    linestyle LineThin   = lwG gridwidth+    linestyle LineDashed = gridDashing . lwG gridwidth+    linestyle LineThick  = lwG edgewidth+    frm = case _frame s of+        Just (FrameStyle f c)  -> outLine f outer # fc c+        Nothing                -> mempty --- | Draw a square grid with default grid line style.-grid :: Backend' b =>-        Size -> Diagram b R2-grid = grid' id+    (outer, inner) = irregularGridPaths g --- | Draw a square grid with thin frame.-plaingrid :: Backend' b =>-             Size -> Diagram b R2-plaingrid s = stroke (fullgridlines s) # lwG gridwidth+outLine :: Backend' b => Double -> Path V2 Double -> Diagram b+outLine f p = lwG 0 . stroke $ pin <> pout+  where+    pout = reversePath $ offsetPath (f * onepix - e) p+    pin = offsetPath (-e) p+    e = onepix / 2 -bgdashingG :: (Semigroup a, HasStyle a, V a ~ R2) =>-             [Double] -> Double -> Colour Double -> a -> a-bgdashingG ds offs c x = x # dashingG ds offs <> x # lc c+bgdashingG :: (Semigroup a, HasStyle a, InSpace V2 Double a) =>+             [Double] -> Double -> AlphaColour Double -> a -> a+bgdashingG ds offs c x = x # dashingG ds offs <> x # lcA c  dashes :: [Double] dashes = [5 / 40, 3 / 40]@@ -82,141 +74,109 @@ dashoffset :: Double dashoffset = 2.5 / 40 -gridDashing :: (Semigroup a, HasStyle a, V a ~ R2) => a -> a+gridDashing :: (Semigroup a, HasStyle a, InSpace V2 Double a) => a -> a gridDashing = bgdashingG dashes dashoffset white'   where-    white' = blend 0.95 white black---- | Draw a square grid with dashed grid lines. The gaps---   between dashes are off-white to aid in using filling---   tools.-dashedgrid :: Backend' b =>-              Size -> Diagram b R2-dashedgrid = grid' gridDashing--edgePath :: Edge' (Vertex Square) -> Path R2-edgePath (E' v R) = p2i v ~~ p2i (v ^+^ (1,0))-edgePath (E' v L) = p2i v ~~ p2i (v ^+^ (-1,0))-edgePath (E' v U) = p2i v ~~ p2i (v ^+^ (0,1))-edgePath (E' v D) = p2i v ~~ p2i (v ^+^ (0,-1))+    white' = black `withOpacity` (0.05 :: Double) -irregularGridPaths :: SGrid a -> (Path R2, Path R2)-irregularGridPaths (Grid _ m) = (toPath outer, toPath inner)+-- | `irregularGridPaths g` is a pair `(outer, inner)` of paths.+--+-- `outer` consists of the loops that make up the border of the+-- grid (assuming the grid is connected orthogonally). They are+-- reoriented to be compatible with `outLine`; for some reason,+-- reversePath on the immediate result does not work.+--+-- `inner` consists of the individual inner segments.+irregularGridPaths :: Grid C a -> (Path V2 Double, Path V2 Double)+irregularGridPaths m = (path' (map revEdge outer), path inner)   where     (outer, inner) = edges (M.keysSet m) (`M.member` m)-    toPath = mconcat . map edgePath+    path  es = mconcat . map (conn . ends) $ es+    path' es = case loops (map ends' es) of+        Just ls   -> mconcat . map (pathFromLoopVertices . map toPoint) $ ls+        Nothing   -> mempty+    pathFromLoopVertices = pathFromLocTrail+                         . mapLoc (wrapLoop . closeLine)+                         . fromVertices+    conn (v, w) = toPoint v ~~ toPoint w -irregularGrid :: Backend' b =>-                 SGrid a -> Diagram b R2-irregularGrid g = stroke outer # lwG (3 * gridwidth) # lineCap LineCapSquare <>-                  stroke inner # lwG gridwidth+irregPathToVertices :: (Path V2 Double, Path V2 Double) -> (S.Set (P2 Double), S.Set (P2 Double), S.Set (P2 Double))+irregPathToVertices (pouter, pinner) = (outer, inner S.\\ outer, inner `S.union` outer)   where-    (outer, inner) = irregularGridPaths g---- | 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 (1/2, 1/2)) . atVertices dc+    outer = S.fromList . mconcat . pathVertices $ pouter+    inner = S.fromList . mconcat . pathVertices $ pinner -atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a]-atCentres' = translate (r2 (1/2, 1/2)) . atVertices'+onGrid :: (Transformable a, Monoid a, InSpace V2 Double a) =>+          Double -> Double -> (t -> a) -> [(Coord, t)] -> a+onGrid dx dy f = mconcat . map g+  where+    g (p, c) = f c # translate (r2coord p)+    r2coord (x, y) = r2 (dx * fromIntegral x, dy * fromIntegral y) --- | 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)+placeGrid :: (ToPoint k, HasOrigin a, Monoid a, InSpace V2 Double a)+          => Grid k a -> a+placeGrid = M.foldMapWithKey (moveTo . toPoint) -atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a]-atVertices' g = [ (g ! c) # translatep c | c <- cells g ]+placeGrid' :: (HasOrigin a, Monoid a, InSpace V2 Double a)+          => Grid (P2 Double) a -> a+placeGrid' = M.foldMapWithKey moveTo -edge :: Edge -> Path R2-edge (E c d) = rule d # translate (r2i c)+edge :: (ToPoint k) => Edge k -> Path V2 Double+edge (E c d) = rule d # translate (toPoint c .-. origin)   where-    rule V = vrule 1.0 # alignB-    rule H = hrule 1.0 # alignL+    rule Vert = vrule 1.0 # alignB+    rule Horiz = hrule 1.0 # alignL -dualEdge :: Edge -> Path R2-dualEdge = translate (r2 (1/2, 1/2)) . edge+midPoint :: (AS.AffineSpace k, AS.Diff k ~ (Int, Int), ToPoint k) => Edge k -> P2 Double+midPoint e = c .+^ 0.5 *^ (d .-. c)+  where+    (a, b) = ends e+    c = toPoint a+    d = toPoint b -edgeStyle :: (HasStyle a, V a ~ R2) => a -> a+edgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a edgeStyle = lineCap LineCapSquare . lwG edgewidth -thinEdgeStyle :: (HasStyle a, V a ~ R2) => a -> a+thinEdgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a thinEdgeStyle = lineCap LineCapSquare . lwG onepix -drawEdges :: Backend' b => [Edge] -> Diagram b R2+drawEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b drawEdges = edgeStyle . stroke . mconcat . map edge -drawDualEdges :: Backend' b => [Edge] -> Diagram b R2-drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge--drawThinDualEdges :: Backend' b => [Edge] -> Diagram b R2-drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge+drawThinEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b+drawThinEdges = thinEdgeStyle . stroke . mconcat . map edge -drawAreaGrid :: (Backend' b, Eq a) =>-                  SGrid a -> Diagram b R2-drawAreaGrid = drawEdges . borders <> grid . size+drawAreas :: (Backend' b, Eq a) =>+             Grid C a -> Diagram b+drawAreas = drawEdges . borders -fillBG :: Backend' b => Colour Double -> Diagram b R2+fillBG :: Backend' b => Colour Double -> Diagram b fillBG c = square 1 # lwG onepix # fc c # lc c  shadeGrid :: Backend' b =>-              SGrid (Maybe (Colour Double)) -> Diagram b R2-shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG)+             Grid C (Maybe (Colour Double)) -> Diagram b+shadeGrid = placeGrid . fmap fillBG . clues -drawShadedGrid :: Backend' b =>-                  SGrid Bool -> Diagram b R2-drawShadedGrid = shadeGrid . fmap f+drawShade :: Backend' b =>+             Grid C Bool -> Diagram b+drawShade = shadeGrid . fmap f   where     f True  = Just gray     f False = Nothing -drawAreaGridGray :: Backend' b =>-                    SGrid Char -> Diagram b R2-drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols+drawAreasGray :: Backend' b =>+                 Grid C Char -> Diagram b+drawAreasGray = drawAreas <> shadeGrid . fmap cols   where     cols c | isUpper c  = Just (blend 0.1 black white)            | otherwise  = Nothing -irregAreaGridX :: Backend' b =>-                      SGrid Char -> Diagram b R2-irregAreaGridX = irregularGrid <> drawEdges . borders <> shadeGrid . fmap cols-  where-    cols 'X' = Just gray-    cols _   = Nothing- -- Place a list of diagrams along a ray, with steps of size -- @f@.-distrib :: (Transformable c, Monoid c, V c ~ R2) =>-           R2 -> (Int, Int) -> Double -> [c] -> c+distrib :: (Transformable c, Monoid c, InSpace V2 Double c) =>+           V2 Double -> (Int, Int) -> Double -> [c] -> c distrib base dir f xs =     translate (0.75 *^ dir' ^+^ base) . mconcat $         zipWith (\i d -> translate (fromIntegral i *^ dir') d) [(0 :: Int)..] xs   where     dir' = f *^ r2i dir--outsideGen :: (Transformable c, Monoid c, V c ~ R2) =>-              (OutsideClue [c] -> R2) -> Double -> [OutsideClue [c]] -> c-outsideGen tobase f ocs = mconcat . map placeOC $ ocs-  where-    placeOC o = distrib (tobase o) (ocDir o) f (ocValue o)--outsideCells :: (Transformable c, Monoid c, V c ~ R2) =>-                Double -> [OutsideClue [c]] -> c-outsideCells = outsideGen base-  where-    base (OClue (bx, by) (dx, dy) _)-        | dx /= 0   = r2 (fromIntegral bx - 1, fromIntegral by - 1/2)-        | dy /= 0   = r2 (fromIntegral bx - 1/2, fromIntegral by)-        | otherwise = error "invalid outside clue"--outsideVertices :: (Transformable c, Monoid c, V c ~ R2) =>-                   Double -> [OutsideClue [c]] -> c-outsideVertices = outsideGen base-  where-    base (OClue (bx, by) (dx, dy) _)-        | dx /= 0   = r2 (fromIntegral bx, fromIntegral by)-        | dy /= 0   = r2 (fromIntegral bx, fromIntegral by)-        | otherwise = error "invalid outside clue"

@@ -1,99 +1,132 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}  module Diagrams.Puzzles.Lib where +import Diagrams.Path (pathPoints) import Diagrams.Prelude -import Graphics.SVGFonts.ReadFont+import Graphics.SVGFonts.Text (TextOpts(..), Mode(..), Spacing(..), textSVG')+import Graphics.SVGFonts.Fonts (bit)+import Graphics.SVGFonts.ReadFont (PreparedFont, loadFont)+ import Control.Arrow ((***))  import Paths_puzzle_draw (getDataFileName) import System.IO.Unsafe (unsafePerformIO) -type Backend' b = (Backend b R2, Renderable (Path R2) b)+type Backend' b = (V b ~ V2, N b ~ Double,+                   Renderable (Path V2 Double) b, Backend b V2 Double)  -- | Vertical/horizontal stroked line of given length.-vline, hline :: Backend' b => Double -> Diagram b R2+vline, hline :: Backend' b => Double -> Diagram b 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 :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a)+        => [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 :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a)+        => [a] -> a vcatsep = cat' (r2 (0,1)) with {_sep = 1}  -- | Collapse the envelope to a point.-smash :: Backend' b => QDiagram b R2 Any -> QDiagram b R2 Any-smash = withEnvelope (pointDiagram origin :: D R2)+smash :: Backend' b => Diagram b -> Diagram b+smash = withEnvelope (pointDiagram origin :: D V2 Double)  -- | Helper to translate by a point given as @(Int, Int)@.-translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t+translatep :: (InSpace V2 Double t, Transformable t)+           => (Int, Int) -> t -> t translatep = translate . r2i  -- | Convert pair of @Int@ to vector.-r2i :: (Int, Int) -> R2+r2i :: (Int, Int) -> V2 Double r2i = r2 . (fromIntegral *** fromIntegral)  -- | Convert pair of @Int@ to point.-p2i :: (Int, Int) -> P2+p2i :: (Int, Int) -> P2 Double p2i = p2 . (fromIntegral *** fromIntegral) -mirror :: (Transformable t, V t ~ R2) => t -> t-mirror = reflectAbout (p2 (0, 0)) (r2 (1, 1))+mirror :: (InSpace V2 Double t, Transformable t) => t -> t+mirror = reflectAbout (p2 (0, 0)) (direction $ r2 (1, -1))  -- | Interleave two lists. interleave :: [a] -> [a] -> [a] interleave [] _ = [] interleave (x:xs) ys = x : interleave ys xs +magnitude :: V2 Double -> Double+magnitude = norm+ -- | Spread diagrams evenly along the given vector.-spread :: Backend' b => R2 -> [Diagram b R2] -> Diagram b R2+spread :: Backend' b => V2 Double -> [Diagram b] -> Diagram b 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+dmid ::  (InSpace V2 Double a, Enveloped a) => V2 Double -> a -> Double+dmid u a = (dtop + dbot) / 2 - dbot     where menv v = magnitude . envelopeV v-          dtop = menv unitY a-          dbot = menv ((-1) *^ unitY) a+          dtop = menv u a+          dbot = menv ((-1) *^ u) a  -- | Place the second diagram to the right of the first, aligning both -- vertically. The origin is the origin of the left diagram.-besidesL :: (Backend' b, Semigroup m, Monoid m) =>-            QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m+besidesL :: Backend' b =>+            Diagram b -> Diagram b -> Diagram b besidesL a b = a ||| strutX 0.5 ||| b'-    where b' = b # centerY # translate (dmid a *^ unitY)+    where b' = b # centerY # translate (dmid unitY a *^ unitY)  -- | Variant of 'besidesL' where the origin is that of the right diagram.-besidesR :: (Backend' b, Semigroup m, Monoid m) =>-           QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m+besidesR :: Backend' b =>+           Diagram b  -> Diagram b -> Diagram b besidesR b a =  b' ||| strutX 0.5 ||| a-    where b' = b # centerY # translate (dmid a *^ unitY)+    where b' = b # centerY # translate (dmid unitY a *^ unitY) +aboveT :: Backend' b =>+          Diagram b -> Diagram b -> Diagram b+aboveT a b = a === strutY 0.5 === b'+    where b' = b # centerX # translate (dmid unitX a *^ unitX)+ -- | @fit f a@ scales @a@ to fit into a square of size @f@.-fit :: (Transformable t, Enveloped t, V t ~ R2) =>+fit :: (Transformable t, Enveloped t, InSpace V2 Double t) =>        Double -> t -> t fit f a = scale (f / m) a-    where m = max (magnitude (diameter unitX a))-                  (magnitude (diameter unitY a))+    where m = max (diameter unitX a)+                  (diameter unitY a) +type Font = PreparedFont Double+ -- | 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' :: Backend' b => String -> Diagram b R2-text' t = stroke (textSVG' $ TextOpts t fnt INSIDE_H KERN False 1 1)-          # lwG 0 # fc black # scale 0.8+text'' :: Backend' b => Font -> String -> Diagram b+text'' fnt t = stroke (textSVG' (TextOpts fnt INSIDE_H KERN False 1 1) t)+             # lwG 0 # rfc black # scale 0.8   where-    fnt = outlMap . unsafePerformIO . getDataFileName-        $ "data/fonts/gen-light.svg"+    rfc :: (HasStyle a, InSpace V2 Double a) => Colour Double -> a -> a+    rfc = recommendFillColor +text' :: Backend' b => String -> Diagram b+text' = text'' fontGenLight++textFixed :: Backend' b => String -> Diagram b+textFixed = text'' fontBit++fontGenLight :: Font+fontGenLight = unsafePerformIO . loadFont . unsafePerformIO . getDataFileName+    $ "data/fonts/gen-light.svg"++fontBit :: Font+fontBit = bit+ -- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07)) --          <> phantom' (textrect t) --textrect :: Backend' b => String -> Diagram b R2@@ -102,5 +135,19 @@ --text'' t = text' t `atop` textrect t  -- | Variant of 'phantom' that forces the argument backend type.-phantom' :: Backend' b => Diagram b R2 -> Diagram b R2+phantom' :: Backend' b => Diagram b -> Diagram b phantom' = phantom++debugPath :: Backend' b => Path V2 Double -> Diagram b+debugPath p = mconcat . map draw $ prts'+  where+    prts = zip (pathVertices p) ['a'..]+    prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts+    draw (pt, l) = moveTo pt $ text' l++debugPath' :: Backend' b => Path V2 Double -> Diagram b+debugPath' p = mconcat . map draw $ prts'+  where+    prts = zip (pathPoints p) ['a'..]+    prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts+    draw (pt, l) = moveTo pt $ text' l

@@ -3,91 +3,91 @@ {-# LANGUAGE TypeFamilies              #-} {-# LANGUAGE ConstraintKinds           #-} -module Diagrams.Puzzles.PuzzleGrids where+module Diagrams.Puzzles.PuzzleGrids+    (+      drawIntGrid+    , drawCharGrid+    , outsideIntGrid+    , drawSlitherGrid+    , drawTightGrid+    , sudokugrid+    , drawWordsClues+    , drawOutsideGrid+    , drawMultiOutsideGrid+    , drawOutsideGridN+    , drawMultiOutsideGridN+    , placeMultiOutside+    ) where -import Diagrams.Prelude+import Diagrams.Prelude hiding (size, N) +import qualified Data.Map as Map+import Data.Maybe (maybeToList)+ import Data.Puzzles.Grid+import Data.Puzzles.GridShape import Data.Puzzles.Elements import Data.Puzzles.Sudoku  import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Style import Diagrams.Puzzles.Grid-import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Elements -drawClueGrid :: Backend' b =>-                SGrid (Clue Char) -> Diagram b R2-drawClueGrid = atCentres drawChar . clues <> grid . size--drawIntClues :: Backend' b =>-                SGrid (Clue Int) -> Diagram b R2-drawIntClues = atCentres drawInt . clues--drawInts :: Backend' b =>-            SGrid Int -> Diagram b R2-drawInts = atCentres drawInt . values+drawCharGrid :: Backend' b =>+                Grid C (Maybe Char) -> Diagram b+drawCharGrid = placeGrid . fmap drawChar . clues <> grid gDefault  drawIntGrid :: Backend' b =>-               SGrid (Clue Int) -> Diagram b R2-drawIntGrid = drawIntClues <> grid . size+               Grid C (Maybe Int) -> Diagram b+drawIntGrid = placeGrid . fmap drawInt . clues  <> grid gDefault  drawSlitherGrid :: Backend' b =>-                   SGrid (Clue Int) -> Diagram b R2-drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size--drawMasyuGrid :: Backend' b =>-                 SGrid MasyuClue -> Diagram b R2-drawMasyuGrid = atCentres pearl . clues <> grid . size--drawCompassClues :: Backend' b =>-                    SGrid CompassClue -> Diagram b R2-drawCompassClues = atCentres drawCompassClue . clues--drawCompassGrid :: Backend' b =>-                   SGrid CompassClue -> Diagram b R2-drawCompassGrid = drawCompassClues <> grid . size+                   Grid C (Maybe Int) -> Diagram b+drawSlitherGrid = placeGrid . fmap  drawInt . clues <> grid gSlither  sudokugrid :: Backend' b =>-              SGrid a -> Diagram b R2-sudokugrid = drawEdges . sudokubordersg  <> grid . size+              Grid C a -> Diagram b+sudokugrid = drawEdges . sudokubordersg <> grid gDefault  drawWordsClues :: Backend' b =>-                  SGrid (Clue [String]) -> Diagram b R2-drawWordsClues = atCentres drawWords . clues+                  Grid C (Maybe [String]) -> Diagram b+drawWordsClues = placeGrid . fmap drawWords . clues  drawTightGrid :: Backend' b =>-                 (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2-drawTightGrid d g = atCentres (drawTight d) (values g)-                    <> grid (size g)-                    <> phantom' (stroke $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1))-    where (sx, sy) = size g+                 (t -> Diagram b) -> Grid C (Tightfit t) -> Diagram b+drawTightGrid d g = (placeGrid . fmap (drawTight d) $ g)+                    <> grid gDefault g+                    <> phantom' (strokePath $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1))+    where (sx, sy) = size (Map.mapKeys toCoord g) -drawSlalomGrid :: Backend' b =>-                  SGrid (Clue Int) -> Diagram b R2-drawSlalomGrid g = atVertices drawSlalomClue (clues g)-                   <> grid (w-1, h-1)-    where (w, h) = size g+placeMultiOutside :: (Ord k, FromCoord k, ToPoint k,+                      HasOrigin a, Monoid a,+                      InSpace V2 Double a)+                  => OutsideClues k [a] -> a+placeMultiOutside = placeGrid . multiOutsideClues -drawSlalomDiags :: Backend' b =>-                   SGrid SlalomDiag -> Diagram b R2-drawSlalomDiags = atCentres diag . clues . fmap Just-    where diag SlalomForward  = stroke ur # lwG edgewidth-          diag SlalomBackward = stroke dr # lwG edgewidth+placeOutside :: (Ord k, FromCoord k, ToPoint k,+                 HasOrigin a, Monoid a,+                 InSpace V2 Double a)+             => OutsideClues k (Maybe a) -> a+placeOutside = placeMultiOutside . fmap maybeToList -drawCrosses ::  Backend' b =>-                 SGrid Bool -> Diagram b R2-drawCrosses = atCentres (if' drawCross mempty) . values-  where-    if' a b x = if x then a else b+drawOutsideGrid :: Backend' b => OutsideClues C (Maybe String) -> Diagram b+drawOutsideGrid = placeOutside . fmap (fmap (scale 0.8 . drawText))+                  <> grid gDefault . outsideGrid +drawOutsideGridN :: Backend' b => OutsideClues N (Maybe String) -> Diagram b+drawOutsideGridN = placeOutside . fmap (fmap (scale 0.8 . drawText))+                  <> grid gDefault . cellGrid . outsideGrid -outsideGrid :: Backend' b =>-               OutsideClues [String] -> Diagram b R2-outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues-              <> grid . outsideSize+drawMultiOutsideGrid :: Backend' b => OutsideClues C [String] -> Diagram b+drawMultiOutsideGrid = placeMultiOutside . fmap (fmap (scale 0.8 . drawText))+                     <> grid gDefault . outsideGrid -outsideIntGrid :: Backend' b =>-                  OutsideClues [Int] -> Diagram b R2-outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues-                 <> grid . outsideSize+drawMultiOutsideGridN :: Backend' b => OutsideClues N [String] -> Diagram b+drawMultiOutsideGridN = placeMultiOutside . fmap (fmap (scale 0.8 . drawText))+                      <> grid gDefault . cellGrid . outsideGrid++outsideIntGrid :: Backend' b => OutsideClues C [Int] -> Diagram b+outsideIntGrid = drawMultiOutsideGrid . fmap (fmap show)

@@ -1,3 +1,4 @@+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}@@ -10,11 +11,25 @@     curvedata, doubleback, slalom, compass, boxof2or3,     afternoonskyscrapers, meanderingnumbers, tapa, japanesesums,     coral, maximallengths, primeplace, labyrinth, bahnhof,-    cave+    cave, angleLoop, shikaku, slovaksums,+    blackoutDominos, anglers, skyscrapers,+    summon, baca, buchstabensalat, doppelblock, sudokuDoppelblock,+    dominos, skyscrapersStars, fillominoCheckered, numberlink,+    slithermulti, dominoPills, fillominoLoop, loopki, litssym,+    scrabble, neighbors, starwars, heyawake, wormhole, pentominous,+    starbattle, colorakari, persistenceOfMemory, abctje, kropki,+    statuepark, pentominousBorders, nanroSignpost, tomTom,+    horseSnake, illumination, pentopia,+    pentominoPipes, greaterWall, galaxies   ) where -import Diagrams.Prelude hiding (Loop, coral)+import Diagrams.Prelude hiding (Loop, N, coral, size) +import Data.Char (isUpper)+import Data.List (nub, sort, sortOn)+import qualified Data.Map as Map++import Diagrams.Puzzles.Style import Diagrams.Puzzles.PuzzleGrids import Diagrams.Puzzles.Draw import Diagrams.Puzzles.Grid@@ -24,64 +39,97 @@ import Diagrams.Puzzles.Widths  import Data.Puzzles.Grid-import Data.Puzzles.GridShape (Edge)+import Data.Puzzles.GridShape import Data.Puzzles.Elements import qualified Data.Puzzles.Pyramid as Pyr  lits :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid lits = (,)-    drawAreaGridGray-    (drawAreaGrid . fst <> drawShadedGrid . snd)+    (grid gDefault <> drawAreasGray)+    ((drawAreas <> grid gDefault) . fst <> drawShade . snd)  litsplus :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid litsplus = lits -solstyle :: (HasStyle a, V a ~ R2) => a -> a+litssym :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid+litssym = (,)+    p+    (p . fst <> drawShade . snd)+  where+    p g = drawAreas g <> grid gDefault g <> translate (c g) (scale 0.5 $ smallPearl MBlack)+    c g = let (rs, cs) = size . Map.mapKeys toCoord $ g+          in r2 ((fromIntegral rs) / 2, (fromIntegral cs) / 2)++solstyle :: (HasStyle a, InSpace V2 Double a) => a -> a solstyle = lc (blend 0.8 black white) . lwG (3 * onepix) -geradeweg :: Backend' b => RenderPuzzle b IntGrid Loop+geradeweg :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Loop C) geradeweg = (,)     drawIntGrid-    (drawIntClues . fst-     <> solstyle . drawDualEdges . snd-     <> grid . size . fst)+    (placeGrid . fmap drawInt . clues . fst+     <> solstyle . drawEdges . snd+     <> grid gDefault . fst) -fillomino :: Backend' b => RenderPuzzle b IntGrid (SGrid Int)+fillomino :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Grid C Int) fillomino = (,)-    (atCentres drawInt . clues <> dashedgrid . size)-    ((atCentres drawInt . values <> drawEdges . borders <> dashedgrid . size) . snd)+    (placeGrid . fmap drawInt . clues <> grid gDashed)+    ((placeGrid . fmap drawInt <> drawEdges . borders <> grid gDashed) . snd) +fillominoCheckered :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Grid C Int)+fillominoCheckered = (,)+    (placeGrid . fmap  drawInt . clues <> grid gDashed)+    ((placeGrid . fmap drawInt+      <> drawEdges . borders+      <> grid gDashed+      <> shadeGrid . checker) . snd)+  where+    checker = fmap pickColour . colour+    pickColour 1 = Nothing+    pickColour 2 = Just gray+    pickColour _ = Just red++fillominoLoop :: Backend' b => RenderPuzzle b (Grid C (Maybe Int))+                                              (Grid C Int, Loop C)+fillominoLoop = (,)+    (fst fillomino)+    ((placeGrid . fmap drawInt . fst+      <> solstyle . drawEdges . snd+      <> drawEdges . borders . fst+      <> grid gDashed . fst) . snd)+ masyu :: Backend' b =>-         RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop+         RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Loop C) masyu = (,)-    drawMasyuGrid-    (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst)+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = placeGrid . fmap pearl . clues <> grid gDefault  nurikabe :: Backend' b =>-            RenderPuzzle b IntGrid ShadedGrid+            RenderPuzzle b (Grid C (Maybe Int)) ShadedGrid nurikabe = (,)     drawIntGrid-    (drawIntGrid . fst <> drawShadedGrid . snd)+    (drawIntGrid . fst <> drawShade . snd)  latintapa :: Backend' b =>-             RenderPuzzle b (SGrid (Clue [String])) CharClueGrid+             RenderPuzzle b (Grid C (Maybe [String])) (Grid C (Maybe Char)) latintapa = (,)     l-    (l . fst <> atCentres drawChar . clues . snd)+    (l . fst <> placeGrid . fmap drawChar . clues . snd)   where-    l = grid . size <> drawWordsClues+    l = grid gDefault <> drawWordsClues  sudoku :: Backend' b =>-          RenderPuzzle b IntGrid IntGrid+          RenderPuzzle b (Grid C (Maybe Int)) (Grid C (Maybe Int)) sudoku = (,)-    (drawIntClues <> sudokugrid)-    ((drawIntClues <> sudokugrid) . snd)+    (placeGrid . fmap drawInt . clues <> sudokugrid)+    ((placeGrid . fmap drawInt . clues <> sudokugrid) . snd)  thermosudoku :: Backend' b =>-                RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid+                RenderPuzzle b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int)) thermosudoku = (,)-    (drawInts . fst <> sudokugrid . fst <> drawThermos . snd)-    (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst)+    (placeGrid . fmap drawInt . clues . fst <> sudokugrid . fst <> drawThermos . snd)+    (placeGrid . fmap drawInt . clues . snd <> sudokugrid . snd <> drawThermos . snd . fst)  pyramid :: Backend' b =>     RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol@@ -100,158 +148,610 @@     merge (p, q) = Pyr.mergekpyramidsol p q  slither :: Backend' b =>-           RenderPuzzle b IntGrid Loop+           RenderPuzzle b (Grid C (Maybe Int)) (Loop N) slither = (,)     drawSlitherGrid     (drawSlitherGrid . fst <> solstyle . drawEdges . snd)  liarslither :: Backend' b =>-               RenderPuzzle b IntGrid (Loop, SGrid Bool)+               RenderPuzzle b (Grid C (Maybe Int)) (Loop N, Grid C Bool) liarslither = (,)     drawSlitherGrid-    (solstyle . drawCrosses . snd . snd+    (placeGrid . fmap (solstyle . drawCross) . snd . snd      <> drawSlitherGrid . fst      <> solstyle . drawEdges . fst . snd) +slithermulti :: Backend' b =>+                RenderPuzzle b (Grid C (Maybe Int), Int) [Edge N]+slithermulti = (,)+    (drawSlitherGrid . fst <> n)+    (drawSlitherGrid . fst . fst <> solstyle . drawEdges . snd)+  where+    n (g, l) = placeNote (size' g) (drawInt l ||| strutX 0.2 ||| miniloop)+    size' = size . Map.mapKeys toCoord+ tightfitskyscrapers :: Backend' b =>-                       RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ()))-                                      (SGrid (Tightfit Int))+                       RenderPuzzle b (OutsideClues C (Maybe Int), Grid C (Tightfit ()))+                                      (Grid C (Tightfit Int)) tightfitskyscrapers = (,)-    (atCentres drawInt . outsideClues . fst+    (placeGrid . fmap drawInt . clues . outsideClues . fst      <> drawTightGrid (const mempty) . snd)-    (atCentres drawInt . outsideClues . fst . fst+    (placeGrid . fmap drawInt . clues . outsideClues . fst . fst      <> drawTightGrid drawInt . snd)  wordgrid :: Backend' b =>-            SGrid (Maybe Char) -> [String] -> Diagram b R2-wordgrid g ws = stackWords ws `besidesR` drawClueGrid g+            Grid C (Maybe Char) -> [String] -> Diagram b+wordgrid g ws = stackWords ws `besidesR` drawCharGrid g  wordloop :: Backend' b =>-            RenderPuzzle b (CharClueGrid, [String]) CharClueGrid+            RenderPuzzle b (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) wordloop = (,)     (uncurry wordgrid)-    (drawClueGrid . snd)+    (drawCharGrid . snd)  wordsearch :: Backend' b =>-              RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])+              RenderPuzzle b (Grid C (Maybe Char), [String])+                             (Grid C (Maybe Char), [MarkedWord]) wordsearch = (,)     (uncurry wordgrid)      (solstyle . drawMarkedWords . snd . snd-     <> drawClueGrid . fst . snd)+     <> drawCharGrid . fst . snd)  curvedata :: Backend' b =>-             RenderPuzzle b (SGrid (Clue [Edge])) [Edge]+             RenderPuzzle b (Grid C (Maybe [Edge N])) [Edge C] curvedata = (,)     cd-    ((solstyle . drawDualEdges . snd) <> cd . fst)+    ((solstyle . drawEdges . snd) <> cd . fst)   where-    cd = atCentres drawCurve . clues <> grid . size+    cd = placeGrid . fmap drawCurve . clues <> grid gDefault  doubleback :: Backend' b =>-              RenderPuzzle b AreaGrid Loop+              RenderPuzzle b AreaGrid (Loop C) doubleback = (,)-    drawAreaGridGray-    (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst)+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = grid gDefault <> drawAreasGray  slalom :: Backend' b =>-          RenderPuzzle b IntGrid (SGrid SlalomDiag)+          RenderPuzzle b (Grid N (Maybe Int)) (Grid C SlalomDiag) slalom = (,)-    drawSlalomGrid-    (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd)+    p+    (p . fst <> placeGrid . fmap (solstyle . drawSlalomDiag) . snd)+  where+    p = placeGrid . fmap drawSlalomClue . clues+        <> grid gDefault . cellGrid  compass :: Backend' b =>-           RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid+           RenderPuzzle b (Grid C (Maybe CompassC)) AreaGrid compass = (,)-    drawCompassGrid-    (drawCompassClues . fst <> drawAreaGridGray . snd)+    (placeGrid . fmap drawCompassClue . clues <> grid gDashed)+    (placeGrid . fmap drawCompassClue . clues . fst+     <> (grid gDashed <> drawAreasGray) . snd)  boxof2or3 :: Backend' b =>-             RenderPuzzle b (SGrid MasyuPearl, [Edge]) ()+             RenderPuzzle b (Grid N MasyuPearl, [Edge N]) () boxof2or3 = (,)-    (atCentres smallPearl . values . fst-     <> phantom' . grid . size . fst-     <> drawThinDualEdges . snd)+    (placeGrid . fmap smallPearl . fst+     <> drawThinEdges . snd)     (error "boxof2or3 solution not implemented")  afternoonskyscrapers :: Backend' b =>-                        RenderPuzzle b (SGrid Shade) IntGrid+                        RenderPuzzle b (Grid C Shade) (Grid C (Maybe Int)) afternoonskyscrapers = (,)-    (grid . size <> atCentres drawShade . values)-    (drawIntGrid . snd <> atCentres drawShade . values . fst)+    (grid gDefault <> placeGrid . fmap drawShadow)+    (drawIntGrid . snd <> placeGrid . fmap drawShadow . fst)  meanderingnumbers :: Backend' b =>-                        RenderPuzzle b AreaGrid IntGrid+                        RenderPuzzle b AreaGrid (Grid C (Maybe Int)) meanderingnumbers = (,)-    drawAreaGrid-    (drawIntGrid . snd <> drawAreaGrid . fst)+    (grid gDefault <> drawAreas)+    (drawIntGrid . snd <> drawAreas . fst)  tapa :: Backend' b =>-        RenderPuzzle b (SGrid TapaClue) ShadedGrid+        RenderPuzzle b (Grid C (Maybe TapaClue)) ShadedGrid tapa = (,)     tapaGrid-    (tapaGrid . fst <> drawShadedGrid . snd)+    (tapaGrid . fst <> drawShade . snd)   where-    tapaGrid = atCentres drawTapaClue . values <> grid . size+    tapaGrid = placeGrid . fmap drawTapaClue . clues <> grid gDefault  japanesesums :: Backend' b =>-                RenderPuzzle b (OutsideClues [Int]) (SGrid (Either Black Int))+                RenderPuzzle b (OutsideClues C [Int], String)+                               (Grid C (Either Black Int)) japanesesums = (,)-    outsideIntGrid-    (outsideIntGrid . fst <> japcells . snd)+    (outsideIntGrid . fst <> n)+    (outsideIntGrid . fst . fst <> japcells . snd)   where-    japcells = atCentres japcell . values+    n (ocs, ds) = placeNoteTL (0, h ocs) (drawText ds # scale 0.8)+    japcells = placeGrid . fmap japcell     japcell (Left Black) = fillBG gray     japcell (Right x) = drawInt x+    h = snd . outsideSize  coral :: Backend' b =>-          RenderPuzzle b (OutsideClues [String]) ShadedGrid+          RenderPuzzle b (OutsideClues C [String]) ShadedGrid coral = (,)-    outsideGrid-    (outsideGrid . fst <> drawShadedGrid . snd)+    drawMultiOutsideGrid+    (drawMultiOutsideGrid . fst <> drawShade . snd)  maximallengths :: Backend' b =>-                  RenderPuzzle b (OutsideClues (Maybe Int)) Loop+                  RenderPuzzle b (OutsideClues C (Maybe Int)) (Loop C) maximallengths = (,)     g-    (solstyle . drawDualEdges . snd <> g . fst)+    (solstyle . drawEdges . snd <> g . fst)   where-    g = atCentres drawInt . outsideClues-        <> grid . outsideSize+    g = placeGrid . fmap drawInt . clues . outsideClues+        <> grid gDefault . outsideGrid  primeplace :: Backend' b =>-              RenderPuzzle b (SGrid PrimeDiag) (SGrid Int)+              RenderPuzzle b (Grid C PrimeDiag) (Grid C Int) primeplace = (,)     g-    (atCentres drawInt . values . snd <> g . fst)+    (placeGrid . fmap drawInt . snd <> g . fst)   where-    g = irregularGrid <> atCentres drawPrimeDiag . values+    g = grid gStyle+        <> placeGrid . fmap drawPrimeDiag+    gStyle = GridStyle LineThin LineThick Nothing VertexNone  labyrinth :: Backend' b =>-             RenderPuzzle b (SGrid (Clue Int), [Edge]) (SGrid (Clue Int))+             RenderPuzzle b (Grid C (Maybe Int), [Edge N]) (Grid C (Maybe Int)) labyrinth = (,)-    (atCentres drawInt . clues . fst <> g)-    (atCentres drawInt . clues . snd <> g . fst)+    (placeGrid . fmap drawInt . clues . fst <> g)+    (placeGrid . fmap drawInt . clues . snd <> g . fst)   where-    g = drawEdges . snd <> plaingrid . size . fst+    g = drawEdges . snd <> grid gPlain . fst  bahnhof :: Backend' b =>-            RenderPuzzle b (SGrid (Maybe BahnhofClue)) [Edge]+            RenderPuzzle b (Grid C (Maybe BahnhofClue)) [Edge C] bahnhof = (,)-    (atCentres drawBahnhofClue . clues <> grid . size)-    (atCentres drawBahnhofStation . clues . fst-     <> solstyle . drawDualEdges . snd-     <> grid . size . fst)+    (placeGrid . fmap drawBahnhofClue . clues <> grid gDefault)+    (placeGrid . fmap drawBahnhofStation . clues . fst+     <> solstyle . drawEdges . snd+     <> grid gDefault . fst)   where     drawBahnhofStation = either drawInt (const mempty) +blackoutDominos :: Backend' b =>+                   RenderPuzzle b (Grid C (Clue Int), DigitRange)+                                  (Grid C (Clue Int), AreaGrid)+blackoutDominos = (,)+    p+    ((placeGrid . fmap drawInt . clues . fst+      <> grid gDashedThick . fst +      <> drawAreas . snd+      <> shadeGrid . fmap cols . snd) . snd)+  where+    p (g, ds) = (placeGrid . fmap drawInt . clues <> grid gDashedThick $ g)+                `aboveT`+                drawDominos ds+    cols 'X' = Just gray+    cols _   = Nothing++angleLoop ::+    Backend' b =>+    RenderPuzzle b (Grid N (Clue Int)) VertexLoop+angleLoop = (,)+    (cs <> gr)+    (cs . fst+     <> lineJoin LineJoinBevel . solstyle . strokeLocLoop . vertexLoop . snd+     <> gr . fst)+  where+    cs = placeGrid . fmap drawAnglePoly . clues+    gr = grid gPlainDashed . cellGrid++anglers ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Clue Int), Grid C (Maybe Fish)) [Edge C]+anglers = (,)+    (p <> g)+    (p . fst <> solstyle . drawEdges . snd <> g . fst)+  where+    p = placeGrid . fmap drawInt' . clues . outsideClues . fst <>+        placeGrid . fmap drawFish' . clues . snd+    g = grid gDefault . snd+    drawInt' x = drawInt x <> (square 0.6 # lc white # fc white)+    drawFish' x = drawFish x <> (square 0.6 # lc white # fc white)+ cave ::-    (Backend b R2, Renderable (Path R2) b) =>-    RenderPuzzle b (SGrid (Clue Int)) ShadedGrid+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Int)) ShadedGrid cave = (,)-    g+    (grid gDashDash <> placeGrid . fmap drawInt . clues)     (drawEdges . edgesGen (/=) not . snd-     <> drawShadedGrid . snd <> fr . fst-     <> g . fst)+     <> placeGrid . fmap drawInt . clues . fst+     <> drawShade . snd+     <> grid gStyle . fst)   where-    g = gridDashing . plaingrid . size <> atCentres drawInt . clues-    fr gr = outframe' 8 (size gr) # lc gray+    gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone+    gStyle = GridStyle LineDashed LineNone (Just $ FrameStyle 8 gray)+                       VertexNone++skyscrapers ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+skyscrapers = (,)+    (g . fst <> n)+    (g . fst . fst <> placeGrid . fmap drawInt . clues . snd)+  where+    g = placeGrid . fmap drawInt . clues . outsideClues+        <> grid gDefault . outsideGrid+    n (oc, s) = placeNote (outsideSize oc) (drawText s)++shikaku :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) AreaGrid+shikaku = (,)+    p+    (drawAreas . snd <> p . fst)+  where+    p = placeGrid . fmap drawInt . clues <> grid gDashed++slovaksums :: Backend' b => RenderPuzzle b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int))+slovaksums = (,)+    (p . fst <> n)+    (placeGrid . fmap drawInt . clues . snd <> p . fst . fst)+  where+    n (g, ds) = placeNote (size' g) (drawText ds # scale 0.8)+    p = grid gDefault <> placeGrid . fmap drawSlovakClue . clues+    size' = size . Map.mapKeys toCoord++skyscrapersStars ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Maybe Int), Int)+                   (Grid C (Either Int Star))+skyscrapersStars = (,)+    (g <> n)+    (g . fst <> placeGrid . fmap (either drawInt drawStar) . snd)+  where+    g = (placeGrid . fmap drawInt . clues . outsideClues+         <> grid gDefault . outsideGrid) . fst+    n (oc, s) = placeNote (outsideSize oc)+                          (drawInt s ||| strutX 0.2 ||| drawStar Star)++summon ::+    Backend' b =>+    RenderPuzzle b (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+summon = (,)+    (p <> n)+    (placeGrid . fmap drawInt . clues . snd <> p . fst)+  where+    p (g, oc, _) = grid gDefault g <> drawAreasGray g+                <> (placeGrid . clues . outsideClues+                    . al . fmap (fmap (scale 0.7 . drawInt)) $ oc)+    al :: Backend' b => OutsideClues k (Maybe (Diagram b)) -> OutsideClues k (Maybe (Diagram b))+    al (OC l r b t) = OC l (map (fmap alignL) r) b t++    n (g, _, ds) = placeNoteBR (size' g) (drawText ds # scale 0.7)+    size' = size . Map.mapKeys toCoord++baca ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Char),+                    OutsideClues C [Int],+                    OutsideClues C (Maybe Char))+                   (Grid C (Either Black Char))+baca = (,)+    (inside <> outside)+    (outside . fst <> placeGrid . fmap drawVal . snd <> inside . fst)+  where+    inside (g,_,_) = placeGrid . fmap (fc gray . drawChar) . clues $ g+    outside (g,tl,br) =+              grid gDefault g+              <> (placeGrid . fmap drawInt+                  . multiOutsideClues $ tl)+              <> (placeGrid . fmap drawChar . clues+                  . outsideClues $ br)+    drawVal (Right c) = drawChar c+    drawVal (Left _) = fillBG gray++buchstabensalat ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Maybe Char), String) (Grid C (Maybe Char))+buchstabensalat = (p <> n, p . fst <> placeGrid . fmap drawChar . clues . snd)+  where+    p = (placeGrid . fmap drawChar . clues . outsideClues+         <> grid gDefault . outsideGrid) . fst+    n (ocs, ls) = placeNote (outsideSize ocs) (drawText ls # scale 0.8)++doppelblock ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Maybe Int))+                   (Grid C (Either Black Int))+doppelblock = (,)+    p+    (p . fst <> placeGrid . fmap drawVal . snd)+  where+    p = placeGrid . fmap (scale 0.8 . drawInt) . clues . outsideClues+        <> grid gDefault . outsideGrid+    drawVal (Right c) = drawInt c+    drawVal (Left _) = fillBG gray++sudokuDoppelblock ::+    Backend' b =>+    RenderPuzzle b (AreaGrid, OutsideClues C (Maybe Int))+                   (Grid C (Either Black Int))+sudokuDoppelblock = (,)+    p+    (p . fst <> placeGrid . fmap drawVal . snd)+  where+    p = placeGrid . fmap (scale 0.8 . drawInt) . clues . outsideClues . snd+        <> (grid gDefault <> drawAreas) . fst+    drawVal (Right c) = drawInt c+    drawVal (Left _) = fillBG gray++dominos ::+    Backend' b =>+    RenderPuzzle b (Grid C (Clue Int), DigitRange) AreaGrid+dominos = (,)+    p+    (placeGrid . fmap drawInt . clues . fst . fst+     <> (grid gDashed <> drawAreasGray) . snd)+  where+    p (g, r) =+        ((placeGrid . fmap drawInt . clues <> grid gDashed) $ g)+        `aboveT`+        drawDominos r++dominoPills ::+    Backend' b =>+    RenderPuzzle b (Grid C (Clue Int), DigitRange, DigitRange) AreaGrid+dominoPills = (,)+    p+    (placeGrid . fmap drawInt . clues . fst3 . fst+     <> (grid gDashed <> drawAreasGray) . snd)+  where+    fst3 (a,_,_) = a+    p (g, ds, ps) =+        ((placeGrid . fmap drawInt . clues <> grid gDashed) $ g)+        `aboveT`+        (drawDominos ds ||| strutX 0.5 ||| drawPills ps)++numberlink ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Int)) [Edge C]+numberlink = (,)+    drawIntGrid+    (placeGrid . fmap drawInt' . clues . fst+     <> solstyle . drawEdges . snd+     <> grid gDefault . fst)+  where+    drawInt' x = drawInt x <> (square 0.7 # lc white # fc white)++loopki :: Backend' b =>+          RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Loop N)+loopki = (,)+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = placeGrid . fmap (scale 0.5 . pearl) . clues <> grid gSlither++scrabble :: Backend' b =>+            RenderPuzzle b (Grid C Bool, [String]) (Grid C (Maybe Char))+scrabble = (,)+    p+    (placeGrid . fmap drawCharFixed . clues . snd <> gr . fst . fst)+  where+    p (g, ws) = stackWords ws `besidesR` gr g+    gr = grid gDefault <> drawShade++neighbors :: Backend' b =>+             RenderPuzzle b (Grid C Bool, Grid C (Maybe Int)) (Grid C Int)+neighbors = (,)+    (placeGrid . fmap drawInt . clues . snd <> (grid gDefault <> drawShade) . fst)+    (placeGrid . fmap drawInt . snd <> (grid gDefault <> drawShade) . fst . fst)++starwars :: Backend' b =>+            RenderPuzzle b (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star))+starwars = (,)+    p+    (p . fst <> placeGrid . fmap drawStar . clues . snd)+  where+    p = ((drawAreas <> grid gDefault) . fst <> drawMarkedLines . snd)++starbattle :: Backend' b =>+              RenderPuzzle b (AreaGrid, Int) (Grid C (Maybe Star))+starbattle = (,)+    (p <> n)+    ((p <> n) . fst <> placeGrid . fmap drawStar . clues . snd)+  where+    p = (drawAreas <> grid gDefault) . fst+    n (g, k) = placeNote (size' g)+                         (drawInt k ||| strutX 0.2 ||| drawStar Star)+    size' = size . Map.mapKeys toCoord++heyawake :: Backend' b =>+            RenderPuzzle b (AreaGrid, Grid C (Maybe Int)) (Grid C Bool)+heyawake = (,)+    (as <> cs)+    (as . fst <> drawShade . snd <> cs . fst)+  where+    as = (drawAreas <> grid gDefault) . fst+    cs = placeGrid . fmap drawInt . clues . snd++wormhole :: Backend' b =>+            RenderPuzzle b (Grid C (Maybe (Either Int Char))) ()+wormhole = (,)+    (placeGrid . fmap (either drawInt drawChar) . clues <> grid gDashed)+    mempty++pentominous ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Char)) (Grid C Char)+pentominous = (,)+    (placeGrid . fmap drawChar . clues <> grid gDashed)+    (placeGrid . fmap drawChar . clues . fst <>+     (drawAreas <> grid gDashed) . snd)++colorakari ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Char)) (Grid C (Maybe Char))+colorakari = (,)+    (placeGrid . fmap drawColorClue . clues <> grid gDefault)+    (error "color akari solution not implemented")+  where+    drawColorClue 'X' = fillBG black+    drawColorClue c = case col c of Nothing -> error "invalid color"+                                    Just c' -> drawText [c] # scale 0.5+                                               <> circle (1/3) # fc c'+                                               <> fillBG black+    col c = case c of 'R' -> Just red+                      'G' -> Just green+                      'B' -> Just blue+                      'Y' -> Just yellow+                      'C' -> Just cyan+                      'M' -> Just magenta+                      'W' -> Just white+                      _   -> Nothing++persistenceOfMemory ::+    Backend' b =>+    RenderPuzzle b (AreaGrid, (Grid C (Maybe MEnd))) (Loop C)+persistenceOfMemory = (,)+    (ends_ <> areas)+    (ends_ . fst <> solstyle . drawEdges . snd <> areas . fst)+  where+    ends_ = placeGrid . fmap drawEnd . clues . snd+    areas = (drawAreas <> grid gDashed <> shadeGrid . fmap cols) . fst+    cols c | isUpper c  = Just (blend 0.25 black white)+           | otherwise  = Nothing++abctje ::+    Backend' b =>+    RenderPuzzle b (DigitRange, [(String, Int)]) [(Int, Char)]+abctje = (,)+    p+    ((b . g . h  ||| const (strutX 1.0) ||| b . g . h') . snd)+  where+    p (ds, cs) = (digNote ds `aboveT` (stackWordsLeft ws ||| strutX 1.0 ||| stackWordsRight ns))+                 `besidesR` (strutX 2.0 ||| (b . g $ ps) ||| strutX 1.0 ||| (b . g $ ps'))+      where+        ws = map fst cs+        ns = map (show . snd) cs+        ls = nub . sort . concatMap fst $ cs+        ps = [ (x:[], "") | x <- ls ]+        ps' = [ (show x, "") | x <- digitList ds ]+    digNote (DigitRange x y) = note . drawText $ show x ++ "-" ++ show y+    b = placeGrid . fmap drawText <> grid gPlain+    h = sortOn fst . map (\(x, y) -> (y:[], show x))+    h' = map (\(x, y) -> (show x, y:[]))+    g ps = Map.fromList $+               [ (C 0 (l-i-1), x) | (i, x) <- zip [0..] c1 ] +++               [ (C 1 (l-i-1), x) | (i, x) <- zip [0..] c2 ]+      where+        l = length ps+        c1 = map fst ps+        c2 = map snd ps++kropki ::+    Backend' b =>+    RenderPuzzle b (Map.Map (Edge N) KropkiDot) (Grid C Int)+kropki = (,)+    p+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = placeGrid' . Map.mapKeys midPoint . fmap kropkiDot <> grid gDefault . sizeGrid . sz+    sz m = edgeSize (Map.keys m)++statuepark ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Grid C Bool)+statuepark = (,)+    p+    (p . fst <> drawShade . snd)+  where+    p = placeGrid . fmap pearl . clues <> grid gDashed++pentominousBorders ::+    Backend' b =>+    RenderPuzzle b (Grid C (), [Edge N]) (Grid C Char)+pentominousBorders = (,)+    (drawEdges . snd <> grid gDashed . fst)+    ((drawAreas <> grid gDashed) . snd)++nanroSignpost ::+    Backend' b =>+    RenderPuzzle b (AreaGrid, Grid C (Maybe Int)) (Grid C Int)+nanroSignpost = (,)+    p+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . fmap show . clues . snd)++tomTom ::+    Backend' b =>+    RenderPuzzle b (AreaGrid, Grid C (Maybe String)) (Grid C Int)+tomTom = (,)+    p+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd)++horseSnake ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe (Either MEnd Int))) [Edge C]+horseSnake = (,)+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = (placeGrid . fmap (either drawEnd drawInt) . clues <> grid gDashed)++illumination ::+    Backend' b =>+    RenderPuzzle b (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N])+illumination = (,)+    p+    ((placeGrid . fmap (const (smallPearl MWhite)) . clues . fst <> drawEdges . snd) . snd <> p . fst)+  where+    p = placeGrid . fmap drawFraction . clues . outsideClues+        <> grid gDashed . outsideGrid++pentopia ::+    Backend' b =>+    RenderPuzzle b (Grid C (Maybe Myopia)) (Grid C Bool)+pentopia = (,)+    p+    (p . fst <> drawShade . snd)+  where+    p = placeGrid . fmap drawMyopia . clues <> grid gDefault++pentominoPipes ::+    Backend' b =>+    RenderPuzzle b (Grid N Char) (Grid N KropkiDot, [Edge N])+pentominoPipes = (,)+    (placeGrid . fmap drawCharOpaque <> grid gSlither . cellGrid)+    ((placeGrid . fmap kropkiDot . fst+      <> drawEdges . snd) . snd+     <> grid gSlither . cellGrid . fst)++greaterWall ::+    Backend' b =>+    RenderPuzzle b ([GreaterClue], [GreaterClue]) (Grid C Bool)+greaterWall = (,)+    ((plc <> grid gDefault . outsideGrid) . munge)+    undefined+  where+    munge (rs,cs) = OC (map (reverse . greaterClue) (reverse rs)) [] []+                       (map (map (rotateBy (-1/4))) . map (reverse . greaterClue) $ cs)+    plc ocs = placeGrid' . Map.mapKeys toPt . multiOutsideClues $ ocs+      where+        OC l _ _ _ = ocs+        h = length l+        h' = fromIntegral h+        -- toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0)+        -- terrible hack+        toPt c@(C x y) | x < 0  = let p = toPoint c in scaleX 0.7 p .+^ r2 (-1/2, 0)+                       | y >= h = let p = toPoint c in scaleY 0.7 (p .-^ r2 (0,h')) .+^ r2 (0, 1/2 + h')+        toPt c = toPoint c++galaxies ::+    Backend' b =>+    RenderPuzzle b (Grid C (), Grid N (), Grid C (), Map.Map (Edge N) ()) AreaGrid+galaxies = (,)+    p+    (p . fst <> drawAreas . snd)+  where+    p = (gals <> grid gDashed . fst4)+    gal = const (kropkiDot KWhite)+    gals (_, a,b,c) = (placeGrid . fmap gal $ a)+                   <> (placeGrid . fmap gal $ b)+                   <> (placeGrid' . fmap gal . Map.mapKeys midPoint $ c)+    fst4 (a,_,_,_) = a

@@ -1,47 +1,41 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}  module Diagrams.Puzzles.Pyramid where  import Diagrams.Prelude -import Data.Puzzles.Elements import Data.Puzzles.Pyramid+import Diagrams.Puzzles.Elements import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths  pgray :: Colour Double pgray = blend 0.6 white black -cell :: Backend' b => Bool -> Diagram b R2+cell :: Backend' b => Bool -> Diagram b cell s = square 1 # lwG onepix # if s then fc pgray else id -clue :: Backend' b => Maybe Int -> Diagram b R2+clue :: Backend' b => Maybe Int -> Diagram b clue Nothing = mempty clue (Just c) = text' (show c) -cellc :: Backend' b => Bool -> Maybe Int -> Diagram b R2+cellc :: Backend' b => Bool -> Maybe Int -> Diagram b cellc s c = clue c `atop` cell s -row :: Backend' b => Row -> Diagram b R2+row :: Backend' b => Row -> Diagram b row (R cs s) = centerX . hcat . map (cellc s) $ cs -pyramid :: Backend' b => Pyramid -> Diagram b R2+pyramid :: Backend' b => Pyramid -> Diagram b pyramid = alignBL . vcat . map row . unPyr -kropki :: Backend' b => KropkiDot -> Diagram b R2-kropki KNone = mempty-kropki c = circle 0.1 # lwG 0.03 # fc (col c) # smash-    where col KWhite = white-          col KBlack = blend 0.98 black white-          col KNone  = error "can't reach"--krow :: Backend' b => KropkiRow -> Diagram b R2+krow :: Backend' b => KropkiRow -> Diagram b krow (KR cs s ks) = ccat dots <> ccat clues     where ccat = centerX . hcat           clues = map (cellc s) cs-          dots = interleave (map phantom' clues) (map kropki ks)+          dots = interleave (map phantom clues) (map kropkiDot ks) -kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b R2+kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b kpyramid = alignBL . vcat . map krow . unKP

@@ -0,0 +1,50 @@+module Diagrams.Puzzles.Style+    ( LineStyle (..)+    , FrameStyle (..)+    , VertexStyle (..)+    , GridStyle (..)++    , gDefault+    , gDashed+    , gDashedThick+    , gPlain+    , gPlainDashed+    , gSlither+    ) where++import Diagrams.Puzzles.Widths++import Diagrams.Prelude++data LineStyle =+      LineNone+    | LineThin+    | LineDashed+    | LineThick++data FrameStyle = FrameStyle+    { _fWidthFactor :: Double+    , _fColour      :: Colour Double+    }++data VertexStyle =+      VertexNone+    | VertexDot++data GridStyle = GridStyle+    { _line    :: LineStyle+    , _border  :: LineStyle+    , _frame   :: Maybe FrameStyle+    , _vertex  :: VertexStyle+    }++gDefault, gSlither, gDashed, gDashedThick, gPlain, gPlainDashed :: GridStyle+gDefault = GridStyle LineThin LineThin+                     (Just (FrameStyle framewidthfactor black)) VertexNone+gSlither = GridStyle LineNone LineNone Nothing VertexDot+gDashed  = GridStyle LineDashed LineThin+                     (Just (FrameStyle framewidthfactor black)) VertexNone+gDashedThick  = GridStyle LineDashed LineThick+                          Nothing VertexNone+gPlain   = GridStyle LineThin LineThin Nothing VertexNone+gPlainDashed = GridStyle LineDashed LineDashed Nothing VertexNone

@@ -19,6 +19,8 @@ framewidthfactor :: Double framewidthfactor = 4 -edgewidth, borderwidth :: Double+edgewidth :: Double edgewidth = 3 * onepix++borderwidth :: Double borderwidth = 1 / 2

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Puzzles.Code where++import Data.Puzzles.Code+import Text.Puzzles.Util++import Data.Yaml++import Data.Maybe (catMaybes)++parseCode :: Value -> Parser [CodePart]+parseCode (Object v) = fmap catMaybes . sequenceA $+    [ fmap Rows'   <$> v .:? "cell_rows_bottom"+    , fmap Cols    <$> v .:? "cell_cols"+    , fmap RowsN'  <$> v .:? "node_rows_bottom"+    , fmap ColsN   <$> v .:? "node_cols"+    , fmap (LabelsN . fmap (fmap unAlpha . blankToMaybe)) <$> (do+        v' <- v .:? "node_labels"+        sequenceA (parseGrid <$> v'))+    ] +parseCode _          = fail "expected object"

@@ -0,0 +1,30 @@+-- | Parsec helper for puzzle file parsing.+module Text.Puzzles.Parsec (+    toParser+  , toStringParser+  , fraction+  ) where++import Text.ParserCombinators.Parsec hiding ((<|>))+import qualified Data.Text as T+import qualified Data.Yaml as Yaml+import Control.Applicative++import Data.Puzzles.Elements++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++toStringParser :: GenParser Char () b -> Yaml.Value -> Yaml.Parser b+toStringParser p v = case v of+    Yaml.String t -> toParser p (T.unpack t)+    _             -> fail "expected string"++-- | fraction is meant to parse things like "1 1/2", "3/10", "7".+fraction :: GenParser Char st Fraction+fraction = do+    a <- many1 digit <* spaces+    FComp a <$> many1 digit <*>  (char '/' *> many1 digit)+      <|> FFrac a <$> (char '/' *> many1 digit)+      <|> pure (FInt a)

@@ -7,14 +7,15 @@  import Data.Puzzles.PuzzleTypes -data TypedPuzzle = TP (Maybe String) Value (Maybe Value)+data TypedPuzzle = TP (Maybe String) Value (Maybe Value) (Maybe Value)     deriving Show  instance FromJSON TypedPuzzle where     parseJSON (Object v) = TP <$>                            v .:? "type" <*>                            v .:  "puzzle" <*>-                           v .:? "solution"+                           v .:? "solution" <*>+                           v .:? "code"     parseJSON _          = empty  -- | A pair of parsers for a puzzle type.

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}  module Text.Puzzles.PuzzleTypes (     lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,@@ -6,47 +7,64 @@     liarslither, tightfitskyscrapers, wordloop, wordsearch,     curvedata, doubleback, slalom, compass, boxof2or3,     afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral,-    maximallengths, primeplace, labyrinth, bahnhof, cave+    maximallengths, primeplace, labyrinth, bahnhof, cave, angleLoop,+    shikaku, slovaksums, blackoutDominos,+    anglers, skyscrapers, summon, baca,+    buchstabensalat, doppelblock, sudokuDoppelblock, dominos,+    skyscrapersStars, numberlink, slithermulti, dominoPills,+    fillominoLoop, loopki, scrabble, neighbors, starwars,+    heyawake, wormhole, pentominous, starbattle, colorakari,+    persistenceOfMemory, abctje, kropki, statuepark, pentominousBorders,+    nanroSignpost, tomTom, horseSnake, illumination, pentopia,+    pentominoPipes, greaterWall, galaxies   ) where  import Control.Applicative import Control.Monad +import qualified Data.Map.Strict as M import Data.Yaml  import Text.Puzzles.Util import Text.Puzzles.Puzzle import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)+import Data.Puzzles.GridShape import qualified Data.Puzzles.Pyramid as Pyr import Data.Puzzles.Elements -lits :: ParsePuzzle AreaGrid ShadedGrid+lits :: ParsePuzzle AreaGrid (Grid C Bool) lits = (parseGrid, parseShadedGrid) -litsplus :: ParsePuzzle AreaGrid ShadedGrid+litsplus :: ParsePuzzle AreaGrid (Grid C Bool) litsplus = lits -geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop+geradeweg :: ParsePuzzle (Grid C (Maybe Int)) (Loop C) geradeweg = (parseClueGrid, parseEdges) -fillomino :: ParsePuzzle IntGrid (SGrid Int)-fillomino = (parseClueGrid, parseExtGrid)+fillomino :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int)+fillomino = (parseExtClueGrid, parseExtGrid) -masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop+fillominoLoop :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int, Loop C)+fillominoLoop = (,)+    parseClueGrid+    (\v -> (,) <$> parseFrom ["grid"] parseExtGrid v+               <*> parseFrom ["loop"] parseEdges v)++masyu :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop C) masyu = (parseClueGrid, parseEdges) -nurikabe :: ParsePuzzle IntGrid ShadedGrid-nurikabe = (parseSpacedClueGrid, parseShadedGrid)+nurikabe :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool)+nurikabe = (parseExtClueGrid, parseShadedGrid) -latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char))+latintapa :: ParsePuzzle (Grid C (Maybe [String])) (Grid C (Maybe Char)) latintapa = ((unRG <$>) . parseJSON,              fmap (fmap (fmap unAlpha)) . parseClueGrid') -sudoku :: ParsePuzzle IntGrid IntGrid+sudoku :: ParsePuzzle (Grid C (Maybe Int)) (Grid C (Maybe Int)) sudoku = (parseClueGrid, parseClueGrid) -thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid+thermosudoku :: ParsePuzzle (Grid C (Maybe Int), [Thermometer])+                            (Grid C (Maybe Int)) thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid)  pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol@@ -55,25 +73,30 @@ kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol kpyramid = (parseJSON, parseJSON) -slither :: ParsePuzzle (SGrid (Clue Int)) Loop+slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N) slither = (parseClueGrid, parseEdges) -newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) }+slithermulti :: ParsePuzzle (Grid C (Clue Int), Int) [Edge N]+slithermulti = (p, parseEdges)+  where p v = (,) <$> parseFrom ["grid"] parseClueGrid v+                  <*> parseFrom ["loops"] parseJSON v++newtype LSol = LSol { unLSol :: (Loop N, Grid C 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 :: ParsePuzzle (Grid C (Maybe Int)) (Loop N, Grid C Bool) liarslither = (parseClueGrid, (unLSol <$>) . parseJSON)  tightfitskyscrapers :: ParsePuzzle-                       (OutsideClues (Maybe Int), SGrid (Tightfit ()))-                       (SGrid (Tightfit Int))-tightfitskyscrapers = (parseTightOutside, parseTightIntGrid)+                       (OutsideClues C (Maybe Int), Grid C (Tightfit ()))+                       (Grid C (Tightfit Int))+tightfitskyscrapers = (parseTightOutside, parseSpacedGrid) -newtype GridWords = GW { unGW :: (CharClueGrid, [String]) }+newtype GridWords = GW { unGW :: (Grid C (Maybe Char), [String]) }  instance FromJSON GridWords where     parseJSON (Object v) = GW <$> ((,) <$>@@ -81,10 +104,10 @@                                    v .: "words")     parseJSON _ = empty -wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid+wordloop :: ParsePuzzle (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) wordloop = ((unGW <$>) . parseJSON, parseClueGrid) -newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) }+newtype GridMarked = GM { unGM :: (Grid C (Maybe Char), [MarkedWord]) }  instance FromJSON GridMarked where     parseJSON (Object v) = GM <$> ((,) <$>@@ -92,60 +115,311 @@                                    (map unPMW <$> v .: "words"))     parseJSON _          = mzero -wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])+wordsearch :: ParsePuzzle (Grid C (Maybe Char), [String])+                          (Grid C (Maybe Char), [MarkedWord]) wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON) -newtype Curve = Curve { unCurve :: [Edge] }+newtype Curve = Curve { unCurve :: [Edge N] }  instance FromJSON Curve where     parseJSON v = Curve <$> parsePlainEdges v -curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge]+curvedata :: ParsePuzzle (Grid C (Maybe [Edge N])) [Edge C] curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges) -doubleback :: ParsePuzzle AreaGrid Loop+doubleback :: ParsePuzzle AreaGrid (Loop C) doubleback = (parseGrid, parseEdges) -slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag)-slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v)+slalom :: ParsePuzzle (Grid N (Maybe Int)) (Grid C SlalomDiag)+slalom = (parseClueGrid, parseGrid) -compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid+compass :: ParsePuzzle (Grid C (Maybe CompassC)) AreaGrid compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid) -boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) ()+boxof2or3 :: ParsePuzzle (Grid N MasyuPearl, [Edge N]) () boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented") -afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid+afternoonskyscrapers :: ParsePuzzle (Grid C Shade) (Grid C (Maybe Int)) afternoonskyscrapers = (parseAfternoonGrid, parseGrid)  -- this should be changed to support clue numbers-meanderingnumbers :: ParsePuzzle AreaGrid IntGrid+meanderingnumbers :: ParsePuzzle AreaGrid (Grid C (Maybe Int)) meanderingnumbers = (parseGrid, parseGrid) -tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid-tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v,+tapa :: ParsePuzzle (Grid C (Maybe TapaClue)) (Grid C Bool)+tapa = (\v -> fmap (fmap unParseTapaClue) . unRG <$> parseJSON v,         parseShadedGrid) -japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid (Either Black Int))-japanesesums = (parseMultiOutsideClues, parseGrid)+japanesesums :: ParsePuzzle (OutsideClues C [Int], String)+                            (Grid C (Either Black Int))+japanesesums = (p, parseGrid)+  where+    p v@(Object o) = (,) <$> parseMultiOutsideClues v <*> o .: "digits"+    p _            = empty -coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid+coral :: ParsePuzzle (OutsideClues C [String]) (Grid C Bool) coral = (,)     (fmap (fmap (map unIntString)) . parseMultiOutsideClues)     parseShadedGrid -maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop+maximallengths :: ParsePuzzle (OutsideClues C (Maybe Int)) (Loop C) maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v,                   parseEdges) -primeplace :: ParsePuzzle (SGrid PrimeDiag) (SGrid Int)+primeplace :: ParsePuzzle (Grid C PrimeDiag) (Grid C Int) primeplace = (parseIrregGrid, parseIrregGrid) -labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int))+labyrinth :: ParsePuzzle (Grid C (Maybe Int), [Edge N]) (Grid C (Maybe Int)) labyrinth = (parseCellEdges, parseClueGrid') -bahnhof :: ParsePuzzle (SGrid (Maybe BahnhofClue)) [Edge]+bahnhof :: ParsePuzzle (Grid C (Maybe BahnhofClue)) [Edge C] bahnhof = (parseClueGrid, parseEdges) -cave :: ParsePuzzle (SGrid (Clue Int)) ShadedGrid+blackoutDominos :: ParsePuzzle (Grid C (Clue Int), DigitRange)+                               (Grid C (Clue Int), AreaGrid)+blackoutDominos = (,)+    (\v -> (,) <$> parseFrom ["grid"] parseIrregGrid v+               <*> parseFrom ["digits"] parseStringJSON v)+    (\v -> (,) <$> parseFrom ["values"] parseIrregGrid v+               <*> parseFrom ["dominos"] parseIrregGrid v)++angleLoop :: ParsePuzzle (Grid N (Clue Int)) VertexLoop+angleLoop = (parseClueGrid, parseCoordLoop)++shikaku :: ParsePuzzle (Grid C (Maybe Int)) AreaGrid+shikaku = (parseExtClueGrid, parseGrid)++slovaksums :: ParsePuzzle (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int))+slovaksums = (p, parseClueGrid)+  where+    p v@(Object o) = (,) <$> g v <*> o .: "digits"+    p _ = empty+    g = (fmap (fmap unPSlovakClue) . unRG <$>) . parseJSON++anglers :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Fish)) [Edge C]+anglers = ( parseOutsideGridMap blankToMaybe blankToMaybe'+          , parseEdgesFull )++cave :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) cave = (parseClueGrid, parseShadedGrid)++parseOut :: FromJSON a =>+            Value -> Parser (OutsideClues k (Maybe a))+parseOut v = fmap (blankToMaybe' . unEither') <$> parseOutside v++skyscrapers :: ParsePuzzle (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+skyscrapers = (,)+    (\v -> (,) <$> parseOut v+               <*> parseFrom ["digits"] parseJSON v)+    parseClueGrid++skyscrapersStars :: ParsePuzzle (OutsideClues C (Maybe Int), Int)+                                (Grid C (Either Int Star))+skyscrapersStars = (p, parseGrid)+  where+    p v@(Object o) = (,) <$> parseOut v <*> o .: "stars"+    p _            = empty++summon :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+summon = ( \v@(Object o) -> (,,) <$> parseFrom ["grid"] parseGrid v+                                 <*> parseFrom ["outside"] parseOut v+                                 <*> o .: "digits"+         , parseClueGrid+         )++baca :: ParsePuzzle+            (Grid C (Maybe Char), OutsideClues C [Int], OutsideClues C (Maybe Char))+            (Grid C (Either Black Char))+baca = ( \v -> (,,) <$> parseFrom ["grid"] parseClueGrid v+                    <*> parseFrom ["outside"] parseTopLeft v+                    <*> parseFrom ["outside"] parseBottomRight v+       , parseGrid+       )+  where+    parseTopLeft (Object v) = do+        l <- reverse <$> v .: "left"+        t <- v .: "top"+        return $ OC (map reverse l) [] [] (map reverse t)+    parseTopLeft _ = empty+    parseBottomRight (Object v) = do+        b <- v .: "bottom"+        r <- reverse <$> v .: "right"+        oc <- OC [] <$> parseLine r <*> parseLine b <*> pure []+        return $ fmap blankToMaybe' oc+    parseBottomRight _ = empty++buchstabensalat :: ParsePuzzle (OutsideClues C (Maybe Char), String)+                               (Grid C (Maybe Char))+buchstabensalat =+    ( p+    , fmap (fmap blankToMaybe') . parseGrid+    )+  where+    p v = (,)+        <$> (fmap blankToMaybe <$> parseCharOutside v)+        <*> parseFrom ["letters"] parseJSON v++doppelblock :: ParsePuzzle (OutsideClues C (Maybe Int))+                           (Grid C (Either Black Int))+doppelblock =+    ( \v -> fmap (blankToMaybe' . unEither') <$> parseOutside v+    , parseGrid+    )++sudokuDoppelblock :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int))+                                 (Grid C (Either Black Int))+sudokuDoppelblock =+    ( \v -> (,) <$> parseFrom ["grid"] parseGrid v+                <*> parseFrom ["outside"] parseOutInts v+    , parseGrid+    )+  where+    parseOutInts v = fmap (blankToMaybe' . unEither') <$> parseOutside v++dominos :: ParsePuzzle (Grid C (Maybe Int), DigitRange) AreaGrid+dominos = (p, parseGrid)+  where+    p v = (,) <$> parseFrom ["grid"] parseClueGrid v+              <*> parseFrom ["digits"] parseStringJSON v++dominoPills :: ParsePuzzle (Grid C (Maybe Int), DigitRange, DigitRange)+                           AreaGrid+dominoPills = (p, parseGrid)+  where+    p v = (,,) <$> parseFrom ["grid"] parseClueGrid v+               <*> parseFrom ["digits"] parseStringJSON v+               <*> parseFrom ["pills"] parseStringJSON v++numberlink :: ParsePuzzle (Grid C (Maybe Int)) [Edge C]+numberlink = (p, fmap collectLines . p)+  where+    p = fmap (fmap (blankToMaybe . unEither')) . parseExtGrid++loopki :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop N)+loopki = (parseClueGrid, parseEdges)++scrabble :: ParsePuzzle (Grid C Bool, [String]) (Grid C (Maybe Char))+scrabble = (p, parseClueGrid)+  where+    p v = (,) <$> parseFrom ["grid"] parseStarGrid v+              <*> parseFrom ["words"] parseJSON v+    parseStarGrid v = fmap ((==) '*') <$> parseGrid v++neighbors :: ParsePuzzle (Grid C Bool, Grid C (Maybe Int)) (Grid C Int)+neighbors = (p, parseGrid)+  where+    p v = (,) <$> parseFrom ["shading"] parseShadedGrid v+              <*> parseFrom ["clues"] parseGrid v++starwars :: ParsePuzzle (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star))+starwars = (p, parseClueGrid)+  where+    p v = (,) <$> parseFrom ["grid"] parseGrid v+              <*> (map unPML <$> parseFrom ["lines"] parseJSON v)++starbattle :: ParsePuzzle (AreaGrid, Int) (Grid C (Maybe Star))+starbattle = (p, parseClueGrid)+  where+    p v@(Object o) = (,) <$> parseFrom ["grid"] parseGrid v+                         <*> o .: "stars"+    p _            = empty++heyawake :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Bool)+heyawake = (p, parseShadedGrid)+  where+    p v = (,) <$> parseFrom ["rooms"] parseGrid v+              <*> parseFrom ["clues"] parseClueGrid v++wormhole :: ParsePuzzle (Grid C (Maybe (Either Int Char))) ()+wormhole = (,) p (const $ return ())+  where+    p v = fmap (fmap unEither') <$> parseExtClueGrid v++pentominous :: ParsePuzzle (Grid C (Maybe Char)) (Grid C Char)+pentominous = (,) parseClueGrid parseGrid++colorakari :: ParsePuzzle (Grid C (Maybe Char)) (Grid C (Maybe Char))+colorakari = (,) parseClueGrid parseClueGrid++persistenceOfMemory :: ParsePuzzle (AreaGrid, Grid C (Maybe MEnd)) (Loop C)+persistenceOfMemory = (p, parseEdgesFull)+  where+    p v = do g <- parseGrid v+             return (areas g, ends_ g)+    areas = fmap (\c -> case c of 'o' -> '.'+                                  _   -> c)+    ends_ = fmap (\c -> case c of 'o' -> Just MEnd+                                  _   -> Nothing)++abctje :: ParsePuzzle (DigitRange, [(String, Int)]) [(Int, Char)]+abctje = (,)+    (\v -> (,) <$> parseFrom ["numbers"] parseStringJSON v+               <*> parseFrom ["clues"] pl v)+    (\v -> pl v >>= sequence . map x)+  where+    pl :: FromJSON b => Value -> Parser [(String, b)]+    pl v = parseJSON v >>= sequence . map pair++    x :: FromString a => (String, b) -> Parser (a, b)+    x (k, v) = (\k' -> (k',v)) <$> parseString k++    pair :: M.Map a b -> Parser (a, b)+    pair m = if M.size m == 1 then (return . head . M.toList $ m) else empty++kropki :: ParsePuzzle (M.Map (Edge N) KropkiDot) (Grid C Int)+kropki = (,) parseAnnotatedEdges parseGrid++statuepark :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Grid C Bool)+statuepark = (\v -> parseFrom ["grid"] parseClueGrid v, parseShadedGrid)++pentominousBorders :: ParsePuzzle (Grid C (), [Edge N]) (Grid C Char)+pentominousBorders = (,) parseCellEdges parseGrid++nanroSignpost :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Int)+nanroSignpost = (,)+    (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] parseGrid v)+    parseGrid++tomTom :: ParsePuzzle (AreaGrid, Grid C (Maybe String)) (Grid C Int)+tomTom = (,)+    (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] ((unRG <$>) . parseJSON) v)+    parseGrid++horseSnake :: ParsePuzzle (Grid C (Maybe (Either MEnd Int))) [Edge C]+horseSnake = (parseGrid, parseEdgesFull)++illumination :: ParsePuzzle (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N])+illumination = (,)+    (fmap (fmap (fmap unPFraction)) . parseOut)+    parseNodeEdges++newtype Myo = Myo { unMyo :: Myopia }+instance FromJSON Myo where+    parseJSON v = do+        s <- parseJSON v+        fmap Myo . sequence . map parseChar $ s++pentopia :: ParsePuzzle (Grid C (Maybe Myopia)) (Grid C Bool)+pentopia = (,)+    (fmap (fmap (fmap unMyo)) . fmap unRG . parseJSON)+    parseShadedGrid++pentominoPipes :: ParsePuzzle (Grid N Char) (Grid N KropkiDot, [Edge N])+pentominoPipes = (,)+    parseGrid+    parseNodeEdges++greaterWall :: ParsePuzzle ([GreaterClue], [GreaterClue]) (Grid C Bool)+greaterWall = (,)+    (\v -> (,) <$> parseFrom ["rows"] parseGreaterClues v+               <*> parseFrom ["columns"] parseGreaterClues v)+    parseShadedGrid++galaxies :: ParsePuzzle (Grid C (), Grid N (), Grid C (), M.Map (Edge N) ()) AreaGrid+galaxies = (,)+    (\v -> do (a,b,c) <- parseEdgeGrid v+              return $ (fmap (const ()) b, f a, f b, f c))+    parseGrid+  where+    toUnit GalaxyCentre = ()+    f = fmap toUnit . M.mapMaybe id . fmap blankToMaybe''

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}  module Text.Puzzles.Util where @@ -8,14 +10,15 @@ import Control.Arrow import Control.Monad hiding (mapM) -import Data.Hashable-import Data.Maybe (catMaybes, fromMaybe)+import Data.List (sortBy, intersect)+import Data.Maybe (catMaybes, fromMaybe, isJust, fromJust)+import Data.Ord (comparing)+import Data.Either (isRight) import qualified Data.Map as Map+import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap-import Data.Traversable (traverse, sequenceA, mapM, Traversable)-import Data.Foldable (Foldable, foldMap)+import Data.Traversable (mapM) import Data.Monoid ((<>))-import Data.List (intersect)  import Data.Char (digitToInt, isAlpha, isDigit) import Text.Read (readMaybe)@@ -24,33 +27,46 @@ import Data.Yaml  import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)+import Data.Puzzles.GridShape import Data.Puzzles.Elements +import Text.Puzzles.Parsec+ type Path = [String] +impossible :: a+impossible = error "impossible"+ field :: Path -> Value -> Parser Value field = field' . map T.pack   where-    field' [] v                = pure v+    field' [] v              = pure v     field' (f:fs) (Object v) = v .: f >>= field' fs-    field' _  _                = empty+    field' (f:_)  _          = fail $ "expected field '" ++ T.unpack f ++ "'" -parseFrom :: Path -> (Value -> Parser b) -> (Value -> Parser b)+parseFrom :: Path -> (Value -> Parser b) -> Value -> Parser b parseFrom fs p v = field fs v >>= p +chars :: [Char] -> Char -> Parser Char+chars cs c = if c `elem` cs+                 then pure c+                 else (fail $ "got '" ++ [c] ++ "', expected '" ++ cs ++ "'")++char :: Char -> Char -> Parser Char+char c = chars [c]+ class FromChar a where     parseChar :: Char -> Parser a -failChar :: Char -> String -> Parser a-failChar c expect = fail $ "got '" ++ [c] ++ "', expected " ++ expect- instance FromChar Char where     parseChar = pure  class FromString a where     parseString :: String -> Parser a +parseStringJSON :: FromString a => Value -> Parser a+parseStringJSON v = parseJSON v >>= parseString+ parseLine :: FromChar a => String -> Parser [a] parseLine = mapM parseChar @@ -112,21 +128,25 @@ data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b)     deriving Show +parseBorderedRect :: (Char -> Parser a) -> (Char -> Parser b)+                  -> Value -> Parser (BorderedRect a b)+parseBorderedRect parseIn parseOut 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 <- mapM (mapM parseIn) ls'+    bparsed  <- mapM parseOut b+    return $ BorderedRect (w-2) (h-2) lsparsed bparsed+  where+    middle len = take (len - 2) . drop 1+ 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 <- mapM (mapM parseChar) ls'-        bparsed  <- mapM parseChar b-        return $ BorderedRect (w-2) (h-2) lsparsed bparsed-      where-        middle len = take (len - 2) . drop 1+    parseJSON = parseBorderedRect parseChar parseChar  newtype SpacedRect a = SpacedRect { unSpaced :: Rect a } @@ -141,19 +161,21 @@         p = mapM (mapM (parseString . T.unpack)) ls     parseJSON _          = empty +instance FromChar () where+    parseChar = fmap (const ()) . chars ['.', ' ']+ data Space = Space  instance FromChar Space where-    parseChar ' ' = pure Space-    parseChar _   = empty+    parseChar = fmap (const Space) . char ' '  data Blank = Blank data Blank' = Blank'+data Blank'' = Blank'' data Empty = Empty  instance FromChar Blank where-    parseChar '.' = pure Blank-    parseChar _   = empty+    parseChar = fmap (const Blank) . char '.'  parseCharJSON :: FromChar a => Value -> Parser a parseCharJSON v = do@@ -164,33 +186,32 @@    parseJSON = parseCharJSON  instance FromChar Blank' where-    parseChar '.' = pure Blank'-    parseChar '-' = pure Blank'-    parseChar _   = empty+    parseChar = fmap (const Blank') . chars ['.', '-']  instance FromJSON Blank' where     parseJSON (String ".") = pure Blank'     parseJSON (String "-") = pure Blank'-    parseJSON _            = empty+    parseJSON _            = fail "expected '.-'" +instance FromChar Blank'' where+    parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|']+ instance FromChar Empty where-    parseChar ' ' = pure Empty-    parseChar _   = empty+    parseChar = fmap (const Empty) . char ' '  instance FromString Blank where     parseString "." = pure Blank-    parseString _   = empty--data PlainNode = PlainNode+    parseString _   = fail "expected '.'"  instance FromChar PlainNode where-    parseChar 'o' = pure PlainNode-    parseChar _   = empty+    parseChar = fmap (const PlainNode) . char 'o'  instance FromChar MasyuPearl where-    parseChar '*' = pure MBlack-    parseChar 'o' = pure MWhite-    parseChar c   = failChar c "'*' or 'o'"+    parseChar = fmap f . chars ['*', 'o']+      where+        f '*' = MBlack+        f 'o' = MWhite+        f _   = impossible  instance FromChar SlalomDiag where     parseChar '/'  = pure SlalomForward@@ -198,10 +219,20 @@     parseChar _    = empty  instance FromChar Black where-    parseChar 'X' = pure Black-    parseChar 'x' = pure Black-    parseChar _   = empty+    parseChar = fmap (const Black) . chars "xX" +instance FromChar Fish where+    parseChar = fmap (const Fish) . char '*'++instance FromChar Star where+    parseChar = fmap (const Star) . char '*'++instance FromChar MEnd where+    parseChar = fmap (const MEnd) . chars "o*"++instance FromChar GalaxyCentre where+    parseChar = fmap (const GalaxyCentre) . char 'o'+ instance (FromChar a, FromChar b) => FromChar (Either a b) where     parseChar c = Left <$> parseChar c <|> Right <$> parseChar c @@ -220,15 +251,15 @@ instance FromChar a => FromChar (Maybe a) where     parseChar = optional . parseChar -listListToMap :: [[a]] -> Map.Map (Cell Square) a+listListToMap :: [[a]] -> Grid Coord 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)+rectToCoordGrid :: Rect a -> Grid Coord a+rectToCoordGrid (Rect _ _ ls) = listListToMap ls  blankToMaybe :: Either Blank a -> Maybe a blankToMaybe = either (const Nothing) Just@@ -236,18 +267,14 @@ blankToMaybe' :: Either Blank' a -> Maybe a blankToMaybe' = either (const Nothing) Just -rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a)-rectToClueGrid = fmap blankToMaybe . rectToSGrid--rectToClueGrid' :: Rect (Either Blank' a) -> SGrid (Clue a)-rectToClueGrid' = fmap blankToMaybe' . rectToSGrid+blankToMaybe'' :: Either Blank'' a -> Maybe a+blankToMaybe'' = either (const Nothing) Just -rectToIrregGrid :: Rect (Either Empty a) -> SGrid a-rectToIrregGrid = fmap fromRight . filterG isRight . rectToSGrid+rectToIrregGrid :: Rect (Either Empty a) -> Grid Coord a+rectToIrregGrid = fmap fromRight . Map.filter isRight . rectToCoordGrid   where-    isRight = either (const False) (const True)     fromRight (Right r) = r-    fromRight _         = error "no way"+    fromRight _         = impossible  newtype Shaded = Shaded { unShaded :: Bool } @@ -256,70 +283,102 @@     parseChar 'X'  = pure . Shaded $ True     parseChar _    = pure . Shaded $ False -parseShadedGrid :: Value -> Parser (SGrid Bool)-parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v+parseShadedGrid :: Key k => Value -> Parser (Grid k Bool)+parseShadedGrid v = fmap unShaded <$> parseGrid v -parseGrid :: FromChar a => Value -> Parser (SGrid a)-parseGrid v = rectToSGrid <$> parseJSON v+parseCoordGrid :: (FromChar a)+               => Value -> Parser (Grid Coord a)+parseCoordGrid v = rectToCoordGrid <$> parseJSON v -parseGridWith :: (Char -> Parser a) -> Value -> Parser (SGrid a)+parseGrid :: (Key k, FromChar a)+          => Value -> Parser (Grid k a)+parseGrid v = fromCoordGrid <$> parseCoordGrid v++parseGridWith :: Key k+              => (Char -> Parser a) -> Value -> Parser (Grid k a) parseGridWith pChar v = traverse pChar =<< parseGrid v  parseWithReplacement :: FromChar a =>     (Char -> Maybe a) -> Char -> Parser a parseWithReplacement replace c = maybe (parseChar c) pure (replace c) +parseSpacedGrid :: (Key k, FromString a)+                => Value -> Parser (Grid k a)+parseSpacedGrid v = fromCoordGrid . rectToCoordGrid . unSpaced <$> parseJSON v+ parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) parseCharMap v = do     m <- parseJSON v     guard . all (\k -> length k == 1) . Map.keys $ m     return $ Map.mapKeys head m -parseExtGrid :: (FromChar a, FromJSON a) => Value -> Parser (SGrid a)-parseExtGrid v@(String _) = parseGrid v-parseExtGrid v = do-    repl <- parseFrom ["replace"] parseCharMap v+parseExtGrid' :: (Key k, FromJSON a, FromChar b)+              => (a -> b) -> Value -> Parser (Grid k b)+parseExtGrid' _ v@(String _) = parseGrid v+parseExtGrid' f v = do+    repl <- fmap f <$> parseFrom ["replace"] parseCharMap v     parseFrom ["grid"] (parseGridWith                         (parseWithReplacement (`Map.lookup` repl))) v -parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a))-parseClueGrid v = rectToClueGrid <$> parseJSON v+parseExtGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k a)+parseExtGrid = parseExtGrid' id -parseClueGrid' :: FromChar a => Value -> Parser (SGrid (Clue a))-parseClueGrid' v = rectToClueGrid' <$> parseJSON v+parseExtClueGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k (Maybe a))+parseExtClueGrid v = fmap blankToMaybe <$> parseExtGrid' Right v -parseIrregGrid :: FromChar a => Value -> Parser (SGrid a)-parseIrregGrid v = rectToIrregGrid <$> parseJSON v+fromCoordGrid :: Key k => Grid Coord a -> Grid k a+fromCoordGrid = Map.mapKeys fromCoord -parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a))-parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v+fromCoordEdge :: Key k => Edge Coord -> Edge k+fromCoordEdge (E c d) = E (fromCoord c) d +fromCoordEdges :: Key k => [Edge Coord] -> [Edge k]+fromCoordEdges = map fromCoordEdge++parseClueGrid :: (FromChar a, Key k)+              => Value -> Parser (Grid k (Maybe a))+parseClueGrid v = fmap blankToMaybe <$> parseGrid v++parseClueGrid' :: (FromChar a, Key k) => Value -> Parser (Grid k (Maybe a))+parseClueGrid' v = fmap blankToMaybe' <$> parseGrid v++parseSpacedClueGrid :: (Key k, FromString a) => Value -> Parser (Grid k (Maybe a))+parseSpacedClueGrid v = fmap blankToMaybe <$> parseSpacedGrid v++parseIrregGrid :: (Key k, FromChar a) => Value -> Parser (Grid k a)+parseIrregGrid v = fromCoordGrid . rectToIrregGrid <$> parseJSON v+ -- parses a string like --  o-o-o --  |   | --  o-o o --    | | --    o-o-parsePlainEdges :: Value -> Parser [Edge]-parsePlainEdges v = readEdges <$> parseGrid v+parsePlainEdges :: Key k => Value -> Parser [Edge k]+parsePlainEdges v = filterPlainEdges <$> parseAnnotatedEdges 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)-                               ]+filterPlainEdges :: Map.Map (Edge k) Char -> [Edge k]+filterPlainEdges = Map.keys . Map.filterWithKey p+  where+    p (E _ Horiz) '-' = True+    p (E _ Vert)  '|' = True+    p _           _   = False -parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a)+parseAnnotatedEdges :: (Key k, FromChar a) => Value -> Parser (Map.Map (Edge k) a)+parseAnnotatedEdges v = do+    g <- readEdges <$> parseCoordGrid v+    Map.mapKeys fromCoordEdge <$> traverse parseChar g++readEdges :: Grid Coord Char -> Map.Map (Edge Coord) Char+readEdges = Map.mapKeysMonotonic fromJust . Map.filterWithKey (const . isJust) . Map.mapKeys toEdge+  where+    toEdge c@(x, y) = case (x `mod` 2, y `mod` 2) of+                        (1, 0) -> Just $ E (div2 c) Horiz+                        (0, 1) -> Just $ E (div2 c) Vert+                        _      -> Nothing+    div2 (x', y') = (x' `div` 2, y' `div` 2)++parseGridChars :: FromChar a => Grid k Char -> Parser (Grid k a) parseGridChars = traverse parseChar  -- | Parse a grid with edges and values at nodes and in cells.@@ -327,33 +386,31 @@ -- E.g. o-*-*-o --      |1|2 3 --      *-o--- to a grid of masyu pearls, a grid of integers, and some edges.-parseEdgeGrid :: (FromChar a, FromChar b) =>-                 Value -> Parser (SGrid a, SGrid b, [Edge])+-- to a grid of masyu pearls, a grid of integers, and some annotated edges.+parseEdgeGrid :: (FromChar a, FromChar b, FromChar c) =>+                 Value -> Parser (Grid N a, Grid C b, Map.Map (Edge N) c) parseEdgeGrid v = uncurry (,,) <$>                   parseBoth <*>-                  parsePlainEdges v+                  parseAnnotatedEdges v   where     parseBoth = do-        g <- parseGrid v-        (gn, gc) <- halveGrid g+        g <- parseCoordGrid v+        let (gn, gc) = halveGrid g         gn' <- parseGridChars gn         gc' <- parseGridChars gc         return (gn', gc')     both f (x, y) = (f x, f y)-    halveGrid (Grid (Square w h) m)-        | odd w && odd h = pure (Grid snode (divkeys mnode),-                                 Grid scell (divkeys mcell))-        | otherwise      = fail "non-odd grid size"+    halveGrid m =+        (fromCoordGrid . divkeys $ mnode, fromCoordGrid . divkeys $ mcell)       where-        w' = (w + 1) `div` 2-        h' = (h + 1) `div` 2-        snode = Square w' h'-        scell = Square (w' - 1) (h' - 1)         mnode = Map.filterWithKey (const . uncurry (&&) . both even) m         mcell = Map.filterWithKey (const . uncurry (&&) . both odd)  m         divkeys = Map.mapKeys (both (`div` 2)) +parsePlainEdgeGrid :: (FromChar a, FromChar b) =>+                 Value -> Parser (Grid N a, Grid C b, [Edge N])+parsePlainEdgeGrid v = (\(a,b,c) -> (a, b, filterPlainEdges c)) <$> parseEdgeGrid v+ -- | Parse a grid of edges with values at the nodes. -- -- E.g. o-*-*-o@@ -361,26 +418,28 @@ --      *-o -- to a grid of masyu pearls and some edges. parseNodeEdges :: FromChar a =>-                  Value -> Parser (SGrid a, [Edge])-parseNodeEdges v = proj13 <$> parseEdgeGrid v+                  Value -> Parser (Grid N a, [Edge N])+parseNodeEdges v = proj13 <$> parsePlainEdgeGrid v   where-    proj13 :: (SGrid a, SGrid Empty, [Edge]) -> (SGrid a, [Edge])+    proj13 :: (Grid N a, Grid C Char, [Edge N])+              -> (Grid N a, [Edge N])     proj13 (x,_,z) = (x,z)  parseCellEdges :: FromChar a =>-                  Value -> Parser (SGrid a, [Edge])-parseCellEdges v = proj23 <$> parseEdgeGrid v+                  Value -> Parser (Grid C a, [Edge N])+parseCellEdges v = proj23 <$> parsePlainEdgeGrid v   where-    proj23 :: (SGrid PlainNode, SGrid a, [Edge]) -> (SGrid a, [Edge])+    proj23 :: (Grid N Char, Grid C a, [Edge N])+              -> (Grid C a, [Edge N])     proj23 (_,y,z) = (y,z)  data HalfDirs = HalfDirs {unHalfDirs :: [Dir]}  instance FromChar HalfDirs where-    parseChar c | c `elem` "└┴├┼" = pure . HalfDirs $ [V, H]-                | c `elem` "│┘┤"  = pure . HalfDirs $ [V]-                | c `elem` "─┌┬"  = pure . HalfDirs $ [H]-                | otherwise       = pure . HalfDirs $ []+    parseChar c | c `elem` ("└┴├┼" :: String) = pure . HalfDirs $ [Vert, Horiz]+                | c `elem` ("│┘┤"  :: String) = pure . HalfDirs $ [Vert]+                | c `elem` ("─┌┬"  :: String) = pure . HalfDirs $ [Horiz]+                | otherwise                   = pure . HalfDirs $ []  -- parses a string like --  ┌┐┌─┐@@ -388,55 +447,103 @@ --  │└─┘│ --  └──┐│ --     └┘-parseEdges :: Value -> Parser [Edge]+parseEdges :: Key k => Value -> Parser [Edge k] parseEdges v = do-    Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v+    m <- fmap unHalfDirs <$> parseGrid v     return [ E p d | (p, ds) <- Map.toList m, d <- ds ] +instance FromChar Dir' where+    parseChar 'u' = pure U+    parseChar 'd' = pure D+    parseChar 'r' = pure R+    parseChar 'l' = pure L+    parseChar _   = fail "expected 'udrl'"++newtype Dirs' = Dirs' { unDirs' :: [Dir'] }++instance FromChar Dirs' where+    parseChar '└' = pure . Dirs' $ [U, R]+    parseChar '│' = pure . Dirs' $ [U, D]+    parseChar '┘' = pure . Dirs' $ [L, U]+    parseChar '─' = pure . Dirs' $ [L, R]+    parseChar '┌' = pure . Dirs' $ [D, R]+    parseChar '┐' = pure . Dirs' $ [L, D]+    parseChar '╶' = pure . Dirs' $ [R]+    parseChar '╴' = pure . Dirs' $ [L]+    parseChar '╷' = pure . Dirs' $ [D]+    parseChar '╵' = pure . Dirs' $ [U]+    parseChar _   = pure . Dirs' $ []++parseEdgesFull :: Key k => Value -> Parser [Edge k]+parseEdgesFull v = do+    m <- parseGrid v+    return . Set.toList . Set.fromList . map unorient+        $ [ E' p d | (p, Dirs' 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)+parseThermos :: Grid C Alpha -> Parser [Thermometer]+parseThermos m = catMaybes <$> mapM parseThermo (Map.keys m')   where     m' = fmap unAlpha m-    parseThermo :: Cell Square -> Parser (Maybe Thermometer)+    parseThermo :: C -> 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' :: C -> 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'' :: C -> Parser Thermometer     parseThermo'' p = do         q <- next p         maybe (pure [p]) (fmap (p:) . parseThermo'') q-    next :: Cell Square -> Parser (Maybe (Cell Square))+    next :: C -> Parser (Maybe C)     next p = case succs p of         []   -> pure Nothing         [q]  -> pure (Just q)         _    -> fail "multiple successors"-    succs      p = filter    (test ((==) . succ) p) . vertexNeighbours s $ p-    isStart    p = not . any (test ((==) . pred) p) . vertexNeighbours s $ p+    succs      p = filter    (test ((==) . succ) p) . vertexNeighbours $ p+    isStart    p = not . any (test ((==) . pred) p) . vertexNeighbours $ p     test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m')-    isAlmostIsolated p = all disjointSucc . vertexNeighbours s $ p+    isAlmostIsolated p = all disjointSucc . vertexNeighbours $ 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)+parseThermoGrid :: ThermoRect -> Parser (Grid C (Maybe Int), [Thermometer])+parseThermoGrid (Rect _ _ ls) = (,) ints+                              <$> parseThermos alphas   where-    s = Square w h-    (ints, alphas) = partitionEithers . snd . partitionEithers $-                     listListToMap ls+    m = fromCoordGrid $ listListToMap ls+    ints = either (const Nothing) (either Just (const Nothing)) <$> m+    alphas = fmap fromRight . Map.filter isRight+           . fmap fromRight . Map.filter isRight $ m+    fromRight (Left _) = impossible+    fromRight (Right x) = x +parseOutsideGrid :: Key k =>+                    (Char -> Parser a)+                 -> (Char -> Parser b)+                 -> Value -> Parser (OutsideClues k b, Grid k a)+parseOutsideGrid parseIn parseOut v = do+    BorderedRect w h ls b <- parseBorderedRect parseIn parseOut v+    return (outside b, fromCoordGrid . rectToCoordGrid $ Rect w h ls)+  where outside (Border l r b t) = OC l r b t++parseOutsideGridMap :: (Key k, FromChar a, FromChar b)+                    => (a -> c) -> (b -> d)+                    -> Value -> Parser (OutsideClues k d, Grid k c)+parseOutsideGridMap mapIn mapOut v = do+    (o, g) <- parseOutsideGrid parseChar parseChar v+    return (mapOut <$> o, mapIn <$> g)+ newtype Tight = Tight { unTight :: Tightfit () }  instance FromChar Tight where@@ -445,14 +552,12 @@     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+parseTightOutside :: Value -> Parser (OutsideClues C (Maybe Int),+                                      Grid C (Tightfit ()))+parseTightOutside = parseOutsideGridMap unTight unBlank'+  where+    unBlank' :: Either Blank' Int -> Maybe Int+    unBlank' = either (const Nothing) Just  instance FromChar a => FromString (Tightfit a) where     parseString [c]           = Single <$> parseChar c@@ -460,9 +565,6 @@     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]@@ -471,15 +573,28 @@   where     ws = words s +parseDoublePair :: FromString a => Value -> Parser ((a, a), (a, a))+parseDoublePair v = (,) <$>+                     ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*>+                     ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x))+    where x = parseJSON v >>= parseNWords 4 >>= mapM parseString+ instance FromJSON PMarkedWord where-    parseJSON v = PMW <$> (MW <$>-                  ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*>-                  ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)))-        where x = parseJSON v >>= parseNWords 4 >>= mapM parseString+    parseJSON v = PMW . uncurry MW <$> parseDoublePair v  instance FromString Int where     parseString s = maybe empty pure $ readMaybe s +parseMarkedLine :: FromCoord a => Value -> Parser (MarkedLine a)+parseMarkedLine v = do+    (s, e) <- parseDoublePair v+    return $ MarkedLine (fromCoord s) (fromCoord e)++newtype PMarkedLine a = PML {unPML :: MarkedLine a}++instance FromCoord a => FromJSON (PMarkedLine a) where+    parseJSON v = PML <$> parseMarkedLine v+ newtype PCompassC = PCC {unPCC :: CompassC}  instance FromJSON PCompassC where@@ -490,49 +605,62 @@               comp _            = empty     parseJSON _          = empty -newtype RefGrid a = RefGrid { unRG :: SGrid a }+newtype PSlovakClue = PSlovakClue {unPSlovakClue :: SlovakClue} -data Ref = Ref { unRef :: Char }-    deriving Show+instance FromJSON PSlovakClue where+    parseJSON (String t) = svk . map T.unpack . T.words $ t+      where+        svk [s, c] = PSlovakClue <$> (SlovakClue <$> parseString s <*> parseString c)+        svk _      = fail "expect two integers"+    parseJSON _ = fail "expect string of two integers" -instance FromChar Ref where-    parseChar c | isAlpha c = pure (Ref c)-    parseChar _             = empty+newtype RefGrid k a = RefGrid { unRG :: Grid k (Maybe a) } -hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b+hashmaptomap :: 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 :: Ord b => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) compose m1 m2 = mapM (`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+newtype MaybeMap k a = MM { unMaybeMap :: Map.Map k (Maybe a) }++instance Functor (MaybeMap k) where+    fmap f (MM m) = MM (fmap (fmap f) m)++instance Foldable (MaybeMap k) where+    foldMap f (MM m) = foldMap (foldMap f) m++instance Traversable (MaybeMap k) where+    traverse f m = MM <$> traverse (traverse f) (unMaybeMap m)++compose' :: Ord b => Map.Map a (Maybe b)+                  -> Map.Map b c+                  -> Maybe (Map.Map a (Maybe c))+compose' m1 m2 = unMaybeMap <$> mapM (`Map.lookup` m2) (MM m1)++instance (Key k, FromJSON a) => FromJSON (RefGrid k a) where+    parseJSON v = RefGrid <$> do+        refs <- fmap (fmap ((:[]) . unAlpha) . blankToMaybe)+                <$> parseFrom ["grid"] parseGrid v+        m <- hashmaptomap <$> parseFrom ["clues"] parseJSON v+        case compose' refs m of             Nothing -> mzero-            Just m' -> return $ Grid s m'-    parseJSON _ = empty+            Just m' -> return m' -parseAfternoonGrid :: Value -> Parser (SGrid Shade)+parseAfternoonGrid :: Value -> Parser (Grid C 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+    (_, _, es) <- parsePlainEdgeGrid v+                  :: Parser (Grid N Char, Grid C Char, [Edge N])+    return . toMap $ es   where-    shrink (Square w h) = Square (w-1) (h-1)-    toShade V = Shade False True-    toShade H = Shade True  False+    toShade Vert  = Shade False True+    toShade Horiz = 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)+        [(fromCoord . toCoord $ p, toShade d) | E p d <- es]  newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue } @@ -541,10 +669,10 @@                      guard $ length xs > 0 && length xs <= 4                      return . ParseTapaClue . TapaClue $ xs -reorientOutside :: OutsideClues a -> OutsideClues a+reorientOutside :: OutsideClues k a -> OutsideClues k a reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t -parseCharOutside :: FromChar a => Value -> Parser (OutsideClues a)+parseCharOutside :: FromChar a => Value -> Parser (OutsideClues k a) parseCharOutside (Object v) = reorientOutside <$>                               (OC <$>                                pfield "left" <*> pfield "right" <*>@@ -553,7 +681,7 @@     pfield f = parseLine . fromMaybe [] =<< v .:? f parseCharOutside _          = empty -parseOutside :: FromJSON a => Value -> Parser (OutsideClues a)+parseOutside :: FromJSON a => Value -> Parser (OutsideClues k a) parseOutside (Object v) = reorientOutside <$>                               (OC <$>                                pfield "left" <*> pfield "right" <*>@@ -562,7 +690,7 @@     pfield f = pure . fromMaybe [] =<< v .:? f parseOutside _          = empty -parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a])+parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues k [a]) parseMultiOutsideClues (Object v) = rev <$> raw   where     raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top"@@ -578,6 +706,55 @@     parseChar 'X'  = pure $ PrimeDiag (True,  True)     parseChar _    = empty +parseCoordLoop :: Value -> Parser VertexLoop+parseCoordLoop v = sortCoords <$> parseClueGrid v+  where+    sortCoords :: Grid N (Maybe Char) -> VertexLoop+    sortCoords = map fst . sortBy (comparing snd) . Map.toList . clues++instance FromString DigitRange where+    parseString s = do+        let (a, b) = break (== '-') s+        b' <- case b of ('-':cs) -> pure cs+                        _        -> fail "exected '-' in range"+        DigitRange <$> parseString a <*> parseString b'++newtype PFraction = PFraction { unPFraction :: Fraction }++instance FromJSON PFraction where+    parseJSON v = PFraction <$> toStringParser fraction v+ instance FromChar Crossing where     parseChar '+' = pure Crossing     parseChar _   = fail "expected '+'"++instance FromChar KropkiDot where+    parseChar '*' = pure KBlack+    parseChar 'o' = pure KWhite+    parseChar ' ' = pure KNone+    parseChar '.' = pure KNone+    parseChar _   = fail "expected '*o '"++instance FromChar Relation where+    parseChar '<' = pure RLess+    parseChar '>' = pure RGreater+    parseChar '=' = pure REqual+    parseChar ' ' = pure RUndetermined+    parseChar _   = fail "expected '<>= '"++parseGreaterClues :: Value -> Parser [GreaterClue]+parseGreaterClues v = do+    Rect _ _ ls <- parseJSON v+    mapM parseGreaterClue ls++parseGreaterClue :: [Char] -> Parser GreaterClue+parseGreaterClue [] = pure []+parseGreaterClue xs = p RUndetermined xs+  where+    p rel ('.':cs) = (rel:) <$> q cs+    p _   (' ':_)  = pure [] -- Rect fills the lines up with spaces...+    p _   _        = fail "expected '.'"+    q [] = pure []+    q (r:cs) = do+        rel <- parseChar r+        p rel cs

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts #-}++module Main where++import Text.Puzzles.Puzzle+import Data.Puzzles.PuzzleTypes (typeNames, PuzzleType(..))+import Data.Puzzles.CmdLine (exitErr, readPuzzle, checkType)++import Data.Puzzles.Elements (digitList)+import qualified Text.Puzzles.PuzzleTypes as T++import Options.Applicative+import Control.Monad+import Data.Maybe+import Data.List (intercalate, sort)++import System.Exit+import System.Environment (getProgName)++import qualified Data.Yaml as Y++optListTypes :: Parser (a -> a)+optListTypes =+    infoOption+        (unlines' . sort . map snd $ typeNames)+        (long "list-types"+         <> help "List supported puzzle types")+  where+    unlines' = intercalate "\n"++data PuzzleOpts = PuzzleOpts+    { _type     :: Maybe String+    , _input    :: FilePath+    }++puzzleOpts :: Parser PuzzleOpts+puzzleOpts = PuzzleOpts+    <$> (optional . strOption $+            (long "type" <> short 't'+             <> metavar "TYPE"+             <> help "Puzzle type, overriding type in input file"))+    <*> argument str+            (metavar "INPUT"+             <> help "Puzzle file in .pzl format")++defaultOpts :: Parser a -> IO a+defaultOpts optsParser = do+    prog <- getProgName+    let p = info (helper <*> optListTypes <*> optsParser)+                (fullDesc+                 <> progDesc "Command-line puzzle checking."+                 <> header prog)+    execParser p++main :: IO ()+main = do+    opts <- defaultOpts puzzleOpts+    mp <- readPuzzle (_input opts)+    TP mt pv msv _ <- case mp of Left  e -> exitErr $+                                             "parse failure: " ++ show e+                                 Right p -> return p+    t <- checkType $ _type opts `mplus` mt+    sv <- maybe (exitErr $ "need solution") return msv +    let es = Y.parseEither (check t) (pv, sv)+    case es of Left err  -> exitErr $ "parse failure: " ++ err+               Right []  -> exitSuccess+               Right es' -> mapM_ putStrLn es' >> exitFailure++check :: PuzzleType -> (Y.Value, Y.Value) -> Y.Parser [String]+check t (pv, sv) =+    case t of+        ABCtje -> checkABCtje (pv, sv)+        _      -> return []++checkABCtje :: (Y.Value, Y.Value) -> Y.Parser [String]+checkABCtje (pv, sv) = do+    p <- fst T.abctje $ pv+    s <- snd T.abctje $ sv+    return . catMaybes . map (\c -> c p s) $+        [ solutionKeys, values ]+  where+    solutionKeys (ds, _) s = let have = sort (digitList ds)+                                 want = sort (map fst (s))+                             in if have /= want then Just "unequal digit lists" else Nothing+    values (_, ws) vs = (\es -> case es of [] -> Nothing+                                           _  -> Just $ intercalate ", " es)+                      . catMaybes+                      . map (\(w, v) -> if val w == v+                                            then Nothing+                                            else Just (w ++ " should be " ++ show (val w)))+                      $ ws+      where+        l c = fromMaybe 0 . lookup c . map (\(x, y) -> (y, x)) $ vs+        val = sum . map l

@@ -4,12 +4,15 @@  import Diagrams.Prelude hiding (value, option, (<>), Result) +import Data.Puzzles.CmdLine import Diagrams.Puzzles.CmdLine  import Text.Puzzles.Puzzle+import Text.Puzzles.Code import Data.Puzzles.Compose import Data.Puzzles.PuzzleTypes (typeNames) import Diagrams.Puzzles.Draw+import Diagrams.Puzzles.Code  import Options.Applicative import Control.Monad@@ -36,6 +39,7 @@     , _puzzle   :: Bool     , _solution :: Bool     , _example  :: Bool+    , _code     :: Bool     , _input    :: FilePath     } @@ -59,6 +63,9 @@     <*> switch             (long "example" <> short 'e'              <> help "Render example (to base.ext)")+    <*> switch+            (long "code" <> short 'c'+             <> help "Add solution code markers")     <*> argument str             (metavar "INPUT"              <> help "Puzzle file in .pzl format")@@ -83,7 +90,7 @@     base = takeBaseName (_input opts)     out = addExtension (base ++ outputSuffix oc) f -renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B R2)) ->+renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B)) ->                 (OutputChoice, Bool) -> IO () renderPuzzle opts r (oc, req) = do     let x = r oc@@ -129,17 +136,29 @@     hasSol DrawExample  = True     hasSol DrawPuzzle   = False +maybeSkipCode :: PuzzleOpts -> Maybe Y.Value -> Maybe Y.Value+maybeSkipCode opts = if _code opts then id else const Nothing++parseAndDrawCode :: Y.Value -> IO (CodeDiagrams (Diagram B))+parseAndDrawCode v = case parsed of+    Left  e -> exitErr $ "solution code parse failure: " ++ e+    Right c -> return $ drawCode c+  where+    parsed = Y.parseEither parseCode v+ main :: IO () main = do     opts <- defaultOpts puzzleOpts     ocs <- checkOutput opts     checkFormat (_format opts)     mp <- readPuzzle (_input opts)-    TP mt pv msv <- case mp of Left  e -> exitErr $-                                          "parse failure: " ++ show e-                               Right p -> return p+    TP mt pv msv mc <- case mp of Left  e -> exitErr $+                                             "parse failure: " ++ show e+                                  Right p -> return p     let msv' = maybeSkipSolution ocs msv+        mc'  = maybeSkipCode opts mc     t <- checkType $ _type opts `mplus` mt     let ps = Y.parseEither (handle drawPuzzleMaybeSol t) (pv, msv')-    case ps of Right ps' -> mapM_ (renderPuzzle opts (draw ps')) ocs+    mcode <- sequenceA $ parseAndDrawCode <$> mc'+    case ps of Right ps' -> mapM_ (renderPuzzle opts (draw mcode ps')) ocs                Left    e -> exitErr $ "parse failure: " ++ e

@@ -0,0 +1,244 @@+module Data where++import qualified Data.Text as T+import Data.Yaml+import Data.Maybe (fromJust)+import qualified Data.ByteString as B+import Data.Text.Encoding (encodeUtf8)++packStr :: String -> B.ByteString+packStr = encodeUtf8 . T.pack++decodeLines :: [String] -> Value+decodeLines = fromJust . decode . packStr . 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."+    ]++thermo_2 :: Value+thermo_2 = packLines $+    [ "....2."+    , "..c5.1"+    , ".b..6."+    , "a..c.."+    , "a...b."+    , ".bc.a."+    ]++thermo_broken_1 :: Value+thermo_broken_1 = packLines $+    [ ".."+    , "a."+    ]++thermo_broken_2 :: Value+thermo_broken_2 = packLines $+    [ "bb"+    , "a."+    ]++multioutside :: Value+multioutside = decodeLines $+    [ "left:"+    , "  - [2, 1]"+    , "  - [3]"+    , "right:"+    , "  - []"+    , "  - [1, 0]"+    , "bottom:"+    , "  - [0, 0, 1]"+    , "top:"+    , "  - [-1, 1]"+    ]++boxof2or3_1 :: Value+boxof2or3_1 = packLines $+    [ "*-*-*-*-*"+    , "| | | | |"+    , "*-*-*-*-*"+    , "| | |"+    , "*-o-o-o-*"+    , "    | | |"+    , "*-*-*-*-*"+    , "| | | | |"+    , "o-*-*-*-*"+    ]++edgeGrid_1 :: Value+edgeGrid_1 = packLines $+   [ "o-*-*-o"+   , "|1|2 3"+   , "*-o"+   ]

@@ -0,0 +1,11 @@+module Data.Puzzles.GridShapeSpec where++import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Puzzles.GridShape++spec :: Spec+spec = do+    describe "edgeSize" $ do+        it "computes the size in cells" $ do+            edgeSize [E (N 1 1) Vert, E (N 2 1) Horiz] `shouldBe` (3, 2)

@@ -0,0 +1,22 @@+module Data.Puzzles.GridSpec where++import qualified Data.Set as Set+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Puzzles.Grid+import Data.Puzzles.GridShape (N(..))++spec :: Spec+spec = do+    describe "sizeGrid" $ do+        it "creates a rectangular grid of nodes" $ do+            nodes (sizeGrid (2, 3)) `shouldBe` Set.fromList [+                                          N 0 0, N 0 1, N 0 2,+                                          N 1 0, N 1 1, N 1 2]+            nodes (sizeGrid (0, 0)) `shouldBe` Set.empty+            nodes (sizeGrid (2, 0)) `shouldBe` Set.empty+            nodes (sizeGrid (2, 1)) `shouldBe ` Set.fromList [N 0 0, N 1 0]++    describe "nodeGrid" $ do+        it "creates the grid of nodes from a rectangular grid of cells" $ do+            nodes (nodeGrid (sizeGrid (2, 1))) `shouldBe` nodes (sizeGrid (3, 2))

@@ -0,0 +1,32 @@+module Diagrams.Puzzles.GridSpec where++import Diagrams.Prelude (p2)+import Diagrams.Path (pathPoints)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Data.Puzzles.Grid+import Data.Puzzles.GridShape+import Diagrams.Puzzles.Grid+import Diagrams.Puzzles.Lib (p2i)++spec :: Spec+spec = do+    describe "irregularGridPaths" $ do+        it "gives the border of a rectangular grid" $ do+            let g = sizeGrid (2, 3) :: Grid C ()+                (outer, _) = irregularGridPaths g+                pts = pathPoints outer+            length pts `shouldBe` 1+            let [opts] = pts+            opts `shouldSatisfy` elem (p2i (0, 0))+            opts `shouldSatisfy` elem (p2i (2, 0))+            opts `shouldSatisfy` elem (p2i (2, 3))+            opts `shouldSatisfy` elem (p2i (0, 3))++    describe "midPoint" $ do+        it "gives the center of a node edge" $ do+            let e = E (N 0 1) Horiz+            midPoint e `shouldBe` p2 (0.5, 1.0)+        it "gives the center of a cell edge" $ do+            let e = E (C 0 0) Vert+            midPoint e `shouldBe` p2 (0.5, 1.0)

@@ -0,0 +1,54 @@+module Text.Puzzles.PuzzleTypesSpec where++import Data.Maybe (isJust)+import qualified Data.Map as Map+import Data.Yaml+import Data.Text.Encoding (encodeUtf8)+import qualified Data.ByteString as B+import qualified Data.Text as T++import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Data.Puzzles.GridShape (edgeSize)+import Data.Puzzles.Elements (DigitRange(..))+import Text.Puzzles.PuzzleTypes++packLines :: [String] -> B.ByteString+packLines = encodeUtf8 . T.pack . unlines++parse :: (Value -> Parser a) -> B.ByteString -> Maybe a+parse p t = decode t >>= parseMaybe p++spec :: Spec+spec = do+    describe "abctje" $ do+        it "parses a list of clues" $ do+            let (p, _) = abctje+                y = packLines [ "numbers: 1-10"+                              , "clues:"+                              , "- HELLO: 15"+                              , "- WORLD: 20"+                              , "- weird stuff, too!: 100"+                              ]+            parse p y `shouldBe` Just (DigitRange 1 10, [("HELLO", 15), ("WORLD", 20), ("weird stuff, too!", 100)])+        it "parses a solution" $ do+            let (_, p) = abctje+                y = packLines [ "- 1: A"+                              , "- 100: C"+                              ]+            parse p y `shouldBe` Just [(1, 'A'), (100, 'C')]++    describe "kropki" $ do+        it "parses edges of the right size" $ do+            let (p, _) = kropki+                y = packLines [ "|"+                              , "  + + + +"+                              , "   . . . "+                              , "  +*+ + +"+                              , "   . .o. "+                              , "  + + + +"+                              ]+                res = parse p y+            res `shouldSatisfy` isJust+            let Just m = res+            edgeSize (Map.keys m) `shouldBe` (3, 2)

@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}+module Text.Puzzles.UtilSpec where++import qualified Data.Map as Map+import Data.Yaml+import qualified Data.Text as T++import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Puzzles.GridShape (Edge(..), N(..), Dir(..))+import Data.Puzzles.Elements (Relation(..))+import Text.Puzzles.Util (parseCoordGrid, parseAnnotatedEdges, parseGreaterClue)++packLines :: [String] -> Value+packLines = String . T.pack . unlines++spec :: Spec+spec = do+    describe "parseCoordGrid" $ do+        it "parses a rectangle of letters" $ do+            let y = packLines [ "abc"+                              , "def"+                              ]+                want = Map.fromList [ ((0, 0), 'd')+                                    , ((1, 0), 'e')+                                    , ((2, 0), 'f')+                                    , ((0, 1), 'a')+                                    , ((1, 1), 'b')+                                    , ((2, 1), 'c')+                                    ]+            parseMaybe parseCoordGrid y `shouldBe` Just want++    describe "parseAnnotatedEdges" $ do+        it "parses some kropki clues" $ do+            let y = packLines [ "+ + + +"+                              , " . .*.o"+                              , "+ +o+ +"+                              , " . . . "+                              , "+ + + +"+                              ]+                want = Map.fromList+                           [ (E (N 1 1) Horiz, 'o')+                           , (E (N 2 1) Vert,  '*')+                           , (E (N 3 1) Vert,  'o')+                           ]+                parseNonempty v = Map.filter ((/=) ' ') <$> parseAnnotatedEdges v+            parseMaybe parseNonempty y `shouldBe` Just want++    describe "parseGreaterClue" $ do+        it "parses an empty line" $ do+            let y = []+                want = []+            parseMaybe parseGreaterClue y `shouldBe` Just want++        it "parses a single dot" $ do+            let y = ['.']+                want = [RUndetermined]+            parseMaybe parseGreaterClue y `shouldBe` Just want++        it "parses a single dot" $ do+            let y = ['.']+                want = [RUndetermined]+            parseMaybe parseGreaterClue y `shouldBe` Just want++        it "parses a mixed line" $ do+            let y = ['.', '<', '.', ' ', '.', '=', '.']+                want = [RUndetermined, RLess, RUndetermined, REqual]+            parseMaybe parseGreaterClue y `shouldBe` Just want

@@ -0,0 +1,29 @@+module Util where++import Control.DeepSeq+import Data.Yaml++import Test.Tasty.HUnit++-- | Force full evaluation of a showable value.+justShow :: Show a => Maybe a -> Bool+justShow Nothing = False+justShow (Just x) = show x `deepseq` True++-- | Force full evaluation of a showable value.+eitherShow :: Show a => Either e a -> Bool+eitherShow (Left _) = False+eitherShow (Right x) = show x `deepseq` True++-- | Test that a value is parsed correctly, by forcing the+--   parse result to be fully evaluated.+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++-- | Test that a value is not parsed.+testNonparse :: Show a => (Value -> Parser a) -> Value -> Assertion+testNonparse p t = (not . justShow . parseMaybe p $ t)+                   @? "parsed but shouldn't"

@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}++module Main where++import Test.Tasty+import Test.Tasty.Golden++import System.Process+import System.FilePath++main :: IO ()+main = tests >>= defaultMain++render :: FilePath -> IO ()+render fp = callProcess "stack" ["exec", "drawpuzzle", "--", "-e", "-c", "-f",  "png", fp ]++testFile :: FilePath -> TestTree+testFile fp = goldenVsFile ("comparing " ++ fp)+                           fppng+                           (takeFileName fppng)+                           (render fp)+  where+    fppng = replaceExtension fp ".png"++tests :: IO TestTree+tests = testGroup "compare to old output" . map testFile+        <$> findByExtension [".pzl"] "tests/examples"

@@ -1,45 +1,62 @@ import Test.Tasty+import Test.Tasty.Hspec import Test.Tasty.HUnit  import Data.Yaml import Data.List (sort) import qualified Data.Map as Map-import Control.DeepSeq  import Text.Puzzles.Puzzle import Data.Puzzles.Elements (Thermometer, MasyuPearl(..)) import Text.Puzzles.Util-    (parseChar, parseMultiOutsideClues, parseEdgeGrid)+    (parseChar, parseMultiOutsideClues, parsePlainEdgeGrid) import Text.Puzzles.PuzzleTypes import qualified Data.Puzzles.Grid as Grid import Data.Puzzles.Pyramid (PyramidSol(..))-import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..))-import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..))+import Data.Puzzles.Grid+import Data.Puzzles.GridShape+import Data.Puzzles.Util -import Diagrams.Puzzles.PuzzleGrids-import Diagrams.Prelude-import Diagrams.Backend.SVG -import Text.Blaze.Svg.Renderer.Text (renderSvg)- import Data import Util+import qualified Data.Puzzles.GridSpec+import qualified Data.Puzzles.GridShapeSpec+import qualified Diagrams.Puzzles.GridSpec+import qualified Text.Puzzles.PuzzleTypesSpec+import qualified Text.Puzzles.UtilSpec  main :: IO ()-main = defaultMain tests+main = do+    ss <- specs+    defaultMain . testGroup "Tests" $ tests ++ ss -tests :: TestTree-tests = testGroup "Tests"-    [ parseUtilTests, parseTests, parseDataTests, renderTests, dataTests ]+specs :: IO [TestTree]+specs = mapM (uncurry testSpec)+            [ ("Data.Puzzles.Grid",        Data.Puzzles.GridSpec.spec)+            , ("Data.Puzzles.GridShape",   Data.Puzzles.GridShapeSpec.spec)+            , ("Diagrams.Puzzles.Grid",    Diagrams.Puzzles.GridSpec.spec)+            , ("Text.Puzzles.PuzzleTypes", Text.Puzzles.PuzzleTypesSpec.spec)+            , ("Text.Puzzles.Util",        Text.Puzzles.UtilSpec.spec)+            ] -testParsePzl, testParseSol, testNonparsePzl, testNonparseSol ::-    (Show a, Show b) => String -> ParsePuzzle a b -> Value -> TestTree+tests :: [TestTree]+tests = [ parseUtilTests, parseTests, parseDataTests, dataTests ]++testParsePzl ::+    Show a => String -> ParsePuzzle a b -> Value -> TestTree testParsePzl name parser yaml =     testCase ("parse " ++ name) $ testParse (fst parser) yaml+testParseSol ::+    Show b => String -> ParsePuzzle a b -> Value -> TestTree testParseSol name parser yaml =     testCase ("parse " ++ name ++ " (sol)") $ testParse (snd parser) yaml+testNonparsePzl ::+    Show a => String -> ParsePuzzle a b -> Value -> TestTree testNonparsePzl name parser yaml =     testCase ("don't parse broken " ++ name) $ testNonparse (fst parser) yaml+testNonparseSol ::+    Show b => String -> ParsePuzzle a b -> Value -> TestTree testNonparseSol name parser yaml =     testCase ("don't parse broken " ++ name ++ " (sol)") $         testNonparse (snd parser) yaml@@ -92,15 +109,15 @@ test_thermo_2 = either (const []) snd $                 parseEither (fst thermosudoku) thermo_2 -testThermo :: [Thermometer] -> [Thermometer] -> Assertion-testThermo t expect = sort t @?= expect+testThermo :: [Thermometer] -> [[Coord]] -> Assertion+testThermo t expect = sort t @?= map (map fromCoord) expect  test_tightfit_1 :: Bool test_tightfit_1 = either (const False) test_both res   where     res = parseEither (fst tightfitskyscrapers) tightfit_1     test_both (o, g) = test_size g && test_clues o-    test_size g = Grid.size g == (3, 3)+    test_size g = Grid.size (Map.mapKeys toCoord 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] &&@@ -118,19 +135,23 @@   where     res = parseEither parseMultiOutsideClues multioutside     oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]]-         :: OutsideClues [Int]+         :: OutsideClues Coord [Int] -test_edge_grid :: Assertion-test_edge_grid = Right (gn, gc, es) @=? res+test_plain_edge_grid :: Assertion+test_plain_edge_grid = Right (gn, gc, sort es) @=? res'   where-    res = parseEither parseEdgeGrid edgeGrid_1-    gn = Grid.Grid (Square 4 2) $ Map.fromList+    res = parseEither parsePlainEdgeGrid edgeGrid_1+    res' = fmap (\(x, y, e) -> (x, y, sort e)) res+    gn :: Grid.Grid N (Maybe MasyuPearl)+    gn = Map.mapKeys fromCoord . Map.fromList $         [((0,0),Just MBlack),((0,1),Just MWhite),((1,0),Just MWhite),((1,1),Just MBlack),          ((2,0),Nothing),((2,1),Just MBlack),((3,0),Nothing),((3,1),Just MWhite)]-    gc :: Grid.SGrid Int-    gc = Grid.Grid (Square 3 1) $ Map.fromList+    gc :: Grid.Grid C Int+    gc = Map.mapKeys fromCoord . Map.fromList $         [((0,0),1),((1,0),2),((2,0),3)]-    es = [E (0,0) H, E (0,1) H, E (1,1) H, E (2,1) H, E (0,0) V, E (1,0) V]+    es = map (\(E c d) -> E (fromCoord c) d)+         [E (0,0) Horiz, E (0,1) Horiz, E (1,1) Horiz, E (2,1) Horiz,+          E (0,0) Vert, E (1,0) Vert]  parseDataTests :: TestTree parseDataTests = testGroup "Parsing tests (full puzzles, result checks)"@@ -144,39 +165,70 @@                                             , [(0, 2), (1, 3), (2, 4)]                                             , [(4, 0), (4, 1), (3, 2)] ]     , testCase "parse multioutsideclues" $ test_multioutside-    , testCase "parse edge grid" $ test_edge_grid+    , testCase "parse edge grid" $ test_plain_edge_grid     ] --- this used to cause a rendering crash, though it's--- caught by parsing by now-testBreakSlalom :: Bool-testBreakSlalom =-    case parseMaybe (snd slalom) slalom_sol_broken of-        Nothing -> True-        Just s  -> let d = drawSlalomDiags s-                       svg = renderDia SVG (SVGOptions (Width 100) Nothing) d-                       svgt = renderSvg svg-                   in (show svgt) `deepseq` True--renderTests :: TestTree-renderTests = testGroup "Rendering tests"-    [ testCase "don't break rendering invalid slalom solution"-         $ testBreakSlalom @? "just testing against errors"-    ]+sorteq :: (Show a, Ord a) => [a] -> [a] -> Assertion+sorteq xs ys = sort xs @?= sort ys  testMultiOutsideClues :: Assertion-testMultiOutsideClues = multiOutsideClues (OC l r b t) `sorteq` res+testMultiOutsideClues = multiOutsideClues (OC l r b t) @=? res   where-    sorteq xs ys = sort xs @?= sort ys     l = [[1, 2], [3]]     r = [[], [1, 0]]     b = [[0, 0, 1]]     t = [[1, -1]]-    res = [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3),+    res :: Map.Map C Int+    res = Map.mapKeys fromCoord . Map.fromList $+          [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3),             ((1,1), 1), ((2,1), 0), ((0,-1), 0), ((0,-2), 0), ((0,-3), 1),-            ((0,2), 1), ((0,3), -1) ] :: [((Int, Int), Int)]+            ((0,2), 1), ((0,3), -1) ] +testEdges :: Assertion+testEdges = do+    inner `sorteq` expinner'+    outer `sorteq` expouter'+  where+    (outer, inner) = edges cs (`elem` cs)+    {-+      ###+      # #+      ###+    -}+    cs :: [C]+    cs = map fromCoord [(0,0), (1,0), (2,0), (0,1), (2,1), (0,2), (1,2), (2,2)]+    expouter = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)),+                ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)),+                ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)),+                ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))]+    expouter' = map (uncurry edge' . fromCoord2) expouter+    expinner = [((0,1),(1,1)), ((0,2),(1,2)), ((1,0),(1,1)), ((2,0),(2,1)),+                ((1,3),(1,2)), ((2,3),(2,2)), ((3,1),(2,1)), ((3,2),(2,2))]+    expinner' = map (uncurry edge . fromCoord2) expinner+    fromCoord2 (p,q) = (fromCoord p, fromCoord q)++testLoops :: Assertion+testLoops = loops es @=? Just loopsexp+  -- rotations of the loops would be fine+  -- inside and outside of:+  --   xxx+  --   x x+  --   xxx+  where+    es = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)),+          ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)),+          ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)),+          ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))]+    loopsexp :: [[(Int, Int)]]+    loopsexp =+        [ [(0,0), (0,1), (0,2), (0,3), (1,3), (2,3), (3,3), (3,2), (3,1),+           (3,0), (2,0), (1,0), (0,0)]+        , [(1,1), (2,1), (2,2), (1,2), (1,1)]+        ]+ dataTests :: TestTree dataTests = testGroup "Generic tests for the Data modules"     [ testCase "multiOutsideClues" testMultiOutsideClues+    , testCase "edges" testEdges+    , testCase "loops" testLoops     ]