packages feed

puzzle-draw 0.1.0.4 → 0.3.0.0

raw patch · 58 files changed

Files

CHANGES.md view
@@ -1,3 +1,18 @@+0.3.0.0: 20180718+-----------------++* Switch backend to diagrams-rasterific, losing the dependency on Cairo.+* Upgrade to diagrams 1.4.+* Various new puzzle types, including Minesweeper, Tents, Snake,+  Country Road, Killer Sudoku.++0.2.0.0: 20161211+-----------------++* Upgrade diagrams version.+* Add various new puzzle types.+* Add solution code markers.+ 0.1.0.4: 20141115 -----------------
README.md view
@@ -29,13 +29,19 @@   3.3..3 solution:   loop: |-    .┌──┐┌┐-    .│┌─┘││-    .│└──┘│-    ┌┘.┌─┐│-    └┐┌┘.││-    ┌┘│..││-    └─┘..└┘+    o o-o-o-o o-o+     .|. . .|.|.|+    o o o-o-o o o+     .|.|. . .|.|+    o o o-o-o-o o+     .|. . . . .|+    o-o o o-o-o o+    |. . .|. .|.|+    o-o o-o o o o+     .|.|. . .|.|+    o-o o o o o o+    |. .|. . .|.|+    o-o-o o o o-o   liars: |     ...X..     .X....@@ -45,7 +51,7 @@     ..X... ``` -There is a demo web application at [demo] that provides some more+There is a [demo web application][demo] that provides some more examples and that can be used to generate SVG images from such puzzle descriptions. @@ -56,24 +62,21 @@ ----------  This is a brief overview of how to install the command line tool.-You'll need to get a Haskell environment, by installing the-[Haskell Platform][platform]. Then install `puzzle-draw` with cabal:+The easiest way right now is to get [stack](https://www.stackage.org/),+clone this repository, and install using  ```-$ cabal install puzzle-draw+$ stack install ``` -This will compile puzzle-draw against the SVG backend, and install-a binary `drawpuzzle` that formats puzzles to SVG. Alternatively,-you can compile against the Cairo backend by passing `-fcairo`:+Alternatively, get a Haskell environment by installing the+[Haskell Platform](https://www.haskell.org/platform/).+Then install `puzzle-draw` with cabal:  ```-$ cabal install -fcairo puzzle-draw+$ cabal install puzzle-draw ``` -This will enable PDF and PNG output. Be warned that getting Cairo-installed can be tricky on non-Linux platforms.- Running ------- @@ -95,9 +98,7 @@ behaviour, e.g., choosing the output format.  [travis]: https://travis-ci.org/robx/puzzle-draw-[cmdline]: https://github.com/robx/puzzle-draw-cmdline [liarslither]: https://maybepuzzles.wordpress.com/types/liar-slither-link/ [twentyfour]: https://maybepuzzles.wordpress.com/2014/03/29/puzzle-set-24-hour-marathon/ [diagrams]: http://projects.haskell.org/diagrams/-[demo]: https://puzzle-draw-demo.herokuapp.com-[platform]: https://www.haskell.org/platform/+[demo]: https://arp.vllmrt.net/puzzles/draw/static/puzzle.html
puzzle-draw.cabal view
@@ -1,105 +1,131 @@-name:                puzzle-draw-version:             0.1.0.4-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-                     layer on top of Diagrams to help with drawing arbitrary-                     puzzles, and to support several specific puzzles types-                     In addition, it includes functionality for parsing-                     puzzle data from a YAML file format.-license:             MIT-license-file:        LICENSE-author:              Robert Vollmert-maintainer:          rfvollmert@gmail.com-category:            Graphics-build-type:          Simple-extra-source-files:  README.md, CHANGES.md-data-files:          data/fonts/*.svg-cabal-version:       >=1.8+cabal-version: >=1.8+name: puzzle-draw+version: 0.3.0.0+license: MIT+license-file: LICENSE+maintainer: rob@vllmrt.net+author: Robert Vollmert+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+    layer on top of Diagrams to help with drawing arbitrary+    puzzles, and to support several specific puzzles types+    In addition, it includes functionality for parsing+    puzzle data from a YAML file format.+category: Graphics+build-type: Simple+data-files:+    data/fonts/*.svg+extra-source-files:+    README.md+    CHANGES.md  source-repository head-  type:     git-  location: http://github.com/robx/puzzle-draw.git--flag cairo-  description: Build against Cairo backend-  default:     False+    type: git+    location: http://github.com/robx/puzzle-draw.git  library-  exposed-modules:     Data.Puzzles.Grid-                       Data.Puzzles.GridShape-                       Data.Puzzles.Elements-                       Data.Puzzles.Pyramid-                       Data.Puzzles.Sudoku-                       Data.Puzzles.Compose-                       Data.Puzzles.PuzzleTypes-                       Text.Puzzles.Util-                       Text.Puzzles.Puzzle-                       Text.Puzzles.PuzzleTypes-                       Diagrams.Puzzles.Grid-                       Diagrams.Puzzles.Lib-                       Diagrams.Puzzles.Elements-                       Diagrams.Puzzles.Widths-                       Diagrams.Puzzles.Pyramid-                       Diagrams.Puzzles.PuzzleGrids-                       Diagrams.Puzzles.PuzzleTypes-                       Diagrams.Puzzles.Draw-                       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,-                       parsec >= 3.1,-                       yaml >= 0.8.4,-                       aeson >= 0.7,-                       unordered-containers >= 0.2,-                       containers >= 0.5,-                       hashable >= 1.2,-                       text >= 1.1,-                       SVGFonts >= 1.4,-                       vector-space >= 0.8,-                       mtl >= 2.1,-                       optparse-applicative >= 0.7,-                       filepath >= 1.3-  if flag(cairo)-    cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.1-  else-    build-depends:     diagrams-svg >= 1.1-  hs-source-dirs:      src-  ghc-options:         -Wall+    exposed-modules:+        Data.Grid+        Data.GridShape+        Data.Util+        Data.Elements+        Data.Pyramid+        Data.Sudoku+        Data.Compose+        Data.PuzzleTypes+        Data.Code+        Data.CmdLine+        Parse.Util+        Parse.Parsec+        Parse.Puzzle+        Parse.PuzzleTypes+        Parse.Code+        Draw.Style+        Draw.Grid+        Draw.Lib+        Draw.Elements+        Draw.Widths+        Draw.Pyramid+        Draw.PuzzleGrids+        Draw.PuzzleTypes+        Draw.Draw+        Draw.Code+        Draw.CmdLine+    hs-source-dirs: src+    other-modules:+        Paths_puzzle_draw+    ghc-options: -Wall+    build-depends:+        base >=4.8 && <5,+        diagrams-lib >=1.4.2.3 && <1.5,+        parsec ==3.1.*,+        yaml >=0.8.4 && <0.9,+        aeson >=0.7 && <1.4,+        unordered-containers ==0.2.*,+        containers ==0.5.*,+        hashable ==1.2.*,+        text >=1.1 && <1.3,+        SVGFonts ==1.7.*,+        vector-space >=0.8 && <0.14,+        mtl >=2.1 && <2.3,+        optparse-applicative >=0.13 && <0.15,+        filepath >=1.3 && <1.5,+        linear >=1.20.8 && <1.21,+        diagrams-rasterific >=1.4.1 && <1.5  executable drawpuzzle-  main-is:          drawpuzzle.hs-  hs-source-dirs:   src/tools-  build-depends:       base >= 4.2,-                       puzzle-draw,-                       diagrams-lib >= 1.2,-                       yaml >= 0.8.4,-                       optparse-applicative >= 0.7,-                       aeson >= 0.7,-                       filepath >= 1.3-  if flag(cairo)-    cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.1-  else-    build-depends:     diagrams-svg >= 1.1-  ghc-options:         -Wall+    main-is: drawpuzzle.hs+    hs-source-dirs: src/tools+    ghc-options: -Wall+    build-depends:+        base >=4.8 && <5,+        puzzle-draw -any,+        diagrams-lib >=1.4.2.3 && <1.5,+        yaml >=0.8.4 && <0.9,+        optparse-applicative >=0.12 && <0.15,+        aeson >=0.7 && <1.4,+        filepath >=1.3 && <1.5,+        diagrams-rasterific >=1.4.1 && <1.5 +executable checkpuzzle+    main-is: checkpuzzle.hs+    hs-source-dirs: src/tools+    ghc-options: -Wall+    build-depends:+        base >=4.8 && <5,+        puzzle-draw -any,+        yaml >=0.8.4 && <0.9,+        containers ==0.5.*,+        optparse-applicative >=0.12 && <0.15,+        aeson >=0.7 && <1.4,+        filepath >=1.3 && <1.5+ test-suite test-  type:                exitcode-stdio-1.0-  hs-source-dirs:      tests-  main-is:             tests.hs-  build-depends:       base >= 4.2,-                       tasty >= 0.8,-                       tasty-hunit >= 0.8,-                       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,-                       bytestring >= 0.10,-                       puzzle-draw-  ghc-options:         -Wall+    type: exitcode-stdio-1.0+    main-is: tests.hs+    hs-source-dirs: tests+    other-modules:+        Data+        Util+        Data.GridSpec+        Data.GridShapeSpec+        Draw.GridSpec+        Parse.PuzzleTypesSpec+        Parse.UtilSpec+    ghc-options: -Wall+    build-depends:+        base >=4.8 && <5,+        tasty >=0.8 && <1.2,+        tasty-hspec >=1.1.5 && <1.2,+        tasty-hunit >=0.8 && <0.11,+        hspec >=2.5.4 && <2.6,+        yaml >=0.8.4 && <0.9,+        text >=1.1 && <1.3,+        deepseq >=1.3 && <1.5,+        containers ==0.5.*,+        blaze-svg ==0.3.*,+        diagrams-lib >=1.4.2.3 && <1.5,+        bytestring ==0.10.*,+        puzzle-draw -any
+ src/Data/CmdLine.hs view
@@ -0,0 +1,27 @@+module Data.CmdLine+    ( checkType+    , exitErr+    , readPuzzle+    ) where++import Parse.Puzzle+import Data.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++
+ src/Data/Code.hs view
@@ -0,0 +1,19 @@+module Data.Code where++import Data.Map.Strict (Map)++import Data.Grid+import Data.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.+    | LRows'  (Map Char Int) -- ^ Rows of cells, counted from the bottom.+    | LCols   (Map Char Int) -- ^ Cols of cells, counted from the left.+    | LRowsN' (Map Char Int) -- ^ Rows of nodes, counted from the bottom.+    | LColsN  (Map Char Int) -- ^ Cols of nodes, counted from the left.
+ src/Data/Compose.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Helpers to string together parser and renderer by puzzle type.++module Data.Compose (+    PuzzleHandler,+    handle,+    -- * Handlers+    drawPuzzleMaybeSol,+  ) where++import Diagrams.Prelude+import Data.Yaml (Parser, Value)++import Parse.Puzzle+import Draw.Draw+import Draw.Lib+import Data.PuzzleTypes++import qualified Parse.PuzzleTypes as R+import qualified Draw.PuzzleTypes as D++-- | A function to compose an arbitrary matching pair of parser and renderer.+--   In @PuzzleHandler b a@, @b@ is the rendering backend type, while @a@ is+--   the result type of the composition.+type PuzzleHandler b a = forall p q.+                         ParsePuzzle p q -> Drawers b p q -> a++-- | @handle h t@ composes the parser and renderer for the puzzle+--   type @t@ with the handler @h@.+handle :: Backend' b =>+        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+handle f Nurikabe             = f R.nurikabe            D.nurikabe+handle f LatinTapa            = f R.latintapa           D.latintapa+handle f Sudoku               = f R.sudoku              D.sudoku+handle f ThermoSudoku         = f R.thermosudoku        D.thermosudoku+handle f Pyramid              = f R.pyramid             D.pyramid+handle f RowKropkiPyramid     = f R.kpyramid            D.kpyramid+handle f SlitherLink          = f R.slither             D.slither+handle f SlitherLinkLiar      = f R.liarslither         D.liarslither+handle f TightfitSkyscrapers  = f R.tightfitskyscrapers D.tightfitskyscrapers+handle f WordLoop             = f R.wordloop            D.wordloop+handle f WordSearch           = f R.wordsearch          D.wordsearch+handle f CurveData            = f R.curvedata           D.curvedata+handle f DoubleBack           = f R.doubleback          D.doubleback+handle f Slalom               = f R.slalom              D.slalom+handle f Compass              = f R.compass             D.compass+handle f BoxOf2Or3            = f R.boxof2or3           D.boxof2or3+handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers+handle f MeanderingNumbers    = f R.meanderingnumbers   D.meanderingnumbers+handle f Tapa                 = f R.tapa                D.tapa+handle f JapaneseSums         = f R.japanesesums        D.japanesesums+handle f Coral                = f R.coral               D.coral+handle f MaximalLengths       = f R.maximallengths      D.maximallengths+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+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+handle f Mines                = f R.mines               D.mines+handle f Tents                = f R.tents               D.tents+handle f PentominoSums        = f R.pentominoSums       D.pentominoSums+handle f CoralLITS            = f R.coralLits           D.coralLits+handle f CoralLITSO           = f R.coralLitso          D.coralLitso+handle f Snake                = f R.snake               D.snake+handle f CountryRoad          = f R.countryRoad         D.countryRoad+handle f KillerSudoku         = f R.killersudoku        D.killersudoku+handle f FriendlySudoku       = f R.friendlysudoku      D.friendlysudoku+handle f JapaneseSumsMasyu    = f R.japsummasyu         D.japsummasyu+++-- | 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, Maybe (Diagram b)))+drawPuzzleMaybeSol (pp, ps) (Drawers 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 <*> pure ())
+ src/Data/Elements.hs view
@@ -0,0 +1,116 @@+-- | Types for a variety of puzzle elements.+module Data.Elements where++import Data.GridShape++type Clue a = Maybe a++data MasyuPearl = MWhite | MBlack+    deriving (Eq, Show)++type MasyuClue = Clue MasyuPearl++type IntClue = Clue Int++-- | A Compass clue, specifiying optional numbers in the+--   four cardinal directions.+data CompassC = CC (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int)+    deriving Show++type CompassClue = Clue CompassC++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++instance Show a => Show (Tightfit a) where+    show c = "(" ++ show' c ++ ")"+        where show' (Single x) = show x+              show' (UR x y)   = show x ++ "/" ++ show y+              show' (DR x y)   = show x ++ "\\" ++ show y++-- | A marked 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 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 = [C]++-- | A forward or backward diagonal as occurring in the solution+--   of a slalom puzzle.+data SlalomDiag = SlalomForward | SlalomBackward+    deriving Show++-- | Shadow along from the western and southern side, as used for+--   afternoon skyscrapers.+data Shade = Shade Bool Bool+    deriving Show++data KropkiDot = KNone | KBlack | KWhite+    deriving (Show, Eq, Ord)++newtype TapaClue = TapaClue [Int]+    deriving Show++-- | Diagonal marking for Prime Place: forward diag?, backward diag?+newtype PrimeDiag = PrimeDiag (Bool, Bool)++data Black = Black+    deriving Eq++data Fish = Fish+    deriving Eq++data Star = Star+    deriving Eq++data Crossing = Crossing+    deriving Eq++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++data PlacedTent = Tent Dir'++data Tree = Tree++data Pentomino = Pentomino Char+    deriving (Show, Eq)
+ src/Data/Grid.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++-- | Puzzle grids.+module Data.Grid+    (+      Grid+    , AreaGrid+    , ShadedGrid+    , nodes+    , size+    , sizeGrid+    , clues+    , nodeGrid+    , cellGrid++    , dominoGrid+    , litsGrid+    , litsoGrid+    , pentominoGrid++    , borders+    , skeletons+    , edgesGen+    , colour+    , collectLines+    , rows++    , OutsideClues(..)+    , outsideSize+    , outsideClues+    , multiOutsideClues+    , outsideGrid+    , outsideValues+    ) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.AffineSpace+import Data.VectorSpace+import Control.Monad.State++import Data.Elements+import Data.GridShape++type Grid k a = Map.Map k a++type AreaGrid = Grid C Char+type ShadedGrid = Grid C Bool++-- | 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++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++nodes :: Grid N a -> Set.Set N+nodes = Map.keysSet++-- | The inner edges of a grid that separate unequal cells.+borders :: Eq a => Grid C a -> [Edge N]+borders = edgesGen (/=) (const False)++corners :: C -> [N]+corners c = map (.+^ (c .-. C 0 0)) [N 0 0, N 1 0, N 0 1, N 1 1]++-- | 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++cellGrid :: Grid N a -> Grid C ()+cellGrid m = Map.fromList+           . map (flip (,) ())+           . filter (all (`Map.member` m) . corners)+           . map cellUpRight+           . Map.keys+           $ m+  where+    cellUpRight :: N -> C+    cellUpRight = fromCoord . toCoord++-- | 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"++    start = fmap (const $ Left [1..]) m+    colour' = mapM_ pickAndFill (Map.keys m)++    -- 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 ()++    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 ()++    -- 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'++colour :: Eq a => Grid C a -> Grid C Int+colour m = colourM edgeNeighbours' m+  where+    edgeNeighbours' p = [ q | q <- edgeNeighbours p+                            , q `Map.member` m ]++-- | 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)++outsideValues :: OutsideClues k a -> [a]+outsideValues (OC l r b t) = l ++ r ++ b ++ t++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)++outsideSize :: OutsideClues k a -> Size+outsideSize (OC l r b t) = (w, h)+  where+    w = max (length t) (length b)+    h = max (length l) (length r)++-- | Create a dummy grid matching the given outside clues in size.+outsideGrid :: (Ord k, FromCoord k) => OutsideClues k a -> Grid k ()+outsideGrid = sizeGrid . outsideSize++-- | 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] ]++data OClue = OClue+    { ocBase :: (Int, Int)+    , _ocDir :: (Int, Int)+    }+  deriving (Show, Eq, Ord)++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++outsideClues :: (Ord k, FromCoord k) => OutsideClues k a -> Map.Map k a+outsideClues = Map.mapKeys (fromCoord . ocBase) . oClues++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++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) ]++collectLines :: (Key k, Eq a) => Grid k (Maybe a) -> [Edge k]+collectLines = dualEdgesP eq+  where+    eq (Just x) (Just y) = x == y+    eq _        _        = False++-- | The skeletons of connected equal cells.+skeletons :: Eq a => Grid C a -> [Edge C]+skeletons = map dualE . edgesGen (==) (const False)++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+    s = y - x++size :: Grid Coord a -> Size+size m = foldr (both max) (0, 0) (Map.keys m) ^+^ (1, 1)+  where+    both f (x, y) (x', y') = (f x x', f y y')++polyominoGrid :: [ ((Int, Int), Char) ] -> [ (Int,Int) ] -> Grid C (Maybe Char)+polyominoGrid ls ps = Map.mapKeys fromCoord . Map.fromList $+    [ (a, Just c) | (a, c) <- ls ] +++    [ (a, Nothing) | a <- ps ]++{-+A grid with (Just p) for the capital letters,+Nothing for the lowercase letters.++    Vvv..N.L..X...Ff.Zz..W+    v...nn.l.xxx.ff..z..ww+    v...n..l..x...f.zz.ww.+    ..T.n.ll..............+    ttt.......U.u..Y...Pp.+    ..t.Iiiii.uuu.yyyy.ppp+-}+pentominoGrid :: Grid C (Maybe Char)+pentominoGrid = polyominoGrid ls ps+  where+    ls = [ ((0,5), 'V')+         , ((5,5), 'N')+         , ((7,5), 'L')+         , ((10,5), 'X')+         , ((14,5), 'F')+         , ((17,5), 'Z')+         , ((21,5), 'W')+         , ((2,2), 'T')+         , ((4,0), 'I')+         , ((10,1), 'U')+         , ((15,1), 'Y')+         , ((19,1), 'P')+         ]+    ps = [ (1,5), (2,5), (0,4), (0,3)+         , (0,1), (1,1), (2,1), (2,0)+         , (5,0), (6,0), (7,0), (8,0)+         , (10,0), (11,0), (12,0), (12,1)+         , (14,0), (15,0), (16,0), (17,0)+         , (19,0), (20,0), (20,1), (21,0)+         , (4,2), (4,3), (4,4), (5,4)+         , (6,2), (7,2), (7,3), (7,4)+         , (9,4), (10,4), (11,4), (10,3)+         , (13,4), (14,4), (14,3), (15,5)+         , (18,5), (17,4), (16,3), (17,3)+         , (19,3), (20,3), (20,4), (21,4)+         ]+++{-+A grid with (Just p) for the capital letters,+Nothing for the lowercase letters.++    L  I+    l  i Ttt  Ss Oo+    ll i  t  ss  oo+       i+-}+litsoGrid :: Grid C (Maybe Char)+litsoGrid = polyominoGrid ls ps+  where+    ls = [ ((0,3), 'L')+         , ((3,3), 'I')+         , ((5,2), 'T')+         , ((10,2), 'S')+         , ((13,2), 'O')+         ]+    ps = [ (0,1), (0,2), (1,1)+         , (3,0), (3,1), (3,2)+         , (6,2), (6,1), (7,2)+         , (9,1), (10,1), (11,2)+         , (13,1), (14,1), (14,2)+         ]++{-+A grid with (Just p) for the capital letters,+Nothing for the lowercase letters.++    L  I+    l  i Ttt  Ss+    ll i  t  ss+       i+-}+litsGrid :: Grid C (Maybe Char)+litsGrid = polyominoGrid ls ps+  where+    ls = [ ((0,3), 'L')+         , ((3,3), 'I')+         , ((5,2), 'T')+         , ((10,2), 'S')+         ]+    ps = [ (0,1), (0,2), (1,1)+         , (3,0), (3,1), (3,2)+         , (6,2), (6,1), (7,2)+         , (9,1), (10,1), (11,2)+         ]
+ src/Data/GridShape.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}++-- | Grid shapes.+module Data.GridShape+    (+      Coord+    , Size+    , Square(..)+    , Dir(..)+    , Edge(..)+    , Dir'(..)+    , Edge'(..)+    , Dual2D(..)+    , Key+    , Dual'+    , C(..)+    , N(..)+    , FromCoord(..)+    , ToCoord(..)++    , edge+    , edge'+    , edgeBetween+    , edgeBetween'+    , orient+    , ends'+    , revEdge+    , edges+    , edgesM+    , ends+    , edgeSize+    , unorient+    , dualE+    , vertexNeighbours+    , edgeNeighbours+    , rows+    ) where++import qualified Data.Foldable as F+import Data.List (partition, groupBy, sortOn)+import qualified Data.Map.Strict as Map+import Data.AffineSpace++type Coord = (Int, Int)++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+    deriving (Show, Eq)++squareNeighbours :: [(Int,Int)] -> C -> [C]+squareNeighbours deltas c = map (c .+^) deltas++vertexNeighbours :: C -> [C]+vertexNeighbours = squareNeighbours [ (dx, dy)+                                    | dx <- [-1..1], dy <- [-1..1]+                                    , 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 = Vert | Horiz+    deriving (Eq, Ord, Show)++-- | An edge in a square grid, going up or right from the given cell+--   centre.+data Edge a = E a Dir+    deriving (Show, Eq, Ord)++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.+data Edge' a = E' a Dir'+    deriving (Eq, Ord, Show)++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 :: (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)] ]+        (ni, no) = partition isc nbrs+        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)++rows :: Map.Map C a -> [[a]]+rows g = map (map snd) $+    grouped byRow (Map.toList g) ++ grouped byCol (Map.toList g)+  where+    byRow (C _ y, _) = y+    byCol (C x _, _) = x+    grouped :: (Ord b, Eq b) => (a -> b) -> [a] -> [[a]]+    grouped f = map (map snd) . groupOn fst . sortOn fst . map (\x -> (f x, x))+    groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+    groupOn f = groupBy (\x y -> f x == f y)
+ src/Data/PuzzleTypes.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}++-- |+-- List of specific puzzle types.++module Data.PuzzleTypes (+    PuzzleType(..)+  , lookupType+  , typeNames+  ) where++import Data.Tuple (swap)++-- | The list of specific puzzle types we can handle.+data PuzzleType = LITS+                | LITSPlus+                | LITSSym+                | Geradeweg+                | Fillomino+                | Masyu+                | Nurikabe+                | LatinTapa+                | Sudoku+                | ThermoSudoku+                | Pyramid+                | RowKropkiPyramid+                | SlitherLink+                | SlitherLinkLiar+                | TightfitSkyscrapers+                | WordLoop+                | WordSearch+                | CurveData+                | DoubleBack+                | Slalom+                | Compass+                | BoxOf2Or3+                | AfternoonSkyscrapers+                | MeanderingNumbers+                | Tapa+                | JapaneseSums+                | Coral+                | MaximalLengths+                | 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+                | Mines+                | Tents+                | PentominoSums+                | CoralLITS+                | CoralLITSO+                | Snake+                | CountryRoad+                | KillerSudoku+                | FriendlySudoku+                | JapaneseSumsMasyu+    deriving (Show, Eq)++typeNames :: [(PuzzleType, String)]+typeNames = [ (LITS, "lits")+            , (LITSPlus, "litsplus")+            , (LITSSym, "lits-symmetry")+            , (Geradeweg, "geradeweg")+            , (Fillomino, "fillomino")+            , (Masyu, "masyu")+            , (Nurikabe, "nurikabe")+            , (LatinTapa, "latintapa")+            , (Sudoku, "sudoku")+            , (ThermoSudoku, "thermosudoku")+            , (Pyramid, "pyramid")+            , (RowKropkiPyramid, "rowkropkipyramid")+            , (SlitherLink, "slitherlink")+            , (SlitherLinkLiar, "slitherlinkliar")+            , (TightfitSkyscrapers, "skyscrapers-tightfit")+            , (WordLoop, "wordloop")+            , (WordSearch, "wordsearch")+            , (CurveData, "curvedata")+            , (DoubleBack, "doubleback")+            , (Slalom, "slalom")+            , (Compass, "compass")+            , (BoxOf2Or3, "boxof2or3")+            , (AfternoonSkyscrapers, "afternoonskyscrapers")+            , (MeanderingNumbers, "meanderingnumbers")+            , (Tapa, "tapa")+            , (JapaneseSums, "japanesesums")+            , (Coral, "coral")+            , (MaximalLengths, "maximallengths")+            , (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")+            , (Mines, "mines")+            , (Tents, "tents")+            , (PentominoSums, "pentomino-sums")+            , (CoralLITS, "coral+lits")+            , (CoralLITSO, "coral+litso")+            , (Snake, "snake")+            , (CountryRoad, "country-road")+            , (KillerSudoku, "killersudoku")+            , (FriendlySudoku, "friendly-sudoku")+            , (JapaneseSumsMasyu, "japanesesums-masyu")+            ]++-- | Look up a puzzle type by name.+lookupType :: String -> Maybe PuzzleType+lookupType t = lookup t (map swap typeNames)
− src/Data/Puzzles/Compose.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-}-{-# LANGUAGE ConstraintKinds #-}---- |--- Helpers to string together parser and renderer by puzzle type.--module Data.Puzzles.Compose (-    PuzzleHandler,-    handle,-    -- * Handlers-    drawPuzzle,-    drawPuzzleSol,-    drawPuzzleMaybeSol,-    drawPuzzle',-    drawSolution',-    drawExample'-  ) where--import Data.Maybe-import Diagrams.Prelude-import Data.Yaml (Parser, Value)-import Data.Traversable (traverse)--import Text.Puzzles.Puzzle-import Diagrams.Puzzles.Draw-import Diagrams.Puzzles.Lib-import Data.Puzzles.PuzzleTypes--import qualified Text.Puzzles.PuzzleTypes as R-import qualified Diagrams.Puzzles.PuzzleTypes as D---- | A function to compose an arbitrary matching pair of parser and renderer.---   In @PuzzleHandler b a@, @b@ is the rendering backend type, while @a@ is---   the result type of the composition.-type PuzzleHandler b a = forall p q.-                         ParsePuzzle p q -> RenderPuzzle b p q -> a---- | @handle h t@ composes the parser and renderer for the puzzle---   type @t@ with the handler @h@.-handle :: Backend' b =>-        PuzzleHandler b a -> PuzzleType -> a-handle f LITS                 = f R.lits                D.lits-handle f LITSPlus             = f R.litsplus            D.litsplus-handle f Geradeweg            = f R.geradeweg           D.geradeweg-handle f Fillomino            = f R.fillomino           D.fillomino-handle f Masyu                = f R.masyu               D.masyu-handle f Nurikabe             = f R.nurikabe            D.nurikabe-handle f LatinTapa            = f R.latintapa           D.latintapa-handle f Sudoku               = f R.sudoku              D.sudoku-handle f ThermoSudoku         = f R.thermosudoku        D.thermosudoku-handle f Pyramid              = f R.pyramid             D.pyramid-handle f RowKropkiPyramid     = f R.kpyramid            D.kpyramid-handle f SlitherLink          = f R.slither             D.slither-handle f SlitherLinkLiar      = f R.liarslither         D.liarslither-handle f TightfitSkyscrapers  = f R.tightfitskyscrapers D.tightfitskyscrapers-handle f WordLoop             = f R.wordloop            D.wordloop-handle f WordSearch           = f R.wordsearch          D.wordsearch-handle f CurveData            = f R.curvedata           D.curvedata-handle f DoubleBack           = f R.doubleback          D.doubleback-handle f Slalom               = f R.slalom              D.slalom-handle f Compass              = f R.compass             D.compass-handle f BoxOf2Or3            = f R.boxof2or3           D.boxof2or3-handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers-handle f MeanderingNumbers    = f R.meanderingnumbers   D.meanderingnumbers-handle f Tapa                 = f R.tapa                D.tapa-handle f JapaneseSums         = f R.japanesesums        D.japanesesums-handle f Coral                = f R.coral               D.coral-handle f MaximalLengths       = f R.maximallengths      D.maximallengths-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 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'))---- | Handler that parses puzzle and an optional solution from a pair of---   corresponding YAML values, and renders both individually, optionally---   for the solution.-drawPuzzleMaybeSol :: PuzzleHandler b ((Value, Maybe Value)-                      -> Parser (Diagram b R2, Maybe (Diagram b R2)))-drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do-    p' <- pp p-    s' <- traverse ps s-    let mps = case s' of Nothing  -> Nothing-                         Just s'' -> Just (p', s'')-    return (dp p', ds <$> mps)---- | Variant of 'drawPuzzle' that accepts a pair of puzzle YAML value and---   optional solution YAML value.-drawPuzzle' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))-drawPuzzle' (pp, _) (dp, _) (p, _) = do-    p' <- pp p-    return $ dp p'---- | Handler that accepts a pair of puzzle YAML value and optional solution---   YAML value, and renders the solution, failing if the solution is not---   provided.-drawSolution' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))-drawSolution' (pp, ps) (_, ds) (p, ms) = do-    p' <- pp p-    s' <- maybe (fail "no solution provided") ps ms-    return $ ds (p', s')---- | Like 'drawSolution'', but renders puzzle and solution in example layout.-drawExample' :: Backend' b =>-                PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2))-drawExample' (pp, ps) (dp, ds) (p, ms) = do-    p' <- pp p-    s' <- maybe (fail "no solution provided") ps ms-    return . fromJust $ draw (dp p', Just $ ds (p', s')) DrawExample
− src/Data/Puzzles/Elements.hs 
@@ -1,68 +0,0 @@--- | Types for a variety of puzzle elements.-module Data.Puzzles.Elements where--import Data.Puzzles.GridShape (Coord, Edge)--type Clue a = Maybe a--data MasyuPearl = MWhite | MBlack-    deriving (Eq, Show)--type MasyuClue = Clue MasyuPearl--type IntClue = Clue Int---- | A Compass clue, specifiying optional numbers in the---   four cardinal directions.-data CompassC = CC (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int)-    deriving Show--type CompassClue = Clue CompassC---- | A cell that is optionally bisected by a diagonal---   (up-right or down-right).-data Tightfit a = Single a | UR a a | DR a a--instance Show a => Show (Tightfit a) where-    show c = "(" ++ show' c ++ ")"-        where show' (Single x) = show x-              show' (UR x y)   = show x ++ "/" ++ show y-              show' (DR x y)   = show x ++ "\\" ++ show y---- | A marked word in a letter grid, by its start and end---   coordinates.-data MarkedWord = MW { mwstart :: Coord, mwend :: Coord }---- | A loop of edges.-type Loop = [Edge]---- | A thermometer, as a list of coordinates from bulb to end.---   There should be at least two entries, entries should be distinct,---   and successive entries should be neighbours (diagonal neighbours---   are fine).-type Thermometer = [Coord]---- | A forward or backward diagonal as occurring in the solution---   of a slalom puzzle.-data SlalomDiag = SlalomForward | SlalomBackward-    deriving Show---- | Shadow along from the western and southern side, as used for---   afternoon skyscrapers.-data Shade = Shade Bool Bool-    deriving Show--data KropkiDot = KNone | KBlack | KWhite-    deriving Show--newtype TapaClue = TapaClue [Int]-    deriving Show---- | Diagonal marking for Prime Place: forward diag?, backward diag?-newtype PrimeDiag = PrimeDiag (Bool, Bool)--data Black = Black--data Crossing = Crossing--type BahnhofClue = Either Int Crossing
− src/Data/Puzzles/Grid.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts,-             GADTs, StandaloneDeriving #-}---- | Puzzle grids.-module Data.Puzzles.Grid where--import Data.Maybe-import qualified Data.Map as Map-import Data.Foldable (Foldable, foldMap)-import Data.Traversable (Traversable, traverse)-import Control.Applicative ((<$>))-import Data.VectorSpace--import Data.Puzzles.GridShape hiding (size, cells)-import qualified Data.Puzzles.GridShape as GS-import Data.Puzzles.Elements---- | A generic grid, with the given shape and contents.-data Grid s a where-    Grid :: { shape :: s-            , contents :: Map.Map (Cell s) a} -> Grid s a--deriving instance (Show a, Show s, GridShape s) => Show (Grid s a)-deriving instance (Eq s, Eq (Cell s), Eq a) => Eq (Grid s a)---- | Standard square grid.-type SGrid = Grid Square--type CharGrid = SGrid Char-type AreaGrid = CharGrid-type ShadedGrid = SGrid Bool-type CharClueGrid = SGrid (Maybe Char)-type IntGrid = SGrid (Clue Int)---- | Lookup a grid value at a given cell. Unsafe.-(!) :: (GridShape s, Ord (Cell s)) => Grid s a -> Cell s -> a-(!) (Grid _ m) = (m Map.!)--instance Functor (Grid s) where-    fmap f (Grid s m) = Grid s (fmap f m)--instance Foldable (Grid s) where-    foldMap f (Grid _ m) = foldMap f m--instance Traversable (Grid s) where-    traverse f (Grid s m) = Grid s <$> traverse f m--filterG :: (a -> Bool) -> Grid s a -> Grid s a-filterG p (Grid s m) = Grid s (Map.filter p m)---- | Initialize a square grid from a list of lists. The grid---   might be incomplete if some rows are shorter.-fromListList :: [[a]] -> Grid Square a-fromListList g = Grid s m-  where-    w = maximum . map length $ g-    h = length g-    s = Square w h-    m = Map.fromList . concat-      . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]-      $ g--size :: GridShape s => Grid s a -> GridSize s-size = GS.size . shape--cells :: GridShape s => Grid s a -> [Cell s]-cells = Map.keys . contents--inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool-inBounds g c = c `elem` cells g---- | For a grid with value type @Maybe a@, return an association---   list of cells and @Just@ values.-clues :: GridShape s => Grid s (Maybe a) -> [(Cell s, a)]-clues g = [ (k, v) | (k, Just v) <- values g ]---- | Association list of cells and values.-values :: GridShape s => Grid s a -> [(Cell s, a)]-values (Grid _ m) = Map.toList m--edgesGen :: (a -> a -> Bool) -> (a -> Bool) -> Grid Square a -> [Edge]-edgesGen p n g = [ E pt V | pt <- vedges ] ++ [ E pt H | pt <- hedges ]-  where-    edges' f (sx, sy) = [ (x + 1, y) | x <- [-1 .. sx - 1]-                                     , y <- [-1 .. sy]-                                     , p' (f (x, y)) (f (x + 1, y)) ]--    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--edgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge]-edgesP p g = edgesGen p (const False) g--dualEdgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge]-dualEdgesP p g = [ E pt H | pt <- hedges ] ++-                 [ E pt V | pt <- vedges ]-  where-    edges' f (sx, sy) = [ (x, y) | x <- [0 .. sx - 2]-                                 , y <- [0 .. sy - 1]-                                 , p' (f (x, y)) (f (x + 1, y)) ]--    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---- | The inner edges of a grid that separate unequal cells.-borders :: Eq a => Grid Square a -> [Edge]-borders = edgesP (/=)---- | Clues along the outside of a square grid.-data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }-    deriving (Show, Eq)--instance Functor OutsideClues where-    fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t)--outsideSize :: OutsideClues a -> (Int, Int)-outsideSize (OC l r b t) = ( max (length t) (length b)-                           , max (length l) (length r)-                           )--data OutsideClue a = OClue-    { ocBase  :: (Int, Int)-    , ocDir   :: (Int, Int)-    , ocValue :: a-    }--instance Functor OutsideClue where-    fmap f (OClue b d x) = OClue b d (f x)--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-       ]-  where-    (w, h) = outsideSize o---- | Convert outside clues to association list mapping coordinate to value.-outsideClues :: OutsideClues (Maybe a) -> [((Int, Int), a)]-outsideClues = mapMaybe (liftMaybe . toCell) . outsideClueList-  where-    toCell (OClue (bx, by) (dx, dy) v) = ((bx + dx, by + dy), v)-    liftMaybe (p, Just x)  = Just (p, x)-    liftMaybe (_, Nothing) = Nothing--multiOutsideClues :: OutsideClues [a] -> [((Int, Int), a)]-multiOutsideClues = concatMap distrib . outsideClues . fmap Just . dired-  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
− src/Data/Puzzles/GridShape.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}---- | Grid shapes.-module Data.Puzzles.GridShape where--import Data.Foldable (Foldable)-import qualified Data.Foldable as F-import Data.List (partition)-import Data.VectorSpace ((^+^))---- | The geometry of a grid.-class Show (Cell a) => GridShape a where-    type GridSize a :: *-    type Cell     a :: *-    type Vertex   a :: *--    size :: a -> GridSize a-    cells :: a -> [Cell a]-    vertices :: a -> [Vertex a]-    vertexNeighbours :: a -> Cell a -> [Cell a]-    edgeNeighbours :: a -> Cell a -> [Cell a]---- | A standard square grid, with cells and vertices---   indexed by pairs of integers in mathematical coordinates.---   The bottom-left corner is vertex (0, 0), the bottom-left---   cell is cell (0, 0).-data Square = Square !Int !Int-    deriving (Show, 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')--instance GridShape Square where-    type GridSize Square = (Int, Int)-    type Cell Square     = (Int, Int)-    type Vertex Square   = (Int, Int)--    size (Square w h)       = (w, h)-    cells (Square w h)      = [(x, y) | x <- [0..w-1], y <- [0..h-1]]-    vertices (Square w h)   = [(x, y) | x <- [0..w], y <- [0..h]]-    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-                                      ]---- | Edge direction in a square grid, vertical or horizontal.-data Dir = V | H-    deriving (Eq, Ord, Show)---- | An edge in a square grid, going up or right from the given cell---   centre.-data Edge = E (Cell Square) Dir-    deriving (Show, Eq, Ord)--type Coord = Cell Square-type Size = GridSize Square---- | Oriented edge direction in a square grid.-data Dir' = U | D | L | R-    deriving (Eq, Ord, Show)---- | 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')---- | @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 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)] ]-        (ni, no) = partition isc nbrs-        newout = map (orientedEdge c) no-        newin = map (orientedEdge c) . filter (c >=) $ ni
− src/Data/Puzzles/PuzzleTypes.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}---- |--- List of specific puzzle types.--module Data.Puzzles.PuzzleTypes (-    PuzzleType(..)-  , lookupType-  , typeNames-  ) where--import Data.Tuple (swap)---- | The list of specific puzzle types we can handle.-data PuzzleType = LITS-                | LITSPlus-                | Geradeweg-                | Fillomino-                | Masyu-                | Nurikabe-                | LatinTapa-                | Sudoku-                | ThermoSudoku-                | Pyramid-                | RowKropkiPyramid-                | SlitherLink-                | SlitherLinkLiar-                | TightfitSkyscrapers-                | WordLoop-                | WordSearch-                | CurveData-                | DoubleBack-                | Slalom-                | Compass-                | BoxOf2Or3-                | AfternoonSkyscrapers-                | MeanderingNumbers-                | Tapa-                | JapaneseSums-                | Coral-                | MaximalLengths-                | PrimePlace-                | Labyrinth-                | Bahnhof-                | Cave-    deriving (Show, Eq)--typeNames :: [(PuzzleType, String)]-typeNames = [ (LITS, "lits")-            , (LITSPlus, "litsplus")-            , (Geradeweg, "geradeweg")-            , (Fillomino, "fillomino")-            , (Masyu, "masyu")-            , (Nurikabe, "nurikabe")-            , (LatinTapa, "latintapa")-            , (Sudoku, "sudoku")-            , (ThermoSudoku, "thermosudoku")-            , (Pyramid, "pyramid")-            , (RowKropkiPyramid, "rowkropkipyramid")-            , (SlitherLink, "slitherlink")-            , (SlitherLinkLiar, "slitherlinkliar")-            , (TightfitSkyscrapers, "skyscrapers-tightfit")-            , (WordLoop, "wordloop")-            , (WordSearch, "wordsearch")-            , (CurveData, "curvedata")-            , (DoubleBack, "doubleback")-            , (Slalom, "slalom")-            , (Compass, "compass")-            , (BoxOf2Or3, "boxof2or3")-            , (AfternoonSkyscrapers, "afternoonskyscrapers")-            , (MeanderingNumbers, "meanderingnumbers")-            , (Tapa, "tapa")-            , (JapaneseSums, "japanesesums")-            , (Coral, "coral")-            , (MaximalLengths, "maximallengths")-            , (PrimePlace, "primeplace")-            , (Labyrinth, "magiclabyrinth")-            , (Bahnhof, "bahnhof")-            , (Cave, "cave")-            ]---- | Look up a puzzle type by name.-lookupType :: String -> Maybe PuzzleType-lookupType t = lookup t (map swap typeNames)
− src/Data/Puzzles/Pyramid.hs 
@@ -1,129 +0,0 @@--- | Data types and parsing for pyramid puzzles.-module Data.Puzzles.Pyramid (-    Row(..),-    Pyramid(..),-    PyramidSol(..),-    KropkiRow(..),-    RowKropkiPyramid(..),-    mergepyramidsol,-    mergekpyramidsol,-    plainpyramid,-    psize-  ) where--import Data.Char (digitToInt)-import Text.ParserCombinators.Parsec hiding ((<|>), many)-import Control.Monad (liftM2, mplus)-import Data.Yaml hiding (Parser)-import qualified Data.Yaml as Yaml-import qualified Data.Text as T-import Control.Applicative--import Data.Puzzles.Elements--data Row = R { entries :: [Maybe Int]-             , shaded  :: Bool-             }--newtype Pyramid = Pyr {unPyr :: [Row]}--newtype PyramidSol = PyramidSol [[Int]]-    deriving Show---- | The size (number of rows) of a pyramid.-psize :: Pyramid -> Int-psize (Pyr rows) = length rows---- | Merge a solution into a pyramid.-mergepyramidsol :: Pyramid -> PyramidSol -> Pyramid-mergepyramidsol (Pyr rs) (PyramidSol qs)-    | length rs /= length qs  = error "can't merge differently sized pyramids"-    | otherwise               = Pyr (zipWith mergerow rs qs)-    where mergerow (R es s) es' = R (zipWith mplus es (map Just es')) s---- | Merge a solution into a kropki pyramid.-mergekpyramidsol :: RowKropkiPyramid -> PyramidSol -> RowKropkiPyramid-mergekpyramidsol (KP rs) (PyramidSol qs)-    | length rs /= length qs  = error "can't merge differently sized pyramids"-    | otherwise               = KP (zipWith mergerow rs qs)-    where mergerow (KR es s ds) es' =-              KR (zipWith mplus es (map Just es')) s ds--prow :: GenParser Char st Row-prow = do s <- pshaded-          spaces-          es <- pclues-          return (R es s)--pplainrow :: GenParser Char st [Int]-pplainrow = many (spaces >> fmap digitToInt digit)--pshaded :: GenParser Char st Bool-pshaded = (char 'G' >> return True) <|> (char 'W' >> return False)--pclues :: GenParser Char st [Maybe Int]-pclues = do c <- pclue-            cs <- many (spaces >> pclue)-            return (c:cs)--pclue :: GenParser Char st (Maybe Int)-pclue = fmap (Just . digitToInt) digit-        <|> (char '.' >> return Nothing)--showClues :: [Maybe Int] -> String-showClues = map showClue-    where showClue = maybe '.' (head . show)--instance Show Row where-    show (R c True) = 'G' : showClues c-    show (R c False) = 'W' : showClues c--instance Show Pyramid where-    show = unlines . map show . unPyr--data KropkiRow = KR { entriesk :: [Maybe Int]-                    , shadedk  :: Bool-                    , dotsk    :: [KropkiDot]-                    }-    deriving Show--newtype RowKropkiPyramid = KP {unKP :: [KropkiRow]}-    deriving Show---- | Forget the kropki dots.-plainpyramid :: RowKropkiPyramid -> Pyramid-plainpyramid (KP rows) = Pyr (map r rows)-    where r x = R (entriesk x) (shadedk x)--pkropkirow :: GenParser Char st KropkiRow-pkropkirow = do s <- pshaded-                spaces-                (ks, cs) <- pkropkiclues-                return (KR cs s ks)--pkropkiclues :: GenParser Char st ([KropkiDot], [Maybe Int])-pkropkiclues = do c <- pclue-                  kcs <- many (liftM2 (,) pkropki pclue)-                  let (ks, cs) = unzip kcs in return (ks, c:cs)--pkropki :: GenParser Char st KropkiDot-pkropki = (char '*' >> return KBlack)-          <|> (char 'o' >> return KWhite)-          <|> (char ' ' >> return KNone)--toParser :: GenParser a () b -> [a] -> Yaml.Parser b-toParser p v = case parse p "(unknown)" v of Left e  -> fail (show e)-                                             Right x -> pure x--instance FromJSON Pyramid where-    parseJSON (String t) = Pyr <$> mapM (toParser prow . T.unpack) (T.lines t)-    parseJSON _          = empty--instance FromJSON RowKropkiPyramid where-    parseJSON (String t) = KP <$> mapM (toParser pkropkirow . T.unpack) (T.lines t)-    parseJSON _          = empty--instance FromJSON PyramidSol where-    parseJSON (String t) = PyramidSol <$>-                             mapM (toParser pplainrow . T.unpack) (T.lines t)-    parseJSON _          = empty
− src/Data/Puzzles/Sudoku.hs 
@@ -1,36 +0,0 @@-module Data.Puzzles.Sudoku (-    sudokuborders,-    sudokubordersg-  ) where--import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)--msqrt :: Integral a => a -> Maybe a-msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing-    where r = round . (sqrt :: Double -> Double) . fromIntegral $ x--mhalf :: Integral a => a -> Maybe a-mhalf x = if even x then Just (x `div` 2) else Nothing---- | Determine the internal borders of a standard sudoku of the---   given size.-sudokuborders :: Int -> [Edge]-sudokuborders s =-    case msqrt s of-        Just r  -> squareborders r-        Nothing -> case mhalf s of-                       Just h  -> rectborders h-                       Nothing -> error "no sudoku layout of this size"-    where squareborders r = [ E (r*x, y) V | x <- [1..r-1], y <- [0..r*r-1] ]-                            ++ [ E (x, r*y) H | x <- [0..r*r-1], y <- [1..r-1] ]-          rectborders h = [ E (h, y) V | y <- [0..2*h-1] ]-                          ++ [ E (x, 2*y) H | x <- [0..2*h-1], y <- [1..h-1] ]---- | Determine the internal borders of a standard sudoku of the---   on the given grid.-sudokubordersg :: SGrid a -> [Edge]-sudokubordersg g = sudokuborders s-   where (w, h) = size g-         s | w == h    = w-           | otherwise = error "non-square sudoku grid?"
+ src/Data/Pyramid.hs view
@@ -0,0 +1,129 @@+-- | Data types and parsing for pyramid puzzles.+module Data.Pyramid (+    Row(..),+    Pyramid(..),+    PyramidSol(..),+    KropkiRow(..),+    RowKropkiPyramid(..),+    mergepyramidsol,+    mergekpyramidsol,+    plainpyramid,+    psize+  ) where++import Data.Char (digitToInt)+import Text.ParserCombinators.Parsec hiding ((<|>), many)+import Control.Monad (liftM2, mplus)+import Data.Yaml hiding (Parser)+import qualified Data.Yaml as Yaml+import qualified Data.Text as T+import Control.Applicative++import Data.Elements++data Row = R { entries :: [Maybe Int]+             , shaded  :: Bool+             }++newtype Pyramid = Pyr {unPyr :: [Row]}++newtype PyramidSol = PyramidSol [[Int]]+    deriving Show++-- | The size (number of rows) of a pyramid.+psize :: Pyramid -> Int+psize (Pyr rows) = length rows++-- | Merge a solution into a pyramid.+mergepyramidsol :: Pyramid -> PyramidSol -> Pyramid+mergepyramidsol (Pyr rs) (PyramidSol qs)+    | length rs /= length qs  = error "can't merge differently sized pyramids"+    | otherwise               = Pyr (zipWith mergerow rs qs)+    where mergerow (R es s) es' = R (zipWith mplus es (map Just es')) s++-- | Merge a solution into a kropki pyramid.+mergekpyramidsol :: RowKropkiPyramid -> PyramidSol -> RowKropkiPyramid+mergekpyramidsol (KP rs) (PyramidSol qs)+    | length rs /= length qs  = error "can't merge differently sized pyramids"+    | otherwise               = KP (zipWith mergerow rs qs)+    where mergerow (KR es s ds) es' =+              KR (zipWith mplus es (map Just es')) s ds++prow :: GenParser Char st Row+prow = do s <- pshaded+          spaces+          es <- pclues+          return (R es s)++pplainrow :: GenParser Char st [Int]+pplainrow = many (spaces >> fmap digitToInt digit)++pshaded :: GenParser Char st Bool+pshaded = (char 'G' >> return True) <|> (char 'W' >> return False)++pclues :: GenParser Char st [Maybe Int]+pclues = do c <- pclue+            cs <- many (spaces >> pclue)+            return (c:cs)++pclue :: GenParser Char st (Maybe Int)+pclue = fmap (Just . digitToInt) digit+        <|> (char '.' >> return Nothing)++showClues :: [Maybe Int] -> String+showClues = map showClue+    where showClue = maybe '.' (head . show)++instance Show Row where+    show (R c True) = 'G' : showClues c+    show (R c False) = 'W' : showClues c++instance Show Pyramid where+    show = unlines . map show . unPyr++data KropkiRow = KR { entriesk :: [Maybe Int]+                    , shadedk  :: Bool+                    , dotsk    :: [KropkiDot]+                    }+    deriving Show++newtype RowKropkiPyramid = KP {unKP :: [KropkiRow]}+    deriving Show++-- | Forget the kropki dots.+plainpyramid :: RowKropkiPyramid -> Pyramid+plainpyramid (KP rows) = Pyr (map r rows)+    where r x = R (entriesk x) (shadedk x)++pkropkirow :: GenParser Char st KropkiRow+pkropkirow = do s <- pshaded+                spaces+                (ks, cs) <- pkropkiclues+                return (KR cs s ks)++pkropkiclues :: GenParser Char st ([KropkiDot], [Maybe Int])+pkropkiclues = do c <- pclue+                  kcs <- many (liftM2 (,) pkropki pclue)+                  let (ks, cs) = unzip kcs in return (ks, c:cs)++pkropki :: GenParser Char st KropkiDot+pkropki = (char '*' >> return KBlack)+          <|> (char 'o' >> return KWhite)+          <|> (char ' ' >> return KNone)++toParser :: GenParser a () b -> [a] -> Yaml.Parser b+toParser p v = case parse p "(unknown)" v of Left e  -> fail (show e)+                                             Right x -> pure x++instance FromJSON Pyramid where+    parseJSON (String t) = Pyr <$> mapM (toParser prow . T.unpack) (T.lines t)+    parseJSON _          = empty++instance FromJSON RowKropkiPyramid where+    parseJSON (String t) = KP <$> mapM (toParser pkropkirow . T.unpack) (T.lines t)+    parseJSON _          = empty++instance FromJSON PyramidSol where+    parseJSON (String t) = PyramidSol <$>+                             mapM (toParser pplainrow . T.unpack) (T.lines t)+    parseJSON _          = empty
+ src/Data/Sudoku.hs view
@@ -0,0 +1,36 @@+module Data.Sudoku (+    sudokuborders,+    sudokubordersg+  ) where++import qualified Data.Map.Strict as Map++import Data.Grid+import Data.GridShape++msqrt :: Integral a => a -> Maybe a+msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing+    where r = round . (sqrt :: Double -> Double) . fromIntegral $ x++mhalf :: Integral a => a -> Maybe a+mhalf x = if even x then Just (x `div` 2) else Nothing++-- | Determine the internal borders of a standard sudoku of the+--   given size.+sudokuborders :: Int -> [Edge 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 (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 :: Grid C a -> [Edge N]+sudokubordersg = sudokuborders+               . fst . size . Map.mapKeys toCoord
+ src/Data/Util.hs view
@@ -0,0 +1,32 @@+module Data.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
− src/Diagrams/Puzzles/CmdLine.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE FlexibleContexts, CPP #-}--module Diagrams.Puzzles.CmdLine -    ( B-    , renderToFile-    , RenderOpts(..)-    , formats-    , checkFormat-    , checkType-    , exitErr-    , readPuzzle-    )-  where--import Diagrams.Prelude hiding (value, option, (<>), Result)--#ifdef CAIRO-import Diagrams.Backend.Cairo (B, renderCairo)-#else-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 =-#ifdef CAIRO-    renderCairo-#else-    renderSVG-#endif--renderToFile :: RenderOpts -> Diagram B R2 -> IO ()-renderToFile ropts = renderB (_file ropts) (Width $ _w ropts)--formats :: [String]-#ifdef CAIRO-formats = ["png", "svg", "ps", "pdf"]-#else-formats = ["svg"]-#endif--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
− src/Diagrams/Puzzles/Draw.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Draw (-    PuzzleSol,-    RenderPuzzle,-    OutputChoice(..),-    draw,-    Unit(..),-    diagramWidth,-    toOutputWidth,-  ) where--import Diagrams.Prelude-import Diagrams.BoundingBox--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths--type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2)--type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2))--data OutputChoice = DrawPuzzle | DrawSolution | DrawExample-    deriving Show---- | Optionally render the puzzle, its solution, or a side-by-side---   example with puzzle and solution.-draw :: Backend' b =>-        PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2)-draw (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--data Unit = Pixels | Points--cmtopoint :: Double -> Double-cmtopoint = (* 28.3464567)--diagramWidth :: Diagram b R2 -> Double-diagramWidth = fst . unr2 . boxExtents . boundingBox--toOutputWidth :: Unit -> Double -> Double-toOutputWidth u w = case u of Pixels -> fromIntegral wpix-                              Points -> wpt-  where-    wpix = round (gridresd * w) :: Int  -- grid square size 40px-    wpt = cmtopoint (0.8 * w)     -- grid square size 0.8cm--alignPixel :: Backend' b => Diagram b R2 -> Diagram b R2-alignPixel = scale (1/gridresd) . align' . scale gridresd-  where-    align' d = maybe id grow (getCorners $ boundingBox d) d-    grow (bl, tr) = mappend $ phantoml (nudge bl False) (nudge tr True)-    nudge p dir = let (px, py) = unp2 p in p2 (nudge' px dir, nudge' py dir)-    nudge' x True  = fromIntegral (ceiling (x - 0.5) :: Int) + 0.5-    nudge' x False = fromIntegral (floor   (x + 0.5) :: Int) - 0.5-    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 w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX)-         . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY)
− src/Diagrams/Puzzles/Elements.hs 
@@ -1,178 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}---- | Module: Diagrams.TwoD.Puzzles.Elements------ Tools to draw individual puzzle components. In particular--- contents and decorations for individual cells.--module Diagrams.Puzzles.Elements where--import Diagrams.Prelude-import Diagrams.TwoD.Offset--import Data.Puzzles.Elements-import Data.Puzzles.GridShape--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths-import Diagrams.Puzzles.Grid--pearl :: Backend' b =>-         MasyuPearl -> Diagram b R2-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-smallPearl = scale 0.4 . pearl---- | The up-right diagonal of a centered unit square.-ur :: Path R2-ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)]---- | The down-right diagonal of a centered unit square.-dr :: Path R2-dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]---- | Both diagonals of a centered unit square.-cross :: Path R2-cross = ur <> dr---- | Draw a cross.-drawCross :: Backend' b => Diagram b R2-drawCross = stroke cross # scale 0.8 # lwG edgewidth---- | Draw a Compass clue.-drawCompassClue :: Backend' b =>-                   CompassC -> Diagram b R2-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)-          texts = mconcat . zipWith tx [n, e, s, w] $-                  [(0,f), (f,0), (0,-f), (-f,0)]-          f = 3/10---- | Draw a thermometer, given by a list of bottom-left corners--- of square cells.-thermo :: Backend' b => [P2] -> QDiagram b R2 Any-thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5))-    where bulb = circle 0.4 # moveTo v-          line = strokeLocLine (fromVertices vs)-                 # lwG 0.55 # lineCap LineCapSquare-          col = lc gr . fc gr-          gr = blend 0.6 white black-thermo [] = error "invalid empty thermometer"---- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell--- coordinates.-drawThermos :: Backend' b => [Thermometer] -> QDiagram b R2 Any-drawThermos = mconcat . map (thermo . map p2i)---- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to--- draw the components.-drawTight :: Backend' b =>-             (a -> Diagram b R2) -> Tightfit a -> Diagram b R2-drawTight d (Single x) = d x-drawTight d (UR x y) = stroke ur # lwG onepix-                       <> d x # scale s # translate (r2 (-t,t))-                       <> d y # scale s # translate (r2 (t,-t))-    where t = 1/5-          s = 2/3-drawTight d (DR x y) = stroke dr # lwG onepix-                       <> d x # scale s # translate (r2 (-t,-t))-                       <> d y # scale s # translate (r2 (t,t))-    where t = 1/5-          s = 2/3---- | Stack the given words, left-justified.-stackWords :: Backend' b => [String] -> QDiagram b R2 Any-stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text')---- | Mark a word in a grid of letters.-drawMarkedWord :: Backend' b => MarkedWord -> QDiagram b R2 Any-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 = mconcat . map drawMarkedWord---- | Draw a slalom clue.-drawSlalomClue :: (Show a, Backend' b) =>-                  a -> Diagram b R2-drawSlalomClue x = text' (show x) # scale 0.75-                   <> circle 0.4 # fc white # lwG onepix---- | Draw text. Shouldn't be more than two characters or so to fit a cell.-drawText :: Backend' b => String -> QDiagram b R2 Any-drawText = text'---- | Draw an @Int@.-drawInt :: Backend' b =>-           Int -> Diagram b R2-drawInt s = drawText (show s)---- | Draw a character.-drawChar :: Backend' b =>-            Char -> Diagram b R2-drawChar c = drawText [c]---- | Stack a list of words into a unit square. Scaled such that at least--- three words will fit.-drawWords :: Backend' b =>-             [String] -> Diagram b R2-drawWords ws = spread (-1.0 *^ unitY)-                      (map (centerXY . scale 0.4 . drawText) ws)-               # centerY---- | Fit a line drawing into a unit square.---   For example, a Curve Data clue.-drawCurve :: Backend' b => [Edge] -> Diagram b R2-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)-  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---- | Draws the digits of a tapa clue, ordered---   left to right, top to bottom.-drawTapaClue :: Backend' b =>-                TapaClue -> Diagram b R2-drawTapaClue (TapaClue [x]) = drawInt x-drawTapaClue (TapaClue xs)  = fit 0.8-                            . decoratePath (p (length xs))-                            . map drawInt-                            $ xs-  where-    p n = centerXY (p' n)-    p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4)-    p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8-    p' 4 = reflectX . rotateBy (3/8) $ square 0.7-    p' 1 = error "singleton clues handled separately"-    p' _ = error "invalid tapa clue"--drawPrimeDiag :: Backend' b =>-                 PrimeDiag -> Diagram b R2-drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white)-  where-    p = case d of (False, False) -> mempty-                  (True,  False) -> ur-                  (False, True)  -> dr-                  (True,  True)  -> ur <> dr--drawCrossing :: Backend' b => Crossing -> Diagram b R2-drawCrossing = const $ drawChar '+'--drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b R2-drawBahnhofClue = either drawInt drawCrossing
− src/Diagrams/Puzzles/Grid.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Grid where--import Data.Char (isUpper)-import qualified Data.Map as M--import Diagrams.Prelude--import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size, cells)--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths---- | Draw a small black dot with no envelope.-dot :: 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)---- | 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)--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)---- | 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)]--outframe :: Backend' b => Size -> Diagram b R2-outframe = outframe' framewidthfactor---- | 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---- | Draw a square grid with default grid line style.-grid :: Backend' b =>-        Size -> Diagram b R2-grid = grid' id---- | Draw a square grid with thin frame.-plaingrid :: Backend' b =>-             Size -> Diagram b R2-plaingrid s = stroke (fullgridlines s) # lwG gridwidth--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--dashes :: [Double]-dashes = [5 / 40, 3 / 40]--dashoffset :: Double-dashoffset = 2.5 / 40--gridDashing :: (Semigroup a, HasStyle a, V a ~ R2) => 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))--irregularGridPaths :: SGrid a -> (Path R2, Path R2)-irregularGridPaths (Grid _ m) = (toPath outer, toPath inner)-  where-    (outer, inner) = edges (M.keysSet m) (`M.member` m)-    toPath = mconcat . map edgePath--irregularGrid :: Backend' b =>-                 SGrid a -> Diagram b R2-irregularGrid g = stroke outer # lwG (3 * gridwidth) # lineCap LineCapSquare <>-                  stroke inner # lwG gridwidth-  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--atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a]-atCentres' = translate (r2 (1/2, 1/2)) . atVertices'---- | In a square grid, use the first argument to draw things---   at the grid vertices given by coordinates.-atVertices :: (Transformable a, Monoid a, V a ~ R2) =>-              (t -> a) -> [(Coord, t)] -> a-atVertices dc = mconcat . map (\ (p, c) -> dc c # translatep p)--atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a]-atVertices' g = [ (g ! c) # translatep c | c <- cells g ]--edge :: Edge -> Path R2-edge (E c d) = rule d # translate (r2i c)-  where-    rule V = vrule 1.0 # alignB-    rule H = hrule 1.0 # alignL--dualEdge :: Edge -> Path R2-dualEdge = translate (r2 (1/2, 1/2)) . edge--edgeStyle :: (HasStyle a, V a ~ R2) => a -> a-edgeStyle = lineCap LineCapSquare . lwG edgewidth--thinEdgeStyle :: (HasStyle a, V a ~ R2) => a -> a-thinEdgeStyle = lineCap LineCapSquare . lwG onepix--drawEdges :: Backend' b => [Edge] -> Diagram b R2-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--drawAreaGrid :: (Backend' b, Eq a) =>-                  SGrid a -> Diagram b R2-drawAreaGrid = drawEdges . borders <> grid . size--fillBG :: Backend' b => Colour Double -> Diagram b R2-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)--drawShadedGrid :: Backend' b =>-                  SGrid Bool -> Diagram b R2-drawShadedGrid = shadeGrid . fmap f-  where-    f True  = Just gray-    f False = Nothing--drawAreaGridGray :: Backend' b =>-                    SGrid Char -> Diagram b R2-drawAreaGridGray = drawAreaGrid <> 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 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"
− src/Diagrams/Puzzles/Lib.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Lib where--import Diagrams.Prelude--import Graphics.SVGFonts.ReadFont-import Control.Arrow ((***))--import Paths_puzzle_draw (getDataFileName)-import System.IO.Unsafe (unsafePerformIO)--type Backend' b = (Backend b R2, Renderable (Path R2) b)---- | Vertical/horizontal stroked line of given length.-vline, hline :: Backend' b => Double -> Diagram b R2-vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)]-hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)]---- | Variant of 'hcat'' that spreads with distance @1@.-hcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a-hcatsep = hcat' with {_sep = 1}---- | Variant of 'vcat'' that spreads with distance @1@,--- and stacks towards the top.-vcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a-vcatsep = cat' (r2 (0,1)) with {_sep = 1}---- | Collapse the envelope to a point.-smash :: Backend' b => QDiagram b R2 Any -> QDiagram b R2 Any-smash = withEnvelope (pointDiagram origin :: D R2)---- | Helper to translate by a point given as @(Int, Int)@.-translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t-translatep = translate . r2i---- | Convert pair of @Int@ to vector.-r2i :: (Int, Int) -> R2-r2i = r2 . (fromIntegral *** fromIntegral)---- | Convert pair of @Int@ to point.-p2i :: (Int, Int) -> P2-p2i = p2 . (fromIntegral *** fromIntegral)--mirror :: (Transformable t, V t ~ R2) => t -> t-mirror = reflectAbout (p2 (0, 0)) (r2 (1, 1))---- | Interleave two lists.-interleave :: [a] -> [a] -> [a]-interleave [] _ = []-interleave (x:xs) ys = x : interleave ys xs---- | Spread diagrams evenly along the given vector.-spread :: Backend' b => R2 -> [Diagram b R2] -> Diagram b R2-spread v things = cat v . interleave (repeat (strut vgap)) $ things-    where ds = map (diameter v) things-          gap' = (magnitude v - sum ds) / fromIntegral (length things + 1)-          vgap = (gap' / magnitude v) *^ v--dmid ::  (Enveloped a, V a ~ R2) => a -> Double-dmid a = (dtop + dbot) / 2 - dbot-    where menv v = magnitude . envelopeV v-          dtop = menv unitY a-          dbot = menv ((-1) *^ unitY) a---- | Place the second diagram to the right of the first, aligning both--- vertically. The origin is the origin of the left diagram.-besidesL :: (Backend' b, Semigroup m, Monoid m) =>-            QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m-besidesL a b = a ||| strutX 0.5 ||| b'-    where b' = b # centerY # translate (dmid a *^ unitY)---- | Variant of 'besidesL' where the origin is that of the right diagram.-besidesR :: (Backend' b, Semigroup m, Monoid m) =>-           QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m-besidesR b a =  b' ||| strutX 0.5 ||| a-    where b' = b # centerY # translate (dmid a *^ unitY)---- | @fit f a@ scales @a@ to fit into a square of size @f@.-fit :: (Transformable t, Enveloped t, V t ~ R2) =>-       Double -> t -> t-fit f a = scale (f / m) a-    where m = max (magnitude (diameter unitX a))-                  (magnitude (diameter unitY a))---- | Write text that is centered both vertically and horizontally and that--- has an envelope. Sized such that single capital characters fit nicely--- into a square of size @1@.-text' :: 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-  where-    fnt = outlMap . unsafePerformIO . getDataFileName-        $ "data/fonts/gen-light.svg"---- 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---textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red---text'' :: Backend' b => String -> Diagram b R2---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' = phantom
− src/Diagrams/Puzzles/PuzzleGrids.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE ConstraintKinds           #-}--module Diagrams.Puzzles.PuzzleGrids where--import Diagrams.Prelude--import Data.Puzzles.Grid-import Data.Puzzles.Elements-import Data.Puzzles.Sudoku--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Grid-import Diagrams.Puzzles.Widths-import Diagrams.Puzzles.Elements--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--drawIntGrid :: Backend' b =>-               SGrid (Clue Int) -> Diagram b R2-drawIntGrid = drawIntClues <> grid . size--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--sudokugrid :: Backend' b =>-              SGrid a -> Diagram b R2-sudokugrid = drawEdges . sudokubordersg  <> grid . size--drawWordsClues :: Backend' b =>-                  SGrid (Clue [String]) -> Diagram b R2-drawWordsClues = atCentres 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--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--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--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---outsideGrid :: Backend' b =>-               OutsideClues [String] -> Diagram b R2-outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues-              <> grid . outsideSize--outsideIntGrid :: Backend' b =>-                  OutsideClues [Int] -> Diagram b R2-outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues-                 <> grid . outsideSize
− src/Diagrams/Puzzles/PuzzleTypes.hs 
@@ -1,257 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.PuzzleTypes (-    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,-    sudoku, thermosudoku, pyramid, kpyramid, slither,-    liarslither, tightfitskyscrapers, wordloop, wordsearch,-    curvedata, doubleback, slalom, compass, boxof2or3,-    afternoonskyscrapers, meanderingnumbers, tapa, japanesesums,-    coral, maximallengths, primeplace, labyrinth, bahnhof,-    cave-  ) where--import Diagrams.Prelude hiding (Loop, coral)--import Diagrams.Puzzles.PuzzleGrids-import Diagrams.Puzzles.Draw-import Diagrams.Puzzles.Grid-import qualified Diagrams.Puzzles.Pyramid as DPyr-import Diagrams.Puzzles.Elements-import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths--import Data.Puzzles.Grid-import Data.Puzzles.GridShape (Edge)-import Data.Puzzles.Elements-import qualified Data.Puzzles.Pyramid as Pyr--lits :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid-lits = (,)-    drawAreaGridGray-    (drawAreaGrid . fst <> drawShadedGrid . snd)--litsplus :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid-litsplus = lits--solstyle :: (HasStyle a, V a ~ R2) => a -> a-solstyle = lc (blend 0.8 black white) . lwG (3 * onepix)--geradeweg :: Backend' b => RenderPuzzle b IntGrid Loop-geradeweg = (,)-    drawIntGrid-    (drawIntClues . fst-     <> solstyle . drawDualEdges . snd-     <> grid . size . fst)--fillomino :: Backend' b => RenderPuzzle b IntGrid (SGrid Int)-fillomino = (,)-    (atCentres drawInt . clues <> dashedgrid . size)-    ((atCentres drawInt . values <> drawEdges . borders <> dashedgrid . size) . snd)--masyu :: Backend' b =>-         RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop-masyu = (,)-    drawMasyuGrid-    (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst)--nurikabe :: Backend' b =>-            RenderPuzzle b IntGrid ShadedGrid-nurikabe = (,)-    drawIntGrid-    (drawIntGrid . fst <> drawShadedGrid . snd)--latintapa :: Backend' b =>-             RenderPuzzle b (SGrid (Clue [String])) CharClueGrid-latintapa = (,)-    l-    (l . fst <> atCentres drawChar . clues . snd)-  where-    l = grid . size <> drawWordsClues--sudoku :: Backend' b =>-          RenderPuzzle b IntGrid IntGrid-sudoku = (,)-    (drawIntClues <> sudokugrid)-    ((drawIntClues <> sudokugrid) . snd)--thermosudoku :: Backend' b =>-                RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid-thermosudoku = (,)-    (drawInts . fst <> sudokugrid . fst <> drawThermos . snd)-    (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst)--pyramid :: Backend' b =>-    RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol-pyramid = (,)-    DPyr.pyramid-    (DPyr.pyramid . merge)-  where-    merge (p, q) = Pyr.mergepyramidsol p q--kpyramid :: Backend' b =>-    RenderPuzzle b Pyr.RowKropkiPyramid Pyr.PyramidSol-kpyramid = (,)-    DPyr.kpyramid-    (DPyr.kpyramid . merge)-  where-    merge (p, q) = Pyr.mergekpyramidsol p q--slither :: Backend' b =>-           RenderPuzzle b IntGrid Loop-slither = (,)-    drawSlitherGrid-    (drawSlitherGrid . fst <> solstyle . drawEdges . snd)--liarslither :: Backend' b =>-               RenderPuzzle b IntGrid (Loop, SGrid Bool)-liarslither = (,)-    drawSlitherGrid-    (solstyle . drawCrosses . snd . snd-     <> drawSlitherGrid . fst-     <> solstyle . drawEdges . fst . snd)--tightfitskyscrapers :: Backend' b =>-                       RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ()))-                                      (SGrid (Tightfit Int))-tightfitskyscrapers = (,)-    (atCentres drawInt . outsideClues . fst-     <> drawTightGrid (const mempty) . snd)-    (atCentres drawInt . outsideClues . fst . fst-     <> drawTightGrid drawInt . snd)--wordgrid :: Backend' b =>-            SGrid (Maybe Char) -> [String] -> Diagram b R2-wordgrid g ws = stackWords ws `besidesR` drawClueGrid g--wordloop :: Backend' b =>-            RenderPuzzle b (CharClueGrid, [String]) CharClueGrid-wordloop = (,)-    (uncurry wordgrid)-    (drawClueGrid . snd)--wordsearch :: Backend' b =>-              RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])-wordsearch = (,)-    (uncurry wordgrid) -    (solstyle . drawMarkedWords . snd . snd-     <> drawClueGrid . fst . snd)--curvedata :: Backend' b =>-             RenderPuzzle b (SGrid (Clue [Edge])) [Edge]-curvedata = (,)-    cd-    ((solstyle . drawDualEdges . snd) <> cd . fst)-  where-    cd = atCentres drawCurve . clues <> grid . size--doubleback :: Backend' b =>-              RenderPuzzle b AreaGrid Loop-doubleback = (,)-    drawAreaGridGray-    (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst)--slalom :: Backend' b =>-          RenderPuzzle b IntGrid (SGrid SlalomDiag)-slalom = (,)-    drawSlalomGrid-    (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd)--compass :: Backend' b =>-           RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid-compass = (,)-    drawCompassGrid-    (drawCompassClues . fst <> drawAreaGridGray . snd)--boxof2or3 :: Backend' b =>-             RenderPuzzle b (SGrid MasyuPearl, [Edge]) ()-boxof2or3 = (,)-    (atCentres smallPearl . values . fst-     <> phantom' . grid . size . fst-     <> drawThinDualEdges . snd)-    (error "boxof2or3 solution not implemented")--afternoonskyscrapers :: Backend' b =>-                        RenderPuzzle b (SGrid Shade) IntGrid-afternoonskyscrapers = (,)-    (grid . size <> atCentres drawShade . values)-    (drawIntGrid . snd <> atCentres drawShade . values . fst)--meanderingnumbers :: Backend' b =>-                        RenderPuzzle b AreaGrid IntGrid-meanderingnumbers = (,)-    drawAreaGrid-    (drawIntGrid . snd <> drawAreaGrid . fst)--tapa :: Backend' b =>-        RenderPuzzle b (SGrid TapaClue) ShadedGrid-tapa = (,)-    tapaGrid-    (tapaGrid . fst <> drawShadedGrid . snd)-  where-    tapaGrid = atCentres drawTapaClue . values <> grid . size--japanesesums :: Backend' b =>-                RenderPuzzle b (OutsideClues [Int]) (SGrid (Either Black Int))-japanesesums = (,)-    outsideIntGrid-    (outsideIntGrid . fst <> japcells . snd)-  where-    japcells = atCentres japcell . values-    japcell (Left Black) = fillBG gray-    japcell (Right x) = drawInt x--coral :: Backend' b =>-          RenderPuzzle b (OutsideClues [String]) ShadedGrid-coral = (,)-    outsideGrid-    (outsideGrid . fst <> drawShadedGrid . snd)--maximallengths :: Backend' b =>-                  RenderPuzzle b (OutsideClues (Maybe Int)) Loop-maximallengths = (,)-    g-    (solstyle . drawDualEdges . snd <> g . fst)-  where-    g = atCentres drawInt . outsideClues-        <> grid . outsideSize--primeplace :: Backend' b =>-              RenderPuzzle b (SGrid PrimeDiag) (SGrid Int)-primeplace = (,)-    g-    (atCentres drawInt . values . snd <> g . fst)-  where-    g = irregularGrid <> atCentres drawPrimeDiag . values--labyrinth :: Backend' b =>-             RenderPuzzle b (SGrid (Clue Int), [Edge]) (SGrid (Clue Int))-labyrinth = (,)-    (atCentres drawInt . clues . fst <> g)-    (atCentres drawInt . clues . snd <> g . fst)-  where-    g = drawEdges . snd <> plaingrid . size . fst--bahnhof :: Backend' b =>-            RenderPuzzle b (SGrid (Maybe BahnhofClue)) [Edge]-bahnhof = (,)-    (atCentres drawBahnhofClue . clues <> grid . size)-    (atCentres drawBahnhofStation . clues . fst-     <> solstyle . drawDualEdges . snd-     <> grid . size . fst)-  where-    drawBahnhofStation = either drawInt (const mempty)--cave ::-    (Backend b R2, Renderable (Path R2) b) =>-    RenderPuzzle b (SGrid (Clue Int)) ShadedGrid-cave = (,)-    g-    (drawEdges . edgesGen (/=) not . snd-     <> drawShadedGrid . snd <> fr . fst-     <> g . fst)-  where-    g = gridDashing . plaingrid . size <> atCentres drawInt . clues-    fr gr = outframe' 8 (size gr) # lc gray
− src/Diagrams/Puzzles/Pyramid.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Pyramid where--import Diagrams.Prelude--import Data.Puzzles.Elements-import Data.Puzzles.Pyramid-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 s = square 1 # lwG onepix # if s then fc pgray else id--clue :: Backend' b => Maybe Int -> Diagram b R2-clue Nothing = mempty-clue (Just c) = text' (show c)--cellc :: Backend' b => Bool -> Maybe Int -> Diagram b R2-cellc s c = clue c `atop` cell s--row :: Backend' b => Row -> Diagram b R2-row (R cs s) = centerX . hcat . map (cellc s) $ cs--pyramid :: Backend' b => Pyramid -> Diagram b R2-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 (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)--kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b R2-kpyramid = alignBL . vcat . map krow . unKP
− src/Diagrams/Puzzles/Widths.hs 
@@ -1,24 +0,0 @@-module Diagrams.Puzzles.Widths where--gridres :: Int-gridres = 40--gridresd :: Double-gridresd = fromIntegral gridres--onepix :: Double-onepix = 1 / fromIntegral gridres--twopix, fourpix :: Double-twopix = 2 * onepix-fourpix = 4 * onepix--gridwidth :: Double-gridwidth = onepix--framewidthfactor :: Double-framewidthfactor = 4--edgewidth, borderwidth :: Double-edgewidth = 3 * onepix-borderwidth = 1 / 2
+ src/Draw/CmdLine.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}++module Draw.CmdLine +    ( B+    , renderToFile+    , RenderOpts(..)+    , formats+    , checkFormat+    )+  where++import Data.CmdLine (exitErr)++import Diagrams.Prelude hiding (value, option, (<>), Result)+import Control.Monad (unless)++import Diagrams.Backend.Rasterific (B, renderRasterific)++data RenderOpts = RenderOpts+  { _file :: FilePath+  , _size :: SizeSpec V2 Double+  }++renderToFile :: RenderOpts -> Diagram B -> IO ()+renderToFile ropts = renderRasterific (_file ropts) (_size ropts)++formats :: [String]+formats = ["png", "ps", "pdf"]++checkFormat :: String -> IO ()+checkFormat f = unless (f `elem` formats) $+                    exitErr $ "unknown format: " ++ f
+ src/Draw/Code.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Draw.Code+    (+      CodeDiagrams (..)+    , drawCode+    ) where++import Data.Code+import Data.GridShape+import Data.Grid+import Draw.Lib+import Draw.Grid+import Draw.Elements++import Diagrams.Prelude++import qualified Data.Map.Strict as Map++data CodeDiagrams a = CodeDiagrams { _cdLeft :: a, _cdTop :: a, _cdOver :: a }++instance Semigroup a => Semigroup (CodeDiagrams a) where+    (CodeDiagrams x y z) <> (CodeDiagrams x' y' z') =+        CodeDiagrams (x <> x') (y <> y') (z <> z')++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))+drawCodePart (LRows'  rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty+  where+    g = Map.fromList [ (C 0 r, arrowRightL l) | (l, r) <- Map.toList rs ]+drawCodePart (LCols   cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty+  where+    g = Map.fromList [ (C c 0, arrowDownL l)  | (l, c) <- Map.toList cs ]+drawCodePart (LRowsN' rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty+  where+    g = Map.fromList [ (N 0 r, arrowRightL l) | (l, r) <- Map.toList rs ]+drawCodePart (LColsN  cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty+  where+    g = Map.fromList [ (N c 0, arrowDownL l)  | (l, c) <- Map.toList cs ]++arrowDown :: Backend' b => Diagram b+arrowDown = triangle 0.5 # lwG 0 # fc black # rotateBy (1/2)++arrowDownL :: Backend' b => Char -> Diagram b+arrowDownL c = drawChar c # fc white # scale 0.5 <> arrowDown # scale 1.2++arrowRight :: Backend' b => Diagram b+arrowRight = arrowDown # rotateBy (1/4)++arrowRightL :: Backend' b => Char -> Diagram b+arrowRightL c = drawChar c # fc white # scale 0.5 # translate (r2 (-0.05,0)) <> arrowRight # scale 1.2
+ src/Draw/Draw.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++module Draw.Draw (+    PuzzleSol,+    Drawers(..),+    drawers,+    OutputChoice(..),+    render,+    Unit(..),+    diagramSize,+    toOutputWidth,+  ) where++import Diagrams.Prelude hiding (render)++import Draw.Lib+import Draw.Widths+import Draw.Code++type Config = ()++data Drawers b p s =+    Drawers+        { puzzle :: p -> Config -> Diagram b+        , solution :: (p, s) -> Config -> Diagram b+        }++drawers :: (p -> Diagram b) -> ((p, s) -> Diagram b) -> Drawers b p s+drawers p s = Drawers (const . p) (const . s)++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.+render :: Backend' b+     => Maybe (CodeDiagrams (Diagram b))+     -> PuzzleSol b -> OutputChoice -> Maybe (Diagram b)+render mc (p, ms) = fmap (bg white) . d+  where+    fixup = alignPixel . border borderwidth+    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)++diagramSize :: Backend' b => Diagram b -> (Double, Double)+diagramSize = unr2 . boxExtents . boundingBox++toOutputWidth :: Unit -> Double -> Double+toOutputWidth u w = case u of Pixels -> fromIntegral wpix+                              Points -> wpt+  where+    wpix = round (gridresd * w) :: Int  -- grid square size 40px+    wpt = cmtopoint w     -- grid square size 1.0cm++alignPixel :: Backend' b => Diagram b -> Diagram b+alignPixel = scale (1/gridresd) . align' . scale gridresd+  where+    align' d = maybe id grow (getCorners $ boundingBox d) d+    grow (bl, tr) = mappend $ phantoml (nudge bl False) (nudge tr True)+    nudge p dir = let (px, py) = unp2 p in p2 (nudge' px dir, nudge' py dir)+    nudge' x True  = fromIntegral (ceiling (x - 0.5) :: Int) + 0.5+    nudge' x False = fromIntegral (floor   (x + 0.5) :: Int) - 0.5+    phantoml p q = phantom' $ p ~~ q++-- | Add a phantom border of the given width around a diagram.+border :: Backend' b => Double -> Diagram b -> Diagram b+border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX)+         . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY)
+ src/Draw/Elements.hs view
@@ -0,0 +1,424 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++-- | Module: Diagrams.TwoD.Puzzles.Elements+--+-- Tools to draw individual puzzle components. In particular+-- contents and decorations for individual cells.++module Draw.Elements where++import Diagrams.Prelude hiding (N)+import Diagrams.TwoD.Offset++import qualified Data.Map.Strict as Map+import Data.List (groupBy, sortOn)++import Data.Grid+import Data.Elements hiding (Loop)+import Data.GridShape hiding (edge)++import Draw.Lib+import Draw.Style+import Draw.Widths+import Draw.Grid++pearl :: Backend' b =>+         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+smallPearl = scale 0.4 . pearl++drawEnd :: Backend' b =>+       MEnd -> Diagram b+drawEnd MEnd = smallPearl MBlack++drawBigEnd :: Backend' b =>+       MEnd -> Diagram b+drawBigEnd MEnd = pearl MBlack++-- | The up-right diagonal of a centered unit square.+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 V2 Double+dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)]++-- | Both diagonals of a centered unit square.+cross :: Path V2 Double+cross = ur <> dr++-- | Draw a cross.+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+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)+          texts = mconcat . zipWith tx [n, e, s, w] $+                  [(0,f), (f,0), (0,-f), (-f,0)]+          f = 3/10++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+          col = lc gr . fc gr+          gr = blend 0.6 white black+thermo [] = error "invalid empty thermometer"++-- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell+-- coordinates.+drawThermos :: 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) -> 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))+                       <> d y # scale s # translate (r2 (t,-t))+    where t = 1/5+          s = 2/3+drawTight d (DR x y) = stroke dr # lwG onepix+                       <> d x # scale s # translate (r2 (-t,-t))+                       <> d y # scale s # translate (r2 (t,t))+    where t = 1/5+          s = 2/3++-- | Stack the given words, left-justified.+stackWords :: Backend' b => [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 -> 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] -> 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+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 -> Diagram b+drawText = text'++drawTextFixed :: Backend' b => String -> Diagram b+drawTextFixed = textFixed++-- | Draw an @Int@.+drawInt :: Backend' b =>+           Int -> Diagram b+drawInt s = drawText (show s)++-- | Draw a character.+drawChar :: Backend' b =>+            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++placeTL :: Backend' b => Diagram b -> Diagram b+placeTL = moveTo (p2 (-0.4,0.4)) . scale 0.5 . alignTL++hintTL :: Backend' b => String -> Diagram b+hintTL = placeTL . 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+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 N] -> Diagram b+drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge)++-- | Draw a shadow in the style of Afternoon Skyscrapers.+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)) (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+drawTapaClue (TapaClue [x]) = drawInt x+drawTapaClue (TapaClue xs)  = fit 0.8+                            . atPoints (p (length xs))+                            . map drawInt+                            $ xs+  where+    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+    p' 1 = error "singleton clues handled separately"+    p' _ = error "invalid tapa clue"++drawPrimeDiag :: Backend' b =>+                 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+                  (True,  False) -> ur+                  (False, True)  -> dr+                  (True,  True)  -> ur <> dr++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 = ((180 @@ deg) ^-^ acosA off ^-^ startAngle)++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++drawTree :: Backend' b => Tree -> Diagram b+drawTree Tree =+    fit 0.5 $ centerXY $ scaleY 0.5 $ fc black $ mconcat+        [ rect 0.1 0.6 # moveTo (p2 (0.5, 0.7))+        , circle 0.1   # moveTo (p2 (0.4, 0.9))+        , circle 0.2   # moveTo (p2 (0.6, 1.0))+        , circle 0.2   # moveTo (p2 (0.4, 1.2))+        , circle 0.16  # moveTo (p2 (0.6, 1.3))+        , circle 0.15  # moveTo (p2 (0.45, 1.45))+        , circle 0.1   # moveTo (p2 (0.7, 1.4))+        ]++drawTent :: Backend' b => PlacedTent -> Diagram b+drawTent (Tent d) = tent <> lwG gridwidth (stroke conn)+  where+    conn :: Path V2 Double+    conn = p2 (0, 0) ~~ p2 (case d of+        U -> (0, 1)+        R -> (1, 0)+        D -> (0, -1)+        L -> (-1, 0))++    tent = fit 0.7 $ centerXY $ lwG 0 $ mconcat+        [ rect 10 (1/4) # fc black+        , shape [(-2, 0), (0, 4), (2, 0), (-2, 0)] # fc white+        , shape [(-4, 0), (0, 8), (4, 0), (-4, 0)] # fc black+        , shape [(0, 8), (-1/2, 8 + 1), (-1, 8 + 1 - 1/4), (0, 8 + 1 - 1/4 - 2), (0, 8) ] # fc black+        , shape [(0, 8), (1/2, 8 + 1), (1, 8 + 1 - 1/4), (0, 8 + 1 - 1/4 - 2), (0, 8) ] # fc black+        ]+    shape = strokeLocLoop . fromVertices . map p2++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)++placeNoteTR :: Backend' b =>+             Size -> Diagram b -> Diagram b+placeNoteTR 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]++polyominoGrid :: Backend' b => Grid C (Maybe Char) -> Diagram b+polyominoGrid = placeGrid . fmap (scale 0.8) . fmap+    (\x -> case x of+        Nothing -> fillBG black+        Just c -> (drawText [c] # fc white # lc white) <> fillBG black)++drawPentominos :: Backend' b => Diagram b+drawPentominos = centerXY . scale 0.5 . polyominoGrid $ pentominoGrid++drawLITS :: Backend' b => Diagram b+drawLITS = centerXY . scale 0.5 . polyominoGrid $ litsGrid++drawLITSO :: Backend' b => Diagram b+drawLITSO = centerXY . scale 0.5 . polyominoGrid $ litsoGrid++drawCrossing :: Backend' b => Crossing -> Diagram b+drawCrossing = const $ drawChar '+'++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++drawCages :: (Backend' b, Eq a, Ord a) =>+             Grid C a -> Map.Map a (Diagram b) -> Diagram b+drawCages g m =+    hints <> (mconcat . map cage . Map.elems) byChar+  where+    hints = placeGrid . fmap (bgFrame 0.05 white . placeTL) . clues+          . fmap (flip Map.lookup m . head) . invertMap . fmap tl $ byChar+    tl = head . sortOn (\ (C x y) -> (-y, x))+    byChar = invertMap g++invertMap :: (Eq a, Ord a) => Map.Map k a -> Map.Map a [k]+invertMap+        = Map.fromList+        . map (\ l -> (fst (head l), map snd l))+        . groupBy (\ x y -> fst x == fst y)+        . sortOn fst+        . map (\ (x,y) -> (y,x))+        . Map.toList+
+ src/Draw/Grid.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++module Draw.Grid where++import Data.Maybe (catMaybes)+import Data.Char (isUpper)+import qualified Data.Map.Strict as Map++import Diagrams.Prelude hiding (size, E, N, dot, outer)+import Diagrams.TwoD.Offset (offsetPath)++import qualified Data.AffineSpace as AS++import Data.Util+import Data.Grid+import Data.GridShape hiding (edge)++import Draw.Style+import Draw.Lib+import Draw.Widths++(.--.) :: AS.AffineSpace p => p -> p -> AS.Diff p+(.--.) = (AS..-.)++class ToPoint a where+    toPoint :: a -> P2 Double++instance ToPoint C where+    toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0)++instance ToPoint N where+    toPoint c = origin .+^ r2i (c .--. N 0 0)++-- | Draw a small black dot with no envelope.+dot :: Backend' b => Diagram b+dot = circle 0.05 # fc black # smash++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++    (outer, inner) = irregularGridPaths g++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, 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]++dashoffset :: Double+dashoffset = 2.5 / 40++gridDashing :: (Semigroup a, HasStyle a, InSpace V2 Double a) => a -> a+gridDashing = bgdashingG dashes dashoffset white'+  where+    white' = black `withOpacity` (0.05 :: Double)++-- | `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 (Map.keysSet m) (`Map.member` m)+    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++offsetBorder :: Double -> [C] -> Path V2 Double+offsetBorder off cs =+    pathFromLoopVertices . map offsetCorner . corners . map toPoint $ loop+  where+    pathFromLoopVertices = pathFromLocTrail+                         . mapLoc (wrapLoop . closeLine)+                         . fromVertices+    outer :: [Edge' N]+    (outer, _) = edges cs (`elem` cs)+    loop :: [N]+    loop = case loops (map ends' outer) of+        Just [l] -> tail l+        _        -> error "broken cage"+    corners :: [P2 Double] -> [(P2 Double, P2 Double, P2 Double)]+    corners vs = catMaybes $ zipWith3+        (\ a b c -> if b .-. a == c .-. b then Nothing else Just (a, b, c))+        vs (tail vs ++ vs) (tail (tail vs) ++ vs)+    offsetCorner :: (P2 Double, P2 Double, P2 Double) -> P2 Double+    offsetCorner (a, b, c) =+      let+        dir = perp (normalize (b .-. a)) ^+^ perp (normalize (c .-. b))+      in+        b .+^ (off *^ dir)++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)++placeGrid :: (ToPoint k, HasOrigin a, Monoid a, InSpace V2 Double a)+          => Grid k a -> a+placeGrid = Map.foldMapWithKey (moveTo . toPoint)++placeGrid' :: (HasOrigin a, Monoid a, InSpace V2 Double a)+          => Grid (P2 Double) a -> a+placeGrid' = Map.foldMapWithKey moveTo++edge :: (ToPoint k) => Edge k -> Path V2 Double+edge (E c d) = rule d # translate (toPoint c .-. origin)+  where+    rule Vert = vrule 1.0 # alignB+    rule Horiz = hrule 1.0 # alignL++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, InSpace V2 Double a) => a -> a+edgeStyle = lineCap LineCapSquare . lwG edgewidth++thinEdgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a+thinEdgeStyle = lineCap LineCapSquare . lwG onepix++drawEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b+drawEdges = edgeStyle . stroke . mconcat . map edge++drawThinEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b+drawThinEdges = thinEdgeStyle . stroke . mconcat . map edge++drawAreas :: (Backend' b, Eq a) =>+             Grid C a -> Diagram b+drawAreas = drawEdges . borders++cage :: Backend' b => [C] -> Diagram b+cage cs = dashingG dashes dashoffset+        . lwG onepix . stroke . offsetBorder (-4 * onepix) $ cs++fillBG :: Backend' b => Colour Double -> Diagram b+fillBG c = square 1 # lwG onepix # fc c # lc c++shadeGrid :: Backend' b =>+             Grid C (Maybe (Colour Double)) -> Diagram b+shadeGrid = placeGrid . fmap fillBG . clues++drawShade :: Backend' b =>+             Grid C Bool -> Diagram b+drawShade = shadeGrid . fmap f+  where+    f True  = Just gray+    f False = Nothing++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++-- Place a list of diagrams along a ray, with steps of size+-- @f@.+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
+ src/Draw/Lib.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++module Draw.Lib where++import Diagrams.Path (pathPoints)+import Diagrams.Prelude++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 = (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+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 :: (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 :: (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 => Diagram b -> Diagram b+smash = withEnvelope (pointDiagram origin :: D V2 Double)++-- | Helper to translate by a point given as @(Int, Int)@.+translatep :: (InSpace V2 Double t, Transformable t)+           => (Int, Int) -> t -> t+translatep = translate . r2i++-- | Convert pair of @Int@ to vector.+r2i :: (Int, Int) -> V2 Double+r2i = r2 . (fromIntegral *** fromIntegral)++-- | Convert pair of @Int@ to point.+p2i :: (Int, Int) -> P2 Double+p2i = p2 . (fromIntegral *** fromIntegral)++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 => 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 ::  (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 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 =>+            Diagram b -> Diagram b -> Diagram b+besidesL a b = a ||| strutX 0.5 ||| b'+    where b' = b # centerY # translate (dmid unitY a *^ unitY)++-- | Variant of 'besidesL' where the origin is that of the right diagram.+besidesR :: Backend' b =>+           Diagram b  -> Diagram b -> Diagram b+besidesR b a =  b' ||| strutX 0.5 ||| a+    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, InSpace V2 Double t) =>+       Double -> t -> t+fit f a = scale (f / m) 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 => 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+    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 = unsafePerformIO $ 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+--textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red+--text'' :: Backend' b => String -> Diagram b R2+--text'' t = text' t `atop` textrect t++-- | Variant of 'phantom' that forces the argument backend type.+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++{-+opaque :: Backend' b => Diagram b -> Diagram b+opaque x = x <> bRect x # stroke # scale 1.1 # lwG 0 # fc white+ where+    bRect :: Backend' b => Diagram b -> Path V2 Double+    bRect = boundingRect+-}
+ src/Draw/PuzzleGrids.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ConstraintKinds           #-}++module Draw.PuzzleGrids+    (+      drawIntGrid+    , drawCharGrid+    , outsideIntGrid+    , drawSlitherGrid+    , drawTightGrid+    , sudokugrid+    , drawWordsClues+    , drawOutsideGrid+    , drawMultiOutsideGrid+    , drawOutsideGridN+    , drawMultiOutsideGridN+    , placeMultiOutside+    ) where++import Diagrams.Prelude hiding (size, N)++import qualified Data.Map.Strict as Map+import Data.Maybe (maybeToList)++import Data.Grid+import Data.GridShape+import Data.Elements+import Data.Sudoku++import Draw.Lib+import Draw.Style+import Draw.Grid+import Draw.Elements++drawCharGrid :: Backend' b =>+                Grid C (Maybe Char) -> Diagram b+drawCharGrid = placeGrid . fmap drawChar . clues <> grid gDefault++drawIntGrid :: Backend' b =>+               Grid C (Maybe Int) -> Diagram b+drawIntGrid = placeGrid . fmap drawInt . clues  <> grid gDefault++drawSlitherGrid :: Backend' b =>+                   Grid C (Maybe Int) -> Diagram b+drawSlitherGrid = placeGrid . fmap  drawInt . clues <> grid gSlither++sudokugrid :: Backend' b =>+              Grid C a -> Diagram b+sudokugrid = drawEdges . sudokubordersg <> grid gDefault++drawWordsClues :: Backend' b =>+                  Grid C (Maybe [String]) -> Diagram b+drawWordsClues = placeGrid . fmap drawWords . clues++drawTightGrid :: Backend' b =>+                 (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)++placeMultiOutside :: (Ord k, FromCoord k, ToPoint k,+                      HasOrigin a, Monoid a,+                      InSpace V2 Double a)+                  => OutsideClues k [a] -> a+placeMultiOutside = placeGrid . multiOutsideClues++placeOutside :: (Ord k, FromCoord k, ToPoint k,+                 HasOrigin a, Monoid a,+                 InSpace V2 Double a)+             => OutsideClues k (Maybe a) -> a+placeOutside = placeMultiOutside . fmap maybeToList++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++drawMultiOutsideGrid :: Backend' b => OutsideClues C [String] -> Diagram b+drawMultiOutsideGrid = placeMultiOutside . fmap (fmap (scale 0.8 . drawText))+                     <> grid gDefault . outsideGrid++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)
+ src/Draw/PuzzleTypes.hs view
@@ -0,0 +1,910 @@++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++module Draw.PuzzleTypes (+    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,+    sudoku, thermosudoku, pyramid, kpyramid, slither,+    liarslither, tightfitskyscrapers, wordloop, wordsearch,+    curvedata, doubleback, slalom, compass, boxof2or3,+    afternoonskyscrapers, meanderingnumbers, tapa, japanesesums,+    coral, maximallengths, primeplace, labyrinth, bahnhof,+    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, mines, tents,+    pentominoSums, coralLits, coralLitso, snake, countryRoad,+    killersudoku, friendlysudoku, japsummasyu+  ) where++import Diagrams.Prelude hiding (Loop, N, coral, size)++import Data.Char (isUpper)+import Data.List (nub, sort, sortOn)+import qualified Data.Map.Strict as Map++import Draw.Style+import Draw.PuzzleGrids+import Draw.Draw+import Draw.Grid+import qualified Draw.Pyramid as DPyr+import Draw.Elements+import Draw.Lib+import Draw.Widths++import Data.Grid+import Data.GridShape+import Data.Elements+import qualified Data.Pyramid as Pyr++unimplemented :: String -> a+unimplemented x = error (x ++ " unimplemented")++lits :: Backend' b => Drawers b AreaGrid ShadedGrid+lits = drawers+    (grid gDefault <> drawAreasGray)+    ((drawAreas <> grid gDefault) . fst <> drawShade . snd)++litsplus :: Backend' b => Drawers b AreaGrid ShadedGrid+litsplus = lits++litssym :: Backend' b => Drawers b AreaGrid ShadedGrid+litssym = drawers+    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 => Drawers b (Grid C (Maybe Int)) (Loop C)+geradeweg = drawers+    drawIntGrid+    (placeGrid . fmap drawInt . clues . fst+     <> solstyle . drawEdges . snd+     <> grid gDefault . fst)++fillomino :: Backend' b => Drawers b (Grid C (Maybe Int)) (Grid C Int)+fillomino = drawers+    (placeGrid . fmap drawInt . clues <> grid gDashed)+    ((placeGrid . fmap drawInt <> drawEdges . borders <> grid gDashed) . snd)++fillominoCheckered :: Backend' b => Drawers b (Grid C (Maybe Int)) (Grid C Int)+fillominoCheckered = drawers+    (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 => Drawers b (Grid C (Maybe Int))+                                              (Grid C Int, Loop C)+fillominoLoop = drawers+    (placeGrid . fmap drawInt . clues <> grid gDashed)+    ((placeGrid . fmap drawInt . fst+      <> solstyle . drawEdges . snd+      <> drawEdges . borders . fst+      <> grid gDashed . fst) . snd)++masyu :: Backend' b =>+         Drawers b (Grid C (Maybe MasyuPearl)) (Loop C)+masyu = drawers+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = placeGrid . fmap pearl . clues <> grid gDefault++nurikabe :: Backend' b =>+            Drawers b (Grid C (Maybe Int)) ShadedGrid+nurikabe = drawers+    drawIntGrid+    (drawIntGrid . fst <> drawShade . snd)++latintapa :: Backend' b =>+             Drawers b (Grid C (Maybe [String])) (Grid C (Maybe Char))+latintapa = drawers+    l+    (l . fst <> placeGrid . fmap drawChar . clues . snd)+  where+    l = grid gDefault <> drawWordsClues++sudoku :: Backend' b =>+          Drawers b (Grid C (Maybe Int)) (Grid C (Maybe Int))+sudoku = drawers+    (placeGrid . fmap drawInt . clues <> sudokugrid)+    ((placeGrid . fmap drawInt . clues <> sudokugrid) . snd)++thermosudoku :: Backend' b =>+                Drawers b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int))+thermosudoku = drawers+    (placeGrid . fmap drawInt . clues . fst <> sudokugrid . fst <> drawThermos . snd)+    (placeGrid . fmap drawInt . clues . snd <> sudokugrid . snd <> drawThermos . snd . fst)++killersudoku :: Backend' b =>+                Drawers b (AreaGrid, Map.Map Char Int, Grid C (Maybe Int)) (Grid C Int)+killersudoku = drawers+    (p <> placeGrid . fmap drawInt . clues . trd3)+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    fst3 (x,_,_) = x+    trd3 (_,_,z) = z+    p = cages <> sudokugrid . fst3+    cages (g, m, _) = drawCages (Map.filter (/= '.') g) (Map.map drawInt m)++pyramid :: Backend' b =>+    Drawers b Pyr.Pyramid Pyr.PyramidSol+pyramid = drawers+    DPyr.pyramid+    (DPyr.pyramid . merge)+  where+    merge (p, q) = Pyr.mergepyramidsol p q++kpyramid :: Backend' b =>+    Drawers b Pyr.RowKropkiPyramid Pyr.PyramidSol+kpyramid = drawers+    DPyr.kpyramid+    (DPyr.kpyramid . merge)+  where+    merge (p, q) = Pyr.mergekpyramidsol p q++slither :: Backend' b =>+           Drawers b (Grid C (Maybe Int)) (Loop N)+slither = drawers+    drawSlitherGrid+    (drawSlitherGrid . fst <> solstyle . drawEdges . snd)++liarslither :: Backend' b =>+               Drawers b (Grid C (Maybe Int)) (Loop N, Grid C Bool)+liarslither = drawers+    drawSlitherGrid+    (placeGrid . fmap (solstyle . drawCross) . snd . snd+     <> drawSlitherGrid . fst+     <> solstyle . drawEdges . fst . snd)++slithermulti :: Backend' b =>+                Drawers b (Grid C (Maybe Int), Int) [Edge N]+slithermulti = drawers+    (drawSlitherGrid . fst <> n)+    (drawSlitherGrid . fst . fst <> solstyle . drawEdges . snd)+  where+    n (g, l) = placeNoteTR (size' g) (drawInt l ||| strutX 0.2 ||| miniloop)+    size' = size . Map.mapKeys toCoord++tightfitskyscrapers :: Backend' b =>+                       Drawers b (OutsideClues C (Maybe Int), Grid C (Tightfit ()))+                                      (Grid C (Tightfit Int))+tightfitskyscrapers = drawers+    (placeGrid . fmap drawInt . clues . outsideClues . fst+     <> drawTightGrid (const mempty) . snd)+    (placeGrid . fmap drawInt . clues . outsideClues . fst . fst+     <> drawTightGrid drawInt . snd)++wordgrid :: Backend' b =>+            Grid C (Maybe Char) -> [String] -> Diagram b+wordgrid g ws = stackWords ws `besidesR` drawCharGrid g++wordloop :: Backend' b =>+            Drawers b (Grid C (Maybe Char), [String]) (Grid C (Maybe Char))+wordloop = drawers+    (uncurry wordgrid)+    (drawCharGrid . snd)++wordsearch :: Backend' b =>+              Drawers b (Grid C (Maybe Char), [String])+                             (Grid C (Maybe Char), [MarkedWord])+wordsearch = drawers+    (uncurry wordgrid) +    (solstyle . drawMarkedWords . snd . snd+     <> drawCharGrid . fst . snd)++curvedata :: Backend' b =>+             Drawers b (Grid C (Maybe [Edge N])) [Edge C]+curvedata = drawers+    (placeGrid . fmap drawCurve . clues+     <> grid gDefault)+    (placeGrid . fmap drawCurve . clues . fst+     <> solstyle . drawEdges . snd+     <> grid gDefault . fst)++doubleback :: Backend' b =>+              Drawers b AreaGrid (Loop C)+doubleback = drawers+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = grid gDefault <> drawAreasGray++slalom :: Backend' b =>+          Drawers b (Grid N (Maybe Int)) (Grid C SlalomDiag)+slalom = drawers+    p+    (p . fst <> placeGrid . fmap (solstyle . drawSlalomDiag) . snd)+  where+    p = placeGrid . fmap drawSlalomClue . clues+        <> grid gDefault . cellGrid++compass :: Backend' b =>+           Drawers b (Grid C (Maybe CompassC)) AreaGrid+compass = drawers+    (placeGrid . fmap drawCompassClue . clues <> grid gDashed)+    (placeGrid . fmap drawCompassClue . clues . fst+     <> (grid gDashed <> drawAreasGray) . snd)++boxof2or3 :: Backend' b =>+             Drawers b (Grid N MasyuPearl, [Edge N]) ()+boxof2or3 = drawers+    (placeGrid . fmap smallPearl . fst+     <> drawThinEdges . snd)+    (unimplemented "boxof2or3 solution")++afternoonskyscrapers :: Backend' b =>+                        Drawers b (Grid C Shade) (Grid C (Maybe Int))+afternoonskyscrapers = drawers+    (grid gDefault <> placeGrid . fmap drawShadow)+    (drawIntGrid . snd <> placeGrid . fmap drawShadow . fst)++meanderingnumbers :: Backend' b =>+                        Drawers b AreaGrid (Grid C (Maybe Int))+meanderingnumbers = drawers+    (grid gDefault <> drawAreas)+    (drawIntGrid . snd <> drawAreas . fst)++tapa :: Backend' b =>+        Drawers b (Grid C (Maybe TapaClue)) ShadedGrid+tapa = drawers+    tapaGrid+    (tapaGrid . fst <> drawShade . snd)+  where+    tapaGrid = placeGrid . fmap drawTapaClue . clues <> grid gDefault++japanesesums :: Backend' b =>+                Drawers b (OutsideClues C [Int], String)+                               (Grid C (Either Black Int))+japanesesums = drawers+    (outsideIntGrid . fst <> n)+    (outsideIntGrid . fst . fst <> japcells . snd)+  where+    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 =>+          Drawers b (OutsideClues C [String]) ShadedGrid+coral = drawers+    drawMultiOutsideGrid+    (drawMultiOutsideGrid . fst <> drawShade . snd)++maximallengths :: Backend' b =>+                  Drawers b (OutsideClues C (Maybe Int)) (Loop C)+maximallengths = drawers+    g+    (solstyle . drawEdges . snd <> g . fst)+  where+    g = placeGrid . fmap drawInt . clues . outsideClues+        <> grid gDefault . outsideGrid++primeplace :: Backend' b =>+              Drawers b (Grid C PrimeDiag) (Grid C Int)+primeplace = drawers+    g+    (placeGrid . fmap drawInt . snd <> g . fst)+  where+    g = grid gStyle+        <> placeGrid . fmap drawPrimeDiag+    gStyle = GridStyle LineThin LineThick Nothing VertexNone++labyrinth :: Backend' b =>+             Drawers b (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int))+labyrinth = drawers+    (placeGrid . fmap drawInt . clues . fst3 <> p <> n)+    (placeGrid . fmap drawInt . clues . snd <> p . fst)+  where+    p (g, e, _) = drawEdges e <> grid gPlain g+    n (g, _, ds) = placeNoteTR (size' g) (drawText ds # scale 0.8)+    size' = size . Map.mapKeys toCoord+    fst3 (x,_,_) = x++bahnhof :: Backend' b =>+            Drawers b (Grid C (Maybe BahnhofClue)) [Edge C]+bahnhof = drawers+    (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 =>+                   Drawers b (Grid C (Clue Int), DigitRange)+                                  (Grid C (Clue Int), AreaGrid)+blackoutDominos = drawers+    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 =>+    Drawers b (Grid N (Clue Int)) VertexLoop+angleLoop = drawers+    (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 =>+    Drawers b (OutsideClues C (Clue Int), Grid C (Maybe Fish)) [Edge C]+anglers = drawers+    (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 =>+    Drawers b (Grid C (Maybe Int)) ShadedGrid+cave = drawers+    (grid gDashDash <> placeGrid . fmap drawInt . clues)+    (drawEdges . edgesGen (/=) not . snd+     <> placeGrid . fmap drawInt . clues . fst+     <> drawShade . snd+     <> grid gStyle . fst)+  where+    gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone+    gStyle = GridStyle LineDashed LineNone (Just $ FrameStyle 8 gray)+                       VertexNone++skyscrapers ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+skyscrapers = drawers+    (g . fst <> n)+    (g . fst . fst <> placeGrid . fmap drawInt . clues . snd)+  where+    g = placeGrid . fmap drawInt . clues . outsideClues+        <> grid gDefault . outsideGrid+    n (oc, s) = placeNoteTR (outsideSize oc) (drawText s)++shikaku :: Backend' b => Drawers b (Grid C (Maybe Int)) AreaGrid+shikaku = drawers+    p+    (drawAreas . snd <> p . fst)+  where+    p = placeGrid . fmap drawInt . clues <> grid gDashed++slovaksums :: Backend' b => Drawers b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int))+slovaksums = drawers+    (p . fst <> n)+    (placeGrid . fmap drawInt . clues . snd <> p . fst . fst)+  where+    n (g, ds) = placeNoteTR (size' g) (drawText ds # scale 0.8)+    p = grid gDefault <> placeGrid . fmap drawSlovakClue . clues+    size' = size . Map.mapKeys toCoord++skyscrapersStars ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Int), Int)+                   (Grid C (Either Int Star))+skyscrapersStars = drawers+    (g <> n)+    (g . fst <> placeGrid . fmap (either drawInt drawStar) . snd)+  where+    g = (placeGrid . fmap drawInt . clues . outsideClues+         <> grid gDefault . outsideGrid) . fst+    n (oc, s) = placeNoteTR (outsideSize oc)+                          (drawInt s ||| strutX 0.2 ||| drawStar Star)++summon ::+    Backend' b =>+    Drawers b (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int))+summon = drawers+    (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 =>+    Drawers b (Grid C (Maybe Char),+                    OutsideClues C [Int],+                    OutsideClues C (Maybe Char))+                   (Grid C (Either Black Char))+baca = drawers+    (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 =>+    Drawers b (OutsideClues C (Maybe Char), String) (Grid C (Maybe Char))+buchstabensalat = drawers+    (p <> n)+    (p . fst <> placeGrid . fmap drawChar . clues . snd)+  where+    p = (placeGrid . fmap drawChar . clues . outsideClues+         <> grid gDefault . outsideGrid) . fst+    n (ocs, ls) = placeNoteTR (outsideSize ocs) (drawText ls # scale 0.8)++doppelblock ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Int))+              (Grid C (Either Black Int))+doppelblock = drawers+    (p <> n)+    (p . fst <> placeGrid . fmap drawVal . snd)+  where+    p = placeGrid . fmap (scale 0.8 . drawInt) . clues . outsideClues+        <> grid gDefault . outsideGrid+    n ocs = placeNoteTL (0, h) (drawText ds # scale 0.8)+      where+        h = snd (outsideSize ocs)+        ds = "1-" ++ show (h - 2)+    drawVal (Right c) = drawInt c+    drawVal (Left _) = fillBG gray++sudokuDoppelblock ::+    Backend' b =>+    Drawers b (AreaGrid, OutsideClues C (Maybe Int))+                   (Grid C (Either Black Int))+sudokuDoppelblock = drawers+    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 =>+    Drawers b (Grid C (Clue Int), DigitRange) AreaGrid+dominos = drawers+    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 =>+    Drawers b (Grid C (Clue Int), DigitRange, DigitRange) AreaGrid+dominoPills = drawers+    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 =>+    Drawers b (Grid C (Maybe Int)) [Edge C]+numberlink = drawers+    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 =>+          Drawers b (Grid C (Maybe MasyuPearl)) (Loop N)+loopki = drawers+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = placeGrid . fmap (scale 0.5 . pearl) . clues <> grid gSlither++scrabble :: Backend' b =>+            Drawers b (Grid C Bool, [String]) (Grid C (Maybe Char))+scrabble = drawers+    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 =>+             Drawers b (Grid C Bool, Grid C (Maybe Int)) (Grid C Int)+neighbors = drawers+    (placeGrid . fmap drawInt . clues . snd <> (grid gDefault <> drawShade) . fst)+    (placeGrid . fmap drawInt . snd <> (grid gDefault <> drawShade) . fst . fst)++starwars :: Backend' b =>+            Drawers b (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star))+starwars = drawers+    p+    (p . fst <> placeGrid . fmap drawStar . clues . snd)+  where+    p = ((drawAreas <> grid gDefault) . fst <> drawMarkedLines . snd)++starbattle :: Backend' b =>+              Drawers b (AreaGrid, Int) (Grid C (Maybe Star))+starbattle = drawers+    (p <> n)+    ((p <> n) . fst <> placeGrid . fmap drawStar . clues . snd)+  where+    p = (drawAreas <> grid gDefault) . fst+    n (g, k) = placeNoteTR (size' g)+                         (drawInt k ||| strutX 0.2 ||| drawStar Star)+    size' = size . Map.mapKeys toCoord++heyawake :: Backend' b =>+            Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Bool)+heyawake = drawers+    (as <> cs)+    (as . fst <> drawShade . snd <> cs . fst)+  where+    as = (drawAreas <> grid gDefault) . fst+    cs = placeGrid . fmap drawInt . clues . snd++wormhole :: Backend' b =>+            Drawers b (Grid C (Maybe (Either Int Char))) ()+wormhole = drawers+    (placeGrid . fmap (either drawInt drawChar) . clues <> grid gDashed)+    mempty++pentominous ::+    Backend' b =>+    Drawers b (Grid C (Maybe Char)) (Grid C Char)+pentominous = drawers+    (placeGrid . fmap drawChar . clues <> grid gDashed)+    (placeGrid . fmap drawChar . clues . fst <>+     (drawAreas <> grid gDashed) . snd)++colorakari ::+    Backend' b =>+    Drawers b (Grid C (Maybe Char)) (Grid C (Maybe Char))+colorakari = drawers+    (placeGrid . fmap drawColorClue . clues <> grid gDefault)+    (unimplemented "color akari solution")+  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 =>+    Drawers b (AreaGrid, (Grid C (Maybe MEnd))) (Loop C)+persistenceOfMemory = drawers+    (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++mappingTable :: Backend' b => [(String, String)] -> Diagram b+mappingTable = b . g+  where+    b = placeGrid . fmap drawText <> grid gPlain+    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++abctje ::+    Backend' b =>+    Drawers b (DigitRange, [(String, Int)]) [(Int, Char)]+abctje = drawers+    p+    ((mappingTable . h  ||| const (strutX 1.0) ||| mappingTable . h') . snd)+  where+    p (ds, cs) = (digNote ds `aboveT` (stackWordsLeft ws ||| strutX 1.0 ||| stackWordsRight ns))+                 `besidesR` (strutX 2.0 ||| mappingTable ps ||| strutX 1.0 ||| mappingTable 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+    h = sortOn fst . map (\(x, y) -> (y:[], show x))+    h' = map (\(x, y) -> (show x, y:[]))++kropki ::+    Backend' b =>+    Drawers b (Map.Map (Edge N) KropkiDot) (Grid C Int)+kropki = drawers+    (p <> n)+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = placeGrid' . Map.mapKeys midPoint . fmap kropkiDot <> grid gDefault . sizeGrid . sz+    n g = placeNoteTR (w, h) (drawText ds # scale 0.8)+      where+        (w, h) = sz g+        ds = "1-" ++ show h+    sz m = edgeSize (Map.keys m)++statuepark ::+    Backend' b =>+    Drawers b (Grid C (Maybe MasyuPearl)) (Grid C Bool)+statuepark = drawers+    p+    (p . fst <> drawShade . snd)+  where+    p = placeGrid . fmap pearl . clues <> grid gDashed++pentominousBorders ::+    Backend' b =>+    Drawers b (Grid C (), [Edge N]) (Grid C Char)+pentominousBorders = drawers+    (drawEdges . snd <> grid gDashed . fst)+    ((drawAreas <> grid gDashed) . snd)++smallHintRooms ::+    Backend' b =>+    (AreaGrid, Grid C (Maybe Int)) -> Diagram b+smallHintRooms = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . fmap show . clues . snd)++nanroSignpost ::+    Backend' b =>+    Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Int)+nanroSignpost = drawers+    smallHintRooms+    (placeGrid . fmap drawInt . snd <> smallHintRooms . fst)++tomTom ::+    Backend' b =>+    Drawers b (AreaGrid, Grid C (Maybe String)) (Grid C Int)+tomTom = drawers+    p+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd)++horseSnake ::+    Backend' b =>+    Drawers b (Grid C (Maybe (Either MEnd Int))) [Edge C]+horseSnake = drawers+    p+    (solstyle . drawEdges . snd <> p . fst)+  where+    p = (placeGrid . fmap (either drawBigEnd drawInt) . clues <> grid gDashed)++illumination ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N])+illumination = drawers+    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 =>+    Drawers b (Grid C (Maybe Myopia)) (Grid C Bool)+pentopia = drawers+    p+    (p . fst <> drawShade . snd)+  where+    p = placeGrid . fmap drawMyopia . clues <> grid gDefault++pentominoPipes ::+    Backend' b =>+    Drawers b (Grid N Char) (Grid N KropkiDot, [Edge N])+pentominoPipes = drawers+    (placeGrid . fmap drawCharOpaque <> grid gSlither . cellGrid)+    ((placeGrid . fmap kropkiDot . fst+      <> drawEdges . snd) . snd+     <> grid gSlither . cellGrid . fst)++greaterWall ::+    Backend' b =>+    Drawers b ([GreaterClue], [GreaterClue]) (Grid C Bool)+greaterWall = drawers+    ((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 =>+    Drawers b (Grid C (), Grid N (), Grid C (), Map.Map (Edge N) ()) AreaGrid+galaxies = drawers+    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++mines ::+    Backend' b =>+    Drawers b (Grid C (Maybe Int)) ShadedGrid+mines = drawers+    p+    (p . fst <> placeGrid . fmap (const (pearl MBlack)) . Map.filter id . snd)+  where+    p = grid gDefault <> placeGrid . fmap (\i -> drawInt i <> fillBG lightgray) . clues++tents ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Int), Grid C (Maybe Tree)) (Grid C (Maybe PlacedTent))+tents = drawers+    p+    (p . fst <> placeGrid . fmap drawTent . clues . snd)+  where+    p = placeGrid . fmap drawInt . clues . outsideClues . fst+        <> placeGrid . fmap drawTree . clues . snd+        <> grid gDashed . snd++pentominoSums :: Backend' b => Drawers b (OutsideClues C [String], String)+                               (Grid C (Either Pentomino Int), [(Char, Int)], OutsideClues C [String])+pentominoSums = drawers+    p+    (solgrid ||| const (strutX 1.0) ||| table)+  where+    p (ocs, ds) =+        (((drawMultiOutsideGrid ocs <> n (ocs, ds)) ||| strutX 1.0 ||| emptyTable ocs)+        `aboveT` drawPentominos)+    n (ocs, ds) = placeNoteTL (0, h ocs) (drawText ds # scale 0.8)+    h = snd . outsideSize+    emptyTable = mappingTable . emptys+    emptys = map (\k -> (k, "")) . nub . sort . concat . outsideValues+    solgrid =+        skel . fst3 . snd+        <> drawMultiOutsideGrid . trd3 . snd+        <> cells . fst3 . snd+    fst3 (x,_,_) = x+    trd3 (_,_,z) = z+    skel = skeletonStyle . drawEdges . skeletons . lefts+    skeletonStyle = lc white . lwG (3 * onepix)+    lefts = clues . fmap (either Just (const Nothing))+    cells = placeGrid . fmap (\v -> case v of+        Left _  -> fillBG gray+        Right x -> drawInt x)+    table ((cs, _), (_, m, _)) = mappingTable m'+      where+        m' = Map.toList (Map.union (Map.fromList a) (Map.fromList (emptys cs)))+        a = map (\(k, v) -> ([k], show v)) m++coralLits ::+    Backend' b =>+    Drawers b (OutsideClues C [String]) (Grid C (Maybe Char))+coralLits = drawers+    (\ocs -> drawMultiOutsideGrid ocs `aboveT` drawLITS)+    (skeletonStyle . drawEdges . skeletons . clues . snd+     <> drawMultiOutsideGrid . fst+     <> placeGrid . fmap (const (fillBG gray)) . clues . snd)+  where+    skeletonStyle = lc white . lwG (3 * onepix)++coralLitso ::+    Backend' b =>+    Drawers b (OutsideClues C [String]) (Grid C (Either Black Char))+coralLitso = drawers+    (\ocs -> drawMultiOutsideGrid ocs `aboveT` drawLITSO)+    (drawMultiOutsideGrid . fst+     <> skeletonStyle . drawEdges . skeletons . rights . snd+     <> placeGrid . fmap (const (fillBG gray)) . lefts . snd)+  where+    skeletonStyle = solstyle+    lefts = clues . fmap (either Just (const Nothing))+    rights = clues . fmap (either (const Nothing) Just)++snake ::+    Backend' b =>+    Drawers b (OutsideClues C (Maybe Int), Grid C (Maybe MEnd))+                   (Grid C (Maybe (Either MEnd Black)))+snake = drawers p s+  where+    cs = placeGrid . fmap drawInt . clues . outsideClues . fst+    p = cs+        <> placeGrid . fmap drawBigEnd . clues . snd+        <> grid gDefault . snd+    s = cs . fst+        <> grid gDefault . snd+        <> placeGrid . fmap (either (drawBigEnd <> gr) gr) . clues . snd+    gr = const (fillBG gray)++countryRoad ::+    Backend' b =>+    Drawers b (AreaGrid, Grid C (Maybe Int)) (Loop C)+countryRoad = drawers+    smallHintRooms+    (solstyle . drawEdges . snd <> smallHintRooms . fst)++friendlysudoku ::+    Backend' b =>+    Drawers b (Map.Map (Edge N) KropkiDot, Grid C (Maybe Int)) (Grid C Int)+friendlysudoku = drawers+    p+    (placeGrid . fmap drawInt . snd <> p . fst)+  where+    p = placeGrid' . Map.mapKeys midPoint . fmap kropkiDot . fst+      <> placeGrid . fmap drawInt . clues . snd+      <> sudokugrid . snd++japsummasyu :: Backend' b =>+          Drawers b (OutsideClues C [String]) ()+japsummasyu = drawers+    (placeMultiOutside . fmap (fmap (scale 0.8 . drawText))+                     <> grid gDashDash . outsideGrid)+    (error "japsummasyu solution not implemented")+  where+    gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone
+ src/Draw/Pyramid.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Draw.Pyramid where++import Diagrams.Prelude++import Data.Pyramid+import Draw.Elements+import Draw.Lib+import Draw.Widths++pgray :: Colour Double+pgray = blend 0.6 white black++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+clue Nothing = mempty+clue (Just c) = text' (show c)++cellc :: Backend' b => Bool -> Maybe Int -> Diagram b+cellc s c = clue c `atop` cell s++row :: Backend' b => Row -> Diagram b+row (R cs s) = centerX . hcat . map (cellc s) $ cs++pyramid :: Backend' b => Pyramid -> Diagram b+pyramid = alignBL . vcat . map row . unPyr++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 kropkiDot ks)++kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b+kpyramid = alignBL . vcat . map krow . unKP
+ src/Draw/Style.hs view
@@ -0,0 +1,50 @@+module Draw.Style+    ( LineStyle (..)+    , FrameStyle (..)+    , VertexStyle (..)+    , GridStyle (..)++    , gDefault+    , gDashed+    , gDashedThick+    , gPlain+    , gPlainDashed+    , gSlither+    ) where++import Draw.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
+ src/Draw/Widths.hs view
@@ -0,0 +1,26 @@+module Draw.Widths where++gridres :: Int+gridres = 40++gridresd :: Double+gridresd = fromIntegral gridres++onepix :: Double+onepix = 1 / fromIntegral gridres++twopix, fourpix :: Double+twopix = 2 * onepix+fourpix = 4 * onepix++gridwidth :: Double+gridwidth = onepix++framewidthfactor :: Double+framewidthfactor = 4++edgewidth :: Double+edgewidth = 3 * onepix++borderwidth :: Double+borderwidth = 1 / 4
+ src/Parse/Code.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Parse.Code where++import Data.Code+import Parse.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'))+    , fmap LRows'   <$> (v .:? "cell_rows_bottom_labeled" >>= traverse parseCharMap)+    , fmap LCols    <$> (v .:? "cell_cols_labeled" >>= traverse parseCharMap)+    , fmap LRowsN'  <$> (v .:? "node_rows_bottom_labeled" >>= traverse parseCharMap)+    , fmap LColsN   <$> (v .:? "node_cols_labeled" >>= traverse parseCharMap)+    ] +parseCode _          = fail "expected object"
+ src/Parse/Parsec.hs view
@@ -0,0 +1,30 @@+-- | Parsec helper for puzzle file parsing.+module Parse.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.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)
+ src/Parse/Puzzle.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Parse.Puzzle where++import Data.Yaml+import Control.Applicative++import Data.PuzzleTypes++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 .:? "code"+    parseJSON _          = empty++-- | A pair of parsers for a puzzle type.+-- First parses the puzzle, second the solution.+type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b)++parseType :: String -> Parser PuzzleType+parseType t = case lookupType t of+                  Nothing -> fail $ "unknown puzzle type: " ++ t+                  Just p  -> return p
+ src/Parse/PuzzleTypes.hs view
@@ -0,0 +1,507 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Parse.PuzzleTypes (+    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,+    sudoku, thermosudoku, pyramid, kpyramid, slither,+    liarslither, tightfitskyscrapers, wordloop, wordsearch,+    curvedata, doubleback, slalom, compass, boxof2or3,+    afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral,+    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, mines, tents,+    pentominoSums, coralLits, coralLitso, snake, countryRoad,+    killersudoku, friendlysudoku, japsummasyu+  ) where++import Control.Applicative+import Control.Monad++import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Yaml++import Parse.Util+import Parse.Puzzle+import Data.Grid+import Data.GridShape+import qualified Data.Pyramid as Pyr+import Data.Elements++lits :: ParsePuzzle AreaGrid (Grid C Bool)+lits = (parseGrid, parseShadedGrid)++litsplus :: ParsePuzzle AreaGrid (Grid C Bool)+litsplus = lits++geradeweg :: ParsePuzzle (Grid C (Maybe Int)) (Loop C)+geradeweg = (parseClueGrid, parseEdges)++fillomino :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int)+fillomino = (parseExtClueGrid, parseExtGrid)++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 (Grid C (Maybe Int)) (Grid C Bool)+nurikabe = (parseExtClueGrid, parseShadedGrid)++latintapa :: ParsePuzzle (Grid C (Maybe [String])) (Grid C (Maybe Char))+latintapa = ((unRG <$>) . parseJSON,+             fmap (fmap (fmap unAlpha)) . parseClueGrid')++sudoku :: ParsePuzzle (Grid C (Maybe Int)) (Grid C (Maybe Int))+sudoku = (parseClueGrid, parseClueGrid)++thermosudoku :: ParsePuzzle (Grid C (Maybe Int), [Thermometer])+                            (Grid C (Maybe Int))+thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid)++killersudoku :: ParsePuzzle (AreaGrid, Map Char Int, Grid C (Maybe Int)) (Grid C Int)+killersudoku = (,)+    (\v -> (,,)+         <$> parseFrom ["cages"] parseGrid v+         <*> parseFrom ["clues"] parseCharMap v+         <*> (parseFrom ["grid"] parseClueGrid v <|> pure Map.empty))+    parseGrid++pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol+pyramid = (parseJSON, parseJSON)++kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol+kpyramid = (parseJSON, parseJSON)++slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N)+slither = (parseClueGrid, parseEdges)++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 (Grid C (Maybe Int)) (Loop N, Grid C Bool)+liarslither = (parseClueGrid, (unLSol <$>) . parseJSON)++tightfitskyscrapers :: ParsePuzzle+                       (OutsideClues C (Maybe Int), Grid C (Tightfit ()))+                       (Grid C (Tightfit Int))+tightfitskyscrapers = (parseTightOutside, parseSpacedGrid)++newtype GridWords = GW { unGW :: (Grid C (Maybe Char), [String]) }++instance FromJSON GridWords where+    parseJSON (Object v) = GW <$> ((,) <$>+                                   (parseClueGrid =<< v .: "grid") <*>+                                   v .: "words")+    parseJSON _ = empty++wordloop :: ParsePuzzle (Grid C (Maybe Char), [String]) (Grid C (Maybe Char))+wordloop = ((unGW <$>) . parseJSON, parseClueGrid)++newtype GridMarked = GM { unGM :: (Grid C (Maybe Char), [MarkedWord]) }++instance FromJSON GridMarked where+    parseJSON (Object v) = GM <$> ((,) <$>+                                   (parseClueGrid =<< v .: "grid") <*>+                                   (map unPMW <$> v .: "words"))+    parseJSON _          = mzero++wordsearch :: ParsePuzzle (Grid C (Maybe Char), [String])+                          (Grid C (Maybe Char), [MarkedWord])+wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON)++newtype Curve = Curve { unCurve :: [Edge N] }++instance FromJSON Curve where+    parseJSON v = Curve <$> parsePlainEdges v++curvedata :: ParsePuzzle (Grid C (Maybe [Edge N])) [Edge C]+curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges)++doubleback :: ParsePuzzle AreaGrid (Loop C)+doubleback = (parseGrid, parseEdges)++slalom :: ParsePuzzle (Grid N (Maybe Int)) (Grid C SlalomDiag)+slalom = (parseClueGrid, parseGrid)++compass :: ParsePuzzle (Grid C (Maybe CompassC)) AreaGrid+compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid)++boxof2or3 :: ParsePuzzle (Grid N MasyuPearl, [Edge N]) ()+boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented")++afternoonskyscrapers :: ParsePuzzle (Grid C Shade) (Grid C (Maybe Int))+afternoonskyscrapers = (parseAfternoonGrid, parseGrid)++-- this should be changed to support clue numbers+meanderingnumbers :: ParsePuzzle AreaGrid (Grid C (Maybe Int))+meanderingnumbers = (parseGrid, parseGrid)++tapa :: ParsePuzzle (Grid C (Maybe TapaClue)) (Grid C Bool)+tapa = (\v -> fmap (fmap unParseTapaClue) . unRG <$> parseJSON v,+        parseShadedGrid)++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 C [String]) (Grid C Bool)+coral = (,)+    (fmap (fmap (map unIntString)) . parseMultiOutsideClues)+    parseShadedGrid++maximallengths :: ParsePuzzle (OutsideClues C (Maybe Int)) (Loop C)+maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v,+                  parseEdges)++primeplace :: ParsePuzzle (Grid C PrimeDiag) (Grid C Int)+primeplace = (parseIrregGrid, parseIrregGrid)++labyrinth :: ParsePuzzle (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int))+labyrinth = (p, parseClueGrid')+  where+    p v@(Object o) = tup <$> parseFrom ["grid"] parseCellEdges v <*> o .: "digits"+    p _            = mempty+    tup (x,y) z = (x,y,z)++bahnhof :: ParsePuzzle (Grid C (Maybe BahnhofClue)) [Edge C]+bahnhof = (parseClueGrid, parseEdges)++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)++{-+  parsing the mappings in order, from something like++  - 1: A+  - 3: B+  - 2: X+-}+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 :: Map a b -> Parser (a, b)+    pair m = if Map.size m == 1 then (return . head . Map.toList $ m) else empty++kropki :: ParsePuzzle (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 (), 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 . Map.mapMaybe id . fmap blankToMaybe''++mines :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool)+mines = (parseIrregGrid, parseShadedGrid)++tents :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Tree)) (Grid C (Maybe PlacedTent))+tents =+    ( p+    , fmap (fmap fromTentOrTree) . parseClueGrid+    )+  where+    fromTentOrTree :: Maybe (Either Tree PlacedTent) -> Maybe PlacedTent+    fromTentOrTree = maybe Nothing (either (const Nothing) Just)++    p v = (,)+        <$> parseFrom ["clues"] parseOut v+        <*> parseFrom ["grid"] parseClueGrid v++pentominoSums :: ParsePuzzle (OutsideClues C [String], String)+                             (Grid C (Either Pentomino Int), [(Char, Int)], OutsideClues C [String])+pentominoSums = (p, s)+  where+    p v@(Object o) = (,) <$> (fst coral) v <*> o .: "digits"+    p _ = empty+    s v = (,,) <$> parseFrom ["grid"] parseGrid v+               <*> parseFrom ["values"] values v+               <*> fst coral v+    values v = parseJSON v >>= sequence . map parseKey . Map.toList+    parseKey (k, v) = (,) <$> parseString k <*> pure v++coralLits :: ParsePuzzle (OutsideClues C [String]) (Grid C (Maybe Char))+coralLits = (,)+    (fst coral)+    (fmap (fmap (fmap unAlpha)) . parseClueGrid)++coralLitso :: ParsePuzzle (OutsideClues C [String]) (Grid C (Either Black Char))+coralLitso = (,)+    (fst coral)+    (fmap (fmap (fmap unAlpha)) . parseGrid)++snake :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe MEnd)) (Grid C (Maybe (Either MEnd Black)))+snake = (p, parseClueGrid)+  where+    p v = (,)+        <$> parseFrom ["clues"] parseOut v+        <*> parseFrom ["grid"] parseClueGrid v++countryRoad :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Loop C)+countryRoad = (,) (fst nanroSignpost) parseEdges++friendlysudoku :: ParsePuzzle (Map (Edge N) KropkiDot, Grid C (Maybe Int)) (Grid C Int)+friendlysudoku = (,) p parseGrid+  where+    p v = (\(_,c,e) -> (e,c)) <$> pp v+    pp :: Value -> Parser (Grid N (), Grid C (Maybe Int), Map.Map (Edge N) KropkiDot)+    pp = parseEdgeGrid++japsummasyu :: ParsePuzzle (OutsideClues C [String]) ()+japsummasyu = (,)+    (fmap (fmap (map unIntString)) . parseMultiOutsideClues)+    (error "japsummasyu solution not implemented")
+ src/Parse/Util.hs view
@@ -0,0 +1,783 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Parse.Util where++import Prelude hiding (mapM)++import Control.Applicative+import Control.Arrow+import Control.Monad hiding (mapM)++import Data.List (sortBy, intersect)+import Data.Maybe (catMaybes, fromMaybe, isJust, fromJust)+import Data.Ord (comparing)+import Data.Either (isRight)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.HashMap.Strict as HMap+import Data.Traversable (mapM)+import Data.Monoid ((<>))++import Data.Char (digitToInt, isAlpha, isDigit)+import Text.Read (readMaybe)+import qualified Data.Text as T++import Data.Yaml++import Data.Grid+import Data.GridShape+import Data.Elements++import Parse.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' (f:fs) (Object v) = v .: f >>= field' fs+    field' (f:_)  _          = fail $ "expected field '" ++ T.unpack f ++ "'"++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++instance FromChar Char where+    parseChar = pure++class FromString a where+    parseString :: String -> Parser a++instance FromString Char where+    parseString [c] = pure c+    parseString s = fail $ "expected a single character, got `" ++ s ++ "`"++parseStringJSON :: FromString a => Value -> Parser a+parseStringJSON v = parseJSON v >>= parseString++parseLine :: FromChar a => String -> Parser [a]+parseLine = mapM parseChar++instance FromChar Int where+    parseChar c+        | isDigit c  = digitToInt <$> parseChar c+        | otherwise  = fail $ "expected a digit, got '" ++ [c] ++ "'"++newtype Alpha = Alpha { unAlpha :: Char }+    deriving (Show, Ord, Eq)++instance FromChar Alpha where+    parseChar c+        | isAlpha c  = Alpha <$> parseChar c+        | otherwise  = fail $ "expected a letter"++-- | Helper to parse strings from number-formatted YAML fields.+--   Somewhat dodgy.+newtype IntString = IntString { unIntString :: String }++instance FromJSON IntString where+    parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v+    parseJSON v            = IntString <$> parseJSON v++-- | A rectangle. Each row has length `w`.+data Rect a = Rect !Int !Int [[a]]+    deriving Show++instance Functor Rect where+    fmap f (Rect w h ls) = Rect w h (map (map f) ls)++instance FromChar a => FromJSON (Rect a) where+    parseJSON (String t) = Rect w h <$> filled+      where+        ls = map T.stripEnd . T.lines $ t+        w = maximum . map T.length $ ls+        h = length ls+        filledc = map (T.unpack . T.justifyLeft w ' ') ls+        filled = mapM (mapM parseChar) filledc+    parseJSON _          = fail "expected string"++data Border a = Border [a] [a] [a] [a]+    deriving Show++-- | This instance might be a lie.+instance Foldable Border where+    foldMap f (Border l r b t) = foldMap f l <> foldMap f r+                              <> foldMap f b <> foldMap f t++instance Traversable Border where+    sequenceA (Border l r b t) = Border <$> sequenceA l+                                        <*> sequenceA r+                                        <*> sequenceA b+                                        <*> sequenceA t++instance Functor Border where+    f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t)++data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b)+    deriving Show++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 = parseBorderedRect parseChar parseChar++newtype SpacedRect a = SpacedRect { unSpaced :: Rect a }++instance FromString a => FromJSON (SpacedRect a) where+    parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p+                                        else empty+      where+        ls = map T.words . T.lines $ t+        w = maximum . map length $ ls+        wmin = minimum . map length $ ls+        h = length ls+        p = mapM (mapM (parseString . T.unpack)) ls+    parseJSON _          = empty++instance FromChar () where+    parseChar = fmap (const ()) . chars ['.', ' ']++data Space = Space++instance FromChar Space where+    parseChar = fmap (const Space) . char ' '++data Blank = Blank+data Blank' = Blank'+data Blank'' = Blank''+data Empty = Empty++instance FromChar Blank where+    parseChar = fmap (const Blank) . char '.'++parseCharJSON :: FromChar a => Value -> Parser a+parseCharJSON v = do+    [c] <- parseJSON v+    parseChar c++instance FromJSON Blank where+   parseJSON = parseCharJSON++instance FromChar Blank' where+    parseChar = fmap (const Blank') . chars ['.', '-']++instance FromJSON Blank' where+    parseJSON (String ".") = pure Blank'+    parseJSON (String "-") = pure Blank'+    parseJSON _            = fail "expected '.-'"++instance FromChar Blank'' where+    parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|']++instance FromChar Empty where+    parseChar = fmap (const Empty) . char ' '++instance FromString Blank where+    parseString "." = pure Blank+    parseString _   = fail "expected '.'"++instance FromChar PlainNode where+    parseChar = fmap (const PlainNode) . char 'o'++instance FromChar MasyuPearl where+    parseChar = fmap f . chars ['*', 'o']+      where+        f '*' = MBlack+        f 'o' = MWhite+        f _   = impossible++instance FromChar SlalomDiag where+    parseChar '/'  = pure SlalomForward+    parseChar '\\' = pure SlalomBackward+    parseChar _    = empty++instance FromChar Black where+    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 Tree where+    parseChar = fmap (const Tree) . char '*'++instance FromChar PlacedTent where+    parseChar = fmap Tent . parseChar++instance FromChar Pentomino where+    parseChar c =+        if c `elem` ("FILNPTUVWXYZ" :: String) then+            pure (Pentomino c)+        else+            fail "expected FILNPTUVWXYZ"++instance (FromChar a, FromChar b) => FromChar (Either a b) where+    parseChar c = Left <$> parseChar c <|> Right <$> parseChar c++instance (FromString a, FromString b) => FromString (Either a b) where+    parseString c = Left <$> parseString c <|> Right <$> parseString c++newtype Either' a b = Either' { unEither' :: Either a b }++instance (FromChar a, FromChar b) => FromChar (Either' a b) where+    parseChar c = Either' <$> parseChar c++instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where+    parseJSON v = Either' <$>+                      (Left <$> parseJSON v <|> Right <$> parseJSON v)++instance FromChar a => FromChar (Maybe a) where+    parseChar = optional . parseChar++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++rectToCoordGrid :: Rect a -> Grid Coord a+rectToCoordGrid (Rect _ _ ls) = listListToMap ls++blankToMaybe :: Either Blank a -> Maybe a+blankToMaybe = either (const Nothing) Just++blankToMaybe' :: Either Blank' a -> Maybe a+blankToMaybe' = either (const Nothing) Just++blankToMaybe'' :: Either Blank'' a -> Maybe a+blankToMaybe'' = either (const Nothing) Just++rectToIrregGrid :: Rect (Either Empty a) -> Grid Coord a+rectToIrregGrid = fmap fromRight . Map.filter isRight . rectToCoordGrid+  where+    fromRight (Right r) = r+    fromRight _         = impossible++newtype Shaded = Shaded { unShaded :: Bool }++instance FromChar Shaded where+    parseChar 'x'  = pure . Shaded $ True+    parseChar 'X'  = pure . Shaded $ True+    parseChar _    = pure . Shaded $ False++parseShadedGrid :: Key k => Value -> Parser (Grid k Bool)+parseShadedGrid v = fmap unShaded <$> parseGrid v++parseCoordGrid :: (FromChar a)+               => Value -> Parser (Grid Coord a)+parseCoordGrid v = rectToCoordGrid <$> parseJSON v++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' :: (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++parseExtGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k a)+parseExtGrid = parseExtGrid' id++parseExtClueGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k (Maybe a))+parseExtClueGrid v = fmap blankToMaybe <$> parseExtGrid' Right v++fromCoordGrid :: Key k => Grid Coord a -> Grid k a+fromCoordGrid = Map.mapKeys fromCoord++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 :: Key k => Value -> Parser [Edge k]+parsePlainEdges v = filterPlainEdges <$> parseAnnotatedEdges v++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++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.+--+-- E.g. o-*-*-o+--      |1|2 3+--      *-o+-- 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 <*>+                  parseAnnotatedEdges v+  where+    parseBoth = do+        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 m =+        (fromCoordGrid . divkeys $ mnode, fromCoordGrid . divkeys $ mcell)+      where+        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+--      | |+--      *-o+-- to a grid of masyu pearls and some edges.+parseNodeEdges :: FromChar a =>+                  Value -> Parser (Grid N a, [Edge N])+parseNodeEdges v = proj13 <$> parsePlainEdgeGrid v+  where+    proj13 :: (Grid N a, Grid C Char, [Edge N])+              -> (Grid N a, [Edge N])+    proj13 (x,_,z) = (x,z)++parseCellEdges :: FromChar a =>+                  Value -> Parser (Grid C a, [Edge N])+parseCellEdges v = proj23 <$> parsePlainEdgeGrid v+  where+    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` ("└┴├┼" :: String) = pure . HalfDirs $ [Vert, Horiz]+                | c `elem` ("│┘┤"  :: String) = pure . HalfDirs $ [Vert]+                | c `elem` ("─┌┬"  :: String) = pure . HalfDirs $ [Horiz]+                | otherwise                   = pure . HalfDirs $ []++-- parses a string like+--  ┌┐┌─┐+--  ││└┐│+--  │└─┘│+--  └──┐│+--     └┘+parseBoxEdges :: Key k => Value -> Parser [Edge k]+parseBoxEdges v = do+    m <- fmap unHalfDirs <$> parseGrid v+    return [ E p d | (p, ds) <- Map.toList m, d <- ds ]++parseEdges :: Key k => Value -> Parser [Edge k]+parseEdges v = parsePlainEdges v <|> parseBoxEdges v++instance FromChar Dir' where+    parseChar 'u' = pure U+    parseChar 'U' = pure U+    parseChar 'd' = pure D+    parseChar 'D' = pure D+    parseChar 'r' = pure R+    parseChar 'R' = pure R+    parseChar 'l' = pure L+    parseChar 'L' = pure L+    parseChar _   = fail "expected 'uUdDrRlL'"++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 :: Grid C Alpha -> Parser [Thermometer]+parseThermos m = catMaybes <$> mapM parseThermo (Map.keys m')+  where+    m' = fmap unAlpha m+    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' :: C -> Parser Thermometer+    parseThermo' p = do+        q <- next p+        maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q+    parseThermo'' :: C -> Parser Thermometer+    parseThermo'' p = do+        q <- next p+        maybe (pure [p]) (fmap (p:) . parseThermo'') q+    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 $ 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 $ p+      where+        disjointSucc q = null $ intersect (succs p) (succs' q)+        succs' q = maybe [] (const $ succs q) (Map.lookup q m')++parseThermoGrid :: ThermoRect -> Parser (Grid C (Maybe Int), [Thermometer])+parseThermoGrid (Rect _ _ ls) = (,) ints+                              <$> parseThermos alphas+  where+    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+    parseChar '.'  = pure . Tight $ Single ()+    parseChar '/'  = pure . Tight $ UR () ()+    parseChar '\\' = pure . Tight $ DR () ()+    parseChar _    = empty++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+    parseString [c, '/',d]    = UR <$> parseChar c <*> parseChar d+    parseString [c,'\\',d]    = DR <$> parseChar c <*> parseChar d+    parseString _             = empty++newtype PMarkedWord = PMW {unPMW :: MarkedWord}++parseNWords :: Int -> String -> Parser [String]+parseNWords n s | length ws == n  = pure ws+                | otherwise       = empty+  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 . 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+    parseJSON (String t) = comp . map T.unpack . T.words $ t+        where c "." = pure Nothing+              c x   = Just <$> parseString x+              comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w)+              comp _            = empty+    parseJSON _          = empty++newtype PSlovakClue = PSlovakClue {unPSlovakClue :: SlovakClue}++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"++newtype RefGrid k a = RefGrid { unRG :: Grid k (Maybe a) }++hashmaptomap :: Ord a => HMap.HashMap a b -> Map.Map a b+hashmaptomap = Map.fromList . HMap.toList++compose :: Ord b => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c)+compose m1 m2 = mapM (`Map.lookup` m2) m1++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 m'++parseAfternoonGrid :: Value -> Parser (Grid C Shade)+parseAfternoonGrid v = do+    (_, g, es) <- parsePlainEdgeGrid v+                  :: Parser (Grid N Char, Grid C Char, [Edge N])+    return $ toMap g es+  where+    toShade Vert  = Shade False True+    toShade Horiz = Shade True  False+    merge (Shade a b) (Shade c d) = Shade (a || c) (b || d)+    toMap g es = Map.fromListWith+        merge+        ([(fromCoord . toCoord $ p, toShade d) | E p d <- es]+         ++ [(p, Shade False False) | p <- Map.keys g])++newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue }++instance FromJSON ParseTapaClue where+    parseJSON v = do xs <- parseJSON v+                     guard $ length xs > 0 && length xs <= 4+                     return . ParseTapaClue . TapaClue $ xs++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 k a)+parseCharOutside (Object v) = reorientOutside <$>+                              (OC <$>+                               pfield "left" <*> pfield "right" <*>+                               pfield "bottom" <*> pfield "top" )+  where+    pfield f = parseLine . fromMaybe [] =<< v .:? f+parseCharOutside _          = empty++parseOutside :: FromJSON a => Value -> Parser (OutsideClues k a)+parseOutside (Object v) = reorientOutside <$>+                              (OC <$>+                               pfield "left" <*> pfield "right" <*>+                               pfield "bottom" <*> pfield "top" )+  where+    pfield f = pure . fromMaybe [] =<< v .:? f+parseOutside _          = empty++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"+    v' `ml` k = fromMaybe [] <$> v' .:? k+    rev (OC l r b t) = reorientOutside $+                       OC (map reverse l) r b (map reverse t)+parseMultiOutsideClues _ = empty++instance FromChar PrimeDiag where+    parseChar '.'  = pure $ PrimeDiag (False, False)+    parseChar '/'  = pure $ PrimeDiag (True,  False)+    parseChar '\\' = pure $ PrimeDiag (False, True)+    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
− src/Text/Puzzles/Puzzle.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Puzzles.Puzzle where--import Data.Yaml-import Control.Applicative--import Data.Puzzles.PuzzleTypes--data TypedPuzzle = TP (Maybe String) Value (Maybe Value)-    deriving Show--instance FromJSON TypedPuzzle where-    parseJSON (Object v) = TP <$>-                           v .:? "type" <*>-                           v .:  "puzzle" <*>-                           v .:? "solution"-    parseJSON _          = empty---- | A pair of parsers for a puzzle type.--- First parses the puzzle, second the solution.-type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b)--parseType :: String -> Parser PuzzleType-parseType t = case lookupType t of-                  Nothing -> fail $ "unknown puzzle type: " ++ t-                  Just p  -> return p
− src/Text/Puzzles/PuzzleTypes.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Puzzles.PuzzleTypes (-    lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa,-    sudoku, thermosudoku, pyramid, kpyramid, slither,-    liarslither, tightfitskyscrapers, wordloop, wordsearch,-    curvedata, doubleback, slalom, compass, boxof2or3,-    afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral,-    maximallengths, primeplace, labyrinth, bahnhof, cave-  ) where--import Control.Applicative-import Control.Monad--import Data.Yaml--import Text.Puzzles.Util-import Text.Puzzles.Puzzle-import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)-import qualified Data.Puzzles.Pyramid as Pyr-import Data.Puzzles.Elements--lits :: ParsePuzzle AreaGrid ShadedGrid-lits = (parseGrid, parseShadedGrid)--litsplus :: ParsePuzzle AreaGrid ShadedGrid-litsplus = lits--geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop-geradeweg = (parseClueGrid, parseEdges)--fillomino :: ParsePuzzle IntGrid (SGrid Int)-fillomino = (parseClueGrid, parseExtGrid)--masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop-masyu = (parseClueGrid, parseEdges)--nurikabe :: ParsePuzzle IntGrid ShadedGrid-nurikabe = (parseSpacedClueGrid, parseShadedGrid)--latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char))-latintapa = ((unRG <$>) . parseJSON,-             fmap (fmap (fmap unAlpha)) . parseClueGrid')--sudoku :: ParsePuzzle IntGrid IntGrid-sudoku = (parseClueGrid, parseClueGrid)--thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid-thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid)--pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol-pyramid = (parseJSON, parseJSON)--kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol-kpyramid = (parseJSON, parseJSON)--slither :: ParsePuzzle (SGrid (Clue Int)) Loop-slither = (parseClueGrid, parseEdges)--newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) }-instance FromJSON LSol where-    parseJSON (Object v) = LSol <$> ((,) <$>-                           (parseEdges =<< v .: "loop") <*>-                           (parseShadedGrid =<< v .: "liars"))-    parseJSON _          = mzero--liarslither :: ParsePuzzle (SGrid (Clue Int)) (Loop, SGrid Bool)-liarslither = (parseClueGrid, (unLSol <$>) . parseJSON)--tightfitskyscrapers :: ParsePuzzle-                       (OutsideClues (Maybe Int), SGrid (Tightfit ()))-                       (SGrid (Tightfit Int))-tightfitskyscrapers = (parseTightOutside, parseTightIntGrid)--newtype GridWords = GW { unGW :: (CharClueGrid, [String]) }--instance FromJSON GridWords where-    parseJSON (Object v) = GW <$> ((,) <$>-                                   (parseClueGrid =<< v .: "grid") <*>-                                   v .: "words")-    parseJSON _ = empty--wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid-wordloop = ((unGW <$>) . parseJSON, parseClueGrid)--newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) }--instance FromJSON GridMarked where-    parseJSON (Object v) = GM <$> ((,) <$>-                                   (parseClueGrid =<< v .: "grid") <*>-                                   (map unPMW <$> v .: "words"))-    parseJSON _          = mzero--wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord])-wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON)--newtype Curve = Curve { unCurve :: [Edge] }--instance FromJSON Curve where-    parseJSON v = Curve <$> parsePlainEdges v--curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge]-curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges)--doubleback :: ParsePuzzle AreaGrid Loop-doubleback = (parseGrid, parseEdges)--slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag)-slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v)--compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid-compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid)--boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) ()-boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented")--afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid-afternoonskyscrapers = (parseAfternoonGrid, parseGrid)---- this should be changed to support clue numbers-meanderingnumbers :: ParsePuzzle AreaGrid IntGrid-meanderingnumbers = (parseGrid, parseGrid)--tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid-tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v,-        parseShadedGrid)--japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid (Either Black Int))-japanesesums = (parseMultiOutsideClues, parseGrid)--coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid-coral = (,)-    (fmap (fmap (map unIntString)) . parseMultiOutsideClues)-    parseShadedGrid--maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop-maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v,-                  parseEdges)--primeplace :: ParsePuzzle (SGrid PrimeDiag) (SGrid Int)-primeplace = (parseIrregGrid, parseIrregGrid)--labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int))-labyrinth = (parseCellEdges, parseClueGrid')--bahnhof :: ParsePuzzle (SGrid (Maybe BahnhofClue)) [Edge]-bahnhof = (parseClueGrid, parseEdges)--cave :: ParsePuzzle (SGrid (Clue Int)) ShadedGrid-cave = (parseClueGrid, parseShadedGrid)
− src/Text/Puzzles/Util.hs 
@@ -1,583 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Text.Puzzles.Util where--import Prelude hiding (mapM)--import Control.Applicative-import Control.Arrow-import Control.Monad hiding (mapM)--import Data.Hashable-import Data.Maybe (catMaybes, fromMaybe)-import qualified Data.Map as Map-import qualified Data.HashMap.Strict as HMap-import Data.Traversable (traverse, sequenceA, mapM, Traversable)-import Data.Foldable (Foldable, foldMap)-import Data.Monoid ((<>))-import Data.List (intersect)--import Data.Char (digitToInt, isAlpha, isDigit)-import Text.Read (readMaybe)-import qualified Data.Text as T--import Data.Yaml--import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (size)-import Data.Puzzles.Elements--type Path = [String]--field :: Path -> Value -> Parser Value-field = field' . map T.pack-  where-    field' [] v                = pure v-    field' (f:fs) (Object v) = v .: f >>= field' fs-    field' _  _                = empty--parseFrom :: Path -> (Value -> Parser b) -> (Value -> Parser b)-parseFrom fs p v = field fs v >>= p--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--parseLine :: FromChar a => String -> Parser [a]-parseLine = mapM parseChar--instance FromChar Int where-    parseChar c-        | isDigit c  = digitToInt <$> parseChar c-        | otherwise  = fail $ "expected a digit, got '" ++ [c] ++ "'"--newtype Alpha = Alpha { unAlpha :: Char }-    deriving (Show, Ord, Eq)--instance FromChar Alpha where-    parseChar c-        | isAlpha c  = Alpha <$> parseChar c-        | otherwise  = empty---- | Helper to parse strings from number-formatted YAML fields.---   Somewhat dodgy.-newtype IntString = IntString { unIntString :: String }--instance FromJSON IntString where-    parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v-    parseJSON v            = IntString <$> parseJSON v---- | A rectangle. Each row has length `w`.-data Rect a = Rect !Int !Int [[a]]-    deriving Show--instance Functor Rect where-    fmap f (Rect w h ls) = Rect w h (map (map f) ls)--instance FromChar a => FromJSON (Rect a) where-    parseJSON (String t) = Rect w h <$> filled-      where-        ls = map T.stripEnd . T.lines $ t-        w = maximum . map T.length $ ls-        h = length ls-        filledc = map (T.unpack . T.justifyLeft w ' ') ls-        filled = mapM (mapM parseChar) filledc-    parseJSON _          = fail "expected string"--data Border a = Border [a] [a] [a] [a]-    deriving Show---- | This instance might be a lie.-instance Foldable Border where-    foldMap f (Border l r b t) = foldMap f l <> foldMap f r-                              <> foldMap f b <> foldMap f t--instance Traversable Border where-    sequenceA (Border l r b t) = Border <$> sequenceA l-                                        <*> sequenceA r-                                        <*> sequenceA b-                                        <*> sequenceA t--instance Functor Border where-    f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t)--data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b)-    deriving Show--instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where-    parseJSON v = do-        Rect w h ls <- parseJSON v-        let b = Border (reverse . map head . middle h $ ls)-                       (reverse . map last . middle h $ ls)-                       (middle w . last $ ls)-                       (middle w . head $ ls)-            ls' = map (middle w) . middle h $ ls-        mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls)-              [head . head, head . last, last . head, last . last]-        lsparsed <- mapM (mapM parseChar) ls'-        bparsed  <- mapM parseChar b-        return $ BorderedRect (w-2) (h-2) lsparsed bparsed-      where-        middle len = take (len - 2) . drop 1--newtype SpacedRect a = SpacedRect { unSpaced :: Rect a }--instance FromString a => FromJSON (SpacedRect a) where-    parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p-                                        else empty-      where-        ls = map T.words . T.lines $ t-        w = maximum . map length $ ls-        wmin = minimum . map length $ ls-        h = length ls-        p = mapM (mapM (parseString . T.unpack)) ls-    parseJSON _          = empty--data Space = Space--instance FromChar Space where-    parseChar ' ' = pure Space-    parseChar _   = empty--data Blank = Blank-data Blank' = Blank'-data Empty = Empty--instance FromChar Blank where-    parseChar '.' = pure Blank-    parseChar _   = empty--parseCharJSON :: FromChar a => Value -> Parser a-parseCharJSON v = do-    [c] <- parseJSON v-    parseChar c--instance FromJSON Blank where-   parseJSON = parseCharJSON--instance FromChar Blank' where-    parseChar '.' = pure Blank'-    parseChar '-' = pure Blank'-    parseChar _   = empty--instance FromJSON Blank' where-    parseJSON (String ".") = pure Blank'-    parseJSON (String "-") = pure Blank'-    parseJSON _            = empty--instance FromChar Empty where-    parseChar ' ' = pure Empty-    parseChar _   = empty--instance FromString Blank where-    parseString "." = pure Blank-    parseString _   = empty--data PlainNode = PlainNode--instance FromChar PlainNode where-    parseChar 'o' = pure PlainNode-    parseChar _   = empty--instance FromChar MasyuPearl where-    parseChar '*' = pure MBlack-    parseChar 'o' = pure MWhite-    parseChar c   = failChar c "'*' or 'o'"--instance FromChar SlalomDiag where-    parseChar '/'  = pure SlalomForward-    parseChar '\\' = pure SlalomBackward-    parseChar _    = empty--instance FromChar Black where-    parseChar 'X' = pure Black-    parseChar 'x' = pure Black-    parseChar _   = empty--instance (FromChar a, FromChar b) => FromChar (Either a b) where-    parseChar c = Left <$> parseChar c <|> Right <$> parseChar c--instance (FromString a, FromString b) => FromString (Either a b) where-    parseString c = Left <$> parseString c <|> Right <$> parseString c--newtype Either' a b = Either' { unEither' :: Either a b }--instance (FromChar a, FromChar b) => FromChar (Either' a b) where-    parseChar c = Either' <$> parseChar c--instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where-    parseJSON v = Either' <$>-                      (Left <$> parseJSON v <|> Right <$> parseJSON v)--instance FromChar a => FromChar (Maybe a) where-    parseChar = optional . parseChar--listListToMap :: [[a]] -> Map.Map (Cell Square) a-listListToMap ls = Map.fromList . concat-                 . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..]-                 $ ls-  where-    h = length ls--rectToSGrid :: Rect a -> SGrid a-rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls)--blankToMaybe :: Either Blank a -> Maybe a-blankToMaybe = either (const Nothing) Just--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--rectToIrregGrid :: Rect (Either Empty a) -> SGrid a-rectToIrregGrid = fmap fromRight . filterG isRight . rectToSGrid-  where-    isRight = either (const False) (const True)-    fromRight (Right r) = r-    fromRight _         = error "no way"--newtype Shaded = Shaded { unShaded :: Bool }--instance FromChar Shaded where-    parseChar 'x'  = pure . Shaded $ True-    parseChar 'X'  = pure . Shaded $ True-    parseChar _    = pure . Shaded $ False--parseShadedGrid :: Value -> Parser (SGrid Bool)-parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v--parseGrid :: FromChar a => Value -> Parser (SGrid a)-parseGrid v = rectToSGrid <$> parseJSON v--parseGridWith :: (Char -> Parser a) -> Value -> Parser (SGrid 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)--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-    parseFrom ["grid"] (parseGridWith-                        (parseWithReplacement (`Map.lookup` repl))) v--parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a))-parseClueGrid v = rectToClueGrid <$> parseJSON v--parseClueGrid' :: FromChar a => Value -> Parser (SGrid (Clue a))-parseClueGrid' v = rectToClueGrid' <$> parseJSON v--parseIrregGrid :: FromChar a => Value -> Parser (SGrid a)-parseIrregGrid v = rectToIrregGrid <$> parseJSON v--parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a))-parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v---- parses a string like---  o-o-o---  |   |---  o-o o---    | |---    o-o-parsePlainEdges :: Value -> Parser [Edge]-parsePlainEdges v = readEdges <$> parseGrid v--readEdges :: SGrid Char -> [Edge]-readEdges g = horiz ++ vert-    where (w, h) = size g-          w' = w `div` 2-          h' = h `div` 2-          isHoriz (x, y) = g ! (2 * x + 1, 2 * y) == '-'-          isVert  (x, y) = g ! (2 * x, 2 * y + 1) == '|'-          horiz = [ E (x, y) H | x <- [0 .. w' - 1]-                               , y <- [0 .. h']-                               , isHoriz (x, y)-                               ]-          vert =  [ E (x, y) V | x <- [0 .. w']-                               , y <- [0 .. h' - 1]-                               , isVert (x, y)-                               ]--parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a)-parseGridChars = traverse parseChar---- | Parse a grid with edges and values at nodes and in cells.------ 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])-parseEdgeGrid v = uncurry (,,) <$>-                  parseBoth <*>-                  parsePlainEdges v-  where-    parseBoth = do-        g <- parseGrid v-        (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"-      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))---- | Parse a grid of edges with values at the nodes.------ E.g. o-*-*-o---      | |---      *-o--- to a grid of masyu pearls and some edges.-parseNodeEdges :: FromChar a =>-                  Value -> Parser (SGrid a, [Edge])-parseNodeEdges v = proj13 <$> parseEdgeGrid v-  where-    proj13 :: (SGrid a, SGrid Empty, [Edge]) -> (SGrid a, [Edge])-    proj13 (x,_,z) = (x,z)--parseCellEdges :: FromChar a =>-                  Value -> Parser (SGrid a, [Edge])-parseCellEdges v = proj23 <$> parseEdgeGrid v-  where-    proj23 :: (SGrid PlainNode, SGrid a, [Edge]) -> (SGrid a, [Edge])-    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 $ []---- parses a string like---  ┌┐┌─┐---  ││└┐│---  │└─┘│---  └──┐│---     └┘-parseEdges :: Value -> Parser [Edge]-parseEdges v = do-    Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v-    return [ E p d | (p, ds) <- Map.toList m, d <- ds ]--type ThermoRect = Rect (Either Blank (Either Int Alpha))--partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b)-partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty)-  where-    insertEither k = either (first . Map.insert k) (second . Map.insert k)--parseThermos :: SGrid Alpha -> Parser [Thermometer]-parseThermos (Grid s m) = catMaybes <$> mapM parseThermo (Map.keys m)-  where-    m' = fmap unAlpha m-    parseThermo :: Cell Square -> Parser (Maybe Thermometer)-    parseThermo p | not (isStart p)           = pure Nothing-                  | not (isAlmostIsolated p)  = fail $ show p ++ " not almost isolated"-                  | otherwise                 = Just <$> parseThermo' p-    parseThermo' :: Cell Square -> Parser Thermometer-    parseThermo' p = do-        q <- next p-        maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q-    parseThermo'' :: Cell Square -> Parser Thermometer-    parseThermo'' p = do-        q <- next p-        maybe (pure [p]) (fmap (p:) . parseThermo'') q-    next :: Cell Square -> Parser (Maybe (Cell Square))-    next p = case succs p of-        []   -> pure Nothing-        [q]  -> pure (Just q)-        _    -> fail "multiple successors"-    succs      p = filter    (test ((==) . succ) p) . vertexNeighbours s $ p-    isStart    p = not . any (test ((==) . pred) p) . vertexNeighbours s $ p-    test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m')-    isAlmostIsolated p = all disjointSucc . vertexNeighbours s $ p-      where-        disjointSucc q = null $ intersect (succs p) (succs' q)-        succs' q = maybe [] (const $ succs q) (Map.lookup q m')--parseThermoGrid :: ThermoRect -> Parser (SGrid Int, [Thermometer])-parseThermoGrid (Rect w h ls) = (,) (Grid s ints)-                              <$> parseThermos (Grid s alphas)-  where-    s = Square w h-    (ints, alphas) = partitionEithers . snd . partitionEithers $-                     listListToMap ls--newtype Tight = Tight { unTight :: Tightfit () }--instance FromChar Tight where-    parseChar '.'  = pure . Tight $ Single ()-    parseChar '/'  = pure . Tight $ UR () ()-    parseChar '\\' = pure . Tight $ DR () ()-    parseChar _    = empty--parseTightOutside :: Value -> Parser (OutsideClues (Maybe Int),-                                      SGrid (Tightfit ()))-parseTightOutside v = do-    BorderedRect w h ls b <- parseJSON v-        :: Parser (BorderedRect Tight (Either Blank' Int))-    return (outside . fmap (either (const Nothing) Just) $ b,-            fmap unTight . rectToSGrid $ Rect w h ls)-  where outside (Border l r b t) = OC l r b t--instance FromChar a => FromString (Tightfit a) where-    parseString [c]           = Single <$> parseChar c-    parseString [c, '/',d]    = UR <$> parseChar c <*> parseChar d-    parseString [c,'\\',d]    = DR <$> parseChar c <*> parseChar d-    parseString _             = empty--parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int))-parseTightIntGrid v = rectToSGrid . unSpaced <$> parseJSON v--newtype PMarkedWord = PMW {unPMW :: MarkedWord}--parseNWords :: Int -> String -> Parser [String]-parseNWords n s | length ws == n  = pure ws-                | otherwise       = empty-  where-    ws = words s--instance FromJSON PMarkedWord where-    parseJSON v = PMW <$> (MW <$>-                  ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*>-                  ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)))-        where x = parseJSON v >>= parseNWords 4 >>= mapM parseString--instance FromString Int where-    parseString s = maybe empty pure $ readMaybe s--newtype PCompassC = PCC {unPCC :: CompassC}--instance FromJSON PCompassC where-    parseJSON (String t) = comp . map T.unpack . T.words $ t-        where c "." = pure Nothing-              c x   = Just <$> parseString x-              comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w)-              comp _            = empty-    parseJSON _          = empty--newtype RefGrid a = RefGrid { unRG :: SGrid a }--data Ref = Ref { unRef :: Char }-    deriving Show--instance FromChar Ref where-    parseChar c | isAlpha c = pure (Ref c)-    parseChar _             = empty--hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b-hashmaptomap = Map.fromList . HMap.toList--compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c)-compose m1 m2 = 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-            Nothing -> mzero-            Just m' -> return $ Grid s m'-    parseJSON _ = empty--parseAfternoonGrid :: Value -> Parser (SGrid Shade)-parseAfternoonGrid v = do-    (Grid s _ , es) <- parseNodeEdges v :: Parser (SGrid Char, [Edge])-    let (m, b) = splitBorder s $ toMap es-    guard $ Map.null b-    return $ Grid (shrink s) m-  where-    shrink (Square w h) = Square (w-1) (h-1)-    toShade V = Shade False True-    toShade H = Shade True  False-    merge (Shade a b) (Shade c d)-        | a && c || b && d  = error "shading collision"-        | otherwise         = Shade (a || c) (b || d)-    toMap es = Map.fromListWith-        merge-        [(p, toShade d) | E p d <- es]-    splitBorder (Square w h) = Map.partitionWithKey-        (\(x, y) _ -> x < w - 1 && y < h - 1)--newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue }--instance FromJSON ParseTapaClue where-    parseJSON v = do xs <- parseJSON v-                     guard $ length xs > 0 && length xs <= 4-                     return . ParseTapaClue . TapaClue $ xs--reorientOutside :: OutsideClues a -> OutsideClues a-reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t--parseCharOutside :: FromChar a => Value -> Parser (OutsideClues a)-parseCharOutside (Object v) = reorientOutside <$>-                              (OC <$>-                               pfield "left" <*> pfield "right" <*>-                               pfield "bottom" <*> pfield "top" )-  where-    pfield f = parseLine . fromMaybe [] =<< v .:? f-parseCharOutside _          = empty--parseOutside :: FromJSON a => Value -> Parser (OutsideClues a)-parseOutside (Object v) = reorientOutside <$>-                              (OC <$>-                               pfield "left" <*> pfield "right" <*>-                               pfield "bottom" <*> pfield "top" )-  where-    pfield f = pure . fromMaybe [] =<< v .:? f-parseOutside _          = empty--parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a])-parseMultiOutsideClues (Object v) = rev <$> raw-  where-    raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top"-    v' `ml` k = fromMaybe [] <$> v' .:? k-    rev (OC l r b t) = reorientOutside $-                       OC (map reverse l) r b (map reverse t)-parseMultiOutsideClues _ = empty--instance FromChar PrimeDiag where-    parseChar '.'  = pure $ PrimeDiag (False, False)-    parseChar '/'  = pure $ PrimeDiag (True,  False)-    parseChar '\\' = pure $ PrimeDiag (False, True)-    parseChar 'X'  = pure $ PrimeDiag (True,  True)-    parseChar _    = empty--instance FromChar Crossing where-    parseChar '+' = pure Crossing-    parseChar _   = fail "expected '+'"
+ src/tools/checkpuzzle.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleContexts #-}++module Main where++import Parse.Puzzle+import Data.PuzzleTypes (typeNames, PuzzleType(..))+import Data.CmdLine (exitErr, readPuzzle, checkType)++import Data.Elements (KropkiDot(..), digitList)+import Data.GridShape (Edge, N, C, rows, edgesM, unorient, ends, dualE)+import Data.Grid (Grid)+import qualified Parse.PuzzleTypes as T++import Options.Applicative+import Control.Monad+import Data.Maybe+import qualified Data.Map.Strict as Map+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)+        Kropki -> checkKropki (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++checkKropki :: (Y.Value, Y.Value) -> Y.Parser [String]+checkKropki (pv, sv) = do+    p <- fst T.kropki $ pv+    s <- snd T.kropki $ sv+    return . catMaybes . map (\c -> c p s) $+        [ match, latin, dots ]+  where+    match :: Map.Map (Edge N) KropkiDot -> Grid C Int -> Maybe String+    match p s = if solEdges == puzEdges then+                    Nothing+                else+                    Just "puzzle and solution shape don't match"+      where+        solEdges = let+            (outer, inner) = edgesM s+          in+            sort (inner ++ map unorient outer)+        puzEdges = sort (Map.keys p)+    latin _ s = either Just (const Nothing) . mapM_ latinRow . rows $ s+    latinRow ds = if sort ds == [1 .. length ds] then+                      Right ()+                  else+                      Left $ "row not 1..N: " ++ show ds+    dots p s = either Just (const Nothing) . mapM_ (checkEdge s) . Map.toList $ p+    checkEdge :: Grid C Int -> (Edge N, KropkiDot) -> Either String ()+    checkEdge s (e, d) =+      let+        (a, b) = ends (dualE e)+        okDot x y =+          let+            white = x - y == 1 || x - y == -1+            black = x == y * 2 || y == x * 2+          in+            case d of+                KBlack -> black+                KWhite -> white+                KNone  -> not black && not white+      in+        case (Map.lookup a s, Map.lookup b s) of+            (Just x, Just y) -> if okDot x y then Right () else Left ("bad dot between: " ++ show a ++ "," ++ show b)+            _                -> if d == KNone then Right () else Left "dot on the edge"
src/tools/drawpuzzle.hs view
@@ -2,14 +2,17 @@  module Main where -import Diagrams.Prelude hiding (value, option, (<>), Result)+import Diagrams.Prelude hiding (value, option, (<>), Result, render) -import Diagrams.Puzzles.CmdLine+import Data.CmdLine+import Draw.CmdLine -import Text.Puzzles.Puzzle-import Data.Puzzles.Compose-import Data.Puzzles.PuzzleTypes (typeNames)-import Diagrams.Puzzles.Draw+import Parse.Puzzle+import Parse.Code+import Data.Compose+import Data.PuzzleTypes (typeNames)+import Draw.Draw+import Draw.Code  import Options.Applicative import Control.Monad@@ -33,9 +36,12 @@ data PuzzleOpts = PuzzleOpts     { _format   :: String     , _type     :: Maybe String+    , _dir      :: FilePath     , _puzzle   :: Bool     , _solution :: Bool     , _example  :: Bool+    , _code     :: Bool+    , _scale    :: Double     , _input    :: FilePath     } @@ -50,6 +56,11 @@             (long "type" <> short 't'              <> metavar "TYPE"              <> help "Puzzle type, overriding type in input file"))+    <*> strOption+            (long "directory" <> short 'd'+             <> value "."+             <> metavar "DIR"+             <> help "Output directory")     <*> switch             (long "puzzle" <> short 'p'              <> help "Render puzzle (to base.ext)")@@ -59,6 +70,14 @@     <*> switch             (long "example" <> short 'e'              <> help "Render example (to base.ext)")+    <*> switch+            (long "code" <> short 'c'+             <> help "Add solution code markers")+    <*> option auto+            (long "scale"+             <> value 1.0+             <> metavar "FACTOR"+             <> help "Scale the size by this factor")     <*> argument str             (metavar "INPUT"              <> help "Puzzle file in .pzl format")@@ -73,17 +92,19 @@ outputSuffix DrawSolution = "-sol" outputSuffix DrawExample = "" -toRenderOpts :: OutputChoice -> Double -> PuzzleOpts -> RenderOpts-toRenderOpts oc w opts = RenderOpts out w'+toRenderOpts :: OutputChoice -> (Double, Double) -> PuzzleOpts -> RenderOpts+toRenderOpts oc (w, h) opts = RenderOpts out sz   where     f = _format opts     u = case f of "png" -> Pixels                   _     -> Points-    w' = toOutputWidth u w+    w' = toOutputWidth u w * (_scale opts)+    h' = toOutputWidth u h * (_scale opts)+    sz = mkSizeSpec2D (Just w') (Just h')     base = takeBaseName (_input opts)-    out = addExtension (base ++ outputSuffix oc) f+    out = _dir opts </> (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@@ -91,7 +112,7 @@         exitErr ("failed to render (no solution?): " ++ show oc)     when (isJust x) $ do         let Just x' = x-            ropts = toRenderOpts oc (diagramWidth x') opts+            ropts = toRenderOpts oc (diagramSize x') opts         renderToFile ropts x'  defaultOpts :: Parser a -> IO a@@ -129,17 +150,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 (render mcode ps')) ocs                Left    e -> exitErr $ "parse failure: " ++ e
+ tests/Data.hs view
@@ -0,0 +1,244 @@+module Data where++import qualified Data.Text as T+import Data.Maybe (fromJust)+import Data.Yaml+import qualified Data.ByteString as B+import Data.Text.Encoding (encodeUtf8)++packStr :: String -> B.ByteString+packStr = encodeUtf8 . T.pack++decodeLines :: [String] -> Value+decodeLines = fromJust . decodeThrow . 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"+   ]
+ tests/Data/GridShapeSpec.hs view
@@ -0,0 +1,17 @@+module Data.GridShapeSpec where++import Test.Hspec (Spec, describe, it, shouldBe)++import Data.GridShape+import qualified Data.Map.Strict as Map+import Data.List (sort)++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)+    describe "rows" $ do+        it "computes the rows for a simple grid" $ do+            sort (rows (Map.fromList [ ((C 1 1), 1::Int), ((C 1 2), 2), ((C 2 1), 3), ((C 2 2), 4) ]))+                `shouldBe` sort [ [1, 2], [3, 4], [1, 3], [2, 4] ]
+ tests/Data/GridSpec.hs view
@@ -0,0 +1,22 @@+module Data.GridSpec where++import qualified Data.Set as Set+import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Grid+import Data.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))
+ tests/Draw/GridSpec.hs view
@@ -0,0 +1,58 @@+module Draw.GridSpec where++import Diagrams.Prelude (p2)+import Diagrams.Path (pathPoints)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++import Data.Grid+import Data.GridShape+import Draw.Grid+import Draw.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)++    describe "offsetBorder" $ do+        it "gives the corners of a square cell" $ do+            let b = offsetBorder 0 [C 0 0]+                [vs] = pathPoints b+            length vs `shouldBe` 4+            vs `shouldSatisfy` elem (p2i (0, 0))+            vs `shouldSatisfy` elem (p2i (1, 0))+            vs `shouldSatisfy` elem (p2i (0, 1))+            vs `shouldSatisfy` elem (p2i (1, 1))+        it "omits in-between nodes of a rectangle" $ do+            let b = offsetBorder 0 [C 0 0, C 1 0]+                [vs] = pathPoints b+            length vs `shouldBe` 4+            vs `shouldSatisfy` elem (p2i (0, 0))+            vs `shouldSatisfy` elem (p2i (2, 0))+            vs `shouldSatisfy` elem (p2i (0, 1))+            vs `shouldSatisfy` elem (p2i (2, 1))+        it "offsets inside for negative offset" $ do+            let b = offsetBorder (-0.5) [C 0 0, C 1 0, C 1 1, C 0 1]+                [vs] = pathPoints b+            length vs `shouldBe` 4+            vs `shouldSatisfy` elem (p2 (0.5, 0.5))+            vs `shouldSatisfy` elem (p2 (0.5, 1.5))+            vs `shouldSatisfy` elem (p2 (1.5, 1.5))+            vs `shouldSatisfy` elem (p2 (1.5, 0.5))
+ tests/Parse/PuzzleTypesSpec.hs view
@@ -0,0 +1,54 @@+module Parse.PuzzleTypesSpec where++import Data.Maybe (isJust)+import qualified Data.Map.Strict 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.GridShape (edgeSize)+import Data.Elements (DigitRange(..))+import Parse.PuzzleTypes++packLines :: [String] -> B.ByteString+packLines = encodeUtf8 . T.pack . unlines++parse :: (Value -> Parser a) -> B.ByteString -> Maybe a+parse p t = decodeThrow 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)
+ tests/Parse/UtilSpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}+module Parse.UtilSpec where++import qualified Data.Map.Strict as Map+import Data.Yaml+import qualified Data.Text as T++import Test.Hspec (Spec, describe, it, shouldBe)++import Data.GridShape (Edge(..), N(..), Dir(..))+import Data.Elements (Relation(..))+import Parse.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
+ tests/Util.hs view
@@ -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"
tests/tests.hs view
@@ -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 qualified Data.Map.Strict as Map -import Text.Puzzles.Puzzle-import Data.Puzzles.Elements (Thermometer, MasyuPearl(..))-import Text.Puzzles.Util-    (parseChar, parseMultiOutsideClues, parseEdgeGrid)-import Text.Puzzles.PuzzleTypes-import qualified Data.Puzzles.Grid as Grid-import Data.Puzzles.Pyramid (PyramidSol(..))-import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..))-import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..))+import Parse.Puzzle+import Data.Elements (Thermometer, MasyuPearl(..))+import Parse.Util+    (parseChar, parseMultiOutsideClues, parsePlainEdgeGrid)+import Parse.PuzzleTypes+import qualified Data.Grid as Grid+import Data.Pyramid (PyramidSol(..))+import Data.Grid+import Data.GridShape+import Data.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.GridSpec+import qualified Data.GridShapeSpec+import qualified Draw.GridSpec+import qualified Parse.PuzzleTypesSpec+import qualified Parse.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.Grid",        Data.GridSpec.spec)+            , ("Data.GridShape",   Data.GridShapeSpec.spec)+            , ("Draw.Grid",    Draw.GridSpec.spec)+            , ("Parse.PuzzleTypes", Parse.PuzzleTypesSpec.spec)+            , ("Parse.Util",        Parse.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     ]