From 6a269ca1cb01e935064a166f53180bf00c2ba84d Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 3 Jan 2020 12:49:00 +0100 Subject: [PATCH] format using ormolu --- Makefile | 4 +- src/Data/Code.hs | 36 +- src/Data/Component.hs | 51 +- src/Data/Compose.hs | 212 ++-- src/Data/Elements.hs | 46 +- src/Data/Grid.hs | 477 +++++---- src/Data/GridShape.hs | 227 ++-- src/Data/Lib.hs | 17 +- src/Data/PuzzleTypes.hs | 337 +++--- src/Data/Pyramid.hs | 112 +- src/Data/Sudoku.hs | 32 +- src/Data/Util.hs | 34 +- src/Draw/CmdLine.hs | 94 +- src/Draw/Code.hs | 95 +- src/Draw/Component.hs | 179 ++-- src/Draw/Draw.hs | 152 +-- src/Draw/Elements.hs | 528 +++++----- src/Draw/Font.hs | 19 +- src/Draw/Generic.hs | 101 +- src/Draw/Grid.hs | 346 +++--- src/Draw/GridShape.hs | 34 +- src/Draw/Lib.hs | 93 +- src/Draw/PuzzleGrids.hs | 236 +++-- src/Draw/PuzzleTypes.hs | 1798 +++++++++++++++++--------------- src/Draw/Pyramid.hs | 27 +- src/Draw/Render.hs | 238 +++-- src/Draw/Style.hs | 95 +- src/Parse/Code.hs | 40 +- src/Parse/Component.hs | 205 ++-- src/Parse/Parsec.hs | 24 +- src/Parse/Puzzle.hs | 35 +- src/Parse/PuzzleTypes.hs | 884 ++++++++-------- src/Parse/Util.hs | 762 +++++++------- src/serve/Main.hs | 174 ++-- src/tools/checkpuzzle.hs | 228 ++-- src/tools/drawpuzzle.hs | 201 ++-- tests/Data.hs | 64 +- tests/Data/GridShapeSpec.hs | 26 +- tests/Data/GridSpec.hs | 37 +- tests/Draw/GridSpec.hs | 38 +- tests/Draw/PuzzleTypesSpec.hs | 49 +- tests/Parse/PuzzleTypesSpec.hs | 70 +- tests/Parse/UtilSpec.hs | 83 +- tests/Util.hs | 17 +- tests/tests.hs | 475 +++++---- 45 files changed, 4634 insertions(+), 4398 deletions(-) diff --git a/Makefile b/Makefile index ab870a1..33ca39d 100644 --- a/Makefile +++ b/Makefile @@ -10,5 +10,5 @@ compare: $(MAKE) -C tests/examples compare DRAW=$(DRAW) format: - find src -name '*.hs' | xargs brittany --write-mode=inplace - find tests -name '*.hs' | xargs brittany --write-mode=inplace + find src -name '*.hs' | xargs ormolu -m inplace + find tests -name '*.hs' | xargs ormolu -m inplace diff --git a/src/Data/Code.hs b/src/Data/Code.hs index 320f5dd..4fab01f 100644 --- a/src/Data/Code.hs +++ b/src/Data/Code.hs @@ -1,19 +1,27 @@ module Data.Code where -import Data.Map.Strict ( Map ) - -import Data.Grid -import Data.GridShape +import Data.Grid +import Data.GridShape +import Data.Map.Strict (Map) 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. +data CodePart + = -- | Rows of cells, counted from the bottom. + Rows' [Int] + | -- | Cols of cells, counted from the left. + Cols [Int] + | -- | Rows of nodes, counted from the bottom. + RowsN' [Int] + | -- | Cols of nodes, counted from the left. + ColsN [Int] + | -- | Nodes, labeld by letters. + LabelsN (Grid N (Maybe Char)) + | -- | Rows of cells, counted from the bottom. + LRows' (Map Char Int) + | -- | Cols of cells, counted from the left. + LCols (Map Char Int) + | -- | Rows of nodes, counted from the bottom. + LRowsN' (Map Char Int) + | -- | Cols of nodes, counted from the left. + LColsN (Map Char Int) diff --git a/src/Data/Component.hs b/src/Data/Component.hs index f607a8c..0e583a9 100644 --- a/src/Data/Component.hs +++ b/src/Data/Component.hs @@ -1,13 +1,12 @@ module Data.Component where -import qualified Data.Map.Strict as Map +import Data.Elements +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map -import Data.GridShape -import Data.Grid -import Data.Elements - -data Component a = - Grid !GridStyle !(Grid C ()) +data Component a + = Grid !GridStyle !(Grid C ()) | Regions !(Grid C Char) | NodeGrid !(Grid N Decoration) | CellGrid !(Grid C Decoration) @@ -18,53 +17,55 @@ data Component a = | Note [Decoration] | RawComponent !Size !a -data Tag = - Puzzle +data Tag + = Puzzle | Solution | Code - deriving (Eq, Show) + deriving (Eq, Show) data TaggedComponent a = TaggedComponent (Maybe Tag) (PlacedComponent a) -data Placement = - Atop +data Placement + = Atop | West | North | TopRight - deriving (Eq, Show) + deriving (Eq, Show) data PlacedComponent a = PlacedComponent Placement (Component a) tagged :: Tag -> TaggedComponent a -> Bool tagged tag component = case component of TaggedComponent (Just t) _ -> tag == t - _ -> False + _ -> False untag :: TaggedComponent a -> PlacedComponent a untag (TaggedComponent _ c) = c extractPuzzle :: Bool -> [TaggedComponent a] -> [PlacedComponent a] extractPuzzle code tcs = map untag . filter want $ tcs - where want c = not (tagged Solution c) && (code || not (tagged Code c)) + where + want c = not (tagged Solution c) && (code || not (tagged Code c)) extractSolution :: Bool -> [TaggedComponent a] -> Maybe [PlacedComponent a] -extractSolution code tcs = if haveSol - then Just . map untag . filter want $ tcs - else Nothing - where - haveSol = not . null . filter (tagged Solution) $ tcs - want c = not (tagged Puzzle c) && (code || not (tagged Code c)) +extractSolution code tcs = + if haveSol + then Just . map untag . filter want $ tcs + else Nothing + where + haveSol = not . null . filter (tagged Solution) $ tcs + want c = not (tagged Puzzle c) && (code || not (tagged Code c)) -data GridStyle = - GridDefault +data GridStyle + = GridDefault | GridDefaultIrregular | GridDashed | GridDots | GridPlain | GridPlainDashed -data Decoration = - Blank +data Decoration + = Blank | Letter !Char | Letters String | InvertedLetters String diff --git a/src/Data/Compose.hs b/src/Data/Compose.hs index ec231df..7006fa7 100644 --- a/src/Data/Compose.hs +++ b/src/Data/Compose.hs @@ -1,135 +1,139 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | -- Helpers to string together parser and renderer by puzzle type. - module Data.Compose - ( compose + ( compose, ) where -import Data.Yaml ( Parser - , Value - ) - -import Parse.Puzzle -import Data.Lib -import Draw.Draw -import Draw.Lib -import Data.PuzzleTypes - -import qualified Parse.PuzzleTypes as R -import qualified Draw.PuzzleTypes as D +import Data.Lib +import Data.PuzzleTypes +import Data.Yaml + ( Parser, + Value, + ) +import Draw.Draw +import Draw.Lib +import qualified Draw.PuzzleTypes as D +import Parse.Puzzle +import qualified Parse.PuzzleTypes as R -compose - :: Backend' b - => PuzzleType - -> ((Value, Maybe Value) -> Parser (Drawing b, Maybe (Drawing b))) +compose :: + Backend' b => + PuzzleType -> + ((Value, Maybe Value) -> Parser (Drawing b, Maybe (Drawing b))) compose = handle drawPuzzleMaybeSol -- | 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 +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 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 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 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 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 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 LITS = f R.lits D.lits +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 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 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 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 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 SkyscrapersTightfit = 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 Starbattle = f R.starbattle D.starbattle -handle f Heyawake = f R.heyawake D.heyawake -handle f Pentominous = f R.pentominous D.pentominous -handle f ColorAkari = f R.colorakari D.colorakari +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 Starbattle = f R.starbattle D.starbattle +handle f Heyawake = f R.heyawake D.heyawake +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 Illumination = f R.illumination D.illumination -handle f Pentopia = f R.pentopia D.pentopia -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 JapaneseSumsMasyu = f R.japsummasyu D.japsummasyu -handle f ArrowSudoku = f R.arrowsudoku D.arrowsudoku -handle f DualLoop = f R.dualloop D.dualloop -handle _ t = if isGeneric t - then impossible - else error $ "puzzle type unhandled: " ++ show t +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 Illumination = f R.illumination D.illumination +handle f Pentopia = f R.pentopia D.pentopia +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 JapaneseSumsMasyu = f R.japsummasyu D.japsummasyu +handle f ArrowSudoku = f R.arrowsudoku D.arrowsudoku +handle f DualLoop = f R.dualloop D.dualloop +handle _ t = + if isGeneric t + then impossible + else error $ "puzzle type unhandled: " ++ show t -- | 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 (Drawing b, Maybe (Drawing b))) +drawPuzzleMaybeSol :: + PuzzleHandler + b + ((Value, Maybe Value) -> Parser (Drawing b, Maybe (Drawing b))) drawPuzzleMaybeSol (pp, ps) (Drawers dp ds) (p, s) = do p' <- pp p s' <- traverse ps s let mps = case s' of - Nothing -> Nothing + Nothing -> Nothing Just s'' -> Just (p', s'') return (dp p', ds <$> mps) diff --git a/src/Data/Elements.hs b/src/Data/Elements.hs index 0933c89..b8f737c 100644 --- a/src/Data/Elements.hs +++ b/src/Data/Elements.hs @@ -1,12 +1,12 @@ -- | Types for a variety of puzzle elements. module Data.Elements where -import Data.GridShape +import Data.GridShape type Clue a = Maybe a data MasyuPearl = MWhite | MBlack - deriving (Eq, Show) + deriving (Eq, Show) type MasyuClue = Clue MasyuPearl @@ -15,7 +15,7 @@ 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 + deriving (Show) type CompassClue = Clue CompassC @@ -26,15 +26,15 @@ data SlovakClue = SlovakClue !Int !Int 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 - + 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 } +data MarkedWord = MW {mwstart :: Coord, mwend :: Coord} -- | A loop of edges. type Loop a = [Edge a] @@ -52,50 +52,50 @@ type Thermometer = [C] -- | A forward or backward diagonal as occurring in the solution -- of a slalom puzzle. data SlalomDiag = SlalomForward | SlalomBackward - deriving Show + deriving (Show) data KropkiDot = KNone | KBlack | KWhite - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) newtype TapaClue = TapaClue [Int] - deriving Show + deriving (Show) -- | Diagonal marking for Prime Place: forward diag?, backward diag? newtype PrimeDiag = PrimeDiag (Bool, Bool) data Black = Black - deriving Eq + deriving (Eq) data Fish = Fish - deriving Eq + deriving (Eq) data Star = Star - deriving Eq + deriving (Eq) data Crossing = Crossing - deriving Eq + deriving (Eq) type BahnhofClue = Either Int Crossing data DigitRange = DigitRange !Int !Int - deriving (Show, Eq) + 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 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) + deriving (Show, Eq) type GreaterClue = [Relation] @@ -106,4 +106,4 @@ data PlacedTent = Tent Dir' data Tree = Tree data Pentomino = Pentomino Char - deriving (Show, Eq) + deriving (Show, Eq) diff --git a/src/Data/Grid.hs b/src/Data/Grid.hs index bff771f..f87d3aa 100644 --- a/src/Data/Grid.hs +++ b/src/Data/Grid.hs @@ -1,52 +1,52 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -- | Puzzle grids. module Data.Grid - ( Grid - , AreaGrid - , ShadedGrid - , nodes - , size - , cellSize - , nodeSize - , edgeSize - , shiftSize - , sizeGrid - , clues - , nodeGrid - , cellGrid - , dominoGrid - , litsGrid - , litsoGrid - , pentominoGrid - , borders - , skeletons - , edgesGen - , colour - , collectLines - , rows - , OutsideClues(..) - , outsideSize - , outsideClues - , outsideGrid - , outsideValues + ( Grid, + AreaGrid, + ShadedGrid, + nodes, + size, + cellSize, + nodeSize, + edgeSize, + shiftSize, + sizeGrid, + clues, + nodeGrid, + cellGrid, + dominoGrid, + litsGrid, + litsoGrid, + pentominoGrid, + borders, + skeletons, + edgesGen, + colour, + collectLines, + rows, + OutsideClues (..), + outsideSize, + outsideClues, + 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 +import Control.Monad.State +import Data.AffineSpace +import Data.Elements +import Data.GridShape +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.VectorSpace 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 @@ -54,21 +54,21 @@ type ShadedGrid = Grid C Bool 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 :: + 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 + 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 @@ -84,7 +84,8 @@ corners c = map (.+^ (c .-. C 0 0)) [N 0 0, N 1 0, N 0 1, N 1 1] -- first grid. nodeGrid :: Grid C a -> Grid N () nodeGrid = Map.unions . map cornersM . Map.keys - where cornersM = Map.fromList . map (flip (,) ()) . corners + where + cornersM = Map.fromList . map (flip (,) ()) . corners cellGrid :: Grid N a -> Grid C () cellGrid m = @@ -94,79 +95,75 @@ cellGrid m = . map cellUpRight . Map.keys $ m - where - cellUpRight :: N -> C - cellUpRight = fromCoord . toCoord + 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 _ -> - let b = m Map.! x - in if a == b - then do - modify (Map.insert x (Right c)) - mapM_ (fill a c) (nbrs x) - else del b c x - Right _ -> return () - - -- flood-remove the given colour from the list of candidates - del a c x = do - v <- (Map.! x) <$> get - case v of - Left cs -> if m Map.! x == a - then case (rm c) cs of - Nothing -> return () - Just cs' -> do - modify (Map.insert x (Left cs')) - mapM_ (del a c) (nbrs x) - else return () - Right _ -> return () - - rm c (x : xs) = - if x == c then Just xs else if x > c then Nothing else (x :) <$> rm c xs - rm _ [] = Nothing - + 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 _ -> + let b = m Map.! x + in if a == b + then do + modify (Map.insert x (Right c)) + mapM_ (fill a c) (nbrs x) + else del b c x + Right _ -> return () + -- flood-remove the given colour from the list of candidates + del a c x = do + v <- (Map.! x) <$> get + case v of + Left cs -> + if m Map.! x == a + then case (rm c) cs of + Nothing -> return () + Just cs' -> do + modify (Map.insert x (Left cs')) + mapM_ (del a c) (nbrs x) + else return () + Right _ -> return () + rm c (x : xs) = + if x == c then Just xs else if x > c then Nothing else (x :) <$> rm c xs + rm _ [] = Nothing 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 ] + 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) +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) + 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) + 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 () @@ -177,34 +174,35 @@ 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] ] + $ [((x, y), ()) | x <- [0 .. w - 1], y <- [0 .. h - 1]] -outsideClues - :: (Ord k, FromCoord k) - => OutsideClues k a - -> [([a], (Int, Int), k, (Int, Int))] +outsideClues :: + (Ord k, FromCoord k) => + OutsideClues k a -> + [([a], (Int, Int), k, (Int, Int))] outsideClues ocs@(OC l r b t) = - [ (l, (-1, 0), fromCoord (-1, 0), (0, 1)) - , (r, (1, 0) , fromCoord (w, 0) , (0, 1)) - , (b, (0, -1), fromCoord (0, -1), (1, 0)) - , (t, (0, 1) , fromCoord (0, h) , (1, 0)) + [ (l, (-1, 0), fromCoord (-1, 0), (0, 1)), + (r, (1, 0), fromCoord (w, 0), (0, 1)), + (b, (0, -1), fromCoord (0, -1), (1, 0)), + (t, (0, 1), fromCoord (0, h), (1, 0)) ] - where (w, h) = outsideSize ocs + where + (w, h) = outsideSize ocs 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) - ] + 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 + where + eq (Just x) (Just y) = x == y + eq _ _ = False -- | The skeletons of connected equal cells. skeletons :: Eq a => Grid C a -> [Edge C] @@ -214,12 +212,14 @@ 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 + $ [((a, s - b), (b + x, a + x)) | a <- [0 .. s], b <- [0 .. s], b <= a] + where + s = y - x listSize :: [Coord] -> Size listSize cs = foldr (both max) (0, 0) cs - where both f (x, y) (x', y') = (f x x', f y y') + where + both f (x, y) (x', y') = (f x x', f y y') size :: Grid Coord a -> Size size = (^+^) (1, 1) . listSize . Map.keys @@ -240,9 +240,9 @@ edgeSize = 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 ] + . Map.fromList + $ [(a, Just c) | (a, c) <- ls] + ++ [(a, Nothing) | a <- ps] {- A grid with (Just p) for the capital letters, @@ -257,72 +257,71 @@ Nothing for the lowercase letters. -} 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) - ] - + 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, @@ -335,31 +334,31 @@ Nothing for the lowercase letters. -} 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) - ] + 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, @@ -372,19 +371,19 @@ Nothing for the lowercase letters. -} 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) - ] + 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 index e85081e..79bccf5 100644 --- a/src/Data/GridShape.hs +++ b/src/Data/GridShape.hs @@ -1,74 +1,77 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Grid shapes. module Data.GridShape - ( Coord - , Size - , Square(..) - , Dir(..) - , Edge(..) - , Dir'(..) - , Edge'(..) - , Dual2D(..) - , Key - , Dual' - , C(..) - , N(..) - , ShiftC(..) - , FromCoord(..) - , ToCoord(..) - , edge - , edge' - , edgeBetween - , edgeBetween' - , orient - , ends' - , revEdge - , edges - , edgesM - , ends - , unorient - , dualE - , vertexNeighbours - , edgeNeighbours - , rows - , shift - , mapEdge + ( Coord, + Size, + Square (..), + Dir (..), + Edge (..), + Dir' (..), + Edge' (..), + Dual2D (..), + Key, + Dual', + C (..), + N (..), + ShiftC (..), + FromCoord (..), + ToCoord (..), + edge, + edge', + edgeBetween, + edgeBetween', + orient, + ends', + revEdge, + edges, + edgesM, + ends, + unorient, + dualE, + vertexNeighbours, + edgeNeighbours, + rows, + shift, + mapEdge, ) where -import qualified Data.Foldable as F -import Data.List ( partition - , groupBy - , sortOn - ) -import qualified Data.Map.Strict as Map -import Data.AffineSpace +import Data.AffineSpace +import qualified Data.Foldable as F +import Data.List + ( groupBy, + partition, + sortOn, + ) +import qualified Data.Map.Strict as Map type Coord = (Int, Int) class FromCoord a where - fromCoord :: Coord -> a + fromCoord :: Coord -> a class ToCoord a where - toCoord :: a -> Coord + toCoord :: a -> Coord data C = C !Int !Int - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) instance FromCoord C where - fromCoord = uncurry C + fromCoord = uncurry C instance ToCoord C where - toCoord (C x y) = (x, y) + 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') + 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') newtype ShiftC = ShiftC C deriving (Show, Eq, Ord) @@ -80,45 +83,48 @@ instance FromCoord ShiftC where fromCoord = ShiftC . fromCoord data N = N !Int !Int - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) instance FromCoord N where - fromCoord = uncurry N + fromCoord = uncurry N instance ToCoord N where - toCoord (N x y) = (x, y) + 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') + 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) + 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 ] +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) + 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) + deriving (Show, Eq, Ord) mapEdge :: (a -> b) -> Edge a -> Edge b mapEdge f (E x d) = E (f x) d @@ -127,18 +133,18 @@ type Size = (Int, Int) -- | Oriented edge direction in a square grid. data Dir' = U | D | L | R - deriving (Eq, Ord, Show) + 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" +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) + deriving (Eq, Ord, Show) edge' :: (AffineSpace a, Diff a ~ (Int, Int)) => a -> a -> Edge' a edge' p q = E' p (toDir' (q .-. p)) @@ -147,36 +153,44 @@ 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) + 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) + +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 + 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 + 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 Vert) = (x, x .+^ (0, 1)) ends (E x Horiz) = (x, x .+^ (1, 0)) ends' :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> (a, a) @@ -195,7 +209,7 @@ 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 Vert) = E' x U orient (E x Horiz) = E' x R edgeBetween' :: Dual' k => k -> k -> Edge' (Dual k) @@ -208,34 +222,37 @@ edgeBetween p q = unorient $ edgeBetween' p q -- 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 :: + (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 ] + 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) +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) shift :: (AffineSpace a, Diff a ~ (Int, Int)) => (Int, Int) -> Edge a -> Edge a shift delta (E x dir) = E (x .+^ delta) dir diff --git a/src/Data/Lib.hs b/src/Data/Lib.hs index babdf1b..34cfc5e 100644 --- a/src/Data/Lib.hs +++ b/src/Data/Lib.hs @@ -1,18 +1,19 @@ module Data.Lib - ( mapLeft - , impossible - , invertMap + ( mapLeft, + impossible, + invertMap, ) where -import qualified Data.Map.Strict as Map -import Data.List ( groupBy - , sortOn - ) +import Data.List + ( groupBy, + sortOn, + ) +import qualified Data.Map.Strict as Map mapLeft :: (a -> b) -> Either a x -> Either b x mapLeft f e = case e of - Left l -> Left $ f l + Left l -> Left $ f l Right r -> Right r invertMap :: (Eq a, Ord a) => Map.Map k a -> Map.Map a [k] diff --git a/src/Data/PuzzleTypes.hs b/src/Data/PuzzleTypes.hs index 38b9548..7c13920 100644 --- a/src/Data/PuzzleTypes.hs +++ b/src/Data/PuzzleTypes.hs @@ -1,191 +1,192 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -- | -- List of specific puzzle types. - module Data.PuzzleTypes - ( PuzzleType(..) - , lookupType - , checkType - , typeOptions - , isGeneric + ( PuzzleType (..), + lookupType, + checkType, + typeOptions, + isGeneric, ) where -import Data.List ( sort ) -import Data.Tuple ( swap ) +import Data.List (sort) +import Data.Tuple (swap) -- | The list of specific puzzle types we can handle. -data PuzzleType = LITS - | Geradeweg - | Fillomino - | Masyu - | Nurikabe - | LatinTapa - | Sudoku - | ThermoSudoku - | Pyramid - | RowKropkiPyramid - | SlitherLink - | SlitherLinkLiar - | WordLoop - | WordSearch - | CurveData - | DoubleBack - | Slalom - | Compass - | MeanderingNumbers - | Tapa - | JapaneseSums - | Coral - | MaximalLengths - | Labyrinth - | Bahnhof - | BlackoutDominos - | TwilightTapa - | TapaCave - | DominoPillen - | AngleLoop - | Shikaku - | SlovakSums - | Anglers - | Dominos - | FillominoCheckered - | FillominoLoop - | Cave - | Numberlink - | Skyscrapers - | SkyscrapersStars - | SkyscrapersFrac - | SkyscrapersTightfit - | TurningFences - | Summon - | Baca - | Buchstabensalat - | Doppelblock - | SudokuDoppelblock - | Loopki - | Scrabble - | Neighbors - | Starbattle - | Heyawake - | Pentominous - | ColorAkari - | PersistenceOfMemory - | ABCtje - | Kropki - | StatuePark - | PentominousBorders - | NanroSignpost - | TomTom - | Illumination - | Pentopia - | GreaterWall - | Galaxies - | Mines - | Tents - | PentominoSums - | CoralLITS - | CoralLITSO - | Snake - | CountryRoad - | KillerSudoku - | JapaneseSumsMasyu - | ArrowSudoku - | DualLoop - | Yajilin - deriving (Show, Eq) +data PuzzleType + = LITS + | Geradeweg + | Fillomino + | Masyu + | Nurikabe + | LatinTapa + | Sudoku + | ThermoSudoku + | Pyramid + | RowKropkiPyramid + | SlitherLink + | SlitherLinkLiar + | WordLoop + | WordSearch + | CurveData + | DoubleBack + | Slalom + | Compass + | MeanderingNumbers + | Tapa + | JapaneseSums + | Coral + | MaximalLengths + | Labyrinth + | Bahnhof + | BlackoutDominos + | TwilightTapa + | TapaCave + | DominoPillen + | AngleLoop + | Shikaku + | SlovakSums + | Anglers + | Dominos + | FillominoCheckered + | FillominoLoop + | Cave + | Numberlink + | Skyscrapers + | SkyscrapersStars + | SkyscrapersFrac + | SkyscrapersTightfit + | TurningFences + | Summon + | Baca + | Buchstabensalat + | Doppelblock + | SudokuDoppelblock + | Loopki + | Scrabble + | Neighbors + | Starbattle + | Heyawake + | Pentominous + | ColorAkari + | PersistenceOfMemory + | ABCtje + | Kropki + | StatuePark + | PentominousBorders + | NanroSignpost + | TomTom + | Illumination + | Pentopia + | GreaterWall + | Galaxies + | Mines + | Tents + | PentominoSums + | CoralLITS + | CoralLITSO + | Snake + | CountryRoad + | KillerSudoku + | JapaneseSumsMasyu + | ArrowSudoku + | DualLoop + | Yajilin + deriving (Show, Eq) typeNames :: [(PuzzleType, String)] typeNames = - [ (LITS , "lits") - , (Geradeweg , "geradeweg") - , (Fillomino , "fillomino") - , (Masyu , "masyu") - , (Nurikabe , "nurikabe") - , (Sudoku , "sudoku") - , (ThermoSudoku , "thermosudoku") - , (Pyramid , "pyramid") - , (SlitherLink , "slitherlink") - , (SlitherLinkLiar , "slitherlinkliar") - , (WordSearch , "wordsearch") - , (CurveData , "curvedata") - , (DoubleBack , "doubleback") - , (Slalom , "slalom") - , (Compass , "compass") - , (MeanderingNumbers , "meanderingnumbers") - , (Tapa , "tapa") - , (JapaneseSums , "japanesesums") - , (Coral , "coral") - , (MaximalLengths , "maximallengths") - , (Labyrinth , "magiclabyrinth") - , (Bahnhof , "bahnhof") - , (BlackoutDominos , "blackout-dominos") - , (TwilightTapa , "twilight-tapa") - , (AngleLoop , "angleloop") - , (Shikaku , "shikaku") - , (SlovakSums , "slovaksums") - , (Anglers , "anglers") - , (Dominos , "dominos") - , (FillominoCheckered , "fillomino-checkered") - , (Cave , "cave") - , (Numberlink , "numberlink") - , (Skyscrapers , "skyscrapers") - , (SkyscrapersFrac , "skyscrapers-fractional") - , (SkyscrapersTightfit, "skyscrapers-tightfit") - , (TurningFences , "turning-fences") - , (Summon , "summon") - , (Baca , "baca") - , (Buchstabensalat , "buchstabensalat") - , (Doppelblock , "doppelblock") - , (Scrabble , "scrabble") - , (Neighbors , "neighbors") - , (Starbattle , "starbattle") - , (Heyawake , "heyawake") - , (Pentominous , "pentominous") - , (PersistenceOfMemory, "persistenceofmemory") - , (ABCtje , "abctje") - , (Kropki , "kropki") - , (StatuePark , "statuepark") - , (PentominousBorders , "pentominous-borders") - , (NanroSignpost , "nanro-signpost") - , (TomTom , "tomtom") - , (Illumination , "illumination") - , (Pentopia , "pentopia") - , (GreaterWall , "greaterwall") - , (Galaxies , "galaxies") - , (Mines , "mines") - , (Tents , "tents") - , (Snake , "snake") - , (CountryRoad , "country-road") - , (KillerSudoku , "killersudoku") - , (ArrowSudoku , "arrowsudoku") - , (Yajilin , "yajilin") + [ (LITS, "lits"), + (Geradeweg, "geradeweg"), + (Fillomino, "fillomino"), + (Masyu, "masyu"), + (Nurikabe, "nurikabe"), + (Sudoku, "sudoku"), + (ThermoSudoku, "thermosudoku"), + (Pyramid, "pyramid"), + (SlitherLink, "slitherlink"), + (SlitherLinkLiar, "slitherlinkliar"), + (WordSearch, "wordsearch"), + (CurveData, "curvedata"), + (DoubleBack, "doubleback"), + (Slalom, "slalom"), + (Compass, "compass"), + (MeanderingNumbers, "meanderingnumbers"), + (Tapa, "tapa"), + (JapaneseSums, "japanesesums"), + (Coral, "coral"), + (MaximalLengths, "maximallengths"), + (Labyrinth, "magiclabyrinth"), + (Bahnhof, "bahnhof"), + (BlackoutDominos, "blackout-dominos"), + (TwilightTapa, "twilight-tapa"), + (AngleLoop, "angleloop"), + (Shikaku, "shikaku"), + (SlovakSums, "slovaksums"), + (Anglers, "anglers"), + (Dominos, "dominos"), + (FillominoCheckered, "fillomino-checkered"), + (Cave, "cave"), + (Numberlink, "numberlink"), + (Skyscrapers, "skyscrapers"), + (SkyscrapersFrac, "skyscrapers-fractional"), + (SkyscrapersTightfit, "skyscrapers-tightfit"), + (TurningFences, "turning-fences"), + (Summon, "summon"), + (Baca, "baca"), + (Buchstabensalat, "buchstabensalat"), + (Doppelblock, "doppelblock"), + (Scrabble, "scrabble"), + (Neighbors, "neighbors"), + (Starbattle, "starbattle"), + (Heyawake, "heyawake"), + (Pentominous, "pentominous"), + (PersistenceOfMemory, "persistenceofmemory"), + (ABCtje, "abctje"), + (Kropki, "kropki"), + (StatuePark, "statuepark"), + (PentominousBorders, "pentominous-borders"), + (NanroSignpost, "nanro-signpost"), + (TomTom, "tomtom"), + (Illumination, "illumination"), + (Pentopia, "pentopia"), + (GreaterWall, "greaterwall"), + (Galaxies, "galaxies"), + (Mines, "mines"), + (Tents, "tents"), + (Snake, "snake"), + (CountryRoad, "country-road"), + (KillerSudoku, "killersudoku"), + (ArrowSudoku, "arrowsudoku"), + (Yajilin, "yajilin") ] obscureTypes :: [(PuzzleType, String)] obscureTypes = - [ (ColorAkari , "color-akari") - , (FillominoLoop , "fillomino-loop") - , (DominoPillen , "domino-pillen") - , (TapaCave , "tapa-cave") - , (WordLoop , "wordloop") - , (RowKropkiPyramid , "rowkropkipyramid") - , (LatinTapa , "latintapa") - , (SkyscrapersStars , "skyscrapers-doppelstern") - , (SudokuDoppelblock, "sudoku-doppelblock") - , (Loopki , "loopki") - , (PentominoSums , "pentomino-sums") - , (CoralLITS , "coral+lits") - , (CoralLITSO , "coral+litso") - , (JapaneseSumsMasyu, "japanesesums-masyu") - , (DualLoop , "dualloop") + [ (ColorAkari, "color-akari"), + (FillominoLoop, "fillomino-loop"), + (DominoPillen, "domino-pillen"), + (TapaCave, "tapa-cave"), + (WordLoop, "wordloop"), + (RowKropkiPyramid, "rowkropkipyramid"), + (LatinTapa, "latintapa"), + (SkyscrapersStars, "skyscrapers-doppelstern"), + (SudokuDoppelblock, "sudoku-doppelblock"), + (Loopki, "loopki"), + (PentominoSums, "pentomino-sums"), + (CoralLITS, "coral+lits"), + (CoralLITSO, "coral+litso"), + (JapaneseSumsMasyu, "japanesesums-masyu"), + (DualLoop, "dualloop") ] isGeneric :: PuzzleType -> Bool isGeneric t = case t of Yajilin -> True - _ -> False + _ -> False typeAliases :: [(PuzzleType, String)] typeAliases = [(LITS, "litsplus")] @@ -203,6 +204,6 @@ lookupType t = lookup t (map swap allTypeNames) checkType :: Maybe String -> Either String PuzzleType checkType mt = case mt of Nothing -> Left "no puzzle type given" - Just t -> case lookupType t of + Just t -> case lookupType t of Nothing -> Left $ "unknown puzzle type: " ++ t Just tt -> Right tt diff --git a/src/Data/Pyramid.hs b/src/Data/Pyramid.hs index 0aff41a..64dfca3 100644 --- a/src/Data/Pyramid.hs +++ b/src/Data/Pyramid.hs @@ -1,40 +1,42 @@ -- | Data types and parsing for pyramid puzzles. module Data.Pyramid - ( Row(..) - , Pyramid(..) - , PyramidSol(..) - , KropkiRow(..) - , RowKropkiPyramid(..) - , mergepyramidsol - , mergekpyramidsol - , plainpyramid - , psize + ( 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 - } +import Control.Applicative +import Control.Monad + ( liftM2, + mplus, + ) +import Data.Char (digitToInt) +import Data.Elements +import qualified Data.Text as T +import Data.Yaml hiding (Parser) +import qualified Data.Yaml as Yaml +import Text.ParserCombinators.Parsec hiding + ( (<|>), + many, + ) + +data Row + = R + { entries :: [Maybe Int], + shaded :: Bool + } newtype Pyramid = Pyr {unPyr :: [Row]} newtype PyramidSol = PyramidSol [[Int]] - deriving Show + deriving (Show) -- | The size (number of rows) of a pyramid. psize :: Pyramid -> Int @@ -44,15 +46,17 @@ psize (Pyr rows) = length rows 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 + | 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 + | 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 @@ -69,7 +73,7 @@ pshaded = (char 'G' >> return True) <|> (char 'W' >> return False) pclues :: GenParser Char st [Maybe Int] pclues = do - c <- pclue + c <- pclue cs <- many (spaces >> pclue) return (c : cs) @@ -80,25 +84,28 @@ 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 + show (R c True) = 'G' : showClues c + show (R c False) = 'W' : showClues c instance Show Pyramid where - show = unlines . map show . unPyr + show = unlines . map show . unPyr -data KropkiRow = KR { entriesk :: [Maybe Int] - , shadedk :: Bool - , dotsk :: [KropkiDot] - } - deriving Show +data KropkiRow + = KR + { entriesk :: [Maybe Int], + shadedk :: Bool, + dotsk :: [KropkiDot] + } + deriving (Show) newtype RowKropkiPyramid = KP {unKP :: [KropkiRow]} - deriving Show + deriving (Show) -- | Forget the kropki dots. plainpyramid :: RowKropkiPyramid -> Pyramid plainpyramid (KP rows) = Pyr (map r rows) - where r x = R (entriesk x) (shadedk x) + where + r x = R (entriesk x) (shadedk x) pkropkirow :: GenParser Char st KropkiRow pkropkirow = do @@ -109,7 +116,7 @@ pkropkirow = do pkropkiclues :: GenParser Char st ([KropkiDot], [Maybe Int]) pkropkiclues = do - c <- pclue + c <- pclue kcs <- many (liftM2 (,) pkropki pclue) let (ks, cs) = unzip kcs in return (ks, c : cs) @@ -121,18 +128,19 @@ pkropki = toParser :: GenParser a () b -> [a] -> Yaml.Parser b toParser p v = case parse p "(unknown)" v of - Left e -> fail (show e) + 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 + 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 + 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 + 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 index 0422f4e..bd67caf 100644 --- a/src/Data/Sudoku.hs +++ b/src/Data/Sudoku.hs @@ -1,17 +1,17 @@ module Data.Sudoku - ( sudokuborders - , sudokubordersg + ( sudokuborders, + sudokubordersg, ) where -import qualified Data.Map.Strict as Map - -import Data.Grid -import Data.GridShape +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map 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 + 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 @@ -20,17 +20,17 @@ mhalf x = if even x then Just (x `div` 2) else Nothing -- given size. sudokuborders :: Int -> [Edge N] sudokuborders s = case msqrt s of - Just r -> squareborders r + Just r -> squareborders r Nothing -> case mhalf s of - Just h -> rectborders h + 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] ] + 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. diff --git a/src/Data/Util.hs b/src/Data/Util.hs index 2731f47..2f14f26 100644 --- a/src/Data/Util.hs +++ b/src/Data/Util.hs @@ -1,31 +1,33 @@ module Data.Util - ( paths - , loops + ( paths, + loops, ) where -import Data.List ( partition ) -import Control.Monad ( guard ) +import Control.Monad (guard) +import Data.List (partition) paths :: Eq a => [(a, a)] -> Maybe [[a]] -paths [] = Just [] +paths [] = Just [] paths ((a, b) : segs) = do - (p , segs' ) <- collect b segs + (p, segs') <- collect b segs (p', segs'') <- collect a segs' - ps <- paths 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 + 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 + where + isLoop p = head p == last p diff --git a/src/Draw/CmdLine.hs b/src/Draw/CmdLine.hs index 9de9edf..dbc96ec 100644 --- a/src/Draw/CmdLine.hs +++ b/src/Draw/CmdLine.hs @@ -1,60 +1,64 @@ {-# LANGUAGE FlexibleContexts #-} module Draw.CmdLine - ( renderBytesRasterific - , renderBytesSVG - , backend - , BackendType(..) - , Format(..) - , lookupFormat - , extension - , formats + ( renderBytesRasterific, + renderBytesSVG, + backend, + BackendType (..), + Format (..), + lookupFormat, + extension, + formats, ) where -import Diagrams.Prelude hiding ( value - , option - , (<>) - , Result - ) - -import Data.ByteString.Lazy ( ByteString ) -import Graphics.Svg.Core ( renderBS ) -import qualified Data.Text as Text -import Codec.Picture ( pixelMap ) -import Codec.Picture.Types ( convertPixel - , dropTransparency - ) -import Codec.Picture.Png ( encodePng ) -import Codec.Picture.Jpg ( encodeJpeg ) - -import qualified Diagrams.Backend.Rasterific as Rasterific -import qualified Diagrams.Backend.SVG as SVG +import Codec.Picture (pixelMap) +import Codec.Picture.Jpg (encodeJpeg) +import Codec.Picture.Png (encodePng) +import Codec.Picture.Types + ( convertPixel, + dropTransparency, + ) +import Data.ByteString.Lazy (ByteString) +import qualified Data.Text as Text +import qualified Diagrams.Backend.Rasterific as Rasterific +import qualified Diagrams.Backend.SVG as SVG +import Diagrams.Prelude hiding + ( (<>), + Result, + option, + value, + ) +import Graphics.Svg.Core (renderBS) -renderBytesRasterific - :: Format -> SizeSpec V2 Double -> Diagram Rasterific.B -> ByteString +renderBytesRasterific :: + Format -> SizeSpec V2 Double -> Diagram Rasterific.B -> ByteString renderBytesRasterific fmt sz dia = case fmt of PDF -> Rasterific.renderPdfBS (round w) (round h) sz dia - PNG -> encodePng - $ renderDia Rasterific.Rasterific (Rasterific.RasterificOptions sz) dia - JPG -> encodeJpeg . pixelMap (convertPixel . dropTransparency) $ renderDia - Rasterific.Rasterific - (Rasterific.RasterificOptions sz) - dia + PNG -> + encodePng $ + renderDia Rasterific.Rasterific (Rasterific.RasterificOptions sz) dia + JPG -> + encodeJpeg . pixelMap (convertPixel . dropTransparency) $ + renderDia + Rasterific.Rasterific + (Rasterific.RasterificOptions sz) + dia _ -> error "unsupported format" - where - V2 w' h' = boxExtents (boundingBox dia) - aspectRatio = h' / w' - (w, h) = case getSpec sz of - V2 (Just ww) (Just hh) -> (ww, hh) - V2 (Just ww) Nothing -> (ww, aspectRatio * ww) - V2 Nothing (Just hh) -> (hh / aspectRatio, hh) - V2 Nothing Nothing -> (100, 100) + where + V2 w' h' = boxExtents (boundingBox dia) + aspectRatio = h' / w' + (w, h) = case getSpec sz of + V2 (Just ww) (Just hh) -> (ww, hh) + V2 (Just ww) Nothing -> (ww, aspectRatio * ww) + V2 Nothing (Just hh) -> (hh / aspectRatio, hh) + V2 Nothing Nothing -> (100, 100) renderBytesSVG :: Format -> SizeSpec V2 Double -> Diagram SVG.B -> ByteString renderBytesSVG fmt sz = case fmt of - SVG -> renderBS - . renderDia SVG.SVG (SVG.SVGOptions sz Nothing (Text.pack "") [] True) + SVG -> + renderBS + . renderDia SVG.SVG (SVG.SVGOptions sz Nothing (Text.pack "") [] True) _ -> error "unsupported format" data Format = PNG | PDF | SVG | JPG @@ -74,7 +78,7 @@ lookupFormat f = case f of "pdf" -> Just PDF "svg" -> Just SVG "jpg" -> Just JPG - _ -> Nothing + _ -> Nothing extension :: Format -> String extension f = case f of diff --git a/src/Draw/Code.hs b/src/Draw/Code.hs index e7d4931..379c8ed 100644 --- a/src/Draw/Code.hs +++ b/src/Draw/Code.hs @@ -3,66 +3,69 @@ {-# LANGUAGE TypeFamilies #-} module Draw.Code - ( code - , arrowRight - , arrowRightL - , arrowDown - , arrowDownL + ( code, + arrowRight, + arrowRightL, + arrowDown, + arrowDownL, ) where -import Data.Code -import Data.Component -import Data.GridShape -import Data.Grid -import Draw.Draw -import Draw.Lib -import Draw.Grid -import Draw.Elements - -import Diagrams.Prelude hiding ( place - , parts - , matching - ) - -import qualified Data.Map.Strict as Map +import Data.Code +import Data.Component +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map +import Diagrams.Prelude hiding + ( matching, + parts, + place, + ) +import Draw.Draw +import Draw.Elements +import Draw.Grid +import Draw.Lib code :: Backend' b => Code -> [TaggedComponent (Drawing b)] code cs = concat [collect Atop, collect West, collect North] - where - parts = map codePart cs - collect p = - let matching = map snd . filter ((==) p . fst) $ parts - in if null matching then [] else [comp p $ mconcat matching] - fakeSize = (0, 0) -- should be the dimensions of the code part - comp p d = - TaggedComponent (Just Code) $ PlacedComponent p $ RawComponent fakeSize $ d + where + parts = map codePart cs + collect p = + let matching = map snd . filter ((==) p . fst) $ parts + in if null matching then [] else [comp p $ mconcat matching] + fakeSize = (0, 0) -- should be the dimensions of the code part + comp p d = + TaggedComponent (Just Code) $ PlacedComponent p $ RawComponent fakeSize $ d codePart :: Backend' b => CodePart -> (Placement, Drawing b) codePart cp = case cp of Rows' rs -> (West, placeGrid g # centerX') - where g = Map.fromList [ (C 1 r, arrowRight) | r <- rs ] + where + g = Map.fromList [(C 1 r, arrowRight) | r <- rs] Cols cs -> (North, placeGrid g # centerY') - where g = Map.fromList [ (C c 0, arrowDown) | c <- cs ] + where + g = Map.fromList [(C c 0, arrowDown) | c <- cs] RowsN' rs -> (West, placeGrid g # centerX') - where g = Map.fromList [ (N 0 r, arrowRight) | r <- rs ] + where + g = Map.fromList [(N 0 r, arrowRight) | r <- rs] ColsN cs -> (North, placeGrid g # centerY') - where g = Map.fromList [ (N c 0, arrowDown) | c <- cs ] + where + g = Map.fromList [(N c 0, arrowDown) | c <- cs] LabelsN g -> (Atop, placeGrid . fmap label . clues $ g) - where - label c = char c # scale 0.5 # fc gray # translate (r2 (1 / 3, -1 / 3)) + where + label c = char c # scale 0.5 # fc gray # translate (r2 (1 / 3, -1 / 3)) LRows' rs -> (West, placeGrid g # centerX') - where - g = Map.fromList [ (C 0 r, arrowRightL [l]) | (l, r) <- Map.toList rs ] + where + g = Map.fromList [(C 0 r, arrowRightL [l]) | (l, r) <- Map.toList rs] LCols cs -> (North, placeGrid g # centerY') - where - g = Map.fromList [ (C c 0, arrowDownL [l]) | (l, c) <- Map.toList cs ] + where + g = Map.fromList [(C c 0, arrowDownL [l]) | (l, c) <- Map.toList cs] LRowsN' rs -> (West, placeGrid g # centerX') - where - g = Map.fromList [ (N 0 r, arrowRightL [l]) | (l, r) <- Map.toList rs ] + where + g = Map.fromList [(N 0 r, arrowRightL [l]) | (l, r) <- Map.toList rs] LColsN cs -> (North, placeGrid g # centerY') - where - g = Map.fromList [ (N c 0, arrowDownL [l]) | (l, c) <- Map.toList cs ] + where + g = Map.fromList [(N c 0, arrowDownL [l]) | (l, c) <- Map.toList cs] arrowDown :: Backend' b => Drawing b arrowDown = draw $ triangle 0.5 # lwG 0 # fc black # rotateBy (1 / 2) @@ -76,8 +79,8 @@ arrowRight = arrowDown # rotateBy (1 / 4) arrowRightL :: Backend' b => String -> Drawing b arrowRightL c = text' c - # fc white - # scale 0.5 - # translate (r2 (-0.05, 0)) + # fc white + # scale 0.5 + # translate (r2 (-0.05, 0)) <> arrowRight - # scale 1.2 + # scale 1.2 diff --git a/src/Draw/Component.hs b/src/Draw/Component.hs index 1984346..7848804 100644 --- a/src/Draw/Component.hs +++ b/src/Draw/Component.hs @@ -1,109 +1,108 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -module Draw.Component where - -import qualified Data.Map.Strict as Map +{-# LANGUAGE TypeFamilies #-} -import Diagrams.Prelude hiding ( dot - , place - , star - ) +module Draw.Component where -import Data.Component -import Data.Elements hiding ( Tent - , Tree - , Black - , Star - ) +import Data.Component +import Data.Elements hiding + ( Black, + Star, + Tent, + Tree, + ) import qualified Data.Elements -import Data.Grid -import Data.GridShape -import Draw.Lib -import Draw.Draw -import Draw.Grid -import Draw.Style -import Draw.Elements -import Draw.Code +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map +import Diagrams.Prelude hiding + ( dot, + place, + star, + ) +import Draw.Code +import Draw.Draw +import Draw.Elements +import Draw.Grid +import Draw.Lib +import Draw.Style components :: Backend' b => [PlacedComponent (Drawing b)] -> Drawing b components cs = snd $ go $ reverse cs - where - go [] = ((0 :: Int, 0 :: Int), mempty) - go ((PlacedComponent p c) : pcs) - = let - (tl , dc ) = component c - (tls, dcs) = go pcs - ntl = (max (fst tl) (fst tls), max (snd tl) (snd tls)) - in - case p of - Atop -> (ntl, dc <> dcs) - West -> (ntl, dcs |!| strutX' 0.5 |!| dc) - North -> (ntl, dcs =!= strutY' 0.5 =!= dc) - TopRight -> - ( ntl - , (dc # alignBL' # translatep tls # translate (r2 (0.6, 0.6))) - <> dcs - ) - (=!=) = beside unitY - (|!|) = beside (negated unitX) + where + go [] = ((0 :: Int, 0 :: Int), mempty) + go ((PlacedComponent p c) : pcs) = + let (tl, dc) = component c + (tls, dcs) = go pcs + ntl = (max (fst tl) (fst tls), max (snd tl) (snd tls)) + in case p of + Atop -> (ntl, dc <> dcs) + West -> (ntl, dcs |!| strutX' 0.5 |!| dc) + North -> (ntl, dcs =!= strutY' 0.5 =!= dc) + TopRight -> + ( ntl, + (dc # alignBL' # translatep tls # translate (r2 (0.6, 0.6))) + <> dcs + ) + (=!=) = beside unitY + (|!|) = beside (negated unitX) component :: Backend' b => Component (Drawing b) -> (Size, Drawing b) component c = case c of RawComponent sz x -> (sz, x) - Grid s g -> (cellSize g, grid (gridStyle s) g) - Regions g -> (cellSize g, areas g) - CellGrid g -> (cellSize g, placeGrid . fmap decoration $ g) - NodeGrid g -> (nodeSize g, placeGrid . fmap decoration $ g) + Grid s g -> (cellSize g, grid (gridStyle s) g) + Regions g -> (cellSize g, areas g) + CellGrid g -> (cellSize g, placeGrid . fmap decoration $ g) + NodeGrid g -> (nodeSize g, placeGrid . fmap decoration $ g) EdgeGrid g -> (edgeSize g, placeGrid' . Map.mapKeys midPoint . fmap decoration $ g) FullGrid ns cs es -> - ( nodeSize ns - , mconcat . map (snd . component) $ [NodeGrid ns, CellGrid cs, EdgeGrid es] + ( nodeSize ns, + mconcat . map (snd . component) $ [NodeGrid ns, CellGrid cs, EdgeGrid es] ) - Note ds -> ((0, 0), note $ hcatSep 0.2 $ map decoration $ ds) - Pyramid g -> (shiftSize g, shiftGrid g) - CellPyramid g -> (shiftSize g, placeGrid . fmap decoration $ g) - where - gridStyle s = case s of - GridDefault -> gDefault - GridDefaultIrregular -> gDefaultIrreg - GridDashed -> gDashed - GridDots -> gSlither - GridPlain -> gPlain - GridPlainDashed -> gPlainDashed + Note ds -> ((0, 0), note $ hcatSep 0.2 $ map decoration $ ds) + Pyramid g -> (shiftSize g, shiftGrid g) + CellPyramid g -> (shiftSize g, placeGrid . fmap decoration $ g) + where + gridStyle s = case s of + GridDefault -> gDefault + GridDefaultIrregular -> gDefaultIrreg + GridDashed -> gDashed + GridDots -> gSlither + GridPlain -> gPlain + GridPlainDashed -> gPlainDashed decoration :: Backend' b => Decoration -> Drawing b decoration d = case d of - Blank -> mempty - Letter c -> char c - Letters s -> text' s - InvertedLetters s -> invert $ text' s - DecKropkiDot k -> kropkiDot k - AfternoonSouth -> afternoonSouth - AfternoonWest -> afternoonWest - LightDiagonal diag -> lc (blend 0.5 gray white) $ primeDiag diag - DarkDiagonal diag -> lc gray $ primeDiag diag - SmallDot -> dot - Dot -> scale 0.5 $ smallPearl MBlack - Star -> star Data.Elements.Star - Shade -> fillBG gray - DarkShade -> fillBG (blend 0.5 gray black) - Black -> fillBG black - LightShade -> fillBG (blend 0.5 gray white) - SmallPearl p -> smallPearl p - Pearl p -> pearl p - Edge dir -> edgeDecoration dir - ThinEdge dir -> edgeDecorationThin dir - SolEdge dir -> edgeDecorationSol dir - TriangleRight -> arrowRight - TriangleDown -> arrowDown - LabeledTriangleRight w -> arrowRightL w - LabeledTriangleDown w -> arrowDownL w - MiniLoop -> miniloop - ShipSquare -> shipSquare - Ship dir -> shipEnd dir - LabeledArrow dir w -> labeledArrow dir $ text' w + Blank -> mempty + Letter c -> char c + Letters s -> text' s + InvertedLetters s -> invert $ text' s + DecKropkiDot k -> kropkiDot k + AfternoonSouth -> afternoonSouth + AfternoonWest -> afternoonWest + LightDiagonal diag -> lc (blend 0.5 gray white) $ primeDiag diag + DarkDiagonal diag -> lc gray $ primeDiag diag + SmallDot -> dot + Dot -> scale 0.5 $ smallPearl MBlack + Star -> star Data.Elements.Star + Shade -> fillBG gray + DarkShade -> fillBG (blend 0.5 gray black) + Black -> fillBG black + LightShade -> fillBG (blend 0.5 gray white) + SmallPearl p -> smallPearl p + Pearl p -> pearl p + Edge dir -> edgeDecoration dir + ThinEdge dir -> edgeDecorationThin dir + SolEdge dir -> edgeDecorationSol dir + TriangleRight -> arrowRight + TriangleDown -> arrowDown + LabeledTriangleRight w -> arrowRightL w + LabeledTriangleDown w -> arrowDownL w + MiniLoop -> miniloop + ShipSquare -> shipSquare + Ship dir -> shipEnd dir + LabeledArrow dir w -> labeledArrow dir $ text' w InvertedLabeledArrow dir w -> invert $ labeledArrow dir $ text' w - Tent -> draw tentDia - Tree -> tree Data.Elements.Tree - Myopia dirs -> myopia dirs + Tent -> draw tentDia + Tree -> tree Data.Elements.Tree + Myopia dirs -> myopia dirs diff --git a/src/Draw/Draw.hs b/src/Draw/Draw.hs index 8529358..77be695 100644 --- a/src/Draw/Draw.hs +++ b/src/Draw/Draw.hs @@ -1,74 +1,76 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Draw.Draw - ( Device(..) - , Config(..) - , Drawers(..) - , QDrawing(..) - , Drawing - , draw - , diagram - , withConfig - , Unit(..) - , DiagramSize - , diagramSize - , toOutputWidth - , centerX' - , centerY' - , centerXY' - , smash' - , alignBL' - , alignBR' - , alignTL' - , alignTR' - , alignL' - , alignR' - , fit' - , fitDown' - , spread' - , phantom'' - , aboveT' - , besidesR' - , strutX' - , strutY' - , text' - , textFixed - , alignPixel - , border + ( Device (..), + Config (..), + Drawers (..), + QDrawing (..), + Drawing, + draw, + diagram, + withConfig, + Unit (..), + DiagramSize, + diagramSize, + toOutputWidth, + centerX', + centerY', + centerXY', + smash', + alignBL', + alignBR', + alignTL', + alignTR', + alignL', + alignR', + fit', + fitDown', + spread', + phantom'', + aboveT', + besidesR', + strutX', + strutY', + text', + textFixed, + alignPixel, + border, ) where -import Diagrams.Prelude hiding ( parts - , render - ) - -import Draw.Font -import Draw.Lib -import Draw.Widths +import Diagrams.Prelude hiding + ( parts, + render, + ) +import Draw.Font +import Draw.Lib +import Draw.Widths data Device = Screen | Print -data Config = Config - { _cfgDevice :: Device - , _cfgFontVar :: Font - , _cfgFontFixed :: Font - } +data Config + = Config + { _cfgDevice :: Device, + _cfgFontVar :: Font, + _cfgFontFixed :: Font + } -newtype QDrawing b v n m = Drawing { fromDrawing :: Config -> QDiagram b v n m } - deriving (Monoid, Semigroup, HasStyle, Juxtaposable) +newtype QDrawing b v n m = Drawing {fromDrawing :: Config -> QDiagram b v n m} + deriving (Monoid, Semigroup, HasStyle, Juxtaposable) type instance V (QDrawing b v n m) = v + type instance N (QDrawing b v n m) = n instance (Metric v, OrderedField n, Semigroup m) => HasOrigin (QDrawing b v n m) where - moveOriginTo p (Drawing f) = Drawing (moveOriginTo p . f) + moveOriginTo p (Drawing f) = Drawing (moveOriginTo p . f) instance (Metric v, OrderedField n, Semigroup m) => Transformable (QDrawing b v n m) where - transform t (Drawing f) = Drawing (transform t . f) + transform t (Drawing f) = Drawing (transform t . f) draw :: QDiagram b v n m -> QDrawing b v n m draw = Drawing . const @@ -81,11 +83,11 @@ withConfig f = Drawing $ \cfg -> diagram cfg (f cfg) type Drawing b = QDrawing b (V b) (N b) Any -data Drawers b p s = - Drawers - { puzzle :: p -> Drawing b - , solution :: (p, s) -> Drawing b - } +data Drawers b p s + = Drawers + { puzzle :: p -> Drawing b, + solution :: (p, s) -> Drawing b + } data Unit = Pixels | Points @@ -101,27 +103,27 @@ 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 + 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 + 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 *^ unitX) . extrudeEnvelope (w *^ unitY) - . extrudeEnvelope (-w *^ unitY) + . extrudeEnvelope (- w *^ unitY) centerX' :: Backend' b => Drawing b -> Drawing b centerX' = lift centerX @@ -180,11 +182,11 @@ strutY' = draw . strutY lift :: (Diagram b -> Diagram b) -> Drawing b -> Drawing b lift f d = Drawing (\c -> f (fromDrawing d c)) -lift2 - :: (Diagram b -> Diagram b -> Diagram b) - -> Drawing b - -> Drawing b - -> Drawing b +lift2 :: + (Diagram b -> Diagram b -> Diagram b) -> + Drawing b -> + Drawing b -> + Drawing b lift2 f d1 d2 = Drawing (\c -> f (fromDrawing d1 c) (fromDrawing d2 c)) text' :: Renderable (Path V2 Double) b => String -> QDrawing b V2 Double Any diff --git a/src/Draw/Elements.hs b/src/Draw/Elements.hs index f83c1c7..6fd81e1 100644 --- a/src/Draw/Elements.hs +++ b/src/Draw/Elements.hs @@ -1,43 +1,40 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# 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 - , arrow - , gap - , star - ) -import qualified Diagrams.Prelude as D -import Diagrams.TwoD.Offset - -import qualified Data.Map.Strict as Map -import Data.List ( sortOn ) - -import Data.Lib ( invertMap ) -import Data.Grid -import Data.Elements hiding ( Loop ) -import Data.GridShape hiding ( edge ) - -import Draw.Lib -import Draw.Draw -import Draw.Style -import Draw.Widths -import Draw.GridShape -import Draw.Grid +import Data.Elements hiding (Loop) +import Data.Grid +import Data.GridShape hiding (edge) +import Data.Lib (invertMap) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Diagrams.Prelude hiding + ( N, + arrow, + gap, + star, + ) +import qualified Diagrams.Prelude as D +import Diagrams.TwoD.Offset +import Draw.Draw +import Draw.Grid +import Draw.GridShape +import Draw.Lib +import Draw.Style +import Draw.Widths pearl :: Backend' b => MasyuPearl -> Drawing b pearl m = draw $ circle 0.35 # lwG 0.05 # fc (c m) - where - c MWhite = white - c MBlack = black + where + c MWhite = white + c MBlack = black smallPearl :: Backend' b => MasyuPearl -> Drawing b smallPearl = scale 0.4 . pearl @@ -53,13 +50,13 @@ shipSquare = draw $ square 0.7 # lwG 0.05 # fc black shipEnd :: Backend' b => Dir' -> Drawing b shipEnd dir = e # rotateTo d - where - e = pearl MBlack <> (shipSquare # scaleX 0.5 # alignL') - d = direction $ case dir of - R -> unitX - L -> -unitX - U -> unitY - D -> -unitY + where + e = pearl MBlack <> (shipSquare # scaleX 0.5 # alignL') + d = direction $ case dir of + R -> unitX + L -> - unitX + U -> unitY + D -> - unitY -- | The up-right diagonal of a centered unit square. ur :: Path V2 Double @@ -75,34 +72,35 @@ crossPath = ur <> dr -- | Draw a cross. cross :: Backend' b => Bool -> Drawing b -cross True = draw $ stroke crossPath # scale 0.8 # lwG edgewidth +cross True = draw $ stroke crossPath # scale 0.8 # lwG edgewidth cross False = mempty -- | Draw a Compass clue. compassClue :: Backend' b => CompassC -> Drawing b compassClue (CC n e s w) = texts <> (draw $ stroke crossPath # 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 + 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 slovakClue :: Backend' b => SlovakClue -> Drawing b -slovakClue (SlovakClue s c) = centerY' (int s === draw (strutY 0.1) === dots c) - <> fillBG gray - where - dots n = draw $ centerX $ hcat' with { _sep = 0.04 } (replicate n $ d) - d = circle 0.1 # lwG 0.02 # fc white +slovakClue (SlovakClue s c) = + centerY' (int s === draw (strutY 0.1) === dots c) + <> fillBG gray + where + dots n = draw $ 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] -> Drawing b thermo vs@(v : _) = (bulb `atop` line) # col # draw - 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 + 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 @@ -112,18 +110,19 @@ thermos = mconcat . map (thermo . map toPoint) arrowTip :: Path V2 Double arrowTip = - p2 (0, 0) ~~ p2 (1, 0) <> p2 (-1 / 2, 1) ~~ p2 (1, 0) <> p2 (-1 / 2, -1) ~~ p2 - (1, 0) + p2 (0, 0) ~~ p2 (1, 0) <> p2 (-1 / 2, 1) ~~ p2 (1, 0) <> p2 (-1 / 2, -1) + ~~ p2 + (1, 0) arrow :: Backend' b => [P2 Double] -> Drawing b arrow vs = if length vs < 2 then mempty else draw arr - where - arr = c <> strokeLocLine (fromVertices vs) <> stroke tip - (s : _) = vs - (e : f : _) = reverse vs - c = circle 0.4 # fc white # moveTo s - dir = direction $ e .-. f - tip = rotateTo dir arrowTip # scale 0.2 # moveTo e + where + arr = c <> strokeLocLine (fromVertices vs) <> stroke tip + (s : _) = vs + (e : f : _) = reverse vs + c = circle 0.4 # fc white # moveTo s + dir = direction $ e .-. f + tip = rotateTo dir arrowTip # scale 0.2 # moveTo e -- | Draw a list of arrows, given as lists of @(Int, Int)@ cell -- coordinates. @@ -136,34 +135,34 @@ tight :: Backend' b => (a -> Drawing b) -> Tightfit a -> Drawing b tight d (Single x) = d x tight d (UR x y) = stroke ur - # lwG onepix - # draw + # lwG onepix + # draw <> d x - # scale s - # translate (r2 (-t, t)) + # scale s + # translate (r2 (- t, t)) <> d y - # scale s - # translate (r2 (t, -t)) - where - t = 1 / 5 - s = 2 / 3 + # scale s + # translate (r2 (t, - t)) + where + t = 1 / 5 + s = 2 / 3 tight d (DR x y) = stroke dr - # lwG onepix - # draw + # lwG onepix + # draw <> d x - # scale s - # translate (r2 (-t, -t)) + # scale s + # translate (r2 (- t, - t)) <> d y - # scale s - # translate (r2 (t, t)) - where - t = 1 / 5 - s = 2 / 3 + # scale s + # translate (r2 (t, t)) + where + t = 1 / 5 + s = 2 / 3 -- | Stack the given words, left-justified. stackWords :: Backend' b => [String] -> Drawing b -stackWords = vcat' with { _sep = 0.1 } . scale 0.8 . map (alignL' . textFixed) +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] -> Drawing b @@ -177,11 +176,14 @@ stackWordsRight = -- | Mark a word in a grid of letters. markedWord :: Backend' b => MarkedWord -> Drawing b -markedWord (MW s e) = draw $ lwG onepix . stroke $ expandTrail' - with { _expandCap = LineCapRound } - 0.4 - t - where t = fromVertices [p2i s, p2i e] # translate (r2 (1 / 2, 1 / 2)) +markedWord (MW s e) = + draw $ 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. markedWords :: Backend' b => [MarkedWord] -> Drawing b @@ -194,9 +196,9 @@ slalomClue x = slalomDiag :: Backend' b => SlalomDiag -> Drawing b slalomDiag d = draw $ stroke (v d) # lwG edgewidth - where - v SlalomForward = ur - v SlalomBackward = dr + where + v SlalomForward = ur + v SlalomBackward = dr -- | Draw an @Int@. int :: Backend' b => Int -> Drawing b @@ -232,13 +234,13 @@ curve = draw . lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) -- | Draw a shadow in the style of Afternoon Skyscrapers. afternoonSouth :: Backend' b => Drawing b afternoonSouth = south - where - shape = - translate (r2 (-1 / 2, 0)) - . fromVertices - . map p2 - $ [(0, 0), (1 / 4, 1 / 4), (1, 1 / 4), (1, 0), (0, 0)] - south = draw $ strokeLocLoop shape # lwG 0 # fc gray + where + shape = + translate (r2 (-1 / 2, 0)) + . fromVertices + . map p2 + $ [(0, 0), (1 / 4, 1 / 4), (1, 1 / 4), (1, 0), (0, 0)] + south = draw $ strokeLocLoop shape # lwG 0 # fc gray afternoonWest :: Backend' b => Drawing b afternoonWest = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) afternoonSouth @@ -247,23 +249,23 @@ afternoonWest = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) afternoonSouth -- left to right, top to bottom. tapaClue :: Backend' b => TapaClue -> Drawing b tapaClue (TapaClue [x]) = int x -tapaClue (TapaClue xs ) = fit' 0.8 . atPoints (p (length xs)) . map int $ 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" +tapaClue (TapaClue xs) = fit' 0.8 . atPoints (p (length xs)) . map int $ 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" primeDiag :: Backend' b => PrimeDiag -> Drawing b primeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # draw - where - p = case d of - (False, False) -> mempty - (True , False) -> ur - (False, True ) -> dr - (True , True ) -> ur <> dr + where + p = case d of + (False, False) -> mempty + (True, False) -> ur + (False, True) -> dr + (True, True) -> ur <> dr anglePoly :: Backend' b => Int -> Drawing b anglePoly 3 = draw $ strokePath (triangle 0.3) # fc black @@ -273,9 +275,9 @@ anglePoly _ = error "expected 3..5" fishTrail :: Double -> Angle Double -> Trail' Loop V2 Double fishTrail off startAngle = closeLine $ half <> half # reverseLine # reflectY - where - half = arc (angleDir startAngle) endAngle # translateY (-off) - endAngle = ((180 @@ deg) ^-^ acosA off ^-^ startAngle) + where + half = arc (angleDir startAngle) endAngle # translateY (- off) + endAngle = ((180 @@ deg) ^-^ acosA off ^-^ startAngle) fish :: Backend' b => Fish -> Drawing b fish Fish = @@ -285,51 +287,58 @@ star :: Backend' b => Star -> Drawing b star Star = draw $ fc black . stroke . D.star (StarSkip 2) $ pentagon 0.3 tree :: Backend' b => Tree -> Drawing b -tree Tree = draw $ 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)) - ] +tree Tree = + draw $ 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)) + ] tent :: Backend' b => PlacedTent -> Drawing b tent (Tent d) = draw $ tentDia <> lwG linewidth (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) - ) + 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) + ) tentDia :: Backend' b => Diagram b -tentDia = 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) +tentDia = + 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 ] - # fc black - , shape - [ (0 , 8) - , (1 / 2, 8 + 1) - , (1 , 8 + 1 - 1 / 4) - , (0 , 8 + 1 - 1 / 4 - 2) - , (0 , 8) - ] - # fc black - ] - where shape = strokeLocLoop . fromVertices . map p2 + where + shape = strokeLocLoop . fromVertices . map p2 vertexLoop :: VertexLoop -> Located (Trail' Loop V2 Double) vertexLoop = mapLoc closeLine . fromVertices . map toPoint @@ -352,9 +361,9 @@ placeNoteBR (x, _) d = miniloop :: Backend' b => Drawing b miniloop = (thinEdges (map unorient out) <> grid gSlither g) # centerXY' # scale 0.4 - where - g = sizeGrid (1, 1) - (out, _) = edgesM g + where + g = sizeGrid (1, 1) + (out, _) = edgesM g dominoBG :: Colour Double dominoBG = blend 0.3 black white @@ -362,19 +371,22 @@ dominoBG = blend 0.3 black white domino :: Backend' b => (Int, Int) -> Drawing b domino (x, y) = (int x # smash' ||| strutX 0.65 # draw ||| int y # smash') - # centerXY' - # scale 0.6 + # centerXY' + # scale 0.6 <> strokePath (rect 0.8 0.5) - # lwG 0 - # fc dominoBG - # draw + # lwG 0 + # fc dominoBG + # draw 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)) + toPoint (DominoC (C x y)) = + p2 + ( (1.0 * fromIntegral x), + (0.7 * fromIntegral y) + ) dominos :: Backend' b => DigitRange -> Drawing b dominos = @@ -383,26 +395,28 @@ dominos = pill :: Backend' b => Int -> Drawing b pill x = int x - # scale 0.6 + # scale 0.6 <> strokePath (roundedRect 0.8 0.5 0.2) - # lwG 0 - # fc dominoBG - # draw + # lwG 0 + # fc dominoBG + # draw pills :: Backend' b => DigitRange -> Drawing b pills (DigitRange a b) = centerXY' . onGrid 1.0 0.7 pill $ 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] + 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) -> Drawing b -polyominoGrid = placeGrid . fmap (scale 0.8) . fmap - (\x -> case x of - Nothing -> fillBG black - Just c -> (text' [c] # fc white # lc white) <> fillBG black - ) +polyominoGrid = + placeGrid . fmap (scale 0.8) + . fmap + ( \x -> case x of + Nothing -> fillBG black + Just c -> (text' [c] # fc white # lc white) <> fillBG black + ) pentominos :: Backend' b => Drawing b pentominos = centerXY' . scale 0.5 . polyominoGrid $ pentominoGrid @@ -421,103 +435,105 @@ bahnhofClue = either int crossing kropkiDot :: Backend' b => KropkiDot -> Drawing b kropkiDot KNone = mempty -kropkiDot c = draw $ 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" +kropkiDot c = draw $ 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" fraction :: Backend' b => Fraction -> Drawing b fraction f = centerX' $ case f of - FInt a -> text' a # scale 0.8 - FFrac a b -> frac a b + FInt a -> text' a # scale 0.8 + FFrac a b -> frac a b FComp a b c -> (text' a # scale 0.8) ||| draw (strutX (1 / 10)) ||| frac b c - where - frac b c = - (draw $ stroke slash # scale (1 / 4) # lwG onepix) - <> text' b - # scale s - # translate (r2 (-t, t)) - <> text' 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)] + where + frac b c = + (draw $ stroke slash # scale (1 / 4) # lwG onepix) + <> text' b + # scale s + # translate (r2 (- t, t)) + <> text' 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)] myopia :: Backend' b => Myopia -> Drawing b myopia = foldMap d' - where - d' = draw . 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 & headLength .~ global 0.2) - (p2 p) - (p2 q) + where + d' = draw . 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 & headLength .~ global 0.2) + (p2 p) + (p2 q) greaterClue :: Backend' b => GreaterClue -> [Drawing b] -greaterClue [] = mempty +greaterClue [] = mempty greaterClue (_ : rs) = g rs - where - g [] = [placeholder] - g (r : rs') = placeholder : drawRel r : g rs' - drawRel RUndetermined = mempty - drawRel RLess = text' "<" - drawRel RGreater = text' ">" - drawRel REqual = text' "=" - placeholder = draw $ circle 0.35 # lwG onepix # dashingG [0.05, 0.05] 0 - -cages - :: (Backend' b, Eq a, Ord a) => Grid C a -> Map.Map a (Drawing b) -> Drawing b + where + g [] = [placeholder] + g (r : rs') = placeholder : drawRel r : g rs' + drawRel RUndetermined = mempty + drawRel RLess = text' "<" + drawRel RGreater = text' ">" + drawRel REqual = text' "=" + placeholder = draw $ circle 0.35 # lwG onepix # dashingG [0.05, 0.05] 0 + +cages :: + (Backend' b, Eq a, Ord a) => Grid C a -> Map.Map a (Drawing b) -> Drawing b cages g m = hints <> (mconcat . map cage . Map.elems) byChar - where - hints = - placeGrid - . fmap framedClue - . clues - . fmap (flip Map.lookup m . head) - . invertMap - . fmap tl - $ byChar - tl = head . sortOn (\(C x y) -> (-y, x)) - byChar = invertMap g - framedClue d = Drawing (\cfg -> framed d cfg) - framed :: Backend' b => Drawing b -> Config -> Diagram b - framed d cfg = (alignTL d' # moveTo corner) <> bgwhite - where - corner = p2 (-0.5 + cageOffset params, 0.5 - cageOffset params) - d' = scale 0.4 (fromDrawing d cfg) - w, h :: Double - (w, h) = diagramSize (scale 1.05 d') - params = cageParams cfg - dashStep = cageDashOn params + cageDashOff params - quant x = q (dashStep / 2) (dashStep / 2) x - where - q o s x' = o + s * (fromIntegral $ (floor ((x' - o) / s + 1) :: Int)) - bgwhite = - rect (quant w + onepix) (quant h + onepix) - # lwG 0 - # fc white - # alignTL - # moveTo (corner .+^ r2 (-onepix, onepix)) + where + hints = + placeGrid + . fmap framedClue + . clues + . fmap (flip Map.lookup m . head) + . invertMap + . fmap tl + $ byChar + tl = head . sortOn (\(C x y) -> (- y, x)) + byChar = invertMap g + framedClue d = Drawing (\cfg -> framed d cfg) + framed :: Backend' b => Drawing b -> Config -> Diagram b + framed d cfg = (alignTL d' # moveTo corner) <> bgwhite + where + corner = p2 (-0.5 + cageOffset params, 0.5 - cageOffset params) + d' = scale 0.4 (fromDrawing d cfg) + w , h :: Double + (w, h) = diagramSize (scale 1.05 d') + params = cageParams cfg + dashStep = cageDashOn params + cageDashOff params + quant x = q (dashStep / 2) (dashStep / 2) x + where + q o s x' = o + s * (fromIntegral $ (floor ((x' - o) / s + 1) :: Int)) + bgwhite = + rect (quant w + onepix) (quant h + onepix) + # lwG 0 + # fc white + # alignTL + # moveTo (corner .+^ r2 (- onepix, onepix)) labeledArrow :: Backend' b => Dir' -> Drawing b -> Drawing b labeledArrow dir x = case dir of U -> (x ||| strutX' gap ||| arr unitY) # centerX' - D -> (x ||| strutX' gap ||| arr (-unitY)) # centerX' + D -> (x ||| strutX' gap ||| arr (- unitY)) # centerX' R -> (x === strutY' gap === arr unitX) # centerY' - L -> (x === strutY' gap === arr (-unitX)) # centerY' - where - gap = 0.2 - arr v = - D.arrowV' (with & arrowHead .~ tri & headLength .~ global 0.2) v - # center - # scale 0.5 - # draw + L -> (x === strutY' gap === arr (- unitX)) # centerY' + where + gap = 0.2 + arr v = + D.arrowV' (with & arrowHead .~ tri & headLength .~ global 0.2) v + # center + # scale 0.5 + # draw invert :: Backend' b => Drawing b -> Drawing b invert d = d # lc white # fc white diff --git a/src/Draw/Font.hs b/src/Draw/Font.hs index c57306b..4a79f6d 100644 --- a/src/Draw/Font.hs +++ b/src/Draw/Font.hs @@ -1,18 +1,19 @@ {-# LANGUAGE TemplateHaskell #-} module Draw.Font - ( fontAnelizaRegular - , fontBit - , Font + ( fontAnelizaRegular, + fontBit, + Font, ) where -import Graphics.SVGFonts.ReadFont ( PreparedFont - , loadFont' - ) -import Data.FileEmbed -import Data.Text.Encoding ( decodeUtf8 ) -import qualified Data.Text as Text +import Data.FileEmbed +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Graphics.SVGFonts.ReadFont + ( PreparedFont, + loadFont', + ) type Font = PreparedFont Double diff --git a/src/Draw/Generic.hs b/src/Draw/Generic.hs index 52cfeb6..921f21f 100644 --- a/src/Draw/Generic.hs +++ b/src/Draw/Generic.hs @@ -1,66 +1,65 @@ module Draw.Generic - ( generic + ( generic, ) where -import qualified Data.Map.Strict as Map -import Data.Yaml -import Data.Maybe ( catMaybes ) - -import Data.Component -import Data.Grid -import Data.GridShape -import Data.PuzzleTypes -import qualified Parse.PuzzleTypes as Parse +import Data.Component +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.PuzzleTypes +import Data.Yaml +import qualified Parse.PuzzleTypes as Parse generic :: PuzzleType -> (Value, Maybe Value) -> Parser [TaggedComponent a] generic t (p, ms) = case t of Yajilin -> do - g <- fst Parse.yajilin p + g <- fst Parse.yajilin p msol <- traverse (snd Parse.yajilin) ms pure . catMaybes - $ [ (\(x, _) -> - TaggedComponent (Just Solution) - $ PlacedComponent Atop - $ CellGrid - $ fmap shade - $ x + $ [ ( \(x, _) -> + TaggedComponent (Just Solution) + $ PlacedComponent Atop + $ CellGrid + $ fmap shade + $ x ) - <$> msol - , Just - $ TaggedComponent Nothing - $ PlacedComponent Atop - $ CellGrid - $ fmap (const LightShade) - $ clues - $ g - , Just - $ TaggedComponent Nothing - $ PlacedComponent Atop - $ CellGrid - $ fmap yajClue - $ clues - $ g - , Just - $ TaggedComponent Nothing - $ PlacedComponent Atop - $ Grid GridDefault - $ fmap (const ()) - $ g - , (\(_, l) -> - TaggedComponent (Just Solution) - $ PlacedComponent Atop - $ EdgeGrid - $ es - $ l + <$> msol, + Just + $ TaggedComponent Nothing + $ PlacedComponent Atop + $ CellGrid + $ fmap (const LightShade) + $ clues + $ g, + Just + $ TaggedComponent Nothing + $ PlacedComponent Atop + $ CellGrid + $ fmap yajClue + $ clues + $ g, + Just + $ TaggedComponent Nothing + $ PlacedComponent Atop + $ Grid GridDefault + $ fmap (const ()) + $ g, + ( \(_, l) -> + TaggedComponent (Just Solution) + $ PlacedComponent Atop + $ EdgeGrid + $ es + $ l ) - <$> msol + <$> msol ] - where - es :: [Edge C] -> Map.Map (Edge N) Decoration - es l = Map.fromList . map (\e@(E _ dir) -> (dualE e, SolEdge dir)) $ l - yajClue x = maybe Blank arr x - shade x = if x then Shade else Blank - arr (v, d) = LabeledArrow d (show v) + where + es :: [Edge C] -> Map.Map (Edge N) Decoration + es l = Map.fromList . map (\e@(E _ dir) -> (dualE e, SolEdge dir)) $ l + yajClue x = maybe Blank arr x + shade x = if x then Shade else Blank + arr (v, d) = LabeledArrow d (show v) _ -> fail $ "puzzle type not implemented as generic: " ++ show t diff --git a/src/Draw/Grid.hs b/src/Draw/Grid.hs index 22e0532..ccb9e62 100644 --- a/src/Draw/Grid.hs +++ b/src/Draw/Grid.hs @@ -1,43 +1,41 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# 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 - , offset - , unit - ) -import Diagrams.TwoD.Offset ( offsetPath ) - -import qualified Data.AffineSpace as AS - -import Data.Util -import Data.Grid -import qualified Data.GridShape as Data -import Data.GridShape ( C - , ShiftC - , N - , Edge' - , Coord - , Edge(..) - , Dir(..) - ) - -import Draw.Draw hiding ( border ) -import Draw.Style -import Draw.Lib -import Draw.Widths -import Draw.GridShape +import qualified Data.AffineSpace as AS +import Data.Char (isUpper) +import Data.Grid +import qualified Data.GridShape as Data +import Data.GridShape + ( C, + Coord, + Dir (..), + Edge (..), + Edge', + N, + ShiftC, + ) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Util +import Diagrams.Prelude hiding + ( E, + N, + dot, + offset, + outer, + size, + unit, + ) +import Diagrams.TwoD.Offset (offsetPath) +import Draw.Draw hiding (border) +import Draw.GridShape +import Draw.Lib +import Draw.Style +import Draw.Widths -- | Draw a small black dot with no envelope. dot :: Backend' b => Drawing b @@ -52,44 +50,44 @@ grid s g = <> Drawing (\c -> stroke inner # linestyle c (_line s)) <> Drawing (\c -> stroke outer # linestyle c (_border s)) <> Drawing (\c -> frm c) - where - vertex = case _vertex s of - VertexDot -> dot - VertexNone -> mempty - edgeWidth cfg = case _cfgDevice cfg of - Screen -> edgewidth - Print -> 2 * edgewidth / 3 - linestyle cfg ls = - let gw = case _cfgDevice cfg of - Screen -> linewidth - Print -> linewidth / 2 - ew = edgeWidth cfg - in case ls of - LineNone -> const mempty - LineThin -> lwG gw - LineDashed -> gridDashing . lwG gw - LineThick -> lwG ew - frm cfg = case _frame s of - Just (FrameStyle f c) -> outLine cfg f outer # fc c - Nothing -> mempty - outLine cfg f p = lwG 0 . stroke $ pin <> pout - where - pout = reversePath $ offsetPath (f * w - e) p - pin = offsetPath (-e) p - e = w / 2 - w = edgeWidth cfg - (outer, inner) = irregularGridPaths g + where + vertex = case _vertex s of + VertexDot -> dot + VertexNone -> mempty + edgeWidth cfg = case _cfgDevice cfg of + Screen -> edgewidth + Print -> 2 * edgewidth / 3 + linestyle cfg ls = + let gw = case _cfgDevice cfg of + Screen -> linewidth + Print -> linewidth / 2 + ew = edgeWidth cfg + in case ls of + LineNone -> const mempty + LineThin -> lwG gw + LineDashed -> gridDashing . lwG gw + LineThick -> lwG ew + frm cfg = case _frame s of + Just (FrameStyle f c) -> outLine cfg f outer # fc c + Nothing -> mempty + outLine cfg f p = lwG 0 . stroke $ pin <> pout + where + pout = reversePath $ offsetPath (f * w - e) p + pin = offsetPath (- e) p + e = w / 2 + w = edgeWidth cfg + (outer, inner) = irregularGridPaths g shiftGrid :: Backend' b => Grid ShiftC a -> Drawing b shiftGrid = placeGrid . fmap (const gridCell) -bgdashingG - :: (Semigroup a, HasStyle a, InSpace V2 Double a) - => [Double] - -> Double - -> AlphaColour Double - -> a - -> a +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] @@ -100,32 +98,32 @@ 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) + where + white' = black `withOpacity` (0.05 :: Double) -data CageParams = CageParams - { cageDashOn :: Double - , cageDashOff :: Double - , cageWidth :: Double - , cageOffset :: Double - } +data CageParams + = CageParams + { cageDashOn :: Double, + cageDashOff :: Double, + cageWidth :: Double, + cageOffset :: Double + } cageParams :: Config -> CageParams cageParams cfg = case _cfgDevice cfg of Screen -> CageParams (4 / 40) (4 / 40) onepix (4 * onepix) Print -> - let - -- input parameters - lwidth = 1.25 * onepix - steps = 10 - gapSteps = 2 + let -- input parameters + lwidth = 1.25 * onepix + steps = 10 + gapSteps = 2 dashFactor = 3 - - step = 1 / steps - cap = lwidth - on = dashFactor * step / (dashFactor + 1) - cap - off = step / (dashFactor + 1) + cap - offset = step * gapSteps / 2 - in CageParams on off lwidth offset + step = 1 / steps + cap = lwidth + on = dashFactor * step / (dashFactor + 1) - cap + off = step / (dashFactor + 1) + cap + offset = step * gapSteps / 2 + in CageParams on off lwidth offset cageDashing :: (HasStyle a, InSpace V2 Double a) => CageParams -> a -> a cageDashing (CageParams on off w _) = @@ -141,81 +139,83 @@ cageDashing (CageParams on off w _) = -- `inner` consists of the individual inner segments. irregularGridPaths :: Grid C a -> (Path V2 Double, Path V2 Double) irregularGridPaths m = (path' (map Data.revEdge outer), path inner) - where - (outer, inner) = Data.edges (Map.keysSet m) (`Map.member` m) - path es = mconcat . map (conn . Data.ends) $ es - path' es = case loops (map Data.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 + where + (outer, inner) = Data.edges (Map.keysSet m) (`Map.member` m) + path es = mconcat . map (conn . Data.ends) $ es + path' es = case loops (map Data.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, _) = Data.edges cs (`elem` cs) - loop :: [N] - loop = case loops (map Data.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 + where + pathFromLoopVertices = + pathFromLocTrail . mapLoc (wrapLoop . closeLine) . fromVertices + outer :: [Edge' N] + (outer, _) = Data.edges cs (`elem` cs) + loop :: [N] + loop = case loops (map Data.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) + 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 :: + (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' :: + (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 + 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) = Data.ends e - c = toPoint a - d = toPoint b + where + (a, b) = Data.ends e + c = toPoint a + d = toPoint b edgeStyle :: (HasStyle a, InSpace V2 Double a) => Config -> a -> a edgeStyle cfg = lineCap LineCapSquare . lwG ew - where - ew = case _cfgDevice cfg of - Screen -> edgewidth - Print -> 2 * edgewidth / 3 + where + ew = case _cfgDevice cfg of + Screen -> edgewidth + Print -> 2 * edgewidth / 3 thinEdgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a thinEdgeStyle = lineCap LineCapSquare . lwG onepix @@ -233,7 +233,7 @@ edges es = Drawing (\cfg -> edgeStyle cfg . stroke . mconcat . map edge $ es) dirPath :: Dir -> Path V2 Double dirPath dir = case dir of Horiz -> hrule 1.0 - Vert -> vrule 1.0 + Vert -> vrule 1.0 edgeDecoration :: Backend' b => Dir -> Drawing b edgeDecoration dir = Drawing (\cfg -> edgeStyle cfg . stroke . dirPath $ dir) @@ -252,11 +252,11 @@ areas = edges . borders cage :: Backend' b => [C] -> Drawing b cage cs = Drawing dcage - where - dcage cfg = border # stroke # cageDashing params - where - params = cageParams cfg - border = offsetBorder (-(cageOffset params)) cs + where + dcage cfg = border # stroke # cageDashing params + where + params = cageParams cfg + border = offsetBorder (- (cageOffset params)) cs fillBG :: Backend' b => Colour Double -> Drawing b fillBG c = draw $ square 1 # lwG onepix # fc c # lc c @@ -266,27 +266,31 @@ shadeGrid = placeGrid . fmap fillBG . clues shade :: Backend' b => Grid C Bool -> Drawing b shade = shadeGrid . fmap f - where - f True = Just gray - f False = Nothing + where + f True = Just gray + f False = Nothing areasGray :: Backend' b => Grid C Char -> Drawing b areasGray = areas <> shadeGrid . fmap cols - where - cols c | isUpper c = Just (blend 0.1 black white) - | otherwise = Nothing + 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 +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/GridShape.hs b/src/Draw/GridShape.hs index 9be175c..df60e8b 100644 --- a/src/Draw/GridShape.hs +++ b/src/Draw/GridShape.hs @@ -1,31 +1,29 @@ module Draw.GridShape where -import Diagrams.Prelude hiding ( size - , E - , N - , dot - , outer - , offset - , unit - ) - -import qualified Data.AffineSpace as AS - -import Data.GridShape -import Draw.Lib +import qualified Data.AffineSpace as AS +import Data.GridShape +import Diagrams.Prelude hiding + ( E, + N, + dot, + offset, + outer, + size, + unit, + ) +import Draw.Lib (.--.) :: AS.AffineSpace p => p -> p -> AS.Diff p (.--.) = (AS..-.) class ToPoint a where - toPoint :: a -> P2 Double + toPoint :: a -> P2 Double instance ToPoint C where - toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0) + toPoint c = p2 (1 / 2, 1 / 2) .+^ r2i (c .--. C 0 0) instance ToPoint N where - toPoint c = origin .+^ r2i (c .--. N 0 0) + toPoint c = origin .+^ r2i (c .--. N 0 0) instance ToPoint ShiftC where - toPoint (ShiftC c@(C _x y)) = toPoint c .+^ 0.5 * fromIntegral y *^ unitX - + toPoint (ShiftC c@(C _x y)) = toPoint c .+^ 0.5 * fromIntegral y *^ unitX diff --git a/src/Draw/Lib.hs b/src/Draw/Lib.hs index 18c73a6..3f6bdef 100644 --- a/src/Draw/Lib.hs +++ b/src/Draw/Lib.hs @@ -1,24 +1,26 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} module Draw.Lib where -import Diagrams.Prelude - -import Graphics.SVGFonts.Text ( TextOpts(..) - , Mode(..) - , Spacing(..) - , textSVG' - ) - -import Control.Arrow ( (***) ) - -import Draw.Font - -type Backend' b = (V b ~ V2, N b ~ Double, - Renderable (Path V2 Double) b, Backend b V2 Double) +import Control.Arrow ((***)) +import Diagrams.Prelude +import Draw.Font +import Graphics.SVGFonts.Text + ( Mode (..), + Spacing (..), + TextOpts (..), + textSVG', + ) + +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 @@ -26,12 +28,12 @@ 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) - => Double - -> [a] - -> a -hcatSep s = hcat' with { _sep = s } +hcatSep :: + (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a) => + Double -> + [a] -> + a +hcatSep s = hcat' with {_sep = s} -- | Collapse the envelope to a point. smash :: Backend' b => Diagram b -> Diagram b @@ -54,7 +56,7 @@ mirror = reflectAbout (p2 (0, 0)) (direction $ r2 (1, -1)) -- | Interleave two lists. interleave :: [a] -> [a] -> [a] -interleave [] _ = [] +interleave [] _ = [] interleave (x : xs) ys = x : interleave ys xs magnitude :: V2 Double -> Double @@ -63,58 +65,61 @@ 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 + 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 + 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) + 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) + 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) + 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) -- | @fitDown f a@ scales @a@ down to fit into a square of size $f$. -fitDown - :: (Transformable t, Enveloped t, InSpace V2 Double t) => Double -> t -> t +fitDown :: + (Transformable t, Enveloped t, InSpace V2 Double t) => Double -> t -> t fitDown f a = scale f' a - where - m = max (diameter unitX a) (diameter unitY a) - f' = if m > f then f / m else 1 + where + m = max (diameter unitX a) (diameter unitY a) + f' = if m > f then f / m else 1 -- | Write text that is centered both vertically and horizontally and that -- has an envelope. Sized such that single capital characters fit nicely -- into a square of size @1@. -text'' - :: Renderable (Path V2 Double) b => Font -> String -> QDiagram b V2 Double Any +text'' :: + Renderable (Path V2 Double) b => Font -> String -> QDiagram b V2 Double Any 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 + where + rfc :: (HasStyle a, InSpace V2 Double a) => Colour Double -> a -> a + rfc = recommendFillColor -- | Variant of 'phantom' that forces the argument backend type. phantom' :: Backend' b => Diagram b -> Diagram b diff --git a/src/Draw/PuzzleGrids.hs b/src/Draw/PuzzleGrids.hs index 7046d4f..a73e64f 100644 --- a/src/Draw/PuzzleGrids.hs +++ b/src/Draw/PuzzleGrids.hs @@ -1,61 +1,62 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Draw.PuzzleGrids - ( intGrid - , charGrid - , outsideIntGrid - , slitherGrid - , tightGrid - , sudokugrid - , wordsClues - , outsideGrid - , multiOutsideGrid - , outsideGridN - , multiOutsideGridN - , placeOutside - , placeMultiOutside - , placeMultiOutsideGW - , layoutRow - , layoutGrid + ( intGrid, + charGrid, + outsideIntGrid, + slitherGrid, + tightGrid, + sudokugrid, + wordsClues, + outsideGrid, + multiOutsideGrid, + outsideGridN, + multiOutsideGridN, + placeOutside, + placeMultiOutside, + placeMultiOutsideGW, + layoutRow, + layoutGrid, ) where -import Diagrams.Prelude hiding ( size - , N - , el - , offset - ) - -import qualified Data.Map.Strict as Map -import Data.Maybe ( maybeToList - , fromMaybe - ) -import Data.Foldable ( fold ) - -import qualified Data.Grid as Data -import Data.Grid ( Grid - , OutsideClues - , clues - , size - ) -import Data.GridShape ( C - , N - , FromCoord(..) - , ToCoord(..) - ) -import Data.Elements -import Data.Sudoku - -import Draw.Draw -import Draw.Lib -import Draw.Widths -import Draw.Style -import Draw.Grid -import Draw.GridShape -import Draw.Elements +import Data.Elements +import Data.Foldable (fold) +import qualified Data.Grid as Data +import Data.Grid + ( Grid, + OutsideClues, + clues, + size, + ) +import Data.GridShape + ( C, + FromCoord (..), + N, + ToCoord (..), + ) +import qualified Data.Map.Strict as Map +import Data.Maybe + ( fromMaybe, + maybeToList, + ) +import Data.Sudoku +import Diagrams.Prelude hiding + ( N, + el, + offset, + size, + ) +import Draw.Draw +import Draw.Elements +import Draw.Grid +import Draw.GridShape +import Draw.Lib +import Draw.Style +import Draw.Widths charGrid :: Backend' b => Grid C (Maybe Char) -> Drawing b charGrid = placeGrid . fmap char . clues <> grid gDefault @@ -73,99 +74,106 @@ wordsClues :: Backend' b => Grid C (Maybe [String]) -> Drawing b wordsClues = placeGrid . fmap Draw.Elements.words . clues tightGrid :: Backend' b => (t -> Drawing b) -> Grid C (Tightfit t) -> Drawing b -tightGrid d g = (placeGrid . fmap (tight d) $ g) <> grid gDefault g <> draw - (phantom' (strokePath $ p2i (-1, -1) ~~ p2i (sx + 1, sy + 1))) - where (sx, sy) = size (Map.mapKeys toCoord g) +tightGrid d g = + (placeGrid . fmap (tight d) $ g) <> grid gDefault g + <> draw + (phantom' (strokePath $ p2i (-1, -1) ~~ p2i (sx + 1, sy + 1))) + where + (sx, sy) = size (Map.mapKeys toCoord g) maxDiam :: Backend' b => V2 Double -> Config -> [Drawing b] -> Double maxDiam dir cfg ds = fromMaybe 0 . fmap getMax . foldMap maxSize . map (diagram cfg) $ ds - where maxSize = Just . Max . diameter dir + where + maxSize = Just . Max . diameter dir layoutRow :: Backend' b => V2 Double -> [Drawing b] -> Drawing b -layoutRow dir = fold - . zipWith (\i -> moveTo (origin .+^ fromIntegral i *^ dir)) [(0 :: Int) ..] +layoutRow dir = + fold + . zipWith (\i -> moveTo (origin .+^ fromIntegral i *^ dir)) [(0 :: Int) ..] layoutGrid :: Backend' b => V2 Double -> V2 Double -> [[Drawing b]] -> Drawing b layoutGrid dirA dirB = layoutRow dirA . map (layoutRow dirB) -placeSideGrid - :: Backend' b - => Double - -> (Double -> Double) - -> V2 Double - -> V2 Double - -> P2 Double - -> [[Drawing b]] - -> Drawing b +placeSideGrid :: + Backend' b => + Double -> + (Double -> Double) -> + V2 Double -> + V2 Double -> + P2 Double -> + [[Drawing b]] -> + Drawing b placeSideGrid mrg off dir1 dir2 base cs = withConfig place_ - where - place_ cfg = - let minDiam = diameter dir1 (diagram cfg (char 'M') :: D V2 Double) - elDiam = max minDiam (maxDiam dir1 cfg (fold cs)) - step = elDiam + mrg - offset = off elDiam - baseOffset = base .+^ offset *^ dir1 - in layoutGrid dir2 (step *^ dir1) cs # moveTo baseOffset - -placeMultiOutside - :: (Backend' b, FromCoord k, ToCoord k, ToPoint k, Ord k) - => OutsideClues k [Drawing b] - -> Drawing b -placeMultiOutside ocs = foldMap - (\(cs, dir1, base, dir2) -> - placeSideGrid mrg off (r2i dir1) (r2i dir2) (toPoint base) cs - ) - (Data.outsideClues ocs) - where - mrg = 1 / 3 - off elDiam = 1 / 2 * elDiam - 1 / 2 * mrg - -placeMultiOutsideGW - :: (Backend' b, FromCoord k, ToCoord k, ToPoint k, Ord k) - => OutsideClues k [Drawing b] - -> Drawing b -placeMultiOutsideGW ocs = foldMap - (\(cs, dir1, base, dir2) -> - placeSideGrid 0 (const (1 / 4)) (r2i dir1) (r2i dir2) (toPoint base) cs - ) - (Data.outsideClues ocs) - -placeOutside - :: (Backend' b, ToPoint k, FromCoord k, ToCoord k, Ord k) - => OutsideClues k (Maybe (Drawing b)) - -> Drawing b + where + place_ cfg = + let minDiam = diameter dir1 (diagram cfg (char 'M') :: D V2 Double) + elDiam = max minDiam (maxDiam dir1 cfg (fold cs)) + step = elDiam + mrg + offset = off elDiam + baseOffset = base .+^ offset *^ dir1 + in layoutGrid dir2 (step *^ dir1) cs # moveTo baseOffset + +placeMultiOutside :: + (Backend' b, FromCoord k, ToCoord k, ToPoint k, Ord k) => + OutsideClues k [Drawing b] -> + Drawing b +placeMultiOutside ocs = + foldMap + ( \(cs, dir1, base, dir2) -> + placeSideGrid mrg off (r2i dir1) (r2i dir2) (toPoint base) cs + ) + (Data.outsideClues ocs) + where + mrg = 1 / 3 + off elDiam = 1 / 2 * elDiam - 1 / 2 * mrg + +placeMultiOutsideGW :: + (Backend' b, FromCoord k, ToCoord k, ToPoint k, Ord k) => + OutsideClues k [Drawing b] -> + Drawing b +placeMultiOutsideGW ocs = + foldMap + ( \(cs, dir1, base, dir2) -> + placeSideGrid 0 (const (1 / 4)) (r2i dir1) (r2i dir2) (toPoint base) cs + ) + (Data.outsideClues ocs) + +placeOutside :: + (Backend' b, ToPoint k, FromCoord k, ToCoord k, Ord k) => + OutsideClues k (Maybe (Drawing b)) -> + Drawing b placeOutside = placeMultiOutside . fmap maybeToList outsideGrid :: Backend' b => OutsideClues C (Maybe String) -> Drawing b outsideGrid = placeOutside - . fmap (fmap (scale outsideScale . text')) + . fmap (fmap (scale outsideScale . text')) <> grid gDefault - . Data.outsideGrid + . Data.outsideGrid outsideGridN :: Backend' b => OutsideClues N (Maybe String) -> Drawing b outsideGridN = placeOutside - . fmap (fmap (scale outsideScale . text')) + . fmap (fmap (scale outsideScale . text')) <> grid gDefault - . Data.cellGrid - . Data.outsideGrid + . Data.cellGrid + . Data.outsideGrid multiOutsideGrid :: Backend' b => OutsideClues C [String] -> Drawing b multiOutsideGrid = placeMultiOutside - . fmap (fmap (scale outsideScale . text')) + . fmap (fmap (scale outsideScale . text')) <> grid gDefault - . Data.outsideGrid + . Data.outsideGrid multiOutsideGridN :: Backend' b => OutsideClues N [String] -> Drawing b multiOutsideGridN = placeMultiOutside - . fmap (fmap (scale outsideScale . text')) + . fmap (fmap (scale outsideScale . text')) <> grid gDefault - . Data.cellGrid - . Data.outsideGrid + . Data.cellGrid + . Data.outsideGrid outsideIntGrid :: Backend' b => OutsideClues C [Int] -> Drawing b outsideIntGrid = multiOutsideGrid . fmap (fmap show) diff --git a/src/Draw/PuzzleTypes.hs b/src/Draw/PuzzleTypes.hs index 508e9bd..dd9615a 100644 --- a/src/Draw/PuzzleTypes.hs +++ b/src/Draw/PuzzleTypes.hs @@ -1,1006 +1,1078 @@ - -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} module Draw.PuzzleTypes - ( lits - , geradeweg - , fillomino - , masyu - , nurikabe - , latintapa - , sudoku - , thermosudoku - , pyramid - , kpyramid - , slither - , liarslither - , tightfitskyscrapers - , wordloop - , wordsearch - , curvedata - , doubleback - , slalom - , compass - , meanderingnumbers - , tapa - , japanesesums - , coral - , maximallengths - , labyrinth - , bahnhof - , cave - , angleLoop - , shikaku - , slovaksums - , blackoutDominos - , anglers - , skyscrapers - , summon - , baca - , buchstabensalat - , doppelblock - , sudokuDoppelblock - , dominos - , skyscrapersStars - , fillominoCheckered - , numberlink - , dominoPills - , fillominoLoop - , loopki - , scrabble - , neighbors - , heyawake - , pentominous - , starbattle - , colorakari - , persistenceOfMemory - , abctje - , kropki - , statuepark - , pentominousBorders - , nanroSignpost - , tomTom - , horseSnake - , illumination - , pentopia - , greaterWall - , galaxies - , mines - , tents - , pentominoSums - , coralLits - , coralLitso - , snake - , countryRoad - , killersudoku - , japsummasyu - , arrowsudoku - , dualloop + ( lits, + geradeweg, + fillomino, + masyu, + nurikabe, + latintapa, + sudoku, + thermosudoku, + pyramid, + kpyramid, + slither, + liarslither, + tightfitskyscrapers, + wordloop, + wordsearch, + curvedata, + doubleback, + slalom, + compass, + meanderingnumbers, + tapa, + japanesesums, + coral, + maximallengths, + labyrinth, + bahnhof, + cave, + angleLoop, + shikaku, + slovaksums, + blackoutDominos, + anglers, + skyscrapers, + summon, + baca, + buchstabensalat, + doppelblock, + sudokuDoppelblock, + dominos, + skyscrapersStars, + fillominoCheckered, + numberlink, + dominoPills, + fillominoLoop, + loopki, + scrabble, + neighbors, + heyawake, + pentominous, + starbattle, + colorakari, + persistenceOfMemory, + abctje, + kropki, + statuepark, + pentominousBorders, + nanroSignpost, + tomTom, + horseSnake, + illumination, + pentopia, + greaterWall, + galaxies, + mines, + tents, + pentominoSums, + coralLits, + coralLitso, + snake, + countryRoad, + killersudoku, + japsummasyu, + arrowsudoku, + dualloop, ) where -import Diagrams.Prelude hiding ( Loop - , N - , coral - , size - , star - , end - ) - -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 hiding ( dominos ) +import Data.Char (isUpper) +import Data.Elements +import qualified Data.Grid as Data +import Data.Grid + ( AreaGrid, + Grid, + OutsideClues (..), + ShadedGrid, + clues, + ) +import Data.GridShape + ( C (..), + Edge, + N, + ToCoord (..), + ) +import Data.List + ( nub, + sort, + sortOn, + ) +import qualified Data.Map.Strict as Map +import qualified Data.Pyramid as Pyr +import Diagrams.Prelude hiding + ( Loop, + N, + coral, + end, + size, + star, + ) +import Draw.Draw +import Draw.Elements hiding (dominos) import qualified Draw.Elements -import Draw.Lib -import Draw.Widths - -import qualified Data.Grid as Data -import Data.Grid ( Grid - , AreaGrid - , ShadedGrid - , OutsideClues(..) - , clues - ) -import Data.GridShape ( C(..) - , N - , Edge - , ToCoord(..) - ) -import Data.Elements -import qualified Data.Pyramid as Pyr +import Draw.Grid +import Draw.Lib +import Draw.PuzzleGrids +import qualified Draw.Pyramid as DPyr +import Draw.Style +import Draw.Widths unimplemented :: Backend' b => String -> (p, s) -> Drawing b unimplemented _ _ = mempty lits :: Backend' b => Drawers b AreaGrid ShadedGrid -lits = Drawers (grid gDefault <> areasGray) - ((areas <> grid gDefault) . fst <> shade . snd) +lits = + Drawers + (grid gDefault <> areasGray) + ((areas <> grid gDefault) . fst <> shade . snd) geradeweg :: Backend' b => Drawers b (Grid C (Maybe Int)) (Loop C) -geradeweg = Drawers - intGrid - ( placeGrid - . fmap int - . clues - . fst - <> solstyle - . edges - . snd - <> grid gDefault - . fst - ) +geradeweg = + Drawers + intGrid + ( placeGrid + . fmap int + . clues + . fst + <> solstyle + . edges + . snd + <> grid gDefault + . fst + ) fillomino :: Backend' b => Drawers b (Grid C (Maybe Int)) (Grid C Int) -fillomino = Drawers - (placeGrid . fmap int . clues <> grid gDashed) - ((placeGrid . fmap int <> edges . Data.borders <> grid gDashed) . snd) +fillomino = + Drawers + (placeGrid . fmap int . clues <> grid gDashed) + ((placeGrid . fmap int <> edges . Data.borders <> grid gDashed) . snd) fillominoCheckered :: Backend' b => Drawers b (Grid C (Maybe Int)) (Grid C Int) -fillominoCheckered = Drawers - (placeGrid . fmap int . clues <> grid gDashed) - ( ( placeGrid - . fmap int - <> edges - . Data.borders - <> grid gDashed - <> shadeGrid - . checker +fillominoCheckered = + Drawers + (placeGrid . fmap int . clues <> grid gDashed) + ( ( placeGrid + . fmap int + <> edges + . Data.borders + <> grid gDashed + <> shadeGrid + . checker + ) + . snd ) - . snd - ) - where - checker = fmap pickColour . Data.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 int . clues <> grid gDashed) - ( ( placeGrid - . fmap int - . fst - <> solstyle - . edges - . snd - <> edges - . Data.borders - . fst - <> grid gDashed - . fst + where + checker = fmap pickColour . Data.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 int . clues <> grid gDashed) + ( ( placeGrid + . fmap int + . fst + <> solstyle + . edges + . snd + <> edges + . Data.borders + . fst + <> grid gDashed + . fst + ) + . snd ) - . snd - ) masyu :: Backend' b => Drawers b (Grid C (Maybe MasyuPearl)) (Loop C) masyu = Drawers p (solstyle . edges . snd <> p . fst) - where p = placeGrid . fmap pearl . clues <> grid gDefault + where + p = placeGrid . fmap pearl . clues <> grid gDefault nurikabe :: Backend' b => Drawers b (Grid C (Maybe Int)) ShadedGrid nurikabe = Drawers intGrid (intGrid . fst <> shade . snd) -latintapa - :: Backend' b => Drawers b (Grid C (Maybe [String])) (Grid C (Maybe Char)) +latintapa :: + Backend' b => Drawers b (Grid C (Maybe [String])) (Grid C (Maybe Char)) latintapa = Drawers l (l . fst <> placeGrid . fmap char . clues . snd) - where l = grid gDefault <> wordsClues + where + l = grid gDefault <> wordsClues sudoku :: Backend' b => Drawers b (Grid C (Maybe Int)) (Grid C (Maybe Int)) -sudoku = Drawers (placeGrid . fmap int . clues <> sudokugrid) - ((placeGrid . fmap int . clues <> sudokugrid) . snd) - -thermosudoku - :: Backend' b - => Drawers b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int)) -thermosudoku = Drawers - (placeGrid . fmap int . clues . fst <> sudokugrid . fst <> thermos . snd) - (placeGrid . fmap int . clues . snd <> sudokugrid . snd <> thermos . snd . fst - ) +sudoku = + Drawers + (placeGrid . fmap int . clues <> sudokugrid) + ((placeGrid . fmap int . clues <> sudokugrid) . snd) + +thermosudoku :: + Backend' b => + Drawers b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int)) +thermosudoku = + Drawers + (placeGrid . fmap int . clues . fst <> sudokugrid . fst <> thermos . snd) + ( placeGrid . fmap int . clues . snd <> sudokugrid . snd <> thermos . snd . fst + ) -killersudoku - :: Backend' b - => Drawers b (AreaGrid, Map.Map Char Int, Grid C (Maybe Int)) (Grid C Int) -killersudoku = Drawers (p <> placeGrid . fmap int . clues . trd3) - (placeGrid . fmap int . snd <> p . fst) - where - fst3 (x, _, _) = x - trd3 (_, _, z) = z - p = sudokugrid . fst3 <> cages' - cages' (g, m, _) = cages (Map.filter (/= '.') g) (Map.map int m) +killersudoku :: + Backend' b => + Drawers b (AreaGrid, Map.Map Char Int, Grid C (Maybe Int)) (Grid C Int) +killersudoku = + Drawers + (p <> placeGrid . fmap int . clues . trd3) + (placeGrid . fmap int . snd <> p . fst) + where + fst3 (x, _, _) = x + trd3 (_, _, z) = z + p = sudokugrid . fst3 <> cages' + cages' (g, m, _) = cages (Map.filter (/= '.') g) (Map.map int 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 + 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 + where + merge (p, q) = Pyr.mergekpyramidsol p q slither :: Backend' b => Drawers b (Grid C (Maybe Int)) (Loop N) slither = Drawers slitherGrid (slitherGrid . fst <> solstyle . edges . snd) -liarslither - :: Backend' b => Drawers b (Grid C (Maybe Int)) (Loop N, Grid C Bool) -liarslither = Drawers - slitherGrid - ( placeGrid - . fmap (solstyle . cross) - . snd - . snd - <> slitherGrid - . fst - <> solstyle - . edges - . fst - . snd - ) +liarslither :: + Backend' b => Drawers b (Grid C (Maybe Int)) (Loop N, Grid C Bool) +liarslither = + Drawers + slitherGrid + ( placeGrid + . fmap (solstyle . cross) + . snd + . snd + <> slitherGrid + . fst + <> solstyle + . edges + . fst + . snd + ) -tightfitskyscrapers - :: Backend' b - => Drawers - b - (OutsideClues C (Maybe Int), Grid C (Tightfit ())) - (Grid C (Tightfit Int)) -tightfitskyscrapers = Drawers - (placeOutside . fmap (fmap int) . fst <> tightGrid (const mempty) . snd) - (placeOutside . fmap (fmap int) . fst . fst <> tightGrid int . snd) +tightfitskyscrapers :: + Backend' b => + Drawers + b + (OutsideClues C (Maybe Int), Grid C (Tightfit ())) + (Grid C (Tightfit Int)) +tightfitskyscrapers = + Drawers + (placeOutside . fmap (fmap int) . fst <> tightGrid (const mempty) . snd) + (placeOutside . fmap (fmap int) . fst . fst <> tightGrid int . snd) wordgrid :: Backend' b => Grid C (Maybe Char) -> [String] -> Drawing b wordgrid g ws = stackWords ws `besidesR'` charGrid g -wordloop - :: Backend' b - => Drawers b (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) +wordloop :: + Backend' b => + Drawers b (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) wordloop = Drawers (uncurry wordgrid) (charGrid . snd) -wordsearch - :: Backend' b - => Drawers - b - (Grid C (Maybe Char), [String]) - (Grid C (Maybe Char), [MarkedWord]) -wordsearch = Drawers - (uncurry wordgrid) - (solstyle . markedWords . snd . snd <> charGrid . fst . snd) +wordsearch :: + Backend' b => + Drawers + b + (Grid C (Maybe Char), [String]) + (Grid C (Maybe Char), [MarkedWord]) +wordsearch = + Drawers + (uncurry wordgrid) + (solstyle . markedWords . snd . snd <> charGrid . fst . snd) curvedata :: Backend' b => Drawers b (Grid C (Maybe [Edge N])) [Edge C] -curvedata = Drawers - (placeGrid . fmap curve . clues <> grid gDefault) - ( placeGrid - . fmap curve - . clues - . fst - <> solstyle - . edges - . snd - <> grid gDefault - . fst - ) +curvedata = + Drawers + (placeGrid . fmap curve . clues <> grid gDefault) + ( placeGrid + . fmap curve + . clues + . fst + <> solstyle + . edges + . snd + <> grid gDefault + . fst + ) doubleback :: Backend' b => Drawers b AreaGrid (Loop C) doubleback = Drawers p (solstyle . edges . snd <> p . fst) - where p = grid gDefault <> areasGray + where + p = grid gDefault <> areasGray slalom :: Backend' b => Drawers b (Grid N (Maybe Int)) (Grid C SlalomDiag) slalom = Drawers p (p . fst <> placeGrid . fmap (solstyle . slalomDiag) . snd) - where - p = placeGrid . fmap slalomClue . clues <> grid gDefault . Data.cellGrid + where + p = placeGrid . fmap slalomClue . clues <> grid gDefault . Data.cellGrid compass :: Backend' b => Drawers b (Grid C (Maybe CompassC)) AreaGrid -compass = Drawers - (placeGrid . fmap compassClue . clues <> grid gDashed) - ( placeGrid - . fmap compassClue - . clues - . fst - <> (grid gDashed <> areasGray) - . snd - ) +compass = + Drawers + (placeGrid . fmap compassClue . clues <> grid gDashed) + ( placeGrid + . fmap compassClue + . clues + . fst + <> (grid gDashed <> areasGray) + . snd + ) -meanderingnumbers - :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C (Maybe Int)) -meanderingnumbers = Drawers - (grid gDefault . fst <> areas . fst <> placeGrid . fmap int . clues . snd) - (intGrid . snd <> areas . fst . fst) +meanderingnumbers :: + Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C (Maybe Int)) +meanderingnumbers = + Drawers + (grid gDefault . fst <> areas . fst <> placeGrid . fmap int . clues . snd) + (intGrid . snd <> areas . fst . fst) tapa :: Backend' b => Drawers b (Grid C (Maybe TapaClue)) ShadedGrid tapa = Drawers tapaGrid (tapaGrid . fst <> shade . snd) - where tapaGrid = placeGrid . fmap tapaClue . 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) (text' ds # scale noteScale) - japcells = placeGrid . fmap japcell - japcell (Left Black) = fillBG gray - japcell (Right x ) = int x - h = snd . Data.outsideSize + where + tapaGrid = placeGrid . fmap tapaClue . 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) (text' ds # scale noteScale) + japcells = placeGrid . fmap japcell + japcell (Left Black) = fillBG gray + japcell (Right x) = int x + h = snd . Data.outsideSize coral :: Backend' b => Drawers b (OutsideClues C [String]) ShadedGrid coral = Drawers multiOutsideGrid (multiOutsideGrid . fst <> shade . snd) maximallengths :: Backend' b => Drawers b (OutsideClues C (Maybe Int)) (Loop C) maximallengths = Drawers g (solstyle . edges . snd <> g . fst) - where g = placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid - -labyrinth - :: Backend' b - => Drawers b (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int)) -labyrinth = Drawers (placeGrid . fmap int . clues . fst3 <> p <> n) - (placeGrid . fmap int . clues . snd <> p . fst) - where - p (g, e, _) = edges e <> grid gPlain g - n (g, _, ds) = placeNoteTR (size' g) (text' ds # scale noteScale) - size' = Data.size . Map.mapKeys toCoord - fst3 (x, _, _) = x + where + g = placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid + +labyrinth :: + Backend' b => + Drawers b (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int)) +labyrinth = + Drawers + (placeGrid . fmap int . clues . fst3 <> p <> n) + (placeGrid . fmap int . clues . snd <> p . fst) + where + p (g, e, _) = edges e <> grid gPlain g + n (g, _, ds) = placeNoteTR (size' g) (text' ds # scale noteScale) + size' = Data.size . Map.mapKeys toCoord + fst3 (x, _, _) = x bahnhof :: Backend' b => Drawers b (Grid C (Maybe BahnhofClue)) [Edge C] -bahnhof = Drawers - (placeGrid . fmap bahnhofClue . clues <> grid gDefault) - ( placeGrid - . fmap bahnhofStation - . clues - . fst - <> solstyle - . edges - . snd - <> grid gDefault - . fst - ) - where bahnhofStation = either int (const mempty) - -blackoutDominos - :: Backend' b - => Drawers b (Grid C (Clue Int), DigitRange) (Grid C (Clue Int), AreaGrid) -blackoutDominos = Drawers - p - ( ( placeGrid - . fmap int - . clues - . fst - <> grid gDashedThick - . fst - <> areas - . snd - <> shadeGrid - . fmap cols - . snd +bahnhof = + Drawers + (placeGrid . fmap bahnhofClue . clues <> grid gDefault) + ( placeGrid + . fmap bahnhofStation + . clues + . fst + <> solstyle + . edges + . snd + <> grid gDefault + . fst ) - . snd - ) - where - p (g, ds) = (placeGrid . fmap int . clues <> grid gDashedThick $ g) - `aboveT'` Draw.Elements.dominos ds - cols 'X' = Just gray - cols _ = Nothing + where + bahnhofStation = either int (const mempty) + +blackoutDominos :: + Backend' b => + Drawers b (Grid C (Clue Int), DigitRange) (Grid C (Clue Int), AreaGrid) +blackoutDominos = + Drawers + p + ( ( placeGrid + . fmap int + . clues + . fst + <> grid gDashedThick + . fst + <> areas + . snd + <> shadeGrid + . fmap cols + . snd + ) + . snd + ) + where + p (g, ds) = + (placeGrid . fmap int . clues <> grid gDashedThick $ g) + `aboveT'` Draw.Elements.dominos ds + cols 'X' = Just gray + cols _ = Nothing angleLoop :: Backend' b => Drawers b (Grid N (Clue Int)) VertexLoop -angleLoop = Drawers - (cs <> gr) - ( cs - . fst - <> draw - . lineJoin LineJoinBevel - . solstyle - . strokeLocLoop - . vertexLoop - . snd - <> gr - . fst - ) - where - cs = placeGrid . fmap anglePoly . clues - gr = grid gPlainDashed . Data.cellGrid +angleLoop = + Drawers + (cs <> gr) + ( cs + . fst + <> draw + . lineJoin LineJoinBevel + . solstyle + . strokeLocLoop + . vertexLoop + . snd + <> gr + . fst + ) + where + cs = placeGrid . fmap anglePoly . clues + gr = grid gPlainDashed . Data.cellGrid -anglers - :: Backend' b - => Drawers b (OutsideClues C (Clue Int), Grid C (Maybe Fish)) [Edge C] +anglers :: + Backend' b => + Drawers b (OutsideClues C (Clue Int), Grid C (Maybe Fish)) [Edge C] anglers = Drawers (p <> g) (p . fst <> solstyle . edges . snd <> g . fst) - where - p = - placeOutside - . fmap (fmap int') - . fst - <> placeGrid - . fmap fish' - . clues - . snd - g = grid gDefault . snd - int' x = int x <> draw (square 0.6 # lc white # fc white) - fish' x = fish x <> draw (square 0.6 # lc white # fc white) + where + p = + placeOutside + . fmap (fmap int') + . fst + <> placeGrid + . fmap fish' + . clues + . snd + g = grid gDefault . snd + int' x = int x <> draw (square 0.6 # lc white # fc white) + fish' x = fish x <> draw (square 0.6 # lc white # fc white) cave :: Backend' b => Drawers b (Grid C (Maybe Int)) ShadedGrid -cave = Drawers - (grid gPlainDashed <> placeGrid . fmap int . clues) - ( edges - . Data.edgesGen (/=) not - . snd - <> placeGrid - . fmap int - . clues - . fst - <> shade - . snd - <> grid gStyle - . fst - ) - where - gStyle = - GridStyle LineDashed LineNone (Just $ FrameStyle (8 / 3) 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 int . clues . snd) - where - g = placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid - n (oc, s) = placeNoteTR (Data.outsideSize oc) (text' s) +cave = + Drawers + (grid gPlainDashed <> placeGrid . fmap int . clues) + ( edges + . Data.edgesGen (/=) not + . snd + <> placeGrid + . fmap int + . clues + . fst + <> shade + . snd + <> grid gStyle + . fst + ) + where + gStyle = + GridStyle LineDashed LineNone (Just $ FrameStyle (8 / 3) 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 int . clues . snd) + where + g = placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid + n (oc, s) = placeNoteTR (Data.outsideSize oc) (text' s) shikaku :: Backend' b => Drawers b (Grid C (Maybe Int)) AreaGrid shikaku = Drawers p (areas . snd <> p . fst) - where p = placeGrid . fmap int . clues <> grid gDashed - -slovaksums - :: Backend' b - => Drawers b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) -slovaksums = Drawers (p . fst <> n) - (placeGrid . fmap int . clues . snd <> p . fst . fst) - where - n (g, ds) = placeNoteTR (size' g) (text' ds # scale noteScale) - p = grid gDefault <> placeGrid . fmap slovakClue . clues - size' = Data.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 int star) . snd) - where - g = - (placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid) . fst - n (oc, s) = - placeNoteTR (Data.outsideSize oc) (int s ||| strutX' 0.2 ||| star Star) - -summon - :: Backend' b - => Drawers - b - (AreaGrid, OutsideClues C (Maybe Int), String) - (Grid C (Maybe Int)) + where + p = placeGrid . fmap int . clues <> grid gDashed + +slovaksums :: + Backend' b => + Drawers b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) +slovaksums = + Drawers + (p . fst <> n) + (placeGrid . fmap int . clues . snd <> p . fst . fst) + where + n (g, ds) = placeNoteTR (size' g) (text' ds # scale noteScale) + p = grid gDefault <> placeGrid . fmap slovakClue . clues + size' = Data.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 int star) . snd) + where + g = + (placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid) . fst + n (oc, s) = + placeNoteTR (Data.outsideSize oc) (int s ||| strutX' 0.2 ||| star Star) + +summon :: + Backend' b => + Drawers + b + (AreaGrid, OutsideClues C (Maybe Int), String) + (Grid C (Maybe Int)) summon = Drawers (p <> n) (placeGrid . fmap int . clues . snd <> p . fst) - where - p (g, oc, _) = - grid gDefault g - <> areasGray g - <> (placeOutside . al . fmap (fmap (scale 0.7 . int)) $ oc) - al - :: Backend' b - => OutsideClues k (Maybe (Drawing b)) - -> OutsideClues k (Maybe (Drawing b)) - al (OC l r b t) = OC l (map (fmap alignL') r) b t - - n (g, _, ds) = placeNoteBR (size' g) (text' ds # scale 0.7) - size' = Data.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 . char) . clues $ g - outside (g, tl, br) = - grid gDefault g - <> (placeMultiOutside . fmap (fmap int) $ tl) - <> (placeOutside . fmap (fmap char) $ br) - drawVal (Right c) = char 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 char . clues . snd) - where - p = - (placeOutside . fmap (fmap char) <> grid gDefault . Data.outsideGrid) . fst - n (ocs, ls) = placeNoteTR (Data.outsideSize ocs) (text' ls # scale noteScale) - -doppelblock - :: Backend' b - => Drawers b (OutsideClues C (Maybe Int)) (Grid C (Either Black Int)) + where + p (g, oc, _) = + grid gDefault g + <> areasGray g + <> (placeOutside . al . fmap (fmap (scale 0.7 . int)) $ oc) + al :: + Backend' b => + OutsideClues k (Maybe (Drawing b)) -> + OutsideClues k (Maybe (Drawing b)) + al (OC l r b t) = OC l (map (fmap alignL') r) b t + n (g, _, ds) = placeNoteBR (size' g) (text' ds # scale 0.7) + size' = Data.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 . char) . clues $ g + outside (g, tl, br) = + grid gDefault g + <> (placeMultiOutside . fmap (fmap int) $ tl) + <> (placeOutside . fmap (fmap char) $ br) + drawVal (Right c) = char 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 char . clues . snd) + where + p = + (placeOutside . fmap (fmap char) <> grid gDefault . Data.outsideGrid) . fst + n (ocs, ls) = placeNoteTR (Data.outsideSize ocs) (text' ls # scale noteScale) + +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 = outsideGrid . fmap (fmap show) - n ocs = placeNoteTL (0, h) (text' ds # scale noteScale) - where - h = snd (Data.outsideSize ocs) - ds = "1-" ++ show (h - 2) - drawVal (Right c) = int c - drawVal (Left _) = fillBG gray - -sudokuDoppelblock - :: Backend' b - => Drawers - b - (AreaGrid, OutsideClues C (Maybe Int)) - (Grid C (Either Black Int)) + where + p = outsideGrid . fmap (fmap show) + n ocs = placeNoteTL (0, h) (text' ds # scale noteScale) + where + h = snd (Data.outsideSize ocs) + ds = "1-" ++ show (h - 2) + drawVal (Right c) = int 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 = - placeOutside - . fmap (fmap (scale outsideScale . int)) - . snd - <> (grid gDefault <> areas) - . fst - drawVal (Right c) = int c - drawVal (Left _) = fillBG gray + where + p = + placeOutside + . fmap (fmap (scale outsideScale . int)) + . snd + <> (grid gDefault <> areas) + . fst + drawVal (Right c) = int c + drawVal (Left _) = fillBG gray dominos :: Backend' b => Drawers b (Grid C (Clue Int), DigitRange) AreaGrid -dominos = Drawers - p - (placeGrid . fmap int . clues . fst . fst <> (grid gDashed <> areasGray) . snd - ) - where - p (g, r) = ((placeGrid . fmap int . clues <> grid gDashed) $ g) - `aboveT'` Draw.Elements.dominos r - -dominoPills - :: Backend' b - => Drawers b (Grid C (Clue Int), DigitRange, DigitRange) AreaGrid -dominoPills = Drawers - p - ( placeGrid - . fmap int - . clues - . fst3 - . fst - <> (grid gDashed <> areasGray) - . snd - ) - where - fst3 (a, _, _) = a - p (g, ds, ps) = - ((placeGrid . fmap int . clues <> grid gDashed) $ g) - `aboveT'` (Draw.Elements.dominos ds ||| strutX' 0.5 ||| pills ps) +dominos = + Drawers + p + ( placeGrid . fmap int . clues . fst . fst <> (grid gDashed <> areasGray) . snd + ) + where + p (g, r) = + ((placeGrid . fmap int . clues <> grid gDashed) $ g) + `aboveT'` Draw.Elements.dominos r + +dominoPills :: + Backend' b => + Drawers b (Grid C (Clue Int), DigitRange, DigitRange) AreaGrid +dominoPills = + Drawers + p + ( placeGrid + . fmap int + . clues + . fst3 + . fst + <> (grid gDashed <> areasGray) + . snd + ) + where + fst3 (a, _, _) = a + p (g, ds, ps) = + ((placeGrid . fmap int . clues <> grid gDashed) $ g) + `aboveT'` (Draw.Elements.dominos ds ||| strutX' 0.5 ||| pills ps) numberlink :: Backend' b => Drawers b (Grid C (Maybe Int)) [Edge C] -numberlink = Drawers - intGrid - ( placeGrid - . fmap int' - . clues - . fst - <> solstyle - . edges - . snd - <> grid gDefault - . fst - ) - where int' x = int x <> draw (square 0.7 # lc white # fc white) +numberlink = + Drawers + intGrid + ( placeGrid + . fmap int' + . clues + . fst + <> solstyle + . edges + . snd + <> grid gDefault + . fst + ) + where + int' x = int x <> draw (square 0.7 # lc white # fc white) loopki :: Backend' b => Drawers b (Grid C (Maybe MasyuPearl)) (Loop N) loopki = Drawers p (solstyle . edges . 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 charFixed . clues . snd <> gr . fst . fst) - where - p (g, ws) = stackWords ws `besidesR'` gr g - gr = grid gDefault <> shade - -neighbors - :: Backend' b => Drawers b (Grid C Bool, Grid C (Maybe Int)) (Grid C Int) -neighbors = Drawers - (placeGrid . fmap int . clues . snd <> (grid gDefault <> shade) . fst) - (placeGrid . fmap int . snd <> (grid gDefault <> shade) . fst . 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 charFixed . clues . snd <> gr . fst . fst) + where + p (g, ws) = stackWords ws `besidesR'` gr g + gr = grid gDefault <> shade + +neighbors :: + Backend' b => Drawers b (Grid C Bool, Grid C (Maybe Int)) (Grid C Int) +neighbors = + Drawers + (placeGrid . fmap int . clues . snd <> (grid gDefault <> shade) . fst) + (placeGrid . fmap int . snd <> (grid gDefault <> shade) . fst . fst) starbattle :: Backend' b => Drawers b (AreaGrid, Int) (Grid C (Maybe Star)) -starbattle = Drawers (p <> n) - ((p <> n) . fst <> placeGrid . fmap star . clues . snd) - where - p = (areas <> grid gDefault) . fst - n (g, k) = placeNoteTR (size' g) (int k ||| strutX' 0.2 ||| star Star) - size' = Data.size . Map.mapKeys toCoord +starbattle = + Drawers + (p <> n) + ((p <> n) . fst <> placeGrid . fmap star . clues . snd) + where + p = (areas <> grid gDefault) . fst + n (g, k) = placeNoteTR (size' g) (int k ||| strutX' 0.2 ||| star Star) + size' = Data.size . Map.mapKeys toCoord heyawake :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Bool) heyawake = Drawers (as <> cs) (as . fst <> shade . snd <> cs . fst) - where - as = (areas <> grid gDefault) . fst - cs = placeGrid . fmap int . clues . snd + where + as = (areas <> grid gDefault) . fst + cs = placeGrid . fmap int . clues . snd pentominous :: Backend' b => Drawers b (Grid C (Maybe Char)) (Grid C Char) -pentominous = Drawers - (placeGrid . fmap char . clues <> grid gDashed) - (placeGrid . fmap char . clues . fst <> (areas <> grid gDashed) . snd) - -colorakari - :: Backend' b => Drawers b (Grid C (Maybe Char)) (Grid C (Maybe Char)) -colorakari = Drawers - p - (p . fst <> placeGrid . fmap drawColorLight . clues . snd) - where - p = placeGrid . fmap drawColorClue . clues <> grid gDefault - drawColorClue 'X' = fillBG black - drawColorClue c = case col c of - Nothing -> mempty - Just c' -> - text' [c] # scale 0.5 <> circle (1 / 3) # fc c' # draw <> fillBG black - drawColorLight c = case col c of - Nothing -> mempty - Just c' -> (text' [c] # scale 0.5 <> circle (1 / 3) # fc c' # lwG 0 # draw) - # scale 1.2 - 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 . edges . snd <> areas' . fst) - where - ends_ = placeGrid . fmap end . clues . snd - areas' = (areas <> grid gDashed <> shadeGrid . fmap cols) . fst - cols c | isUpper c = Just (blend 0.25 black white) - | otherwise = Nothing +pentominous = + Drawers + (placeGrid . fmap char . clues <> grid gDashed) + (placeGrid . fmap char . clues . fst <> (areas <> grid gDashed) . snd) + +colorakari :: + Backend' b => Drawers b (Grid C (Maybe Char)) (Grid C (Maybe Char)) +colorakari = + Drawers + p + (p . fst <> placeGrid . fmap drawColorLight . clues . snd) + where + p = placeGrid . fmap drawColorClue . clues <> grid gDefault + drawColorClue 'X' = fillBG black + drawColorClue c = case col c of + Nothing -> mempty + Just c' -> + text' [c] # scale 0.5 <> circle (1 / 3) # fc c' # draw <> fillBG black + drawColorLight c = case col c of + Nothing -> mempty + Just c' -> + (text' [c] # scale 0.5 <> circle (1 / 3) # fc c' # lwG 0 # draw) + # scale 1.2 + 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 . edges . snd <> areas' . fst) + where + ends_ = placeGrid . fmap end . clues . snd + areas' = (areas <> grid gDashed <> shadeGrid . fmap cols) . fst + cols c + | isUpper c = Just (blend 0.25 black white) + | otherwise = Nothing mappingTable :: Backend' b => [(String, String)] -> Drawing b mappingTable = b . g - where - b = placeGrid . fmap text' <> 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 + where + b = placeGrid . fmap text' <> 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) +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 . text' $ show x ++ "-" ++ show y - h = sortOn fst . map (\(x, y) -> (y : [], show x)) - h' = map (\(x, y) -> (show x, y : [])) + `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 . text' $ 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 int . snd <> p . fst) - where - p = - placeGrid' - . Map.mapKeys midPoint - . fmap kropkiDot - <> grid gDefault - . Data.sizeGrid - . sz - n g = placeNoteTR (w, h) (text' ds # scale noteScale) - where - (w, h) = sz g - ds = "1-" ++ show h - sz m = Data.edgeSize m + where + p = + placeGrid' + . Map.mapKeys midPoint + . fmap kropkiDot + <> grid gDefault + . Data.sizeGrid + . sz + n g = placeNoteTR (w, h) (text' ds # scale noteScale) + where + (w, h) = sz g + ds = "1-" ++ show h + sz m = Data.edgeSize m statuepark :: Backend' b => Drawers b (Grid C (Maybe MasyuPearl)) (Grid C Bool) statuepark = Drawers p (p . fst <> shade . snd) - where p = placeGrid . fmap pearl . clues <> grid gDashed + where + p = placeGrid . fmap pearl . clues <> grid gDashed -pentominousBorders - :: Backend' b => Drawers b (Grid C (), [Edge N]) (Grid C Char) +pentominousBorders :: + Backend' b => Drawers b (Grid C (), [Edge N]) (Grid C Char) pentominousBorders = Drawers (edges . snd <> grid gDashed . fst) ((areas <> grid gDashed) . snd) smallHintRooms :: Backend' b => (AreaGrid, Grid C (Maybe Int)) -> Drawing b smallHintRooms = - ( (areas <> grid gDashed) - . fst - <> placeGrid - . fmap hintTL - . fmap show - . clues - . snd + ( (areas <> grid gDashed) + . fst + <> placeGrid + . fmap hintTL + . fmap show + . clues + . snd ) -nanroSignpost - :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Int) +nanroSignpost :: + Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Int) nanroSignpost = Drawers smallHintRooms (placeGrid . fmap int . snd <> smallHintRooms . fst) tomTom :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe String)) (Grid C Int) tomTom = Drawers p (placeGrid . fmap int . snd <> p . fst) - where - p = ((areas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd) + where + p = ((areas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd) -horseSnake - :: Backend' b => Drawers b (Grid C (Maybe (Either MEnd Int))) [Edge C] +horseSnake :: + Backend' b => Drawers b (Grid C (Maybe (Either MEnd Int))) [Edge C] horseSnake = Drawers p (solstyle . edges . snd <> p . fst) - where p = (placeGrid . fmap (either bigEnd int) . 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 <> edges . snd) - . snd - <> p - . fst - ) - where - p = placeOutside . fmap (fmap fraction) <> grid gDashed . Data.outsideGrid + where + p = (placeGrid . fmap (either bigEnd int) . 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 <> edges . snd) + . snd + <> p + . fst + ) + where + p = placeOutside . fmap (fmap fraction) <> grid gDashed . Data.outsideGrid pentopia :: Backend' b => Drawers b (Grid C (Maybe Myopia)) (Grid C Bool) pentopia = Drawers p (p . fst <> shade . snd) - where p = placeGrid . fmap myopia . clues <> grid gDefault - -greaterWall - :: Backend' b => Drawers b ([GreaterClue], [GreaterClue]) (Grid C Bool) -greaterWall = Drawers - ((placeMultiOutsideGW <> grid gDefault . Data.outsideGrid) . munge) - undefined - where - munge (rs, cs) = OC - (map (reverse . greaterClue) (reverse rs)) - [] - [] - (map (map (rotateBy (-1 / 4))) . map (reverse . greaterClue) $ cs) - -galaxies - :: Backend' b - => Drawers - b - (Grid C (), Grid N (), Grid C (), Map.Map (Edge N) ()) - AreaGrid + where + p = placeGrid . fmap myopia . clues <> grid gDefault + +greaterWall :: + Backend' b => Drawers b ([GreaterClue], [GreaterClue]) (Grid C Bool) +greaterWall = + Drawers + ((placeMultiOutsideGW <> grid gDefault . Data.outsideGrid) . munge) + undefined + where + munge (rs, cs) = + OC + (map (reverse . greaterClue) (reverse rs)) + [] + [] + (map (map (rotateBy (-1 / 4))) . map (reverse . greaterClue) $ cs) + +galaxies :: + Backend' b => + Drawers + b + (Grid C (), Grid N (), Grid C (), Map.Map (Edge N) ()) + AreaGrid galaxies = Drawers p (p . fst <> areas . 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 + 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 -> int i <> fillBG lightgray) . clues - -tents - :: Backend' b - => Drawers - b - (OutsideClues C (Maybe Int), Grid C (Maybe Tree)) - (Grid C (Maybe PlacedTent)) +mines = + Drawers + p + (p . fst <> placeGrid . fmap (const (pearl MBlack)) . Map.filter id . snd) + where + p = + grid gDefault <> placeGrid . fmap (\i -> int 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 tent . clues . snd) - where - p = - placeOutside - . fmap (fmap int) - . fst - <> placeGrid - . fmap tree - . clues - . snd - <> grid gDashed - . snd - -pentominoSums - :: Backend' b - => Drawers - b - (OutsideClues C [String], String) - ( Grid C (Either Pentomino Int) - , [(Char, Int)] - , OutsideClues C [String] - ) + where + p = + placeOutside + . fmap (fmap int) + . fst + <> placeGrid + . fmap tree + . 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) = - (((multiOutsideGrid ocs <> n (ocs, ds)) ||| strutX' 1.0 ||| emptyTable ocs) - `aboveT'` pentominos + where + p (ocs, ds) = + ( ((multiOutsideGrid ocs <> n (ocs, ds)) ||| strutX' 1.0 ||| emptyTable ocs) + `aboveT'` pentominos + ) + n (ocs, ds) = placeNoteTL (0, h ocs) (text' ds # scale noteScale) + h = snd . Data.outsideSize + emptyTable = mappingTable . emptys + emptys = map (\k -> (k, "")) . nub . sort . concat . Data.outsideValues + solgrid = + skel . fst3 . snd <> multiOutsideGrid . trd3 . snd <> cells . fst3 . snd + fst3 (x, _, _) = x + trd3 (_, _, z) = z + skel = skeletonStyle . edges . Data.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 -> int 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 -> multiOutsideGrid ocs `aboveT'` lITS) + ( skeletonStyle + . edges + . Data.skeletons + . clues + . snd + <> multiOutsideGrid + . fst + <> placeGrid + . fmap (const (fillBG gray)) + . clues + . snd ) - n (ocs, ds) = placeNoteTL (0, h ocs) (text' ds # scale noteScale) - h = snd . Data.outsideSize - emptyTable = mappingTable . emptys - emptys = map (\k -> (k, "")) . nub . sort . concat . Data.outsideValues - solgrid = - skel . fst3 . snd <> multiOutsideGrid . trd3 . snd <> cells . fst3 . snd - fst3 (x, _, _) = x - trd3 (_, _, z) = z - skel = skeletonStyle . edges . Data.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 -> int x + where + skeletonStyle = lc white . lwG (3 * onepix) + +coralLitso :: + Backend' b => + Drawers b (OutsideClues C [String]) (Grid C (Either Black Char)) +coralLitso = + Drawers + (\ocs -> multiOutsideGrid ocs `aboveT'` lITSO) + ( multiOutsideGrid + . fst + <> skeletonStyle + . edges + . Data.skeletons + . rights + . snd + <> placeGrid + . fmap (const (fillBG gray)) + . lefts + . snd ) - 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 -> multiOutsideGrid ocs `aboveT'` lITS) - ( skeletonStyle - . edges - . Data.skeletons - . clues - . snd - <> multiOutsideGrid - . 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 -> multiOutsideGrid ocs `aboveT'` lITSO) - ( multiOutsideGrid - . fst - <> skeletonStyle - . edges - . Data.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))) + 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 = placeOutside . fmap (fmap int) . fst - p = cs <> placeGrid . fmap bigEnd . clues . snd <> grid gDefault . snd - s = - cs - . fst - <> grid gDefault - . snd - <> placeGrid - . fmap (either (bigEnd <> gr) gr) - . clues - . snd - gr = const (fillBG gray) + where + cs = placeOutside . fmap (fmap int) . fst + p = cs <> placeGrid . fmap bigEnd . clues . snd <> grid gDefault . snd + s = + cs + . fst + <> grid gDefault + . snd + <> placeGrid + . fmap (either (bigEnd <> gr) gr) + . clues + . snd + gr = const (fillBG gray) countryRoad :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Loop C) countryRoad = Drawers smallHintRooms (solstyle . edges . snd <> smallHintRooms . fst) japsummasyu :: Backend' b => Drawers b (OutsideClues C [String]) () -japsummasyu = Drawers - ( placeMultiOutside - . fmap (fmap (scale outsideScale . text')) - <> grid gPlainDashed - . Data.outsideGrid - ) - (unimplemented "japsummasyu solution") - -arrowsudoku - :: Backend' b - => Drawers b (AreaGrid, Grid C (Maybe Int), [Thermometer]) (Grid C Int) -arrowsudoku = Drawers - ( areas - . fst3 - <> placeGrid - . fmap int - . clues - . snd3 - <> arrows - . trd3 - <> grid gDefault - . fst3 - ) - ( areas - . fst3 - . fst - <> placeGrid - . fmap int - . snd - <> thermos - . trd3 - . fst - <> grid gDefault - . fst3 - . fst - ) - where - fst3 (a, _, _) = a - snd3 (_, b, _) = b - trd3 (_, _, c) = c - -dualloop - :: Backend' b - => Drawers b (Grid C (Maybe Int), Grid N (Maybe Int)) (Loop N, Loop C) +japsummasyu = + Drawers + ( placeMultiOutside + . fmap (fmap (scale outsideScale . text')) + <> grid gPlainDashed + . Data.outsideGrid + ) + (unimplemented "japsummasyu solution") + +arrowsudoku :: + Backend' b => + Drawers b (AreaGrid, Grid C (Maybe Int), [Thermometer]) (Grid C Int) +arrowsudoku = + Drawers + ( areas + . fst3 + <> placeGrid + . fmap int + . clues + . snd3 + <> arrows + . trd3 + <> grid gDefault + . fst3 + ) + ( areas + . fst3 + . fst + <> placeGrid + . fmap int + . snd + <> thermos + . trd3 + . fst + <> grid gDefault + . fst3 + . fst + ) + where + fst3 (a, _, _) = a + snd3 (_, b, _) = b + trd3 (_, _, c) = c + +dualloop :: + Backend' b => + Drawers b (Grid C (Maybe Int), Grid N (Maybe Int)) (Loop N, Loop C) dualloop = Drawers p (s . snd <> p . fst) - where - p = - placeGrid - . fmap int - . clues - . fst - <> placeGrid - . fmap smallClue - . clues - . snd - <> grid gDashDash - . fst - smallClue x = scale (2 / 3) (int x <> circle 0.5 # fc white # lwG 0 # draw) - gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone - s = solstyle . edges . fst <> solstyle . edges . snd + where + p = + placeGrid + . fmap int + . clues + . fst + <> placeGrid + . fmap smallClue + . clues + . snd + <> grid gDashDash + . fst + smallClue x = scale (2 / 3) (int x <> circle 0.5 # fc white # lwG 0 # draw) + gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone + s = solstyle . edges . fst <> solstyle . edges . snd diff --git a/src/Draw/Pyramid.hs b/src/Draw/Pyramid.hs index d12e92d..9a4b292 100644 --- a/src/Draw/Pyramid.hs +++ b/src/Draw/Pyramid.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Draw.Pyramid where -import Diagrams.Prelude - -import Data.Pyramid -import Draw.Draw -import Draw.Elements -import Draw.Lib -import Draw.Grid +import Data.Pyramid +import Diagrams.Prelude +import Draw.Draw +import Draw.Elements +import Draw.Grid +import Draw.Lib pgray :: Colour Double pgray = blend 0.6 white black clue :: Backend' b => Maybe Int -> Drawing b -clue Nothing = mempty +clue Nothing = mempty clue (Just c) = text' (show c) cellc :: Backend' b => Bool -> Maybe Int -> Drawing b @@ -31,10 +30,10 @@ pyramid = alignBL' . vcat . map row . unPyr krow :: Backend' b => KropkiRow -> Drawing 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) + where + ccat = centerX' . hcat + clues = map (cellc s) cs + dots = interleave (map phantom'' clues) (map kropkiDot ks) kpyramid :: Backend' b => RowKropkiPyramid -> Drawing b kpyramid = alignBL' . vcat . map krow . unKP diff --git a/src/Draw/Render.hs b/src/Draw/Render.hs index 4c12c30..4c47b93 100644 --- a/src/Draw/Render.hs +++ b/src/Draw/Render.hs @@ -3,143 +3,141 @@ module Draw.Render where -import Control.Monad - -import System.FilePath.Posix -import Data.Yaml -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL - -import Diagrams.Prelude hiding ( parts - , render - , sc - ) - -import Data.Lib -import Data.Component -import Draw.Widths -import Data.Compose -import Parse.Code -import Parse.Component -import Draw.Generic -import Data.PuzzleTypes -import Draw.CmdLine -import qualified Draw.Code as Draw -import qualified Draw.Component as Draw -import Draw.Draw -import Draw.Lib ( Backend' ) -import Parse.Puzzle ( TypedPuzzle(..) ) - -data Params = Params - { paramFormat :: Format - , paramConfig :: Config - , paramOutputChoice :: OutputChoice - , paramScale :: Double - , paramCode :: Bool - , paramPuzzleFormat :: PuzzleFormat - } - -newtype ParseComponent a = PC { unPC :: TaggedComponent a } +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Component +import Data.Compose +import Data.Lib +import Data.PuzzleTypes +import Data.Yaml +import Diagrams.Prelude hiding + ( parts, + render, + sc, + ) +import Draw.CmdLine +import qualified Draw.Code as Draw +import qualified Draw.Component as Draw +import Draw.Draw +import Draw.Generic +import Draw.Lib (Backend') +import Draw.Widths +import Parse.Code +import Parse.Component +import Parse.Puzzle (TypedPuzzle (..)) +import System.FilePath.Posix + +data Params + = Params + { paramFormat :: Format, + paramConfig :: Config, + paramOutputChoice :: OutputChoice, + paramScale :: Double, + paramCode :: Bool, + paramPuzzleFormat :: PuzzleFormat + } + +newtype ParseComponent a = PC {unPC :: TaggedComponent a} instance FromJSON (ParseComponent a) where parseJSON v = PC <$> parseComponent v decodeAndDraw :: Params -> B.ByteString -> Either String BL.ByteString decodeAndDraw params b = case backend fmt of - BackendSVG -> withSize (renderBytesSVG fmt) toDiagram + BackendSVG -> withSize (renderBytesSVG fmt) toDiagram BackendRasterific -> withSize (renderBytesRasterific fmt) toDiagram - where - Params fmt cfg oc s code pfmt = params - u = case fmt of - PDF -> Points - _ -> Pixels - withSize - :: (Monad m, Backend' b) - => (SizeSpec V2 Double -> Diagram b -> BL.ByteString) - -> m (Diagram b) - -> m BL.ByteString - withSize f x = do - d <- x - let (w, h) = diagramSize d - sz = mkSizeSpec2D (Just $ toOutputWidth u (s * w)) - (Just $ toOutputWidth u (s * h)) - return $ f sz d - - toDiagram :: Backend' b => Either String (Diagram b) - toDiagram = do - components <- case pfmt of - PZL -> toComponentsPzl b - PZG -> toComponentsPzg b - render cfg components code oc - - toComponentsPzg - :: Backend' b => B.ByteString -> Either String [TaggedComponent (Drawing b)] - toComponentsPzg bytes = do - fmap (map unPC) . mapLeft (\e -> "parse failure: " ++ show e) $ decodeThrow - bytes - - toComponentsPzl - :: Backend' b => B.ByteString -> Either String [TaggedComponent (Drawing b)] - toComponentsPzl bytes = do - TP mt mrt p ms mc <- mapLeft (\e -> "parse failure: " ++ show e) - $ decodeThrow bytes - codeComponents <- case (code, mc) of - (True, Just c) -> mapLeft ("solution code parse failure: " ++) $ do - parsedCode <- parseEither parseCode c - return $ Draw.code parsedCode - _ -> pure [] - t' <- checkType (mrt `mplus` mt) - if isGeneric t' - then parseEither (generic t') (p, ms) - else do - (pzl, msol) <- parseEither (compose t') (p, ms) - let - fakeSize = (0, 0) - pc = - [ TaggedComponent (Just Puzzle) - $ PlacedComponent Atop - $ RawComponent fakeSize pzl - ] - sc = case msol of - Just sol -> - [ TaggedComponent (Just Solution) - $ PlacedComponent Atop - $ RawComponent fakeSize sol - ] - Nothing -> [] - return $ concat [pc, sc, codeComponents] + where + Params fmt cfg oc s code pfmt = params + u = case fmt of + PDF -> Points + _ -> Pixels + withSize :: + (Monad m, Backend' b) => + (SizeSpec V2 Double -> Diagram b -> BL.ByteString) -> + m (Diagram b) -> + m BL.ByteString + withSize f x = do + d <- x + let (w, h) = diagramSize d + sz = + mkSizeSpec2D + (Just $ toOutputWidth u (s * w)) + (Just $ toOutputWidth u (s * h)) + return $ f sz d + toDiagram :: Backend' b => Either String (Diagram b) + toDiagram = do + components <- case pfmt of + PZL -> toComponentsPzl b + PZG -> toComponentsPzg b + render cfg components code oc + toComponentsPzg :: + Backend' b => B.ByteString -> Either String [TaggedComponent (Drawing b)] + toComponentsPzg bytes = do + fmap (map unPC) . mapLeft (\e -> "parse failure: " ++ show e) $ + decodeThrow + bytes + toComponentsPzl :: + Backend' b => B.ByteString -> Either String [TaggedComponent (Drawing b)] + toComponentsPzl bytes = do + TP mt mrt p ms mc <- + mapLeft (\e -> "parse failure: " ++ show e) $ + decodeThrow bytes + codeComponents <- case (code, mc) of + (True, Just c) -> mapLeft ("solution code parse failure: " ++) $ do + parsedCode <- parseEither parseCode c + return $ Draw.code parsedCode + _ -> pure [] + t' <- checkType (mrt `mplus` mt) + if isGeneric t' + then parseEither (generic t') (p, ms) + else do + (pzl, msol) <- parseEither (compose t') (p, ms) + let fakeSize = (0, 0) + pc = + [ TaggedComponent (Just Puzzle) + $ PlacedComponent Atop + $ RawComponent fakeSize pzl + ] + sc = case msol of + Just sol -> + [ TaggedComponent (Just Solution) + $ PlacedComponent Atop + $ RawComponent fakeSize sol + ] + Nothing -> [] + return $ concat [pc, sc, codeComponents] data PuzzleFormat = PZL | PZG - deriving (Show, Ord, Eq) + deriving (Show, Ord, Eq) lookupPuzzleFormat :: FilePath -> Maybe PuzzleFormat lookupPuzzleFormat fp = case takeExtension fp of ".pzl" -> Just PZL ".pzg" -> Just PZG - _ -> Nothing + _ -> Nothing data OutputChoice = DrawPuzzle | DrawSolution | DrawExample - deriving Show + deriving (Show) -- | Optionally render the puzzle, its solution, or a side-by-side -- example with puzzle and solution. -render - :: Backend' b - => Config - -> [TaggedComponent (Drawing b)] - -> Bool - -> OutputChoice - -> Either String (Diagram b) +render :: + Backend' b => + Config -> + [TaggedComponent (Drawing b)] -> + Bool -> + OutputChoice -> + Either String (Diagram b) render config components code oc = fmap (bg white) $ d oc - where - d choice = case choice of - DrawPuzzle -> Right . fixup $ diagram config pzl - DrawSolution -> case msol of - Just sol -> Right . fixup $ diagram config sol - Nothing -> Left "missing solution" - DrawExample -> sideBySide <$> d DrawPuzzle <*> d DrawSolution - fixup = alignPixel . border borderwidth - sideBySide x y = x ||| strutX 2.0 ||| y - pzl = Draw.components $ extractPuzzle code components - msol = fmap Draw.components $ extractSolution code components - + where + d choice = case choice of + DrawPuzzle -> Right . fixup $ diagram config pzl + DrawSolution -> case msol of + Just sol -> Right . fixup $ diagram config sol + Nothing -> Left "missing solution" + DrawExample -> sideBySide <$> d DrawPuzzle <*> d DrawSolution + fixup = alignPixel . border borderwidth + sideBySide x y = x ||| strutX 2.0 ||| y + pzl = Draw.components $ extractPuzzle code components + msol = fmap Draw.components $ extractSolution code components diff --git a/src/Draw/Style.hs b/src/Draw/Style.hs index 554108f..2435746 100644 --- a/src/Draw/Style.hs +++ b/src/Draw/Style.hs @@ -1,56 +1,67 @@ module Draw.Style - ( LineStyle(..) - , FrameStyle(..) - , VertexStyle(..) - , GridStyle(..) - , gDefault - , gDefaultIrreg - , gDashed - , gDashedThick - , gPlain - , gPlainDashed - , gSlither + ( LineStyle (..), + FrameStyle (..), + VertexStyle (..), + GridStyle (..), + gDefault, + gDefaultIrreg, + gDashed, + gDashedThick, + gPlain, + gPlainDashed, + gSlither, ) where -import Draw.Widths +import Diagrams.Prelude +import Draw.Widths -import Diagrams.Prelude +data LineStyle + = LineNone + | LineThin + | LineDashed + | LineThick -data LineStyle = - LineNone - | LineThin - | LineDashed - | LineThick +data FrameStyle + = FrameStyle + { _fWidthFactor :: Double, + _fColour :: Colour Double + } -data FrameStyle = FrameStyle - { _fWidthFactor :: Double - , _fColour :: Colour Double - } +data VertexStyle + = VertexNone + | VertexDot -data VertexStyle = - VertexNone - | VertexDot +data GridStyle + = GridStyle + { _line :: LineStyle, + _border :: LineStyle, + _frame :: Maybe FrameStyle, + _vertex :: VertexStyle + } -data GridStyle = GridStyle - { _line :: LineStyle - , _border :: LineStyle - , _frame :: Maybe FrameStyle - , _vertex :: VertexStyle - } - -gDefault, gDefaultIrreg, gSlither, gDashed, gDashedThick, gPlain, gPlainDashed - :: GridStyle -gDefault = GridStyle LineThin - LineThin - (Just (FrameStyle framewidthfactor black)) - VertexNone +gDefault, + gDefaultIrreg, + gSlither, + gDashed, + gDashedThick, + gPlain, + gPlainDashed :: + GridStyle +gDefault = + GridStyle + LineThin + LineThin + (Just (FrameStyle framewidthfactor black)) + VertexNone gDefaultIrreg = GridStyle LineThin LineThick Nothing VertexNone gSlither = GridStyle LineNone LineNone Nothing VertexDot -gDashed = GridStyle LineDashed - LineThin - (Just (FrameStyle framewidthfactor black)) - VertexNone +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/Parse/Code.hs b/src/Parse/Code.hs index b6dd6fc..c45861e 100644 --- a/src/Parse/Code.hs +++ b/src/Parse/Code.hs @@ -2,31 +2,29 @@ module Parse.Code where -import Data.Code -import Parse.Util - -import Data.Yaml - -import Data.Maybe ( catMaybes ) +import Data.Code +import Data.Maybe (catMaybes) +import Data.Yaml +import Parse.Util 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) + $ [ 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/Component.hs b/src/Parse/Component.hs index 1e0e395..67adf95 100644 --- a/src/Parse/Component.hs +++ b/src/Parse/Component.hs @@ -2,50 +2,49 @@ module Parse.Component where -import Data.Yaml -import qualified Data.Map.Strict as Map - -import qualified Data.Elements as E -import Data.Component -import Data.Grid -import Data.GridShape -import qualified Parse.Util as Util +import Data.Component +import qualified Data.Elements as E +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map +import Data.Yaml +import qualified Parse.Util as Util parseComponent :: Value -> Parser (TaggedComponent a) parseComponent = withObject "Component" $ \o -> do - t <- o .: "type" :: Parser String - tag <- parseTag o + t <- o .: "type" :: Parser String + tag <- parseTag o place <- parsePlacement o - c <- case t of - "grid" -> parseGrid o + c <- case t of + "grid" -> parseGrid o "regions" -> Regions <$> parseRegions o - "nodes" -> NodeGrid <$> parseNodeGrid o - "cells" -> parseCellGrid o - "edges" -> EdgeGrid <$> parseEdgeGrid o - "full" -> parseFullGrid o - "note" -> Note <$> parseNote o - _ -> fail $ "unknown component type: " ++ t + "nodes" -> NodeGrid <$> parseNodeGrid o + "cells" -> parseCellGrid o + "edges" -> EdgeGrid <$> parseEdgeGrid o + "full" -> parseFullGrid o + "note" -> Note <$> parseNote o + _ -> fail $ "unknown component type: " ++ t pure $ TaggedComponent tag (PlacedComponent place c) parseTag :: Object -> Parser (Maybe Tag) parseTag o = do t <- o .:? "tag" :: Parser (Maybe String) case t of - Nothing -> pure Nothing - Just "puzzle" -> pure (Just Puzzle) + Nothing -> pure Nothing + Just "puzzle" -> pure (Just Puzzle) Just "solution" -> pure (Just Solution) - Just "code" -> pure (Just Code) - Just x -> fail $ "unknown tag: " ++ x + Just "code" -> pure (Just Code) + Just x -> fail $ "unknown tag: " ++ x parsePlacement :: Object -> Parser Placement parsePlacement o = do p <- o .:? "place" :: Parser (Maybe String) case p of - Nothing -> pure Atop - Just "north" -> pure North - Just "west" -> pure West + Nothing -> pure Atop + Just "north" -> pure North + Just "west" -> pure West Just "top-right" -> pure TopRight - Just x -> fail $ "unknown placement: " ++ x + Just x -> fail $ "unknown placement: " ++ x data Shape = ShapeSquare | ShapeShifted @@ -53,29 +52,29 @@ parseShape :: Object -> Parser Shape parseShape o = do s <- o .:? "shape" case s of - Nothing -> pure ShapeSquare - Just "square" -> pure ShapeSquare + Nothing -> pure ShapeSquare + Just "square" -> pure ShapeSquare Just "shifted" -> pure ShapeShifted - Just x -> fail $ "unknown shape: " ++ x + Just x -> fail $ "unknown shape: " ++ x parseGrid :: Object -> Parser (Component a) parseGrid o = do - g <- o .: "grid" >>= Util.parseIrregGrid - s <- o .: "style" + g <- o .: "grid" >>= Util.parseIrregGrid + s <- o .: "style" gs <- case s of - "default" -> pure GridDefault + "default" -> pure GridDefault "default-irregular" -> pure GridDefaultIrregular - "dashed" -> pure GridDashed - "dots" -> pure GridDots - "plain" -> pure GridPlain - "plain-dashed" -> pure GridPlainDashed - _ -> fail $ "unknown grid style: " ++ s + "dashed" -> pure GridDashed + "dots" -> pure GridDots + "plain" -> pure GridPlain + "plain-dashed" -> pure GridPlainDashed + _ -> fail $ "unknown grid style: " ++ s sh <- parseShape o case sh of - ShapeSquare -> pure $ Grid gs g + ShapeSquare -> pure $ Grid gs g ShapeShifted -> case gs of GridPlain -> pure $ Pyramid (Map.mapKeys ShiftC g) - _ -> fail $ "unsupported shifted grid style: " ++ s + _ -> fail $ "unsupported shifted grid style: " ++ s parseRegions :: Object -> Parser (Grid C Char) parseRegions o = do @@ -91,11 +90,11 @@ parseNodeGrid o = do parseCellGrid :: Object -> Parser (Component a) parseCellGrid o = do sh <- parseShape o - g <- o .: "grid" - r <- parseReplacements o + g <- o .: "grid" + r <- parseReplacements o gg <- Util.parseGridWith (parseDecorationWithReplacements r) g pure $ case sh of - ShapeSquare -> CellGrid gg + ShapeSquare -> CellGrid gg ShapeShifted -> CellPyramid $ Map.mapKeys ShiftC $ gg parseEdgeGrid :: Object -> Parser (Map.Map (Edge N) Decoration) @@ -122,83 +121,83 @@ parseReplacements o = do ms <- o .:? "substitute" case ms of Nothing -> pure Map.empty - Just s -> Util.parseCharMapWith parseExtendedDecoration s + Just s -> Util.parseCharMapWith parseExtendedDecoration s -parseDecorationWithReplacements - :: Map.Map Char Decoration -> Char -> Parser Decoration +parseDecorationWithReplacements :: + Map.Map Char Decoration -> Char -> Parser Decoration parseDecorationWithReplacements repl c = case Map.lookup c repl of Just dec -> pure dec - Nothing -> parseDecoration c + Nothing -> parseDecoration c parseDecoration :: Char -> Parser Decoration parseDecoration c = return $ case c of - '.' -> Blank - 'o' -> DecKropkiDot E.KWhite - '*' -> DecKropkiDot E.KBlack - '/' -> DarkDiagonal $ E.PrimeDiag (True, False) + '.' -> Blank + 'o' -> DecKropkiDot E.KWhite + '*' -> DecKropkiDot E.KBlack + '/' -> DarkDiagonal $ E.PrimeDiag (True, False) '\\' -> DarkDiagonal $ E.PrimeDiag (False, True) - '#' -> Shade - '-' -> Edge Horiz - '|' -> Edge Vert - '>' -> TriangleRight - 'v' -> TriangleDown - _ -> Letter c + '#' -> Shade + '-' -> Edge Horiz + '|' -> Edge Vert + '>' -> TriangleRight + 'v' -> TriangleDown + _ -> Letter c parseExtendedDecoration :: Util.IntString -> Parser Decoration parseExtendedDecoration (Util.IntString s) = case words s of [w1] -> case w1 of - "kropki-white" -> pure $ DecKropkiDot E.KWhite - "kropki-black" -> pure $ DecKropkiDot E.KBlack + "kropki-white" -> pure $ DecKropkiDot E.KWhite + "kropki-black" -> pure $ DecKropkiDot E.KBlack "small-pearl-white" -> pure $ SmallPearl E.MWhite "small-pearl-black" -> pure $ SmallPearl E.MBlack - "pearl-white" -> pure $ Pearl E.MWhite - "pearl-black" -> pure $ Pearl E.MBlack - "blank" -> pure Blank - "afternoon-west" -> pure $ AfternoonWest - "afternoon-south" -> pure $ AfternoonSouth + "pearl-white" -> pure $ Pearl E.MWhite + "pearl-black" -> pure $ Pearl E.MBlack + "blank" -> pure Blank + "afternoon-west" -> pure $ AfternoonWest + "afternoon-south" -> pure $ AfternoonSouth "light-diagonal-forward" -> pure $ LightDiagonal $ E.PrimeDiag (True, False) - "light-diagonal-back" -> pure $ LightDiagonal $ E.PrimeDiag (False, True) - "light-diagonal-both" -> pure $ LightDiagonal $ E.PrimeDiag (True, True) + "light-diagonal-back" -> pure $ LightDiagonal $ E.PrimeDiag (False, True) + "light-diagonal-both" -> pure $ LightDiagonal $ E.PrimeDiag (True, True) "dark-diagonal-forward" -> pure $ DarkDiagonal $ E.PrimeDiag (True, False) - "dark-diagonal-back" -> pure $ DarkDiagonal $ E.PrimeDiag (False, True) - "dark-diagonal-both" -> pure $ DarkDiagonal $ E.PrimeDiag (True, True) - "edge-horiz" -> pure $ Edge Horiz - "edge-vert" -> pure $ Edge Vert - "thin-edge-horiz" -> pure $ ThinEdge Horiz - "thin-edge-vert" -> pure $ ThinEdge Vert - "sol-edge-horiz" -> pure $ SolEdge Horiz - "sol-edge-vert" -> pure $ SolEdge Vert - "dot" -> pure $ Dot - "small-dot" -> pure $ SmallDot - "star" -> pure $ Star - "shade" -> pure $ Shade - "dark-shade" -> pure $ DarkShade - "black" -> pure $ Black - "light-shade" -> pure $ LightShade - "triangle-right" -> pure $ TriangleRight - "triangle-down" -> pure $ TriangleDown - "miniloop" -> pure $ MiniLoop - "ship-square" -> pure $ ShipSquare - "ship-end-left" -> pure $ Ship R - "ship-end-right" -> pure $ Ship L - "ship-end-top" -> pure $ Ship D - "ship-end-bottom" -> pure $ Ship U - "tent" -> pure $ Tent - "tree" -> pure $ Tree - _ -> pure $ Letters s + "dark-diagonal-back" -> pure $ DarkDiagonal $ E.PrimeDiag (False, True) + "dark-diagonal-both" -> pure $ DarkDiagonal $ E.PrimeDiag (True, True) + "edge-horiz" -> pure $ Edge Horiz + "edge-vert" -> pure $ Edge Vert + "thin-edge-horiz" -> pure $ ThinEdge Horiz + "thin-edge-vert" -> pure $ ThinEdge Vert + "sol-edge-horiz" -> pure $ SolEdge Horiz + "sol-edge-vert" -> pure $ SolEdge Vert + "dot" -> pure $ Dot + "small-dot" -> pure $ SmallDot + "star" -> pure $ Star + "shade" -> pure $ Shade + "dark-shade" -> pure $ DarkShade + "black" -> pure $ Black + "light-shade" -> pure $ LightShade + "triangle-right" -> pure $ TriangleRight + "triangle-down" -> pure $ TriangleDown + "miniloop" -> pure $ MiniLoop + "ship-square" -> pure $ ShipSquare + "ship-end-left" -> pure $ Ship R + "ship-end-right" -> pure $ Ship L + "ship-end-top" -> pure $ Ship D + "ship-end-bottom" -> pure $ Ship U + "tent" -> pure $ Tent + "tree" -> pure $ Tree + _ -> pure $ Letters s [w1, w2] -> case w1 of - "triangle-right" -> pure $ LabeledTriangleRight w2 - "triangle-down" -> pure $ LabeledTriangleDown w2 - "arrow-right" -> pure $ LabeledArrow R w2 - "arrow-left" -> pure $ LabeledArrow L w2 - "arrow-up" -> pure $ LabeledArrow U w2 - "arrow-down" -> pure $ LabeledArrow D w2 - "inverted-arrow-down" -> pure $ InvertedLabeledArrow D w2 + "triangle-right" -> pure $ LabeledTriangleRight w2 + "triangle-down" -> pure $ LabeledTriangleDown w2 + "arrow-right" -> pure $ LabeledArrow R w2 + "arrow-left" -> pure $ LabeledArrow L w2 + "arrow-up" -> pure $ LabeledArrow U w2 + "arrow-down" -> pure $ LabeledArrow D w2 + "inverted-arrow-down" -> pure $ InvertedLabeledArrow D w2 "inverted-arrow-right" -> pure $ InvertedLabeledArrow R w2 - "inverted-arrow-left" -> pure $ InvertedLabeledArrow L w2 - "inverted-arrow-up" -> pure $ InvertedLabeledArrow U w2 - "inverted-letters" -> pure $ InvertedLetters w2 - "myopia" -> Myopia <$> (sequence . map Util.parseChar $ w2) - _ -> fail $ "unknown unary function: " ++ w1 + "inverted-arrow-left" -> pure $ InvertedLabeledArrow L w2 + "inverted-arrow-up" -> pure $ InvertedLabeledArrow U w2 + "inverted-letters" -> pure $ InvertedLetters w2 + "myopia" -> Myopia <$> (sequence . map Util.parseChar $ w2) + _ -> fail $ "unknown unary function: " ++ w1 _ -> fail $ "unknown decoration: " ++ show s diff --git a/src/Parse/Parsec.hs b/src/Parse/Parsec.hs index e42d6a9..eb02950 100644 --- a/src/Parse/Parsec.hs +++ b/src/Parse/Parsec.hs @@ -1,28 +1,28 @@ -- | Parsec helper for puzzle file parsing. module Parse.Parsec - ( toParser - , toStringParser - , fraction + ( 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 +import Control.Applicative +import Data.Elements +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import Text.ParserCombinators.Parsec hiding + ( (<|>), + ) toParser :: GenParser a () b -> [a] -> Yaml.Parser b toParser p v = case parse p "(unknown)" v of - Left e -> fail (show e) + 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" + _ -> fail "expected string" -- | fraction is meant to parse things like "1 1/2", "3/10", "7". fraction :: GenParser Char st Fraction diff --git a/src/Parse/Puzzle.hs b/src/Parse/Puzzle.hs index 184ce8b..ad53ed0 100644 --- a/src/Parse/Puzzle.hs +++ b/src/Parse/Puzzle.hs @@ -2,25 +2,28 @@ module Parse.Puzzle where -import Data.Yaml -import Control.Applicative +import Control.Applicative +import Data.Yaml -data TypedPuzzle = TP - { _tpType :: Maybe String - , _tpRenderAs :: Maybe String - , _tpPuzzle :: Value - , _tpSolution :: Maybe Value - , _tpCode :: Maybe Value - } deriving Show +data TypedPuzzle + = TP + { _tpType :: Maybe String, + _tpRenderAs :: Maybe String, + _tpPuzzle :: Value, + _tpSolution :: Maybe Value, + _tpCode :: Maybe Value + } + deriving (Show) instance FromJSON TypedPuzzle where - parseJSON (Object v) = TP <$> - v .:? "type" <*> - v .:? "render-as" <*> - v .: "puzzle" <*> - v .:? "solution" <*> - v .:? "code" - parseJSON _ = empty + parseJSON (Object v) = + TP + <$> v .:? "type" + <*> v .:? "render-as" + <*> v .: "puzzle" + <*> v .:? "solution" + <*> v .:? "code" + parseJSON _ = empty -- | A pair of parsers for a puzzle type. -- First parses the puzzle, second the solution. diff --git a/src/Parse/PuzzleTypes.hs b/src/Parse/PuzzleTypes.hs index 5dbba67..0763e60 100644 --- a/src/Parse/PuzzleTypes.hs +++ b/src/Parse/PuzzleTypes.hs @@ -2,96 +2,94 @@ {-# LANGUAGE TypeFamilies #-} module Parse.PuzzleTypes - ( lits - , geradeweg - , fillomino - , masyu - , nurikabe - , latintapa - , sudoku - , thermosudoku - , pyramid - , kpyramid - , slither - , liarslither - , tightfitskyscrapers - , wordloop - , wordsearch - , curvedata - , doubleback - , slalom - , compass - , meanderingnumbers - , tapa - , japanesesums - , coral - , maximallengths - , labyrinth - , bahnhof - , cave - , angleLoop - , shikaku - , slovaksums - , blackoutDominos - , anglers - , skyscrapers - , summon - , baca - , buchstabensalat - , doppelblock - , sudokuDoppelblock - , dominos - , skyscrapersStars - , numberlink - , dominoPills - , fillominoLoop - , loopki - , scrabble - , neighbors - , heyawake - , pentominous - , starbattle - , colorakari - , persistenceOfMemory - , abctje - , kropki - , statuepark - , pentominousBorders - , nanroSignpost - , tomTom - , horseSnake - , illumination - , pentopia - , greaterWall - , galaxies - , mines - , tents - , pentominoSums - , coralLits - , coralLitso - , snake - , countryRoad - , killersudoku - , japsummasyu - , arrowsudoku - , dualloop - , yajilin + ( lits, + geradeweg, + fillomino, + masyu, + nurikabe, + latintapa, + sudoku, + thermosudoku, + pyramid, + kpyramid, + slither, + liarslither, + tightfitskyscrapers, + wordloop, + wordsearch, + curvedata, + doubleback, + slalom, + compass, + meanderingnumbers, + tapa, + japanesesums, + coral, + maximallengths, + labyrinth, + bahnhof, + cave, + angleLoop, + shikaku, + slovaksums, + blackoutDominos, + anglers, + skyscrapers, + summon, + baca, + buchstabensalat, + doppelblock, + sudokuDoppelblock, + dominos, + skyscrapersStars, + numberlink, + dominoPills, + fillominoLoop, + loopki, + scrabble, + neighbors, + heyawake, + pentominous, + starbattle, + colorakari, + persistenceOfMemory, + abctje, + kropki, + statuepark, + pentominousBorders, + nanroSignpost, + tomTom, + horseSnake, + illumination, + pentopia, + greaterWall, + galaxies, + mines, + tents, + pentominoSums, + coralLits, + coralLitso, + snake, + countryRoad, + killersudoku, + japsummasyu, + arrowsudoku, + dualloop, + yajilin, ) 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 +import Control.Applicative +import Control.Monad +import Data.Elements +import Data.Grid +import Data.GridShape +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Pyramid as Pyr +import Data.Yaml +import Parse.Puzzle +import Parse.Util unimplemented :: String -> Value -> Parser () unimplemented _ _ = pure () @@ -106,13 +104,14 @@ 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 - ) +fillominoLoop = + (,) + parseClueGrid + ( \v -> + (,) + <$> parseFrom ["grid"] parseExtGrid v + <*> parseFrom ["loop"] parseEdges v + ) masyu :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop C) masyu = (parseClueGrid, parseEdges) @@ -127,20 +126,21 @@ latintapa = 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 :: + 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 +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) @@ -151,51 +151,61 @@ kpyramid = (parseJSON, parseJSON) slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N) slither = (parseClueGrid, parseEdges) -newtype LSol = LSol { unLSol :: (Loop N, Grid C Bool) } +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 + 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 :: + ParsePuzzle + (OutsideClues C (Maybe Int), Grid C (Tightfit ())) + (Grid C (Tightfit Int)) tightfitskyscrapers = (parseTightOutside, parseSpacedGrid) -newtype GridWords = GW { unGW :: (Grid C (Maybe Char), [String]) } +newtype GridWords = GW {unGW :: (Grid C (Maybe Char), [String])} instance FromJSON GridWords where - parseJSON (Object v) = GW <$> ((,) <$> - (fmap blankToMaybe <$> (parseIrregGrid =<< v .: "grid")) <*> - v .: "words") - parseJSON _ = empty + parseJSON (Object v) = + GW + <$> ( (,) + <$> (fmap blankToMaybe <$> (parseIrregGrid =<< 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]) } +newtype GridMarked = GM {unGM :: (Grid C (Maybe Char), [MarkedWord])} instance FromJSON GridMarked where - parseJSON (Object v) = GM <$> ((,) <$> - (fmap blankToMaybe <$> (parseIrregGrid =<< v .: "grid")) <*> - (map unPMW <$> v .: "words")) - parseJSON _ = mzero - -wordsearch - :: ParsePuzzle - (Grid C (Maybe Char), [String]) - (Grid C (Maybe Char), [MarkedWord]) + parseJSON (Object v) = + GM + <$> ( (,) + <$> (fmap blankToMaybe <$> (parseIrregGrid =<< 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] } +newtype Curve = Curve {unCurve :: [Edge N]} instance FromJSON Curve where - parseJSON v = Curve <$> parseEdges v + parseJSON v = Curve <$> parseEdges v curvedata :: ParsePuzzle (Grid C (Maybe [Edge N])) [Edge C] curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parseEdges) @@ -209,27 +219,27 @@ slalom = (parseClueGrid, parseGrid) compass :: ParsePuzzle (Grid C (Maybe CompassC)) AreaGrid compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid) - -meanderingnumbers - :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C (Maybe Int)) -meanderingnumbers = (,) - (\v -> - (,) - <$> parseFrom ["regions"] parseGrid v - <*> parseFrom ["clues"] parseGrid v - ) - parseGrid +meanderingnumbers :: + ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C (Maybe Int)) +meanderingnumbers = + (,) + ( \v -> + (,) + <$> parseFrom ["regions"] parseGrid v + <*> parseFrom ["clues"] parseGrid v + ) + 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 :: + ParsePuzzle (OutsideClues C [Int], String) (Grid C (Either Black Int)) japanesesums = (p, parseGrid) - where - p v@(Object o) = (,) <$> parseMultiOutsideClues v <*> o .: "digits" - p _ = empty + where + p v@(Object o) = (,) <$> parseMultiOutsideClues v <*> o .: "digits" + p _ = empty coral :: ParsePuzzle (OutsideClues C [String]) (Grid C Bool) coral = @@ -238,31 +248,32 @@ coral = maximallengths :: ParsePuzzle (OutsideClues C (Maybe Int)) (Loop C) maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v, parseEdges) -labyrinth - :: ParsePuzzle (Grid C (Maybe Int), [Edge N], String) (Grid C (Maybe Int)) +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) + 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 - ) +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) @@ -270,19 +281,19 @@ 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 :: + 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 + 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 :: + ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Fish)) [Edge C] anglers = - ( parseOutsideGridMap blankToMaybe blankToMaybe' - , \v -> map (shift (-1, -1)) <$> parseEdges v + ( parseOutsideGridMap blankToMaybe blankToMaybe', + \v -> map (shift (-1, -1)) <$> parseEdges v ) cave :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) @@ -291,139 +302,142 @@ cave = (parseExtClueGrid, 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 +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 :: + 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)) + 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 + (,,) + <$> 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 :: + 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 + (,,) + <$> 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)) + 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)) + 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 :: + ParsePuzzle + (AreaGrid, OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) sudokuDoppelblock = ( \v -> - (,) - <$> parseFrom ["grid"] parseGrid v - <*> parseFrom ["outside"] parseOutInts v - , parseGrid + (,) + <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["outside"] parseOutInts v, + parseGrid ) - where parseOutInts v = fmap (blankToMaybe' . unEither') <$> parseOutside v + 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 + 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 + 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 + 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 + 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 + where + p v = + (,) + <$> parseFrom ["shading"] parseShadedGrid v + <*> parseFrom ["clues"] parseGrid 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 + 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 + where + p v = + (,) + <$> parseFrom ["rooms"] parseGrid v + <*> parseFrom ["clues"] parseClueGrid v pentominous :: ParsePuzzle (Grid C (Maybe Char)) (Grid C Char) pentominous = (,) parseClueGrid parseGrid @@ -433,20 +447,22 @@ colorakari = (,) parseClueGrid parseClueGrid persistenceOfMemory :: ParsePuzzle (AreaGrid, Grid C (Maybe MEnd)) (Loop C) persistenceOfMemory = (p, parseEdges) - 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 - ) + 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 @@ -456,20 +472,19 @@ persistenceOfMemory = (p, parseEdges) - 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 +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 @@ -481,93 +496,97 @@ 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 +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 +tomTom = + (,) + ( \v -> + (,) + <$> parseFrom ["rooms"] parseGrid v + <*> parseFrom ["clues"] ((unRG <$>) . parseJSON) v + ) + parseGrid horseSnake :: ParsePuzzle (Grid C (Maybe (Either MEnd Int))) [Edge C] horseSnake = (parseGrid, parseEdges) -illumination - :: ParsePuzzle - (OutsideClues C (Maybe Fraction)) - (Grid N (Maybe PlainNode), [Edge N]) +illumination :: + ParsePuzzle + (OutsideClues C (Maybe Fraction)) + (Grid N (Maybe PlainNode), [Edge N]) illumination = (,) (fmap (fmap (fmap unPFraction)) . parseOut) parseNodeEdges -newtype Myo = Myo { unMyo :: Myopia } +newtype Myo = Myo {unMyo :: Myopia} + instance FromJSON Myo where - parseJSON v = do - s <- parseJSON v - fmap Myo . sequence . map parseChar $ s + 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 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'' +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 :: + 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]) + 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 + 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) @@ -575,77 +594,84 @@ 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 :: + 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 + where + p v = + (,) + <$> parseFrom ["clues"] parseOut v + <*> parseFrom ["grid"] parseClueGrid v countryRoad :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Loop C) countryRoad = (,) (fst nanroSignpost) parseEdges japsummasyu :: ParsePuzzle (OutsideClues C [String]) () -japsummasyu = (,) (fmap (fmap (map unIntString)) . parseMultiOutsideClues) - (unimplemented "japsummasyu solution") - -arrowsudoku - :: ParsePuzzle (AreaGrid, Grid C (Maybe Int), [Thermometer]) (Grid C Int) -arrowsudoku = (,) - (\v -> - (,,) - <$> parseFrom ["regions"] parseGrid v - <*> parseFrom ["givens"] parseClueGrid v - <*> (do - g <- parseFrom ["arrows"] parseJSON v - snd <$> parseThermoGrid g - ) - ) - parseGrid +japsummasyu = + (,) + (fmap (fmap (map unIntString)) . parseMultiOutsideClues) + (unimplemented "japsummasyu solution") + +arrowsudoku :: + ParsePuzzle (AreaGrid, Grid C (Maybe Int), [Thermometer]) (Grid C Int) +arrowsudoku = + (,) + ( \v -> + (,,) + <$> parseFrom ["regions"] parseGrid v + <*> parseFrom ["givens"] parseClueGrid v + <*> ( do + g <- parseFrom ["arrows"] parseJSON v + snd <$> parseThermoGrid g + ) + ) + parseGrid dualloop :: ParsePuzzle (Grid C (Clue Int), Grid N (Clue Int)) (Loop N, Loop C) -dualloop = (,) - (\v -> - (,) - <$> parseFrom ["edges"] parseClueGrid v - <*> parseFrom ["dual"] parseClueGrid v - ) - (\v -> - (,) <$> parseFrom ["edges"] parseEdges v <*> parseFrom ["dual"] parseEdges v - ) - -yajilin - :: ParsePuzzle (Grid C (Maybe (Maybe (Int, Dir')))) (Grid C Bool, Loop C) -yajilin = (,) - (\v -> do - replace <- parseFrom ["clues"] - (parseCharMapWith (fmap Just . parseYajClue)) - v - parseFrom ["grid"] - (parseGridWith (parseYajOrBlank (`Map.lookup` replace))) - v - ) - (\v -> unShade . toCells <$> parseNodeEdges v) - where - parseYajOrBlank repl c = case c of - '.' -> pure Nothing - _ -> pure $ repl c - parseYajClue s = case words s of - [a, b] -> (,) <$> parseString a <*> parseDir b - _ -> fail "expected " - parseDir s = case s of - "right" -> pure R - "left" -> pure L - "up" -> pure U - "down" -> pure D - _ -> fail "expected right/left/up/down" - unShade (g, l) = (unShaded <$> g, l) - toCell :: N -> C - toCell = fromCoord . toCoord - toCells :: (Grid N a, [Edge N]) -> (Grid C a, [Edge C]) - toCells (x, y) = (Map.mapKeys toCell x, map (mapEdge toCell) y) +dualloop = + (,) + ( \v -> + (,) + <$> parseFrom ["edges"] parseClueGrid v + <*> parseFrom ["dual"] parseClueGrid v + ) + ( \v -> + (,) <$> parseFrom ["edges"] parseEdges v <*> parseFrom ["dual"] parseEdges v + ) +yajilin :: + ParsePuzzle (Grid C (Maybe (Maybe (Int, Dir')))) (Grid C Bool, Loop C) +yajilin = + (,) + ( \v -> do + replace <- + parseFrom + ["clues"] + (parseCharMapWith (fmap Just . parseYajClue)) + v + parseFrom + ["grid"] + (parseGridWith (parseYajOrBlank (`Map.lookup` replace))) + v + ) + (\v -> unShade . toCells <$> parseNodeEdges v) + where + parseYajOrBlank repl c = case c of + '.' -> pure Nothing + _ -> pure $ repl c + parseYajClue s = case words s of + [a, b] -> (,) <$> parseString a <*> parseDir b + _ -> fail "expected " + parseDir s = case s of + "right" -> pure R + "left" -> pure L + "up" -> pure U + "down" -> pure D + _ -> fail "expected right/left/up/down" + unShade (g, l) = (unShaded <$> g, l) + toCell :: N -> C + toCell = fromCoord . toCoord + toCells :: (Grid N a, [Edge N]) -> (Grid C a, [Edge C]) + toCells (x, y) = (Map.mapKeys toCell x, map (mapEdge toCell) y) diff --git a/src/Parse/Util.hs b/src/Parse/Util.hs index 42d6755..a129580 100644 --- a/src/Parse/Util.hs +++ b/src/Parse/Util.hs @@ -1,78 +1,76 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# 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.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.Lib -import Data.Grid -import Data.GridShape -import Data.Elements - -import Parse.Parsec +import Control.Applicative +import Control.Arrow +import Control.Monad hiding (mapM) +import Data.Char + ( digitToInt, + isAlpha, + isDigit, + ) +import Data.Either (isRight) +import Data.Elements +import Data.Grid +import Data.GridShape +import qualified Data.HashMap.Strict as HMap +import Data.Lib +import Data.List + ( intersect, + sortBy, + ) +import qualified Data.Map.Strict as Map +import Data.Maybe + ( catMaybes, + fromJust, + fromMaybe, + isJust, + ) +import Data.Monoid ((<>)) +import Data.Ord (comparing) +import qualified Data.Text as T +import Data.Traversable (mapM) +import Data.Yaml +import Parse.Parsec +import Text.Read (readMaybe) +import Prelude hiding (mapM) 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' (f : _ ) _ = fail $ "expected field '" ++ T.unpack f ++ "'" + 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 ++ "'") +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 + parseChar :: Char -> Parser a instance FromChar Char where - parseChar = pure + parseChar = pure class FromString a where - parseString :: String -> Parser a + parseString :: String -> Parser a instance FromString Char where - parseString [c] = pure c - parseString s = fail $ "expected a single character, got `" ++ s ++ "`" + parseString [c] = pure c + parseString s = fail $ "expected a single character, got `" ++ s ++ "`" parseStringJSON :: FromString a => Value -> Parser a parseStringJSON v = parseJSON v >>= parseString @@ -81,113 +79,125 @@ 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] ++ "'" + parseChar c + | isDigit c = digitToInt <$> parseChar c + | otherwise = fail $ "expected a digit, got '" ++ [c] ++ "'" -newtype Alpha = Alpha { unAlpha :: Char } - deriving (Show, Ord, Eq) +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" + 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 } +newtype IntString = IntString {unIntString :: String} instance FromJSON IntString where - parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v - parseJSON v = IntString <$> parseJSON v + 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 + deriving (Show) instance Functor Rect where - fmap f (Rect w h ls) = Rect w h (map (map f) ls) + 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" + 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 + 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 + 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 + 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) + 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 + deriving (Show) -parseBorderedRect - :: (Char -> Parser a) - -> (Char -> Parser b) - -> Value - -> Parser (BorderedRect a b) +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) + 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] + mapM_ + ((parseChar :: Char -> Parser Space) . flip ($) ls) + [head . head, head . last, last . head, last . last] lsparsed <- mapM (mapM parseIn) ls' - bparsed <- mapM parseOut b + bparsed <- mapM parseOut b return $ BorderedRect (w - 2) (h - 2) lsparsed bparsed - where middle len = take (len - 2) . drop 1 + where + middle len = take (len - 2) . drop 1 instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where - parseJSON = parseBorderedRect parseChar parseChar + parseJSON = parseBorderedRect parseChar parseChar -newtype SpacedRect a = SpacedRect { unSpaced :: Rect a } +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 + 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 ['.', ' '] + parseChar = fmap (const ()) . chars ['.', ' '] data Space = Space instance FromChar Space where - parseChar = fmap (const Space) . char ' ' + 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 '.' + parseChar = fmap (const Blank) . char '.' parseCharJSON :: FromChar a => Value -> Parser a parseCharJSON v = do @@ -195,86 +205,86 @@ parseCharJSON v = do parseChar c instance FromJSON Blank where - parseJSON = parseCharJSON + parseJSON = parseCharJSON instance FromChar Blank' where - parseChar = fmap (const Blank') . chars ['.', '-'] + parseChar = fmap (const Blank') . chars ['.', '-'] instance FromJSON Blank' where - parseJSON (String ".") = pure Blank' - parseJSON (String "-") = pure Blank' - parseJSON _ = fail "expected '.-'" + parseJSON (String ".") = pure Blank' + parseJSON (String "-") = pure Blank' + parseJSON _ = fail "expected '.-'" instance FromChar Blank'' where - parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|'] + parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|'] instance FromChar Empty where - parseChar = fmap (const Empty) . char ' ' + parseChar = fmap (const Empty) . char ' ' instance FromString Blank where - parseString "." = pure Blank - parseString _ = fail "expected '.'" + parseString "." = pure Blank + parseString _ = fail "expected '.'" instance FromChar PlainNode where - parseChar = fmap (const PlainNode) . char 'o' + parseChar = fmap (const PlainNode) . char 'o' instance FromChar MasyuPearl where - parseChar = fmap f . chars ['*', 'o'] - where - f '*' = MBlack - f 'o' = MWhite - f _ = impossible + 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 + parseChar '/' = pure SlalomForward + parseChar '\\' = pure SlalomBackward + parseChar _ = empty instance FromChar Black where - parseChar = fmap (const Black) . chars "xX" + parseChar = fmap (const Black) . chars "xX" instance FromChar Fish where - parseChar = fmap (const Fish) . char '*' + parseChar = fmap (const Fish) . char '*' instance FromChar Star where - parseChar = fmap (const Star) . char '*' + parseChar = fmap (const Star) . char '*' instance FromChar MEnd where - parseChar = fmap (const MEnd) . chars "o*" + parseChar = fmap (const MEnd) . chars "o*" instance FromChar GalaxyCentre where - parseChar = fmap (const GalaxyCentre) . char 'o' + parseChar = fmap (const GalaxyCentre) . char 'o' instance FromChar Tree where - parseChar = fmap (const Tree) . char '*' + parseChar = fmap (const Tree) . char '*' instance FromChar PlacedTent where - parseChar = fmap Tent . parseChar + parseChar = fmap Tent . parseChar instance FromChar Pentomino where - parseChar c = - if c `elem` ("FILNPTUVWXYZ" :: String) then - pure (Pentomino c) - else - fail "expected FILNPTUVWXYZ" + 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 + 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 + parseString c = Left <$> parseString c <|> Right <$> parseString c -newtype Either' a b = Either' { unEither' :: Either a b } +newtype Either' a b = Either' {unEither' :: Either a b} instance (FromChar a, FromChar b) => FromChar (Either' a b) where - parseChar c = Either' <$> parseChar c + parseChar c = Either' <$> parseChar c instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where - parseJSON v = Either' <$> - (Left <$> parseJSON v <|> Right <$> parseJSON v) + parseJSON v = + Either' + <$> (Left <$> parseJSON v <|> Right <$> parseJSON v) instance FromChar a => FromChar (Maybe a) where - parseChar = optional . parseChar + parseChar = optional . parseChar listListToMap :: [[a]] -> Grid Coord a listListToMap ls = @@ -282,7 +292,8 @@ listListToMap ls = . concat . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0 ..]) [h - 1, h - 2 ..] $ ls - where h = length ls + where + h = length ls rectToCoordGrid :: Rect a -> Grid Coord a rectToCoordGrid (Rect _ _ ls) = listListToMap ls @@ -298,16 +309,16 @@ 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 + where + fromRight (Right r) = r + fromRight _ = impossible -newtype Shaded = Shaded { unShaded :: Bool } +newtype Shaded = Shaded {unShaded :: Bool} instance FromChar Shaded where - parseChar 'x' = pure . Shaded $ True - parseChar 'X' = pure . Shaded $ True - parseChar _ = pure . Shaded $ False + 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 @@ -324,8 +335,8 @@ parseGridWith pChar v = traverse pChar =<< parseGrid v parseWithReplacement :: FromChar a => (Char -> Maybe a) -> Char -> Parser a parseWithReplacement replace = parseWithReplacementWith replace parseChar -parseWithReplacementWith - :: (Char -> Maybe a) -> (Char -> Parser a) -> Char -> Parser a +parseWithReplacementWith :: + (Char -> Maybe a) -> (Char -> Parser a) -> Char -> Parser a parseWithReplacementWith replace p c = maybe (p c) pure (replace c) parseSpacedGrid :: (Key k, FromString a) => Value -> Parser (Grid k a) @@ -334,28 +345,29 @@ parseSpacedGrid v = fromCoordGrid . rectToCoordGrid . unSpaced <$> parseJSON v parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) parseCharMap = parseCharMapWith parseJSON -parseCharMapWith - :: FromJSON b => (b -> Parser a) -> Value -> Parser (Map.Map Char a) +parseCharMapWith :: + FromJSON b => (b -> Parser a) -> Value -> Parser (Map.Map Char a) parseCharMapWith p v = do mj <- parseJSON v - m <- sequence $ p <$> mj + m <- sequence $ p <$> mj 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' :: + (Key k, FromJSON a, FromChar b) => (a -> b) -> Value -> Parser (Grid k b) parseExtGrid' _ v@(String _) = parseGrid v -parseExtGrid' f v = do +parseExtGrid' f v = do repl <- fmap f <$> parseFrom ["replace"] parseCharMap v - parseFrom ["grid"] - (parseGridWith (parseWithReplacement (`Map.lookup` repl))) - 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 :: + (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 @@ -373,8 +385,8 @@ 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 :: + (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) @@ -391,33 +403,32 @@ parseEdges 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 + where + p (E _ Horiz) '-' = True + p (E _ Vert) '|' = True + p _ _ = False -parseAnnotatedEdges - :: (Key k, FromChar a) => Value -> Parser (Map.Map (Edge k) a) +parseAnnotatedEdges :: + (Key k, FromChar a) => Value -> Parser (Map.Map (Edge k) a) parseAnnotatedEdges = parseAnnotatedEdgesWith parseChar -parseAnnotatedEdgesWith - :: (Key k) => (Char -> Parser a) -> Value -> Parser (Map.Map (Edge k) a) +parseAnnotatedEdgesWith :: + (Key k) => (Char -> Parser a) -> Value -> Parser (Map.Map (Edge k) a) parseAnnotatedEdgesWith p v = do g <- readEdges <$> parseCoordGrid v Map.mapKeys fromCoordEdge <$> traverse p 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) + 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 @@ -428,37 +439,37 @@ parseGridChars = traverse parseChar -- |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 :: + (FromChar a, FromChar b, FromChar c) => + Value -> + Parser (Grid N a, Grid C b, Map.Map (Edge N) c) parseEdgeGrid = parseEdgeGridWith parseChar parseChar parseChar -parseEdgeGridWith - :: (Char -> Parser a) - -> (Char -> Parser b) - -> (Char -> Parser c) - -> Value - -> Parser (Grid N a, Grid C b, Map.Map (Edge N) c) +parseEdgeGridWith :: + (Char -> Parser a) -> + (Char -> Parser b) -> + (Char -> Parser c) -> + Value -> + Parser (Grid N a, Grid C b, Map.Map (Edge N) c) parseEdgeGridWith pn pc pe v = uncurry (,,) <$> parseBoth <*> parseAnnotatedEdgesWith pe v - where - parseBoth = do - g <- parseCoordGrid v - let (gn, gc) = halveGrid g - gn' <- traverse pn gn - gc' <- traverse pc 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]) + where + parseBoth = do + g <- parseCoordGrid v + let (gn, gc) = halveGrid g + gn' <- traverse pn gn + gc' <- traverse pc 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 @@ -470,160 +481,166 @@ parsePlainEdgeGrid v = -- 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) + 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) + where + proj23 :: (Grid N Char, Grid C a, [Edge N]) -> (Grid C a, [Edge N]) + proj23 (_, y, z) = (y, z) 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'" + 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'" 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 :: + 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) + 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') + 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) + 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) + 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 () } +newtype Tight = Tight {unTight :: Tightfit ()} instance FromChar Tight where - parseChar '.' = pure . Tight $ Single () - parseChar '/' = pure . Tight $ UR () () - parseChar '\\' = pure . Tight $ DR () () - parseChar _ = empty + 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 :: + 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 + 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 + 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 +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 + where + x = parseJSON v >>= parseNWords 4 >>= mapM parseString instance FromJSON PMarkedWord where - parseJSON v = PMW . uncurry MW <$> parseDoublePair v + parseJSON v = PMW . uncurry MW <$> parseDoublePair v instance FromString Int where - parseString s = maybe empty pure $ readMaybe s + 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 + 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" + 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) } +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 @@ -631,36 +648,38 @@ 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) } +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) + fmap f (MM m) = MM (fmap (fmap f) m) instance Foldable (MaybeMap k) where - foldMap f (MM m) = foldMap (foldMap f) m + foldMap f (MM m) = foldMap (foldMap f) m instance Traversable (MaybeMap k) where - traverse f m = MM <$> traverse (traverse f) (unMaybeMap m) + 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' :: + 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' + 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' -newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue } +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 + 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 @@ -668,65 +687,70 @@ 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" + <$> ( OC <$> pfield "left" <*> pfield "right" <*> pfield "bottom" + <*> pfield + "top" ) - where pfield f = parseLine . fromMaybe [] =<< v .:? f + 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" + <$> ( OC <$> pfield "left" <*> pfield "right" <*> pfield "bottom" + <*> pfield + "top" ) - where pfield f = pure . fromMaybe [] =<< v .:? f + 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) + 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 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 + 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' + 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 } +newtype PFraction = PFraction {unPFraction :: Fraction} instance FromJSON PFraction where - parseJSON v = PFraction <$> toStringParser fraction v + parseJSON v = PFraction <$> toStringParser fraction v instance FromChar Crossing where - parseChar '+' = pure Crossing - parseChar _ = fail "expected '+'" + 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 '" + 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 '<>= '" + parseChar '<' = pure RLess + parseChar '>' = pure RGreater + parseChar '=' = pure REqual + parseChar ' ' = pure RUndetermined + parseChar _ = fail "expected '<>= '" parseGreaterClues :: Value -> Parser [GreaterClue] parseGreaterClues v = do @@ -736,11 +760,11 @@ parseGreaterClues v = do 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 + 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/serve/Main.hs b/src/serve/Main.hs index 6c2edf4..e445088 100644 --- a/src/serve/Main.hs +++ b/src/serve/Main.hs @@ -4,45 +4,42 @@ module Main where -import Control.Applicative -import Control.Monad -import Data.Maybe -import Control.Monad.IO.Class -import Data.List ( sort ) -import Safe ( readMay ) - -import Snap.Core hiding ( getParams - , Params - , dir - ) -import Snap.Util.FileServe -import Snap.Http.Server hiding ( Config ) - -import qualified Data.Aeson as J -import Data.Yaml - -import Draw.CmdLine -import Draw.Draw -import Draw.Render -import Draw.Font ( fontAnelizaRegular - , fontBit - ) - -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL - -import System.Directory -import System.FilePath.Posix -import System.Environment -import Data.List ( stripPrefix ) +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as BL +import Data.List (sort) +import Data.List (stripPrefix) +import Data.Maybe +import Data.Yaml +import Draw.CmdLine +import Draw.Draw +import Draw.Font + ( fontAnelizaRegular, + fontBit, + ) +import Draw.Render +import Safe (readMay) +import Snap.Core hiding + ( Params, + dir, + getParams, + ) +import Snap.Http.Server hiding (Config) +import Snap.Util.FileServe +import System.Directory +import System.Environment +import System.FilePath.Posix main :: IO () main = do root <- lookupEnv "PUZZLE_DRAW_ROOT" case root of Just dir -> setCurrentDirectory dir - Nothing -> return () + Nothing -> return () quickHttpServe site site :: Snap () @@ -50,10 +47,10 @@ site = ifTop (serveFile "static/index.html") <|> route [("/static/puzzle.html", redirect "/")] -- old demo redirect <|> route - [ ("/api/preview" , previewPostHandler) - , ("/api/download", downloadPostHandler) - , ("/api/examples", examplesGetHandler) - ] + [ ("/api/preview", previewPostHandler), + ("/api/download", downloadPostHandler), + ("/api/examples", examplesGetHandler) + ] <|> serveDirectory "static" fail400 :: String -> Snap a @@ -65,11 +62,13 @@ fail400 e = do addContentDisposition :: Format -> B.ByteString -> Snap () addContentDisposition fmt filename = do - modifyResponse $ addHeader "Content-Disposition" - (B.concat ["attachment; filename=\"", n, "\""]) - where - n = B.filter (flip B.elem safe) filename <> "." <> (C.pack $ extension fmt) - safe = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-." + modifyResponse $ + addHeader + "Content-Disposition" + (B.concat ["attachment; filename=\"", n, "\""]) + where + n = B.filter (flip B.elem safe) filename <> "." <> (C.pack $ extension fmt) + safe = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-." contentType :: Format -> B.ByteString contentType fmt = case fmt of @@ -83,7 +82,7 @@ serveDiagram format name bs = do modifyResponse $ setContentType (contentType format) case name of Nothing -> return () - Just n -> addContentDisposition format n + Just n -> addContentDisposition format n writeLBS $ bs config :: Device -> Config @@ -94,49 +93,49 @@ getOutputChoice = do ocs <- maybe "puzzle" id <$> getParam "output" case ocs of "solution" -> return DrawSolution - "both" -> return DrawExample - "puzzle" -> return DrawPuzzle - _ -> fail400 "invalid parameter value: output" + "both" -> return DrawExample + "puzzle" -> return DrawPuzzle + _ -> fail400 "invalid parameter value: output" getDevice :: Format -> Snap Device getDevice fmt = do devs <- maybe "auto" id <$> getParam "device" return $ case (devs, fmt) of - ("screen", _ ) -> Screen - ("print" , _ ) -> Print - (_ , PDF) -> Print - _ -> Screen + ("screen", _) -> Screen + ("print", _) -> Print + (_, PDF) -> Print + _ -> Screen getBoolParam :: B.ByteString -> Snap Bool getBoolParam key = do param <- getParam key case fromMaybe "" param of - "yes" -> return True - "true" -> return True - "1" -> return True - "no" -> return False + "yes" -> return True + "true" -> return True + "1" -> return True + "no" -> return False "false" -> return False - "0" -> return False - "" -> return False - _ -> fail400 "invalid boolean parameter value" + "0" -> return False + "" -> return False + _ -> fail400 "invalid boolean parameter value" getFormat :: Snap Format getFormat = do fmt <- getParam "format" case fmt of Nothing -> return SVG - Just f -> case lookupFormat (C.unpack f) of - Nothing -> fail400 "invalid parameter value: format" + Just f -> case lookupFormat (C.unpack f) of + Nothing -> fail400 "invalid parameter value: format" Just format -> return format getPuzzleFormat :: Snap PuzzleFormat getPuzzleFormat = do fmt <- getParam "pformat" case fmt of - Nothing -> return PZL + Nothing -> return PZL Just "pzl" -> return PZL Just "pzg" -> return PZG - _ -> fail400 "invalid parameter value: pformat" + _ -> fail400 "invalid parameter value: pformat" getDouble :: B.ByteString -> Double -> Snap Double getDouble key defaultValue = do @@ -144,7 +143,7 @@ getDouble key defaultValue = do case param of Nothing -> return defaultValue Just "" -> return defaultValue - Just d -> case readMay (C.unpack d) of + Just d -> case readMay (C.unpack d) of Nothing -> fail400 "invalid number parameter" Just dd -> return dd @@ -160,49 +159,52 @@ getParams fmt = do previewPostHandler :: Snap () previewPostHandler = do params <- getParams SVG - body <- readRequestBody 4096 + body <- readRequestBody 4096 case decodeAndDraw params (BL.toStrict body) of - Left err -> fail400 err + Left err -> fail400 err Right bytes -> serveDiagram SVG Nothing bytes downloadPostHandler :: Snap () downloadPostHandler = do - body <- maybe "" id <$> getParam "pzl" + body <- maybe "" id <$> getParam "pzl" format <- getFormat params <- getParams format - fname <- maybe "" id <$> getParam "filename" + fname <- maybe "" id <$> getParam "filename" let filename = if fname == "" then "puzzle" else fname case decodeAndDraw params body of - Left e -> fail400 e + Left e -> fail400 e Right bytes -> serveDiagram format (Just filename) bytes -data Example = Example - { _name :: String - , _path :: FilePath - , _puzzleFormat :: PuzzleFormat } - deriving (Show, Ord, Eq) +data Example + = Example + { _name :: String, + _path :: FilePath, + _puzzleFormat :: PuzzleFormat + } + deriving (Show, Ord, Eq) instance ToJSON Example where - toJSON (Example n p f) = - object - [ "name" .= n - , "path" .= p - , "pformat" .= case f of - PZL -> "pzl" :: String - PZG -> "pzg" ] + toJSON (Example n p f) = + object + [ "name" .= n, + "path" .= p, + "pformat" .= case f of + PZL -> "pzl" :: String + PZG -> "pzg" + ] exampleFromPath :: FilePath -> Maybe Example exampleFromPath fp = case lookupPuzzleFormat fp of - Nothing -> Nothing + Nothing -> Nothing Just fmt -> do guard $ length n > 0 return $ Example n ("./examples" fp) fmt - where - n = stripSuffixMaybe "-example" $ takeBaseName fp - stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse - stripSuffixMaybe suffix str = case stripSuffix suffix str of - Just s -> s - Nothing -> str + where + n = stripSuffixMaybe "-example" $ takeBaseName fp + stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse + stripSuffixMaybe suffix str = case stripSuffix suffix str of + Just s -> s + Nothing -> str listExamples :: IO [Example] listExamples = do diff --git a/src/tools/checkpuzzle.hs b/src/tools/checkpuzzle.hs index 63cc36a..bab241c 100644 --- a/src/tools/checkpuzzle.hs +++ b/src/tools/checkpuzzle.hs @@ -2,157 +2,167 @@ module Main where -import Parse.Puzzle -import Data.PuzzleTypes ( typeOptions - , PuzzleType(..) - , checkType - ) - -import Data.Lib -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 qualified Data.ByteString as ByteString -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 +import Control.Monad +import qualified Data.ByteString as ByteString +import Data.Elements + ( KropkiDot (..), + digitList, + ) +import Data.Grid (Grid) +import Data.GridShape + ( C, + Edge, + N, + dualE, + edgesM, + ends, + rows, + unorient, + ) +import Data.Lib +import Data.List + ( intercalate, + sort, + ) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.PuzzleTypes + ( PuzzleType (..), + checkType, + typeOptions, + ) +import qualified Data.Yaml as Y +import Options.Applicative +import Parse.Puzzle +import qualified Parse.PuzzleTypes as T +import System.Environment (getProgName) +import System.Exit optListTypes :: Parser (a -> a) -optListTypes = infoOption - (unlines' typeOptions) - (long "list-types" <> help "List supported puzzle types") - where unlines' = intercalate "\n" - -data PuzzleOpts = PuzzleOpts - { _type :: Maybe String - , _input :: FilePath - } +optListTypes = + infoOption + (unlines' typeOptions) + (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" - ) + . 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) + let p = + info + (helper <*> optListTypes <*> optsParser) + (fullDesc <> progDesc "Command-line puzzle checking." <> header prog) execParser p main :: IO () main = do - opts <- defaultOpts puzzleOpts + opts <- defaultOpts puzzleOpts bytes <- ByteString.readFile (_input opts) - es <- orExit $ do - TP mt _ pv msv _ <- mapLeft (\e -> "parse failure: " ++ show e) - $ Y.decodeThrow bytes - t <- checkType $ _type opts `mplus` mt + es <- orExit $ do + TP mt _ pv msv _ <- + mapLeft (\e -> "parse failure: " ++ show e) $ + Y.decodeThrow bytes + t <- checkType $ _type opts `mplus` mt sv <- note "need solution" msv Y.parseEither (check t) (pv, sv) case es of [] -> exitSuccess - _ -> mapM_ putStrLn es >> exitFailure + _ -> mapM_ putStrLn es >> exitFailure orExit :: Either String a -> IO a -orExit (Left err) = putStrLn err >> exitFailure -orExit (Right r ) = return r +orExit (Left err) = putStrLn err >> exitFailure +orExit (Right r) = return r note :: String -> Maybe a -> Either String a -note err Nothing = Left err -note _ (Just x) = Right x +note err Nothing = Left err +note _ (Just x) = Right x 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 [] + _ -> 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 + 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)) + . 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 + $ 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" + 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 index 175992c..af2f3fb 100644 --- a/src/tools/drawpuzzle.hs +++ b/src/tools/drawpuzzle.hs @@ -3,138 +3,143 @@ module Main where -import Data.Lib -import Data.PuzzleTypes -import Draw.CmdLine -import Draw.Draw -import Draw.Font -import Draw.Render - -import Options.Applicative -import Data.List ( intercalate ) - -import System.FilePath -import System.Environment ( getProgName ) -import System.Exit ( exitFailure ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Yaml as Y +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Lib +import Data.List (intercalate) +import Data.PuzzleTypes +import qualified Data.Yaml as Y +import Draw.CmdLine +import Draw.Draw +import Draw.Font +import Draw.Render +import Options.Applicative +import System.Environment (getProgName) +import System.Exit (exitFailure) +import System.FilePath optListTypes :: Parser (a -> a) -optListTypes = infoOption - (unlines' typeOptions) - (long "list-types" <> help "List supported puzzle types") - where unlines' = intercalate "\n" - -data PuzzleOpts = PuzzleOpts - { _format :: Format - , _type :: Maybe String - , _dir :: FilePath - , _puzzle :: Bool - , _solution :: Bool - , _example :: Bool - , _code :: Bool - , _scale :: Double - , _input :: [FilePath] - } +optListTypes = + infoOption + (unlines' typeOptions) + (long "list-types" <> help "List supported puzzle types") + where + unlines' = intercalate "\n" + +data PuzzleOpts + = PuzzleOpts + { _format :: Format, + _type :: Maybe String, + _dir :: FilePath, + _puzzle :: Bool, + _solution :: Bool, + _example :: Bool, + _code :: Bool, + _scale :: Double, + _input :: [FilePath] + } config :: PuzzleOpts -> Config config opts = - let var = fontAnelizaRegular - bit = fontBit + let var = fontAnelizaRegular + bit = fontBit device = case _format opts of PDF -> Print - _ -> Screen - in Config device var bit + _ -> Screen + in Config device var bit puzzleOpts :: Parser PuzzleOpts puzzleOpts = PuzzleOpts <$> option - parseFormat - ( long "format" + parseFormat + ( long "format" <> short 'f' <> value (head formats) <> metavar "FMT" <> help ("Desired output format by file extension " ++ fmts) - ) + ) <*> ( optional - . strOption - $ (long "type" <> short 't' <> metavar "TYPE" <> help - "Puzzle type, overriding type in input file" - ) + . strOption + $ ( long "type" <> short 't' <> metavar "TYPE" + <> help + "Puzzle type, overriding type in input file" + ) ) <*> strOption - (long "directory" <> short 'd' <> value "." <> metavar "DIR" <> help + ( long "directory" <> short 'd' <> value "." <> metavar "DIR" + <> help "Output directory" - ) + ) <*> switch - (long "puzzle" <> short 'p' <> help "Render puzzle (to base.ext)") + (long "puzzle" <> short 'p' <> help "Render puzzle (to base.ext)") <*> switch - (long "solution" <> short 's' <> help + ( long "solution" <> short 's' + <> help "Render solution (to base-sol.ext)" - ) + ) <*> switch - (long "example" <> short 'e' <> help "Render example (to base.ext)") + (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 + auto + ( long "scale" <> value 1.0 <> metavar "FACTOR" + <> help "Scale the size by this factor" - ) + ) <*> some - (argument - str - (metavar "INPUT..." <> help "Puzzle files in .pzl or .pzg format") - ) - where - parseFormat = eitherReader - (\s -> case lookupFormat s of - Just f -> Right f - Nothing -> Left "unknown format" - ) - fmts = "(" ++ intercalate ", " (map extension formats) ++ ")" + ( argument + str + (metavar "INPUT..." <> help "Puzzle files in .pzl or .pzg format") + ) + where + parseFormat = + eitherReader + ( \s -> case lookupFormat s of + Just f -> Right f + Nothing -> Left "unknown format" + ) + fmts = "(" ++ intercalate ", " (map extension formats) ++ ")" outputSuffix :: OutputChoice -> String -outputSuffix DrawPuzzle = "" +outputSuffix DrawPuzzle = "" outputSuffix DrawSolution = "-sol" -outputSuffix DrawExample = "" +outputSuffix DrawExample = "" outputPath :: PuzzleOpts -> FilePath -> Format -> OutputChoice -> FilePath outputPath opts input fmt oc = out - where - base = takeBaseName input - out = _dir opts (base ++ outputSuffix oc) <.> extension fmt + where + base = takeBaseName input + out = _dir opts (base ++ outputSuffix oc) <.> extension fmt defaultOpts :: Parser a -> IO a defaultOpts optsParser = do prog <- getProgName - let - p = info - (helper <*> optListTypes <*> optsParser) - (fullDesc <> progDesc "Command-line diagram generation." <> header prog) + let p = + info + (helper <*> optListTypes <*> optsParser) + (fullDesc <> progDesc "Command-line diagram generation." <> header prog) execParser p checkOutput :: PuzzleOpts -> Either String OutputChoice checkOutput opts = case choices of [oc] -> Right oc - [] -> Right DrawPuzzle - _ -> Left "more than one output flag given" - where - p = _puzzle opts - s = _solution opts - e = _example opts - choices = - map snd - . filter fst - $ [(p, DrawPuzzle), (s, DrawSolution), (e, DrawExample)] + [] -> Right DrawPuzzle + _ -> Left "more than one output flag given" + where + p = _puzzle opts + s = _solution opts + e = _example opts + choices = + map snd + . filter fst + $ [(p, DrawPuzzle), (s, DrawSolution), (e, DrawExample)] checkPuzzleFormat :: FilePath -> Either String PuzzleFormat checkPuzzleFormat fp = case takeExtension fp of ".pzl" -> Right PZL ".pzg" -> Right PZG - ext -> Left $ "unknown format: " ++ ext + ext -> Left $ "unknown format: " ++ ext maybeSkipCode :: PuzzleOpts -> Maybe Y.Value -> Maybe Y.Value maybeSkipCode opts = if _code opts then id else const Nothing @@ -142,26 +147,28 @@ maybeSkipCode opts = if _code opts then id else const Nothing handleOne :: PuzzleOpts -> OutputChoice -> FilePath -> IO () handleOne opts oc fpin = do puzzleFormat <- orExitFile $ checkPuzzleFormat fpin - let params = Params (_format opts) - (config opts) - oc - (_scale opts) - (_code opts) - puzzleFormat + let params = + Params + (_format opts) + (config opts) + oc + (_scale opts) + (_code opts) + puzzleFormat fpout = outputPath opts fpin (_format opts) oc - input <- B.readFile fpin + input <- B.readFile fpin output <- orExitFile $ decodeAndDraw params input BL.writeFile fpout output - where - orExitFile :: Either String a -> IO a - orExitFile = orExit . mapLeft ((fpin <> ": ") <>) + where + orExitFile :: Either String a -> IO a + orExitFile = orExit . mapLeft ((fpin <> ": ") <>) main :: IO () main = do opts <- defaultOpts puzzleOpts - oc <- orExit $ checkOutput opts + oc <- orExit $ checkOutput opts mapM_ (handleOne opts oc) (_input opts) orExit :: Either String a -> IO a -orExit (Left err) = putStrLn err >> exitFailure -orExit (Right r ) = return r +orExit (Left err) = putStrLn err >> exitFailure +orExit (Right r) = return r diff --git a/tests/Data.hs b/tests/Data.hs index b505be3..690c151 100644 --- a/tests/Data.hs +++ b/tests/Data.hs @@ -1,10 +1,10 @@ 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 ) +import qualified Data.ByteString as B +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Yaml packStr :: String -> B.ByteString packStr = encodeUtf8 . T.pack @@ -57,18 +57,18 @@ kpyramid_1_sol = kpyramid_broken_1 :: Value kpyramid_broken_1 = - packLines - $ [ " G 3" - , " G . 22" - , " H . aa ." - , " W .o. .|. " - , " G 1*.*.o.*6" - ] + 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"] + packLines $ + ["G 3", "G . 22", "H . aa .", "W .o. .|. ", "G 1*.*.o.*6"] kpyramid_broken_3 :: Value kpyramid_broken_3 = @@ -76,8 +76,8 @@ kpyramid_broken_3 = compass_1 :: Value compass_1 = - decodeLines - $ ["grid: |", " ...", " a.b", "clues:", " a: 2 1 . 2", " b: 21 . . 0"] + decodeLines $ + ["grid: |", " ...", " a.b", "clues:", " a: 2 1 . 2", " b: 21 . . 0"] compass_broken_1 :: Value compass_broken_1 = @@ -93,13 +93,13 @@ compass_broken_3 = compass_broken_4 :: Value compass_broken_4 = - decodeLines - $ ["grid: |", " a.b", "clues:", " a: 1 . . 2 3", " b: 21 . . 0"] + 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"] + decodeLines $ + ["grid: |", " a3b", "clues:", " a: 1 . . 2 3", " b: 21 . . 0"] thermo_1 :: Value thermo_1 = @@ -117,18 +117,18 @@ thermo_broken_2 = packLines $ ["bb", "a."] multioutside :: Value multioutside = - decodeLines - $ [ "left:" - , " - [2, 1]" - , " - [3]" - , "right:" - , " - []" - , " - [1, 0]" - , "bottom:" - , " - [0, 0, 1]" - , "top:" - , " - [-1, 1]" - ] + decodeLines $ + [ "left:", + " - [2, 1]", + " - [3]", + "right:", + " - []", + " - [1, 0]", + "bottom:", + " - [0, 0, 1]", + "top:", + " - [-1, 1]" + ] edgeGrid_1 :: Value edgeGrid_1 = packLines $ ["o-*-*-o", "|1|2 3", "*-o"] diff --git a/tests/Data/GridShapeSpec.hs b/tests/Data/GridShapeSpec.hs index 1ef6556..f50d075 100644 --- a/tests/Data/GridShapeSpec.hs +++ b/tests/Data/GridShapeSpec.hs @@ -1,23 +1,23 @@ 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 ) +import Data.GridShape +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Test.Hspec + ( Spec, + describe, + it, + shouldBe, + ) spec :: Spec spec = do 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)] + ( 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 index bb3baac..39d71ac 100644 --- a/tests/Data/GridSpec.hs +++ b/tests/Data/GridSpec.hs @@ -1,20 +1,22 @@ module Data.GridSpec where -import Data.List ( nub - , sort - ) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Test.Hspec ( Spec - , describe - , it - , shouldBe - ) - -import Data.Grid -import Data.GridShape ( N(..) - , C(..) - ) +import Data.Grid +import Data.GridShape + ( C (..), + N (..), + ) +import Data.List + ( nub, + sort, + ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Test.Hspec + ( Spec, + describe, + it, + shouldBe, + ) spec :: Spec spec = do @@ -25,15 +27,13 @@ spec = do 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)) - describe "colour" $ do it "colours a line alternatingly" $ do let input = [((C 1 1), 1 :: Int), ((C 1 2), 2), ((C 1 3), 3)] - let want = [((C 1 1), 1 :: Int), ((C 1 2), 2), ((C 1 3), 1)] + let want = [((C 1 1), 1 :: Int), ((C 1 2), 2), ((C 1 3), 1)] colour (Map.fromList input) `shouldBe` (Map.fromList want) it "colours a checkerboard" $ do let input = @@ -61,4 +61,3 @@ spec = do [((C 1 1), 1 :: Int), ((C 1 2), 2), ((C 2 1), 1), ((C 2 2), 3)] let count = length . nub . sort . Map.elems count (colour (Map.fromList input)) `shouldBe` 3 - diff --git a/tests/Draw/GridSpec.hs b/tests/Draw/GridSpec.hs index 765d1b0..2d32dcc 100644 --- a/tests/Draw/GridSpec.hs +++ b/tests/Draw/GridSpec.hs @@ -1,33 +1,32 @@ 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 ) +import Data.Grid +import Data.GridShape +import Diagrams.Path (pathPoints) +import Diagrams.Prelude (p2) +import Draw.Grid +import Draw.Lib (p2i) +import Test.Hspec + ( Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) spec :: Spec spec = do describe "irregularGridPaths" $ do it "gives the border of a rectangular grid" $ do - let g = sizeGrid (2, 3) :: Grid C () + let g = sizeGrid (2, 3) :: Grid C () (outer, _) = irregularGridPaths g - pts = pathPoints outer + 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 @@ -35,10 +34,9 @@ spec = do 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] + let b = offsetBorder 0 [C 0 0] [vs] = pathPoints b length vs `shouldBe` 4 vs `shouldSatisfy` elem (p2i (0, 0)) @@ -46,7 +44,7 @@ spec = do 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] + let b = offsetBorder 0 [C 0 0, C 1 0] [vs] = pathPoints b length vs `shouldBe` 4 vs `shouldSatisfy` elem (p2i (0, 0)) @@ -54,7 +52,7 @@ spec = do 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] + 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)) diff --git a/tests/Draw/PuzzleTypesSpec.hs b/tests/Draw/PuzzleTypesSpec.hs index 7106c14..34798c0 100644 --- a/tests/Draw/PuzzleTypesSpec.hs +++ b/tests/Draw/PuzzleTypesSpec.hs @@ -1,33 +1,32 @@ module Draw.PuzzleTypesSpec where -import Test.Hspec ( Spec - , describe - , it - , shouldSatisfy - ) - -import qualified Data.Map.Strict as Map -import qualified Data.ByteString.Lazy as LBS - -import Diagrams.Prelude ( mkSizeSpec2D ) - -import Data.GridShape -import qualified Draw.Draw as Draw -import qualified Draw.Font as Font -import Draw.CmdLine ( renderBytesSVG - , Format(SVG) - ) -import Draw.PuzzleTypes ( colorakari ) +import qualified Data.ByteString.Lazy as LBS +import Data.GridShape +import qualified Data.Map.Strict as Map +import Diagrams.Prelude (mkSizeSpec2D) +import Draw.CmdLine + ( Format (SVG), + renderBytesSVG, + ) +import qualified Draw.Draw as Draw +import qualified Draw.Font as Font +import Draw.PuzzleTypes (colorakari) +import Test.Hspec + ( Spec, + describe, + it, + shouldSatisfy, + ) spec :: Spec spec = do describe "colorakari" $ do it "doesn't crash on blanks in the grid" $ do - let - sz = mkSizeSpec2D (Just 1.0) (Just 1.0) - cfg = Draw.Config Draw.Screen Font.fontAnelizaRegular Font.fontBit - g = Map.fromList - [((C 1 1), Just 'R'), ((C 1 2), Just ' '), ((C 2 2), Nothing)] - d = Draw.diagram cfg $ Draw.puzzle colorakari $ g - bs = renderBytesSVG SVG sz d + let sz = mkSizeSpec2D (Just 1.0) (Just 1.0) + cfg = Draw.Config Draw.Screen Font.fontAnelizaRegular Font.fontBit + g = + Map.fromList + [((C 1 1), Just 'R'), ((C 1 2), Just ' '), ((C 2 2), Nothing)] + d = Draw.diagram cfg $ Draw.puzzle colorakari $ g + bs = renderBytesSVG SVG sz d LBS.length bs `shouldSatisfy` (\l -> l > 0) diff --git a/tests/Parse/PuzzleTypesSpec.hs b/tests/Parse/PuzzleTypesSpec.hs index bf70656..e587da3 100644 --- a/tests/Parse/PuzzleTypesSpec.hs +++ b/tests/Parse/PuzzleTypesSpec.hs @@ -1,21 +1,20 @@ module Parse.PuzzleTypesSpec where -import Data.Maybe ( isJust ) -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.Grid ( edgeSize ) -import Data.Elements ( DigitRange(..) ) -import Parse.PuzzleTypes +import qualified Data.ByteString as B +import Data.Elements (DigitRange (..)) +import Data.Grid (edgeSize) +import Data.Maybe (isJust) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Yaml +import Parse.PuzzleTypes +import Test.Hspec + ( Spec, + describe, + it, + shouldBe, + shouldSatisfy, + ) packLines :: [String] -> B.ByteString packLines = encodeUtf8 . T.pack . unlines @@ -28,33 +27,34 @@ 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)] - ) + 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"] + 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. " - , " + + + +" + [ "|", + " + + + +", + " . . . ", + " +*+ + +", + " . .o. ", + " + + + +" ] res = parse p y res `shouldSatisfy` isJust diff --git a/tests/Parse/UtilSpec.hs b/tests/Parse/UtilSpec.hs index a047e0a..1622e82 100644 --- a/tests/Parse/UtilSpec.hs +++ b/tests/Parse/UtilSpec.hs @@ -1,25 +1,27 @@ {-# 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 - ) +module Parse.UtilSpec where -import Data.GridShape ( Edge(..) - , N(..) - , Dir(..) - ) -import Data.Elements ( Relation(..) ) -import Parse.Util ( parseCoordGrid - , parseAnnotatedEdges - , parseGreaterClue - ) +import Data.Elements (Relation (..)) +import Data.GridShape + ( Dir (..), + Edge (..), + N (..), + ) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Yaml +import Parse.Util + ( parseAnnotatedEdges, + parseCoordGrid, + parseGreaterClue, + ) +import Test.Hspec + ( Spec, + describe, + it, + shouldBe, + ) packLines :: [String] -> Value packLines = String . T.pack . unlines @@ -28,45 +30,42 @@ 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') - ] + 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') - ] + 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 = [] + let y = [] want = [] parseMaybe parseGreaterClue y `shouldBe` Just want - it "parses a single dot" $ do - let y = ['.'] + let y = ['.'] want = [RUndetermined] parseMaybe parseGreaterClue y `shouldBe` Just want - it "parses a single dot" $ do - let y = ['.'] + let y = ['.'] want = [RUndetermined] parseMaybe parseGreaterClue y `shouldBe` Just want - it "parses a mixed line" $ do - let y = ['.', '<', '.', ' ', '.', '=', '.'] + let y = ['.', '<', '.', ' ', '.', '=', '.'] want = [RUndetermined, RLess, RUndetermined, REqual] parseMaybe parseGreaterClue y `shouldBe` Just want diff --git a/tests/Util.hs b/tests/Util.hs index f7ae676..54d9ca9 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,27 +1,26 @@ module Util where -import Control.DeepSeq -import Data.Yaml - -import Test.Tasty.HUnit +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 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 (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 + 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 diff --git a/tests/tests.hs b/tests/tests.hs index 7e47e8c..c6e5767 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,35 +1,33 @@ -import Test.Tasty -import Test.Tasty.Hspec -import Test.Tasty.HUnit - -import Data.Yaml -import Data.List ( sort ) -import qualified Data.Map.Strict as Map - -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 Data -import Util -import qualified Data.GridSpec +import Data +import Data.Elements + ( MasyuPearl (..), + Thermometer, + ) +import qualified Data.Grid as Grid +import Data.Grid +import Data.GridShape import qualified Data.GridShapeSpec +import qualified Data.GridSpec +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Pyramid (PyramidSol (..)) +import Data.Util +import Data.Yaml import qualified Draw.GridSpec import qualified Draw.PuzzleTypesSpec +import Parse.Puzzle +import Parse.PuzzleTypes import qualified Parse.PuzzleTypesSpec +import Parse.Util + ( parseChar, + parseMultiOutsideClues, + parsePlainEdgeGrid, + ) import qualified Parse.UtilSpec +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hspec +import Util main :: IO () main = do @@ -37,15 +35,16 @@ main = do defaultMain . testGroup "Tests" $ tests ++ ss specs :: IO [TestTree] -specs = mapM - (uncurry testSpec) - [ ("Data.Grid" , Data.GridSpec.spec) - , ("Data.GridShape" , Data.GridShapeSpec.spec) - , ("Draw.Grid" , Draw.GridSpec.spec) - , ("Draw.PuzzleTypes" , Draw.PuzzleTypesSpec.spec) - , ("Parse.PuzzleTypes", Parse.PuzzleTypesSpec.spec) - , ("Parse.Util" , Parse.UtilSpec.spec) - ] +specs = + mapM + (uncurry testSpec) + [ ("Data.Grid", Data.GridSpec.spec), + ("Data.GridShape", Data.GridShapeSpec.spec), + ("Draw.Grid", Draw.GridSpec.spec), + ("Draw.PuzzleTypes", Draw.PuzzleTypesSpec.spec), + ("Parse.PuzzleTypes", Parse.PuzzleTypesSpec.spec), + ("Parse.Util", Parse.UtilSpec.spec) + ] tests :: [TestTree] tests = [parseUtilTests, parseTests, parseDataTests, dataTests] @@ -53,57 +52,62 @@ 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 + testCase ("don't parse broken " ++ name ++ " (sol)") $ + testNonparse (snd parser) yaml parseUtilTests :: TestTree -parseUtilTests = testGroup - "Parsing infrastructure tests (parseChar)" - [ testCase "parse digit" $ (parseMaybe parseChar '5' :: Maybe Int) @=? Just 5 - , testCase "don't parse hex chars" - $ (parseMaybe parseChar 'a' :: Maybe Int) - @=? Nothing - , testCase "don't break on non-digits" - $ (parseMaybe parseChar ' ' :: Maybe Int) - @=? Nothing - ] +parseUtilTests = + testGroup + "Parsing infrastructure tests (parseChar)" + [ testCase "parse digit" $ (parseMaybe parseChar '5' :: Maybe Int) @=? Just 5, + testCase "don't parse hex chars" $ + (parseMaybe parseChar 'a' :: Maybe Int) + @=? Nothing, + testCase "don't break on non-digits" $ + (parseMaybe parseChar ' ' :: Maybe Int) + @=? Nothing + ] parseTests :: TestTree -parseTests = testGroup - "Parsing tests (full puzzles, no details)" - [ testParsePzl "geradeweg" geradeweg geradeweg_1 - , testParseSol "geradeweg" geradeweg geradeweg_1_sol - , testParsePzl "tightfit" tightfitskyscrapers tightfit_1 - , testParseSol "tightfit" tightfitskyscrapers tightfit_1_sol - , testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_1 - , testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_2 - , testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken - , testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken_2 - , testNonparseSol "slalom" slalom slalom_sol_broken - , testParsePzl "kpyramid" kpyramid kpyramid_1 - , testParseSol "kpyramid" kpyramid kpyramid_1_sol - , testNonparsePzl "kpyramid" kpyramid kpyramid_broken_1 - , testNonparsePzl "kpyramid" kpyramid kpyramid_broken_2 - , testNonparsePzl "kpyramid" kpyramid kpyramid_broken_3 - , testParsePzl "compass" compass compass_1 - , testNonparsePzl "compass" compass compass_broken_1 - , testNonparsePzl "compass" compass compass_broken_2 - , testNonparsePzl "compass" compass compass_broken_3 - , testNonparsePzl "compass" compass compass_broken_4 - , testNonparsePzl "compass" compass compass_broken_5 - , testParsePzl "thermosudoku" thermosudoku thermo_1 - , testParsePzl "thermosudoku" thermosudoku thermo_2 - , testNonparsePzl "thermosudoku" thermosudoku thermo_broken_1 - , testNonparsePzl "thermosudoku" thermosudoku thermo_broken_2 - ] +parseTests = + testGroup + "Parsing tests (full puzzles, no details)" + [ testParsePzl "geradeweg" geradeweg geradeweg_1, + testParseSol "geradeweg" geradeweg geradeweg_1_sol, + testParsePzl "tightfit" tightfitskyscrapers tightfit_1, + testParseSol "tightfit" tightfitskyscrapers tightfit_1_sol, + testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_1, + testNonparsePzl "tightfit" tightfitskyscrapers tightfit_broken_2, + testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken, + testNonparseSol "tightfit" tightfitskyscrapers tightfit_sol_broken_2, + testNonparseSol "slalom" slalom slalom_sol_broken, + testParsePzl "kpyramid" kpyramid kpyramid_1, + testParseSol "kpyramid" kpyramid kpyramid_1_sol, + testNonparsePzl "kpyramid" kpyramid kpyramid_broken_1, + testNonparsePzl "kpyramid" kpyramid kpyramid_broken_2, + testNonparsePzl "kpyramid" kpyramid kpyramid_broken_3, + testParsePzl "compass" compass compass_1, + testNonparsePzl "compass" compass compass_broken_1, + testNonparsePzl "compass" compass compass_broken_2, + testNonparsePzl "compass" compass compass_broken_3, + testNonparsePzl "compass" compass compass_broken_4, + testNonparsePzl "compass" compass compass_broken_5, + testParsePzl "thermosudoku" thermosudoku thermo_1, + testParsePzl "thermosudoku" thermosudoku thermo_2, + testNonparsePzl "thermosudoku" thermosudoku thermo_broken_1, + testNonparsePzl "thermosudoku" thermosudoku thermo_broken_2 + ] test_thermo_1 :: [Thermometer] test_thermo_1 = either (const []) snd $ parseEither (fst thermosudoku) thermo_1 @@ -117,90 +121,95 @@ 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 (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] - && t - == [Nothing, Nothing, Nothing] + where + res = parseEither (fst tightfitskyscrapers) tightfit_1 + test_both (o, g) = test_size g && test_clues o + 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] + && t + == [Nothing, Nothing, Nothing] test_pyramid_sol :: Bool test_pyramid_sol = either (const False) test_content res - where - res = parseEither (snd kpyramid) kpyramid_1_sol - test_content (PyramidSol rs) = - rs == [[3], [8, 5], [1, 9, 4], [3, 2, 7, 3], [1, 2, 4, 3, 6]] + where + res = parseEither (snd kpyramid) kpyramid_1_sol + test_content (PyramidSol rs) = + rs == [[3], [8, 5], [1, 9, 4], [3, 2, 7, 3], [1, 2, 4, 3, 6]] test_multioutside :: Assertion test_multioutside = Right oc @=? res - where - res = parseEither parseMultiOutsideClues multioutside - oc = - OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]] :: OutsideClues - Coord - [Int] + where + res = parseEither parseMultiOutsideClues multioutside + oc = + OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]] :: + OutsideClues + Coord + [Int] test_plain_edge_grid :: Assertion test_plain_edge_grid = Right (gn, gc, sort es) @=? res' - where - 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) + where + 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.Grid C Int + gc = + Map.mapKeys fromCoord + . Map.fromList + $ [((0, 0), 1), ((1, 0), 2), ((2, 0), 3)] + 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 ] - gc :: Grid.Grid C Int - gc = - Map.mapKeys fromCoord - . Map.fromList - $ [((0, 0), 1), ((1, 0), 2), ((2, 0), 3)] - 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)" - [ testCase "parse tightfit, correct size" - $ test_tightfit_1 - @? "error in puzzle" - , testCase "parse kpyramid sol properly" - $ test_pyramid_sol - @? "wrong solution" - , testCase "parse thermos" $ testThermo - test_thermo_1 - [[(0, 4), (1, 5), (2, 4), (1, 3)], [(4, 0), (3, 1), (4, 2), (5, 1)]] - , testCase "parse thermos" $ testThermo - test_thermo_2 - [ [(0, 1), (1, 0), (2, 0)] - , [(0, 2), (1, 3), (2, 4)] - , [(4, 0), (4, 1), (3, 2)] +parseDataTests = + testGroup + "Parsing tests (full puzzles, result checks)" + [ testCase "parse tightfit, correct size" $ + test_tightfit_1 + @? "error in puzzle", + testCase "parse kpyramid sol properly" $ + test_pyramid_sol + @? "wrong solution", + testCase "parse thermos" $ + testThermo + test_thermo_1 + [[(0, 4), (1, 5), (2, 4), (1, 3)], [(4, 0), (3, 1), (4, 2), (5, 1)]], + testCase "parse thermos" $ + testThermo + test_thermo_2 + [ [(0, 1), (1, 0), (2, 0)], + [(0, 2), (1, 3), (2, 4)], + [(4, 0), (4, 1), (3, 2)] + ], + testCase "parse multioutsideclues" $ test_multioutside, + testCase "parse edge grid" $ test_plain_edge_grid ] - , testCase "parse multioutsideclues" $ test_multioutside - , testCase "parse edge grid" $ test_plain_edge_grid - ] sorteq :: (Show a, Ord a) => [a] -> [a] -> Assertion sorteq xs ys = sort xs @?= sort ys @@ -209,94 +218,98 @@ 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) + 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) + where + -- rotations of the loops would be fine + -- inside and outside of: + -- xxx + -- x x + -- xxx + + 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)] ] - , [(1, 1), (2, 1), (2, 2), (1, 2), (1, 1)] - ] dataTests :: TestTree -dataTests = testGroup - "Generic tests for the Data modules" - [testCase "edges" testEdges, testCase "loops" testLoops] +dataTests = + testGroup + "Generic tests for the Data modules" + [testCase "edges" testEdges, testCase "loops" testLoops]