puzzle-draw 0.2.0.0 → 0.3.0.0

raw patch · 70 files changed

+5185/−4569 lines, 70 filesdep +diagrams-rasterificdep −diagrams-cairodep −diagrams-svgdep −processdep ~SVGFontsdep ~aesondep ~blaze-svgPVP ok

version bump matches the API change (PVP)

Dependencies added: diagrams-rasterific

Dependencies removed: diagrams-cairo, diagrams-svg, process, tasty-golden

Dependency ranges changed: SVGFonts, aeson, blaze-svg, bytestring, containers, deepseq, diagrams-lib, filepath, hashable, hspec, linear, mtl, optparse-applicative, parsec, tasty, tasty-hspec, tasty-hunit, text, unordered-containers, vector-space, yaml

API changes (from Hackage documentation)

Files

• CHANGES.md +8/−0
• README.md +22/−22
• puzzle-draw.cabal +121/−135
• src/Data/CmdLine.hs +27/−0
• src/Data/Code.hs +19/−0
• src/Data/Compose.hs +134/−0
• src/Data/Elements.hs +116/−0
• src/Data/Grid.hs +314/−0
• src/Data/GridShape.hs +231/−0
• src/Data/PuzzleTypes.hs +194/−0
• src/Data/Puzzles/CmdLine.hs +0/−27
• src/Data/Puzzles/Code.hs +0/−13
• src/Data/Puzzles/Compose.hs +0/−123
• src/Data/Puzzles/Elements.hs +0/−102
• src/Data/Puzzles/Grid.hs +0/−207
• src/Data/Puzzles/GridShape.hs +0/−219
• src/Data/Puzzles/PuzzleTypes.hs +0/−174
• src/Data/Puzzles/Pyramid.hs +0/−129
• src/Data/Puzzles/Sudoku.hs +0/−36
• src/Data/Puzzles/Util.hs +0/−32
• src/Data/Pyramid.hs +129/−0
• src/Data/Sudoku.hs +36/−0
• src/Data/Util.hs +32/−0
• src/Diagrams/Puzzles/CmdLine.hs +0/−45
• src/Diagrams/Puzzles/Code.hs +0/−53
• src/Diagrams/Puzzles/Draw.hs +0/−79
• src/Diagrams/Puzzles/Elements.hs +0/−350
• src/Diagrams/Puzzles/Grid.hs +0/−182
• src/Diagrams/Puzzles/Lib.hs +0/−153
• src/Diagrams/Puzzles/PuzzleGrids.hs +0/−93
• src/Diagrams/Puzzles/PuzzleTypes.hs +0/−757
• src/Diagrams/Puzzles/Pyramid.hs +0/−41
• src/Diagrams/Puzzles/Style.hs +0/−50
• src/Diagrams/Puzzles/Widths.hs +0/−26
• src/Draw/CmdLine.hs +32/−0
• src/Draw/Code.hs +75/−0
• src/Draw/Draw.hs +89/−0
• src/Draw/Elements.hs +424/−0
• src/Draw/Grid.hs +206/−0
• src/Draw/Lib.hs +161/−0
• src/Draw/PuzzleGrids.hs +93/−0
• src/Draw/PuzzleTypes.hs +910/−0
• src/Draw/Pyramid.hs +41/−0
• src/Draw/Style.hs +50/−0
• src/Draw/Widths.hs +26/−0
• src/Parse/Code.hs +26/−0
• src/Parse/Parsec.hs +30/−0
• src/Parse/Puzzle.hs +28/−0
• src/Parse/PuzzleTypes.hs +507/−0
• src/Parse/Util.hs +783/−0
• src/Text/Puzzles/Code.hs +0/−22
• src/Text/Puzzles/Parsec.hs +0/−30
• src/Text/Puzzles/Puzzle.hs +0/−28
• src/Text/Puzzles/PuzzleTypes.hs +0/−425
• src/Text/Puzzles/Util.hs +0/−760
• src/tools/checkpuzzle.hs +51/−5
• src/tools/drawpuzzle.hs +29/−15
• tests/Data.hs +2/−2
• tests/Data/GridShapeSpec.hs +17/−0
• tests/Data/GridSpec.hs +22/−0
• tests/Data/Puzzles/GridShapeSpec.hs +0/−11
• tests/Data/Puzzles/GridSpec.hs +0/−22
• tests/Diagrams/Puzzles/GridSpec.hs +0/−32
• tests/Draw/GridSpec.hs +58/−0
• tests/Parse/PuzzleTypesSpec.hs +54/−0
• tests/Parse/UtilSpec.hs +68/−0
• tests/Text/Puzzles/PuzzleTypesSpec.hs +0/−54
• tests/Text/Puzzles/UtilSpec.hs +0/−68
• tests/compare.hs +0/−27
• tests/tests.hs +20/−20

