diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,18 @@ +0.3.0.0: 20180718 +----------------- + +* Switch backend to diagrams-rasterific, losing the dependency on Cairo. +* Upgrade to diagrams 1.4. +* Various new puzzle types, including Minesweeper, Tents, Snake, + Country Road, Killer Sudoku. + +0.2.0.0: 20161211 +----------------- + +* Upgrade diagrams version. +* Add various new puzzle types. +* Add solution code markers. + 0.1.0.4: 20141115 ----------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,13 +29,19 @@ 3.3..3 solution: loop: | - .┌──┐┌┐ - .│┌─┘││ - .│└──┘│ - ┌┘.┌─┐│ - └┐┌┘.││ - ┌┘│..││ - └─┘..└┘ + o o-o-o-o o-o + .|. . .|.|.| + o o o-o-o o o + .|.|. . .|.| + o o o-o-o-o o + .|. . . . .| + o-o o o-o-o o + |. . .|. .|.| + o-o o-o o o o + .|.|. . .|.| + o-o o o o o o + |. .|. . .|.| + o-o-o o o o-o liars: | ...X.. .X.... @@ -45,7 +51,7 @@ ..X... ``` -There is a demo web application at [demo] that provides some more +There is a [demo web application][demo] that provides some more examples and that can be used to generate SVG images from such puzzle descriptions. @@ -56,24 +62,21 @@ ---------- This is a brief overview of how to install the command line tool. -You'll need to get a Haskell environment, by installing the -[Haskell Platform][platform]. Then install `puzzle-draw` with cabal: +The easiest way right now is to get [stack](https://www.stackage.org/), +clone this repository, and install using ``` -$ cabal install puzzle-draw +$ stack install ``` -This will compile puzzle-draw against the SVG backend, and install -a binary `drawpuzzle` that formats puzzles to SVG. Alternatively, -you can compile against the Cairo backend by passing `-fcairo`: +Alternatively, get a Haskell environment by installing the +[Haskell Platform](https://www.haskell.org/platform/). +Then install `puzzle-draw` with cabal: ``` -$ cabal install -fcairo puzzle-draw +$ cabal install puzzle-draw ``` -This will enable PDF and PNG output. Be warned that getting Cairo -installed can be tricky on non-Linux platforms. - Running ------- @@ -95,9 +98,7 @@ behaviour, e.g., choosing the output format. [travis]: https://travis-ci.org/robx/puzzle-draw -[cmdline]: https://github.com/robx/puzzle-draw-cmdline [liarslither]: https://maybepuzzles.wordpress.com/types/liar-slither-link/ [twentyfour]: https://maybepuzzles.wordpress.com/2014/03/29/puzzle-set-24-hour-marathon/ [diagrams]: http://projects.haskell.org/diagrams/ -[demo]: https://puzzle-draw-demo.herokuapp.com -[platform]: https://www.haskell.org/platform/ +[demo]: https://arp.vllmrt.net/puzzles/draw/static/puzzle.html diff --git a/puzzle-draw.cabal b/puzzle-draw.cabal --- a/puzzle-draw.cabal +++ b/puzzle-draw.cabal @@ -1,105 +1,131 @@ -name: puzzle-draw -version: 0.1.0.4 -synopsis: Creating graphics for pencil puzzles. -description: puzzle-draw is a library and tool for drawing pencil - puzzles using Diagrams. It aims to provide a utility - layer on top of Diagrams to help with drawing arbitrary - puzzles, and to support several specific puzzles types - In addition, it includes functionality for parsing - puzzle data from a YAML file format. -license: MIT -license-file: LICENSE -author: Robert Vollmert -maintainer: rfvollmert@gmail.com -category: Graphics -build-type: Simple -extra-source-files: README.md, CHANGES.md -data-files: data/fonts/*.svg -cabal-version: >=1.8 +cabal-version: >=1.8 +name: puzzle-draw +version: 0.3.0.0 +license: MIT +license-file: LICENSE +maintainer: rob@vllmrt.net +author: Robert Vollmert +synopsis: Creating graphics for pencil puzzles. +description: + puzzle-draw is a library and tool for drawing pencil + puzzles using Diagrams. It aims to provide a utility + layer on top of Diagrams to help with drawing arbitrary + puzzles, and to support several specific puzzles types + In addition, it includes functionality for parsing + puzzle data from a YAML file format. +category: Graphics +build-type: Simple +data-files: + data/fonts/*.svg +extra-source-files: + README.md + CHANGES.md source-repository head - type: git - location: http://github.com/robx/puzzle-draw.git - -flag cairo - description: Build against Cairo backend - default: False + type: git + location: http://github.com/robx/puzzle-draw.git library - exposed-modules: Data.Puzzles.Grid - Data.Puzzles.GridShape - Data.Puzzles.Elements - Data.Puzzles.Pyramid - Data.Puzzles.Sudoku - Data.Puzzles.Compose - Data.Puzzles.PuzzleTypes - Text.Puzzles.Util - Text.Puzzles.Puzzle - Text.Puzzles.PuzzleTypes - Diagrams.Puzzles.Grid - Diagrams.Puzzles.Lib - Diagrams.Puzzles.Elements - Diagrams.Puzzles.Widths - Diagrams.Puzzles.Pyramid - Diagrams.Puzzles.PuzzleGrids - Diagrams.Puzzles.PuzzleTypes - Diagrams.Puzzles.Draw - Diagrams.Puzzles.CmdLine - -- For access to the font files in the data directory. - other-modules: Paths_puzzle_draw - build-depends: base >= 4.2 && < 5, - diagrams-lib >= 1.2, - parsec >= 3.1, - yaml >= 0.8.4, - aeson >= 0.7, - unordered-containers >= 0.2, - containers >= 0.5, - hashable >= 1.2, - text >= 1.1, - SVGFonts >= 1.4, - vector-space >= 0.8, - mtl >= 2.1, - optparse-applicative >= 0.7, - filepath >= 1.3 - if flag(cairo) - cpp-options: "-DCAIRO" - build-depends: diagrams-cairo >= 1.1 - else - build-depends: diagrams-svg >= 1.1 - hs-source-dirs: src - ghc-options: -Wall + exposed-modules: + Data.Grid + Data.GridShape + Data.Util + Data.Elements + Data.Pyramid + Data.Sudoku + Data.Compose + Data.PuzzleTypes + Data.Code + Data.CmdLine + Parse.Util + Parse.Parsec + Parse.Puzzle + Parse.PuzzleTypes + Parse.Code + Draw.Style + Draw.Grid + Draw.Lib + Draw.Elements + Draw.Widths + Draw.Pyramid + Draw.PuzzleGrids + Draw.PuzzleTypes + Draw.Draw + Draw.Code + Draw.CmdLine + hs-source-dirs: src + other-modules: + Paths_puzzle_draw + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + diagrams-lib >=1.4.2.3 && <1.5, + parsec ==3.1.*, + yaml >=0.8.4 && <0.9, + aeson >=0.7 && <1.4, + unordered-containers ==0.2.*, + containers ==0.5.*, + hashable ==1.2.*, + text >=1.1 && <1.3, + SVGFonts ==1.7.*, + vector-space >=0.8 && <0.14, + mtl >=2.1 && <2.3, + optparse-applicative >=0.13 && <0.15, + filepath >=1.3 && <1.5, + linear >=1.20.8 && <1.21, + diagrams-rasterific >=1.4.1 && <1.5 executable drawpuzzle - main-is: drawpuzzle.hs - hs-source-dirs: src/tools - build-depends: base >= 4.2, - puzzle-draw, - diagrams-lib >= 1.2, - yaml >= 0.8.4, - optparse-applicative >= 0.7, - aeson >= 0.7, - filepath >= 1.3 - if flag(cairo) - cpp-options: "-DCAIRO" - build-depends: diagrams-cairo >= 1.1 - else - build-depends: diagrams-svg >= 1.1 - ghc-options: -Wall + main-is: drawpuzzle.hs + hs-source-dirs: src/tools + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + puzzle-draw -any, + diagrams-lib >=1.4.2.3 && <1.5, + yaml >=0.8.4 && <0.9, + optparse-applicative >=0.12 && <0.15, + aeson >=0.7 && <1.4, + filepath >=1.3 && <1.5, + diagrams-rasterific >=1.4.1 && <1.5 +executable checkpuzzle + main-is: checkpuzzle.hs + hs-source-dirs: src/tools + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + puzzle-draw -any, + yaml >=0.8.4 && <0.9, + containers ==0.5.*, + optparse-applicative >=0.12 && <0.15, + aeson >=0.7 && <1.4, + filepath >=1.3 && <1.5 + test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: tests.hs - build-depends: base >= 4.2, - tasty >= 0.8, - tasty-hunit >= 0.8, - yaml >= 0.8.4, - text >= 1.1, - deepseq >= 1.3, - containers >= 0.5, - blaze-svg >= 0.3, - diagrams-lib >= 1.2, - diagrams-svg >= 1.1, - bytestring >= 0.10, - puzzle-draw - ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: tests.hs + hs-source-dirs: tests + other-modules: + Data + Util + Data.GridSpec + Data.GridShapeSpec + Draw.GridSpec + Parse.PuzzleTypesSpec + Parse.UtilSpec + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + tasty >=0.8 && <1.2, + tasty-hspec >=1.1.5 && <1.2, + tasty-hunit >=0.8 && <0.11, + hspec >=2.5.4 && <2.6, + yaml >=0.8.4 && <0.9, + text >=1.1 && <1.3, + deepseq >=1.3 && <1.5, + containers ==0.5.*, + blaze-svg ==0.3.*, + diagrams-lib >=1.4.2.3 && <1.5, + bytestring ==0.10.*, + puzzle-draw -any diff --git a/src/Data/CmdLine.hs b/src/Data/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Data/CmdLine.hs @@ -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 + + diff --git a/src/Data/Code.hs b/src/Data/Code.hs new file mode 100644 --- /dev/null +++ b/src/Data/Code.hs @@ -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. diff --git a/src/Data/Compose.hs b/src/Data/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Data/Compose.hs @@ -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 ()) diff --git a/src/Data/Elements.hs b/src/Data/Elements.hs new file mode 100644 --- /dev/null +++ b/src/Data/Elements.hs @@ -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) diff --git a/src/Data/Grid.hs b/src/Data/Grid.hs new file mode 100644 --- /dev/null +++ b/src/Data/Grid.hs @@ -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) + ] diff --git a/src/Data/GridShape.hs b/src/Data/GridShape.hs new file mode 100644 --- /dev/null +++ b/src/Data/GridShape.hs @@ -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) diff --git a/src/Data/PuzzleTypes.hs b/src/Data/PuzzleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Data/PuzzleTypes.hs @@ -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) diff --git a/src/Data/Puzzles/Compose.hs b/src/Data/Puzzles/Compose.hs deleted file mode 100644 --- a/src/Data/Puzzles/Compose.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} -{-# LANGUAGE ConstraintKinds #-} - --- | --- Helpers to string together parser and renderer by puzzle type. - -module Data.Puzzles.Compose ( - PuzzleHandler, - handle, - -- * Handlers - drawPuzzle, - drawPuzzleSol, - drawPuzzleMaybeSol, - drawPuzzle', - drawSolution', - drawExample' - ) where - -import Data.Maybe -import Diagrams.Prelude -import Data.Yaml (Parser, Value) -import Data.Traversable (traverse) - -import Text.Puzzles.Puzzle -import Diagrams.Puzzles.Draw -import Diagrams.Puzzles.Lib -import Data.Puzzles.PuzzleTypes - -import qualified Text.Puzzles.PuzzleTypes as R -import qualified Diagrams.Puzzles.PuzzleTypes as D - --- | A function to compose an arbitrary matching pair of parser and renderer. --- In @PuzzleHandler b a@, @b@ is the rendering backend type, while @a@ is --- the result type of the composition. -type PuzzleHandler b a = forall p q. - ParsePuzzle p q -> RenderPuzzle b p q -> a - --- | @handle h t@ composes the parser and renderer for the puzzle --- type @t@ with the handler @h@. -handle :: Backend' b => - PuzzleHandler b a -> PuzzleType -> a -handle f LITS = f R.lits D.lits -handle f LITSPlus = f R.litsplus D.litsplus -handle f Geradeweg = f R.geradeweg D.geradeweg -handle f Fillomino = f R.fillomino D.fillomino -handle f Masyu = f R.masyu D.masyu -handle f Nurikabe = f R.nurikabe D.nurikabe -handle f LatinTapa = f R.latintapa D.latintapa -handle f Sudoku = f R.sudoku D.sudoku -handle f ThermoSudoku = f R.thermosudoku D.thermosudoku -handle f Pyramid = f R.pyramid D.pyramid -handle f RowKropkiPyramid = f R.kpyramid D.kpyramid -handle f SlitherLink = f R.slither D.slither -handle f SlitherLinkLiar = f R.liarslither D.liarslither -handle f TightfitSkyscrapers = f R.tightfitskyscrapers D.tightfitskyscrapers -handle f WordLoop = f R.wordloop D.wordloop -handle f WordSearch = f R.wordsearch D.wordsearch -handle f CurveData = f R.curvedata D.curvedata -handle f DoubleBack = f R.doubleback D.doubleback -handle f Slalom = f R.slalom D.slalom -handle f Compass = f R.compass D.compass -handle f BoxOf2Or3 = f R.boxof2or3 D.boxof2or3 -handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers -handle f MeanderingNumbers = f R.meanderingnumbers D.meanderingnumbers -handle f Tapa = f R.tapa D.tapa -handle f JapaneseSums = f R.japanesesums D.japanesesums -handle f Coral = f R.coral D.coral -handle f MaximalLengths = f R.maximallengths D.maximallengths -handle f PrimePlace = f R.primeplace D.primeplace -handle f Labyrinth = f R.labyrinth D.labyrinth -handle f Bahnhof = f R.bahnhof D.bahnhof -handle f Cave = f R.cave D.cave - --- | Handler that parses a puzzle from a YAML value, and renders. -drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2)) -drawPuzzle (pp, _) (dp, _) p = do - p' <- pp p - return $ dp p' - --- | Handler that parses puzzle and solution from a pair of corresponding --- YAML values, and renders both individually. -drawPuzzleSol :: PuzzleHandler b ((Value, Value) - -> Parser (Diagram b R2, Diagram b R2)) -drawPuzzleSol (pp, ps) (dp, ds) (p, s) = do - p' <- pp p - s' <- ps s - return (dp p', ds (p', s')) - --- | Handler that parses puzzle and an optional solution from a pair of --- corresponding YAML values, and renders both individually, optionally --- for the solution. -drawPuzzleMaybeSol :: PuzzleHandler b ((Value, Maybe Value) - -> Parser (Diagram b R2, Maybe (Diagram b R2))) -drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do - p' <- pp p - s' <- traverse ps s - let mps = case s' of Nothing -> Nothing - Just s'' -> Just (p', s'') - return (dp p', ds <$> mps) - --- | Variant of 'drawPuzzle' that accepts a pair of puzzle YAML value and --- optional solution YAML value. -drawPuzzle' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawPuzzle' (pp, _) (dp, _) (p, _) = do - p' <- pp p - return $ dp p' - --- | Handler that accepts a pair of puzzle YAML value and optional solution --- YAML value, and renders the solution, failing if the solution is not --- provided. -drawSolution' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawSolution' (pp, ps) (_, ds) (p, ms) = do - p' <- pp p - s' <- maybe (fail "no solution provided") ps ms - return $ ds (p', s') - --- | Like 'drawSolution'', but renders puzzle and solution in example layout. -drawExample' :: Backend' b => - PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawExample' (pp, ps) (dp, ds) (p, ms) = do - p' <- pp p - s' <- maybe (fail "no solution provided") ps ms - return . fromJust $ draw (dp p', Just $ ds (p', s')) DrawExample diff --git a/src/Data/Puzzles/Elements.hs b/src/Data/Puzzles/Elements.hs deleted file mode 100644 --- a/src/Data/Puzzles/Elements.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | Types for a variety of puzzle elements. -module Data.Puzzles.Elements where - -import Data.Puzzles.GridShape (Coord, Edge) - -type Clue a = Maybe a - -data MasyuPearl = MWhite | MBlack - deriving (Eq, Show) - -type MasyuClue = Clue MasyuPearl - -type IntClue = Clue Int - --- | A Compass clue, specifiying optional numbers in the --- four cardinal directions. -data CompassC = CC (Maybe Int) (Maybe Int) (Maybe Int) (Maybe Int) - deriving Show - -type CompassClue = Clue CompassC - --- | A cell that is optionally bisected by a diagonal --- (up-right or down-right). -data Tightfit a = Single a | UR a a | DR a a - -instance Show a => Show (Tightfit a) where - show c = "(" ++ show' c ++ ")" - where show' (Single x) = show x - show' (UR x y) = show x ++ "/" ++ show y - show' (DR x y) = show x ++ "\\" ++ show y - --- | A marked word in a letter grid, by its start and end --- coordinates. -data MarkedWord = MW { mwstart :: Coord, mwend :: Coord } - --- | A loop of edges. -type Loop = [Edge] - --- | A thermometer, as a list of coordinates from bulb to end. --- There should be at least two entries, entries should be distinct, --- and successive entries should be neighbours (diagonal neighbours --- are fine). -type Thermometer = [Coord] - --- | A forward or backward diagonal as occurring in the solution --- of a slalom puzzle. -data SlalomDiag = SlalomForward | SlalomBackward - deriving Show - --- | Shadow along from the western and southern side, as used for --- afternoon skyscrapers. -data Shade = Shade Bool Bool - deriving Show - -data KropkiDot = KNone | KBlack | KWhite - deriving Show - -newtype TapaClue = TapaClue [Int] - deriving Show - --- | Diagonal marking for Prime Place: forward diag?, backward diag? -newtype PrimeDiag = PrimeDiag (Bool, Bool) - -data Black = Black - -data Crossing = Crossing - -type BahnhofClue = Either Int Crossing diff --git a/src/Data/Puzzles/Grid.hs b/src/Data/Puzzles/Grid.hs deleted file mode 100644 --- a/src/Data/Puzzles/Grid.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, - GADTs, StandaloneDeriving #-} - --- | Puzzle grids. -module Data.Puzzles.Grid where - -import Data.Maybe -import qualified Data.Map as Map -import Data.Foldable (Foldable, foldMap) -import Data.Traversable (Traversable, traverse) -import Control.Applicative ((<$>)) -import Data.VectorSpace - -import Data.Puzzles.GridShape hiding (size, cells) -import qualified Data.Puzzles.GridShape as GS -import Data.Puzzles.Elements - --- | A generic grid, with the given shape and contents. -data Grid s a where - Grid :: { shape :: s - , contents :: Map.Map (Cell s) a} -> Grid s a - -deriving instance (Show a, Show s, GridShape s) => Show (Grid s a) -deriving instance (Eq s, Eq (Cell s), Eq a) => Eq (Grid s a) - --- | Standard square grid. -type SGrid = Grid Square - -type CharGrid = SGrid Char -type AreaGrid = CharGrid -type ShadedGrid = SGrid Bool -type CharClueGrid = SGrid (Maybe Char) -type IntGrid = SGrid (Clue Int) - --- | Lookup a grid value at a given cell. Unsafe. -(!) :: (GridShape s, Ord (Cell s)) => Grid s a -> Cell s -> a -(!) (Grid _ m) = (m Map.!) - -instance Functor (Grid s) where - fmap f (Grid s m) = Grid s (fmap f m) - -instance Foldable (Grid s) where - foldMap f (Grid _ m) = foldMap f m - -instance Traversable (Grid s) where - traverse f (Grid s m) = Grid s <$> traverse f m - -filterG :: (a -> Bool) -> Grid s a -> Grid s a -filterG p (Grid s m) = Grid s (Map.filter p m) - --- | Initialize a square grid from a list of lists. The grid --- might be incomplete if some rows are shorter. -fromListList :: [[a]] -> Grid Square a -fromListList g = Grid s m - where - w = maximum . map length $ g - h = length g - s = Square w h - m = Map.fromList . concat - . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..] - $ g - -size :: GridShape s => Grid s a -> GridSize s -size = GS.size . shape - -cells :: GridShape s => Grid s a -> [Cell s] -cells = Map.keys . contents - -inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool -inBounds g c = c `elem` cells g - --- | For a grid with value type @Maybe a@, return an association --- list of cells and @Just@ values. -clues :: GridShape s => Grid s (Maybe a) -> [(Cell s, a)] -clues g = [ (k, v) | (k, Just v) <- values g ] - --- | Association list of cells and values. -values :: GridShape s => Grid s a -> [(Cell s, a)] -values (Grid _ m) = Map.toList m - -edgesGen :: (a -> a -> Bool) -> (a -> Bool) -> Grid Square a -> [Edge] -edgesGen p n g = [ E pt V | pt <- vedges ] ++ [ E pt H | pt <- hedges ] - where - edges' f (sx, sy) = [ (x + 1, y) | x <- [-1 .. sx - 1] - , y <- [-1 .. sy] - , p' (f (x, y)) (f (x + 1, y)) ] - - vedges = edges' id (size g) - hedges = map swap $ edges' swap (swap . size $ g) - swap (x, y) = (y, x) - p' c d = p'' (Map.lookup c (contents g)) - (Map.lookup d (contents g)) - p'' (Just e) (Just f) = p e f - p'' (Just e) Nothing = n e - p'' Nothing (Just e) = n e - p'' _ _ = False - -edgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] -edgesP p g = edgesGen p (const False) g - -dualEdgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] -dualEdgesP p g = [ E pt H | pt <- hedges ] ++ - [ E pt V | pt <- vedges ] - where - edges' f (sx, sy) = [ (x, y) | x <- [0 .. sx - 2] - , y <- [0 .. sy - 1] - , p' (f (x, y)) (f (x + 1, y)) ] - - hedges = edges' id (size g) - vedges = map swap $ edges' swap (swap . size $ g) - swap (x, y) = (y, x) - p' c d = p'' (Map.lookup c (contents g)) - (Map.lookup d (contents g)) - p'' (Just e) (Just f) = p e f - p'' _ _ = False - --- | The inner edges of a grid that separate unequal cells. -borders :: Eq a => Grid Square a -> [Edge] -borders = edgesP (/=) - --- | Clues along the outside of a square grid. -data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] } - deriving (Show, Eq) - -instance Functor OutsideClues where - fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t) - -outsideSize :: OutsideClues a -> (Int, Int) -outsideSize (OC l r b t) = ( max (length t) (length b) - , max (length l) (length r) - ) - -data OutsideClue a = OClue - { ocBase :: (Int, Int) - , ocDir :: (Int, Int) - , ocValue :: a - } - -instance Functor OutsideClue where - fmap f (OClue b d x) = OClue b d (f x) - -outsideClueList :: OutsideClues a -> [OutsideClue a] -outsideClueList o@(OC l r b t) = - concat - [ zipWith (\ y c -> OClue (0,y) (-1, 0) c) [0..h-1] l - , zipWith (\ y c -> OClue (w-1,y) ( 1, 0) c) [0..h-1] r - , zipWith (\ x c -> OClue (x,0) ( 0,-1) c) [0..w-1] b - , zipWith (\ x c -> OClue (x,h-1) ( 0, 1) c) [0..w-1] t - ] - where - (w, h) = outsideSize o - --- | Convert outside clues to association list mapping coordinate to value. -outsideClues :: OutsideClues (Maybe a) -> [((Int, Int), a)] -outsideClues = mapMaybe (liftMaybe . toCell) . outsideClueList - where - toCell (OClue (bx, by) (dx, dy) v) = ((bx + dx, by + dy), v) - liftMaybe (p, Just x) = Just (p, x) - liftMaybe (_, Nothing) = Nothing - -multiOutsideClues :: OutsideClues [a] -> [((Int, Int), a)] -multiOutsideClues = concatMap distrib . outsideClues . fmap Just . dired - where - dired (OC l r b t) = OC (z (-1,0) l) (z (1,0) r) (z (0,-1) b) (z (0,1) t) - z x ys = zip (repeat x) ys - distrib (o, (d, xs)) = zip [o ^+^ i *^ d | i <- [0..]] xs diff --git a/src/Data/Puzzles/GridShape.hs b/src/Data/Puzzles/GridShape.hs deleted file mode 100644 --- a/src/Data/Puzzles/GridShape.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} - --- | Grid shapes. -module Data.Puzzles.GridShape where - -import Data.Foldable (Foldable) -import qualified Data.Foldable as F -import Data.List (partition) -import Data.VectorSpace ((^+^)) - --- | The geometry of a grid. -class Show (Cell a) => GridShape a where - type GridSize a :: * - type Cell a :: * - type Vertex a :: * - - size :: a -> GridSize a - cells :: a -> [Cell a] - vertices :: a -> [Vertex a] - vertexNeighbours :: a -> Cell a -> [Cell a] - edgeNeighbours :: a -> Cell a -> [Cell a] - --- | A standard square grid, with cells and vertices --- indexed by pairs of integers in mathematical coordinates. --- The bottom-left corner is vertex (0, 0), the bottom-left --- cell is cell (0, 0). -data Square = Square !Int !Int - deriving (Show, Eq) - -squareNeighbours :: [(Int, Int)] -> Square -> Cell Square -> [Cell Square] -squareNeighbours deltas (Square w h) c = filter inBounds . map (add c) $ deltas - where - inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h - add (x, y) (x', y') = (x + x', y + y') - -instance GridShape Square where - type GridSize Square = (Int, Int) - type Cell Square = (Int, Int) - type Vertex Square = (Int, Int) - - size (Square w h) = (w, h) - cells (Square w h) = [(x, y) | x <- [0..w-1], y <- [0..h-1]] - vertices (Square w h) = [(x, y) | x <- [0..w], y <- [0..h]] - vertexNeighbours = squareNeighbours [ (dx, dy) - | dx <- [-1..1], dy <- [-1..1] - , dx /= 0 || dy /= 0 - ] - edgeNeighbours = squareNeighbours [ (dx, dy) - | dx <- [-1..1], dy <- [-1..1] - , dx /= 0 || dy /= 0 - , dx == 0 || dy == 0 - ] - --- | Edge direction in a square grid, vertical or horizontal. -data Dir = V | H - deriving (Eq, Ord, Show) - --- | An edge in a square grid, going up or right from the given cell --- centre. -data Edge = E (Cell Square) Dir - deriving (Show, Eq, Ord) - -type Coord = Cell Square -type Size = GridSize Square - --- | Oriented edge direction in a square grid. -data Dir' = U | D | L | R - deriving (Eq, Ord, Show) - --- | An oriented edge in a square grid. --- @a@ should be @Cell Square@ or @Vertex Square@. -data Edge' a = E' a Dir' - deriving (Eq, Ord, Show) - --- | The edge between two neighbouring cells, with the first cell --- on the left. -orientedEdge :: Cell Square -> Cell Square -> Edge' (Vertex Square) -orientedEdge (x,y) (x',y') - | x' == x && y' == y+1 = E' (x,y+1) R - | x' == x && y' == y-1 = E' (x+1,y) L - | x' == x+1 && y' == y = E' (x+1,y+1) D - | x' == x-1 && y' == y = E' (x,y) U - | otherwise = error $ "not neighbours: " ++ - show (x,y) ++ " " ++ show (x',y') - --- | @edges@ computes the outer and inner edges of a set of cells. --- The set is given via fold and membership predicate, the result --- is a pair @(outer, inner)@ of lists of edges, where the outer --- edges are oriented such that the outside is to the left. -edges :: Foldable f => - f (Cell Square) -> (Cell Square -> Bool) -> - ([Edge' (Vertex Square)], [Edge' (Vertex Square)]) -edges cs isc = F.foldr f ([], []) cs - where - f c (outer, inner) = (newout ++ outer, newin ++ inner) - where - nbrs = [ c ^+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ] - (ni, no) = partition isc nbrs - newout = map (orientedEdge c) no - newin = map (orientedEdge c) . filter (c >=) $ ni diff --git a/src/Data/Puzzles/PuzzleTypes.hs b/src/Data/Puzzles/PuzzleTypes.hs deleted file mode 100644 --- a/src/Data/Puzzles/PuzzleTypes.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes #-} - --- | --- List of specific puzzle types. - -module Data.Puzzles.PuzzleTypes ( - PuzzleType(..) - , lookupType - , typeNames - ) where - -import Data.Tuple (swap) - --- | The list of specific puzzle types we can handle. -data PuzzleType = LITS - | LITSPlus - | Geradeweg - | Fillomino - | Masyu - | Nurikabe - | LatinTapa - | Sudoku - | ThermoSudoku - | Pyramid - | RowKropkiPyramid - | SlitherLink - | SlitherLinkLiar - | TightfitSkyscrapers - | WordLoop - | WordSearch - | CurveData - | DoubleBack - | Slalom - | Compass - | BoxOf2Or3 - | AfternoonSkyscrapers - | MeanderingNumbers - | Tapa - | JapaneseSums - | Coral - | MaximalLengths - | PrimePlace - | Labyrinth - | Bahnhof - | Cave - deriving (Show, Eq) - -typeNames :: [(PuzzleType, String)] -typeNames = [ (LITS, "lits") - , (LITSPlus, "litsplus") - , (Geradeweg, "geradeweg") - , (Fillomino, "fillomino") - , (Masyu, "masyu") - , (Nurikabe, "nurikabe") - , (LatinTapa, "latintapa") - , (Sudoku, "sudoku") - , (ThermoSudoku, "thermosudoku") - , (Pyramid, "pyramid") - , (RowKropkiPyramid, "rowkropkipyramid") - , (SlitherLink, "slitherlink") - , (SlitherLinkLiar, "slitherlinkliar") - , (TightfitSkyscrapers, "skyscrapers-tightfit") - , (WordLoop, "wordloop") - , (WordSearch, "wordsearch") - , (CurveData, "curvedata") - , (DoubleBack, "doubleback") - , (Slalom, "slalom") - , (Compass, "compass") - , (BoxOf2Or3, "boxof2or3") - , (AfternoonSkyscrapers, "afternoonskyscrapers") - , (MeanderingNumbers, "meanderingnumbers") - , (Tapa, "tapa") - , (JapaneseSums, "japanesesums") - , (Coral, "coral") - , (MaximalLengths, "maximallengths") - , (PrimePlace, "primeplace") - , (Labyrinth, "magiclabyrinth") - , (Bahnhof, "bahnhof") - , (Cave, "cave") - ] - --- | Look up a puzzle type by name. -lookupType :: String -> Maybe PuzzleType -lookupType t = lookup t (map swap typeNames) diff --git a/src/Data/Puzzles/Pyramid.hs b/src/Data/Puzzles/Pyramid.hs deleted file mode 100644 --- a/src/Data/Puzzles/Pyramid.hs +++ /dev/null @@ -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 diff --git a/src/Data/Puzzles/Sudoku.hs b/src/Data/Puzzles/Sudoku.hs deleted file mode 100644 --- a/src/Data/Puzzles/Sudoku.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Data.Puzzles.Sudoku ( - sudokuborders, - sudokubordersg - ) where - -import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) - -msqrt :: Integral a => a -> Maybe a -msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing - where r = round . (sqrt :: Double -> Double) . fromIntegral $ x - -mhalf :: Integral a => a -> Maybe a -mhalf x = if even x then Just (x `div` 2) else Nothing - --- | Determine the internal borders of a standard sudoku of the --- given size. -sudokuborders :: Int -> [Edge] -sudokuborders s = - case msqrt s of - Just r -> squareborders r - Nothing -> case mhalf s of - Just h -> rectborders h - Nothing -> error "no sudoku layout of this size" - where squareborders r = [ E (r*x, y) V | x <- [1..r-1], y <- [0..r*r-1] ] - ++ [ E (x, r*y) H | x <- [0..r*r-1], y <- [1..r-1] ] - rectborders h = [ E (h, y) V | y <- [0..2*h-1] ] - ++ [ E (x, 2*y) H | x <- [0..2*h-1], y <- [1..h-1] ] - --- | Determine the internal borders of a standard sudoku of the --- on the given grid. -sudokubordersg :: SGrid a -> [Edge] -sudokubordersg g = sudokuborders s - where (w, h) = size g - s | w == h = w - | otherwise = error "non-square sudoku grid?" diff --git a/src/Data/Pyramid.hs b/src/Data/Pyramid.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pyramid.hs @@ -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 diff --git a/src/Data/Sudoku.hs b/src/Data/Sudoku.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sudoku.hs @@ -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 diff --git a/src/Data/Util.hs b/src/Data/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Util.hs @@ -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 diff --git a/src/Diagrams/Puzzles/CmdLine.hs b/src/Diagrams/Puzzles/CmdLine.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/CmdLine.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleContexts, CPP #-} - -module Diagrams.Puzzles.CmdLine - ( B - , renderToFile - , RenderOpts(..) - , formats - , checkFormat - , checkType - , exitErr - , readPuzzle - ) - where - -import Diagrams.Prelude hiding (value, option, (<>), Result) - -#ifdef CAIRO -import Diagrams.Backend.Cairo (B, renderCairo) -#else -import Diagrams.Backend.SVG (B, renderSVG) -#endif - -import Text.Puzzles.Puzzle -import Data.Puzzles.PuzzleTypes - -import System.Exit - -import Control.Monad (unless) -import qualified Data.Yaml as Y - -data RenderOpts = RenderOpts { _file :: FilePath, _w :: Double } - -renderB :: FilePath -> SizeSpec2D -> Diagram B R2 -> IO () -renderB = -#ifdef CAIRO - renderCairo -#else - renderSVG -#endif - -renderToFile :: RenderOpts -> Diagram B R2 -> IO () -renderToFile ropts = renderB (_file ropts) (Width $ _w ropts) - -formats :: [String] -#ifdef CAIRO -formats = ["png", "svg", "ps", "pdf"] -#else -formats = ["svg"] -#endif - -checkFormat :: String -> IO () -checkFormat f = unless (f `elem` formats) $ - exitErr $ "unknown format: " ++ f - -checkType :: Maybe String -> IO PuzzleType -checkType mt = do - t <- maybe errno return mt - maybe (errunk t) return (lookupType t) - where - errno = exitErr "no puzzle type given" - errunk t = exitErr $ "unknown puzzle type: " ++ t - -readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle) -readPuzzle = Y.decodeFileEither - -exitErr :: String -> IO a -exitErr e = putStrLn e >> exitFailure diff --git a/src/Diagrams/Puzzles/Draw.hs b/src/Diagrams/Puzzles/Draw.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Draw.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.Draw ( - PuzzleSol, - RenderPuzzle, - OutputChoice(..), - draw, - Unit(..), - diagramWidth, - toOutputWidth, - ) where - -import Diagrams.Prelude -import Diagrams.BoundingBox - -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Widths - -type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2) - -type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2)) - -data OutputChoice = DrawPuzzle | DrawSolution | DrawExample - deriving Show - --- | Optionally render the puzzle, its solution, or a side-by-side --- example with puzzle and solution. -draw :: Backend' b => - PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2) -draw (p, ms) = fmap (bg white) . d - where - fixup = alignPixel . border borderwidth - d DrawPuzzle = Just (fixup p) - d DrawSolution = fixup <$> ms - d DrawExample = ms >>= \s -> return $ fixup p ||| strutX 2.0 ||| fixup s - -data Unit = Pixels | Points - -cmtopoint :: Double -> Double -cmtopoint = (* 28.3464567) - -diagramWidth :: Diagram b R2 -> Double -diagramWidth = fst . unr2 . boxExtents . boundingBox - -toOutputWidth :: Unit -> Double -> Double -toOutputWidth u w = case u of Pixels -> fromIntegral wpix - Points -> wpt - where - wpix = round (gridresd * w) :: Int -- grid square size 40px - wpt = cmtopoint (0.8 * w) -- grid square size 0.8cm - -alignPixel :: Backend' b => Diagram b R2 -> Diagram b R2 -alignPixel = scale (1/gridresd) . align' . scale gridresd - where - align' d = maybe id grow (getCorners $ boundingBox d) d - grow (bl, tr) = mappend $ phantoml (nudge bl False) (nudge tr True) - nudge p dir = let (px, py) = unp2 p in p2 (nudge' px dir, nudge' py dir) - nudge' x True = fromIntegral (ceiling (x - 0.5) :: Int) + 0.5 - nudge' x False = fromIntegral (floor (x + 0.5) :: Int) - 0.5 - phantoml p q = phantom' $ p ~~ q - --- | Add a phantom border of the given width around a diagram. -border :: Backend' b => Double -> Diagram b R2 -> Diagram b R2 -border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX) - . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY) diff --git a/src/Diagrams/Puzzles/Elements.hs b/src/Diagrams/Puzzles/Elements.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Elements.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - --- | Module: Diagrams.TwoD.Puzzles.Elements --- --- Tools to draw individual puzzle components. In particular --- contents and decorations for individual cells. - -module Diagrams.Puzzles.Elements where - -import Diagrams.Prelude -import Diagrams.TwoD.Offset - -import Data.Puzzles.Elements -import Data.Puzzles.GridShape - -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Widths -import Diagrams.Puzzles.Grid - -pearl :: Backend' b => - MasyuPearl -> Diagram b R2 -pearl m = circle 0.35 # lwG 0.05 # fc (c m) - where - c MWhite = white - c MBlack = black - -smallPearl :: Backend' b => - MasyuPearl -> Diagram b R2 -smallPearl = scale 0.4 . pearl - --- | The up-right diagonal of a centered unit square. -ur :: Path R2 -ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)] - --- | The down-right diagonal of a centered unit square. -dr :: Path R2 -dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)] - --- | Both diagonals of a centered unit square. -cross :: Path R2 -cross = ur <> dr - --- | Draw a cross. -drawCross :: Backend' b => Diagram b R2 -drawCross = stroke cross # scale 0.8 # lwG edgewidth - --- | Draw a Compass clue. -drawCompassClue :: Backend' b => - CompassC -> Diagram b R2 -drawCompassClue (CC n e s w) = texts <> stroke cross # lwG onepix - where tx Nothing _ = mempty - tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v) - texts = mconcat . zipWith tx [n, e, s, w] $ - [(0,f), (f,0), (0,-f), (-f,0)] - f = 3/10 - --- | Draw a thermometer, given by a list of bottom-left corners --- of square cells. -thermo :: Backend' b => [P2] -> QDiagram b R2 Any -thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5)) - where bulb = circle 0.4 # moveTo v - line = strokeLocLine (fromVertices vs) - # lwG 0.55 # lineCap LineCapSquare - col = lc gr . fc gr - gr = blend 0.6 white black -thermo [] = error "invalid empty thermometer" - --- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell --- coordinates. -drawThermos :: Backend' b => [Thermometer] -> QDiagram b R2 Any -drawThermos = mconcat . map (thermo . map p2i) - --- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to --- draw the components. -drawTight :: Backend' b => - (a -> Diagram b R2) -> Tightfit a -> Diagram b R2 -drawTight d (Single x) = d x -drawTight d (UR x y) = stroke ur # lwG onepix - <> d x # scale s # translate (r2 (-t,t)) - <> d y # scale s # translate (r2 (t,-t)) - where t = 1/5 - s = 2/3 -drawTight d (DR x y) = stroke dr # lwG onepix - <> d x # scale s # translate (r2 (-t,-t)) - <> d y # scale s # translate (r2 (t,t)) - where t = 1/5 - s = 2/3 - --- | Stack the given words, left-justified. -stackWords :: Backend' b => [String] -> QDiagram b R2 Any -stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text') - --- | Mark a word in a grid of letters. -drawMarkedWord :: Backend' b => MarkedWord -> QDiagram b R2 Any -drawMarkedWord (MW s e) = lwG onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t - where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2)) - --- | Apply 'drawMarkedWord' to a list of words. -drawMarkedWords :: Backend' b => [MarkedWord] -> QDiagram b R2 Any -drawMarkedWords = mconcat . map drawMarkedWord - --- | Draw a slalom clue. -drawSlalomClue :: (Show a, Backend' b) => - a -> Diagram b R2 -drawSlalomClue x = text' (show x) # scale 0.75 - <> circle 0.4 # fc white # lwG onepix - --- | Draw text. Shouldn't be more than two characters or so to fit a cell. -drawText :: Backend' b => String -> QDiagram b R2 Any -drawText = text' - --- | Draw an @Int@. -drawInt :: Backend' b => - Int -> Diagram b R2 -drawInt s = drawText (show s) - --- | Draw a character. -drawChar :: Backend' b => - Char -> Diagram b R2 -drawChar c = drawText [c] - --- | Stack a list of words into a unit square. Scaled such that at least --- three words will fit. -drawWords :: Backend' b => - [String] -> Diagram b R2 -drawWords ws = spread (-1.0 *^ unitY) - (map (centerXY . scale 0.4 . drawText) ws) - # centerY - --- | Fit a line drawing into a unit square. --- For example, a Curve Data clue. -drawCurve :: Backend' b => [Edge] -> Diagram b R2 -drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) - --- | Draw a shadow in the style of Afternoon Skyscrapers. -drawShade :: Backend' b => Shade -> Diagram b R2 -drawShade (Shade s w) = (if s then south else mempty) <> - (if w then west else mempty) - where - shape = translate (r2 (-1/2, -1/2)) . fromVertices . map p2 $ - [ (0, 0), (1/4, 1/4), (1, 1/4), (1, 0), (0, 0) ] - south = strokeLocLoop shape # lwG 0 # fc gray - west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south - --- | Draws the digits of a tapa clue, ordered --- left to right, top to bottom. -drawTapaClue :: Backend' b => - TapaClue -> Diagram b R2 -drawTapaClue (TapaClue [x]) = drawInt x -drawTapaClue (TapaClue xs) = fit 0.8 - . decoratePath (p (length xs)) - . map drawInt - $ xs - where - p n = centerXY (p' n) - p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4) - p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8 - p' 4 = reflectX . rotateBy (3/8) $ square 0.7 - p' 1 = error "singleton clues handled separately" - p' _ = error "invalid tapa clue" - -drawPrimeDiag :: Backend' b => - PrimeDiag -> Diagram b R2 -drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white) - where - p = case d of (False, False) -> mempty - (True, False) -> ur - (False, True) -> dr - (True, True) -> ur <> dr - -drawCrossing :: Backend' b => Crossing -> Diagram b R2 -drawCrossing = const $ drawChar '+' - -drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b R2 -drawBahnhofClue = either drawInt drawCrossing diff --git a/src/Diagrams/Puzzles/Grid.hs b/src/Diagrams/Puzzles/Grid.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Grid.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.Grid where - -import Data.Char (isUpper) -import qualified Data.Map as M - -import Diagrams.Prelude - -import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size, cells) - -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Widths - --- | Draw a small black dot with no envelope. -dot :: Backend' b => Diagram b R2 -dot = circle 0.05 # fc black # smash - --- | Draw a Slither Link style grid of dots of the specified size. -slithergrid :: Backend' b => - Size -> Diagram b R2 -slithergrid (x, y) = - hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot - -fence :: [Double] -> Double -> Path R2 -fence xs h = decoratePath xspath (repeat v) - where - xspath = fromVertices [ p2 (x, 0) | x <- xs ] - v = alignB (vrule h) - --- | The inner grid lines of a square grid of the specified size. -gridlines :: Size -> Path R2 -gridlines (w, h) = fence' w h <> mirror (fence' h w) - where - fence' n l = fence (map fromIntegral [1..n-1]) (fromIntegral l) - -fullgridlines :: Size -> Path R2 -fullgridlines (w, h) = fence' w h <> mirror (fence' h w) - where - fence' n l = fence (map fromIntegral [0..n]) (fromIntegral l) - --- | Draw a frame around the outside of a rectangle. -outframe' :: Backend' b => Double -> Size -> Diagram b R2 -outframe' f (w, h) = strokePointLoop r # lwG fw - where wd = fromIntegral w - hd = fromIntegral h - strokePointLoop = strokeLocTrail . mapLoc (wrapLoop . closeLine) - . fromVertices . map p2 - fw = f * gridwidth - e = fw / 2 - gridwidth / 2 - r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)] - -outframe :: Backend' b => Size -> Diagram b R2 -outframe = outframe' framewidthfactor - --- | Draw a square grid, applying the given style to the grid lines. -grid' :: Backend' b => - (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2 -grid' gridstyle s = - outframe s - <> stroke (gridlines s) # lwG gridwidth # gridstyle - --- | Draw a square grid with default grid line style. -grid :: Backend' b => - Size -> Diagram b R2 -grid = grid' id - --- | Draw a square grid with thin frame. -plaingrid :: Backend' b => - Size -> Diagram b R2 -plaingrid s = stroke (fullgridlines s) # lwG gridwidth - -bgdashingG :: (Semigroup a, HasStyle a, V a ~ R2) => - [Double] -> Double -> Colour Double -> a -> a -bgdashingG ds offs c x = x # dashingG ds offs <> x # lc c - -dashes :: [Double] -dashes = [5 / 40, 3 / 40] - -dashoffset :: Double -dashoffset = 2.5 / 40 - -gridDashing :: (Semigroup a, HasStyle a, V a ~ R2) => a -> a -gridDashing = bgdashingG dashes dashoffset white' - where - white' = blend 0.95 white black - --- | Draw a square grid with dashed grid lines. The gaps --- between dashes are off-white to aid in using filling --- tools. -dashedgrid :: Backend' b => - Size -> Diagram b R2 -dashedgrid = grid' gridDashing - -edgePath :: Edge' (Vertex Square) -> Path R2 -edgePath (E' v R) = p2i v ~~ p2i (v ^+^ (1,0)) -edgePath (E' v L) = p2i v ~~ p2i (v ^+^ (-1,0)) -edgePath (E' v U) = p2i v ~~ p2i (v ^+^ (0,1)) -edgePath (E' v D) = p2i v ~~ p2i (v ^+^ (0,-1)) - -irregularGridPaths :: SGrid a -> (Path R2, Path R2) -irregularGridPaths (Grid _ m) = (toPath outer, toPath inner) - where - (outer, inner) = edges (M.keysSet m) (`M.member` m) - toPath = mconcat . map edgePath - -irregularGrid :: Backend' b => - SGrid a -> Diagram b R2 -irregularGrid g = stroke outer # lwG (3 * gridwidth) # lineCap LineCapSquare <> - stroke inner # lwG gridwidth - where - (outer, inner) = irregularGridPaths g - --- | In a square grid, use the first argument to draw things at the centres --- of cells given by coordinates. -atCentres :: (Transformable a, Monoid a, V a ~ R2) => - (t -> a) -> [(Coord, t)] -> a -atCentres dc = translate (r2 (1/2, 1/2)) . atVertices dc - -atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a] -atCentres' = translate (r2 (1/2, 1/2)) . atVertices' - --- | In a square grid, use the first argument to draw things --- at the grid vertices given by coordinates. -atVertices :: (Transformable a, Monoid a, V a ~ R2) => - (t -> a) -> [(Coord, t)] -> a -atVertices dc = mconcat . map (\ (p, c) -> dc c # translatep p) - -atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a] -atVertices' g = [ (g ! c) # translatep c | c <- cells g ] - -edge :: Edge -> Path R2 -edge (E c d) = rule d # translate (r2i c) - where - rule V = vrule 1.0 # alignB - rule H = hrule 1.0 # alignL - -dualEdge :: Edge -> Path R2 -dualEdge = translate (r2 (1/2, 1/2)) . edge - -edgeStyle :: (HasStyle a, V a ~ R2) => a -> a -edgeStyle = lineCap LineCapSquare . lwG edgewidth - -thinEdgeStyle :: (HasStyle a, V a ~ R2) => a -> a -thinEdgeStyle = lineCap LineCapSquare . lwG onepix - -drawEdges :: Backend' b => [Edge] -> Diagram b R2 -drawEdges = edgeStyle . stroke . mconcat . map edge - -drawDualEdges :: Backend' b => [Edge] -> Diagram b R2 -drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge - -drawThinDualEdges :: Backend' b => [Edge] -> Diagram b R2 -drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge - -drawAreaGrid :: (Backend' b, Eq a) => - SGrid a -> Diagram b R2 -drawAreaGrid = drawEdges . borders <> grid . size - -fillBG :: Backend' b => Colour Double -> Diagram b R2 -fillBG c = square 1 # lwG onepix # fc c # lc c - -shadeGrid :: Backend' b => - SGrid (Maybe (Colour Double)) -> Diagram b R2 -shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG) - -drawShadedGrid :: Backend' b => - SGrid Bool -> Diagram b R2 -drawShadedGrid = shadeGrid . fmap f - where - f True = Just gray - f False = Nothing - -drawAreaGridGray :: Backend' b => - SGrid Char -> Diagram b R2 -drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols - where - cols c | isUpper c = Just (blend 0.1 black white) - | otherwise = Nothing - -irregAreaGridX :: Backend' b => - SGrid Char -> Diagram b R2 -irregAreaGridX = irregularGrid <> drawEdges . borders <> shadeGrid . fmap cols - where - cols 'X' = Just gray - cols _ = Nothing - --- Place a list of diagrams along a ray, with steps of size --- @f@. -distrib :: (Transformable c, Monoid c, V c ~ R2) => - R2 -> (Int, Int) -> Double -> [c] -> c -distrib base dir f xs = - translate (0.75 *^ dir' ^+^ base) . mconcat $ - zipWith (\i d -> translate (fromIntegral i *^ dir') d) [(0 :: Int)..] xs - where - dir' = f *^ r2i dir - -outsideGen :: (Transformable c, Monoid c, V c ~ R2) => - (OutsideClue [c] -> R2) -> Double -> [OutsideClue [c]] -> c -outsideGen tobase f ocs = mconcat . map placeOC $ ocs - where - placeOC o = distrib (tobase o) (ocDir o) f (ocValue o) - -outsideCells :: (Transformable c, Monoid c, V c ~ R2) => - Double -> [OutsideClue [c]] -> c -outsideCells = outsideGen base - where - base (OClue (bx, by) (dx, dy) _) - | dx /= 0 = r2 (fromIntegral bx - 1, fromIntegral by - 1/2) - | dy /= 0 = r2 (fromIntegral bx - 1/2, fromIntegral by) - | otherwise = error "invalid outside clue" - -outsideVertices :: (Transformable c, Monoid c, V c ~ R2) => - Double -> [OutsideClue [c]] -> c -outsideVertices = outsideGen base - where - base (OClue (bx, by) (dx, dy) _) - | dx /= 0 = r2 (fromIntegral bx, fromIntegral by) - | dy /= 0 = r2 (fromIntegral bx, fromIntegral by) - | otherwise = error "invalid outside clue" diff --git a/src/Diagrams/Puzzles/Lib.hs b/src/Diagrams/Puzzles/Lib.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Lib.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.Lib where - -import Diagrams.Prelude - -import Graphics.SVGFonts.ReadFont -import Control.Arrow ((***)) - -import Paths_puzzle_draw (getDataFileName) -import System.IO.Unsafe (unsafePerformIO) - -type Backend' b = (Backend b R2, Renderable (Path R2) b) - --- | Vertical/horizontal stroked line of given length. -vline, hline :: Backend' b => Double -> Diagram b R2 -vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)] -hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)] - --- | Variant of 'hcat'' that spreads with distance @1@. -hcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a -hcatsep = hcat' with {_sep = 1} - --- | Variant of 'vcat'' that spreads with distance @1@, --- and stacks towards the top. -vcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a -vcatsep = cat' (r2 (0,1)) with {_sep = 1} - --- | Collapse the envelope to a point. -smash :: Backend' b => QDiagram b R2 Any -> QDiagram b R2 Any -smash = withEnvelope (pointDiagram origin :: D R2) - --- | Helper to translate by a point given as @(Int, Int)@. -translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t -translatep = translate . r2i - --- | Convert pair of @Int@ to vector. -r2i :: (Int, Int) -> R2 -r2i = r2 . (fromIntegral *** fromIntegral) - --- | Convert pair of @Int@ to point. -p2i :: (Int, Int) -> P2 -p2i = p2 . (fromIntegral *** fromIntegral) - -mirror :: (Transformable t, V t ~ R2) => t -> t -mirror = reflectAbout (p2 (0, 0)) (r2 (1, 1)) - --- | Interleave two lists. -interleave :: [a] -> [a] -> [a] -interleave [] _ = [] -interleave (x:xs) ys = x : interleave ys xs - --- | Spread diagrams evenly along the given vector. -spread :: Backend' b => R2 -> [Diagram b R2] -> Diagram b R2 -spread v things = cat v . interleave (repeat (strut vgap)) $ things - where ds = map (diameter v) things - gap' = (magnitude v - sum ds) / fromIntegral (length things + 1) - vgap = (gap' / magnitude v) *^ v - -dmid :: (Enveloped a, V a ~ R2) => a -> Double -dmid a = (dtop + dbot) / 2 - dbot - where menv v = magnitude . envelopeV v - dtop = menv unitY a - dbot = menv ((-1) *^ unitY) a - --- | Place the second diagram to the right of the first, aligning both --- vertically. The origin is the origin of the left diagram. -besidesL :: (Backend' b, Semigroup m, Monoid m) => - QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m -besidesL a b = a ||| strutX 0.5 ||| b' - where b' = b # centerY # translate (dmid a *^ unitY) - --- | Variant of 'besidesL' where the origin is that of the right diagram. -besidesR :: (Backend' b, Semigroup m, Monoid m) => - QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m -besidesR b a = b' ||| strutX 0.5 ||| a - where b' = b # centerY # translate (dmid a *^ unitY) - --- | @fit f a@ scales @a@ to fit into a square of size @f@. -fit :: (Transformable t, Enveloped t, V t ~ R2) => - Double -> t -> t -fit f a = scale (f / m) a - where m = max (magnitude (diameter unitX a)) - (magnitude (diameter unitY a)) - --- | Write text that is centered both vertically and horizontally and that --- has an envelope. Sized such that single capital characters fit nicely --- into a square of size @1@. -text' :: Backend' b => String -> Diagram b R2 -text' t = stroke (textSVG' $ TextOpts t fnt INSIDE_H KERN False 1 1) - # lwG 0 # fc black # scale 0.8 - where - fnt = outlMap . unsafePerformIO . getDataFileName - $ "data/fonts/gen-light.svg" - --- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07)) --- <> phantom' (textrect t) ---textrect :: Backend' b => String -> Diagram b R2 ---textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red ---text'' :: Backend' b => String -> Diagram b R2 ---text'' t = text' t `atop` textrect t - --- | Variant of 'phantom' that forces the argument backend type. -phantom' :: Backend' b => Diagram b R2 -> Diagram b R2 -phantom' = phantom diff --git a/src/Diagrams/Puzzles/PuzzleGrids.hs b/src/Diagrams/Puzzles/PuzzleGrids.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/PuzzleGrids.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.PuzzleGrids where - -import Diagrams.Prelude - -import Data.Puzzles.Grid -import Data.Puzzles.Elements -import Data.Puzzles.Sudoku - -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Grid -import Diagrams.Puzzles.Widths -import Diagrams.Puzzles.Elements - -drawClueGrid :: Backend' b => - SGrid (Clue Char) -> Diagram b R2 -drawClueGrid = atCentres drawChar . clues <> grid . size - -drawIntClues :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawIntClues = atCentres drawInt . clues - -drawInts :: Backend' b => - SGrid Int -> Diagram b R2 -drawInts = atCentres drawInt . values - -drawIntGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawIntGrid = drawIntClues <> grid . size - -drawSlitherGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size - -drawMasyuGrid :: Backend' b => - SGrid MasyuClue -> Diagram b R2 -drawMasyuGrid = atCentres pearl . clues <> grid . size - -drawCompassClues :: Backend' b => - SGrid CompassClue -> Diagram b R2 -drawCompassClues = atCentres drawCompassClue . clues - -drawCompassGrid :: Backend' b => - SGrid CompassClue -> Diagram b R2 -drawCompassGrid = drawCompassClues <> grid . size - -sudokugrid :: Backend' b => - SGrid a -> Diagram b R2 -sudokugrid = drawEdges . sudokubordersg <> grid . size - -drawWordsClues :: Backend' b => - SGrid (Clue [String]) -> Diagram b R2 -drawWordsClues = atCentres drawWords . clues - -drawTightGrid :: Backend' b => - (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2 -drawTightGrid d g = atCentres (drawTight d) (values g) - <> grid (size g) - <> phantom' (stroke $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1)) - where (sx, sy) = size g - -drawSlalomGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawSlalomGrid g = atVertices drawSlalomClue (clues g) - <> grid (w-1, h-1) - where (w, h) = size g - -drawSlalomDiags :: Backend' b => - SGrid SlalomDiag -> Diagram b R2 -drawSlalomDiags = atCentres diag . clues . fmap Just - where diag SlalomForward = stroke ur # lwG edgewidth - diag SlalomBackward = stroke dr # lwG edgewidth - -drawCrosses :: Backend' b => - SGrid Bool -> Diagram b R2 -drawCrosses = atCentres (if' drawCross mempty) . values - where - if' a b x = if x then a else b - - -outsideGrid :: Backend' b => - OutsideClues [String] -> Diagram b R2 -outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues - <> grid . outsideSize - -outsideIntGrid :: Backend' b => - OutsideClues [Int] -> Diagram b R2 -outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues - <> grid . outsideSize diff --git a/src/Diagrams/Puzzles/PuzzleTypes.hs b/src/Diagrams/Puzzles/PuzzleTypes.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/PuzzleTypes.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.PuzzleTypes ( - lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa, - sudoku, thermosudoku, pyramid, kpyramid, slither, - liarslither, tightfitskyscrapers, wordloop, wordsearch, - curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, - coral, maximallengths, primeplace, labyrinth, bahnhof, - cave - ) where - -import Diagrams.Prelude hiding (Loop, coral) - -import Diagrams.Puzzles.PuzzleGrids -import Diagrams.Puzzles.Draw -import Diagrams.Puzzles.Grid -import qualified Diagrams.Puzzles.Pyramid as DPyr -import Diagrams.Puzzles.Elements -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Widths - -import Data.Puzzles.Grid -import Data.Puzzles.GridShape (Edge) -import Data.Puzzles.Elements -import qualified Data.Puzzles.Pyramid as Pyr - -lits :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid -lits = (,) - drawAreaGridGray - (drawAreaGrid . fst <> drawShadedGrid . snd) - -litsplus :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid -litsplus = lits - -solstyle :: (HasStyle a, V a ~ R2) => a -> a -solstyle = lc (blend 0.8 black white) . lwG (3 * onepix) - -geradeweg :: Backend' b => RenderPuzzle b IntGrid Loop -geradeweg = (,) - drawIntGrid - (drawIntClues . fst - <> solstyle . drawDualEdges . snd - <> grid . size . fst) - -fillomino :: Backend' b => RenderPuzzle b IntGrid (SGrid Int) -fillomino = (,) - (atCentres drawInt . clues <> dashedgrid . size) - ((atCentres drawInt . values <> drawEdges . borders <> dashedgrid . size) . snd) - -masyu :: Backend' b => - RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop -masyu = (,) - drawMasyuGrid - (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst) - -nurikabe :: Backend' b => - RenderPuzzle b IntGrid ShadedGrid -nurikabe = (,) - drawIntGrid - (drawIntGrid . fst <> drawShadedGrid . snd) - -latintapa :: Backend' b => - RenderPuzzle b (SGrid (Clue [String])) CharClueGrid -latintapa = (,) - l - (l . fst <> atCentres drawChar . clues . snd) - where - l = grid . size <> drawWordsClues - -sudoku :: Backend' b => - RenderPuzzle b IntGrid IntGrid -sudoku = (,) - (drawIntClues <> sudokugrid) - ((drawIntClues <> sudokugrid) . snd) - -thermosudoku :: Backend' b => - RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid -thermosudoku = (,) - (drawInts . fst <> sudokugrid . fst <> drawThermos . snd) - (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst) - -pyramid :: Backend' b => - RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol -pyramid = (,) - DPyr.pyramid - (DPyr.pyramid . merge) - where - merge (p, q) = Pyr.mergepyramidsol p q - -kpyramid :: Backend' b => - RenderPuzzle b Pyr.RowKropkiPyramid Pyr.PyramidSol -kpyramid = (,) - DPyr.kpyramid - (DPyr.kpyramid . merge) - where - merge (p, q) = Pyr.mergekpyramidsol p q - -slither :: Backend' b => - RenderPuzzle b IntGrid Loop -slither = (,) - drawSlitherGrid - (drawSlitherGrid . fst <> solstyle . drawEdges . snd) - -liarslither :: Backend' b => - RenderPuzzle b IntGrid (Loop, SGrid Bool) -liarslither = (,) - drawSlitherGrid - (solstyle . drawCrosses . snd . snd - <> drawSlitherGrid . fst - <> solstyle . drawEdges . fst . snd) - -tightfitskyscrapers :: Backend' b => - RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ())) - (SGrid (Tightfit Int)) -tightfitskyscrapers = (,) - (atCentres drawInt . outsideClues . fst - <> drawTightGrid (const mempty) . snd) - (atCentres drawInt . outsideClues . fst . fst - <> drawTightGrid drawInt . snd) - -wordgrid :: Backend' b => - SGrid (Maybe Char) -> [String] -> Diagram b R2 -wordgrid g ws = stackWords ws `besidesR` drawClueGrid g - -wordloop :: Backend' b => - RenderPuzzle b (CharClueGrid, [String]) CharClueGrid -wordloop = (,) - (uncurry wordgrid) - (drawClueGrid . snd) - -wordsearch :: Backend' b => - RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord]) -wordsearch = (,) - (uncurry wordgrid) - (solstyle . drawMarkedWords . snd . snd - <> drawClueGrid . fst . snd) - -curvedata :: Backend' b => - RenderPuzzle b (SGrid (Clue [Edge])) [Edge] -curvedata = (,) - cd - ((solstyle . drawDualEdges . snd) <> cd . fst) - where - cd = atCentres drawCurve . clues <> grid . size - -doubleback :: Backend' b => - RenderPuzzle b AreaGrid Loop -doubleback = (,) - drawAreaGridGray - (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst) - -slalom :: Backend' b => - RenderPuzzle b IntGrid (SGrid SlalomDiag) -slalom = (,) - drawSlalomGrid - (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd) - -compass :: Backend' b => - RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid -compass = (,) - drawCompassGrid - (drawCompassClues . fst <> drawAreaGridGray . snd) - -boxof2or3 :: Backend' b => - RenderPuzzle b (SGrid MasyuPearl, [Edge]) () -boxof2or3 = (,) - (atCentres smallPearl . values . fst - <> phantom' . grid . size . fst - <> drawThinDualEdges . snd) - (error "boxof2or3 solution not implemented") - -afternoonskyscrapers :: Backend' b => - RenderPuzzle b (SGrid Shade) IntGrid -afternoonskyscrapers = (,) - (grid . size <> atCentres drawShade . values) - (drawIntGrid . snd <> atCentres drawShade . values . fst) - -meanderingnumbers :: Backend' b => - RenderPuzzle b AreaGrid IntGrid -meanderingnumbers = (,) - drawAreaGrid - (drawIntGrid . snd <> drawAreaGrid . fst) - -tapa :: Backend' b => - RenderPuzzle b (SGrid TapaClue) ShadedGrid -tapa = (,) - tapaGrid - (tapaGrid . fst <> drawShadedGrid . snd) - where - tapaGrid = atCentres drawTapaClue . values <> grid . size - -japanesesums :: Backend' b => - RenderPuzzle b (OutsideClues [Int]) (SGrid (Either Black Int)) -japanesesums = (,) - outsideIntGrid - (outsideIntGrid . fst <> japcells . snd) - where - japcells = atCentres japcell . values - japcell (Left Black) = fillBG gray - japcell (Right x) = drawInt x - -coral :: Backend' b => - RenderPuzzle b (OutsideClues [String]) ShadedGrid -coral = (,) - outsideGrid - (outsideGrid . fst <> drawShadedGrid . snd) - -maximallengths :: Backend' b => - RenderPuzzle b (OutsideClues (Maybe Int)) Loop -maximallengths = (,) - g - (solstyle . drawDualEdges . snd <> g . fst) - where - g = atCentres drawInt . outsideClues - <> grid . outsideSize - -primeplace :: Backend' b => - RenderPuzzle b (SGrid PrimeDiag) (SGrid Int) -primeplace = (,) - g - (atCentres drawInt . values . snd <> g . fst) - where - g = irregularGrid <> atCentres drawPrimeDiag . values - -labyrinth :: Backend' b => - RenderPuzzle b (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) -labyrinth = (,) - (atCentres drawInt . clues . fst <> g) - (atCentres drawInt . clues . snd <> g . fst) - where - g = drawEdges . snd <> plaingrid . size . fst - -bahnhof :: Backend' b => - RenderPuzzle b (SGrid (Maybe BahnhofClue)) [Edge] -bahnhof = (,) - (atCentres drawBahnhofClue . clues <> grid . size) - (atCentres drawBahnhofStation . clues . fst - <> solstyle . drawDualEdges . snd - <> grid . size . fst) - where - drawBahnhofStation = either drawInt (const mempty) - -cave :: - (Backend b R2, Renderable (Path R2) b) => - RenderPuzzle b (SGrid (Clue Int)) ShadedGrid -cave = (,) - g - (drawEdges . edgesGen (/=) not . snd - <> drawShadedGrid . snd <> fr . fst - <> g . fst) - where - g = gridDashing . plaingrid . size <> atCentres drawInt . clues - fr gr = outframe' 8 (size gr) # lc gray diff --git a/src/Diagrams/Puzzles/Pyramid.hs b/src/Diagrams/Puzzles/Pyramid.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Pyramid.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} - -module Diagrams.Puzzles.Pyramid where - -import Diagrams.Prelude - -import Data.Puzzles.Elements -import Data.Puzzles.Pyramid -import Diagrams.Puzzles.Lib -import Diagrams.Puzzles.Widths - -pgray :: Colour Double -pgray = blend 0.6 white black - -cell :: Backend' b => Bool -> Diagram b R2 -cell s = square 1 # lwG onepix # if s then fc pgray else id - -clue :: Backend' b => Maybe Int -> Diagram b R2 -clue Nothing = mempty -clue (Just c) = text' (show c) - -cellc :: Backend' b => Bool -> Maybe Int -> Diagram b R2 -cellc s c = clue c `atop` cell s - -row :: Backend' b => Row -> Diagram b R2 -row (R cs s) = centerX . hcat . map (cellc s) $ cs - -pyramid :: Backend' b => Pyramid -> Diagram b R2 -pyramid = alignBL . vcat . map row . unPyr - -kropki :: Backend' b => KropkiDot -> Diagram b R2 -kropki KNone = mempty -kropki c = circle 0.1 # lwG 0.03 # fc (col c) # smash - where col KWhite = white - col KBlack = blend 0.98 black white - col KNone = error "can't reach" - -krow :: Backend' b => KropkiRow -> Diagram b R2 -krow (KR cs s ks) = ccat dots <> ccat clues - where ccat = centerX . hcat - clues = map (cellc s) cs - dots = interleave (map phantom' clues) (map kropki ks) - -kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b R2 -kpyramid = alignBL . vcat . map krow . unKP diff --git a/src/Diagrams/Puzzles/Widths.hs b/src/Diagrams/Puzzles/Widths.hs deleted file mode 100644 --- a/src/Diagrams/Puzzles/Widths.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Diagrams.Puzzles.Widths where - -gridres :: Int -gridres = 40 - -gridresd :: Double -gridresd = fromIntegral gridres - -onepix :: Double -onepix = 1 / fromIntegral gridres - -twopix, fourpix :: Double -twopix = 2 * onepix -fourpix = 4 * onepix - -gridwidth :: Double -gridwidth = onepix - -framewidthfactor :: Double -framewidthfactor = 4 - -edgewidth, borderwidth :: Double -edgewidth = 3 * onepix -borderwidth = 1 / 2 diff --git a/src/Draw/CmdLine.hs b/src/Draw/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Draw/CmdLine.hs @@ -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 diff --git a/src/Draw/Code.hs b/src/Draw/Code.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Code.hs @@ -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 diff --git a/src/Draw/Draw.hs b/src/Draw/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Draw.hs @@ -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) diff --git a/src/Draw/Elements.hs b/src/Draw/Elements.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Elements.hs @@ -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 + diff --git a/src/Draw/Grid.hs b/src/Draw/Grid.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Grid.hs @@ -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 diff --git a/src/Draw/Lib.hs b/src/Draw/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Lib.hs @@ -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 +-} diff --git a/src/Draw/PuzzleGrids.hs b/src/Draw/PuzzleGrids.hs new file mode 100644 --- /dev/null +++ b/src/Draw/PuzzleGrids.hs @@ -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) diff --git a/src/Draw/PuzzleTypes.hs b/src/Draw/PuzzleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Draw/PuzzleTypes.hs @@ -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 diff --git a/src/Draw/Pyramid.hs b/src/Draw/Pyramid.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Pyramid.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Draw.Pyramid where + +import Diagrams.Prelude + +import Data.Pyramid +import Draw.Elements +import Draw.Lib +import Draw.Widths + +pgray :: Colour Double +pgray = blend 0.6 white black + +cell :: Backend' b => Bool -> Diagram b +cell s = square 1 # lwG onepix # if s then fc pgray else id + +clue :: Backend' b => Maybe Int -> Diagram b +clue Nothing = mempty +clue (Just c) = text' (show c) + +cellc :: Backend' b => Bool -> Maybe Int -> Diagram b +cellc s c = clue c `atop` cell s + +row :: Backend' b => Row -> Diagram b +row (R cs s) = centerX . hcat . map (cellc s) $ cs + +pyramid :: Backend' b => Pyramid -> Diagram b +pyramid = alignBL . vcat . map row . unPyr + +krow :: Backend' b => KropkiRow -> Diagram b +krow (KR cs s ks) = ccat dots <> ccat clues + where ccat = centerX . hcat + clues = map (cellc s) cs + dots = interleave (map phantom clues) (map kropkiDot ks) + +kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b +kpyramid = alignBL . vcat . map krow . unKP diff --git a/src/Draw/Style.hs b/src/Draw/Style.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Style.hs @@ -0,0 +1,50 @@ +module Draw.Style + ( LineStyle (..) + , FrameStyle (..) + , VertexStyle (..) + , GridStyle (..) + + , gDefault + , gDashed + , gDashedThick + , gPlain + , gPlainDashed + , gSlither + ) where + +import Draw.Widths + +import Diagrams.Prelude + +data LineStyle = + LineNone + | LineThin + | LineDashed + | LineThick + +data FrameStyle = FrameStyle + { _fWidthFactor :: Double + , _fColour :: Colour Double + } + +data VertexStyle = + VertexNone + | VertexDot + +data GridStyle = GridStyle + { _line :: LineStyle + , _border :: LineStyle + , _frame :: Maybe FrameStyle + , _vertex :: VertexStyle + } + +gDefault, gSlither, gDashed, gDashedThick, gPlain, gPlainDashed :: GridStyle +gDefault = GridStyle LineThin LineThin + (Just (FrameStyle framewidthfactor black)) VertexNone +gSlither = GridStyle LineNone LineNone Nothing VertexDot +gDashed = GridStyle LineDashed LineThin + (Just (FrameStyle framewidthfactor black)) VertexNone +gDashedThick = GridStyle LineDashed LineThick + Nothing VertexNone +gPlain = GridStyle LineThin LineThin Nothing VertexNone +gPlainDashed = GridStyle LineDashed LineDashed Nothing VertexNone diff --git a/src/Draw/Widths.hs b/src/Draw/Widths.hs new file mode 100644 --- /dev/null +++ b/src/Draw/Widths.hs @@ -0,0 +1,26 @@ +module Draw.Widths where + +gridres :: Int +gridres = 40 + +gridresd :: Double +gridresd = fromIntegral gridres + +onepix :: Double +onepix = 1 / fromIntegral gridres + +twopix, fourpix :: Double +twopix = 2 * onepix +fourpix = 4 * onepix + +gridwidth :: Double +gridwidth = onepix + +framewidthfactor :: Double +framewidthfactor = 4 + +edgewidth :: Double +edgewidth = 3 * onepix + +borderwidth :: Double +borderwidth = 1 / 4 diff --git a/src/Parse/Code.hs b/src/Parse/Code.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Code.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Parse.Code where + +import Data.Code +import Parse.Util + +import Data.Yaml + +import Data.Maybe (catMaybes) + +parseCode :: Value -> Parser [CodePart] +parseCode (Object v) = fmap catMaybes . sequenceA $ + [ fmap Rows' <$> v .:? "cell_rows_bottom" + , fmap Cols <$> v .:? "cell_cols" + , fmap RowsN' <$> v .:? "node_rows_bottom" + , fmap ColsN <$> v .:? "node_cols" + , fmap (LabelsN . fmap (fmap unAlpha . blankToMaybe)) <$> (do + v' <- v .:? "node_labels" + sequenceA (parseGrid <$> v')) + , fmap LRows' <$> (v .:? "cell_rows_bottom_labeled" >>= traverse parseCharMap) + , fmap LCols <$> (v .:? "cell_cols_labeled" >>= traverse parseCharMap) + , fmap LRowsN' <$> (v .:? "node_rows_bottom_labeled" >>= traverse parseCharMap) + , fmap LColsN <$> (v .:? "node_cols_labeled" >>= traverse parseCharMap) + ] +parseCode _ = fail "expected object" diff --git a/src/Parse/Parsec.hs b/src/Parse/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Parsec.hs @@ -0,0 +1,30 @@ +-- | Parsec helper for puzzle file parsing. +module Parse.Parsec ( + toParser + , toStringParser + , fraction + ) where + +import Text.ParserCombinators.Parsec hiding ((<|>)) +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import Control.Applicative + +import Data.Elements + +toParser :: GenParser a () b -> [a] -> Yaml.Parser b +toParser p v = case parse p "(unknown)" v of Left e -> fail (show e) + Right x -> pure x + +toStringParser :: GenParser Char () b -> Yaml.Value -> Yaml.Parser b +toStringParser p v = case v of + Yaml.String t -> toParser p (T.unpack t) + _ -> fail "expected string" + +-- | fraction is meant to parse things like "1 1/2", "3/10", "7". +fraction :: GenParser Char st Fraction +fraction = do + a <- many1 digit <* spaces + FComp a <$> many1 digit <*> (char '/' *> many1 digit) + <|> FFrac a <$> (char '/' *> many1 digit) + <|> pure (FInt a) diff --git a/src/Parse/Puzzle.hs b/src/Parse/Puzzle.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Puzzle.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Parse.Puzzle where + +import Data.Yaml +import Control.Applicative + +import Data.PuzzleTypes + +data TypedPuzzle = TP (Maybe String) Value (Maybe Value) (Maybe Value) + deriving Show + +instance FromJSON TypedPuzzle where + parseJSON (Object v) = TP <$> + v .:? "type" <*> + v .: "puzzle" <*> + v .:? "solution" <*> + v .:? "code" + parseJSON _ = empty + +-- | A pair of parsers for a puzzle type. +-- First parses the puzzle, second the solution. +type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b) + +parseType :: String -> Parser PuzzleType +parseType t = case lookupType t of + Nothing -> fail $ "unknown puzzle type: " ++ t + Just p -> return p diff --git a/src/Parse/PuzzleTypes.hs b/src/Parse/PuzzleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Parse/PuzzleTypes.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Parse.PuzzleTypes ( + lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa, + sudoku, thermosudoku, pyramid, kpyramid, slither, + liarslither, tightfitskyscrapers, wordloop, wordsearch, + curvedata, doubleback, slalom, compass, boxof2or3, + afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral, + maximallengths, primeplace, labyrinth, bahnhof, cave, angleLoop, + shikaku, slovaksums, blackoutDominos, + anglers, skyscrapers, summon, baca, + buchstabensalat, doppelblock, sudokuDoppelblock, dominos, + skyscrapersStars, numberlink, slithermulti, dominoPills, + fillominoLoop, loopki, scrabble, neighbors, starwars, + heyawake, wormhole, pentominous, starbattle, colorakari, + persistenceOfMemory, abctje, kropki, statuepark, pentominousBorders, + nanroSignpost, tomTom, horseSnake, illumination, pentopia, + pentominoPipes, greaterWall, galaxies, mines, tents, + pentominoSums, coralLits, coralLitso, snake, countryRoad, + killersudoku, friendlysudoku, japsummasyu + ) where + +import Control.Applicative +import Control.Monad + +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Yaml + +import Parse.Util +import Parse.Puzzle +import Data.Grid +import Data.GridShape +import qualified Data.Pyramid as Pyr +import Data.Elements + +lits :: ParsePuzzle AreaGrid (Grid C Bool) +lits = (parseGrid, parseShadedGrid) + +litsplus :: ParsePuzzle AreaGrid (Grid C Bool) +litsplus = lits + +geradeweg :: ParsePuzzle (Grid C (Maybe Int)) (Loop C) +geradeweg = (parseClueGrid, parseEdges) + +fillomino :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int) +fillomino = (parseExtClueGrid, parseExtGrid) + +fillominoLoop :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int, Loop C) +fillominoLoop = (,) + parseClueGrid + (\v -> (,) <$> parseFrom ["grid"] parseExtGrid v + <*> parseFrom ["loop"] parseEdges v) + +masyu :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop C) +masyu = (parseClueGrid, parseEdges) + +nurikabe :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) +nurikabe = (parseExtClueGrid, parseShadedGrid) + +latintapa :: ParsePuzzle (Grid C (Maybe [String])) (Grid C (Maybe Char)) +latintapa = ((unRG <$>) . parseJSON, + fmap (fmap (fmap unAlpha)) . parseClueGrid') + +sudoku :: ParsePuzzle (Grid C (Maybe Int)) (Grid C (Maybe Int)) +sudoku = (parseClueGrid, parseClueGrid) + +thermosudoku :: ParsePuzzle (Grid C (Maybe Int), [Thermometer]) + (Grid C (Maybe Int)) +thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid) + +killersudoku :: ParsePuzzle (AreaGrid, Map Char Int, Grid C (Maybe Int)) (Grid C Int) +killersudoku = (,) + (\v -> (,,) + <$> parseFrom ["cages"] parseGrid v + <*> parseFrom ["clues"] parseCharMap v + <*> (parseFrom ["grid"] parseClueGrid v <|> pure Map.empty)) + parseGrid + +pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol +pyramid = (parseJSON, parseJSON) + +kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol +kpyramid = (parseJSON, parseJSON) + +slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N) +slither = (parseClueGrid, parseEdges) + +slithermulti :: ParsePuzzle (Grid C (Clue Int), Int) [Edge N] +slithermulti = (p, parseEdges) + where p v = (,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["loops"] parseJSON v + +newtype LSol = LSol { unLSol :: (Loop N, Grid C Bool) } +instance FromJSON LSol where + parseJSON (Object v) = LSol <$> ((,) <$> + (parseEdges =<< v .: "loop") <*> + (parseShadedGrid =<< v .: "liars")) + parseJSON _ = mzero + +liarslither :: ParsePuzzle (Grid C (Maybe Int)) (Loop N, Grid C Bool) +liarslither = (parseClueGrid, (unLSol <$>) . parseJSON) + +tightfitskyscrapers :: ParsePuzzle + (OutsideClues C (Maybe Int), Grid C (Tightfit ())) + (Grid C (Tightfit Int)) +tightfitskyscrapers = (parseTightOutside, parseSpacedGrid) + +newtype GridWords = GW { unGW :: (Grid C (Maybe Char), [String]) } + +instance FromJSON GridWords where + parseJSON (Object v) = GW <$> ((,) <$> + (parseClueGrid =<< v .: "grid") <*> + v .: "words") + parseJSON _ = empty + +wordloop :: ParsePuzzle (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) +wordloop = ((unGW <$>) . parseJSON, parseClueGrid) + +newtype GridMarked = GM { unGM :: (Grid C (Maybe Char), [MarkedWord]) } + +instance FromJSON GridMarked where + parseJSON (Object v) = GM <$> ((,) <$> + (parseClueGrid =<< v .: "grid") <*> + (map unPMW <$> v .: "words")) + parseJSON _ = mzero + +wordsearch :: ParsePuzzle (Grid C (Maybe Char), [String]) + (Grid C (Maybe Char), [MarkedWord]) +wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON) + +newtype Curve = Curve { unCurve :: [Edge N] } + +instance FromJSON Curve where + parseJSON v = Curve <$> parsePlainEdges v + +curvedata :: ParsePuzzle (Grid C (Maybe [Edge N])) [Edge C] +curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges) + +doubleback :: ParsePuzzle AreaGrid (Loop C) +doubleback = (parseGrid, parseEdges) + +slalom :: ParsePuzzle (Grid N (Maybe Int)) (Grid C SlalomDiag) +slalom = (parseClueGrid, parseGrid) + +compass :: ParsePuzzle (Grid C (Maybe CompassC)) AreaGrid +compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid) + +boxof2or3 :: ParsePuzzle (Grid N MasyuPearl, [Edge N]) () +boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented") + +afternoonskyscrapers :: ParsePuzzle (Grid C Shade) (Grid C (Maybe Int)) +afternoonskyscrapers = (parseAfternoonGrid, parseGrid) + +-- this should be changed to support clue numbers +meanderingnumbers :: ParsePuzzle AreaGrid (Grid C (Maybe Int)) +meanderingnumbers = (parseGrid, parseGrid) + +tapa :: ParsePuzzle (Grid C (Maybe TapaClue)) (Grid C Bool) +tapa = (\v -> fmap (fmap unParseTapaClue) . unRG <$> parseJSON v, + parseShadedGrid) + +japanesesums :: ParsePuzzle (OutsideClues C [Int], String) + (Grid C (Either Black Int)) +japanesesums = (p, parseGrid) + where + p v@(Object o) = (,) <$> parseMultiOutsideClues v <*> o .: "digits" + p _ = empty + +coral :: ParsePuzzle (OutsideClues C [String]) (Grid C Bool) +coral = (,) + (fmap (fmap (map unIntString)) . parseMultiOutsideClues) + parseShadedGrid + +maximallengths :: ParsePuzzle (OutsideClues C (Maybe Int)) (Loop C) +maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v, + parseEdges) + +primeplace :: ParsePuzzle (Grid C PrimeDiag) (Grid C Int) +primeplace = (parseIrregGrid, parseIrregGrid) + +labyrinth :: ParsePuzzle (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int)) +labyrinth = (p, parseClueGrid') + where + p v@(Object o) = tup <$> parseFrom ["grid"] parseCellEdges v <*> o .: "digits" + p _ = mempty + tup (x,y) z = (x,y,z) + +bahnhof :: ParsePuzzle (Grid C (Maybe BahnhofClue)) [Edge C] +bahnhof = (parseClueGrid, parseEdges) + +blackoutDominos :: ParsePuzzle (Grid C (Clue Int), DigitRange) + (Grid C (Clue Int), AreaGrid) +blackoutDominos = (,) + (\v -> (,) <$> parseFrom ["grid"] parseIrregGrid v + <*> parseFrom ["digits"] parseStringJSON v) + (\v -> (,) <$> parseFrom ["values"] parseIrregGrid v + <*> parseFrom ["dominos"] parseIrregGrid v) + +angleLoop :: ParsePuzzle (Grid N (Clue Int)) VertexLoop +angleLoop = (parseClueGrid, parseCoordLoop) + +shikaku :: ParsePuzzle (Grid C (Maybe Int)) AreaGrid +shikaku = (parseExtClueGrid, parseGrid) + +slovaksums :: ParsePuzzle (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) +slovaksums = (p, parseClueGrid) + where + p v@(Object o) = (,) <$> g v <*> o .: "digits" + p _ = empty + g = (fmap (fmap unPSlovakClue) . unRG <$>) . parseJSON + +anglers :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Fish)) [Edge C] +anglers = ( parseOutsideGridMap blankToMaybe blankToMaybe' + , parseEdgesFull ) + +cave :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) +cave = (parseClueGrid, parseShadedGrid) + +parseOut :: FromJSON a => + Value -> Parser (OutsideClues k (Maybe a)) +parseOut v = fmap (blankToMaybe' . unEither') <$> parseOutside v + +skyscrapers :: ParsePuzzle (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +skyscrapers = (,) + (\v -> (,) <$> parseOut v + <*> parseFrom ["digits"] parseJSON v) + parseClueGrid + +skyscrapersStars :: ParsePuzzle (OutsideClues C (Maybe Int), Int) + (Grid C (Either Int Star)) +skyscrapersStars = (p, parseGrid) + where + p v@(Object o) = (,) <$> parseOut v <*> o .: "stars" + p _ = empty + +summon :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +summon = ( \v@(Object o) -> (,,) <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["outside"] parseOut v + <*> o .: "digits" + , parseClueGrid + ) + +baca :: ParsePuzzle + (Grid C (Maybe Char), OutsideClues C [Int], OutsideClues C (Maybe Char)) + (Grid C (Either Black Char)) +baca = ( \v -> (,,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["outside"] parseTopLeft v + <*> parseFrom ["outside"] parseBottomRight v + , parseGrid + ) + where + parseTopLeft (Object v) = do + l <- reverse <$> v .: "left" + t <- v .: "top" + return $ OC (map reverse l) [] [] (map reverse t) + parseTopLeft _ = empty + parseBottomRight (Object v) = do + b <- v .: "bottom" + r <- reverse <$> v .: "right" + oc <- OC [] <$> parseLine r <*> parseLine b <*> pure [] + return $ fmap blankToMaybe' oc + parseBottomRight _ = empty + +buchstabensalat :: ParsePuzzle (OutsideClues C (Maybe Char), String) + (Grid C (Maybe Char)) +buchstabensalat = + ( p + , fmap (fmap blankToMaybe') . parseGrid + ) + where + p v = (,) + <$> (fmap blankToMaybe <$> parseCharOutside v) + <*> parseFrom ["letters"] parseJSON v + +doppelblock :: ParsePuzzle (OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +doppelblock = + ( \v -> fmap (blankToMaybe' . unEither') <$> parseOutside v + , parseGrid + ) + +sudokuDoppelblock :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +sudokuDoppelblock = + ( \v -> (,) <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["outside"] parseOutInts v + , parseGrid + ) + where + parseOutInts v = fmap (blankToMaybe' . unEither') <$> parseOutside v + +dominos :: ParsePuzzle (Grid C (Maybe Int), DigitRange) AreaGrid +dominos = (p, parseGrid) + where + p v = (,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["digits"] parseStringJSON v + +dominoPills :: ParsePuzzle (Grid C (Maybe Int), DigitRange, DigitRange) + AreaGrid +dominoPills = (p, parseGrid) + where + p v = (,,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["digits"] parseStringJSON v + <*> parseFrom ["pills"] parseStringJSON v + +numberlink :: ParsePuzzle (Grid C (Maybe Int)) [Edge C] +numberlink = (p, fmap collectLines . p) + where + p = fmap (fmap (blankToMaybe . unEither')) . parseExtGrid + +loopki :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop N) +loopki = (parseClueGrid, parseEdges) + +scrabble :: ParsePuzzle (Grid C Bool, [String]) (Grid C (Maybe Char)) +scrabble = (p, parseClueGrid) + where + p v = (,) <$> parseFrom ["grid"] parseStarGrid v + <*> parseFrom ["words"] parseJSON v + parseStarGrid v = fmap ((==) '*') <$> parseGrid v + +neighbors :: ParsePuzzle (Grid C Bool, Grid C (Maybe Int)) (Grid C Int) +neighbors = (p, parseGrid) + where + p v = (,) <$> parseFrom ["shading"] parseShadedGrid v + <*> parseFrom ["clues"] parseGrid v + +starwars :: ParsePuzzle (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star)) +starwars = (p, parseClueGrid) + where + p v = (,) <$> parseFrom ["grid"] parseGrid v + <*> (map unPML <$> parseFrom ["lines"] parseJSON v) + +starbattle :: ParsePuzzle (AreaGrid, Int) (Grid C (Maybe Star)) +starbattle = (p, parseClueGrid) + where + p v@(Object o) = (,) <$> parseFrom ["grid"] parseGrid v + <*> o .: "stars" + p _ = empty + +heyawake :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Bool) +heyawake = (p, parseShadedGrid) + where + p v = (,) <$> parseFrom ["rooms"] parseGrid v + <*> parseFrom ["clues"] parseClueGrid v + +wormhole :: ParsePuzzle (Grid C (Maybe (Either Int Char))) () +wormhole = (,) p (const $ return ()) + where + p v = fmap (fmap unEither') <$> parseExtClueGrid v + +pentominous :: ParsePuzzle (Grid C (Maybe Char)) (Grid C Char) +pentominous = (,) parseClueGrid parseGrid + +colorakari :: ParsePuzzle (Grid C (Maybe Char)) (Grid C (Maybe Char)) +colorakari = (,) parseClueGrid parseClueGrid + +persistenceOfMemory :: ParsePuzzle (AreaGrid, Grid C (Maybe MEnd)) (Loop C) +persistenceOfMemory = (p, parseEdgesFull) + where + p v = do g <- parseGrid v + return (areas g, ends_ g) + areas = fmap (\c -> case c of 'o' -> '.' + _ -> c) + ends_ = fmap (\c -> case c of 'o' -> Just MEnd + _ -> Nothing) + +{- + parsing the mappings in order, from something like + + - 1: A + - 3: B + - 2: X +-} +abctje :: ParsePuzzle (DigitRange, [(String, Int)]) [(Int, Char)] +abctje = (,) + (\v -> (,) <$> parseFrom ["numbers"] parseStringJSON v + <*> parseFrom ["clues"] pl v) + (\v -> pl v >>= sequence . map x) + where + pl :: FromJSON b => Value -> Parser [(String, b)] + pl v = parseJSON v >>= sequence . map pair + + x :: FromString a => (String, b) -> Parser (a, b) + x (k, v) = (\k' -> (k',v)) <$> parseString k + + pair :: Map a b -> Parser (a, b) + pair m = if Map.size m == 1 then (return . head . Map.toList $ m) else empty + +kropki :: ParsePuzzle (Map (Edge N) KropkiDot) (Grid C Int) +kropki = (,) parseAnnotatedEdges parseGrid + +statuepark :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Grid C Bool) +statuepark = (\v -> parseFrom ["grid"] parseClueGrid v, parseShadedGrid) + +pentominousBorders :: ParsePuzzle (Grid C (), [Edge N]) (Grid C Char) +pentominousBorders = (,) parseCellEdges parseGrid + +nanroSignpost :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Int) +nanroSignpost = (,) + (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] parseGrid v) + parseGrid + +tomTom :: ParsePuzzle (AreaGrid, Grid C (Maybe String)) (Grid C Int) +tomTom = (,) + (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] ((unRG <$>) . parseJSON) v) + parseGrid + +horseSnake :: ParsePuzzle (Grid C (Maybe (Either MEnd Int))) [Edge C] +horseSnake = (parseGrid, parseEdgesFull) + +illumination :: ParsePuzzle (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N]) +illumination = (,) + (fmap (fmap (fmap unPFraction)) . parseOut) + parseNodeEdges + +newtype Myo = Myo { unMyo :: Myopia } +instance FromJSON Myo where + parseJSON v = do + s <- parseJSON v + fmap Myo . sequence . map parseChar $ s + +pentopia :: ParsePuzzle (Grid C (Maybe Myopia)) (Grid C Bool) +pentopia = (,) + (fmap (fmap (fmap unMyo)) . fmap unRG . parseJSON) + parseShadedGrid + +pentominoPipes :: ParsePuzzle (Grid N Char) (Grid N KropkiDot, [Edge N]) +pentominoPipes = (,) + parseGrid + parseNodeEdges + +greaterWall :: ParsePuzzle ([GreaterClue], [GreaterClue]) (Grid C Bool) +greaterWall = (,) + (\v -> (,) <$> parseFrom ["rows"] parseGreaterClues v + <*> parseFrom ["columns"] parseGreaterClues v) + parseShadedGrid + +galaxies :: ParsePuzzle (Grid C (), Grid N (), Grid C (), Map (Edge N) ()) AreaGrid +galaxies = (,) + (\v -> do (a,b,c) <- parseEdgeGrid v + return $ (fmap (const ()) b, f a, f b, f c)) + parseGrid + where + toUnit GalaxyCentre = () + f = fmap toUnit . Map.mapMaybe id . fmap blankToMaybe'' + +mines :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) +mines = (parseIrregGrid, parseShadedGrid) + +tents :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Tree)) (Grid C (Maybe PlacedTent)) +tents = + ( p + , fmap (fmap fromTentOrTree) . parseClueGrid + ) + where + fromTentOrTree :: Maybe (Either Tree PlacedTent) -> Maybe PlacedTent + fromTentOrTree = maybe Nothing (either (const Nothing) Just) + + p v = (,) + <$> parseFrom ["clues"] parseOut v + <*> parseFrom ["grid"] parseClueGrid v + +pentominoSums :: ParsePuzzle (OutsideClues C [String], String) + (Grid C (Either Pentomino Int), [(Char, Int)], OutsideClues C [String]) +pentominoSums = (p, s) + where + p v@(Object o) = (,) <$> (fst coral) v <*> o .: "digits" + p _ = empty + s v = (,,) <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["values"] values v + <*> fst coral v + values v = parseJSON v >>= sequence . map parseKey . Map.toList + parseKey (k, v) = (,) <$> parseString k <*> pure v + +coralLits :: ParsePuzzle (OutsideClues C [String]) (Grid C (Maybe Char)) +coralLits = (,) + (fst coral) + (fmap (fmap (fmap unAlpha)) . parseClueGrid) + +coralLitso :: ParsePuzzle (OutsideClues C [String]) (Grid C (Either Black Char)) +coralLitso = (,) + (fst coral) + (fmap (fmap (fmap unAlpha)) . parseGrid) + +snake :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe MEnd)) (Grid C (Maybe (Either MEnd Black))) +snake = (p, parseClueGrid) + where + p v = (,) + <$> parseFrom ["clues"] parseOut v + <*> parseFrom ["grid"] parseClueGrid v + +countryRoad :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Loop C) +countryRoad = (,) (fst nanroSignpost) parseEdges + +friendlysudoku :: ParsePuzzle (Map (Edge N) KropkiDot, Grid C (Maybe Int)) (Grid C Int) +friendlysudoku = (,) p parseGrid + where + p v = (\(_,c,e) -> (e,c)) <$> pp v + pp :: Value -> Parser (Grid N (), Grid C (Maybe Int), Map.Map (Edge N) KropkiDot) + pp = parseEdgeGrid + +japsummasyu :: ParsePuzzle (OutsideClues C [String]) () +japsummasyu = (,) + (fmap (fmap (map unIntString)) . parseMultiOutsideClues) + (error "japsummasyu solution not implemented") diff --git a/src/Parse/Util.hs b/src/Parse/Util.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Util.hs @@ -0,0 +1,783 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Parse.Util where + +import Prelude hiding (mapM) + +import Control.Applicative +import Control.Arrow +import Control.Monad hiding (mapM) + +import Data.List (sortBy, intersect) +import Data.Maybe (catMaybes, fromMaybe, isJust, fromJust) +import Data.Ord (comparing) +import Data.Either (isRight) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HMap +import Data.Traversable (mapM) +import Data.Monoid ((<>)) + +import Data.Char (digitToInt, isAlpha, isDigit) +import Text.Read (readMaybe) +import qualified Data.Text as T + +import Data.Yaml + +import Data.Grid +import Data.GridShape +import Data.Elements + +import Parse.Parsec + +type Path = [String] + +impossible :: a +impossible = error "impossible" + +field :: Path -> Value -> Parser Value +field = field' . map T.pack + where + field' [] v = pure v + field' (f:fs) (Object v) = v .: f >>= field' fs + field' (f:_) _ = fail $ "expected field '" ++ T.unpack f ++ "'" + +parseFrom :: Path -> (Value -> Parser b) -> Value -> Parser b +parseFrom fs p v = field fs v >>= p + +chars :: [Char] -> Char -> Parser Char +chars cs c = if c `elem` cs + then pure c + else (fail $ "got '" ++ [c] ++ "', expected '" ++ cs ++ "'") + +char :: Char -> Char -> Parser Char +char c = chars [c] + +class FromChar a where + parseChar :: Char -> Parser a + +instance FromChar Char where + parseChar = pure + +class FromString a where + parseString :: String -> Parser a + +instance FromString Char where + parseString [c] = pure c + parseString s = fail $ "expected a single character, got `" ++ s ++ "`" + +parseStringJSON :: FromString a => Value -> Parser a +parseStringJSON v = parseJSON v >>= parseString + +parseLine :: FromChar a => String -> Parser [a] +parseLine = mapM parseChar + +instance FromChar Int where + parseChar c + | isDigit c = digitToInt <$> parseChar c + | otherwise = fail $ "expected a digit, got '" ++ [c] ++ "'" + +newtype Alpha = Alpha { unAlpha :: Char } + deriving (Show, Ord, Eq) + +instance FromChar Alpha where + parseChar c + | isAlpha c = Alpha <$> parseChar c + | otherwise = fail $ "expected a letter" + +-- | Helper to parse strings from number-formatted YAML fields. +-- Somewhat dodgy. +newtype IntString = IntString { unIntString :: String } + +instance FromJSON IntString where + parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v + parseJSON v = IntString <$> parseJSON v + +-- | A rectangle. Each row has length `w`. +data Rect a = Rect !Int !Int [[a]] + deriving Show + +instance Functor Rect where + fmap f (Rect w h ls) = Rect w h (map (map f) ls) + +instance FromChar a => FromJSON (Rect a) where + parseJSON (String t) = Rect w h <$> filled + where + ls = map T.stripEnd . T.lines $ t + w = maximum . map T.length $ ls + h = length ls + filledc = map (T.unpack . T.justifyLeft w ' ') ls + filled = mapM (mapM parseChar) filledc + parseJSON _ = fail "expected string" + +data Border a = Border [a] [a] [a] [a] + deriving Show + +-- | This instance might be a lie. +instance Foldable Border where + foldMap f (Border l r b t) = foldMap f l <> foldMap f r + <> foldMap f b <> foldMap f t + +instance Traversable Border where + sequenceA (Border l r b t) = Border <$> sequenceA l + <*> sequenceA r + <*> sequenceA b + <*> sequenceA t + +instance Functor Border where + f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t) + +data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b) + deriving Show + +parseBorderedRect :: (Char -> Parser a) -> (Char -> Parser b) + -> Value -> Parser (BorderedRect a b) +parseBorderedRect parseIn parseOut v = do + Rect w h ls <- parseJSON v + let b = Border (reverse . map head . middle h $ ls) + (reverse . map last . middle h $ ls) + (middle w . last $ ls) + (middle w . head $ ls) + ls' = map (middle w) . middle h $ ls + mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls) + [head . head, head . last, last . head, last . last] + lsparsed <- mapM (mapM parseIn) ls' + bparsed <- mapM parseOut b + return $ BorderedRect (w-2) (h-2) lsparsed bparsed + where + middle len = take (len - 2) . drop 1 + +instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where + parseJSON = parseBorderedRect parseChar parseChar + +newtype SpacedRect a = SpacedRect { unSpaced :: Rect a } + +instance FromString a => FromJSON (SpacedRect a) where + parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p + else empty + where + ls = map T.words . T.lines $ t + w = maximum . map length $ ls + wmin = minimum . map length $ ls + h = length ls + p = mapM (mapM (parseString . T.unpack)) ls + parseJSON _ = empty + +instance FromChar () where + parseChar = fmap (const ()) . chars ['.', ' '] + +data Space = Space + +instance FromChar Space where + parseChar = fmap (const Space) . char ' ' + +data Blank = Blank +data Blank' = Blank' +data Blank'' = Blank'' +data Empty = Empty + +instance FromChar Blank where + parseChar = fmap (const Blank) . char '.' + +parseCharJSON :: FromChar a => Value -> Parser a +parseCharJSON v = do + [c] <- parseJSON v + parseChar c + +instance FromJSON Blank where + parseJSON = parseCharJSON + +instance FromChar Blank' where + parseChar = fmap (const Blank') . chars ['.', '-'] + +instance FromJSON Blank' where + parseJSON (String ".") = pure Blank' + parseJSON (String "-") = pure Blank' + parseJSON _ = fail "expected '.-'" + +instance FromChar Blank'' where + parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|'] + +instance FromChar Empty where + parseChar = fmap (const Empty) . char ' ' + +instance FromString Blank where + parseString "." = pure Blank + parseString _ = fail "expected '.'" + +instance FromChar PlainNode where + parseChar = fmap (const PlainNode) . char 'o' + +instance FromChar MasyuPearl where + parseChar = fmap f . chars ['*', 'o'] + where + f '*' = MBlack + f 'o' = MWhite + f _ = impossible + +instance FromChar SlalomDiag where + parseChar '/' = pure SlalomForward + parseChar '\\' = pure SlalomBackward + parseChar _ = empty + +instance FromChar Black where + parseChar = fmap (const Black) . chars "xX" + +instance FromChar Fish where + parseChar = fmap (const Fish) . char '*' + +instance FromChar Star where + parseChar = fmap (const Star) . char '*' + +instance FromChar MEnd where + parseChar = fmap (const MEnd) . chars "o*" + +instance FromChar GalaxyCentre where + parseChar = fmap (const GalaxyCentre) . char 'o' + +instance FromChar Tree where + parseChar = fmap (const Tree) . char '*' + +instance FromChar PlacedTent where + parseChar = fmap Tent . parseChar + +instance FromChar Pentomino where + parseChar c = + if c `elem` ("FILNPTUVWXYZ" :: String) then + pure (Pentomino c) + else + fail "expected FILNPTUVWXYZ" + +instance (FromChar a, FromChar b) => FromChar (Either a b) where + parseChar c = Left <$> parseChar c <|> Right <$> parseChar c + +instance (FromString a, FromString b) => FromString (Either a b) where + parseString c = Left <$> parseString c <|> Right <$> parseString c + +newtype Either' a b = Either' { unEither' :: Either a b } + +instance (FromChar a, FromChar b) => FromChar (Either' a b) where + parseChar c = Either' <$> parseChar c + +instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where + parseJSON v = Either' <$> + (Left <$> parseJSON v <|> Right <$> parseJSON v) + +instance FromChar a => FromChar (Maybe a) where + parseChar = optional . parseChar + +listListToMap :: [[a]] -> Grid Coord a +listListToMap ls = Map.fromList . concat + . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..] + $ ls + where + h = length ls + +rectToCoordGrid :: Rect a -> Grid Coord a +rectToCoordGrid (Rect _ _ ls) = listListToMap ls + +blankToMaybe :: Either Blank a -> Maybe a +blankToMaybe = either (const Nothing) Just + +blankToMaybe' :: Either Blank' a -> Maybe a +blankToMaybe' = either (const Nothing) Just + +blankToMaybe'' :: Either Blank'' a -> Maybe a +blankToMaybe'' = either (const Nothing) Just + +rectToIrregGrid :: Rect (Either Empty a) -> Grid Coord a +rectToIrregGrid = fmap fromRight . Map.filter isRight . rectToCoordGrid + where + fromRight (Right r) = r + fromRight _ = impossible + +newtype Shaded = Shaded { unShaded :: Bool } + +instance FromChar Shaded where + parseChar 'x' = pure . Shaded $ True + parseChar 'X' = pure . Shaded $ True + parseChar _ = pure . Shaded $ False + +parseShadedGrid :: Key k => Value -> Parser (Grid k Bool) +parseShadedGrid v = fmap unShaded <$> parseGrid v + +parseCoordGrid :: (FromChar a) + => Value -> Parser (Grid Coord a) +parseCoordGrid v = rectToCoordGrid <$> parseJSON v + +parseGrid :: (Key k, FromChar a) + => Value -> Parser (Grid k a) +parseGrid v = fromCoordGrid <$> parseCoordGrid v + +parseGridWith :: Key k + => (Char -> Parser a) -> Value -> Parser (Grid k a) +parseGridWith pChar v = traverse pChar =<< parseGrid v + +parseWithReplacement :: FromChar a => + (Char -> Maybe a) -> Char -> Parser a +parseWithReplacement replace c = maybe (parseChar c) pure (replace c) + +parseSpacedGrid :: (Key k, FromString a) + => Value -> Parser (Grid k a) +parseSpacedGrid v = fromCoordGrid . rectToCoordGrid . unSpaced <$> parseJSON v + +parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) +parseCharMap v = do + m <- parseJSON v + guard . all (\k -> length k == 1) . Map.keys $ m + return $ Map.mapKeys head m + +parseExtGrid' :: (Key k, FromJSON a, FromChar b) + => (a -> b) -> Value -> Parser (Grid k b) +parseExtGrid' _ v@(String _) = parseGrid v +parseExtGrid' f v = do + repl <- fmap f <$> parseFrom ["replace"] parseCharMap v + parseFrom ["grid"] (parseGridWith + (parseWithReplacement (`Map.lookup` repl))) v + +parseExtGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k a) +parseExtGrid = parseExtGrid' id + +parseExtClueGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k (Maybe a)) +parseExtClueGrid v = fmap blankToMaybe <$> parseExtGrid' Right v + +fromCoordGrid :: Key k => Grid Coord a -> Grid k a +fromCoordGrid = Map.mapKeys fromCoord + +fromCoordEdge :: Key k => Edge Coord -> Edge k +fromCoordEdge (E c d) = E (fromCoord c) d + +fromCoordEdges :: Key k => [Edge Coord] -> [Edge k] +fromCoordEdges = map fromCoordEdge + +parseClueGrid :: (FromChar a, Key k) + => Value -> Parser (Grid k (Maybe a)) +parseClueGrid v = fmap blankToMaybe <$> parseGrid v + +parseClueGrid' :: (FromChar a, Key k) => Value -> Parser (Grid k (Maybe a)) +parseClueGrid' v = fmap blankToMaybe' <$> parseGrid v + +parseSpacedClueGrid :: (Key k, FromString a) => Value -> Parser (Grid k (Maybe a)) +parseSpacedClueGrid v = fmap blankToMaybe <$> parseSpacedGrid v + +parseIrregGrid :: (Key k, FromChar a) => Value -> Parser (Grid k a) +parseIrregGrid v = fromCoordGrid . rectToIrregGrid <$> parseJSON v + +-- parses a string like +-- o-o-o +-- | | +-- o-o o +-- | | +-- o-o +parsePlainEdges :: Key k => Value -> Parser [Edge k] +parsePlainEdges v = filterPlainEdges <$> parseAnnotatedEdges v + +filterPlainEdges :: Map.Map (Edge k) Char -> [Edge k] +filterPlainEdges = Map.keys . Map.filterWithKey p + where + p (E _ Horiz) '-' = True + p (E _ Vert) '|' = True + p _ _ = False + +parseAnnotatedEdges :: (Key k, FromChar a) => Value -> Parser (Map.Map (Edge k) a) +parseAnnotatedEdges v = do + g <- readEdges <$> parseCoordGrid v + Map.mapKeys fromCoordEdge <$> traverse parseChar g + +readEdges :: Grid Coord Char -> Map.Map (Edge Coord) Char +readEdges = Map.mapKeysMonotonic fromJust . Map.filterWithKey (const . isJust) . Map.mapKeys toEdge + where + toEdge c@(x, y) = case (x `mod` 2, y `mod` 2) of + (1, 0) -> Just $ E (div2 c) Horiz + (0, 1) -> Just $ E (div2 c) Vert + _ -> Nothing + div2 (x', y') = (x' `div` 2, y' `div` 2) + +parseGridChars :: FromChar a => Grid k Char -> Parser (Grid k a) +parseGridChars = traverse parseChar + +-- | Parse a grid with edges and values at nodes and in cells. +-- +-- E.g. o-*-*-o +-- |1|2 3 +-- *-o +-- to a grid of masyu pearls, a grid of integers, and some annotated edges. +parseEdgeGrid :: (FromChar a, FromChar b, FromChar c) => + Value -> Parser (Grid N a, Grid C b, Map.Map (Edge N) c) +parseEdgeGrid v = uncurry (,,) <$> + parseBoth <*> + parseAnnotatedEdges v + where + parseBoth = do + g <- parseCoordGrid v + let (gn, gc) = halveGrid g + gn' <- parseGridChars gn + gc' <- parseGridChars gc + return (gn', gc') + both f (x, y) = (f x, f y) + halveGrid m = + (fromCoordGrid . divkeys $ mnode, fromCoordGrid . divkeys $ mcell) + where + mnode = Map.filterWithKey (const . uncurry (&&) . both even) m + mcell = Map.filterWithKey (const . uncurry (&&) . both odd) m + divkeys = Map.mapKeys (both (`div` 2)) + +parsePlainEdgeGrid :: (FromChar a, FromChar b) => + Value -> Parser (Grid N a, Grid C b, [Edge N]) +parsePlainEdgeGrid v = (\(a,b,c) -> (a, b, filterPlainEdges c)) <$> parseEdgeGrid v + +-- | Parse a grid of edges with values at the nodes. +-- +-- E.g. o-*-*-o +-- | | +-- *-o +-- to a grid of masyu pearls and some edges. +parseNodeEdges :: FromChar a => + Value -> Parser (Grid N a, [Edge N]) +parseNodeEdges v = proj13 <$> parsePlainEdgeGrid v + where + proj13 :: (Grid N a, Grid C Char, [Edge N]) + -> (Grid N a, [Edge N]) + proj13 (x,_,z) = (x,z) + +parseCellEdges :: FromChar a => + Value -> Parser (Grid C a, [Edge N]) +parseCellEdges v = proj23 <$> parsePlainEdgeGrid v + where + proj23 :: (Grid N Char, Grid C a, [Edge N]) + -> (Grid C a, [Edge N]) + proj23 (_,y,z) = (y,z) + +data HalfDirs = HalfDirs {unHalfDirs :: [Dir]} + +instance FromChar HalfDirs where + parseChar c | c `elem` ("└┴├┼" :: String) = pure . HalfDirs $ [Vert, Horiz] + | c `elem` ("│┘┤" :: String) = pure . HalfDirs $ [Vert] + | c `elem` ("─┌┬" :: String) = pure . HalfDirs $ [Horiz] + | otherwise = pure . HalfDirs $ [] + +-- parses a string like +-- ┌┐┌─┐ +-- ││└┐│ +-- │└─┘│ +-- └──┐│ +-- └┘ +parseBoxEdges :: Key k => Value -> Parser [Edge k] +parseBoxEdges v = do + m <- fmap unHalfDirs <$> parseGrid v + return [ E p d | (p, ds) <- Map.toList m, d <- ds ] + +parseEdges :: Key k => Value -> Parser [Edge k] +parseEdges v = parsePlainEdges v <|> parseBoxEdges v + +instance FromChar Dir' where + parseChar 'u' = pure U + parseChar 'U' = pure U + parseChar 'd' = pure D + parseChar 'D' = pure D + parseChar 'r' = pure R + parseChar 'R' = pure R + parseChar 'l' = pure L + parseChar 'L' = pure L + parseChar _ = fail "expected 'uUdDrRlL'" + +newtype Dirs' = Dirs' { unDirs' :: [Dir'] } + +instance FromChar Dirs' where + parseChar '└' = pure . Dirs' $ [U, R] + parseChar '│' = pure . Dirs' $ [U, D] + parseChar '┘' = pure . Dirs' $ [L, U] + parseChar '─' = pure . Dirs' $ [L, R] + parseChar '┌' = pure . Dirs' $ [D, R] + parseChar '┐' = pure . Dirs' $ [L, D] + parseChar '╶' = pure . Dirs' $ [R] + parseChar '╴' = pure . Dirs' $ [L] + parseChar '╷' = pure . Dirs' $ [D] + parseChar '╵' = pure . Dirs' $ [U] + parseChar _ = pure . Dirs' $ [] + +parseEdgesFull :: Key k => Value -> Parser [Edge k] +parseEdgesFull v = do + m <- parseGrid v + return . Set.toList . Set.fromList . map unorient + $ [ E' p d | (p, Dirs' ds) <- Map.toList m, d <- ds ] + +type ThermoRect = Rect (Either Blank (Either Int Alpha)) + +partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b) +partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty) + + where + insertEither k = either (first . Map.insert k) (second . Map.insert k) + +parseThermos :: Grid C Alpha -> Parser [Thermometer] +parseThermos m = catMaybes <$> mapM parseThermo (Map.keys m') + where + m' = fmap unAlpha m + parseThermo :: C -> Parser (Maybe Thermometer) + parseThermo p | not (isStart p) = pure Nothing + | not (isAlmostIsolated p) = fail $ show p ++ " not almost isolated" + | otherwise = Just <$> parseThermo' p + parseThermo' :: C -> Parser Thermometer + parseThermo' p = do + q <- next p + maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q + parseThermo'' :: C -> Parser Thermometer + parseThermo'' p = do + q <- next p + maybe (pure [p]) (fmap (p:) . parseThermo'') q + next :: C -> Parser (Maybe C) + next p = case succs p of + [] -> pure Nothing + [q] -> pure (Just q) + _ -> fail "multiple successors" + succs p = filter (test ((==) . succ) p) . vertexNeighbours $ p + isStart p = not . any (test ((==) . pred) p) . vertexNeighbours $ p + test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m') + isAlmostIsolated p = all disjointSucc . vertexNeighbours $ p + where + disjointSucc q = null $ intersect (succs p) (succs' q) + succs' q = maybe [] (const $ succs q) (Map.lookup q m') + +parseThermoGrid :: ThermoRect -> Parser (Grid C (Maybe Int), [Thermometer]) +parseThermoGrid (Rect _ _ ls) = (,) ints + <$> parseThermos alphas + where + m = fromCoordGrid $ listListToMap ls + ints = either (const Nothing) (either Just (const Nothing)) <$> m + alphas = fmap fromRight . Map.filter isRight + . fmap fromRight . Map.filter isRight $ m + fromRight (Left _) = impossible + fromRight (Right x) = x + +parseOutsideGrid :: Key k => + (Char -> Parser a) + -> (Char -> Parser b) + -> Value -> Parser (OutsideClues k b, Grid k a) +parseOutsideGrid parseIn parseOut v = do + BorderedRect w h ls b <- parseBorderedRect parseIn parseOut v + return (outside b, fromCoordGrid . rectToCoordGrid $ Rect w h ls) + where outside (Border l r b t) = OC l r b t + +parseOutsideGridMap :: (Key k, FromChar a, FromChar b) + => (a -> c) -> (b -> d) + -> Value -> Parser (OutsideClues k d, Grid k c) +parseOutsideGridMap mapIn mapOut v = do + (o, g) <- parseOutsideGrid parseChar parseChar v + return (mapOut <$> o, mapIn <$> g) + +newtype Tight = Tight { unTight :: Tightfit () } + +instance FromChar Tight where + parseChar '.' = pure . Tight $ Single () + parseChar '/' = pure . Tight $ UR () () + parseChar '\\' = pure . Tight $ DR () () + parseChar _ = empty + +parseTightOutside :: Value -> Parser (OutsideClues C (Maybe Int), + Grid C (Tightfit ())) +parseTightOutside = parseOutsideGridMap unTight unBlank' + where + unBlank' :: Either Blank' Int -> Maybe Int + unBlank' = either (const Nothing) Just + +instance FromChar a => FromString (Tightfit a) where + parseString [c] = Single <$> parseChar c + parseString [c, '/',d] = UR <$> parseChar c <*> parseChar d + parseString [c,'\\',d] = DR <$> parseChar c <*> parseChar d + parseString _ = empty + +newtype PMarkedWord = PMW {unPMW :: MarkedWord} + +parseNWords :: Int -> String -> Parser [String] +parseNWords n s | length ws == n = pure ws + | otherwise = empty + where + ws = words s + +parseDoublePair :: FromString a => Value -> Parser ((a, a), (a, a)) +parseDoublePair v = (,) <$> + ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*> + ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)) + where x = parseJSON v >>= parseNWords 4 >>= mapM parseString + +instance FromJSON PMarkedWord where + parseJSON v = PMW . uncurry MW <$> parseDoublePair v + +instance FromString Int where + parseString s = maybe empty pure $ readMaybe s + +parseMarkedLine :: FromCoord a => Value -> Parser (MarkedLine a) +parseMarkedLine v = do + (s, e) <- parseDoublePair v + return $ MarkedLine (fromCoord s) (fromCoord e) + +newtype PMarkedLine a = PML {unPML :: MarkedLine a} + +instance FromCoord a => FromJSON (PMarkedLine a) where + parseJSON v = PML <$> parseMarkedLine v + +newtype PCompassC = PCC {unPCC :: CompassC} + +instance FromJSON PCompassC where + parseJSON (String t) = comp . map T.unpack . T.words $ t + where c "." = pure Nothing + c x = Just <$> parseString x + comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w) + comp _ = empty + parseJSON _ = empty + +newtype PSlovakClue = PSlovakClue {unPSlovakClue :: SlovakClue} + +instance FromJSON PSlovakClue where + parseJSON (String t) = svk . map T.unpack . T.words $ t + where + svk [s, c] = PSlovakClue <$> (SlovakClue <$> parseString s <*> parseString c) + svk _ = fail "expect two integers" + parseJSON _ = fail "expect string of two integers" + +newtype RefGrid k a = RefGrid { unRG :: Grid k (Maybe a) } + +hashmaptomap :: Ord a => HMap.HashMap a b -> Map.Map a b +hashmaptomap = Map.fromList . HMap.toList + +compose :: Ord b => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) +compose m1 m2 = mapM (`Map.lookup` m2) m1 + +newtype MaybeMap k a = MM { unMaybeMap :: Map.Map k (Maybe a) } + +instance Functor (MaybeMap k) where + fmap f (MM m) = MM (fmap (fmap f) m) + +instance Foldable (MaybeMap k) where + foldMap f (MM m) = foldMap (foldMap f) m + +instance Traversable (MaybeMap k) where + traverse f m = MM <$> traverse (traverse f) (unMaybeMap m) + +compose' :: Ord b => Map.Map a (Maybe b) + -> Map.Map b c + -> Maybe (Map.Map a (Maybe c)) +compose' m1 m2 = unMaybeMap <$> mapM (`Map.lookup` m2) (MM m1) + +instance (Key k, FromJSON a) => FromJSON (RefGrid k a) where + parseJSON v = RefGrid <$> do + refs <- fmap (fmap ((:[]) . unAlpha) . blankToMaybe) + <$> parseFrom ["grid"] parseGrid v + m <- hashmaptomap <$> parseFrom ["clues"] parseJSON v + case compose' refs m of + Nothing -> mzero + Just m' -> return m' + +parseAfternoonGrid :: Value -> Parser (Grid C Shade) +parseAfternoonGrid v = do + (_, g, es) <- parsePlainEdgeGrid v + :: Parser (Grid N Char, Grid C Char, [Edge N]) + return $ toMap g es + where + toShade Vert = Shade False True + toShade Horiz = Shade True False + merge (Shade a b) (Shade c d) = Shade (a || c) (b || d) + toMap g es = Map.fromListWith + merge + ([(fromCoord . toCoord $ p, toShade d) | E p d <- es] + ++ [(p, Shade False False) | p <- Map.keys g]) + +newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue } + +instance FromJSON ParseTapaClue where + parseJSON v = do xs <- parseJSON v + guard $ length xs > 0 && length xs <= 4 + return . ParseTapaClue . TapaClue $ xs + +reorientOutside :: OutsideClues k a -> OutsideClues k a +reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t + +parseCharOutside :: FromChar a => Value -> Parser (OutsideClues k a) +parseCharOutside (Object v) = reorientOutside <$> + (OC <$> + pfield "left" <*> pfield "right" <*> + pfield "bottom" <*> pfield "top" ) + where + pfield f = parseLine . fromMaybe [] =<< v .:? f +parseCharOutside _ = empty + +parseOutside :: FromJSON a => Value -> Parser (OutsideClues k a) +parseOutside (Object v) = reorientOutside <$> + (OC <$> + pfield "left" <*> pfield "right" <*> + pfield "bottom" <*> pfield "top" ) + where + pfield f = pure . fromMaybe [] =<< v .:? f +parseOutside _ = empty + +parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues k [a]) +parseMultiOutsideClues (Object v) = rev <$> raw + where + raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top" + v' `ml` k = fromMaybe [] <$> v' .:? k + rev (OC l r b t) = reorientOutside $ + OC (map reverse l) r b (map reverse t) +parseMultiOutsideClues _ = empty + +instance FromChar PrimeDiag where + parseChar '.' = pure $ PrimeDiag (False, False) + parseChar '/' = pure $ PrimeDiag (True, False) + parseChar '\\' = pure $ PrimeDiag (False, True) + parseChar 'X' = pure $ PrimeDiag (True, True) + parseChar _ = empty + +parseCoordLoop :: Value -> Parser VertexLoop +parseCoordLoop v = sortCoords <$> parseClueGrid v + where + sortCoords :: Grid N (Maybe Char) -> VertexLoop + sortCoords = map fst . sortBy (comparing snd) . Map.toList . clues + +instance FromString DigitRange where + parseString s = do + let (a, b) = break (== '-') s + b' <- case b of ('-':cs) -> pure cs + _ -> fail "exected '-' in range" + DigitRange <$> parseString a <*> parseString b' + +newtype PFraction = PFraction { unPFraction :: Fraction } + +instance FromJSON PFraction where + parseJSON v = PFraction <$> toStringParser fraction v + +instance FromChar Crossing where + parseChar '+' = pure Crossing + parseChar _ = fail "expected '+'" + +instance FromChar KropkiDot where + parseChar '*' = pure KBlack + parseChar 'o' = pure KWhite + parseChar ' ' = pure KNone + parseChar '.' = pure KNone + parseChar _ = fail "expected '*o '" + +instance FromChar Relation where + parseChar '<' = pure RLess + parseChar '>' = pure RGreater + parseChar '=' = pure REqual + parseChar ' ' = pure RUndetermined + parseChar _ = fail "expected '<>= '" + +parseGreaterClues :: Value -> Parser [GreaterClue] +parseGreaterClues v = do + Rect _ _ ls <- parseJSON v + mapM parseGreaterClue ls + +parseGreaterClue :: [Char] -> Parser GreaterClue +parseGreaterClue [] = pure [] +parseGreaterClue xs = p RUndetermined xs + where + p rel ('.':cs) = (rel:) <$> q cs + p _ (' ':_) = pure [] -- Rect fills the lines up with spaces... + p _ _ = fail "expected '.'" + q [] = pure [] + q (r:cs) = do + rel <- parseChar r + p rel cs diff --git a/src/Text/Puzzles/Puzzle.hs b/src/Text/Puzzles/Puzzle.hs deleted file mode 100644 --- a/src/Text/Puzzles/Puzzle.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.Puzzles.Puzzle where - -import Data.Yaml -import Control.Applicative - -import Data.Puzzles.PuzzleTypes - -data TypedPuzzle = TP (Maybe String) Value (Maybe Value) - deriving Show - -instance FromJSON TypedPuzzle where - parseJSON (Object v) = TP <$> - v .:? "type" <*> - v .: "puzzle" <*> - v .:? "solution" - parseJSON _ = empty - --- | A pair of parsers for a puzzle type. --- First parses the puzzle, second the solution. -type ParsePuzzle a b = (Value -> Parser a, Value -> Parser b) - -parseType :: String -> Parser PuzzleType -parseType t = case lookupType t of - Nothing -> fail $ "unknown puzzle type: " ++ t - Just p -> return p diff --git a/src/Text/Puzzles/PuzzleTypes.hs b/src/Text/Puzzles/PuzzleTypes.hs deleted file mode 100644 --- a/src/Text/Puzzles/PuzzleTypes.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.Puzzles.PuzzleTypes ( - lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa, - sudoku, thermosudoku, pyramid, kpyramid, slither, - liarslither, tightfitskyscrapers, wordloop, wordsearch, - curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral, - maximallengths, primeplace, labyrinth, bahnhof, cave - ) where - -import Control.Applicative -import Control.Monad - -import Data.Yaml - -import Text.Puzzles.Util -import Text.Puzzles.Puzzle -import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) -import qualified Data.Puzzles.Pyramid as Pyr -import Data.Puzzles.Elements - -lits :: ParsePuzzle AreaGrid ShadedGrid -lits = (parseGrid, parseShadedGrid) - -litsplus :: ParsePuzzle AreaGrid ShadedGrid -litsplus = lits - -geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop -geradeweg = (parseClueGrid, parseEdges) - -fillomino :: ParsePuzzle IntGrid (SGrid Int) -fillomino = (parseClueGrid, parseExtGrid) - -masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop -masyu = (parseClueGrid, parseEdges) - -nurikabe :: ParsePuzzle IntGrid ShadedGrid -nurikabe = (parseSpacedClueGrid, parseShadedGrid) - -latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char)) -latintapa = ((unRG <$>) . parseJSON, - fmap (fmap (fmap unAlpha)) . parseClueGrid') - -sudoku :: ParsePuzzle IntGrid IntGrid -sudoku = (parseClueGrid, parseClueGrid) - -thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid -thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid) - -pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol -pyramid = (parseJSON, parseJSON) - -kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol -kpyramid = (parseJSON, parseJSON) - -slither :: ParsePuzzle (SGrid (Clue Int)) Loop -slither = (parseClueGrid, parseEdges) - -newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) } -instance FromJSON LSol where - parseJSON (Object v) = LSol <$> ((,) <$> - (parseEdges =<< v .: "loop") <*> - (parseShadedGrid =<< v .: "liars")) - parseJSON _ = mzero - -liarslither :: ParsePuzzle (SGrid (Clue Int)) (Loop, SGrid Bool) -liarslither = (parseClueGrid, (unLSol <$>) . parseJSON) - -tightfitskyscrapers :: ParsePuzzle - (OutsideClues (Maybe Int), SGrid (Tightfit ())) - (SGrid (Tightfit Int)) -tightfitskyscrapers = (parseTightOutside, parseTightIntGrid) - -newtype GridWords = GW { unGW :: (CharClueGrid, [String]) } - -instance FromJSON GridWords where - parseJSON (Object v) = GW <$> ((,) <$> - (parseClueGrid =<< v .: "grid") <*> - v .: "words") - parseJSON _ = empty - -wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid -wordloop = ((unGW <$>) . parseJSON, parseClueGrid) - -newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) } - -instance FromJSON GridMarked where - parseJSON (Object v) = GM <$> ((,) <$> - (parseClueGrid =<< v .: "grid") <*> - (map unPMW <$> v .: "words")) - parseJSON _ = mzero - -wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord]) -wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON) - -newtype Curve = Curve { unCurve :: [Edge] } - -instance FromJSON Curve where - parseJSON v = Curve <$> parsePlainEdges v - -curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge] -curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges) - -doubleback :: ParsePuzzle AreaGrid Loop -doubleback = (parseGrid, parseEdges) - -slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag) -slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v) - -compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid -compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid) - -boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) () -boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented") - -afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid -afternoonskyscrapers = (parseAfternoonGrid, parseGrid) - --- this should be changed to support clue numbers -meanderingnumbers :: ParsePuzzle AreaGrid IntGrid -meanderingnumbers = (parseGrid, parseGrid) - -tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid -tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v, - parseShadedGrid) - -japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid (Either Black Int)) -japanesesums = (parseMultiOutsideClues, parseGrid) - -coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid -coral = (,) - (fmap (fmap (map unIntString)) . parseMultiOutsideClues) - parseShadedGrid - -maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop -maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v, - parseEdges) - -primeplace :: ParsePuzzle (SGrid PrimeDiag) (SGrid Int) -primeplace = (parseIrregGrid, parseIrregGrid) - -labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) -labyrinth = (parseCellEdges, parseClueGrid') - -bahnhof :: ParsePuzzle (SGrid (Maybe BahnhofClue)) [Edge] -bahnhof = (parseClueGrid, parseEdges) - -cave :: ParsePuzzle (SGrid (Clue Int)) ShadedGrid -cave = (parseClueGrid, parseShadedGrid) diff --git a/src/Text/Puzzles/Util.hs b/src/Text/Puzzles/Util.hs deleted file mode 100644 --- a/src/Text/Puzzles/Util.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.Puzzles.Util where - -import Prelude hiding (mapM) - -import Control.Applicative -import Control.Arrow -import Control.Monad hiding (mapM) - -import Data.Hashable -import Data.Maybe (catMaybes, fromMaybe) -import qualified Data.Map as Map -import qualified Data.HashMap.Strict as HMap -import Data.Traversable (traverse, sequenceA, mapM, Traversable) -import Data.Foldable (Foldable, foldMap) -import Data.Monoid ((<>)) -import Data.List (intersect) - -import Data.Char (digitToInt, isAlpha, isDigit) -import Text.Read (readMaybe) -import qualified Data.Text as T - -import Data.Yaml - -import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) -import Data.Puzzles.Elements - -type Path = [String] - -field :: Path -> Value -> Parser Value -field = field' . map T.pack - where - field' [] v = pure v - field' (f:fs) (Object v) = v .: f >>= field' fs - field' _ _ = empty - -parseFrom :: Path -> (Value -> Parser b) -> (Value -> Parser b) -parseFrom fs p v = field fs v >>= p - -class FromChar a where - parseChar :: Char -> Parser a - -failChar :: Char -> String -> Parser a -failChar c expect = fail $ "got '" ++ [c] ++ "', expected " ++ expect - -instance FromChar Char where - parseChar = pure - -class FromString a where - parseString :: String -> Parser a - -parseLine :: FromChar a => String -> Parser [a] -parseLine = mapM parseChar - -instance FromChar Int where - parseChar c - | isDigit c = digitToInt <$> parseChar c - | otherwise = fail $ "expected a digit, got '" ++ [c] ++ "'" - -newtype Alpha = Alpha { unAlpha :: Char } - deriving (Show, Ord, Eq) - -instance FromChar Alpha where - parseChar c - | isAlpha c = Alpha <$> parseChar c - | otherwise = empty - --- | Helper to parse strings from number-formatted YAML fields. --- Somewhat dodgy. -newtype IntString = IntString { unIntString :: String } - -instance FromJSON IntString where - parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v - parseJSON v = IntString <$> parseJSON v - --- | A rectangle. Each row has length `w`. -data Rect a = Rect !Int !Int [[a]] - deriving Show - -instance Functor Rect where - fmap f (Rect w h ls) = Rect w h (map (map f) ls) - -instance FromChar a => FromJSON (Rect a) where - parseJSON (String t) = Rect w h <$> filled - where - ls = map T.stripEnd . T.lines $ t - w = maximum . map T.length $ ls - h = length ls - filledc = map (T.unpack . T.justifyLeft w ' ') ls - filled = mapM (mapM parseChar) filledc - parseJSON _ = fail "expected string" - -data Border a = Border [a] [a] [a] [a] - deriving Show - --- | This instance might be a lie. -instance Foldable Border where - foldMap f (Border l r b t) = foldMap f l <> foldMap f r - <> foldMap f b <> foldMap f t - -instance Traversable Border where - sequenceA (Border l r b t) = Border <$> sequenceA l - <*> sequenceA r - <*> sequenceA b - <*> sequenceA t - -instance Functor Border where - f `fmap` (Border l r b t) = Border (f <$> l) (f <$> r) (f <$> b) (f <$> t) - -data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b) - deriving Show - -instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where - parseJSON v = do - Rect w h ls <- parseJSON v - let b = Border (reverse . map head . middle h $ ls) - (reverse . map last . middle h $ ls) - (middle w . last $ ls) - (middle w . head $ ls) - ls' = map (middle w) . middle h $ ls - mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls) - [head . head, head . last, last . head, last . last] - lsparsed <- mapM (mapM parseChar) ls' - bparsed <- mapM parseChar b - return $ BorderedRect (w-2) (h-2) lsparsed bparsed - where - middle len = take (len - 2) . drop 1 - -newtype SpacedRect a = SpacedRect { unSpaced :: Rect a } - -instance FromString a => FromJSON (SpacedRect a) where - parseJSON (String t) = if w == wmin then SpacedRect . Rect w h <$> p - else empty - where - ls = map T.words . T.lines $ t - w = maximum . map length $ ls - wmin = minimum . map length $ ls - h = length ls - p = mapM (mapM (parseString . T.unpack)) ls - parseJSON _ = empty - -data Space = Space - -instance FromChar Space where - parseChar ' ' = pure Space - parseChar _ = empty - -data Blank = Blank -data Blank' = Blank' -data Empty = Empty - -instance FromChar Blank where - parseChar '.' = pure Blank - parseChar _ = empty - -parseCharJSON :: FromChar a => Value -> Parser a -parseCharJSON v = do - [c] <- parseJSON v - parseChar c - -instance FromJSON Blank where - parseJSON = parseCharJSON - -instance FromChar Blank' where - parseChar '.' = pure Blank' - parseChar '-' = pure Blank' - parseChar _ = empty - -instance FromJSON Blank' where - parseJSON (String ".") = pure Blank' - parseJSON (String "-") = pure Blank' - parseJSON _ = empty - -instance FromChar Empty where - parseChar ' ' = pure Empty - parseChar _ = empty - -instance FromString Blank where - parseString "." = pure Blank - parseString _ = empty - -data PlainNode = PlainNode - -instance FromChar PlainNode where - parseChar 'o' = pure PlainNode - parseChar _ = empty - -instance FromChar MasyuPearl where - parseChar '*' = pure MBlack - parseChar 'o' = pure MWhite - parseChar c = failChar c "'*' or 'o'" - -instance FromChar SlalomDiag where - parseChar '/' = pure SlalomForward - parseChar '\\' = pure SlalomBackward - parseChar _ = empty - -instance FromChar Black where - parseChar 'X' = pure Black - parseChar 'x' = pure Black - parseChar _ = empty - -instance (FromChar a, FromChar b) => FromChar (Either a b) where - parseChar c = Left <$> parseChar c <|> Right <$> parseChar c - -instance (FromString a, FromString b) => FromString (Either a b) where - parseString c = Left <$> parseString c <|> Right <$> parseString c - -newtype Either' a b = Either' { unEither' :: Either a b } - -instance (FromChar a, FromChar b) => FromChar (Either' a b) where - parseChar c = Either' <$> parseChar c - -instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where - parseJSON v = Either' <$> - (Left <$> parseJSON v <|> Right <$> parseJSON v) - -instance FromChar a => FromChar (Maybe a) where - parseChar = optional . parseChar - -listListToMap :: [[a]] -> Map.Map (Cell Square) a -listListToMap ls = Map.fromList . concat - . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..] - $ ls - where - h = length ls - -rectToSGrid :: Rect a -> SGrid a -rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls) - -blankToMaybe :: Either Blank a -> Maybe a -blankToMaybe = either (const Nothing) Just - -blankToMaybe' :: Either Blank' a -> Maybe a -blankToMaybe' = either (const Nothing) Just - -rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a) -rectToClueGrid = fmap blankToMaybe . rectToSGrid - -rectToClueGrid' :: Rect (Either Blank' a) -> SGrid (Clue a) -rectToClueGrid' = fmap blankToMaybe' . rectToSGrid - -rectToIrregGrid :: Rect (Either Empty a) -> SGrid a -rectToIrregGrid = fmap fromRight . filterG isRight . rectToSGrid - where - isRight = either (const False) (const True) - fromRight (Right r) = r - fromRight _ = error "no way" - -newtype Shaded = Shaded { unShaded :: Bool } - -instance FromChar Shaded where - parseChar 'x' = pure . Shaded $ True - parseChar 'X' = pure . Shaded $ True - parseChar _ = pure . Shaded $ False - -parseShadedGrid :: Value -> Parser (SGrid Bool) -parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v - -parseGrid :: FromChar a => Value -> Parser (SGrid a) -parseGrid v = rectToSGrid <$> parseJSON v - -parseGridWith :: (Char -> Parser a) -> Value -> Parser (SGrid a) -parseGridWith pChar v = traverse pChar =<< parseGrid v - -parseWithReplacement :: FromChar a => - (Char -> Maybe a) -> Char -> Parser a -parseWithReplacement replace c = maybe (parseChar c) pure (replace c) - -parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) -parseCharMap v = do - m <- parseJSON v - guard . all (\k -> length k == 1) . Map.keys $ m - return $ Map.mapKeys head m - -parseExtGrid :: (FromChar a, FromJSON a) => Value -> Parser (SGrid a) -parseExtGrid v@(String _) = parseGrid v -parseExtGrid v = do - repl <- parseFrom ["replace"] parseCharMap v - parseFrom ["grid"] (parseGridWith - (parseWithReplacement (`Map.lookup` repl))) v - -parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a)) -parseClueGrid v = rectToClueGrid <$> parseJSON v - -parseClueGrid' :: FromChar a => Value -> Parser (SGrid (Clue a)) -parseClueGrid' v = rectToClueGrid' <$> parseJSON v - -parseIrregGrid :: FromChar a => Value -> Parser (SGrid a) -parseIrregGrid v = rectToIrregGrid <$> parseJSON v - -parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a)) -parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v - --- parses a string like --- o-o-o --- | | --- o-o o --- | | --- o-o -parsePlainEdges :: Value -> Parser [Edge] -parsePlainEdges v = readEdges <$> parseGrid v - -readEdges :: SGrid Char -> [Edge] -readEdges g = horiz ++ vert - where (w, h) = size g - w' = w `div` 2 - h' = h `div` 2 - isHoriz (x, y) = g ! (2 * x + 1, 2 * y) == '-' - isVert (x, y) = g ! (2 * x, 2 * y + 1) == '|' - horiz = [ E (x, y) H | x <- [0 .. w' - 1] - , y <- [0 .. h'] - , isHoriz (x, y) - ] - vert = [ E (x, y) V | x <- [0 .. w'] - , y <- [0 .. h' - 1] - , isVert (x, y) - ] - -parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a) -parseGridChars = traverse parseChar - --- | Parse a grid with edges and values at nodes and in cells. --- --- E.g. o-*-*-o --- |1|2 3 --- *-o --- to a grid of masyu pearls, a grid of integers, and some edges. -parseEdgeGrid :: (FromChar a, FromChar b) => - Value -> Parser (SGrid a, SGrid b, [Edge]) -parseEdgeGrid v = uncurry (,,) <$> - parseBoth <*> - parsePlainEdges v - where - parseBoth = do - g <- parseGrid v - (gn, gc) <- halveGrid g - gn' <- parseGridChars gn - gc' <- parseGridChars gc - return (gn', gc') - both f (x, y) = (f x, f y) - halveGrid (Grid (Square w h) m) - | odd w && odd h = pure (Grid snode (divkeys mnode), - Grid scell (divkeys mcell)) - | otherwise = fail "non-odd grid size" - where - w' = (w + 1) `div` 2 - h' = (h + 1) `div` 2 - snode = Square w' h' - scell = Square (w' - 1) (h' - 1) - mnode = Map.filterWithKey (const . uncurry (&&) . both even) m - mcell = Map.filterWithKey (const . uncurry (&&) . both odd) m - divkeys = Map.mapKeys (both (`div` 2)) - --- | Parse a grid of edges with values at the nodes. --- --- E.g. o-*-*-o --- | | --- *-o --- to a grid of masyu pearls and some edges. -parseNodeEdges :: FromChar a => - Value -> Parser (SGrid a, [Edge]) -parseNodeEdges v = proj13 <$> parseEdgeGrid v - where - proj13 :: (SGrid a, SGrid Empty, [Edge]) -> (SGrid a, [Edge]) - proj13 (x,_,z) = (x,z) - -parseCellEdges :: FromChar a => - Value -> Parser (SGrid a, [Edge]) -parseCellEdges v = proj23 <$> parseEdgeGrid v - where - proj23 :: (SGrid PlainNode, SGrid a, [Edge]) -> (SGrid a, [Edge]) - proj23 (_,y,z) = (y,z) - -data HalfDirs = HalfDirs {unHalfDirs :: [Dir]} - -instance FromChar HalfDirs where - parseChar c | c `elem` "└┴├┼" = pure . HalfDirs $ [V, H] - | c `elem` "│┘┤" = pure . HalfDirs $ [V] - | c `elem` "─┌┬" = pure . HalfDirs $ [H] - | otherwise = pure . HalfDirs $ [] - --- parses a string like --- ┌┐┌─┐ --- ││└┐│ --- │└─┘│ --- └──┐│ --- └┘ -parseEdges :: Value -> Parser [Edge] -parseEdges v = do - Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v - return [ E p d | (p, ds) <- Map.toList m, d <- ds ] - -type ThermoRect = Rect (Either Blank (Either Int Alpha)) - -partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b) -partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty) - where - insertEither k = either (first . Map.insert k) (second . Map.insert k) - -parseThermos :: SGrid Alpha -> Parser [Thermometer] -parseThermos (Grid s m) = catMaybes <$> mapM parseThermo (Map.keys m) - where - m' = fmap unAlpha m - parseThermo :: Cell Square -> Parser (Maybe Thermometer) - parseThermo p | not (isStart p) = pure Nothing - | not (isAlmostIsolated p) = fail $ show p ++ " not almost isolated" - | otherwise = Just <$> parseThermo' p - parseThermo' :: Cell Square -> Parser Thermometer - parseThermo' p = do - q <- next p - maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q - parseThermo'' :: Cell Square -> Parser Thermometer - parseThermo'' p = do - q <- next p - maybe (pure [p]) (fmap (p:) . parseThermo'') q - next :: Cell Square -> Parser (Maybe (Cell Square)) - next p = case succs p of - [] -> pure Nothing - [q] -> pure (Just q) - _ -> fail "multiple successors" - succs p = filter (test ((==) . succ) p) . vertexNeighbours s $ p - isStart p = not . any (test ((==) . pred) p) . vertexNeighbours s $ p - test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m') - isAlmostIsolated p = all disjointSucc . vertexNeighbours s $ p - where - disjointSucc q = null $ intersect (succs p) (succs' q) - succs' q = maybe [] (const $ succs q) (Map.lookup q m') - -parseThermoGrid :: ThermoRect -> Parser (SGrid Int, [Thermometer]) -parseThermoGrid (Rect w h ls) = (,) (Grid s ints) - <$> parseThermos (Grid s alphas) - where - s = Square w h - (ints, alphas) = partitionEithers . snd . partitionEithers $ - listListToMap ls - -newtype Tight = Tight { unTight :: Tightfit () } - -instance FromChar Tight where - parseChar '.' = pure . Tight $ Single () - parseChar '/' = pure . Tight $ UR () () - parseChar '\\' = pure . Tight $ DR () () - parseChar _ = empty - -parseTightOutside :: Value -> Parser (OutsideClues (Maybe Int), - SGrid (Tightfit ())) -parseTightOutside v = do - BorderedRect w h ls b <- parseJSON v - :: Parser (BorderedRect Tight (Either Blank' Int)) - return (outside . fmap (either (const Nothing) Just) $ b, - fmap unTight . rectToSGrid $ Rect w h ls) - where outside (Border l r b t) = OC l r b t - -instance FromChar a => FromString (Tightfit a) where - parseString [c] = Single <$> parseChar c - parseString [c, '/',d] = UR <$> parseChar c <*> parseChar d - parseString [c,'\\',d] = DR <$> parseChar c <*> parseChar d - parseString _ = empty - -parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int)) -parseTightIntGrid v = rectToSGrid . unSpaced <$> parseJSON v - -newtype PMarkedWord = PMW {unPMW :: MarkedWord} - -parseNWords :: Int -> String -> Parser [String] -parseNWords n s | length ws == n = pure ws - | otherwise = empty - where - ws = words s - -instance FromJSON PMarkedWord where - parseJSON v = PMW <$> (MW <$> - ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*> - ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x))) - where x = parseJSON v >>= parseNWords 4 >>= mapM parseString - -instance FromString Int where - parseString s = maybe empty pure $ readMaybe s - -newtype PCompassC = PCC {unPCC :: CompassC} - -instance FromJSON PCompassC where - parseJSON (String t) = comp . map T.unpack . T.words $ t - where c "." = pure Nothing - c x = Just <$> parseString x - comp [n, e, s, w] = PCC <$> (CC <$> c n <*> c e <*> c s <*> c w) - comp _ = empty - parseJSON _ = empty - -newtype RefGrid a = RefGrid { unRG :: SGrid a } - -data Ref = Ref { unRef :: Char } - deriving Show - -instance FromChar Ref where - parseChar c | isAlpha c = pure (Ref c) - parseChar _ = empty - -hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b -hashmaptomap = Map.fromList . HMap.toList - -compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) -compose m1 m2 = mapM (`Map.lookup` m2) m1 - -instance FromJSON a => FromJSON (RefGrid a) where - parseJSON (Object v) = RefGrid <$> do - Grid s refs <- fmap (fmap ((:[]) . unRef)) . rectToClueGrid <$> - (v .: "grid" :: Parser (Rect (Either Blank Ref))) - m <- hashmaptomap <$> v .: "clues" - case compose (Map.mapMaybe id refs) m of - Nothing -> mzero - Just m' -> return $ Grid s m' - parseJSON _ = empty - -parseAfternoonGrid :: Value -> Parser (SGrid Shade) -parseAfternoonGrid v = do - (Grid s _ , es) <- parseNodeEdges v :: Parser (SGrid Char, [Edge]) - let (m, b) = splitBorder s $ toMap es - guard $ Map.null b - return $ Grid (shrink s) m - where - shrink (Square w h) = Square (w-1) (h-1) - toShade V = Shade False True - toShade H = Shade True False - merge (Shade a b) (Shade c d) - | a && c || b && d = error "shading collision" - | otherwise = Shade (a || c) (b || d) - toMap es = Map.fromListWith - merge - [(p, toShade d) | E p d <- es] - splitBorder (Square w h) = Map.partitionWithKey - (\(x, y) _ -> x < w - 1 && y < h - 1) - -newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue } - -instance FromJSON ParseTapaClue where - parseJSON v = do xs <- parseJSON v - guard $ length xs > 0 && length xs <= 4 - return . ParseTapaClue . TapaClue $ xs - -reorientOutside :: OutsideClues a -> OutsideClues a -reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t - -parseCharOutside :: FromChar a => Value -> Parser (OutsideClues a) -parseCharOutside (Object v) = reorientOutside <$> - (OC <$> - pfield "left" <*> pfield "right" <*> - pfield "bottom" <*> pfield "top" ) - where - pfield f = parseLine . fromMaybe [] =<< v .:? f -parseCharOutside _ = empty - -parseOutside :: FromJSON a => Value -> Parser (OutsideClues a) -parseOutside (Object v) = reorientOutside <$> - (OC <$> - pfield "left" <*> pfield "right" <*> - pfield "bottom" <*> pfield "top" ) - where - pfield f = pure . fromMaybe [] =<< v .:? f -parseOutside _ = empty - -parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a]) -parseMultiOutsideClues (Object v) = rev <$> raw - where - raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top" - v' `ml` k = fromMaybe [] <$> v' .:? k - rev (OC l r b t) = reorientOutside $ - OC (map reverse l) r b (map reverse t) -parseMultiOutsideClues _ = empty - -instance FromChar PrimeDiag where - parseChar '.' = pure $ PrimeDiag (False, False) - parseChar '/' = pure $ PrimeDiag (True, False) - parseChar '\\' = pure $ PrimeDiag (False, True) - parseChar 'X' = pure $ PrimeDiag (True, True) - parseChar _ = empty - -instance FromChar Crossing where - parseChar '+' = pure Crossing - parseChar _ = fail "expected '+'" diff --git a/src/tools/checkpuzzle.hs b/src/tools/checkpuzzle.hs new file mode 100644 --- /dev/null +++ b/src/tools/checkpuzzle.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import Parse.Puzzle +import Data.PuzzleTypes (typeNames, PuzzleType(..)) +import Data.CmdLine (exitErr, readPuzzle, checkType) + +import Data.Elements (KropkiDot(..), digitList) +import Data.GridShape (Edge, N, C, rows, edgesM, unorient, ends, dualE) +import Data.Grid (Grid) +import qualified Parse.PuzzleTypes as T + +import Options.Applicative +import Control.Monad +import Data.Maybe +import qualified Data.Map.Strict as Map +import Data.List (intercalate, sort) + +import System.Exit +import System.Environment (getProgName) + +import qualified Data.Yaml as Y + +optListTypes :: Parser (a -> a) +optListTypes = + infoOption + (unlines' . sort . map snd $ typeNames) + (long "list-types" + <> help "List supported puzzle types") + where + unlines' = intercalate "\n" + +data PuzzleOpts = PuzzleOpts + { _type :: Maybe String + , _input :: FilePath + } + +puzzleOpts :: Parser PuzzleOpts +puzzleOpts = PuzzleOpts + <$> (optional . strOption $ + (long "type" <> short 't' + <> metavar "TYPE" + <> help "Puzzle type, overriding type in input file")) + <*> argument str + (metavar "INPUT" + <> help "Puzzle file in .pzl format") + +defaultOpts :: Parser a -> IO a +defaultOpts optsParser = do + prog <- getProgName + let p = info (helper <*> optListTypes <*> optsParser) + (fullDesc + <> progDesc "Command-line puzzle checking." + <> header prog) + execParser p + +main :: IO () +main = do + opts <- defaultOpts puzzleOpts + mp <- readPuzzle (_input opts) + TP mt pv msv _ <- case mp of Left e -> exitErr $ + "parse failure: " ++ show e + Right p -> return p + t <- checkType $ _type opts `mplus` mt + sv <- maybe (exitErr $ "need solution") return msv + let es = Y.parseEither (check t) (pv, sv) + case es of Left err -> exitErr $ "parse failure: " ++ err + Right [] -> exitSuccess + Right es' -> mapM_ putStrLn es' >> exitFailure + +check :: PuzzleType -> (Y.Value, Y.Value) -> Y.Parser [String] +check t (pv, sv) = + case t of + ABCtje -> checkABCtje (pv, sv) + Kropki -> checkKropki (pv, sv) + _ -> return [] + +checkABCtje :: (Y.Value, Y.Value) -> Y.Parser [String] +checkABCtje (pv, sv) = do + p <- fst T.abctje $ pv + s <- snd T.abctje $ sv + return . catMaybes . map (\c -> c p s) $ + [ solutionKeys, values ] + where + solutionKeys (ds, _) s = let have = sort (digitList ds) + want = sort (map fst (s)) + in if have /= want then Just "unequal digit lists" else Nothing + values (_, ws) vs = (\es -> case es of [] -> Nothing + _ -> Just $ intercalate ", " es) + . catMaybes + . map (\(w, v) -> if val w == v + then Nothing + else Just (w ++ " should be " ++ show (val w))) + $ ws + where + l c = fromMaybe 0 . lookup c . map (\(x, y) -> (y, x)) $ vs + val = sum . map l + +checkKropki :: (Y.Value, Y.Value) -> Y.Parser [String] +checkKropki (pv, sv) = do + p <- fst T.kropki $ pv + s <- snd T.kropki $ sv + return . catMaybes . map (\c -> c p s) $ + [ match, latin, dots ] + where + match :: Map.Map (Edge N) KropkiDot -> Grid C Int -> Maybe String + match p s = if solEdges == puzEdges then + Nothing + else + Just "puzzle and solution shape don't match" + where + solEdges = let + (outer, inner) = edgesM s + in + sort (inner ++ map unorient outer) + puzEdges = sort (Map.keys p) + latin _ s = either Just (const Nothing) . mapM_ latinRow . rows $ s + latinRow ds = if sort ds == [1 .. length ds] then + Right () + else + Left $ "row not 1..N: " ++ show ds + dots p s = either Just (const Nothing) . mapM_ (checkEdge s) . Map.toList $ p + checkEdge :: Grid C Int -> (Edge N, KropkiDot) -> Either String () + checkEdge s (e, d) = + let + (a, b) = ends (dualE e) + okDot x y = + let + white = x - y == 1 || x - y == -1 + black = x == y * 2 || y == x * 2 + in + case d of + KBlack -> black + KWhite -> white + KNone -> not black && not white + in + case (Map.lookup a s, Map.lookup b s) of + (Just x, Just y) -> if okDot x y then Right () else Left ("bad dot between: " ++ show a ++ "," ++ show b) + _ -> if d == KNone then Right () else Left "dot on the edge" diff --git a/src/tools/drawpuzzle.hs b/src/tools/drawpuzzle.hs --- a/src/tools/drawpuzzle.hs +++ b/src/tools/drawpuzzle.hs @@ -2,14 +2,17 @@ module Main where -import Diagrams.Prelude hiding (value, option, (<>), Result) +import Diagrams.Prelude hiding (value, option, (<>), Result, render) -import Diagrams.Puzzles.CmdLine +import Data.CmdLine +import Draw.CmdLine -import Text.Puzzles.Puzzle -import Data.Puzzles.Compose -import Data.Puzzles.PuzzleTypes (typeNames) -import Diagrams.Puzzles.Draw +import Parse.Puzzle +import Parse.Code +import Data.Compose +import Data.PuzzleTypes (typeNames) +import Draw.Draw +import Draw.Code import Options.Applicative import Control.Monad @@ -33,9 +36,12 @@ data PuzzleOpts = PuzzleOpts { _format :: String , _type :: Maybe String + , _dir :: FilePath , _puzzle :: Bool , _solution :: Bool , _example :: Bool + , _code :: Bool + , _scale :: Double , _input :: FilePath } @@ -50,6 +56,11 @@ (long "type" <> short 't' <> metavar "TYPE" <> help "Puzzle type, overriding type in input file")) + <*> strOption + (long "directory" <> short 'd' + <> value "." + <> metavar "DIR" + <> help "Output directory") <*> switch (long "puzzle" <> short 'p' <> help "Render puzzle (to base.ext)") @@ -59,6 +70,14 @@ <*> switch (long "example" <> short 'e' <> help "Render example (to base.ext)") + <*> switch + (long "code" <> short 'c' + <> help "Add solution code markers") + <*> option auto + (long "scale" + <> value 1.0 + <> metavar "FACTOR" + <> help "Scale the size by this factor") <*> argument str (metavar "INPUT" <> help "Puzzle file in .pzl format") @@ -73,17 +92,19 @@ outputSuffix DrawSolution = "-sol" outputSuffix DrawExample = "" -toRenderOpts :: OutputChoice -> Double -> PuzzleOpts -> RenderOpts -toRenderOpts oc w opts = RenderOpts out w' +toRenderOpts :: OutputChoice -> (Double, Double) -> PuzzleOpts -> RenderOpts +toRenderOpts oc (w, h) opts = RenderOpts out sz where f = _format opts u = case f of "png" -> Pixels _ -> Points - w' = toOutputWidth u w + w' = toOutputWidth u w * (_scale opts) + h' = toOutputWidth u h * (_scale opts) + sz = mkSizeSpec2D (Just w') (Just h') base = takeBaseName (_input opts) - out = addExtension (base ++ outputSuffix oc) f + out = _dir opts (base ++ outputSuffix oc) <.> f -renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B R2)) -> +renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B)) -> (OutputChoice, Bool) -> IO () renderPuzzle opts r (oc, req) = do let x = r oc @@ -91,7 +112,7 @@ exitErr ("failed to render (no solution?): " ++ show oc) when (isJust x) $ do let Just x' = x - ropts = toRenderOpts oc (diagramWidth x') opts + ropts = toRenderOpts oc (diagramSize x') opts renderToFile ropts x' defaultOpts :: Parser a -> IO a @@ -129,17 +150,29 @@ hasSol DrawExample = True hasSol DrawPuzzle = False +maybeSkipCode :: PuzzleOpts -> Maybe Y.Value -> Maybe Y.Value +maybeSkipCode opts = if _code opts then id else const Nothing + +parseAndDrawCode :: Y.Value -> IO (CodeDiagrams (Diagram B)) +parseAndDrawCode v = case parsed of + Left e -> exitErr $ "solution code parse failure: " ++ e + Right c -> return $ drawCode c + where + parsed = Y.parseEither parseCode v + main :: IO () main = do opts <- defaultOpts puzzleOpts ocs <- checkOutput opts checkFormat (_format opts) mp <- readPuzzle (_input opts) - TP mt pv msv <- case mp of Left e -> exitErr $ - "parse failure: " ++ show e - Right p -> return p + TP mt pv msv mc <- case mp of Left e -> exitErr $ + "parse failure: " ++ show e + Right p -> return p let msv' = maybeSkipSolution ocs msv + mc' = maybeSkipCode opts mc t <- checkType $ _type opts `mplus` mt let ps = Y.parseEither (handle drawPuzzleMaybeSol t) (pv, msv') - case ps of Right ps' -> mapM_ (renderPuzzle opts (draw ps')) ocs + mcode <- sequenceA $ parseAndDrawCode <$> mc' + case ps of Right ps' -> mapM_ (renderPuzzle opts (render mcode ps')) ocs Left e -> exitErr $ "parse failure: " ++ e diff --git a/tests/Data.hs b/tests/Data.hs new file mode 100644 --- /dev/null +++ b/tests/Data.hs @@ -0,0 +1,244 @@ +module Data where + +import qualified Data.Text as T +import Data.Maybe (fromJust) +import Data.Yaml +import qualified Data.ByteString as B +import Data.Text.Encoding (encodeUtf8) + +packStr :: String -> B.ByteString +packStr = encodeUtf8 . T.pack + +decodeLines :: [String] -> Value +decodeLines = fromJust . decodeThrow . packStr . unlines + +packLine :: String -> Value +packLine = String . T.pack + +packLines :: [String] -> Value +packLines = String . T.pack . unlines + +geradeweg_1 :: Value +geradeweg_1 = packLines $ + [ "..... " + , ".211." + , "..2.. " + , "3...4" + , "....." + ] + +geradeweg_1_sol :: Value +geradeweg_1_sol = packLines $ + [ "┌┐┌─┐" + , "││└┐│ " + , "│└─┘│" + , "└──┐│" + , " .└┘ " + ] + +tightfit_1 :: Value +tightfit_1 = packLines $ + [ " --- " + , "3/\\.-" + , "-\\.\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_broken_1 :: Value +tightfit_broken_1 = packLines $ + [ " --- " + , "3/\\.-" + , "-\\x\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_broken_2 :: Value +tightfit_broken_2 = packLines $ + [ "3/\\.-" + , "-\\x\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_1_sol :: Value +tightfit_1_sol = packLines $ + [ "2/1 4\\5 3" + , " 4\\5 3 2\\1 " + , " 3 1\\2 5/4" + ] + +tightfit_sol_broken :: Value +tightfit_sol_broken = packLine "2/1 4 /5" + +tightfit_sol_broken_2 :: Value +tightfit_sol_broken_2 = packLine "2/x 4 3/5" + +slalom_sol_broken :: Value +slalom_sol_broken = packLine "//\\ /\\x5 " + +kpyramid_1 :: Value +kpyramid_1 = packLines $ + [ "G 3" + , "G . ." + , "G . . ." + , "W .o. . ." + , "G 1*.*.o.*6" + ] + +kpyramid_1_sol :: Value +kpyramid_1_sol = packLines $ + [ " 3" + , " 8 5" + , " 1 9 4" + , " 3 2 7 3" + , "1 2 4 3 6" + ] + +kpyramid_broken_1 :: Value +kpyramid_broken_1 = packLines $ + [ " G 3" + , " G . 22" + , " H . aa ." + , " W .o. .|. " + , " G 1*.*.o.*6" + ] + +kpyramid_broken_2 :: Value +kpyramid_broken_2 = packLines $ + [ "G 3" + , "G . 22" + , "H . aa ." + , "W .o. .|. " + , "G 1*.*.o.*6" + ] + +kpyramid_broken_3 :: Value +kpyramid_broken_3 = packLines $ + [ "G 3" + , "G . ." + , "G . . ." + , "W .o. . ." + , "G a*.*.o.*6" + ] + +compass_1 :: Value +compass_1 = decodeLines $ + [ "grid: |" + , " ..." + , " a.b" + , "clues:" + , " a: 2 1 . 2" + , " b: 21 . . 0" + ] + +compass_broken_1 :: Value +compass_broken_1 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " b: 21 . . 0" + ] + +compass_broken_2 :: Value +compass_broken_2 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: x . . 0" + , " b: 21 . . 0" + ] + +compass_broken_3 :: Value +compass_broken_3 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: 1 . ." + , " b: 21 . . 0" + ] + +compass_broken_4 :: Value +compass_broken_4 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: 1 . . 2 3" + , " b: 21 . . 0" + ] + +compass_broken_5 :: Value +compass_broken_5 = decodeLines $ + [ "grid: |" + , " a3b" + , "clues:" + , " a: 1 . . 2 3" + , " b: 21 . . 0" + ] + +thermo_1 :: Value +thermo_1 = packLines $ + [ ".b..2." + , "a.c5.1" + , ".d..6." + , ".4..c." + , "5.3b.d" + , ".2..a." + ] + +thermo_2 :: Value +thermo_2 = packLines $ + [ "....2." + , "..c5.1" + , ".b..6." + , "a..c.." + , "a...b." + , ".bc.a." + ] + +thermo_broken_1 :: Value +thermo_broken_1 = packLines $ + [ ".." + , "a." + ] + +thermo_broken_2 :: Value +thermo_broken_2 = packLines $ + [ "bb" + , "a." + ] + +multioutside :: Value +multioutside = decodeLines $ + [ "left:" + , " - [2, 1]" + , " - [3]" + , "right:" + , " - []" + , " - [1, 0]" + , "bottom:" + , " - [0, 0, 1]" + , "top:" + , " - [-1, 1]" + ] + +boxof2or3_1 :: Value +boxof2or3_1 = packLines $ + [ "*-*-*-*-*" + , "| | | | |" + , "*-*-*-*-*" + , "| | |" + , "*-o-o-o-*" + , " | | |" + , "*-*-*-*-*" + , "| | | | |" + , "o-*-*-*-*" + ] + +edgeGrid_1 :: Value +edgeGrid_1 = packLines $ + [ "o-*-*-o" + , "|1|2 3" + , "*-o" + ] diff --git a/tests/Data/GridShapeSpec.hs b/tests/Data/GridShapeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GridShapeSpec.hs @@ -0,0 +1,17 @@ +module Data.GridShapeSpec where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.GridShape +import qualified Data.Map.Strict as Map +import Data.List (sort) + +spec :: Spec +spec = do + describe "edgeSize" $ do + it "computes the size in cells" $ do + edgeSize [E (N 1 1) Vert, E (N 2 1) Horiz] `shouldBe` (3, 2) + describe "rows" $ do + it "computes the rows for a simple grid" $ do + sort (rows (Map.fromList [ ((C 1 1), 1::Int), ((C 1 2), 2), ((C 2 1), 3), ((C 2 2), 4) ])) + `shouldBe` sort [ [1, 2], [3, 4], [1, 3], [2, 4] ] diff --git a/tests/Data/GridSpec.hs b/tests/Data/GridSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/GridSpec.hs @@ -0,0 +1,22 @@ +module Data.GridSpec where + +import qualified Data.Set as Set +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Grid +import Data.GridShape (N(..)) + +spec :: Spec +spec = do + describe "sizeGrid" $ do + it "creates a rectangular grid of nodes" $ do + nodes (sizeGrid (2, 3)) `shouldBe` Set.fromList [ + N 0 0, N 0 1, N 0 2, + N 1 0, N 1 1, N 1 2] + nodes (sizeGrid (0, 0)) `shouldBe` Set.empty + nodes (sizeGrid (2, 0)) `shouldBe` Set.empty + nodes (sizeGrid (2, 1)) `shouldBe ` Set.fromList [N 0 0, N 1 0] + + describe "nodeGrid" $ do + it "creates the grid of nodes from a rectangular grid of cells" $ do + nodes (nodeGrid (sizeGrid (2, 1))) `shouldBe` nodes (sizeGrid (3, 2)) diff --git a/tests/Draw/GridSpec.hs b/tests/Draw/GridSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Draw/GridSpec.hs @@ -0,0 +1,58 @@ +module Draw.GridSpec where + +import Diagrams.Prelude (p2) +import Diagrams.Path (pathPoints) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Data.Grid +import Data.GridShape +import Draw.Grid +import Draw.Lib (p2i) + +spec :: Spec +spec = do + describe "irregularGridPaths" $ do + it "gives the border of a rectangular grid" $ do + let g = sizeGrid (2, 3) :: Grid C () + (outer, _) = irregularGridPaths g + pts = pathPoints outer + length pts `shouldBe` 1 + let [opts] = pts + opts `shouldSatisfy` elem (p2i (0, 0)) + opts `shouldSatisfy` elem (p2i (2, 0)) + opts `shouldSatisfy` elem (p2i (2, 3)) + opts `shouldSatisfy` elem (p2i (0, 3)) + + describe "midPoint" $ do + it "gives the center of a node edge" $ do + let e = E (N 0 1) Horiz + midPoint e `shouldBe` p2 (0.5, 1.0) + it "gives the center of a cell edge" $ do + let e = E (C 0 0) Vert + midPoint e `shouldBe` p2 (0.5, 1.0) + + describe "offsetBorder" $ do + it "gives the corners of a square cell" $ do + let b = offsetBorder 0 [C 0 0] + [vs] = pathPoints b + length vs `shouldBe` 4 + vs `shouldSatisfy` elem (p2i (0, 0)) + vs `shouldSatisfy` elem (p2i (1, 0)) + vs `shouldSatisfy` elem (p2i (0, 1)) + vs `shouldSatisfy` elem (p2i (1, 1)) + it "omits in-between nodes of a rectangle" $ do + let b = offsetBorder 0 [C 0 0, C 1 0] + [vs] = pathPoints b + length vs `shouldBe` 4 + vs `shouldSatisfy` elem (p2i (0, 0)) + vs `shouldSatisfy` elem (p2i (2, 0)) + vs `shouldSatisfy` elem (p2i (0, 1)) + vs `shouldSatisfy` elem (p2i (2, 1)) + it "offsets inside for negative offset" $ do + let b = offsetBorder (-0.5) [C 0 0, C 1 0, C 1 1, C 0 1] + [vs] = pathPoints b + length vs `shouldBe` 4 + vs `shouldSatisfy` elem (p2 (0.5, 0.5)) + vs `shouldSatisfy` elem (p2 (0.5, 1.5)) + vs `shouldSatisfy` elem (p2 (1.5, 1.5)) + vs `shouldSatisfy` elem (p2 (1.5, 0.5)) diff --git a/tests/Parse/PuzzleTypesSpec.hs b/tests/Parse/PuzzleTypesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Parse/PuzzleTypesSpec.hs @@ -0,0 +1,54 @@ +module Parse.PuzzleTypesSpec where + +import Data.Maybe (isJust) +import qualified Data.Map.Strict as Map +import Data.Yaml +import Data.Text.Encoding (encodeUtf8) +import qualified Data.ByteString as B +import qualified Data.Text as T + +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Data.GridShape (edgeSize) +import Data.Elements (DigitRange(..)) +import Parse.PuzzleTypes + +packLines :: [String] -> B.ByteString +packLines = encodeUtf8 . T.pack . unlines + +parse :: (Value -> Parser a) -> B.ByteString -> Maybe a +parse p t = decodeThrow t >>= parseMaybe p + +spec :: Spec +spec = do + describe "abctje" $ do + it "parses a list of clues" $ do + let (p, _) = abctje + y = packLines [ "numbers: 1-10" + , "clues:" + , "- HELLO: 15" + , "- WORLD: 20" + , "- weird stuff, too!: 100" + ] + parse p y `shouldBe` Just (DigitRange 1 10, [("HELLO", 15), ("WORLD", 20), ("weird stuff, too!", 100)]) + it "parses a solution" $ do + let (_, p) = abctje + y = packLines [ "- 1: A" + , "- 100: C" + ] + parse p y `shouldBe` Just [(1, 'A'), (100, 'C')] + + describe "kropki" $ do + it "parses edges of the right size" $ do + let (p, _) = kropki + y = packLines [ "|" + , " + + + +" + , " . . . " + , " +*+ + +" + , " . .o. " + , " + + + +" + ] + res = parse p y + res `shouldSatisfy` isJust + let Just m = res + edgeSize (Map.keys m) `shouldBe` (3, 2) diff --git a/tests/Parse/UtilSpec.hs b/tests/Parse/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Parse/UtilSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeFamilies #-} +module Parse.UtilSpec where + +import qualified Data.Map.Strict as Map +import Data.Yaml +import qualified Data.Text as T + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.GridShape (Edge(..), N(..), Dir(..)) +import Data.Elements (Relation(..)) +import Parse.Util (parseCoordGrid, parseAnnotatedEdges, parseGreaterClue) + +packLines :: [String] -> Value +packLines = String . T.pack . unlines + +spec :: Spec +spec = do + describe "parseCoordGrid" $ do + it "parses a rectangle of letters" $ do + let y = packLines [ "abc" + , "def" + ] + want = Map.fromList [ ((0, 0), 'd') + , ((1, 0), 'e') + , ((2, 0), 'f') + , ((0, 1), 'a') + , ((1, 1), 'b') + , ((2, 1), 'c') + ] + parseMaybe parseCoordGrid y `shouldBe` Just want + + describe "parseAnnotatedEdges" $ do + it "parses some kropki clues" $ do + let y = packLines [ "+ + + +" + , " . .*.o" + , "+ +o+ +" + , " . . . " + , "+ + + +" + ] + want = Map.fromList + [ (E (N 1 1) Horiz, 'o') + , (E (N 2 1) Vert, '*') + , (E (N 3 1) Vert, 'o') + ] + parseNonempty v = Map.filter ((/=) ' ') <$> parseAnnotatedEdges v + parseMaybe parseNonempty y `shouldBe` Just want + + describe "parseGreaterClue" $ do + it "parses an empty line" $ do + let y = [] + want = [] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a single dot" $ do + let y = ['.'] + want = [RUndetermined] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a single dot" $ do + let y = ['.'] + want = [RUndetermined] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a mixed line" $ do + let y = ['.', '<', '.', ' ', '.', '=', '.'] + want = [RUndetermined, RLess, RUndetermined, REqual] + parseMaybe parseGreaterClue y `shouldBe` Just want diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,29 @@ +module Util where + +import Control.DeepSeq +import Data.Yaml + +import Test.Tasty.HUnit + +-- | Force full evaluation of a showable value. +justShow :: Show a => Maybe a -> Bool +justShow Nothing = False +justShow (Just x) = show x `deepseq` True + +-- | Force full evaluation of a showable value. +eitherShow :: Show a => Either e a -> Bool +eitherShow (Left _) = False +eitherShow (Right x) = show x `deepseq` True + +-- | Test that a value is parsed correctly, by forcing the +-- parse result to be fully evaluated. +testParse :: Show a => (Value -> Parser a) -> Value -> Assertion +testParse p t = eitherShow res @? "bad parse: " ++ err + where + res = parseEither p t + err = either id (const "no error") res + +-- | Test that a value is not parsed. +testNonparse :: Show a => (Value -> Parser a) -> Value -> Assertion +testNonparse p t = (not . justShow . parseMaybe p $ t) + @? "parsed but shouldn't" diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,45 +1,62 @@ import Test.Tasty +import Test.Tasty.Hspec import Test.Tasty.HUnit import Data.Yaml import Data.List (sort) -import qualified Data.Map as Map -import Control.DeepSeq +import qualified Data.Map.Strict as Map -import Text.Puzzles.Puzzle -import Data.Puzzles.Elements (Thermometer, MasyuPearl(..)) -import Text.Puzzles.Util - (parseChar, parseMultiOutsideClues, parseEdgeGrid) -import Text.Puzzles.PuzzleTypes -import qualified Data.Puzzles.Grid as Grid -import Data.Puzzles.Pyramid (PyramidSol(..)) -import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..)) -import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..)) +import Parse.Puzzle +import Data.Elements (Thermometer, MasyuPearl(..)) +import Parse.Util + (parseChar, parseMultiOutsideClues, parsePlainEdgeGrid) +import Parse.PuzzleTypes +import qualified Data.Grid as Grid +import Data.Pyramid (PyramidSol(..)) +import Data.Grid +import Data.GridShape +import Data.Util -import Diagrams.Puzzles.PuzzleGrids -import Diagrams.Prelude -import Diagrams.Backend.SVG -import Text.Blaze.Svg.Renderer.Text (renderSvg) - import Data import Util +import qualified Data.GridSpec +import qualified Data.GridShapeSpec +import qualified Draw.GridSpec +import qualified Parse.PuzzleTypesSpec +import qualified Parse.UtilSpec main :: IO () -main = defaultMain tests +main = do + ss <- specs + defaultMain . testGroup "Tests" $ tests ++ ss -tests :: TestTree -tests = testGroup "Tests" - [ parseUtilTests, parseTests, parseDataTests, renderTests, dataTests ] +specs :: IO [TestTree] +specs = mapM (uncurry testSpec) + [ ("Data.Grid", Data.GridSpec.spec) + , ("Data.GridShape", Data.GridShapeSpec.spec) + , ("Draw.Grid", Draw.GridSpec.spec) + , ("Parse.PuzzleTypes", Parse.PuzzleTypesSpec.spec) + , ("Parse.Util", Parse.UtilSpec.spec) + ] -testParsePzl, testParseSol, testNonparsePzl, testNonparseSol :: - (Show a, Show b) => String -> ParsePuzzle a b -> Value -> TestTree +tests :: [TestTree] +tests = [ parseUtilTests, parseTests, parseDataTests, dataTests ] + +testParsePzl :: + Show a => String -> ParsePuzzle a b -> Value -> TestTree testParsePzl name parser yaml = testCase ("parse " ++ name) $ testParse (fst parser) yaml +testParseSol :: + Show b => String -> ParsePuzzle a b -> Value -> TestTree testParseSol name parser yaml = testCase ("parse " ++ name ++ " (sol)") $ testParse (snd parser) yaml +testNonparsePzl :: + Show a => String -> ParsePuzzle a b -> Value -> TestTree testNonparsePzl name parser yaml = testCase ("don't parse broken " ++ name) $ testNonparse (fst parser) yaml +testNonparseSol :: + Show b => String -> ParsePuzzle a b -> Value -> TestTree testNonparseSol name parser yaml = testCase ("don't parse broken " ++ name ++ " (sol)") $ testNonparse (snd parser) yaml @@ -92,15 +109,15 @@ test_thermo_2 = either (const []) snd $ parseEither (fst thermosudoku) thermo_2 -testThermo :: [Thermometer] -> [Thermometer] -> Assertion -testThermo t expect = sort t @?= expect +testThermo :: [Thermometer] -> [[Coord]] -> Assertion +testThermo t expect = sort t @?= map (map fromCoord) expect test_tightfit_1 :: Bool test_tightfit_1 = either (const False) test_both res where res = parseEither (fst tightfitskyscrapers) tightfit_1 test_both (o, g) = test_size g && test_clues o - test_size g = Grid.size g == (3, 3) + test_size g = Grid.size (Map.mapKeys toCoord g) == (3, 3) test_clues (Grid.OC l r b t) = l == [Nothing, Nothing, Just 3] && r == [Nothing, Just 4, Nothing] && b == [Just 3, Just 5, Nothing] && @@ -118,19 +135,23 @@ where res = parseEither parseMultiOutsideClues multioutside oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]] - :: OutsideClues [Int] + :: OutsideClues Coord [Int] -test_edge_grid :: Assertion -test_edge_grid = Right (gn, gc, es) @=? res +test_plain_edge_grid :: Assertion +test_plain_edge_grid = Right (gn, gc, sort es) @=? res' where - res = parseEither parseEdgeGrid edgeGrid_1 - gn = Grid.Grid (Square 4 2) $ Map.fromList + res = parseEither parsePlainEdgeGrid edgeGrid_1 + res' = fmap (\(x, y, e) -> (x, y, sort e)) res + gn :: Grid.Grid N (Maybe MasyuPearl) + gn = Map.mapKeys fromCoord . Map.fromList $ [((0,0),Just MBlack),((0,1),Just MWhite),((1,0),Just MWhite),((1,1),Just MBlack), ((2,0),Nothing),((2,1),Just MBlack),((3,0),Nothing),((3,1),Just MWhite)] - gc :: Grid.SGrid Int - gc = Grid.Grid (Square 3 1) $ Map.fromList + gc :: Grid.Grid C Int + gc = Map.mapKeys fromCoord . Map.fromList $ [((0,0),1),((1,0),2),((2,0),3)] - es = [E (0,0) H, E (0,1) H, E (1,1) H, E (2,1) H, E (0,0) V, E (1,0) V] + es = map (\(E c d) -> E (fromCoord c) d) + [E (0,0) Horiz, E (0,1) Horiz, E (1,1) Horiz, E (2,1) Horiz, + E (0,0) Vert, E (1,0) Vert] parseDataTests :: TestTree parseDataTests = testGroup "Parsing tests (full puzzles, result checks)" @@ -144,39 +165,70 @@ , [(0, 2), (1, 3), (2, 4)] , [(4, 0), (4, 1), (3, 2)] ] , testCase "parse multioutsideclues" $ test_multioutside - , testCase "parse edge grid" $ test_edge_grid + , testCase "parse edge grid" $ test_plain_edge_grid ] --- this used to cause a rendering crash, though it's --- caught by parsing by now -testBreakSlalom :: Bool -testBreakSlalom = - case parseMaybe (snd slalom) slalom_sol_broken of - Nothing -> True - Just s -> let d = drawSlalomDiags s - svg = renderDia SVG (SVGOptions (Width 100) Nothing) d - svgt = renderSvg svg - in (show svgt) `deepseq` True - -renderTests :: TestTree -renderTests = testGroup "Rendering tests" - [ testCase "don't break rendering invalid slalom solution" - $ testBreakSlalom @? "just testing against errors" - ] +sorteq :: (Show a, Ord a) => [a] -> [a] -> Assertion +sorteq xs ys = sort xs @?= sort ys testMultiOutsideClues :: Assertion -testMultiOutsideClues = multiOutsideClues (OC l r b t) `sorteq` res +testMultiOutsideClues = multiOutsideClues (OC l r b t) @=? res where - sorteq xs ys = sort xs @?= sort ys l = [[1, 2], [3]] r = [[], [1, 0]] b = [[0, 0, 1]] t = [[1, -1]] - res = [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3), + res :: Map.Map C Int + res = Map.mapKeys fromCoord . Map.fromList $ + [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3), ((1,1), 1), ((2,1), 0), ((0,-1), 0), ((0,-2), 0), ((0,-3), 1), - ((0,2), 1), ((0,3), -1) ] :: [((Int, Int), Int)] + ((0,2), 1), ((0,3), -1) ] +testEdges :: Assertion +testEdges = do + inner `sorteq` expinner' + outer `sorteq` expouter' + where + (outer, inner) = edges cs (`elem` cs) + {- + ### + # # + ### + -} + cs :: [C] + cs = map fromCoord [(0,0), (1,0), (2,0), (0,1), (2,1), (0,2), (1,2), (2,2)] + expouter = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)), + ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)), + ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)), + ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))] + expouter' = map (uncurry edge' . fromCoord2) expouter + expinner = [((0,1),(1,1)), ((0,2),(1,2)), ((1,0),(1,1)), ((2,0),(2,1)), + ((1,3),(1,2)), ((2,3),(2,2)), ((3,1),(2,1)), ((3,2),(2,2))] + expinner' = map (uncurry edge . fromCoord2) expinner + fromCoord2 (p,q) = (fromCoord p, fromCoord q) + +testLoops :: Assertion +testLoops = loops es @=? Just loopsexp + -- rotations of the loops would be fine + -- inside and outside of: + -- xxx + -- x x + -- xxx + where + es = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)), + ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)), + ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)), + ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))] + loopsexp :: [[(Int, Int)]] + loopsexp = + [ [(0,0), (0,1), (0,2), (0,3), (1,3), (2,3), (3,3), (3,2), (3,1), + (3,0), (2,0), (1,0), (0,0)] + , [(1,1), (2,1), (2,2), (1,2), (1,1)] + ] + dataTests :: TestTree dataTests = testGroup "Generic tests for the Data modules" [ testCase "multiOutsideClues" testMultiOutsideClues + , testCase "edges" testEdges + , testCase "loops" testLoops ]