@@ -1,3 +1,11 @@+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 ----------------- 

@@ -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,8 +51,7 @@     ..X... ``` -There is a demo web application at-[puzzle-draw-demo.herokuapp.com][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. @@ -57,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 ------- @@ -96,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

@@ -1,145 +1,131 @@-name:                puzzle-draw-version:             0.2.0.0-synopsis:            Creating graphics for pencil puzzles.-description:         puzzle-draw is a library and tool for drawing pencil-                     puzzles using Diagrams. It aims to provide a utility-                     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.Util-                       Data.Puzzles.Elements-                       Data.Puzzles.Pyramid-                       Data.Puzzles.Sudoku-                       Data.Puzzles.Compose-                       Data.Puzzles.PuzzleTypes-                       Data.Puzzles.Code-                       Data.Puzzles.CmdLine-                       Text.Puzzles.Util-                       Text.Puzzles.Parsec-                       Text.Puzzles.Puzzle-                       Text.Puzzles.PuzzleTypes-                       Text.Puzzles.Code-                       Diagrams.Puzzles.Style-                       Diagrams.Puzzles.Grid-                       Diagrams.Puzzles.Lib-                       Diagrams.Puzzles.Elements-                       Diagrams.Puzzles.Widths-                       Diagrams.Puzzles.Pyramid-                       Diagrams.Puzzles.PuzzleGrids-                       Diagrams.Puzzles.PuzzleTypes-                       Diagrams.Puzzles.Draw-                       Diagrams.Puzzles.Code-                       Diagrams.Puzzles.CmdLine-  -- For access to the font files in the data directory.-  other-modules:       Paths_puzzle_draw-  build-depends:       base >= 4.8 && < 5,-                       diagrams-lib >= 1.3.1,-                       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.12 && < 0.13,-                       filepath >= 1.3,-                       linear-  if flag(cairo)-    cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.3-  else-    build-depends:     diagrams-svg >= 1.3-  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.8 && < 5,-                       puzzle-draw,-                       diagrams-lib >= 1.3,-                       yaml >= 0.8.4,-                       optparse-applicative >= 0.12,-                       aeson >= 0.7,-                       filepath >= 1.3-  if flag(cairo)-    cpp-options: "-DCAIRO"-    build-depends:     diagrams-cairo >= 1.3-  else-    build-depends:     diagrams-svg >= 1.3-  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-  build-depends:       base >= 4.8 && < 5,-                       puzzle-draw,-                       yaml >= 0.8.4,-                       optparse-applicative >= 0.12,-                       aeson >= 0.7,-                       filepath >= 1.3-  ghc-options:         -Wall+    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-  other-modules:       Data,-                       Util,-                       Data.Puzzles.GridSpec,-                       Data.Puzzles.GridShapeSpec,-                       Diagrams.Puzzles.GridSpec,-                       Text.Puzzles.PuzzleTypesSpec,-                       Text.Puzzles.UtilSpec-  build-depends:       base >= 4.8 && < 5,-                       tasty >= 0.8,-                       tasty-hspec,-                       tasty-hunit >= 0.8,-                       hspec,-                       yaml >= 0.8.4,-                       text >= 1.1,-                       deepseq >= 1.3,-                       containers >= 0.5,-                       blaze-svg >= 0.3,-                       diagrams-lib >= 1.3,-                       diagrams-svg >= 1.3,-                       bytestring >= 0.10,-                       puzzle-draw-  ghc-options:         -Wall---- This should depend on the executable `drawpuzzle`--- and not the library.-executable test-compare-  hs-source-dirs:      tests-  main-is:             compare.hs-  build-depends:       base >= 4.8 && < 5,-                       tasty >= 0.8,-                       tasty-golden >= 2.0,-                       filepath >= 1.3,-                       process >= 1.2-  ghc-options:         -Wall+    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

@@ -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++

@@ -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.

@@ -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 ())

@@ -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)

@@ -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)+         ]

@@ -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)

@@ -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)

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

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

@@ -1,123 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}---- |--- Helpers to string together parser and renderer by puzzle type.--module Data.Puzzles.Compose (-    PuzzleHandler,-    handle,-    -- * Handlers-    drawPuzzleMaybeSol,-  ) where--import Diagrams.Prelude-import Data.Yaml (Parser, Value)--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 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---- | 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) (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)

@@ -1,102 +0,0 @@--- | Types for a variety of puzzle elements.-module Data.Puzzles.Elements where--import Data.Puzzles.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--newtype TapaClue = TapaClue [Int]-    deriving Show---- | Diagonal marking for Prime Place: forward diag?, backward diag?-newtype PrimeDiag = PrimeDiag (Bool, Bool)--data Black = Black-data Fish = Fish-data Star = Star-data Crossing = Crossing--type BahnhofClue = Either Int Crossing--data DigitRange = DigitRange !Int !Int-    deriving (Show, Eq)--digitList :: DigitRange -> [Int]-digitList (DigitRange a b) = [a..b]--data MEnd = MEnd--data Fraction =-    FComp String String String  -- a b/c-  | FFrac String String         -- a/b-  | FInt String                 -- a--data PlainNode = PlainNode--type Myopia = [Dir']--data Relation = RGreater | RLess | REqual | RUndetermined-    deriving (Show, Eq)--type GreaterClue = [Relation]--data GalaxyCentre = GalaxyCentre

@@ -1,207 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}---- | Puzzle grids.-module Data.Puzzles.Grid-    (-      Grid-    , AreaGrid-    , ShadedGrid-    , nodes-    , size-    , sizeGrid-    , clues-    , nodeGrid-    , cellGrid--    , dominoGrid--    , borders-    , edgesGen-    , colour-    , collectLines--    , OutsideClues(..)-    , outsideSize-    , outsideClues-    , multiOutsideClues-    , outsideGrid-    ) where--import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.AffineSpace-import Data.VectorSpace-import Control.Monad.State--import Data.Puzzles.Elements-import Data.Puzzles.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)--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--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')

@@ -1,219 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}---- | Grid shapes.-module Data.Puzzles.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-    ) where--import qualified Data.Foldable as F-import Data.List (partition)-import qualified Data.Map 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)

@@ -1,174 +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-                | 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-    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")-            ]---- | Look up a puzzle type by name.-lookupType :: String -> Maybe PuzzleType-lookupType t = lookup t (map swap typeNames)

@@ -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

@@ -1,36 +0,0 @@-module Data.Puzzles.Sudoku (-    sudokuborders,-    sudokubordersg-  ) where--import qualified Data.Map as Map--import Data.Puzzles.Grid-import Data.Puzzles.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

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

@@ -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

@@ -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

@@ -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

@@ -1,45 +0,0 @@-{-# LANGUAGE FlexibleContexts, CPP #-}--module Diagrams.Puzzles.CmdLine -    ( B-    , renderToFile-    , RenderOpts(..)-    , formats-    , checkFormat-    )-  where--import Data.Puzzles.CmdLine (exitErr)--import Diagrams.Prelude hiding (value, option, (<>), Result)-import Control.Monad (unless)--#ifdef CAIRO-import Diagrams.Backend.Cairo (B, renderCairo)-#else-import Diagrams.Backend.SVG (B, renderSVG)-#endif--data RenderOpts = RenderOpts { _file :: FilePath, _w :: Double }--renderB :: FilePath -> SizeSpec V2 Double -> Diagram B -> IO ()-renderB =-#ifdef CAIRO-    renderCairo-#else-    renderSVG-#endif--renderToFile :: RenderOpts -> Diagram B -> IO ()-renderToFile ropts = renderB (_file ropts) (mkWidth $ _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

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

@@ -1,79 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Draw (-    PuzzleSol,-    RenderPuzzle,-    OutputChoice(..),-    draw,-    Unit(..),-    diagramWidth,-    toOutputWidth,-  ) where--import Diagrams.Prelude--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths-import Diagrams.Puzzles.Code--type RenderPuzzle b p s = (p -> Diagram b, (p, s) -> Diagram b)--type PuzzleSol b = (Diagram b, Maybe (Diagram b))--data OutputChoice = DrawPuzzle | DrawSolution | DrawExample-    deriving Show---- | Optionally render the puzzle, its solution, or a side-by-side---   example with puzzle and solution.-draw :: Backend' b-     => Maybe (CodeDiagrams (Diagram b))-     -> PuzzleSol b -> OutputChoice -> Maybe (Diagram b)-draw 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)--diagramWidth :: Backend' b => Diagram b -> 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 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)

@@ -1,350 +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 hiding (N)-import Diagrams.TwoD.Offset--import qualified Data.Map as Map--import Data.Puzzles.Grid-import Data.Puzzles.Elements hiding (Loop)-import Data.Puzzles.GridShape hiding (edge)--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Style-import Diagrams.Puzzles.Widths-import Diagrams.Puzzles.Grid--pearl :: Backend' b =>-         MasyuPearl -> Diagram b-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---- | 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--hintTL :: Backend' b => String -> Diagram b-hintTL = moveTo (p2 (-0.4,0.4)) . scale 0.5 . alignTL . drawText---- | Stack a list of words into a unit square. Scaled such that at least--- three words will fit.-drawWords :: Backend' b =>-             [String] -> Diagram b-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 = acosA off ^+^ (90 @@ deg)--drawFish :: Backend' b =>-            Fish -> Diagram b-drawFish Fish = fit 0.6 . centerXY . fc black . strokeLoop $-                fish 0.7 (30 @@ deg)--drawStar :: Backend' b =>-            Star -> Diagram b-drawStar Star = fc black . stroke . star (StarSkip 2) $ pentagon 0.3--vertexLoop :: VertexLoop -> Located (Trail' Loop V2 Double)-vertexLoop = mapLoc closeLine . fromVertices . map toPoint--note :: Backend' b =>-        Diagram b -> Diagram b-note d = d # frame 0.2 # bg (blend 0.2 black white)--placeNote :: Backend' b =>-             Size -> Diagram b -> Diagram b-placeNote sz d = note d # alignBL # translatep sz # translate (r2 (0.6,0.6))--placeNoteTL :: Backend' b =>-             Size -> Diagram b -> Diagram b-placeNoteTL sz d = note d # alignBR # translatep sz # translate (r2 (-0.6,0.6))--placeNoteBR :: Backend' b =>-             Size -> Diagram b -> Diagram b-placeNoteBR (x,_) d = note d # alignTL # translatep (x,0) # translate (r2 (0.6,-0.6))--miniloop :: Backend' b => Diagram b-miniloop = (drawThinEdges (map unorient out) <> grid gSlither g)-           # centerXY # scale 0.4-  where-    g = sizeGrid (1, 1)-    (out, _) = edgesM g--dominoBG :: Colour Double-dominoBG = blend 0.3 black white--drawDomino :: Backend' b => (Int, Int) -> Diagram b-drawDomino (x, y) =-    (drawInt x # smash ||| strutX 0.65 ||| drawInt y # smash) # centerXY # scale 0.6-    <> strokePath (rect 0.8 0.5) # lwG 0 # fc dominoBG--newtype DominoC = DominoC C-  deriving (Ord, Eq)--instance ToPoint DominoC where-    toPoint (DominoC (C x y)) = p2 ((1.0 * fromIntegral x),-                                    (0.7 * fromIntegral y))--drawDominos :: Backend' b => DigitRange -> Diagram b-drawDominos = centerXY . placeGrid-            . Map.mapKeys DominoC . fmap drawDomino . dominoGrid--drawPill :: Backend' b => Int -> Diagram b-drawPill x = drawInt x # scale 0.6-             <> strokePath (roundedRect 0.8 0.5 0.2) # lwG 0 # fc dominoBG--drawPills :: Backend' b => DigitRange -> Diagram b-drawPills (DigitRange a b) = centerXY . onGrid 1.0 0.7 drawPill $ placed-  where-    n = b - a + 1-    root = head [ x | x <- [n,n-1..], x*x <= n ]-    placed = zip [(x, y) | x <- [0..root], y <- [root,root-1..0]] [a..b]--drawCrossing :: Backend' b => Crossing -> Diagram b-drawCrossing = const $ drawChar '+'--drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b-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

@@ -1,182 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.Grid where--import Data.Char (isUpper)-import qualified Data.Map as M-import qualified Data.Set as S--import Diagrams.Prelude hiding (size, E, N, dot, outer)-import Diagrams.TwoD.Offset (offsetPath)--import qualified Data.AffineSpace as AS--import Data.Puzzles.Util-import Data.Puzzles.Grid-import Data.Puzzles.GridShape hiding (edge)--import Diagrams.Puzzles.Style-import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.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 (M.keysSet m) (`M.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--irregPathToVertices :: (Path V2 Double, Path V2 Double) -> (S.Set (P2 Double), S.Set (P2 Double), S.Set (P2 Double))-irregPathToVertices (pouter, pinner) = (outer, inner S.\\ outer, inner `S.union` outer)-  where-    outer = S.fromList . mconcat . pathVertices $ pouter-    inner = S.fromList . mconcat . pathVertices $ pinner--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 = M.foldMapWithKey (moveTo . toPoint)--placeGrid' :: (HasOrigin a, Monoid a, InSpace V2 Double a)-          => Grid (P2 Double) a -> a-placeGrid' = M.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--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

@@ -1,153 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}--module Diagrams.Puzzles.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 = 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

@@ -1,93 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE ConstraintKinds           #-}--module Diagrams.Puzzles.PuzzleGrids-    (-      drawIntGrid-    , drawCharGrid-    , outsideIntGrid-    , drawSlitherGrid-    , drawTightGrid-    , sudokugrid-    , drawWordsClues-    , drawOutsideGrid-    , drawMultiOutsideGrid-    , drawOutsideGridN-    , drawMultiOutsideGridN-    , placeMultiOutside-    ) where--import Diagrams.Prelude hiding (size, N)--import qualified Data.Map as Map-import Data.Maybe (maybeToList)--import Data.Puzzles.Grid-import Data.Puzzles.GridShape-import Data.Puzzles.Elements-import Data.Puzzles.Sudoku--import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Style-import Diagrams.Puzzles.Grid-import Diagrams.Puzzles.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)

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

@@ -1,41 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}--module Diagrams.Puzzles.Pyramid where--import Diagrams.Prelude--import Data.Puzzles.Pyramid-import Diagrams.Puzzles.Elements-import Diagrams.Puzzles.Lib-import Diagrams.Puzzles.Widths--pgray :: Colour Double-pgray = blend 0.6 white black--cell :: Backend' b => Bool -> Diagram b-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

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

@@ -1,26 +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 :: Double-edgewidth = 3 * onepix--borderwidth :: Double-borderwidth = 1 / 2

@@ -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

@@ -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

@@ -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)

@@ -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+

@@ -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

@@ -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+-}

@@ -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)

@@ -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