diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +0.2.0.0: 20161211 +----------------- + +* Upgrade diagrams version. +* Add various new puzzle types. +* Add solution code markers. + 0.1.0.4: 20141115 ----------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -45,7 +45,8 @@ ..X... ``` -There is a demo web application at [demo] that provides some more +There is a demo web application at +[puzzle-draw-demo.herokuapp.com][demo] that provides some more examples and that can be used to generate SVG images from such puzzle descriptions. diff --git a/puzzle-draw.cabal b/puzzle-draw.cabal --- a/puzzle-draw.cabal +++ b/puzzle-draw.cabal @@ -1,5 +1,5 @@ name: puzzle-draw -version: 0.1.0.4 +version: 0.2.0.0 synopsis: Creating graphics for pencil puzzles. description: puzzle-draw is a library and tool for drawing pencil puzzles using Diagrams. It aims to provide a utility @@ -28,14 +28,20 @@ library exposed-modules: Data.Puzzles.Grid Data.Puzzles.GridShape + Data.Puzzles.Util Data.Puzzles.Elements Data.Puzzles.Pyramid Data.Puzzles.Sudoku Data.Puzzles.Compose Data.Puzzles.PuzzleTypes + Data.Puzzles.Code + Data.Puzzles.CmdLine Text.Puzzles.Util + Text.Puzzles.Parsec Text.Puzzles.Puzzle Text.Puzzles.PuzzleTypes + Text.Puzzles.Code + Diagrams.Puzzles.Style Diagrams.Puzzles.Grid Diagrams.Puzzles.Lib Diagrams.Puzzles.Elements @@ -44,11 +50,12 @@ Diagrams.Puzzles.PuzzleGrids Diagrams.Puzzles.PuzzleTypes Diagrams.Puzzles.Draw + Diagrams.Puzzles.Code Diagrams.Puzzles.CmdLine -- For access to the font files in the data directory. other-modules: Paths_puzzle_draw - build-depends: base >= 4.2 && < 5, - diagrams-lib >= 1.2, + build-depends: base >= 4.8 && < 5, + diagrams-lib >= 1.3.1, parsec >= 3.1, yaml >= 0.8.4, aeson >= 0.7, @@ -59,47 +66,80 @@ SVGFonts >= 1.4, vector-space >= 0.8, mtl >= 2.1, - optparse-applicative >= 0.7, - filepath >= 1.3 + optparse-applicative >= 0.12 && < 0.13, + filepath >= 1.3, + linear if flag(cairo) cpp-options: "-DCAIRO" - build-depends: diagrams-cairo >= 1.1 + build-depends: diagrams-cairo >= 1.3 else - build-depends: diagrams-svg >= 1.1 + build-depends: diagrams-svg >= 1.3 hs-source-dirs: src ghc-options: -Wall executable drawpuzzle main-is: drawpuzzle.hs hs-source-dirs: src/tools - build-depends: base >= 4.2, + build-depends: base >= 4.8 && < 5, puzzle-draw, - diagrams-lib >= 1.2, + diagrams-lib >= 1.3, yaml >= 0.8.4, - optparse-applicative >= 0.7, + optparse-applicative >= 0.12, aeson >= 0.7, filepath >= 1.3 if flag(cairo) cpp-options: "-DCAIRO" - build-depends: diagrams-cairo >= 1.1 + build-depends: diagrams-cairo >= 1.3 else - build-depends: diagrams-svg >= 1.1 + build-depends: diagrams-svg >= 1.3 ghc-options: -Wall +executable checkpuzzle + main-is: checkpuzzle.hs + hs-source-dirs: src/tools + build-depends: base >= 4.8 && < 5, + puzzle-draw, + yaml >= 0.8.4, + optparse-applicative >= 0.12, + aeson >= 0.7, + filepath >= 1.3 + ghc-options: -Wall + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: tests.hs - build-depends: base >= 4.2, + other-modules: Data, + Util, + Data.Puzzles.GridSpec, + Data.Puzzles.GridShapeSpec, + Diagrams.Puzzles.GridSpec, + Text.Puzzles.PuzzleTypesSpec, + Text.Puzzles.UtilSpec + build-depends: base >= 4.8 && < 5, tasty >= 0.8, + tasty-hspec, tasty-hunit >= 0.8, + hspec, yaml >= 0.8.4, text >= 1.1, deepseq >= 1.3, containers >= 0.5, blaze-svg >= 0.3, - diagrams-lib >= 1.2, - diagrams-svg >= 1.1, + diagrams-lib >= 1.3, + diagrams-svg >= 1.3, bytestring >= 0.10, puzzle-draw + ghc-options: -Wall + +-- This should depend on the executable `drawpuzzle` +-- and not the library. +executable test-compare + hs-source-dirs: tests + main-is: compare.hs + build-depends: base >= 4.8 && < 5, + tasty >= 0.8, + tasty-golden >= 2.0, + filepath >= 1.3, + process >= 1.2 ghc-options: -Wall diff --git a/src/Data/Puzzles/CmdLine.hs b/src/Data/Puzzles/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Puzzles/CmdLine.hs @@ -0,0 +1,27 @@ +module Data.Puzzles.CmdLine + ( checkType + , exitErr + , readPuzzle + ) where + +import Text.Puzzles.Puzzle +import Data.Puzzles.PuzzleTypes + +import qualified Data.Yaml as Y +import System.Exit + +checkType :: Maybe String -> IO PuzzleType +checkType mt = do + t <- maybe errno return mt + maybe (errunk t) return (lookupType t) + where + errno = exitErr "no puzzle type given" + errunk t = exitErr $ "unknown puzzle type: " ++ t + +readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle) +readPuzzle = Y.decodeFileEither + +exitErr :: String -> IO a +exitErr e = putStrLn e >> exitFailure + + diff --git a/src/Data/Puzzles/Code.hs b/src/Data/Puzzles/Code.hs new file mode 100644 --- /dev/null +++ b/src/Data/Puzzles/Code.hs @@ -0,0 +1,13 @@ +module Data.Puzzles.Code where + +import Data.Puzzles.Grid +import Data.Puzzles.GridShape + +type Code = [CodePart] + +data CodePart = + Rows' [Int] -- ^ Rows of cells, counted from the bottom. + | Cols [Int] -- ^ Cols of cells, counted from the left. + | RowsN' [Int] -- ^ Rows of nodes, counted from the bottom. + | ColsN [Int] -- ^ Cols of nodes, counted from the left. + | LabelsN (Grid N (Maybe Char)) -- ^ Nodes, labeld by letters. diff --git a/src/Data/Puzzles/Compose.hs b/src/Data/Puzzles/Compose.hs --- a/src/Data/Puzzles/Compose.hs +++ b/src/Data/Puzzles/Compose.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Helpers to string together parser and renderer by puzzle type. @@ -8,18 +9,11 @@ PuzzleHandler, handle, -- * Handlers - drawPuzzle, - drawPuzzleSol, drawPuzzleMaybeSol, - drawPuzzle', - drawSolution', - drawExample' ) where -import Data.Maybe import Diagrams.Prelude import Data.Yaml (Parser, Value) -import Data.Traversable (traverse) import Text.Puzzles.Puzzle import Diagrams.Puzzles.Draw @@ -41,6 +35,7 @@ PuzzleHandler b a -> PuzzleType -> a handle f LITS = f R.lits D.lits handle f LITSPlus = f R.litsplus D.litsplus +handle f LITSSym = f R.lits D.litssym handle f Geradeweg = f R.geradeweg D.geradeweg handle f Fillomino = f R.fillomino D.fillomino handle f Masyu = f R.masyu D.masyu @@ -69,55 +64,60 @@ handle f PrimePlace = f R.primeplace D.primeplace handle f Labyrinth = f R.labyrinth D.labyrinth handle f Bahnhof = f R.bahnhof D.bahnhof +handle f BlackoutDominos = f R.blackoutDominos D.blackoutDominos +handle f TwilightTapa = f R.tapa D.tapa +handle f TapaCave = f R.tapa D.tapa +handle f DominoPillen = f R.dominoPills D.dominoPills +handle f SlitherLinkMulti = f R.slithermulti D.slithermulti +handle f AngleLoop = f R.angleLoop D.angleLoop +handle f Shikaku = f R.shikaku D.shikaku +handle f SlovakSums = f R.slovaksums D.slovaksums +handle f Anglers = f R.anglers D.anglers +handle f Dominos = f R.dominos D.dominos +handle f FillominoCheckered = f R.fillomino D.fillominoCheckered +handle f FillominoLoop = f R.fillominoLoop D.fillominoLoop handle f Cave = f R.cave D.cave - --- | Handler that parses a puzzle from a YAML value, and renders. -drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2)) -drawPuzzle (pp, _) (dp, _) p = do - p' <- pp p - return $ dp p' - --- | Handler that parses puzzle and solution from a pair of corresponding --- YAML values, and renders both individually. -drawPuzzleSol :: PuzzleHandler b ((Value, Value) - -> Parser (Diagram b R2, Diagram b R2)) -drawPuzzleSol (pp, ps) (dp, ds) (p, s) = do - p' <- pp p - s' <- ps s - return (dp p', ds (p', s')) +handle f Numberlink = f R.numberlink D.numberlink +handle f Skyscrapers = f R.skyscrapers D.skyscrapers +handle f SkyscrapersStars = f R.skyscrapersStars D.skyscrapersStars +handle f SkyscrapersFrac = f R.tightfitskyscrapers D.tightfitskyscrapers +handle f TurningFences = f R.slither D.slither +handle f Summon = f R.summon D.summon +handle f Baca = f R.baca D.baca +handle f Buchstabensalat = f R.buchstabensalat D.buchstabensalat +handle f Doppelblock = f R.doppelblock D.doppelblock +handle f SudokuDoppelblock = f R.sudokuDoppelblock D.sudokuDoppelblock +handle f Loopki = f R.loopki D.loopki +handle f Scrabble = f R.scrabble D.scrabble +handle f Neighbors = f R.neighbors D.neighbors +handle f Starwars = f R.starwars D.starwars +handle f Starbattle = f R.starbattle D.starbattle +handle f Heyawake = f R.heyawake D.heyawake +handle f Wormhole = f R.wormhole D.wormhole +handle f Pentominous = f R.pentominous D.pentominous +handle f ColorAkari = f R.colorakari D.colorakari +handle f PersistenceOfMemory = f R.persistenceOfMemory D.persistenceOfMemory +handle f ABCtje = f R.abctje D.abctje +handle f Kropki = f R.kropki D.kropki +handle f StatuePark = f R.statuepark D.statuepark +handle f PentominousBorders = f R.pentominousBorders D.pentominousBorders +handle f NanroSignpost = f R.nanroSignpost D.nanroSignpost +handle f TomTom = f R.tomTom D.tomTom +handle f HorseSnake = f R.horseSnake D.horseSnake +handle f Illumination = f R.illumination D.illumination +handle f Pentopia = f R.pentopia D.pentopia +handle f PentominoPipes = f R.pentominoPipes D.pentominoPipes +handle f GreaterWall = f R.greaterWall D.greaterWall +handle f Galaxies = f R.galaxies D.galaxies -- | Handler that parses puzzle and an optional solution from a pair of -- corresponding YAML values, and renders both individually, optionally -- for the solution. drawPuzzleMaybeSol :: PuzzleHandler b ((Value, Maybe Value) - -> Parser (Diagram b R2, Maybe (Diagram b R2))) + -> Parser (Diagram b, Maybe (Diagram b))) drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do p' <- pp p s' <- traverse ps s let mps = case s' of Nothing -> Nothing Just s'' -> Just (p', s'') return (dp p', ds <$> mps) - --- | Variant of 'drawPuzzle' that accepts a pair of puzzle YAML value and --- optional solution YAML value. -drawPuzzle' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawPuzzle' (pp, _) (dp, _) (p, _) = do - p' <- pp p - return $ dp p' - --- | Handler that accepts a pair of puzzle YAML value and optional solution --- YAML value, and renders the solution, failing if the solution is not --- provided. -drawSolution' :: PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawSolution' (pp, ps) (_, ds) (p, ms) = do - p' <- pp p - s' <- maybe (fail "no solution provided") ps ms - return $ ds (p', s') - --- | Like 'drawSolution'', but renders puzzle and solution in example layout. -drawExample' :: Backend' b => - PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) -drawExample' (pp, ps) (dp, ds) (p, ms) = do - p' <- pp p - s' <- maybe (fail "no solution provided") ps ms - return . fromJust $ draw (dp p', Just $ ds (p', s')) DrawExample diff --git a/src/Data/Puzzles/Elements.hs b/src/Data/Puzzles/Elements.hs --- a/src/Data/Puzzles/Elements.hs +++ b/src/Data/Puzzles/Elements.hs @@ -1,7 +1,7 @@ -- | Types for a variety of puzzle elements. module Data.Puzzles.Elements where -import Data.Puzzles.GridShape (Coord, Edge) +import Data.Puzzles.GridShape type Clue a = Maybe a @@ -19,6 +19,8 @@ type CompassClue = Clue CompassC +data SlovakClue = SlovakClue !Int !Int + -- | A cell that is optionally bisected by a diagonal -- (up-right or down-right). data Tightfit a = Single a | UR a a | DR a a @@ -29,18 +31,25 @@ show' (UR x y) = show x ++ "/" ++ show y show' (DR x y) = show x ++ "\\" ++ show y +-- | A marked line in a grid, given by start and end points. +data MarkedLine a = MarkedLine a a + -- | A marked word in a letter grid, by its start and end -- coordinates. data MarkedWord = MW { mwstart :: Coord, mwend :: Coord } -- | A loop of edges. -type Loop = [Edge] +type Loop a = [Edge a] +-- | A loop consisting of straight segments of arbitrary +-- angles between vertices. +type VertexLoop = [N] + -- | A thermometer, as a list of coordinates from bulb to end. -- There should be at least two entries, entries should be distinct, -- and successive entries should be neighbours (diagonal neighbours -- are fine). -type Thermometer = [Coord] +type Thermometer = [C] -- | A forward or backward diagonal as occurring in the solution -- of a slalom puzzle. @@ -62,7 +71,32 @@ newtype PrimeDiag = PrimeDiag (Bool, Bool) data Black = Black - +data Fish = Fish +data Star = Star data Crossing = Crossing type BahnhofClue = Either Int Crossing + +data DigitRange = DigitRange !Int !Int + deriving (Show, Eq) + +digitList :: DigitRange -> [Int] +digitList (DigitRange a b) = [a..b] + +data MEnd = MEnd + +data Fraction = + FComp String String String -- a b/c + | FFrac String String -- a/b + | FInt String -- a + +data PlainNode = PlainNode + +type Myopia = [Dir'] + +data Relation = RGreater | RLess | REqual | RUndetermined + deriving (Show, Eq) + +type GreaterClue = [Relation] + +data GalaxyCentre = GalaxyCentre diff --git a/src/Data/Puzzles/Grid.hs b/src/Data/Puzzles/Grid.hs --- a/src/Data/Puzzles/Grid.hs +++ b/src/Data/Puzzles/Grid.hs @@ -1,166 +1,207 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, - GADTs, StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} -- | Puzzle grids. -module Data.Puzzles.Grid where +module Data.Puzzles.Grid + ( + Grid + , AreaGrid + , ShadedGrid + , nodes + , size + , sizeGrid + , clues + , nodeGrid + , cellGrid -import Data.Maybe + , dominoGrid + + , borders + , edgesGen + , colour + , collectLines + + , OutsideClues(..) + , outsideSize + , outsideClues + , multiOutsideClues + , outsideGrid + ) where + import qualified Data.Map as Map -import Data.Foldable (Foldable, foldMap) -import Data.Traversable (Traversable, traverse) -import Control.Applicative ((<$>)) +import qualified Data.Set as Set +import Data.AffineSpace import Data.VectorSpace +import Control.Monad.State -import Data.Puzzles.GridShape hiding (size, cells) -import qualified Data.Puzzles.GridShape as GS import Data.Puzzles.Elements +import Data.Puzzles.GridShape --- | A generic grid, with the given shape and contents. -data Grid s a where - Grid :: { shape :: s - , contents :: Map.Map (Cell s) a} -> Grid s a +type Grid k a = Map.Map k a -deriving instance (Show a, Show s, GridShape s) => Show (Grid s a) -deriving instance (Eq s, Eq (Cell s), Eq a) => Eq (Grid s a) +type AreaGrid = Grid C Char +type ShadedGrid = Grid C Bool --- | Standard square grid. -type SGrid = Grid Square +-- | For a grid with value type @Maybe a@, return an association +-- list of cells and @Just@ values. +clues :: Grid k (Maybe a) -> Grid k a +clues = Map.mapMaybe id -type CharGrid = SGrid Char -type AreaGrid = CharGrid -type ShadedGrid = SGrid Bool -type CharClueGrid = SGrid (Maybe Char) -type IntGrid = SGrid (Clue Int) +edgesGen :: Dual' k + => (a -> a -> Bool) -> (a -> Bool) -> Map.Map k a -> [Edge (Dual k)] +edgesGen p n m = filter (uncurry p' . ends . dualE) es + where + (outer, inner) = edgesM m + es = map unorient outer ++ inner + p' c d = p'' (Map.lookup c m) + (Map.lookup d m) + p'' (Just e) (Just f) = p e f + p'' (Just e) Nothing = n e + p'' Nothing (Just e) = n e + p'' _ _ = False --- | Lookup a grid value at a given cell. Unsafe. -(!) :: (GridShape s, Ord (Cell s)) => Grid s a -> Cell s -> a -(!) (Grid _ m) = (m Map.!) -instance Functor (Grid s) where - fmap f (Grid s m) = Grid s (fmap f m) +nodes :: Grid N a -> Set.Set N +nodes = Map.keysSet -instance Foldable (Grid s) where - foldMap f (Grid _ m) = foldMap f m +-- | The inner edges of a grid that separate unequal cells. +borders :: Eq a => Grid C a -> [Edge N] +borders = edgesGen (/=) (const False) -instance Traversable (Grid s) where - traverse f (Grid s m) = Grid s <$> traverse f m +corners :: C -> [N] +corners c = map (.+^ (c .-. C 0 0)) [N 0 0, N 1 0, N 0 1, N 1 1] -filterG :: (a -> Bool) -> Grid s a -> Grid s a -filterG p (Grid s m) = Grid s (Map.filter p m) +-- | A grid of empty nodes with all nodes of the cells of the +-- first grid. +nodeGrid :: Grid C a -> Grid N () +nodeGrid = Map.unions . map cornersM . Map.keys + where + cornersM = Map.fromList . map (flip (,) ()) . corners --- | Initialize a square grid from a list of lists. The grid --- might be incomplete if some rows are shorter. -fromListList :: [[a]] -> Grid Square a -fromListList g = Grid s m +cellGrid :: Grid N a -> Grid C () +cellGrid m = Map.fromList + . map (flip (,) ()) + . filter (all (`Map.member` m) . corners) + . map cellUpRight + . Map.keys + $ m where - w = maximum . map length $ g - h = length g - s = Square w h - m = Map.fromList . concat - . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..] - $ g + cellUpRight :: N -> C + cellUpRight = fromCoord . toCoord -size :: GridShape s => Grid s a -> GridSize s -size = GS.size . shape +-- | Colour a graph. +colourM :: (Ord k, Eq a) => (k -> [k]) -> Map.Map k a -> Map.Map k Int +colourM nbrs m = fmap fromRight . execState colour' $ start + where + fromRight (Right r) = r + fromRight (Left _) = error "expected Right" -cells :: GridShape s => Grid s a -> [Cell s] -cells = Map.keys . contents + start = fmap (const $ Left [1..]) m + colour' = mapM_ pickAndFill (Map.keys m) -inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool -inBounds g c = c `elem` cells g + -- choose a colour for the given node, and spread it to + -- equal neighbours, removing it from unequal neighbours + pickAndFill x = do + v <- (Map.! x) <$> get + case v of + Left (c:_) -> fill (m Map.! x) c x + Left _ -> error "empty set of candidates" + Right _ -> return () --- | For a grid with value type @Maybe a@, return an association --- list of cells and @Just@ values. -clues :: GridShape s => Grid s (Maybe a) -> [(Cell s, a)] -clues g = [ (k, v) | (k, Just v) <- values g ] + fill a c x = do + v <- (Map.! x) <$> get + case v of + Left _ -> if m Map.! x == a + then do modify (Map.insert x (Right c)) + mapM_ (fill a c) (nbrs x) + else modify (del x c) + Right _ -> return () --- | Association list of cells and values. -values :: GridShape s => Grid s a -> [(Cell s, a)] -values (Grid _ m) = Map.toList m + -- remove the given colour from the list of candidates + del x c = Map.adjust f x + where + f (Left cs) = Left $ filter (/= c) cs + f (Right c') = Right c' -edgesGen :: (a -> a -> Bool) -> (a -> Bool) -> Grid Square a -> [Edge] -edgesGen p n g = [ E pt V | pt <- vedges ] ++ [ E pt H | pt <- hedges ] +colour :: Eq a => Grid C a -> Grid C Int +colour m = colourM edgeNeighbours' m where - edges' f (sx, sy) = [ (x + 1, y) | x <- [-1 .. sx - 1] - , y <- [-1 .. sy] - , p' (f (x, y)) (f (x + 1, y)) ] + edgeNeighbours' p = [ q | q <- edgeNeighbours p + , q `Map.member` m ] - vedges = edges' id (size g) - hedges = map swap $ edges' swap (swap . size $ g) - swap (x, y) = (y, x) - p' c d = p'' (Map.lookup c (contents g)) - (Map.lookup d (contents g)) - p'' (Just e) (Just f) = p e f - p'' (Just e) Nothing = n e - p'' Nothing (Just e) = n e - p'' _ _ = False +-- | Clues along the outside of a square grid. +-- Ordered such that coordinates increase. +data OutsideClues k a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] } + deriving (Show, Eq) -edgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] -edgesP p g = edgesGen p (const False) g +instance Functor (OutsideClues k) where + fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t) -dualEdgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] -dualEdgesP p g = [ E pt H | pt <- hedges ] ++ - [ E pt V | pt <- vedges ] +outsideSize :: OutsideClues k a -> Size +outsideSize (OC l r b t) = (w, h) where - edges' f (sx, sy) = [ (x, y) | x <- [0 .. sx - 2] - , y <- [0 .. sy - 1] - , p' (f (x, y)) (f (x + 1, y)) ] + w = max (length t) (length b) + h = max (length l) (length r) - hedges = edges' id (size g) - vedges = map swap $ edges' swap (swap . size $ g) - swap (x, y) = (y, x) - p' c d = p'' (Map.lookup c (contents g)) - (Map.lookup d (contents g)) - p'' (Just e) (Just f) = p e f - p'' _ _ = False +-- | Create a dummy grid matching the given outside clues in size. +outsideGrid :: (Ord k, FromCoord k) => OutsideClues k a -> Grid k () +outsideGrid = sizeGrid . outsideSize --- | The inner edges of a grid that separate unequal cells. -borders :: Eq a => Grid Square a -> [Edge] -borders = edgesP (/=) +-- | Create a dummy grid of the given size. +sizeGrid :: (Ord k, FromCoord k) => Size -> Grid k () +sizeGrid (w, h) = Map.mapKeys fromCoord + . Map.fromList + $ [ ((x, y), ()) | x <- [0..w-1], y <- [0..h-1] ] --- | Clues along the outside of a square grid. -data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] } - deriving (Show, Eq) +data OClue = OClue + { ocBase :: (Int, Int) + , _ocDir :: (Int, Int) + } + deriving (Show, Eq, Ord) -instance Functor OutsideClues where - fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t) +oClues :: OutsideClues k a -> Map.Map OClue a +oClues ocs@(OC l r b t) = Map.fromList . concat $ + [ zipWith (\y c -> (OClue (-1, y) (-1, 0), c)) [0..h-1] l + , zipWith (\y c -> (OClue ( w, y) ( 1, 0), c)) [0..h-1] r + , zipWith (\x c -> (OClue ( x,-1) ( 0,-1), c)) [0..w-1] b + , zipWith (\x c -> (OClue ( x, h) ( 0, 1), c)) [0..w-1] t + ] + where + (w, h) = outsideSize ocs -outsideSize :: OutsideClues a -> (Int, Int) -outsideSize (OC l r b t) = ( max (length t) (length b) - , max (length l) (length r) - ) +outsideClues :: (Ord k, FromCoord k) => OutsideClues k a -> Map.Map k a +outsideClues = Map.mapKeys (fromCoord . ocBase) . oClues -data OutsideClue a = OClue - { ocBase :: (Int, Int) - , ocDir :: (Int, Int) - , ocValue :: a - } +multiOutsideClues :: (Ord k, FromCoord k) => OutsideClues k [a] -> Map.Map k a +multiOutsideClues = Map.mapKeys fromCoord + . Map.fromList . concatMap distrib . Map.toList + . oClues + where + distrib (OClue o d, xs) = zip [o ^+^ i *^ d | i <- [0..]] xs -instance Functor OutsideClue where - fmap f (OClue b d x) = OClue b d (f x) +dualEdgesP :: Key k + => (a -> a -> Bool) -> Grid k a -> [Edge k] +dualEdgesP p m = concatMap f (Map.keys m) + where + f c = [ edge c d | d <- map (c .+^) [(0,1), (1,0)] + , d `Map.member` m && p (m Map.! c) (m Map.! d) ] -outsideClueList :: OutsideClues a -> [OutsideClue a] -outsideClueList o@(OC l r b t) = - concat - [ zipWith (\ y c -> OClue (0,y) (-1, 0) c) [0..h-1] l - , zipWith (\ y c -> OClue (w-1,y) ( 1, 0) c) [0..h-1] r - , zipWith (\ x c -> OClue (x,0) ( 0,-1) c) [0..w-1] b - , zipWith (\ x c -> OClue (x,h-1) ( 0, 1) c) [0..w-1] t - ] +collectLines :: (Key k, Eq a) => Grid k (Maybe a) -> [Edge k] +collectLines = dualEdgesP eq where - (w, h) = outsideSize o + eq (Just x) (Just y) = x == y + eq _ _ = False --- | Convert outside clues to association list mapping coordinate to value. -outsideClues :: OutsideClues (Maybe a) -> [((Int, Int), a)] -outsideClues = mapMaybe (liftMaybe . toCell) . outsideClueList +dominoGrid :: DigitRange -> Grid C (Int, Int) +dominoGrid (DigitRange x y) = + Map.mapKeys fromCoord . Map.fromList $ + [ ((a, s - b), (b + x, a + x)) + | a <- [0..s], b <- [0..s], b <= a ] where - toCell (OClue (bx, by) (dx, dy) v) = ((bx + dx, by + dy), v) - liftMaybe (p, Just x) = Just (p, x) - liftMaybe (_, Nothing) = Nothing + s = y - x -multiOutsideClues :: OutsideClues [a] -> [((Int, Int), a)] -multiOutsideClues = concatMap distrib . outsideClues . fmap Just . dired +size :: Grid Coord a -> Size +size m = foldr (both max) (0, 0) (Map.keys m) ^+^ (1, 1) where - dired (OC l r b t) = OC (z (-1,0) l) (z (1,0) r) (z (0,-1) b) (z (0,1) t) - z x ys = zip (repeat x) ys - distrib (o, (d, xs)) = zip [o ^+^ i *^ d | i <- [0..]] xs + both f (x, y) (x', y') = (f x x', f y y') diff --git a/src/Data/Puzzles/GridShape.hs b/src/Data/Puzzles/GridShape.hs --- a/src/Data/Puzzles/GridShape.hs +++ b/src/Data/Puzzles/GridShape.hs @@ -1,100 +1,219 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} -- | Grid shapes. -module Data.Puzzles.GridShape where +module Data.Puzzles.GridShape + ( + Coord + , Size + , Square(..) + , Dir(..) + , Edge(..) + , Dir'(..) + , Edge'(..) + , Dual2D(..) + , Key + , Dual' + , C(..) + , N(..) + , FromCoord(..) + , ToCoord(..) -import Data.Foldable (Foldable) + , edge + , edge' + , edgeBetween + , edgeBetween' + , orient + , ends' + , revEdge + , edges + , edgesM + , ends + , edgeSize + , unorient + , dualE + , vertexNeighbours + , edgeNeighbours + ) where + import qualified Data.Foldable as F import Data.List (partition) -import Data.VectorSpace ((^+^)) +import qualified Data.Map as Map +import Data.AffineSpace --- | The geometry of a grid. -class Show (Cell a) => GridShape a where - type GridSize a :: * - type Cell a :: * - type Vertex a :: * +type Coord = (Int, Int) - size :: a -> GridSize a - cells :: a -> [Cell a] - vertices :: a -> [Vertex a] - vertexNeighbours :: a -> Cell a -> [Cell a] - edgeNeighbours :: a -> Cell a -> [Cell a] +class FromCoord a where + fromCoord :: Coord -> a +class ToCoord a where + toCoord :: a -> Coord + +data C = C !Int !Int + deriving (Show, Eq, Ord) + +instance FromCoord C where + fromCoord = uncurry C + +instance ToCoord C where + toCoord (C x y) = (x, y) + +instance AffineSpace C where + type Diff C = (Int, Int) + + (C x y) .-. (C x' y') = (x - x', y - y') + (C x y) .+^ (x',y') = C (x + x') (y + y') + +data N = N !Int !Int + deriving (Show, Eq, Ord) + +instance FromCoord N where + fromCoord = uncurry N + +instance ToCoord N where + toCoord (N x y) = (x, y) + +instance AffineSpace N where + type Diff N = (Int, Int) + + (N x y) .-. (N x' y') = (x - x', y - y') + (N x y) .+^ (x',y') = N (x + x') (y + y') + -- | A standard square grid, with cells and vertices -- indexed by pairs of integers in mathematical coordinates. -- The bottom-left corner is vertex (0, 0), the bottom-left -- cell is cell (0, 0). -data Square = Square !Int !Int +data Square = Square deriving (Show, Eq) -squareNeighbours :: [(Int, Int)] -> Square -> Cell Square -> [Cell Square] -squareNeighbours deltas (Square w h) c = filter inBounds . map (add c) $ deltas - where - inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h - add (x, y) (x', y') = (x + x', y + y') +squareNeighbours :: [(Int,Int)] -> C -> [C] +squareNeighbours deltas c = map (c .+^) deltas -instance GridShape Square where - type GridSize Square = (Int, Int) - type Cell Square = (Int, Int) - type Vertex Square = (Int, Int) +vertexNeighbours :: C -> [C] +vertexNeighbours = squareNeighbours [ (dx, dy) + | dx <- [-1..1], dy <- [-1..1] + , dx /= 0 || dy /= 0 + ] - size (Square w h) = (w, h) - cells (Square w h) = [(x, y) | x <- [0..w-1], y <- [0..h-1]] - vertices (Square w h) = [(x, y) | x <- [0..w], y <- [0..h]] - vertexNeighbours = squareNeighbours [ (dx, dy) - | dx <- [-1..1], dy <- [-1..1] - , dx /= 0 || dy /= 0 - ] - edgeNeighbours = squareNeighbours [ (dx, dy) - | dx <- [-1..1], dy <- [-1..1] - , dx /= 0 || dy /= 0 - , dx == 0 || dy == 0 - ] +edgeNeighbours :: C -> [C] +edgeNeighbours = squareNeighbours [ (1, 0), (-1,0), (0,1), (0,-1) ] -- | Edge direction in a square grid, vertical or horizontal. -data Dir = V | H +data Dir = Vert | Horiz deriving (Eq, Ord, Show) -- | An edge in a square grid, going up or right from the given cell -- centre. -data Edge = E (Cell Square) Dir +data Edge a = E a Dir deriving (Show, Eq, Ord) -type Coord = Cell Square -type Size = GridSize Square +type Size = (Int, Int) -- | Oriented edge direction in a square grid. data Dir' = U | D | L | R deriving (Eq, Ord, Show) +toDir' :: (Int, Int) -> Dir' +toDir' ( 1, 0) = R +toDir' ( 0, 1) = U +toDir' (-1, 0) = L +toDir' ( 0,-1) = D +toDir' _ = error "non-primitive vector" + -- | An oriented edge in a square grid. --- @a@ should be @Cell Square@ or @Vertex Square@. data Edge' a = E' a Dir' deriving (Eq, Ord, Show) --- | The edge between two neighbouring cells, with the first cell --- on the left. -orientedEdge :: Cell Square -> Cell Square -> Edge' (Vertex Square) -orientedEdge (x,y) (x',y') - | x' == x && y' == y+1 = E' (x,y+1) R - | x' == x && y' == y-1 = E' (x+1,y) L - | x' == x+1 && y' == y = E' (x+1,y+1) D - | x' == x-1 && y' == y = E' (x,y) U - | otherwise = error $ "not neighbours: " ++ - show (x,y) ++ " " ++ show (x',y') +edge' :: (AffineSpace a, Diff a ~ (Int, Int)) => a -> a -> Edge' a +edge' p q = E' p (toDir' (q .-. p)) +edge :: (AffineSpace a, Diff a ~ (Int, Int)) => a -> a -> Edge a +edge p q = unorient $ edge' p q + +class Dual2D a where + type Dual a :: * + + dualE' :: Edge' a -> Edge' (Dual a) + +dualE :: Dual' a => Edge a -> Edge (Dual a) +dualE = unorient . dualE' . orient + +type Key k = (AffineSpace k, Diff k ~ (Int, Int), Ord k, FromCoord k) +type Dual' k = (Key k, Dual2D k, Key (Dual k), Dual2D (Dual k), + Dual (Dual k) ~ k) + +instance Dual2D N where + type Dual N = C + + dualE' (E' (N x y) R) = E' (C x (y-1)) U + dualE' (E' (N x y) U) = E' (C x y) L + dualE' (E' (N x y) L) = E' (C (x-1) y) D + dualE' (E' (N x y) D) = E' (C (x-1) (y-1)) R + +instance Dual2D C where + type Dual C = N + + dualE' (E' (C x y) R) = E' (N (x+1) y) U + dualE' (E' (C x y) U) = E' (N (x+1) (y+1)) L + dualE' (E' (C x y) L) = E' (N x (y+1)) D + dualE' (E' (C x y) D) = E' (N x y) R + + +ends :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge a -> (a, a) +ends (E x Vert) = (x, x .+^ (0, 1)) +ends (E x Horiz) = (x, x .+^ (1, 0)) + +ends' :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> (a, a) +ends' (E' x U) = (x, x .+^ (0, 1)) +ends' (E' x R) = (x, x .+^ (1, 0)) +ends' (E' x D) = (x, x .+^ (0, -1)) +ends' (E' x L) = (x, x .+^ (-1, 0)) + +edgeSize :: [Edge N] -> Size +edgeSize es = (maximum (map fst ps), maximum (map snd ps)) + where + ps = map toCoord + . concatMap ((\(x, y) -> [x, y]) . ends) + $ es + +revEdge :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> Edge' a +revEdge = uncurry edge' . swap . ends' + where + swap (x, y) = (y, x) + +unorient :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> Edge a +unorient (E' x U) = E x Vert +unorient (E' x R) = E x Horiz +unorient (E' x D) = E (x .-^ (0,1)) Vert +unorient (E' x L) = E (x .-^ (1,0)) Horiz + +orient :: Edge a -> Edge' a +orient (E x Vert) = E' x U +orient (E x Horiz) = E' x R + +edgeBetween' :: Dual' k => k -> k -> Edge' (Dual k) +edgeBetween' p q = dualE' (edge' p q) + +edgeBetween :: Dual' k => k -> k -> Edge (Dual k) +edgeBetween p q = unorient $ edgeBetween' p q + -- | @edges@ computes the outer and inner edges of a set of cells. -- The set is given via fold and membership predicate, the result -- is a pair @(outer, inner)@ of lists of edges, where the outer -- edges are oriented such that the outside is to the left. -edges :: Foldable f => - f (Cell Square) -> (Cell Square -> Bool) -> - ([Edge' (Vertex Square)], [Edge' (Vertex Square)]) +edges :: (Dual' k, Foldable f) => + f k -> (k -> Bool) -> + ([Edge' (Dual k)], [Edge (Dual k)]) edges cs isc = F.foldr f ([], []) cs where f c (outer, inner) = (newout ++ outer, newin ++ inner) where - nbrs = [ c ^+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ] + nbrs = [ c .+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ] (ni, no) = partition isc nbrs - newout = map (orientedEdge c) no - newin = map (orientedEdge c) . filter (c >=) $ ni + newout = [ edgeBetween' q c | q <- no ] + newin = [ edgeBetween q c | q <- ni, c >= q ] + +edgesM :: Dual' k + => Map.Map k a -> ([Edge' (Dual k)], [Edge (Dual k)]) +edgesM m = edges (Map.keysSet m) (`Map.member` m) diff --git a/src/Data/Puzzles/PuzzleTypes.hs b/src/Data/Puzzles/PuzzleTypes.hs --- a/src/Data/Puzzles/PuzzleTypes.hs +++ b/src/Data/Puzzles/PuzzleTypes.hs @@ -14,6 +14,7 @@ -- | The list of specific puzzle types we can handle. data PuzzleType = LITS | LITSPlus + | LITSSym | Geradeweg | Fillomino | Masyu @@ -42,12 +43,57 @@ | PrimePlace | Labyrinth | Bahnhof + | BlackoutDominos + | TwilightTapa + | TapaCave + | DominoPillen + | SlitherLinkMulti + | AngleLoop + | Shikaku + | SlovakSums + | Anglers + | Dominos + | FillominoCheckered + | FillominoLoop | Cave + | Numberlink + | Skyscrapers + | SkyscrapersStars + | SkyscrapersFrac + | TurningFences + | Summon + | Baca + | Buchstabensalat + | Doppelblock + | SudokuDoppelblock + | Loopki + | Scrabble + | Neighbors + | Starwars + | Starbattle + | Heyawake + | Wormhole + | Pentominous + | ColorAkari + | PersistenceOfMemory + | ABCtje + | Kropki + | StatuePark + | PentominousBorders + | NanroSignpost + | TomTom + | HorseSnake + | Illumination + | Pentopia + | PentominoPipes + | GreaterWall + | Galaxies deriving (Show, Eq) typeNames :: [(PuzzleType, String)] typeNames = [ (LITS, "lits") , (LITSPlus, "litsplus") + , (LITSSym, "lits-symmetry") , (Geradeweg, "geradeweg") , (Fillomino, "fillomino") , (Masyu, "masyu") @@ -76,7 +122,51 @@ , (PrimePlace, "primeplace") , (Labyrinth, "magiclabyrinth") , (Bahnhof, "bahnhof") + , (BlackoutDominos, "blackout-dominos") + , (TwilightTapa, "twilight-tapa") + , (TapaCave, "tapa-cave") + , (DominoPillen, "domino-pillen") + , (SlitherLinkMulti, "slitherlink-multi") + , (AngleLoop, "angleloop") + , (Shikaku, "shikaku") + , (SlovakSums, "slovaksums") + , (Anglers, "anglers") + , (Dominos, "dominos") + , (FillominoCheckered, "fillomino-checkered") + , (FillominoLoop, "fillomino-loop") , (Cave, "cave") + , (Numberlink, "numberlink") + , (Skyscrapers, "skyscrapers") + , (SkyscrapersStars, "skyscrapers-doppelstern") + , (SkyscrapersFrac, "skyscrapers-fractional") + , (TurningFences, "turning-fences") + , (Summon, "summon") + , (Baca, "baca") + , (Buchstabensalat, "buchstabensalat") + , (Doppelblock, "doppelblock") + , (SudokuDoppelblock, "sudoku-doppelblock") + , (Loopki, "loopki") + , (Scrabble, "scrabble") + , (Neighbors, "neighbors") + , (Starwars, "starwars") + , (Starbattle, "starbattle") + , (Heyawake, "heyawake") + , (Wormhole, "wormhole") + , (Pentominous, "pentominous") + , (ColorAkari, "color-akari") + , (PersistenceOfMemory, "persistenceofmemory") + , (ABCtje, "abctje") + , (Kropki, "kropki") + , (StatuePark, "statuepark") + , (PentominousBorders, "pentominous-borders") + , (NanroSignpost, "nanro-signpost") + , (TomTom, "tomtom") + , (HorseSnake, "horsesnake") + , (Illumination, "illumination") + , (Pentopia, "pentopia") + , (PentominoPipes, "pentomino-pipes") + , (GreaterWall, "greaterwall") + , (Galaxies, "galaxies") ] -- | Look up a puzzle type by name. diff --git a/src/Data/Puzzles/Sudoku.hs b/src/Data/Puzzles/Sudoku.hs --- a/src/Data/Puzzles/Sudoku.hs +++ b/src/Data/Puzzles/Sudoku.hs @@ -3,8 +3,10 @@ sudokubordersg ) where +import qualified Data.Map as Map + import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) +import Data.Puzzles.GridShape msqrt :: Integral a => a -> Maybe a msqrt x = if r ^ (2 :: Int) == x then Just r else Nothing @@ -15,22 +17,20 @@ -- | Determine the internal borders of a standard sudoku of the -- given size. -sudokuborders :: Int -> [Edge] +sudokuborders :: Int -> [Edge N] sudokuborders s = case msqrt s of Just r -> squareborders r Nothing -> case mhalf s of Just h -> rectborders h Nothing -> error "no sudoku layout of this size" - where squareborders r = [ E (r*x, y) V | x <- [1..r-1], y <- [0..r*r-1] ] - ++ [ E (x, r*y) H | x <- [0..r*r-1], y <- [1..r-1] ] - rectborders h = [ E (h, y) V | y <- [0..2*h-1] ] - ++ [ E (x, 2*y) H | x <- [0..2*h-1], y <- [1..h-1] ] + where squareborders r = [ E (N (r*x) y) Vert | x <- [1..r-1], y <- [0..r*r-1] ] + ++ [ E (N x (r*y)) Horiz | x <- [0..r*r-1], y <- [1..r-1] ] + rectborders h = [ E (N h y) Vert | y <- [0..2*h-1] ] + ++ [ E (N x (2*y)) Horiz | x <- [0..2*h-1], y <- [1..h-1] ] -- | Determine the internal borders of a standard sudoku of the -- on the given grid. -sudokubordersg :: SGrid a -> [Edge] -sudokubordersg g = sudokuborders s - where (w, h) = size g - s | w == h = w - | otherwise = error "non-square sudoku grid?" +sudokubordersg :: Grid C a -> [Edge N] +sudokubordersg = sudokuborders + . fst . size . Map.mapKeys toCoord diff --git a/src/Data/Puzzles/Util.hs b/src/Data/Puzzles/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Puzzles/Util.hs @@ -0,0 +1,32 @@ +module Data.Puzzles.Util + ( paths + , loops + ) where + +import Data.List (partition) +import Control.Monad (guard) + +paths :: Eq a => [(a, a)] -> Maybe [[a]] +paths [] = Just [] +paths ((a,b):segs) = do + (p, segs') <- collect b segs + (p', segs'') <- collect a segs' + ps <- paths segs'' + return ((reverse p' ++ p) : ps) + where + collect x sgs = case withx of + [] -> Just ([x], withoutx) + [(y,z)] -> do + (xs, sgs') <- collect (if x == y then z else y) withoutx + Just (x:xs, sgs') + _ -> Nothing + where + (withx, withoutx) = partition (\s -> fst s == x || snd s == x) sgs + +loops :: Eq a => [(a, a)] -> Maybe [[a]] +loops segs = do + ps <- paths segs + mapM_ (guard . isLoop) ps + return ps + where + isLoop p = head p == last p diff --git a/src/Diagrams/Puzzles/CmdLine.hs b/src/Diagrams/Puzzles/CmdLine.hs --- a/src/Diagrams/Puzzles/CmdLine.hs +++ b/src/Diagrams/Puzzles/CmdLine.hs @@ -6,13 +6,13 @@ , RenderOpts(..) , formats , checkFormat - , checkType - , exitErr - , readPuzzle ) where +import Data.Puzzles.CmdLine (exitErr) + import Diagrams.Prelude hiding (value, option, (<>), Result) +import Control.Monad (unless) #ifdef CAIRO import Diagrams.Backend.Cairo (B, renderCairo) @@ -20,17 +20,9 @@ import Diagrams.Backend.SVG (B, renderSVG) #endif -import Text.Puzzles.Puzzle -import Data.Puzzles.PuzzleTypes - -import System.Exit - -import Control.Monad (unless) -import qualified Data.Yaml as Y - data RenderOpts = RenderOpts { _file :: FilePath, _w :: Double } -renderB :: FilePath -> SizeSpec2D -> Diagram B R2 -> IO () +renderB :: FilePath -> SizeSpec V2 Double -> Diagram B -> IO () renderB = #ifdef CAIRO renderCairo @@ -38,8 +30,8 @@ renderSVG #endif -renderToFile :: RenderOpts -> Diagram B R2 -> IO () -renderToFile ropts = renderB (_file ropts) (Width $ _w ropts) +renderToFile :: RenderOpts -> Diagram B -> IO () +renderToFile ropts = renderB (_file ropts) (mkWidth $ _w ropts) formats :: [String] #ifdef CAIRO @@ -51,17 +43,3 @@ checkFormat :: String -> IO () checkFormat f = unless (f `elem` formats) $ exitErr $ "unknown format: " ++ f - -checkType :: Maybe String -> IO PuzzleType -checkType mt = do - t <- maybe errno return mt - maybe (errunk t) return (lookupType t) - where - errno = exitErr "no puzzle type given" - errunk t = exitErr $ "unknown puzzle type: " ++ t - -readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle) -readPuzzle = Y.decodeFileEither - -exitErr :: String -> IO a -exitErr e = putStrLn e >> exitFailure diff --git a/src/Diagrams/Puzzles/Code.hs b/src/Diagrams/Puzzles/Code.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Puzzles/Code.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.Puzzles.Code + ( + CodeDiagrams (..) + , drawCode + ) where + +import Data.Puzzles.Code +import Data.Puzzles.GridShape +import Data.Puzzles.Grid +import Diagrams.Puzzles.Lib +import Diagrams.Puzzles.Grid +import Diagrams.Puzzles.Elements + +import Diagrams.Prelude + +import qualified Data.Map as Map + +data CodeDiagrams a = CodeDiagrams { _cdLeft :: a, _cdTop :: a, _cdOver :: a } + +instance Monoid a => Monoid (CodeDiagrams a) where + mempty = CodeDiagrams mempty mempty mempty + (CodeDiagrams x y z) `mappend` (CodeDiagrams x' y' z') = + CodeDiagrams (x `mappend` x') (y `mappend` y') (z `mappend` z') + +drawCode :: Backend' b => Code -> CodeDiagrams (Diagram b) +drawCode cs = mconcat (map drawCodePart cs) + +drawCodePart :: Backend' b => CodePart -> CodeDiagrams (Diagram b) +drawCodePart (Rows' rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty + where + g = Map.fromList [ (C 0 r, arrowRight) | r <- rs ] +drawCodePart (Cols cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty + where + g = Map.fromList [ (C c 0, arrowDown) | c <- cs ] +drawCodePart (RowsN' rs) = CodeDiagrams (placeGrid g # centerX) mempty mempty + where + g = Map.fromList [ (N 0 r, arrowRight) | r <- rs ] +drawCodePart (ColsN cs) = CodeDiagrams mempty (placeGrid g # centerY) mempty + where + g = Map.fromList [ (N c 0, arrowDown) | c <- cs ] +drawCodePart (LabelsN g) = CodeDiagrams mempty mempty (placeGrid . fmap label . clues $ g) + where + label c = drawChar c # scale 0.5 # fc gray # translate (r2 (1/3, -1/3)) + +arrowDown :: Backend' b => Diagram b +arrowDown = triangle 0.7 # lwG 0 # fc (blend 0.7 white black) # rotateBy (1/2) + +arrowRight :: Backend' b => Diagram b +arrowRight = arrowDown # rotateBy (1/4) diff --git a/src/Diagrams/Puzzles/Draw.hs b/src/Diagrams/Puzzles/Draw.hs --- a/src/Diagrams/Puzzles/Draw.hs +++ b/src/Diagrams/Puzzles/Draw.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Draw ( @@ -13,35 +14,46 @@ ) where import Diagrams.Prelude -import Diagrams.BoundingBox import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths +import Diagrams.Puzzles.Code -type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2) +type RenderPuzzle b p s = (p -> Diagram b, (p, s) -> Diagram b) -type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2)) +type PuzzleSol b = (Diagram b, Maybe (Diagram b)) data OutputChoice = DrawPuzzle | DrawSolution | DrawExample deriving Show -- | Optionally render the puzzle, its solution, or a side-by-side -- example with puzzle and solution. -draw :: Backend' b => - PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2) -draw (p, ms) = fmap (bg white) . d +draw :: Backend' b + => Maybe (CodeDiagrams (Diagram b)) + -> PuzzleSol b -> OutputChoice -> Maybe (Diagram b) +draw mc (p, ms) = fmap (bg white) . d where fixup = alignPixel . border borderwidth - d DrawPuzzle = Just (fixup p) - d DrawSolution = fixup <$> ms - d DrawExample = ms >>= \s -> return $ fixup p ||| strutX 2.0 ||| fixup s + addCode x = case mc of + Nothing -> x + Just (CodeDiagrams cleft ctop cover) -> + ((cover <> x) =!= top ctop) |!| lft cleft + (=!=) = beside unitY + (|!|) = beside (negated unitX) + top c = if isEmpty c then mempty else strutY 0.5 =!= c + lft c = if isEmpty c then mempty else strutX 0.5 |!| c + isEmpty c = diameter unitX c == 0 + d DrawPuzzle = fixup . addCode <$> Just p + d DrawSolution = fixup . addCode <$> ms + d DrawExample = sideBySide <$> d DrawPuzzle <*> d DrawSolution + sideBySide x y = x ||| strutX 2.0 ||| y data Unit = Pixels | Points cmtopoint :: Double -> Double cmtopoint = (* 28.3464567) -diagramWidth :: Diagram b R2 -> Double +diagramWidth :: Backend' b => Diagram b -> Double diagramWidth = fst . unr2 . boxExtents . boundingBox toOutputWidth :: Unit -> Double -> Double @@ -49,9 +61,9 @@ Points -> wpt where wpix = round (gridresd * w) :: Int -- grid square size 40px - wpt = cmtopoint (0.8 * w) -- grid square size 0.8cm + wpt = cmtopoint w -- grid square size 1.0cm -alignPixel :: Backend' b => Diagram b R2 -> Diagram b R2 +alignPixel :: Backend' b => Diagram b -> Diagram b alignPixel = scale (1/gridresd) . align' . scale gridresd where align' d = maybe id grow (getCorners $ boundingBox d) d @@ -62,6 +74,6 @@ phantoml p q = phantom' $ p ~~ q -- | Add a phantom border of the given width around a diagram. -border :: Backend' b => Double -> Diagram b R2 -> Diagram b R2 +border :: Backend' b => Double -> Diagram b -> Diagram b border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX) . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY) diff --git a/src/Diagrams/Puzzles/Elements.hs b/src/Diagrams/Puzzles/Elements.hs --- a/src/Diagrams/Puzzles/Elements.hs +++ b/src/Diagrams/Puzzles/Elements.hs @@ -10,46 +10,55 @@ module Diagrams.Puzzles.Elements where -import Diagrams.Prelude +import Diagrams.Prelude hiding (N) import Diagrams.TwoD.Offset -import Data.Puzzles.Elements -import Data.Puzzles.GridShape +import qualified Data.Map as Map +import Data.Puzzles.Grid +import Data.Puzzles.Elements hiding (Loop) +import Data.Puzzles.GridShape hiding (edge) + import Diagrams.Puzzles.Lib +import Diagrams.Puzzles.Style import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Grid pearl :: Backend' b => - MasyuPearl -> Diagram b R2 + MasyuPearl -> Diagram b pearl m = circle 0.35 # lwG 0.05 # fc (c m) where c MWhite = white c MBlack = black smallPearl :: Backend' b => - MasyuPearl -> Diagram b R2 + MasyuPearl -> Diagram b smallPearl = scale 0.4 . pearl +drawEnd :: Backend' b => + MEnd -> Diagram b +drawEnd MEnd = smallPearl MBlack + -- | The up-right diagonal of a centered unit square. -ur :: Path R2 +ur :: Path V2 Double ur = fromVertices [p2 (-1/2,-1/2), p2 (1/2,1/2)] -- | The down-right diagonal of a centered unit square. -dr :: Path R2 +dr :: Path V2 Double dr = fromVertices [p2 (1/2,-1/2), p2 (-1/2,1/2)] -- | Both diagonals of a centered unit square. -cross :: Path R2 +cross :: Path V2 Double cross = ur <> dr -- | Draw a cross. -drawCross :: Backend' b => Diagram b R2 -drawCross = stroke cross # scale 0.8 # lwG edgewidth +drawCross :: Backend' b => Bool -> Diagram b +drawCross True = stroke cross # scale 0.8 # lwG edgewidth +drawCross False = mempty -- | Draw a Compass clue. drawCompassClue :: Backend' b => - CompassC -> Diagram b R2 + CompassC -> Diagram b drawCompassClue (CC n e s w) = texts <> stroke cross # lwG onepix where tx Nothing _ = mempty tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v) @@ -57,10 +66,17 @@ [(0,f), (f,0), (0,-f), (-f,0)] f = 3/10 --- | Draw a thermometer, given by a list of bottom-left corners --- of square cells. -thermo :: Backend' b => [P2] -> QDiagram b R2 Any -thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5)) +drawSlovakClue :: Backend' b => + SlovakClue -> Diagram b +drawSlovakClue (SlovakClue s c) = + centerY (drawInt s === strutY 0.1 === dots c) <> fillBG gray + where + dots n = centerX $ hcat' with {_sep = 0.04} (replicate n $ d) + d = circle 0.1 # lwG 0.02 # fc white + +-- | Draw a thermometer. +thermo :: Backend' b => [P2 Double] -> Diagram b +thermo vs@(v:_) = (bulb `atop` line) # col where bulb = circle 0.4 # moveTo v line = strokeLocLine (fromVertices vs) # lwG 0.55 # lineCap LineCapSquare @@ -70,13 +86,13 @@ -- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell -- coordinates. -drawThermos :: Backend' b => [Thermometer] -> QDiagram b R2 Any -drawThermos = mconcat . map (thermo . map p2i) +drawThermos :: Backend' b => [Thermometer] -> Diagram b +drawThermos = mconcat . map (thermo . map toPoint) -- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to -- draw the components. drawTight :: Backend' b => - (a -> Diagram b R2) -> Tightfit a -> Diagram b R2 + (a -> Diagram b) -> Tightfit a -> Diagram b drawTight d (Single x) = d x drawTight d (UR x y) = stroke ur # lwG onepix <> d x # scale s # translate (r2 (-t,t)) @@ -90,72 +106,107 @@ s = 2/3 -- | Stack the given words, left-justified. -stackWords :: Backend' b => [String] -> QDiagram b R2 Any -stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text') +stackWords :: Backend' b => [String] -> Diagram b +stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . textFixed) +-- | Stack the given words, left-justified, a bit more generous, nice font +stackWordsLeft :: Backend' b => [String] -> Diagram b +stackWordsLeft = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignL . text') + +-- | Stack the given words, left-justified, a bit more generous, nice font +stackWordsRight :: Backend' b => [String] -> Diagram b +stackWordsRight = vcat' (with & catMethod .~ Distrib & sep .~ 1) . map (alignR . text') + -- | Mark a word in a grid of letters. -drawMarkedWord :: Backend' b => MarkedWord -> QDiagram b R2 Any +drawMarkedWord :: Backend' b => MarkedWord -> Diagram b drawMarkedWord (MW s e) = lwG onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2)) -- | Apply 'drawMarkedWord' to a list of words. -drawMarkedWords :: Backend' b => [MarkedWord] -> QDiagram b R2 Any +drawMarkedWords :: Backend' b => [MarkedWord] -> Diagram b drawMarkedWords = mconcat . map drawMarkedWord +drawMarkedLine :: (ToPoint a, Backend' b) => MarkedLine a -> Diagram b +drawMarkedLine (MarkedLine s e) = strokePath (toPoint s ~~ toPoint e) # lwG edgewidth # lc gray + +drawMarkedLines :: (ToPoint a, Backend' b) => [MarkedLine a] -> Diagram b +drawMarkedLines = mconcat . map drawMarkedLine + -- | Draw a slalom clue. drawSlalomClue :: (Show a, Backend' b) => - a -> Diagram b R2 + a -> Diagram b drawSlalomClue x = text' (show x) # scale 0.75 <> circle 0.4 # fc white # lwG onepix +drawSlalomDiag :: Backend' b + => SlalomDiag -> Diagram b +drawSlalomDiag d = stroke (v d) # lwG edgewidth + where + v SlalomForward = ur + v SlalomBackward = dr + -- | Draw text. Shouldn't be more than two characters or so to fit a cell. -drawText :: Backend' b => String -> QDiagram b R2 Any +drawText :: Backend' b => String -> Diagram b drawText = text' +drawTextFixed :: Backend' b => String -> Diagram b +drawTextFixed = textFixed + -- | Draw an @Int@. drawInt :: Backend' b => - Int -> Diagram b R2 + Int -> Diagram b drawInt s = drawText (show s) -- | Draw a character. drawChar :: Backend' b => - Char -> Diagram b R2 + Char -> Diagram b drawChar c = drawText [c] +drawCharFixed :: Backend' b => + Char -> Diagram b +drawCharFixed c = drawTextFixed [c] + +drawCharOpaque :: Backend' b => + Char -> Diagram b +drawCharOpaque c = drawChar c <> circle 0.5 # lwG 0 # fc white + +hintTL :: Backend' b => String -> Diagram b +hintTL = moveTo (p2 (-0.4,0.4)) . scale 0.5 . alignTL . drawText + -- | Stack a list of words into a unit square. Scaled such that at least -- three words will fit. drawWords :: Backend' b => - [String] -> Diagram b R2 + [String] -> Diagram b drawWords ws = spread (-1.0 *^ unitY) (map (centerXY . scale 0.4 . drawText) ws) # centerY -- | Fit a line drawing into a unit square. -- For example, a Curve Data clue. -drawCurve :: Backend' b => [Edge] -> Diagram b R2 +drawCurve :: Backend' b => [Edge N] -> Diagram b drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) -- | Draw a shadow in the style of Afternoon Skyscrapers. -drawShade :: Backend' b => Shade -> Diagram b R2 -drawShade (Shade s w) = (if s then south else mempty) <> - (if w then west else mempty) +drawShadow :: Backend' b => Shade -> Diagram b +drawShadow (Shade s w) = (if s then south else mempty) <> + (if w then west else mempty) where shape = translate (r2 (-1/2, -1/2)) . fromVertices . map p2 $ [ (0, 0), (1/4, 1/4), (1, 1/4), (1, 0), (0, 0) ] south = strokeLocLoop shape # lwG 0 # fc gray - west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south + west = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) south -- | Draws the digits of a tapa clue, ordered -- left to right, top to bottom. drawTapaClue :: Backend' b => - TapaClue -> Diagram b R2 + TapaClue -> Diagram b drawTapaClue (TapaClue [x]) = drawInt x drawTapaClue (TapaClue xs) = fit 0.8 - . decoratePath (p (length xs)) + . atPoints (p (length xs)) . map drawInt $ xs where - p n = centerXY (p' n) + p n = mconcat . pathVertices $ centerXY (p' n) p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4) p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8 p' 4 = reflectX . rotateBy (3/8) $ square 0.7 @@ -163,7 +214,7 @@ p' _ = error "invalid tapa clue" drawPrimeDiag :: Backend' b => - PrimeDiag -> Diagram b R2 + PrimeDiag -> Diagram b drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white) where p = case d of (False, False) -> mempty @@ -171,8 +222,129 @@ (False, True) -> dr (True, True) -> ur <> dr -drawCrossing :: Backend' b => Crossing -> Diagram b R2 +drawAnglePoly :: Backend' b => + Int -> Diagram b +drawAnglePoly 3 = strokePath (triangle 0.3) # fc black +drawAnglePoly 4 = strokePath (square 0.25) # fc gray +drawAnglePoly 5 = strokePath (pentagon 0.2) # fc white +drawAnglePoly _ = error "expected 3..5" + +fish :: Double -> Angle Double -> Trail' Loop V2 Double +fish off startAngle = closeLine $ half <> half # reverseLine # reflectY + where + half = arc (angleDir startAngle) endAngle # translateY (-off) + endAngle = acosA off ^+^ (90 @@ deg) + +drawFish :: Backend' b => + Fish -> Diagram b +drawFish Fish = fit 0.6 . centerXY . fc black . strokeLoop $ + fish 0.7 (30 @@ deg) + +drawStar :: Backend' b => + Star -> Diagram b +drawStar Star = fc black . stroke . star (StarSkip 2) $ pentagon 0.3 + +vertexLoop :: VertexLoop -> Located (Trail' Loop V2 Double) +vertexLoop = mapLoc closeLine . fromVertices . map toPoint + +note :: Backend' b => + Diagram b -> Diagram b +note d = d # frame 0.2 # bg (blend 0.2 black white) + +placeNote :: Backend' b => + Size -> Diagram b -> Diagram b +placeNote sz d = note d # alignBL # translatep sz # translate (r2 (0.6,0.6)) + +placeNoteTL :: Backend' b => + Size -> Diagram b -> Diagram b +placeNoteTL sz d = note d # alignBR # translatep sz # translate (r2 (-0.6,0.6)) + +placeNoteBR :: Backend' b => + Size -> Diagram b -> Diagram b +placeNoteBR (x,_) d = note d # alignTL # translatep (x,0) # translate (r2 (0.6,-0.6)) + +miniloop :: Backend' b => Diagram b +miniloop = (drawThinEdges (map unorient out) <> grid gSlither g) + # centerXY # scale 0.4 + where + g = sizeGrid (1, 1) + (out, _) = edgesM g + +dominoBG :: Colour Double +dominoBG = blend 0.3 black white + +drawDomino :: Backend' b => (Int, Int) -> Diagram b +drawDomino (x, y) = + (drawInt x # smash ||| strutX 0.65 ||| drawInt y # smash) # centerXY # scale 0.6 + <> strokePath (rect 0.8 0.5) # lwG 0 # fc dominoBG + +newtype DominoC = DominoC C + deriving (Ord, Eq) + +instance ToPoint DominoC where + toPoint (DominoC (C x y)) = p2 ((1.0 * fromIntegral x), + (0.7 * fromIntegral y)) + +drawDominos :: Backend' b => DigitRange -> Diagram b +drawDominos = centerXY . placeGrid + . Map.mapKeys DominoC . fmap drawDomino . dominoGrid + +drawPill :: Backend' b => Int -> Diagram b +drawPill x = drawInt x # scale 0.6 + <> strokePath (roundedRect 0.8 0.5 0.2) # lwG 0 # fc dominoBG + +drawPills :: Backend' b => DigitRange -> Diagram b +drawPills (DigitRange a b) = centerXY . onGrid 1.0 0.7 drawPill $ placed + where + n = b - a + 1 + root = head [ x | x <- [n,n-1..], x*x <= n ] + placed = zip [(x, y) | x <- [0..root], y <- [root,root-1..0]] [a..b] + +drawCrossing :: Backend' b => Crossing -> Diagram b drawCrossing = const $ drawChar '+' -drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b R2 +drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b drawBahnhofClue = either drawInt drawCrossing + +kropkiDot :: Backend' b => KropkiDot -> Diagram b +kropkiDot KNone = mempty +kropkiDot c = circle 0.1 # lwG 0.03 # fc (col c) # smash + where col KWhite = white + col KBlack = blend 0.98 black white + col KNone = error "can't reach" + +drawFraction :: Backend' b => Fraction -> Diagram b +drawFraction f = centerX $ case f of + FInt a -> drawText a # scale 0.8 + FFrac a b -> frac a b + FComp a b c -> (drawText a # scale 0.8) ||| strutX (1/10) ||| frac b c + where + frac b c = stroke slash # scale (1/4) # lwG onepix + <> drawText b # scale s # translate (r2 (-t,t)) + <> drawText c # scale s # translate (r2 (t,-t)) + where t = 1/6 + s = 1/2 + slash :: Path V2 Double + slash = fromVertices [p2 (-1/3,-1/2), p2 (1/3,1/2)] + +drawMyopia :: Backend' b => Myopia -> Diagram b +drawMyopia = foldMap d' + where + d' = lwG onepix . scale (1/3) . d + d U = a (0, 0) (0, 1) + d R = a (0, 0) (1, 0) + d D = a (0, 0) (0, -1) + d L = a (0, 0) (-1, 0) + a p q = arrowBetween' (with & arrowHead .~ tri & lengths .~ verySmall) (p2 p) (p2 q) + +greaterClue :: Backend' b => GreaterClue -> [Diagram b] +greaterClue [] = mempty +greaterClue (_:rs) = g rs + where + g [] = [placeholder] + g (r:rs') = placeholder : drawRel r : g rs' + drawRel RUndetermined = mempty + drawRel RLess = drawText "<" + drawRel RGreater = drawText ">" + drawRel REqual = drawText "=" + placeholder = circle 0.35 # lwG onepix # dashingG [0.05, 0.05] 0 diff --git a/src/Diagrams/Puzzles/Grid.hs b/src/Diagrams/Puzzles/Grid.hs --- a/src/Diagrams/Puzzles/Grid.hs +++ b/src/Diagrams/Puzzles/Grid.hs @@ -5,76 +5,68 @@ import Data.Char (isUpper) import qualified Data.Map as M +import qualified Data.Set as S -import Diagrams.Prelude +import Diagrams.Prelude hiding (size, E, N, dot, outer) +import Diagrams.TwoD.Offset (offsetPath) +import qualified Data.AffineSpace as AS + +import Data.Puzzles.Util import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size, cells) +import Data.Puzzles.GridShape hiding (edge) +import Diagrams.Puzzles.Style import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths --- | Draw a small black dot with no envelope. -dot :: Backend' b => Diagram b R2 -dot = circle 0.05 # fc black # smash - --- | Draw a Slither Link style grid of dots of the specified size. -slithergrid :: Backend' b => - Size -> Diagram b R2 -slithergrid (x, y) = - hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot - -fence :: [Double] -> Double -> Path R2 -fence xs h = decoratePath xspath (repeat v) - where - xspath = fromVertices [ p2 (x, 0) | x <- xs ] - v = alignB (vrule h) +(.--.) :: AS.AffineSpace p => p -> p -> AS.Diff p +(.--.) = (AS..-.) --- | The inner grid lines of a square grid of the specified size. -gridlines :: Size -> Path R2 -gridlines (w, h) = fence' w h <> mirror (fence' h w) - where - fence' n l = fence (map fromIntegral [1..n-1]) (fromIntegral l) +class ToPoint a where + toPoint :: a -> P2 Double -fullgridlines :: Size -> Path R2 -fullgridlines (w, h) = fence' w h <> mirror (fence' h w) - where - fence' n l = fence (map fromIntegral [0..n]) (fromIntegral l) +instance ToPoint C where + toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0) --- | Draw a frame around the outside of a rectangle. -outframe' :: Backend' b => Double -> Size -> Diagram b R2 -outframe' f (w, h) = strokePointLoop r # lwG fw - where wd = fromIntegral w - hd = fromIntegral h - strokePointLoop = strokeLocTrail . mapLoc (wrapLoop . closeLine) - . fromVertices . map p2 - fw = f * gridwidth - e = fw / 2 - gridwidth / 2 - r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)] +instance ToPoint N where + toPoint c = origin .+^ r2i (c .--. N 0 0) -outframe :: Backend' b => Size -> Diagram b R2 -outframe = outframe' framewidthfactor +-- | Draw a small black dot with no envelope. +dot :: Backend' b => Diagram b +dot = circle 0.05 # fc black # smash --- | Draw a square grid, applying the given style to the grid lines. -grid' :: Backend' b => - (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2 -grid' gridstyle s = - outframe s - <> stroke (gridlines s) # lwG gridwidth # gridstyle +grid :: Backend' b + => GridStyle -> Grid C a -> Diagram b +grid s g = + (placeGrid . fmap (const vertex) . nodeGrid $ g) + <> stroke inner # linestyle (_line s) + <> stroke outer # linestyle (_border s) + <> frm + where + vertex = case _vertex s of + VertexDot -> dot + VertexNone -> mempty + linestyle LineNone = const mempty + linestyle LineThin = lwG gridwidth + linestyle LineDashed = gridDashing . lwG gridwidth + linestyle LineThick = lwG edgewidth + frm = case _frame s of + Just (FrameStyle f c) -> outLine f outer # fc c + Nothing -> mempty --- | Draw a square grid with default grid line style. -grid :: Backend' b => - Size -> Diagram b R2 -grid = grid' id + (outer, inner) = irregularGridPaths g --- | Draw a square grid with thin frame. -plaingrid :: Backend' b => - Size -> Diagram b R2 -plaingrid s = stroke (fullgridlines s) # lwG gridwidth +outLine :: Backend' b => Double -> Path V2 Double -> Diagram b +outLine f p = lwG 0 . stroke $ pin <> pout + where + pout = reversePath $ offsetPath (f * onepix - e) p + pin = offsetPath (-e) p + e = onepix / 2 -bgdashingG :: (Semigroup a, HasStyle a, V a ~ R2) => - [Double] -> Double -> Colour Double -> a -> a -bgdashingG ds offs c x = x # dashingG ds offs <> x # lc c +bgdashingG :: (Semigroup a, HasStyle a, InSpace V2 Double a) => + [Double] -> Double -> AlphaColour Double -> a -> a +bgdashingG ds offs c x = x # dashingG ds offs <> x # lcA c dashes :: [Double] dashes = [5 / 40, 3 / 40] @@ -82,141 +74,109 @@ dashoffset :: Double dashoffset = 2.5 / 40 -gridDashing :: (Semigroup a, HasStyle a, V a ~ R2) => a -> a +gridDashing :: (Semigroup a, HasStyle a, InSpace V2 Double a) => a -> a gridDashing = bgdashingG dashes dashoffset white' where - white' = blend 0.95 white black - --- | Draw a square grid with dashed grid lines. The gaps --- between dashes are off-white to aid in using filling --- tools. -dashedgrid :: Backend' b => - Size -> Diagram b R2 -dashedgrid = grid' gridDashing - -edgePath :: Edge' (Vertex Square) -> Path R2 -edgePath (E' v R) = p2i v ~~ p2i (v ^+^ (1,0)) -edgePath (E' v L) = p2i v ~~ p2i (v ^+^ (-1,0)) -edgePath (E' v U) = p2i v ~~ p2i (v ^+^ (0,1)) -edgePath (E' v D) = p2i v ~~ p2i (v ^+^ (0,-1)) + white' = black `withOpacity` (0.05 :: Double) -irregularGridPaths :: SGrid a -> (Path R2, Path R2) -irregularGridPaths (Grid _ m) = (toPath outer, toPath inner) +-- | `irregularGridPaths g` is a pair `(outer, inner)` of paths. +-- +-- `outer` consists of the loops that make up the border of the +-- grid (assuming the grid is connected orthogonally). They are +-- reoriented to be compatible with `outLine`; for some reason, +-- reversePath on the immediate result does not work. +-- +-- `inner` consists of the individual inner segments. +irregularGridPaths :: Grid C a -> (Path V2 Double, Path V2 Double) +irregularGridPaths m = (path' (map revEdge outer), path inner) where (outer, inner) = edges (M.keysSet m) (`M.member` m) - toPath = mconcat . map edgePath + path es = mconcat . map (conn . ends) $ es + path' es = case loops (map ends' es) of + Just ls -> mconcat . map (pathFromLoopVertices . map toPoint) $ ls + Nothing -> mempty + pathFromLoopVertices = pathFromLocTrail + . mapLoc (wrapLoop . closeLine) + . fromVertices + conn (v, w) = toPoint v ~~ toPoint w -irregularGrid :: Backend' b => - SGrid a -> Diagram b R2 -irregularGrid g = stroke outer # lwG (3 * gridwidth) # lineCap LineCapSquare <> - stroke inner # lwG gridwidth +irregPathToVertices :: (Path V2 Double, Path V2 Double) -> (S.Set (P2 Double), S.Set (P2 Double), S.Set (P2 Double)) +irregPathToVertices (pouter, pinner) = (outer, inner S.\\ outer, inner `S.union` outer) where - (outer, inner) = irregularGridPaths g - --- | In a square grid, use the first argument to draw things at the centres --- of cells given by coordinates. -atCentres :: (Transformable a, Monoid a, V a ~ R2) => - (t -> a) -> [(Coord, t)] -> a -atCentres dc = translate (r2 (1/2, 1/2)) . atVertices dc + outer = S.fromList . mconcat . pathVertices $ pouter + inner = S.fromList . mconcat . pathVertices $ pinner -atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a] -atCentres' = translate (r2 (1/2, 1/2)) . atVertices' +onGrid :: (Transformable a, Monoid a, InSpace V2 Double a) => + Double -> Double -> (t -> a) -> [(Coord, t)] -> a +onGrid dx dy f = mconcat . map g + where + g (p, c) = f c # translate (r2coord p) + r2coord (x, y) = r2 (dx * fromIntegral x, dy * fromIntegral y) --- | In a square grid, use the first argument to draw things --- at the grid vertices given by coordinates. -atVertices :: (Transformable a, Monoid a, V a ~ R2) => - (t -> a) -> [(Coord, t)] -> a -atVertices dc = mconcat . map (\ (p, c) -> dc c # translatep p) +placeGrid :: (ToPoint k, HasOrigin a, Monoid a, InSpace V2 Double a) + => Grid k a -> a +placeGrid = M.foldMapWithKey (moveTo . toPoint) -atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a] -atVertices' g = [ (g ! c) # translatep c | c <- cells g ] +placeGrid' :: (HasOrigin a, Monoid a, InSpace V2 Double a) + => Grid (P2 Double) a -> a +placeGrid' = M.foldMapWithKey moveTo -edge :: Edge -> Path R2 -edge (E c d) = rule d # translate (r2i c) +edge :: (ToPoint k) => Edge k -> Path V2 Double +edge (E c d) = rule d # translate (toPoint c .-. origin) where - rule V = vrule 1.0 # alignB - rule H = hrule 1.0 # alignL + rule Vert = vrule 1.0 # alignB + rule Horiz = hrule 1.0 # alignL -dualEdge :: Edge -> Path R2 -dualEdge = translate (r2 (1/2, 1/2)) . edge +midPoint :: (AS.AffineSpace k, AS.Diff k ~ (Int, Int), ToPoint k) => Edge k -> P2 Double +midPoint e = c .+^ 0.5 *^ (d .-. c) + where + (a, b) = ends e + c = toPoint a + d = toPoint b -edgeStyle :: (HasStyle a, V a ~ R2) => a -> a +edgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a edgeStyle = lineCap LineCapSquare . lwG edgewidth -thinEdgeStyle :: (HasStyle a, V a ~ R2) => a -> a +thinEdgeStyle :: (HasStyle a, InSpace V2 Double a) => a -> a thinEdgeStyle = lineCap LineCapSquare . lwG onepix -drawEdges :: Backend' b => [Edge] -> Diagram b R2 +drawEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b drawEdges = edgeStyle . stroke . mconcat . map edge -drawDualEdges :: Backend' b => [Edge] -> Diagram b R2 -drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge - -drawThinDualEdges :: Backend' b => [Edge] -> Diagram b R2 -drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge +drawThinEdges :: (ToPoint k, Backend' b) => [Edge k] -> Diagram b +drawThinEdges = thinEdgeStyle . stroke . mconcat . map edge -drawAreaGrid :: (Backend' b, Eq a) => - SGrid a -> Diagram b R2 -drawAreaGrid = drawEdges . borders <> grid . size +drawAreas :: (Backend' b, Eq a) => + Grid C a -> Diagram b +drawAreas = drawEdges . borders -fillBG :: Backend' b => Colour Double -> Diagram b R2 +fillBG :: Backend' b => Colour Double -> Diagram b fillBG c = square 1 # lwG onepix # fc c # lc c shadeGrid :: Backend' b => - SGrid (Maybe (Colour Double)) -> Diagram b R2 -shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG) + Grid C (Maybe (Colour Double)) -> Diagram b +shadeGrid = placeGrid . fmap fillBG . clues -drawShadedGrid :: Backend' b => - SGrid Bool -> Diagram b R2 -drawShadedGrid = shadeGrid . fmap f +drawShade :: Backend' b => + Grid C Bool -> Diagram b +drawShade = shadeGrid . fmap f where f True = Just gray f False = Nothing -drawAreaGridGray :: Backend' b => - SGrid Char -> Diagram b R2 -drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols +drawAreasGray :: Backend' b => + Grid C Char -> Diagram b +drawAreasGray = drawAreas <> shadeGrid . fmap cols where cols c | isUpper c = Just (blend 0.1 black white) | otherwise = Nothing -irregAreaGridX :: Backend' b => - SGrid Char -> Diagram b R2 -irregAreaGridX = irregularGrid <> drawEdges . borders <> shadeGrid . fmap cols - where - cols 'X' = Just gray - cols _ = Nothing - -- Place a list of diagrams along a ray, with steps of size -- @f@. -distrib :: (Transformable c, Monoid c, V c ~ R2) => - R2 -> (Int, Int) -> Double -> [c] -> c +distrib :: (Transformable c, Monoid c, InSpace V2 Double c) => + V2 Double -> (Int, Int) -> Double -> [c] -> c distrib base dir f xs = translate (0.75 *^ dir' ^+^ base) . mconcat $ zipWith (\i d -> translate (fromIntegral i *^ dir') d) [(0 :: Int)..] xs where dir' = f *^ r2i dir - -outsideGen :: (Transformable c, Monoid c, V c ~ R2) => - (OutsideClue [c] -> R2) -> Double -> [OutsideClue [c]] -> c -outsideGen tobase f ocs = mconcat . map placeOC $ ocs - where - placeOC o = distrib (tobase o) (ocDir o) f (ocValue o) - -outsideCells :: (Transformable c, Monoid c, V c ~ R2) => - Double -> [OutsideClue [c]] -> c -outsideCells = outsideGen base - where - base (OClue (bx, by) (dx, dy) _) - | dx /= 0 = r2 (fromIntegral bx - 1, fromIntegral by - 1/2) - | dy /= 0 = r2 (fromIntegral bx - 1/2, fromIntegral by) - | otherwise = error "invalid outside clue" - -outsideVertices :: (Transformable c, Monoid c, V c ~ R2) => - Double -> [OutsideClue [c]] -> c -outsideVertices = outsideGen base - where - base (OClue (bx, by) (dx, dy) _) - | dx /= 0 = r2 (fromIntegral bx, fromIntegral by) - | dy /= 0 = r2 (fromIntegral bx, fromIntegral by) - | otherwise = error "invalid outside clue" diff --git a/src/Diagrams/Puzzles/Lib.hs b/src/Diagrams/Puzzles/Lib.hs --- a/src/Diagrams/Puzzles/Lib.hs +++ b/src/Diagrams/Puzzles/Lib.hs @@ -1,99 +1,132 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Lib where +import Diagrams.Path (pathPoints) import Diagrams.Prelude -import Graphics.SVGFonts.ReadFont +import Graphics.SVGFonts.Text (TextOpts(..), Mode(..), Spacing(..), textSVG') +import Graphics.SVGFonts.Fonts (bit) +import Graphics.SVGFonts.ReadFont (PreparedFont, loadFont) + import Control.Arrow ((***)) import Paths_puzzle_draw (getDataFileName) import System.IO.Unsafe (unsafePerformIO) -type Backend' b = (Backend b R2, Renderable (Path R2) b) +type Backend' b = (V b ~ V2, N b ~ Double, + Renderable (Path V2 Double) b, Backend b V2 Double) -- | Vertical/horizontal stroked line of given length. -vline, hline :: Backend' b => Double -> Diagram b R2 +vline, hline :: Backend' b => Double -> Diagram b vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)] hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)] -- | Variant of 'hcat'' that spreads with distance @1@. -hcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a +hcatsep :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a) + => [a] -> a hcatsep = hcat' with {_sep = 1} -- | Variant of 'vcat'' that spreads with distance @1@, -- and stacks towards the top. -vcatsep :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [a] -> a +vcatsep :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a) + => [a] -> a vcatsep = cat' (r2 (0,1)) with {_sep = 1} -- | Collapse the envelope to a point. -smash :: Backend' b => QDiagram b R2 Any -> QDiagram b R2 Any -smash = withEnvelope (pointDiagram origin :: D R2) +smash :: Backend' b => Diagram b -> Diagram b +smash = withEnvelope (pointDiagram origin :: D V2 Double) -- | Helper to translate by a point given as @(Int, Int)@. -translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t +translatep :: (InSpace V2 Double t, Transformable t) + => (Int, Int) -> t -> t translatep = translate . r2i -- | Convert pair of @Int@ to vector. -r2i :: (Int, Int) -> R2 +r2i :: (Int, Int) -> V2 Double r2i = r2 . (fromIntegral *** fromIntegral) -- | Convert pair of @Int@ to point. -p2i :: (Int, Int) -> P2 +p2i :: (Int, Int) -> P2 Double p2i = p2 . (fromIntegral *** fromIntegral) -mirror :: (Transformable t, V t ~ R2) => t -> t -mirror = reflectAbout (p2 (0, 0)) (r2 (1, 1)) +mirror :: (InSpace V2 Double t, Transformable t) => t -> t +mirror = reflectAbout (p2 (0, 0)) (direction $ r2 (1, -1)) -- | Interleave two lists. interleave :: [a] -> [a] -> [a] interleave [] _ = [] interleave (x:xs) ys = x : interleave ys xs +magnitude :: V2 Double -> Double +magnitude = norm + -- | Spread diagrams evenly along the given vector. -spread :: Backend' b => R2 -> [Diagram b R2] -> Diagram b R2 +spread :: Backend' b => V2 Double -> [Diagram b] -> Diagram b spread v things = cat v . interleave (repeat (strut vgap)) $ things where ds = map (diameter v) things gap' = (magnitude v - sum ds) / fromIntegral (length things + 1) vgap = (gap' / magnitude v) *^ v -dmid :: (Enveloped a, V a ~ R2) => a -> Double -dmid a = (dtop + dbot) / 2 - dbot +dmid :: (InSpace V2 Double a, Enveloped a) => V2 Double -> a -> Double +dmid u a = (dtop + dbot) / 2 - dbot where menv v = magnitude . envelopeV v - dtop = menv unitY a - dbot = menv ((-1) *^ unitY) a + dtop = menv u a + dbot = menv ((-1) *^ u) a -- | Place the second diagram to the right of the first, aligning both -- vertically. The origin is the origin of the left diagram. -besidesL :: (Backend' b, Semigroup m, Monoid m) => - QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m +besidesL :: Backend' b => + Diagram b -> Diagram b -> Diagram b besidesL a b = a ||| strutX 0.5 ||| b' - where b' = b # centerY # translate (dmid a *^ unitY) + where b' = b # centerY # translate (dmid unitY a *^ unitY) -- | Variant of 'besidesL' where the origin is that of the right diagram. -besidesR :: (Backend' b, Semigroup m, Monoid m) => - QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m +besidesR :: Backend' b => + Diagram b -> Diagram b -> Diagram b besidesR b a = b' ||| strutX 0.5 ||| a - where b' = b # centerY # translate (dmid a *^ unitY) + where b' = b # centerY # translate (dmid unitY a *^ unitY) +aboveT :: Backend' b => + Diagram b -> Diagram b -> Diagram b +aboveT a b = a === strutY 0.5 === b' + where b' = b # centerX # translate (dmid unitX a *^ unitX) + -- | @fit f a@ scales @a@ to fit into a square of size @f@. -fit :: (Transformable t, Enveloped t, V t ~ R2) => +fit :: (Transformable t, Enveloped t, InSpace V2 Double t) => Double -> t -> t fit f a = scale (f / m) a - where m = max (magnitude (diameter unitX a)) - (magnitude (diameter unitY a)) + where m = max (diameter unitX a) + (diameter unitY a) +type Font = PreparedFont Double + -- | Write text that is centered both vertically and horizontally and that -- has an envelope. Sized such that single capital characters fit nicely -- into a square of size @1@. -text' :: Backend' b => String -> Diagram b R2 -text' t = stroke (textSVG' $ TextOpts t fnt INSIDE_H KERN False 1 1) - # lwG 0 # fc black # scale 0.8 +text'' :: Backend' b => Font -> String -> Diagram b +text'' fnt t = stroke (textSVG' (TextOpts fnt INSIDE_H KERN False 1 1) t) + # lwG 0 # rfc black # scale 0.8 where - fnt = outlMap . unsafePerformIO . getDataFileName - $ "data/fonts/gen-light.svg" + rfc :: (HasStyle a, InSpace V2 Double a) => Colour Double -> a -> a + rfc = recommendFillColor +text' :: Backend' b => String -> Diagram b +text' = text'' fontGenLight + +textFixed :: Backend' b => String -> Diagram b +textFixed = text'' fontBit + +fontGenLight :: Font +fontGenLight = unsafePerformIO . loadFont . unsafePerformIO . getDataFileName + $ "data/fonts/gen-light.svg" + +fontBit :: Font +fontBit = bit + -- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07)) -- <> phantom' (textrect t) --textrect :: Backend' b => String -> Diagram b R2 @@ -102,5 +135,19 @@ --text'' t = text' t `atop` textrect t -- | Variant of 'phantom' that forces the argument backend type. -phantom' :: Backend' b => Diagram b R2 -> Diagram b R2 +phantom' :: Backend' b => Diagram b -> Diagram b phantom' = phantom + +debugPath :: Backend' b => Path V2 Double -> Diagram b +debugPath p = mconcat . map draw $ prts' + where + prts = zip (pathVertices p) ['a'..] + prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts + draw (pt, l) = moveTo pt $ text' l + +debugPath' :: Backend' b => Path V2 Double -> Diagram b +debugPath' p = mconcat . map draw $ prts' + where + prts = zip (pathPoints p) ['a'..] + prts' = concatMap (\(ps,c) -> zipWith (\pt d -> (pt, c:d:[])) ps ['0'..]) prts + draw (pt, l) = moveTo pt $ text' l diff --git a/src/Diagrams/Puzzles/PuzzleGrids.hs b/src/Diagrams/Puzzles/PuzzleGrids.hs --- a/src/Diagrams/Puzzles/PuzzleGrids.hs +++ b/src/Diagrams/Puzzles/PuzzleGrids.hs @@ -3,91 +3,91 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} -module Diagrams.Puzzles.PuzzleGrids where +module Diagrams.Puzzles.PuzzleGrids + ( + drawIntGrid + , drawCharGrid + , outsideIntGrid + , drawSlitherGrid + , drawTightGrid + , sudokugrid + , drawWordsClues + , drawOutsideGrid + , drawMultiOutsideGrid + , drawOutsideGridN + , drawMultiOutsideGridN + , placeMultiOutside + ) where -import Diagrams.Prelude +import Diagrams.Prelude hiding (size, N) +import qualified Data.Map as Map +import Data.Maybe (maybeToList) + import Data.Puzzles.Grid +import Data.Puzzles.GridShape import Data.Puzzles.Elements import Data.Puzzles.Sudoku import Diagrams.Puzzles.Lib +import Diagrams.Puzzles.Style import Diagrams.Puzzles.Grid -import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Elements -drawClueGrid :: Backend' b => - SGrid (Clue Char) -> Diagram b R2 -drawClueGrid = atCentres drawChar . clues <> grid . size - -drawIntClues :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawIntClues = atCentres drawInt . clues - -drawInts :: Backend' b => - SGrid Int -> Diagram b R2 -drawInts = atCentres drawInt . values +drawCharGrid :: Backend' b => + Grid C (Maybe Char) -> Diagram b +drawCharGrid = placeGrid . fmap drawChar . clues <> grid gDefault drawIntGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawIntGrid = drawIntClues <> grid . size + Grid C (Maybe Int) -> Diagram b +drawIntGrid = placeGrid . fmap drawInt . clues <> grid gDefault drawSlitherGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size - -drawMasyuGrid :: Backend' b => - SGrid MasyuClue -> Diagram b R2 -drawMasyuGrid = atCentres pearl . clues <> grid . size - -drawCompassClues :: Backend' b => - SGrid CompassClue -> Diagram b R2 -drawCompassClues = atCentres drawCompassClue . clues - -drawCompassGrid :: Backend' b => - SGrid CompassClue -> Diagram b R2 -drawCompassGrid = drawCompassClues <> grid . size + Grid C (Maybe Int) -> Diagram b +drawSlitherGrid = placeGrid . fmap drawInt . clues <> grid gSlither sudokugrid :: Backend' b => - SGrid a -> Diagram b R2 -sudokugrid = drawEdges . sudokubordersg <> grid . size + Grid C a -> Diagram b +sudokugrid = drawEdges . sudokubordersg <> grid gDefault drawWordsClues :: Backend' b => - SGrid (Clue [String]) -> Diagram b R2 -drawWordsClues = atCentres drawWords . clues + Grid C (Maybe [String]) -> Diagram b +drawWordsClues = placeGrid . fmap drawWords . clues drawTightGrid :: Backend' b => - (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2 -drawTightGrid d g = atCentres (drawTight d) (values g) - <> grid (size g) - <> phantom' (stroke $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1)) - where (sx, sy) = size g + (t -> Diagram b) -> Grid C (Tightfit t) -> Diagram b +drawTightGrid d g = (placeGrid . fmap (drawTight d) $ g) + <> grid gDefault g + <> phantom' (strokePath $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1)) + where (sx, sy) = size (Map.mapKeys toCoord g) -drawSlalomGrid :: Backend' b => - SGrid (Clue Int) -> Diagram b R2 -drawSlalomGrid g = atVertices drawSlalomClue (clues g) - <> grid (w-1, h-1) - where (w, h) = size g +placeMultiOutside :: (Ord k, FromCoord k, ToPoint k, + HasOrigin a, Monoid a, + InSpace V2 Double a) + => OutsideClues k [a] -> a +placeMultiOutside = placeGrid . multiOutsideClues -drawSlalomDiags :: Backend' b => - SGrid SlalomDiag -> Diagram b R2 -drawSlalomDiags = atCentres diag . clues . fmap Just - where diag SlalomForward = stroke ur # lwG edgewidth - diag SlalomBackward = stroke dr # lwG edgewidth +placeOutside :: (Ord k, FromCoord k, ToPoint k, + HasOrigin a, Monoid a, + InSpace V2 Double a) + => OutsideClues k (Maybe a) -> a +placeOutside = placeMultiOutside . fmap maybeToList -drawCrosses :: Backend' b => - SGrid Bool -> Diagram b R2 -drawCrosses = atCentres (if' drawCross mempty) . values - where - if' a b x = if x then a else b +drawOutsideGrid :: Backend' b => OutsideClues C (Maybe String) -> Diagram b +drawOutsideGrid = placeOutside . fmap (fmap (scale 0.8 . drawText)) + <> grid gDefault . outsideGrid +drawOutsideGridN :: Backend' b => OutsideClues N (Maybe String) -> Diagram b +drawOutsideGridN = placeOutside . fmap (fmap (scale 0.8 . drawText)) + <> grid gDefault . cellGrid . outsideGrid -outsideGrid :: Backend' b => - OutsideClues [String] -> Diagram b R2 -outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues - <> grid . outsideSize +drawMultiOutsideGrid :: Backend' b => OutsideClues C [String] -> Diagram b +drawMultiOutsideGrid = placeMultiOutside . fmap (fmap (scale 0.8 . drawText)) + <> grid gDefault . outsideGrid -outsideIntGrid :: Backend' b => - OutsideClues [Int] -> Diagram b R2 -outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues - <> grid . outsideSize +drawMultiOutsideGridN :: Backend' b => OutsideClues N [String] -> Diagram b +drawMultiOutsideGridN = placeMultiOutside . fmap (fmap (scale 0.8 . drawText)) + <> grid gDefault . cellGrid . outsideGrid + +outsideIntGrid :: Backend' b => OutsideClues C [Int] -> Diagram b +outsideIntGrid = drawMultiOutsideGrid . fmap (fmap show) diff --git a/src/Diagrams/Puzzles/PuzzleTypes.hs b/src/Diagrams/Puzzles/PuzzleTypes.hs --- a/src/Diagrams/Puzzles/PuzzleTypes.hs +++ b/src/Diagrams/Puzzles/PuzzleTypes.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -10,11 +11,25 @@ curvedata, doubleback, slalom, compass, boxof2or3, afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral, maximallengths, primeplace, labyrinth, bahnhof, - cave + cave, angleLoop, shikaku, slovaksums, + blackoutDominos, anglers, skyscrapers, + summon, baca, buchstabensalat, doppelblock, sudokuDoppelblock, + dominos, skyscrapersStars, fillominoCheckered, numberlink, + slithermulti, dominoPills, fillominoLoop, loopki, litssym, + scrabble, neighbors, starwars, heyawake, wormhole, pentominous, + starbattle, colorakari, persistenceOfMemory, abctje, kropki, + statuepark, pentominousBorders, nanroSignpost, tomTom, + horseSnake, illumination, pentopia, + pentominoPipes, greaterWall, galaxies ) where -import Diagrams.Prelude hiding (Loop, coral) +import Diagrams.Prelude hiding (Loop, N, coral, size) +import Data.Char (isUpper) +import Data.List (nub, sort, sortOn) +import qualified Data.Map as Map + +import Diagrams.Puzzles.Style import Diagrams.Puzzles.PuzzleGrids import Diagrams.Puzzles.Draw import Diagrams.Puzzles.Grid @@ -24,64 +39,97 @@ import Diagrams.Puzzles.Widths import Data.Puzzles.Grid -import Data.Puzzles.GridShape (Edge) +import Data.Puzzles.GridShape import Data.Puzzles.Elements import qualified Data.Puzzles.Pyramid as Pyr lits :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid lits = (,) - drawAreaGridGray - (drawAreaGrid . fst <> drawShadedGrid . snd) + (grid gDefault <> drawAreasGray) + ((drawAreas <> grid gDefault) . fst <> drawShade . snd) litsplus :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid litsplus = lits -solstyle :: (HasStyle a, V a ~ R2) => a -> a +litssym :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid +litssym = (,) + p + (p . fst <> drawShade . snd) + where + p g = drawAreas g <> grid gDefault g <> translate (c g) (scale 0.5 $ smallPearl MBlack) + c g = let (rs, cs) = size . Map.mapKeys toCoord $ g + in r2 ((fromIntegral rs) / 2, (fromIntegral cs) / 2) + +solstyle :: (HasStyle a, InSpace V2 Double a) => a -> a solstyle = lc (blend 0.8 black white) . lwG (3 * onepix) -geradeweg :: Backend' b => RenderPuzzle b IntGrid Loop +geradeweg :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Loop C) geradeweg = (,) drawIntGrid - (drawIntClues . fst - <> solstyle . drawDualEdges . snd - <> grid . size . fst) + (placeGrid . fmap drawInt . clues . fst + <> solstyle . drawEdges . snd + <> grid gDefault . fst) -fillomino :: Backend' b => RenderPuzzle b IntGrid (SGrid Int) +fillomino :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Grid C Int) fillomino = (,) - (atCentres drawInt . clues <> dashedgrid . size) - ((atCentres drawInt . values <> drawEdges . borders <> dashedgrid . size) . snd) + (placeGrid . fmap drawInt . clues <> grid gDashed) + ((placeGrid . fmap drawInt <> drawEdges . borders <> grid gDashed) . snd) +fillominoCheckered :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) (Grid C Int) +fillominoCheckered = (,) + (placeGrid . fmap drawInt . clues <> grid gDashed) + ((placeGrid . fmap drawInt + <> drawEdges . borders + <> grid gDashed + <> shadeGrid . checker) . snd) + where + checker = fmap pickColour . colour + pickColour 1 = Nothing + pickColour 2 = Just gray + pickColour _ = Just red + +fillominoLoop :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) + (Grid C Int, Loop C) +fillominoLoop = (,) + (fst fillomino) + ((placeGrid . fmap drawInt . fst + <> solstyle . drawEdges . snd + <> drawEdges . borders . fst + <> grid gDashed . fst) . snd) + masyu :: Backend' b => - RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop + RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Loop C) masyu = (,) - drawMasyuGrid - (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst) + p + (solstyle . drawEdges . snd <> p . fst) + where + p = placeGrid . fmap pearl . clues <> grid gDefault nurikabe :: Backend' b => - RenderPuzzle b IntGrid ShadedGrid + RenderPuzzle b (Grid C (Maybe Int)) ShadedGrid nurikabe = (,) drawIntGrid - (drawIntGrid . fst <> drawShadedGrid . snd) + (drawIntGrid . fst <> drawShade . snd) latintapa :: Backend' b => - RenderPuzzle b (SGrid (Clue [String])) CharClueGrid + RenderPuzzle b (Grid C (Maybe [String])) (Grid C (Maybe Char)) latintapa = (,) l - (l . fst <> atCentres drawChar . clues . snd) + (l . fst <> placeGrid . fmap drawChar . clues . snd) where - l = grid . size <> drawWordsClues + l = grid gDefault <> drawWordsClues sudoku :: Backend' b => - RenderPuzzle b IntGrid IntGrid + RenderPuzzle b (Grid C (Maybe Int)) (Grid C (Maybe Int)) sudoku = (,) - (drawIntClues <> sudokugrid) - ((drawIntClues <> sudokugrid) . snd) + (placeGrid . fmap drawInt . clues <> sudokugrid) + ((placeGrid . fmap drawInt . clues <> sudokugrid) . snd) thermosudoku :: Backend' b => - RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid + RenderPuzzle b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int)) thermosudoku = (,) - (drawInts . fst <> sudokugrid . fst <> drawThermos . snd) - (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst) + (placeGrid . fmap drawInt . clues . fst <> sudokugrid . fst <> drawThermos . snd) + (placeGrid . fmap drawInt . clues . snd <> sudokugrid . snd <> drawThermos . snd . fst) pyramid :: Backend' b => RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol @@ -100,158 +148,610 @@ merge (p, q) = Pyr.mergekpyramidsol p q slither :: Backend' b => - RenderPuzzle b IntGrid Loop + RenderPuzzle b (Grid C (Maybe Int)) (Loop N) slither = (,) drawSlitherGrid (drawSlitherGrid . fst <> solstyle . drawEdges . snd) liarslither :: Backend' b => - RenderPuzzle b IntGrid (Loop, SGrid Bool) + RenderPuzzle b (Grid C (Maybe Int)) (Loop N, Grid C Bool) liarslither = (,) drawSlitherGrid - (solstyle . drawCrosses . snd . snd + (placeGrid . fmap (solstyle . drawCross) . snd . snd <> drawSlitherGrid . fst <> solstyle . drawEdges . fst . snd) +slithermulti :: Backend' b => + RenderPuzzle b (Grid C (Maybe Int), Int) [Edge N] +slithermulti = (,) + (drawSlitherGrid . fst <> n) + (drawSlitherGrid . fst . fst <> solstyle . drawEdges . snd) + where + n (g, l) = placeNote (size' g) (drawInt l ||| strutX 0.2 ||| miniloop) + size' = size . Map.mapKeys toCoord + tightfitskyscrapers :: Backend' b => - RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ())) - (SGrid (Tightfit Int)) + RenderPuzzle b (OutsideClues C (Maybe Int), Grid C (Tightfit ())) + (Grid C (Tightfit Int)) tightfitskyscrapers = (,) - (atCentres drawInt . outsideClues . fst + (placeGrid . fmap drawInt . clues . outsideClues . fst <> drawTightGrid (const mempty) . snd) - (atCentres drawInt . outsideClues . fst . fst + (placeGrid . fmap drawInt . clues . outsideClues . fst . fst <> drawTightGrid drawInt . snd) wordgrid :: Backend' b => - SGrid (Maybe Char) -> [String] -> Diagram b R2 -wordgrid g ws = stackWords ws `besidesR` drawClueGrid g + Grid C (Maybe Char) -> [String] -> Diagram b +wordgrid g ws = stackWords ws `besidesR` drawCharGrid g wordloop :: Backend' b => - RenderPuzzle b (CharClueGrid, [String]) CharClueGrid + RenderPuzzle b (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) wordloop = (,) (uncurry wordgrid) - (drawClueGrid . snd) + (drawCharGrid . snd) wordsearch :: Backend' b => - RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord]) + RenderPuzzle b (Grid C (Maybe Char), [String]) + (Grid C (Maybe Char), [MarkedWord]) wordsearch = (,) (uncurry wordgrid) (solstyle . drawMarkedWords . snd . snd - <> drawClueGrid . fst . snd) + <> drawCharGrid . fst . snd) curvedata :: Backend' b => - RenderPuzzle b (SGrid (Clue [Edge])) [Edge] + RenderPuzzle b (Grid C (Maybe [Edge N])) [Edge C] curvedata = (,) cd - ((solstyle . drawDualEdges . snd) <> cd . fst) + ((solstyle . drawEdges . snd) <> cd . fst) where - cd = atCentres drawCurve . clues <> grid . size + cd = placeGrid . fmap drawCurve . clues <> grid gDefault doubleback :: Backend' b => - RenderPuzzle b AreaGrid Loop + RenderPuzzle b AreaGrid (Loop C) doubleback = (,) - drawAreaGridGray - (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst) + p + (solstyle . drawEdges . snd <> p . fst) + where + p = grid gDefault <> drawAreasGray slalom :: Backend' b => - RenderPuzzle b IntGrid (SGrid SlalomDiag) + RenderPuzzle b (Grid N (Maybe Int)) (Grid C SlalomDiag) slalom = (,) - drawSlalomGrid - (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd) + p + (p . fst <> placeGrid . fmap (solstyle . drawSlalomDiag) . snd) + where + p = placeGrid . fmap drawSlalomClue . clues + <> grid gDefault . cellGrid compass :: Backend' b => - RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid + RenderPuzzle b (Grid C (Maybe CompassC)) AreaGrid compass = (,) - drawCompassGrid - (drawCompassClues . fst <> drawAreaGridGray . snd) + (placeGrid . fmap drawCompassClue . clues <> grid gDashed) + (placeGrid . fmap drawCompassClue . clues . fst + <> (grid gDashed <> drawAreasGray) . snd) boxof2or3 :: Backend' b => - RenderPuzzle b (SGrid MasyuPearl, [Edge]) () + RenderPuzzle b (Grid N MasyuPearl, [Edge N]) () boxof2or3 = (,) - (atCentres smallPearl . values . fst - <> phantom' . grid . size . fst - <> drawThinDualEdges . snd) + (placeGrid . fmap smallPearl . fst + <> drawThinEdges . snd) (error "boxof2or3 solution not implemented") afternoonskyscrapers :: Backend' b => - RenderPuzzle b (SGrid Shade) IntGrid + RenderPuzzle b (Grid C Shade) (Grid C (Maybe Int)) afternoonskyscrapers = (,) - (grid . size <> atCentres drawShade . values) - (drawIntGrid . snd <> atCentres drawShade . values . fst) + (grid gDefault <> placeGrid . fmap drawShadow) + (drawIntGrid . snd <> placeGrid . fmap drawShadow . fst) meanderingnumbers :: Backend' b => - RenderPuzzle b AreaGrid IntGrid + RenderPuzzle b AreaGrid (Grid C (Maybe Int)) meanderingnumbers = (,) - drawAreaGrid - (drawIntGrid . snd <> drawAreaGrid . fst) + (grid gDefault <> drawAreas) + (drawIntGrid . snd <> drawAreas . fst) tapa :: Backend' b => - RenderPuzzle b (SGrid TapaClue) ShadedGrid + RenderPuzzle b (Grid C (Maybe TapaClue)) ShadedGrid tapa = (,) tapaGrid - (tapaGrid . fst <> drawShadedGrid . snd) + (tapaGrid . fst <> drawShade . snd) where - tapaGrid = atCentres drawTapaClue . values <> grid . size + tapaGrid = placeGrid . fmap drawTapaClue . clues <> grid gDefault japanesesums :: Backend' b => - RenderPuzzle b (OutsideClues [Int]) (SGrid (Either Black Int)) + RenderPuzzle b (OutsideClues C [Int], String) + (Grid C (Either Black Int)) japanesesums = (,) - outsideIntGrid - (outsideIntGrid . fst <> japcells . snd) + (outsideIntGrid . fst <> n) + (outsideIntGrid . fst . fst <> japcells . snd) where - japcells = atCentres japcell . values + n (ocs, ds) = placeNoteTL (0, h ocs) (drawText ds # scale 0.8) + japcells = placeGrid . fmap japcell japcell (Left Black) = fillBG gray japcell (Right x) = drawInt x + h = snd . outsideSize coral :: Backend' b => - RenderPuzzle b (OutsideClues [String]) ShadedGrid + RenderPuzzle b (OutsideClues C [String]) ShadedGrid coral = (,) - outsideGrid - (outsideGrid . fst <> drawShadedGrid . snd) + drawMultiOutsideGrid + (drawMultiOutsideGrid . fst <> drawShade . snd) maximallengths :: Backend' b => - RenderPuzzle b (OutsideClues (Maybe Int)) Loop + RenderPuzzle b (OutsideClues C (Maybe Int)) (Loop C) maximallengths = (,) g - (solstyle . drawDualEdges . snd <> g . fst) + (solstyle . drawEdges . snd <> g . fst) where - g = atCentres drawInt . outsideClues - <> grid . outsideSize + g = placeGrid . fmap drawInt . clues . outsideClues + <> grid gDefault . outsideGrid primeplace :: Backend' b => - RenderPuzzle b (SGrid PrimeDiag) (SGrid Int) + RenderPuzzle b (Grid C PrimeDiag) (Grid C Int) primeplace = (,) g - (atCentres drawInt . values . snd <> g . fst) + (placeGrid . fmap drawInt . snd <> g . fst) where - g = irregularGrid <> atCentres drawPrimeDiag . values + g = grid gStyle + <> placeGrid . fmap drawPrimeDiag + gStyle = GridStyle LineThin LineThick Nothing VertexNone labyrinth :: Backend' b => - RenderPuzzle b (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) + RenderPuzzle b (Grid C (Maybe Int), [Edge N]) (Grid C (Maybe Int)) labyrinth = (,) - (atCentres drawInt . clues . fst <> g) - (atCentres drawInt . clues . snd <> g . fst) + (placeGrid . fmap drawInt . clues . fst <> g) + (placeGrid . fmap drawInt . clues . snd <> g . fst) where - g = drawEdges . snd <> plaingrid . size . fst + g = drawEdges . snd <> grid gPlain . fst bahnhof :: Backend' b => - RenderPuzzle b (SGrid (Maybe BahnhofClue)) [Edge] + RenderPuzzle b (Grid C (Maybe BahnhofClue)) [Edge C] bahnhof = (,) - (atCentres drawBahnhofClue . clues <> grid . size) - (atCentres drawBahnhofStation . clues . fst - <> solstyle . drawDualEdges . snd - <> grid . size . fst) + (placeGrid . fmap drawBahnhofClue . clues <> grid gDefault) + (placeGrid . fmap drawBahnhofStation . clues . fst + <> solstyle . drawEdges . snd + <> grid gDefault . fst) where drawBahnhofStation = either drawInt (const mempty) +blackoutDominos :: Backend' b => + RenderPuzzle b (Grid C (Clue Int), DigitRange) + (Grid C (Clue Int), AreaGrid) +blackoutDominos = (,) + p + ((placeGrid . fmap drawInt . clues . fst + <> grid gDashedThick . fst + <> drawAreas . snd + <> shadeGrid . fmap cols . snd) . snd) + where + p (g, ds) = (placeGrid . fmap drawInt . clues <> grid gDashedThick $ g) + `aboveT` + drawDominos ds + cols 'X' = Just gray + cols _ = Nothing + +angleLoop :: + Backend' b => + RenderPuzzle b (Grid N (Clue Int)) VertexLoop +angleLoop = (,) + (cs <> gr) + (cs . fst + <> lineJoin LineJoinBevel . solstyle . strokeLocLoop . vertexLoop . snd + <> gr . fst) + where + cs = placeGrid . fmap drawAnglePoly . clues + gr = grid gPlainDashed . cellGrid + +anglers :: + Backend' b => + RenderPuzzle b (OutsideClues C (Clue Int), Grid C (Maybe Fish)) [Edge C] +anglers = (,) + (p <> g) + (p . fst <> solstyle . drawEdges . snd <> g . fst) + where + p = placeGrid . fmap drawInt' . clues . outsideClues . fst <> + placeGrid . fmap drawFish' . clues . snd + g = grid gDefault . snd + drawInt' x = drawInt x <> (square 0.6 # lc white # fc white) + drawFish' x = drawFish x <> (square 0.6 # lc white # fc white) + cave :: - (Backend b R2, Renderable (Path R2) b) => - RenderPuzzle b (SGrid (Clue Int)) ShadedGrid + Backend' b => + RenderPuzzle b (Grid C (Maybe Int)) ShadedGrid cave = (,) - g + (grid gDashDash <> placeGrid . fmap drawInt . clues) (drawEdges . edgesGen (/=) not . snd - <> drawShadedGrid . snd <> fr . fst - <> g . fst) + <> placeGrid . fmap drawInt . clues . fst + <> drawShade . snd + <> grid gStyle . fst) where - g = gridDashing . plaingrid . size <> atCentres drawInt . clues - fr gr = outframe' 8 (size gr) # lc gray + gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone + gStyle = GridStyle LineDashed LineNone (Just $ FrameStyle 8 gray) + VertexNone + +skyscrapers :: + Backend' b => + RenderPuzzle b (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +skyscrapers = (,) + (g . fst <> n) + (g . fst . fst <> placeGrid . fmap drawInt . clues . snd) + where + g = placeGrid . fmap drawInt . clues . outsideClues + <> grid gDefault . outsideGrid + n (oc, s) = placeNote (outsideSize oc) (drawText s) + +shikaku :: Backend' b => RenderPuzzle b (Grid C (Maybe Int)) AreaGrid +shikaku = (,) + p + (drawAreas . snd <> p . fst) + where + p = placeGrid . fmap drawInt . clues <> grid gDashed + +slovaksums :: Backend' b => RenderPuzzle b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) +slovaksums = (,) + (p . fst <> n) + (placeGrid . fmap drawInt . clues . snd <> p . fst . fst) + where + n (g, ds) = placeNote (size' g) (drawText ds # scale 0.8) + p = grid gDefault <> placeGrid . fmap drawSlovakClue . clues + size' = size . Map.mapKeys toCoord + +skyscrapersStars :: + Backend' b => + RenderPuzzle b (OutsideClues C (Maybe Int), Int) + (Grid C (Either Int Star)) +skyscrapersStars = (,) + (g <> n) + (g . fst <> placeGrid . fmap (either drawInt drawStar) . snd) + where + g = (placeGrid . fmap drawInt . clues . outsideClues + <> grid gDefault . outsideGrid) . fst + n (oc, s) = placeNote (outsideSize oc) + (drawInt s ||| strutX 0.2 ||| drawStar Star) + +summon :: + Backend' b => + RenderPuzzle b (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +summon = (,) + (p <> n) + (placeGrid . fmap drawInt . clues . snd <> p . fst) + where + p (g, oc, _) = grid gDefault g <> drawAreasGray g + <> (placeGrid . clues . outsideClues + . al . fmap (fmap (scale 0.7 . drawInt)) $ oc) + al :: Backend' b => OutsideClues k (Maybe (Diagram b)) -> OutsideClues k (Maybe (Diagram b)) + al (OC l r b t) = OC l (map (fmap alignL) r) b t + + n (g, _, ds) = placeNoteBR (size' g) (drawText ds # scale 0.7) + size' = size . Map.mapKeys toCoord + +baca :: + Backend' b => + RenderPuzzle b (Grid C (Maybe Char), + OutsideClues C [Int], + OutsideClues C (Maybe Char)) + (Grid C (Either Black Char)) +baca = (,) + (inside <> outside) + (outside . fst <> placeGrid . fmap drawVal . snd <> inside . fst) + where + inside (g,_,_) = placeGrid . fmap (fc gray . drawChar) . clues $ g + outside (g,tl,br) = + grid gDefault g + <> (placeGrid . fmap drawInt + . multiOutsideClues $ tl) + <> (placeGrid . fmap drawChar . clues + . outsideClues $ br) + drawVal (Right c) = drawChar c + drawVal (Left _) = fillBG gray + +buchstabensalat :: + Backend' b => + RenderPuzzle b (OutsideClues C (Maybe Char), String) (Grid C (Maybe Char)) +buchstabensalat = (p <> n, p . fst <> placeGrid . fmap drawChar . clues . snd) + where + p = (placeGrid . fmap drawChar . clues . outsideClues + <> grid gDefault . outsideGrid) . fst + n (ocs, ls) = placeNote (outsideSize ocs) (drawText ls # scale 0.8) + +doppelblock :: + Backend' b => + RenderPuzzle b (OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +doppelblock = (,) + p + (p . fst <> placeGrid . fmap drawVal . snd) + where + p = placeGrid . fmap (scale 0.8 . drawInt) . clues . outsideClues + <> grid gDefault . outsideGrid + drawVal (Right c) = drawInt c + drawVal (Left _) = fillBG gray + +sudokuDoppelblock :: + Backend' b => + RenderPuzzle b (AreaGrid, OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +sudokuDoppelblock = (,) + p + (p . fst <> placeGrid . fmap drawVal . snd) + where + p = placeGrid . fmap (scale 0.8 . drawInt) . clues . outsideClues . snd + <> (grid gDefault <> drawAreas) . fst + drawVal (Right c) = drawInt c + drawVal (Left _) = fillBG gray + +dominos :: + Backend' b => + RenderPuzzle b (Grid C (Clue Int), DigitRange) AreaGrid +dominos = (,) + p + (placeGrid . fmap drawInt . clues . fst . fst + <> (grid gDashed <> drawAreasGray) . snd) + where + p (g, r) = + ((placeGrid . fmap drawInt . clues <> grid gDashed) $ g) + `aboveT` + drawDominos r + +dominoPills :: + Backend' b => + RenderPuzzle b (Grid C (Clue Int), DigitRange, DigitRange) AreaGrid +dominoPills = (,) + p + (placeGrid . fmap drawInt . clues . fst3 . fst + <> (grid gDashed <> drawAreasGray) . snd) + where + fst3 (a,_,_) = a + p (g, ds, ps) = + ((placeGrid . fmap drawInt . clues <> grid gDashed) $ g) + `aboveT` + (drawDominos ds ||| strutX 0.5 ||| drawPills ps) + +numberlink :: + Backend' b => + RenderPuzzle b (Grid C (Maybe Int)) [Edge C] +numberlink = (,) + drawIntGrid + (placeGrid . fmap drawInt' . clues . fst + <> solstyle . drawEdges . snd + <> grid gDefault . fst) + where + drawInt' x = drawInt x <> (square 0.7 # lc white # fc white) + +loopki :: Backend' b => + RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Loop N) +loopki = (,) + p + (solstyle . drawEdges . snd <> p . fst) + where + p = placeGrid . fmap (scale 0.5 . pearl) . clues <> grid gSlither + +scrabble :: Backend' b => + RenderPuzzle b (Grid C Bool, [String]) (Grid C (Maybe Char)) +scrabble = (,) + p + (placeGrid . fmap drawCharFixed . clues . snd <> gr . fst . fst) + where + p (g, ws) = stackWords ws `besidesR` gr g + gr = grid gDefault <> drawShade + +neighbors :: Backend' b => + RenderPuzzle b (Grid C Bool, Grid C (Maybe Int)) (Grid C Int) +neighbors = (,) + (placeGrid . fmap drawInt . clues . snd <> (grid gDefault <> drawShade) . fst) + (placeGrid . fmap drawInt . snd <> (grid gDefault <> drawShade) . fst . fst) + +starwars :: Backend' b => + RenderPuzzle b (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star)) +starwars = (,) + p + (p . fst <> placeGrid . fmap drawStar . clues . snd) + where + p = ((drawAreas <> grid gDefault) . fst <> drawMarkedLines . snd) + +starbattle :: Backend' b => + RenderPuzzle b (AreaGrid, Int) (Grid C (Maybe Star)) +starbattle = (,) + (p <> n) + ((p <> n) . fst <> placeGrid . fmap drawStar . clues . snd) + where + p = (drawAreas <> grid gDefault) . fst + n (g, k) = placeNote (size' g) + (drawInt k ||| strutX 0.2 ||| drawStar Star) + size' = size . Map.mapKeys toCoord + +heyawake :: Backend' b => + RenderPuzzle b (AreaGrid, Grid C (Maybe Int)) (Grid C Bool) +heyawake = (,) + (as <> cs) + (as . fst <> drawShade . snd <> cs . fst) + where + as = (drawAreas <> grid gDefault) . fst + cs = placeGrid . fmap drawInt . clues . snd + +wormhole :: Backend' b => + RenderPuzzle b (Grid C (Maybe (Either Int Char))) () +wormhole = (,) + (placeGrid . fmap (either drawInt drawChar) . clues <> grid gDashed) + mempty + +pentominous :: + Backend' b => + RenderPuzzle b (Grid C (Maybe Char)) (Grid C Char) +pentominous = (,) + (placeGrid . fmap drawChar . clues <> grid gDashed) + (placeGrid . fmap drawChar . clues . fst <> + (drawAreas <> grid gDashed) . snd) + +colorakari :: + Backend' b => + RenderPuzzle b (Grid C (Maybe Char)) (Grid C (Maybe Char)) +colorakari = (,) + (placeGrid . fmap drawColorClue . clues <> grid gDefault) + (error "color akari solution not implemented") + where + drawColorClue 'X' = fillBG black + drawColorClue c = case col c of Nothing -> error "invalid color" + Just c' -> drawText [c] # scale 0.5 + <> circle (1/3) # fc c' + <> fillBG black + col c = case c of 'R' -> Just red + 'G' -> Just green + 'B' -> Just blue + 'Y' -> Just yellow + 'C' -> Just cyan + 'M' -> Just magenta + 'W' -> Just white + _ -> Nothing + +persistenceOfMemory :: + Backend' b => + RenderPuzzle b (AreaGrid, (Grid C (Maybe MEnd))) (Loop C) +persistenceOfMemory = (,) + (ends_ <> areas) + (ends_ . fst <> solstyle . drawEdges . snd <> areas . fst) + where + ends_ = placeGrid . fmap drawEnd . clues . snd + areas = (drawAreas <> grid gDashed <> shadeGrid . fmap cols) . fst + cols c | isUpper c = Just (blend 0.25 black white) + | otherwise = Nothing + +abctje :: + Backend' b => + RenderPuzzle b (DigitRange, [(String, Int)]) [(Int, Char)] +abctje = (,) + p + ((b . g . h ||| const (strutX 1.0) ||| b . g . h') . snd) + where + p (ds, cs) = (digNote ds `aboveT` (stackWordsLeft ws ||| strutX 1.0 ||| stackWordsRight ns)) + `besidesR` (strutX 2.0 ||| (b . g $ ps) ||| strutX 1.0 ||| (b . g $ ps')) + where + ws = map fst cs + ns = map (show . snd) cs + ls = nub . sort . concatMap fst $ cs + ps = [ (x:[], "") | x <- ls ] + ps' = [ (show x, "") | x <- digitList ds ] + digNote (DigitRange x y) = note . drawText $ show x ++ "-" ++ show y + b = placeGrid . fmap drawText <> grid gPlain + h = sortOn fst . map (\(x, y) -> (y:[], show x)) + h' = map (\(x, y) -> (show x, y:[])) + g ps = Map.fromList $ + [ (C 0 (l-i-1), x) | (i, x) <- zip [0..] c1 ] ++ + [ (C 1 (l-i-1), x) | (i, x) <- zip [0..] c2 ] + where + l = length ps + c1 = map fst ps + c2 = map snd ps + +kropki :: + Backend' b => + RenderPuzzle b (Map.Map (Edge N) KropkiDot) (Grid C Int) +kropki = (,) + p + (placeGrid . fmap drawInt . snd <> p . fst) + where + p = placeGrid' . Map.mapKeys midPoint . fmap kropkiDot <> grid gDefault . sizeGrid . sz + sz m = edgeSize (Map.keys m) + +statuepark :: + Backend' b => + RenderPuzzle b (Grid C (Maybe MasyuPearl)) (Grid C Bool) +statuepark = (,) + p + (p . fst <> drawShade . snd) + where + p = placeGrid . fmap pearl . clues <> grid gDashed + +pentominousBorders :: + Backend' b => + RenderPuzzle b (Grid C (), [Edge N]) (Grid C Char) +pentominousBorders = (,) + (drawEdges . snd <> grid gDashed . fst) + ((drawAreas <> grid gDashed) . snd) + +nanroSignpost :: + Backend' b => + RenderPuzzle b (AreaGrid, Grid C (Maybe Int)) (Grid C Int) +nanroSignpost = (,) + p + (placeGrid . fmap drawInt . snd <> p . fst) + where + p = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . fmap show . clues . snd) + +tomTom :: + Backend' b => + RenderPuzzle b (AreaGrid, Grid C (Maybe String)) (Grid C Int) +tomTom = (,) + p + (placeGrid . fmap drawInt . snd <> p . fst) + where + p = ((drawAreas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd) + +horseSnake :: + Backend' b => + RenderPuzzle b (Grid C (Maybe (Either MEnd Int))) [Edge C] +horseSnake = (,) + p + (solstyle . drawEdges . snd <> p . fst) + where + p = (placeGrid . fmap (either drawEnd drawInt) . clues <> grid gDashed) + +illumination :: + Backend' b => + RenderPuzzle b (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N]) +illumination = (,) + p + ((placeGrid . fmap (const (smallPearl MWhite)) . clues . fst <> drawEdges . snd) . snd <> p . fst) + where + p = placeGrid . fmap drawFraction . clues . outsideClues + <> grid gDashed . outsideGrid + +pentopia :: + Backend' b => + RenderPuzzle b (Grid C (Maybe Myopia)) (Grid C Bool) +pentopia = (,) + p + (p . fst <> drawShade . snd) + where + p = placeGrid . fmap drawMyopia . clues <> grid gDefault + +pentominoPipes :: + Backend' b => + RenderPuzzle b (Grid N Char) (Grid N KropkiDot, [Edge N]) +pentominoPipes = (,) + (placeGrid . fmap drawCharOpaque <> grid gSlither . cellGrid) + ((placeGrid . fmap kropkiDot . fst + <> drawEdges . snd) . snd + <> grid gSlither . cellGrid . fst) + +greaterWall :: + Backend' b => + RenderPuzzle b ([GreaterClue], [GreaterClue]) (Grid C Bool) +greaterWall = (,) + ((plc <> grid gDefault . outsideGrid) . munge) + undefined + where + munge (rs,cs) = OC (map (reverse . greaterClue) (reverse rs)) [] [] + (map (map (rotateBy (-1/4))) . map (reverse . greaterClue) $ cs) + plc ocs = placeGrid' . Map.mapKeys toPt . multiOutsideClues $ ocs + where + OC l _ _ _ = ocs + h = length l + h' = fromIntegral h + -- toPoint c = p2 (1/2, 1/2) .+^ r2i (c .--. C 0 0) + -- terrible hack + toPt c@(C x y) | x < 0 = let p = toPoint c in scaleX 0.7 p .+^ r2 (-1/2, 0) + | y >= h = let p = toPoint c in scaleY 0.7 (p .-^ r2 (0,h')) .+^ r2 (0, 1/2 + h') + toPt c = toPoint c + +galaxies :: + Backend' b => + RenderPuzzle b (Grid C (), Grid N (), Grid C (), Map.Map (Edge N) ()) AreaGrid +galaxies = (,) + p + (p . fst <> drawAreas . snd) + where + p = (gals <> grid gDashed . fst4) + gal = const (kropkiDot KWhite) + gals (_, a,b,c) = (placeGrid . fmap gal $ a) + <> (placeGrid . fmap gal $ b) + <> (placeGrid' . fmap gal . Map.mapKeys midPoint $ c) + fst4 (a,_,_,_) = a diff --git a/src/Diagrams/Puzzles/Pyramid.hs b/src/Diagrams/Puzzles/Pyramid.hs --- a/src/Diagrams/Puzzles/Pyramid.hs +++ b/src/Diagrams/Puzzles/Pyramid.hs @@ -1,47 +1,41 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} module Diagrams.Puzzles.Pyramid where import Diagrams.Prelude -import Data.Puzzles.Elements import Data.Puzzles.Pyramid +import Diagrams.Puzzles.Elements import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths pgray :: Colour Double pgray = blend 0.6 white black -cell :: Backend' b => Bool -> Diagram b R2 +cell :: Backend' b => Bool -> Diagram b cell s = square 1 # lwG onepix # if s then fc pgray else id -clue :: Backend' b => Maybe Int -> Diagram b R2 +clue :: Backend' b => Maybe Int -> Diagram b clue Nothing = mempty clue (Just c) = text' (show c) -cellc :: Backend' b => Bool -> Maybe Int -> Diagram b R2 +cellc :: Backend' b => Bool -> Maybe Int -> Diagram b cellc s c = clue c `atop` cell s -row :: Backend' b => Row -> Diagram b R2 +row :: Backend' b => Row -> Diagram b row (R cs s) = centerX . hcat . map (cellc s) $ cs -pyramid :: Backend' b => Pyramid -> Diagram b R2 +pyramid :: Backend' b => Pyramid -> Diagram b pyramid = alignBL . vcat . map row . unPyr -kropki :: Backend' b => KropkiDot -> Diagram b R2 -kropki KNone = mempty -kropki c = circle 0.1 # lwG 0.03 # fc (col c) # smash - where col KWhite = white - col KBlack = blend 0.98 black white - col KNone = error "can't reach" - -krow :: Backend' b => KropkiRow -> Diagram b R2 +krow :: Backend' b => KropkiRow -> Diagram b krow (KR cs s ks) = ccat dots <> ccat clues where ccat = centerX . hcat clues = map (cellc s) cs - dots = interleave (map phantom' clues) (map kropki ks) + dots = interleave (map phantom clues) (map kropkiDot ks) -kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b R2 +kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b kpyramid = alignBL . vcat . map krow . unKP diff --git a/src/Diagrams/Puzzles/Style.hs b/src/Diagrams/Puzzles/Style.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Puzzles/Style.hs @@ -0,0 +1,50 @@ +module Diagrams.Puzzles.Style + ( LineStyle (..) + , FrameStyle (..) + , VertexStyle (..) + , GridStyle (..) + + , gDefault + , gDashed + , gDashedThick + , gPlain + , gPlainDashed + , gSlither + ) where + +import Diagrams.Puzzles.Widths + +import Diagrams.Prelude + +data LineStyle = + LineNone + | LineThin + | LineDashed + | LineThick + +data FrameStyle = FrameStyle + { _fWidthFactor :: Double + , _fColour :: Colour Double + } + +data VertexStyle = + VertexNone + | VertexDot + +data GridStyle = GridStyle + { _line :: LineStyle + , _border :: LineStyle + , _frame :: Maybe FrameStyle + , _vertex :: VertexStyle + } + +gDefault, gSlither, gDashed, gDashedThick, gPlain, gPlainDashed :: GridStyle +gDefault = GridStyle LineThin LineThin + (Just (FrameStyle framewidthfactor black)) VertexNone +gSlither = GridStyle LineNone LineNone Nothing VertexDot +gDashed = GridStyle LineDashed LineThin + (Just (FrameStyle framewidthfactor black)) VertexNone +gDashedThick = GridStyle LineDashed LineThick + Nothing VertexNone +gPlain = GridStyle LineThin LineThin Nothing VertexNone +gPlainDashed = GridStyle LineDashed LineDashed Nothing VertexNone diff --git a/src/Diagrams/Puzzles/Widths.hs b/src/Diagrams/Puzzles/Widths.hs --- a/src/Diagrams/Puzzles/Widths.hs +++ b/src/Diagrams/Puzzles/Widths.hs @@ -19,6 +19,8 @@ framewidthfactor :: Double framewidthfactor = 4 -edgewidth, borderwidth :: Double +edgewidth :: Double edgewidth = 3 * onepix + +borderwidth :: Double borderwidth = 1 / 2 diff --git a/src/Text/Puzzles/Code.hs b/src/Text/Puzzles/Code.hs new file mode 100644 --- /dev/null +++ b/src/Text/Puzzles/Code.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Puzzles.Code where + +import Data.Puzzles.Code +import Text.Puzzles.Util + +import Data.Yaml + +import Data.Maybe (catMaybes) + +parseCode :: Value -> Parser [CodePart] +parseCode (Object v) = fmap catMaybes . sequenceA $ + [ fmap Rows' <$> v .:? "cell_rows_bottom" + , fmap Cols <$> v .:? "cell_cols" + , fmap RowsN' <$> v .:? "node_rows_bottom" + , fmap ColsN <$> v .:? "node_cols" + , fmap (LabelsN . fmap (fmap unAlpha . blankToMaybe)) <$> (do + v' <- v .:? "node_labels" + sequenceA (parseGrid <$> v')) + ] +parseCode _ = fail "expected object" diff --git a/src/Text/Puzzles/Parsec.hs b/src/Text/Puzzles/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Text/Puzzles/Parsec.hs @@ -0,0 +1,30 @@ +-- | Parsec helper for puzzle file parsing. +module Text.Puzzles.Parsec ( + toParser + , toStringParser + , fraction + ) where + +import Text.ParserCombinators.Parsec hiding ((<|>)) +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import Control.Applicative + +import Data.Puzzles.Elements + +toParser :: GenParser a () b -> [a] -> Yaml.Parser b +toParser p v = case parse p "(unknown)" v of Left e -> fail (show e) + Right x -> pure x + +toStringParser :: GenParser Char () b -> Yaml.Value -> Yaml.Parser b +toStringParser p v = case v of + Yaml.String t -> toParser p (T.unpack t) + _ -> fail "expected string" + +-- | fraction is meant to parse things like "1 1/2", "3/10", "7". +fraction :: GenParser Char st Fraction +fraction = do + a <- many1 digit <* spaces + FComp a <$> many1 digit <*> (char '/' *> many1 digit) + <|> FFrac a <$> (char '/' *> many1 digit) + <|> pure (FInt a) diff --git a/src/Text/Puzzles/Puzzle.hs b/src/Text/Puzzles/Puzzle.hs --- a/src/Text/Puzzles/Puzzle.hs +++ b/src/Text/Puzzles/Puzzle.hs @@ -7,14 +7,15 @@ import Data.Puzzles.PuzzleTypes -data TypedPuzzle = TP (Maybe String) Value (Maybe Value) +data TypedPuzzle = TP (Maybe String) Value (Maybe Value) (Maybe Value) deriving Show instance FromJSON TypedPuzzle where parseJSON (Object v) = TP <$> v .:? "type" <*> v .: "puzzle" <*> - v .:? "solution" + v .:? "solution" <*> + v .:? "code" parseJSON _ = empty -- | A pair of parsers for a puzzle type. diff --git a/src/Text/Puzzles/PuzzleTypes.hs b/src/Text/Puzzles/PuzzleTypes.hs --- a/src/Text/Puzzles/PuzzleTypes.hs +++ b/src/Text/Puzzles/PuzzleTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Text.Puzzles.PuzzleTypes ( lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa, @@ -6,47 +7,64 @@ liarslither, tightfitskyscrapers, wordloop, wordsearch, curvedata, doubleback, slalom, compass, boxof2or3, afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral, - maximallengths, primeplace, labyrinth, bahnhof, cave + maximallengths, primeplace, labyrinth, bahnhof, cave, angleLoop, + shikaku, slovaksums, blackoutDominos, + anglers, skyscrapers, summon, baca, + buchstabensalat, doppelblock, sudokuDoppelblock, dominos, + skyscrapersStars, numberlink, slithermulti, dominoPills, + fillominoLoop, loopki, scrabble, neighbors, starwars, + heyawake, wormhole, pentominous, starbattle, colorakari, + persistenceOfMemory, abctje, kropki, statuepark, pentominousBorders, + nanroSignpost, tomTom, horseSnake, illumination, pentopia, + pentominoPipes, greaterWall, galaxies ) where import Control.Applicative import Control.Monad +import qualified Data.Map.Strict as M import Data.Yaml import Text.Puzzles.Util import Text.Puzzles.Puzzle import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) +import Data.Puzzles.GridShape import qualified Data.Puzzles.Pyramid as Pyr import Data.Puzzles.Elements -lits :: ParsePuzzle AreaGrid ShadedGrid +lits :: ParsePuzzle AreaGrid (Grid C Bool) lits = (parseGrid, parseShadedGrid) -litsplus :: ParsePuzzle AreaGrid ShadedGrid +litsplus :: ParsePuzzle AreaGrid (Grid C Bool) litsplus = lits -geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop +geradeweg :: ParsePuzzle (Grid C (Maybe Int)) (Loop C) geradeweg = (parseClueGrid, parseEdges) -fillomino :: ParsePuzzle IntGrid (SGrid Int) -fillomino = (parseClueGrid, parseExtGrid) +fillomino :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int) +fillomino = (parseExtClueGrid, parseExtGrid) -masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop +fillominoLoop :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Int, Loop C) +fillominoLoop = (,) + parseClueGrid + (\v -> (,) <$> parseFrom ["grid"] parseExtGrid v + <*> parseFrom ["loop"] parseEdges v) + +masyu :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop C) masyu = (parseClueGrid, parseEdges) -nurikabe :: ParsePuzzle IntGrid ShadedGrid -nurikabe = (parseSpacedClueGrid, parseShadedGrid) +nurikabe :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) +nurikabe = (parseExtClueGrid, parseShadedGrid) -latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char)) +latintapa :: ParsePuzzle (Grid C (Maybe [String])) (Grid C (Maybe Char)) latintapa = ((unRG <$>) . parseJSON, fmap (fmap (fmap unAlpha)) . parseClueGrid') -sudoku :: ParsePuzzle IntGrid IntGrid +sudoku :: ParsePuzzle (Grid C (Maybe Int)) (Grid C (Maybe Int)) sudoku = (parseClueGrid, parseClueGrid) -thermosudoku :: ParsePuzzle (SGrid Int, [Thermometer]) IntGrid +thermosudoku :: ParsePuzzle (Grid C (Maybe Int), [Thermometer]) + (Grid C (Maybe Int)) thermosudoku = ((parseThermoGrid =<<) . parseJSON, parseClueGrid) pyramid :: ParsePuzzle Pyr.Pyramid Pyr.PyramidSol @@ -55,25 +73,30 @@ kpyramid :: ParsePuzzle Pyr.RowKropkiPyramid Pyr.PyramidSol kpyramid = (parseJSON, parseJSON) -slither :: ParsePuzzle (SGrid (Clue Int)) Loop +slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N) slither = (parseClueGrid, parseEdges) -newtype LSol = LSol { unLSol :: (Loop, SGrid Bool) } +slithermulti :: ParsePuzzle (Grid C (Clue Int), Int) [Edge N] +slithermulti = (p, parseEdges) + where p v = (,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["loops"] parseJSON v + +newtype LSol = LSol { unLSol :: (Loop N, Grid C Bool) } instance FromJSON LSol where parseJSON (Object v) = LSol <$> ((,) <$> (parseEdges =<< v .: "loop") <*> (parseShadedGrid =<< v .: "liars")) parseJSON _ = mzero -liarslither :: ParsePuzzle (SGrid (Clue Int)) (Loop, SGrid Bool) +liarslither :: ParsePuzzle (Grid C (Maybe Int)) (Loop N, Grid C Bool) liarslither = (parseClueGrid, (unLSol <$>) . parseJSON) tightfitskyscrapers :: ParsePuzzle - (OutsideClues (Maybe Int), SGrid (Tightfit ())) - (SGrid (Tightfit Int)) -tightfitskyscrapers = (parseTightOutside, parseTightIntGrid) + (OutsideClues C (Maybe Int), Grid C (Tightfit ())) + (Grid C (Tightfit Int)) +tightfitskyscrapers = (parseTightOutside, parseSpacedGrid) -newtype GridWords = GW { unGW :: (CharClueGrid, [String]) } +newtype GridWords = GW { unGW :: (Grid C (Maybe Char), [String]) } instance FromJSON GridWords where parseJSON (Object v) = GW <$> ((,) <$> @@ -81,10 +104,10 @@ v .: "words") parseJSON _ = empty -wordloop :: ParsePuzzle (CharClueGrid, [String]) CharClueGrid +wordloop :: ParsePuzzle (Grid C (Maybe Char), [String]) (Grid C (Maybe Char)) wordloop = ((unGW <$>) . parseJSON, parseClueGrid) -newtype GridMarked = GM { unGM :: (CharClueGrid, [MarkedWord]) } +newtype GridMarked = GM { unGM :: (Grid C (Maybe Char), [MarkedWord]) } instance FromJSON GridMarked where parseJSON (Object v) = GM <$> ((,) <$> @@ -92,60 +115,311 @@ (map unPMW <$> v .: "words")) parseJSON _ = mzero -wordsearch :: ParsePuzzle (CharClueGrid, [String]) (CharClueGrid, [MarkedWord]) +wordsearch :: ParsePuzzle (Grid C (Maybe Char), [String]) + (Grid C (Maybe Char), [MarkedWord]) wordsearch = ((unGW <$>) . parseJSON, (unGM <$>) . parseJSON) -newtype Curve = Curve { unCurve :: [Edge] } +newtype Curve = Curve { unCurve :: [Edge N] } instance FromJSON Curve where parseJSON v = Curve <$> parsePlainEdges v -curvedata :: ParsePuzzle (SGrid (Clue [Edge])) [Edge] +curvedata :: ParsePuzzle (Grid C (Maybe [Edge N])) [Edge C] curvedata = ((fmap (fmap unCurve) . unRG <$>) . parseJSON, parsePlainEdges) -doubleback :: ParsePuzzle AreaGrid Loop +doubleback :: ParsePuzzle AreaGrid (Loop C) doubleback = (parseGrid, parseEdges) -slalom :: ParsePuzzle (SGrid (Clue Int)) (SGrid SlalomDiag) -slalom = (parseClueGrid, \v -> rectToSGrid <$> parseJSON v) +slalom :: ParsePuzzle (Grid N (Maybe Int)) (Grid C SlalomDiag) +slalom = (parseClueGrid, parseGrid) -compass :: ParsePuzzle (SGrid (Clue CompassC)) CharGrid +compass :: ParsePuzzle (Grid C (Maybe CompassC)) AreaGrid compass = ((fmap (fmap unPCC) . unRG <$>) . parseJSON, parseGrid) -boxof2or3 :: ParsePuzzle (SGrid MasyuPearl, [Edge]) () +boxof2or3 :: ParsePuzzle (Grid N MasyuPearl, [Edge N]) () boxof2or3 = (parseNodeEdges, error "boxof2or3 parsing not implemented") -afternoonskyscrapers :: ParsePuzzle (SGrid Shade) IntGrid +afternoonskyscrapers :: ParsePuzzle (Grid C Shade) (Grid C (Maybe Int)) afternoonskyscrapers = (parseAfternoonGrid, parseGrid) -- this should be changed to support clue numbers -meanderingnumbers :: ParsePuzzle AreaGrid IntGrid +meanderingnumbers :: ParsePuzzle AreaGrid (Grid C (Maybe Int)) meanderingnumbers = (parseGrid, parseGrid) -tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid -tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v, +tapa :: ParsePuzzle (Grid C (Maybe TapaClue)) (Grid C Bool) +tapa = (\v -> fmap (fmap unParseTapaClue) . unRG <$> parseJSON v, parseShadedGrid) -japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid (Either Black Int)) -japanesesums = (parseMultiOutsideClues, parseGrid) +japanesesums :: ParsePuzzle (OutsideClues C [Int], String) + (Grid C (Either Black Int)) +japanesesums = (p, parseGrid) + where + p v@(Object o) = (,) <$> parseMultiOutsideClues v <*> o .: "digits" + p _ = empty -coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid +coral :: ParsePuzzle (OutsideClues C [String]) (Grid C Bool) coral = (,) (fmap (fmap (map unIntString)) . parseMultiOutsideClues) parseShadedGrid -maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop +maximallengths :: ParsePuzzle (OutsideClues C (Maybe Int)) (Loop C) maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v, parseEdges) -primeplace :: ParsePuzzle (SGrid PrimeDiag) (SGrid Int) +primeplace :: ParsePuzzle (Grid C PrimeDiag) (Grid C Int) primeplace = (parseIrregGrid, parseIrregGrid) -labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) +labyrinth :: ParsePuzzle (Grid C (Maybe Int), [Edge N]) (Grid C (Maybe Int)) labyrinth = (parseCellEdges, parseClueGrid') -bahnhof :: ParsePuzzle (SGrid (Maybe BahnhofClue)) [Edge] +bahnhof :: ParsePuzzle (Grid C (Maybe BahnhofClue)) [Edge C] bahnhof = (parseClueGrid, parseEdges) -cave :: ParsePuzzle (SGrid (Clue Int)) ShadedGrid +blackoutDominos :: ParsePuzzle (Grid C (Clue Int), DigitRange) + (Grid C (Clue Int), AreaGrid) +blackoutDominos = (,) + (\v -> (,) <$> parseFrom ["grid"] parseIrregGrid v + <*> parseFrom ["digits"] parseStringJSON v) + (\v -> (,) <$> parseFrom ["values"] parseIrregGrid v + <*> parseFrom ["dominos"] parseIrregGrid v) + +angleLoop :: ParsePuzzle (Grid N (Clue Int)) VertexLoop +angleLoop = (parseClueGrid, parseCoordLoop) + +shikaku :: ParsePuzzle (Grid C (Maybe Int)) AreaGrid +shikaku = (parseExtClueGrid, parseGrid) + +slovaksums :: ParsePuzzle (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) +slovaksums = (p, parseClueGrid) + where + p v@(Object o) = (,) <$> g v <*> o .: "digits" + p _ = empty + g = (fmap (fmap unPSlovakClue) . unRG <$>) . parseJSON + +anglers :: ParsePuzzle (OutsideClues C (Maybe Int), Grid C (Maybe Fish)) [Edge C] +anglers = ( parseOutsideGridMap blankToMaybe blankToMaybe' + , parseEdgesFull ) + +cave :: ParsePuzzle (Grid C (Maybe Int)) (Grid C Bool) cave = (parseClueGrid, parseShadedGrid) + +parseOut :: FromJSON a => + Value -> Parser (OutsideClues k (Maybe a)) +parseOut v = fmap (blankToMaybe' . unEither') <$> parseOutside v + +skyscrapers :: ParsePuzzle (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +skyscrapers = (,) + (\v -> (,) <$> parseOut v + <*> parseFrom ["digits"] parseJSON v) + parseClueGrid + +skyscrapersStars :: ParsePuzzle (OutsideClues C (Maybe Int), Int) + (Grid C (Either Int Star)) +skyscrapersStars = (p, parseGrid) + where + p v@(Object o) = (,) <$> parseOut v <*> o .: "stars" + p _ = empty + +summon :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) +summon = ( \v@(Object o) -> (,,) <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["outside"] parseOut v + <*> o .: "digits" + , parseClueGrid + ) + +baca :: ParsePuzzle + (Grid C (Maybe Char), OutsideClues C [Int], OutsideClues C (Maybe Char)) + (Grid C (Either Black Char)) +baca = ( \v -> (,,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["outside"] parseTopLeft v + <*> parseFrom ["outside"] parseBottomRight v + , parseGrid + ) + where + parseTopLeft (Object v) = do + l <- reverse <$> v .: "left" + t <- v .: "top" + return $ OC (map reverse l) [] [] (map reverse t) + parseTopLeft _ = empty + parseBottomRight (Object v) = do + b <- v .: "bottom" + r <- reverse <$> v .: "right" + oc <- OC [] <$> parseLine r <*> parseLine b <*> pure [] + return $ fmap blankToMaybe' oc + parseBottomRight _ = empty + +buchstabensalat :: ParsePuzzle (OutsideClues C (Maybe Char), String) + (Grid C (Maybe Char)) +buchstabensalat = + ( p + , fmap (fmap blankToMaybe') . parseGrid + ) + where + p v = (,) + <$> (fmap blankToMaybe <$> parseCharOutside v) + <*> parseFrom ["letters"] parseJSON v + +doppelblock :: ParsePuzzle (OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +doppelblock = + ( \v -> fmap (blankToMaybe' . unEither') <$> parseOutside v + , parseGrid + ) + +sudokuDoppelblock :: ParsePuzzle (AreaGrid, OutsideClues C (Maybe Int)) + (Grid C (Either Black Int)) +sudokuDoppelblock = + ( \v -> (,) <$> parseFrom ["grid"] parseGrid v + <*> parseFrom ["outside"] parseOutInts v + , parseGrid + ) + where + parseOutInts v = fmap (blankToMaybe' . unEither') <$> parseOutside v + +dominos :: ParsePuzzle (Grid C (Maybe Int), DigitRange) AreaGrid +dominos = (p, parseGrid) + where + p v = (,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["digits"] parseStringJSON v + +dominoPills :: ParsePuzzle (Grid C (Maybe Int), DigitRange, DigitRange) + AreaGrid +dominoPills = (p, parseGrid) + where + p v = (,,) <$> parseFrom ["grid"] parseClueGrid v + <*> parseFrom ["digits"] parseStringJSON v + <*> parseFrom ["pills"] parseStringJSON v + +numberlink :: ParsePuzzle (Grid C (Maybe Int)) [Edge C] +numberlink = (p, fmap collectLines . p) + where + p = fmap (fmap (blankToMaybe . unEither')) . parseExtGrid + +loopki :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Loop N) +loopki = (parseClueGrid, parseEdges) + +scrabble :: ParsePuzzle (Grid C Bool, [String]) (Grid C (Maybe Char)) +scrabble = (p, parseClueGrid) + where + p v = (,) <$> parseFrom ["grid"] parseStarGrid v + <*> parseFrom ["words"] parseJSON v + parseStarGrid v = fmap ((==) '*') <$> parseGrid v + +neighbors :: ParsePuzzle (Grid C Bool, Grid C (Maybe Int)) (Grid C Int) +neighbors = (p, parseGrid) + where + p v = (,) <$> parseFrom ["shading"] parseShadedGrid v + <*> parseFrom ["clues"] parseGrid v + +starwars :: ParsePuzzle (AreaGrid, [MarkedLine C]) (Grid C (Maybe Star)) +starwars = (p, parseClueGrid) + where + p v = (,) <$> parseFrom ["grid"] parseGrid v + <*> (map unPML <$> parseFrom ["lines"] parseJSON v) + +starbattle :: ParsePuzzle (AreaGrid, Int) (Grid C (Maybe Star)) +starbattle = (p, parseClueGrid) + where + p v@(Object o) = (,) <$> parseFrom ["grid"] parseGrid v + <*> o .: "stars" + p _ = empty + +heyawake :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Bool) +heyawake = (p, parseShadedGrid) + where + p v = (,) <$> parseFrom ["rooms"] parseGrid v + <*> parseFrom ["clues"] parseClueGrid v + +wormhole :: ParsePuzzle (Grid C (Maybe (Either Int Char))) () +wormhole = (,) p (const $ return ()) + where + p v = fmap (fmap unEither') <$> parseExtClueGrid v + +pentominous :: ParsePuzzle (Grid C (Maybe Char)) (Grid C Char) +pentominous = (,) parseClueGrid parseGrid + +colorakari :: ParsePuzzle (Grid C (Maybe Char)) (Grid C (Maybe Char)) +colorakari = (,) parseClueGrid parseClueGrid + +persistenceOfMemory :: ParsePuzzle (AreaGrid, Grid C (Maybe MEnd)) (Loop C) +persistenceOfMemory = (p, parseEdgesFull) + where + p v = do g <- parseGrid v + return (areas g, ends_ g) + areas = fmap (\c -> case c of 'o' -> '.' + _ -> c) + ends_ = fmap (\c -> case c of 'o' -> Just MEnd + _ -> Nothing) + +abctje :: ParsePuzzle (DigitRange, [(String, Int)]) [(Int, Char)] +abctje = (,) + (\v -> (,) <$> parseFrom ["numbers"] parseStringJSON v + <*> parseFrom ["clues"] pl v) + (\v -> pl v >>= sequence . map x) + where + pl :: FromJSON b => Value -> Parser [(String, b)] + pl v = parseJSON v >>= sequence . map pair + + x :: FromString a => (String, b) -> Parser (a, b) + x (k, v) = (\k' -> (k',v)) <$> parseString k + + pair :: M.Map a b -> Parser (a, b) + pair m = if M.size m == 1 then (return . head . M.toList $ m) else empty + +kropki :: ParsePuzzle (M.Map (Edge N) KropkiDot) (Grid C Int) +kropki = (,) parseAnnotatedEdges parseGrid + +statuepark :: ParsePuzzle (Grid C (Maybe MasyuPearl)) (Grid C Bool) +statuepark = (\v -> parseFrom ["grid"] parseClueGrid v, parseShadedGrid) + +pentominousBorders :: ParsePuzzle (Grid C (), [Edge N]) (Grid C Char) +pentominousBorders = (,) parseCellEdges parseGrid + +nanroSignpost :: ParsePuzzle (AreaGrid, Grid C (Maybe Int)) (Grid C Int) +nanroSignpost = (,) + (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] parseGrid v) + parseGrid + +tomTom :: ParsePuzzle (AreaGrid, Grid C (Maybe String)) (Grid C Int) +tomTom = (,) + (\v -> (,) <$> parseFrom ["rooms"] parseGrid v <*> parseFrom ["clues"] ((unRG <$>) . parseJSON) v) + parseGrid + +horseSnake :: ParsePuzzle (Grid C (Maybe (Either MEnd Int))) [Edge C] +horseSnake = (parseGrid, parseEdgesFull) + +illumination :: ParsePuzzle (OutsideClues C (Maybe Fraction)) (Grid N (Maybe PlainNode), [Edge N]) +illumination = (,) + (fmap (fmap (fmap unPFraction)) . parseOut) + parseNodeEdges + +newtype Myo = Myo { unMyo :: Myopia } +instance FromJSON Myo where + parseJSON v = do + s <- parseJSON v + fmap Myo . sequence . map parseChar $ s + +pentopia :: ParsePuzzle (Grid C (Maybe Myopia)) (Grid C Bool) +pentopia = (,) + (fmap (fmap (fmap unMyo)) . fmap unRG . parseJSON) + parseShadedGrid + +pentominoPipes :: ParsePuzzle (Grid N Char) (Grid N KropkiDot, [Edge N]) +pentominoPipes = (,) + parseGrid + parseNodeEdges + +greaterWall :: ParsePuzzle ([GreaterClue], [GreaterClue]) (Grid C Bool) +greaterWall = (,) + (\v -> (,) <$> parseFrom ["rows"] parseGreaterClues v + <*> parseFrom ["columns"] parseGreaterClues v) + parseShadedGrid + +galaxies :: ParsePuzzle (Grid C (), Grid N (), Grid C (), M.Map (Edge N) ()) AreaGrid +galaxies = (,) + (\v -> do (a,b,c) <- parseEdgeGrid v + return $ (fmap (const ()) b, f a, f b, f c)) + parseGrid + where + toUnit GalaxyCentre = () + f = fmap toUnit . M.mapMaybe id . fmap blankToMaybe'' diff --git a/src/Text/Puzzles/Util.hs b/src/Text/Puzzles/Util.hs --- a/src/Text/Puzzles/Util.hs +++ b/src/Text/Puzzles/Util.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} module Text.Puzzles.Util where @@ -8,14 +10,15 @@ import Control.Arrow import Control.Monad hiding (mapM) -import Data.Hashable -import Data.Maybe (catMaybes, fromMaybe) +import Data.List (sortBy, intersect) +import Data.Maybe (catMaybes, fromMaybe, isJust, fromJust) +import Data.Ord (comparing) +import Data.Either (isRight) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap -import Data.Traversable (traverse, sequenceA, mapM, Traversable) -import Data.Foldable (Foldable, foldMap) +import Data.Traversable (mapM) import Data.Monoid ((<>)) -import Data.List (intersect) import Data.Char (digitToInt, isAlpha, isDigit) import Text.Read (readMaybe) @@ -24,33 +27,46 @@ import Data.Yaml import Data.Puzzles.Grid -import Data.Puzzles.GridShape hiding (size) +import Data.Puzzles.GridShape import Data.Puzzles.Elements +import Text.Puzzles.Parsec + type Path = [String] +impossible :: a +impossible = error "impossible" + field :: Path -> Value -> Parser Value field = field' . map T.pack where - field' [] v = pure v + field' [] v = pure v field' (f:fs) (Object v) = v .: f >>= field' fs - field' _ _ = empty + field' (f:_) _ = fail $ "expected field '" ++ T.unpack f ++ "'" -parseFrom :: Path -> (Value -> Parser b) -> (Value -> Parser b) +parseFrom :: Path -> (Value -> Parser b) -> Value -> Parser b parseFrom fs p v = field fs v >>= p +chars :: [Char] -> Char -> Parser Char +chars cs c = if c `elem` cs + then pure c + else (fail $ "got '" ++ [c] ++ "', expected '" ++ cs ++ "'") + +char :: Char -> Char -> Parser Char +char c = chars [c] + class FromChar a where parseChar :: Char -> Parser a -failChar :: Char -> String -> Parser a -failChar c expect = fail $ "got '" ++ [c] ++ "', expected " ++ expect - instance FromChar Char where parseChar = pure class FromString a where parseString :: String -> Parser a +parseStringJSON :: FromString a => Value -> Parser a +parseStringJSON v = parseJSON v >>= parseString + parseLine :: FromChar a => String -> Parser [a] parseLine = mapM parseChar @@ -112,21 +128,25 @@ data BorderedRect a b = BorderedRect !Int !Int [[a]] (Border b) deriving Show +parseBorderedRect :: (Char -> Parser a) -> (Char -> Parser b) + -> Value -> Parser (BorderedRect a b) +parseBorderedRect parseIn parseOut v = do + Rect w h ls <- parseJSON v + let b = Border (reverse . map head . middle h $ ls) + (reverse . map last . middle h $ ls) + (middle w . last $ ls) + (middle w . head $ ls) + ls' = map (middle w) . middle h $ ls + mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls) + [head . head, head . last, last . head, last . last] + lsparsed <- mapM (mapM parseIn) ls' + bparsed <- mapM parseOut b + return $ BorderedRect (w-2) (h-2) lsparsed bparsed + where + middle len = take (len - 2) . drop 1 + instance (FromChar a, FromChar b) => FromJSON (BorderedRect a b) where - parseJSON v = do - Rect w h ls <- parseJSON v - let b = Border (reverse . map head . middle h $ ls) - (reverse . map last . middle h $ ls) - (middle w . last $ ls) - (middle w . head $ ls) - ls' = map (middle w) . middle h $ ls - mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls) - [head . head, head . last, last . head, last . last] - lsparsed <- mapM (mapM parseChar) ls' - bparsed <- mapM parseChar b - return $ BorderedRect (w-2) (h-2) lsparsed bparsed - where - middle len = take (len - 2) . drop 1 + parseJSON = parseBorderedRect parseChar parseChar newtype SpacedRect a = SpacedRect { unSpaced :: Rect a } @@ -141,19 +161,21 @@ p = mapM (mapM (parseString . T.unpack)) ls parseJSON _ = empty +instance FromChar () where + parseChar = fmap (const ()) . chars ['.', ' '] + data Space = Space instance FromChar Space where - parseChar ' ' = pure Space - parseChar _ = empty + parseChar = fmap (const Space) . char ' ' data Blank = Blank data Blank' = Blank' +data Blank'' = Blank'' data Empty = Empty instance FromChar Blank where - parseChar '.' = pure Blank - parseChar _ = empty + parseChar = fmap (const Blank) . char '.' parseCharJSON :: FromChar a => Value -> Parser a parseCharJSON v = do @@ -164,33 +186,32 @@ parseJSON = parseCharJSON instance FromChar Blank' where - parseChar '.' = pure Blank' - parseChar '-' = pure Blank' - parseChar _ = empty + parseChar = fmap (const Blank') . chars ['.', '-'] instance FromJSON Blank' where parseJSON (String ".") = pure Blank' parseJSON (String "-") = pure Blank' - parseJSON _ = empty + parseJSON _ = fail "expected '.-'" +instance FromChar Blank'' where + parseChar = fmap (const Blank'') . chars ['.', ' ', '-', '|'] + instance FromChar Empty where - parseChar ' ' = pure Empty - parseChar _ = empty + parseChar = fmap (const Empty) . char ' ' instance FromString Blank where parseString "." = pure Blank - parseString _ = empty - -data PlainNode = PlainNode + parseString _ = fail "expected '.'" instance FromChar PlainNode where - parseChar 'o' = pure PlainNode - parseChar _ = empty + parseChar = fmap (const PlainNode) . char 'o' instance FromChar MasyuPearl where - parseChar '*' = pure MBlack - parseChar 'o' = pure MWhite - parseChar c = failChar c "'*' or 'o'" + parseChar = fmap f . chars ['*', 'o'] + where + f '*' = MBlack + f 'o' = MWhite + f _ = impossible instance FromChar SlalomDiag where parseChar '/' = pure SlalomForward @@ -198,10 +219,20 @@ parseChar _ = empty instance FromChar Black where - parseChar 'X' = pure Black - parseChar 'x' = pure Black - parseChar _ = empty + parseChar = fmap (const Black) . chars "xX" +instance FromChar Fish where + parseChar = fmap (const Fish) . char '*' + +instance FromChar Star where + parseChar = fmap (const Star) . char '*' + +instance FromChar MEnd where + parseChar = fmap (const MEnd) . chars "o*" + +instance FromChar GalaxyCentre where + parseChar = fmap (const GalaxyCentre) . char 'o' + instance (FromChar a, FromChar b) => FromChar (Either a b) where parseChar c = Left <$> parseChar c <|> Right <$> parseChar c @@ -220,15 +251,15 @@ instance FromChar a => FromChar (Maybe a) where parseChar = optional . parseChar -listListToMap :: [[a]] -> Map.Map (Cell Square) a +listListToMap :: [[a]] -> Grid Coord a listListToMap ls = Map.fromList . concat . zipWith (\y -> zipWith (\x -> (,) (x, y)) [0..]) [h-1,h-2..] $ ls where h = length ls -rectToSGrid :: Rect a -> SGrid a -rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls) +rectToCoordGrid :: Rect a -> Grid Coord a +rectToCoordGrid (Rect _ _ ls) = listListToMap ls blankToMaybe :: Either Blank a -> Maybe a blankToMaybe = either (const Nothing) Just @@ -236,18 +267,14 @@ blankToMaybe' :: Either Blank' a -> Maybe a blankToMaybe' = either (const Nothing) Just -rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a) -rectToClueGrid = fmap blankToMaybe . rectToSGrid - -rectToClueGrid' :: Rect (Either Blank' a) -> SGrid (Clue a) -rectToClueGrid' = fmap blankToMaybe' . rectToSGrid +blankToMaybe'' :: Either Blank'' a -> Maybe a +blankToMaybe'' = either (const Nothing) Just -rectToIrregGrid :: Rect (Either Empty a) -> SGrid a -rectToIrregGrid = fmap fromRight . filterG isRight . rectToSGrid +rectToIrregGrid :: Rect (Either Empty a) -> Grid Coord a +rectToIrregGrid = fmap fromRight . Map.filter isRight . rectToCoordGrid where - isRight = either (const False) (const True) fromRight (Right r) = r - fromRight _ = error "no way" + fromRight _ = impossible newtype Shaded = Shaded { unShaded :: Bool } @@ -256,70 +283,102 @@ parseChar 'X' = pure . Shaded $ True parseChar _ = pure . Shaded $ False -parseShadedGrid :: Value -> Parser (SGrid Bool) -parseShadedGrid v = rectToSGrid . fmap unShaded <$> parseJSON v +parseShadedGrid :: Key k => Value -> Parser (Grid k Bool) +parseShadedGrid v = fmap unShaded <$> parseGrid v -parseGrid :: FromChar a => Value -> Parser (SGrid a) -parseGrid v = rectToSGrid <$> parseJSON v +parseCoordGrid :: (FromChar a) + => Value -> Parser (Grid Coord a) +parseCoordGrid v = rectToCoordGrid <$> parseJSON v -parseGridWith :: (Char -> Parser a) -> Value -> Parser (SGrid a) +parseGrid :: (Key k, FromChar a) + => Value -> Parser (Grid k a) +parseGrid v = fromCoordGrid <$> parseCoordGrid v + +parseGridWith :: Key k + => (Char -> Parser a) -> Value -> Parser (Grid k a) parseGridWith pChar v = traverse pChar =<< parseGrid v parseWithReplacement :: FromChar a => (Char -> Maybe a) -> Char -> Parser a parseWithReplacement replace c = maybe (parseChar c) pure (replace c) +parseSpacedGrid :: (Key k, FromString a) + => Value -> Parser (Grid k a) +parseSpacedGrid v = fromCoordGrid . rectToCoordGrid . unSpaced <$> parseJSON v + parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) parseCharMap v = do m <- parseJSON v guard . all (\k -> length k == 1) . Map.keys $ m return $ Map.mapKeys head m -parseExtGrid :: (FromChar a, FromJSON a) => Value -> Parser (SGrid a) -parseExtGrid v@(String _) = parseGrid v -parseExtGrid v = do - repl <- parseFrom ["replace"] parseCharMap v +parseExtGrid' :: (Key k, FromJSON a, FromChar b) + => (a -> b) -> Value -> Parser (Grid k b) +parseExtGrid' _ v@(String _) = parseGrid v +parseExtGrid' f v = do + repl <- fmap f <$> parseFrom ["replace"] parseCharMap v parseFrom ["grid"] (parseGridWith (parseWithReplacement (`Map.lookup` repl))) v -parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a)) -parseClueGrid v = rectToClueGrid <$> parseJSON v +parseExtGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k a) +parseExtGrid = parseExtGrid' id -parseClueGrid' :: FromChar a => Value -> Parser (SGrid (Clue a)) -parseClueGrid' v = rectToClueGrid' <$> parseJSON v +parseExtClueGrid :: (Key k, FromChar a, FromJSON a) => Value -> Parser (Grid k (Maybe a)) +parseExtClueGrid v = fmap blankToMaybe <$> parseExtGrid' Right v -parseIrregGrid :: FromChar a => Value -> Parser (SGrid a) -parseIrregGrid v = rectToIrregGrid <$> parseJSON v +fromCoordGrid :: Key k => Grid Coord a -> Grid k a +fromCoordGrid = Map.mapKeys fromCoord -parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a)) -parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v +fromCoordEdge :: Key k => Edge Coord -> Edge k +fromCoordEdge (E c d) = E (fromCoord c) d +fromCoordEdges :: Key k => [Edge Coord] -> [Edge k] +fromCoordEdges = map fromCoordEdge + +parseClueGrid :: (FromChar a, Key k) + => Value -> Parser (Grid k (Maybe a)) +parseClueGrid v = fmap blankToMaybe <$> parseGrid v + +parseClueGrid' :: (FromChar a, Key k) => Value -> Parser (Grid k (Maybe a)) +parseClueGrid' v = fmap blankToMaybe' <$> parseGrid v + +parseSpacedClueGrid :: (Key k, FromString a) => Value -> Parser (Grid k (Maybe a)) +parseSpacedClueGrid v = fmap blankToMaybe <$> parseSpacedGrid v + +parseIrregGrid :: (Key k, FromChar a) => Value -> Parser (Grid k a) +parseIrregGrid v = fromCoordGrid . rectToIrregGrid <$> parseJSON v + -- parses a string like -- o-o-o -- | | -- o-o o -- | | -- o-o -parsePlainEdges :: Value -> Parser [Edge] -parsePlainEdges v = readEdges <$> parseGrid v +parsePlainEdges :: Key k => Value -> Parser [Edge k] +parsePlainEdges v = filterPlainEdges <$> parseAnnotatedEdges v -readEdges :: SGrid Char -> [Edge] -readEdges g = horiz ++ vert - where (w, h) = size g - w' = w `div` 2 - h' = h `div` 2 - isHoriz (x, y) = g ! (2 * x + 1, 2 * y) == '-' - isVert (x, y) = g ! (2 * x, 2 * y + 1) == '|' - horiz = [ E (x, y) H | x <- [0 .. w' - 1] - , y <- [0 .. h'] - , isHoriz (x, y) - ] - vert = [ E (x, y) V | x <- [0 .. w'] - , y <- [0 .. h' - 1] - , isVert (x, y) - ] +filterPlainEdges :: Map.Map (Edge k) Char -> [Edge k] +filterPlainEdges = Map.keys . Map.filterWithKey p + where + p (E _ Horiz) '-' = True + p (E _ Vert) '|' = True + p _ _ = False -parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a) +parseAnnotatedEdges :: (Key k, FromChar a) => Value -> Parser (Map.Map (Edge k) a) +parseAnnotatedEdges v = do + g <- readEdges <$> parseCoordGrid v + Map.mapKeys fromCoordEdge <$> traverse parseChar g + +readEdges :: Grid Coord Char -> Map.Map (Edge Coord) Char +readEdges = Map.mapKeysMonotonic fromJust . Map.filterWithKey (const . isJust) . Map.mapKeys toEdge + where + toEdge c@(x, y) = case (x `mod` 2, y `mod` 2) of + (1, 0) -> Just $ E (div2 c) Horiz + (0, 1) -> Just $ E (div2 c) Vert + _ -> Nothing + div2 (x', y') = (x' `div` 2, y' `div` 2) + +parseGridChars :: FromChar a => Grid k Char -> Parser (Grid k a) parseGridChars = traverse parseChar -- | Parse a grid with edges and values at nodes and in cells. @@ -327,33 +386,31 @@ -- E.g. o-*-*-o -- |1|2 3 -- *-o --- to a grid of masyu pearls, a grid of integers, and some edges. -parseEdgeGrid :: (FromChar a, FromChar b) => - Value -> Parser (SGrid a, SGrid b, [Edge]) +-- to a grid of masyu pearls, a grid of integers, and some annotated edges. +parseEdgeGrid :: (FromChar a, FromChar b, FromChar c) => + Value -> Parser (Grid N a, Grid C b, Map.Map (Edge N) c) parseEdgeGrid v = uncurry (,,) <$> parseBoth <*> - parsePlainEdges v + parseAnnotatedEdges v where parseBoth = do - g <- parseGrid v - (gn, gc) <- halveGrid g + g <- parseCoordGrid v + let (gn, gc) = halveGrid g gn' <- parseGridChars gn gc' <- parseGridChars gc return (gn', gc') both f (x, y) = (f x, f y) - halveGrid (Grid (Square w h) m) - | odd w && odd h = pure (Grid snode (divkeys mnode), - Grid scell (divkeys mcell)) - | otherwise = fail "non-odd grid size" + halveGrid m = + (fromCoordGrid . divkeys $ mnode, fromCoordGrid . divkeys $ mcell) where - w' = (w + 1) `div` 2 - h' = (h + 1) `div` 2 - snode = Square w' h' - scell = Square (w' - 1) (h' - 1) mnode = Map.filterWithKey (const . uncurry (&&) . both even) m mcell = Map.filterWithKey (const . uncurry (&&) . both odd) m divkeys = Map.mapKeys (both (`div` 2)) +parsePlainEdgeGrid :: (FromChar a, FromChar b) => + Value -> Parser (Grid N a, Grid C b, [Edge N]) +parsePlainEdgeGrid v = (\(a,b,c) -> (a, b, filterPlainEdges c)) <$> parseEdgeGrid v + -- | Parse a grid of edges with values at the nodes. -- -- E.g. o-*-*-o @@ -361,26 +418,28 @@ -- *-o -- to a grid of masyu pearls and some edges. parseNodeEdges :: FromChar a => - Value -> Parser (SGrid a, [Edge]) -parseNodeEdges v = proj13 <$> parseEdgeGrid v + Value -> Parser (Grid N a, [Edge N]) +parseNodeEdges v = proj13 <$> parsePlainEdgeGrid v where - proj13 :: (SGrid a, SGrid Empty, [Edge]) -> (SGrid a, [Edge]) + proj13 :: (Grid N a, Grid C Char, [Edge N]) + -> (Grid N a, [Edge N]) proj13 (x,_,z) = (x,z) parseCellEdges :: FromChar a => - Value -> Parser (SGrid a, [Edge]) -parseCellEdges v = proj23 <$> parseEdgeGrid v + Value -> Parser (Grid C a, [Edge N]) +parseCellEdges v = proj23 <$> parsePlainEdgeGrid v where - proj23 :: (SGrid PlainNode, SGrid a, [Edge]) -> (SGrid a, [Edge]) + proj23 :: (Grid N Char, Grid C a, [Edge N]) + -> (Grid C a, [Edge N]) proj23 (_,y,z) = (y,z) data HalfDirs = HalfDirs {unHalfDirs :: [Dir]} instance FromChar HalfDirs where - parseChar c | c `elem` "└┴├┼" = pure . HalfDirs $ [V, H] - | c `elem` "│┘┤" = pure . HalfDirs $ [V] - | c `elem` "─┌┬" = pure . HalfDirs $ [H] - | otherwise = pure . HalfDirs $ [] + parseChar c | c `elem` ("└┴├┼" :: String) = pure . HalfDirs $ [Vert, Horiz] + | c `elem` ("│┘┤" :: String) = pure . HalfDirs $ [Vert] + | c `elem` ("─┌┬" :: String) = pure . HalfDirs $ [Horiz] + | otherwise = pure . HalfDirs $ [] -- parses a string like -- ┌┐┌─┐ @@ -388,55 +447,103 @@ -- │└─┘│ -- └──┐│ -- └┘ -parseEdges :: Value -> Parser [Edge] +parseEdges :: Key k => Value -> Parser [Edge k] parseEdges v = do - Grid _ m <- rectToSGrid . fmap unHalfDirs <$> parseJSON v + m <- fmap unHalfDirs <$> parseGrid v return [ E p d | (p, ds) <- Map.toList m, d <- ds ] +instance FromChar Dir' where + parseChar 'u' = pure U + parseChar 'd' = pure D + parseChar 'r' = pure R + parseChar 'l' = pure L + parseChar _ = fail "expected 'udrl'" + +newtype Dirs' = Dirs' { unDirs' :: [Dir'] } + +instance FromChar Dirs' where + parseChar '└' = pure . Dirs' $ [U, R] + parseChar '│' = pure . Dirs' $ [U, D] + parseChar '┘' = pure . Dirs' $ [L, U] + parseChar '─' = pure . Dirs' $ [L, R] + parseChar '┌' = pure . Dirs' $ [D, R] + parseChar '┐' = pure . Dirs' $ [L, D] + parseChar '╶' = pure . Dirs' $ [R] + parseChar '╴' = pure . Dirs' $ [L] + parseChar '╷' = pure . Dirs' $ [D] + parseChar '╵' = pure . Dirs' $ [U] + parseChar _ = pure . Dirs' $ [] + +parseEdgesFull :: Key k => Value -> Parser [Edge k] +parseEdgesFull v = do + m <- parseGrid v + return . Set.toList . Set.fromList . map unorient + $ [ E' p d | (p, Dirs' ds) <- Map.toList m, d <- ds ] + type ThermoRect = Rect (Either Blank (Either Int Alpha)) partitionEithers :: Ord k => Map.Map k (Either a b) -> (Map.Map k a, Map.Map k b) partitionEithers = Map.foldrWithKey insertEither (Map.empty, Map.empty) + where insertEither k = either (first . Map.insert k) (second . Map.insert k) -parseThermos :: SGrid Alpha -> Parser [Thermometer] -parseThermos (Grid s m) = catMaybes <$> mapM parseThermo (Map.keys m) +parseThermos :: Grid C Alpha -> Parser [Thermometer] +parseThermos m = catMaybes <$> mapM parseThermo (Map.keys m') where m' = fmap unAlpha m - parseThermo :: Cell Square -> Parser (Maybe Thermometer) + parseThermo :: C -> Parser (Maybe Thermometer) parseThermo p | not (isStart p) = pure Nothing | not (isAlmostIsolated p) = fail $ show p ++ " not almost isolated" | otherwise = Just <$> parseThermo' p - parseThermo' :: Cell Square -> Parser Thermometer + parseThermo' :: C -> Parser Thermometer parseThermo' p = do q <- next p maybe (fail "no succ for thermo bulb") (fmap (p:) . parseThermo'') q - parseThermo'' :: Cell Square -> Parser Thermometer + parseThermo'' :: C -> Parser Thermometer parseThermo'' p = do q <- next p maybe (pure [p]) (fmap (p:) . parseThermo'') q - next :: Cell Square -> Parser (Maybe (Cell Square)) + next :: C -> Parser (Maybe C) next p = case succs p of [] -> pure Nothing [q] -> pure (Just q) _ -> fail "multiple successors" - succs p = filter (test ((==) . succ) p) . vertexNeighbours s $ p - isStart p = not . any (test ((==) . pred) p) . vertexNeighbours s $ p + succs p = filter (test ((==) . succ) p) . vertexNeighbours $ p + isStart p = not . any (test ((==) . pred) p) . vertexNeighbours $ p test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m') - isAlmostIsolated p = all disjointSucc . vertexNeighbours s $ p + isAlmostIsolated p = all disjointSucc . vertexNeighbours $ p where disjointSucc q = null $ intersect (succs p) (succs' q) succs' q = maybe [] (const $ succs q) (Map.lookup q m') -parseThermoGrid :: ThermoRect -> Parser (SGrid Int, [Thermometer]) -parseThermoGrid (Rect w h ls) = (,) (Grid s ints) - <$> parseThermos (Grid s alphas) +parseThermoGrid :: ThermoRect -> Parser (Grid C (Maybe Int), [Thermometer]) +parseThermoGrid (Rect _ _ ls) = (,) ints + <$> parseThermos alphas where - s = Square w h - (ints, alphas) = partitionEithers . snd . partitionEithers $ - listListToMap ls + m = fromCoordGrid $ listListToMap ls + ints = either (const Nothing) (either Just (const Nothing)) <$> m + alphas = fmap fromRight . Map.filter isRight + . fmap fromRight . Map.filter isRight $ m + fromRight (Left _) = impossible + fromRight (Right x) = x +parseOutsideGrid :: Key k => + (Char -> Parser a) + -> (Char -> Parser b) + -> Value -> Parser (OutsideClues k b, Grid k a) +parseOutsideGrid parseIn parseOut v = do + BorderedRect w h ls b <- parseBorderedRect parseIn parseOut v + return (outside b, fromCoordGrid . rectToCoordGrid $ Rect w h ls) + where outside (Border l r b t) = OC l r b t + +parseOutsideGridMap :: (Key k, FromChar a, FromChar b) + => (a -> c) -> (b -> d) + -> Value -> Parser (OutsideClues k d, Grid k c) +parseOutsideGridMap mapIn mapOut v = do + (o, g) <- parseOutsideGrid parseChar parseChar v + return (mapOut <$> o, mapIn <$> g) + newtype Tight = Tight { unTight :: Tightfit () } instance FromChar Tight where @@ -445,14 +552,12 @@ parseChar '\\' = pure . Tight $ DR () () parseChar _ = empty -parseTightOutside :: Value -> Parser (OutsideClues (Maybe Int), - SGrid (Tightfit ())) -parseTightOutside v = do - BorderedRect w h ls b <- parseJSON v - :: Parser (BorderedRect Tight (Either Blank' Int)) - return (outside . fmap (either (const Nothing) Just) $ b, - fmap unTight . rectToSGrid $ Rect w h ls) - where outside (Border l r b t) = OC l r b t +parseTightOutside :: Value -> Parser (OutsideClues C (Maybe Int), + Grid C (Tightfit ())) +parseTightOutside = parseOutsideGridMap unTight unBlank' + where + unBlank' :: Either Blank' Int -> Maybe Int + unBlank' = either (const Nothing) Just instance FromChar a => FromString (Tightfit a) where parseString [c] = Single <$> parseChar c @@ -460,9 +565,6 @@ parseString [c,'\\',d] = DR <$> parseChar c <*> parseChar d parseString _ = empty -parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int)) -parseTightIntGrid v = rectToSGrid . unSpaced <$> parseJSON v - newtype PMarkedWord = PMW {unPMW :: MarkedWord} parseNWords :: Int -> String -> Parser [String] @@ -471,15 +573,28 @@ where ws = words s +parseDoublePair :: FromString a => Value -> Parser ((a, a), (a, a)) +parseDoublePair v = (,) <$> + ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*> + ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x)) + where x = parseJSON v >>= parseNWords 4 >>= mapM parseString + instance FromJSON PMarkedWord where - parseJSON v = PMW <$> (MW <$> - ((,) <$> ((!!0) <$> x) <*> ((!!1) <$> x)) <*> - ((,) <$> ((!!2) <$> x) <*> ((!!3) <$> x))) - where x = parseJSON v >>= parseNWords 4 >>= mapM parseString + parseJSON v = PMW . uncurry MW <$> parseDoublePair v instance FromString Int where parseString s = maybe empty pure $ readMaybe s +parseMarkedLine :: FromCoord a => Value -> Parser (MarkedLine a) +parseMarkedLine v = do + (s, e) <- parseDoublePair v + return $ MarkedLine (fromCoord s) (fromCoord e) + +newtype PMarkedLine a = PML {unPML :: MarkedLine a} + +instance FromCoord a => FromJSON (PMarkedLine a) where + parseJSON v = PML <$> parseMarkedLine v + newtype PCompassC = PCC {unPCC :: CompassC} instance FromJSON PCompassC where @@ -490,49 +605,62 @@ comp _ = empty parseJSON _ = empty -newtype RefGrid a = RefGrid { unRG :: SGrid a } +newtype PSlovakClue = PSlovakClue {unPSlovakClue :: SlovakClue} -data Ref = Ref { unRef :: Char } - deriving Show +instance FromJSON PSlovakClue where + parseJSON (String t) = svk . map T.unpack . T.words $ t + where + svk [s, c] = PSlovakClue <$> (SlovakClue <$> parseString s <*> parseString c) + svk _ = fail "expect two integers" + parseJSON _ = fail "expect string of two integers" -instance FromChar Ref where - parseChar c | isAlpha c = pure (Ref c) - parseChar _ = empty +newtype RefGrid k a = RefGrid { unRG :: Grid k (Maybe a) } -hashmaptomap :: (Eq a, Hashable a, Ord a) => HMap.HashMap a b -> Map.Map a b +hashmaptomap :: Ord a => HMap.HashMap a b -> Map.Map a b hashmaptomap = Map.fromList . HMap.toList -compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) +compose :: Ord b => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) compose m1 m2 = mapM (`Map.lookup` m2) m1 -instance FromJSON a => FromJSON (RefGrid a) where - parseJSON (Object v) = RefGrid <$> do - Grid s refs <- fmap (fmap ((:[]) . unRef)) . rectToClueGrid <$> - (v .: "grid" :: Parser (Rect (Either Blank Ref))) - m <- hashmaptomap <$> v .: "clues" - case compose (Map.mapMaybe id refs) m of +newtype MaybeMap k a = MM { unMaybeMap :: Map.Map k (Maybe a) } + +instance Functor (MaybeMap k) where + fmap f (MM m) = MM (fmap (fmap f) m) + +instance Foldable (MaybeMap k) where + foldMap f (MM m) = foldMap (foldMap f) m + +instance Traversable (MaybeMap k) where + traverse f m = MM <$> traverse (traverse f) (unMaybeMap m) + +compose' :: Ord b => Map.Map a (Maybe b) + -> Map.Map b c + -> Maybe (Map.Map a (Maybe c)) +compose' m1 m2 = unMaybeMap <$> mapM (`Map.lookup` m2) (MM m1) + +instance (Key k, FromJSON a) => FromJSON (RefGrid k a) where + parseJSON v = RefGrid <$> do + refs <- fmap (fmap ((:[]) . unAlpha) . blankToMaybe) + <$> parseFrom ["grid"] parseGrid v + m <- hashmaptomap <$> parseFrom ["clues"] parseJSON v + case compose' refs m of Nothing -> mzero - Just m' -> return $ Grid s m' - parseJSON _ = empty + Just m' -> return m' -parseAfternoonGrid :: Value -> Parser (SGrid Shade) +parseAfternoonGrid :: Value -> Parser (Grid C Shade) parseAfternoonGrid v = do - (Grid s _ , es) <- parseNodeEdges v :: Parser (SGrid Char, [Edge]) - let (m, b) = splitBorder s $ toMap es - guard $ Map.null b - return $ Grid (shrink s) m + (_, _, es) <- parsePlainEdgeGrid v + :: Parser (Grid N Char, Grid C Char, [Edge N]) + return . toMap $ es where - shrink (Square w h) = Square (w-1) (h-1) - toShade V = Shade False True - toShade H = Shade True False + toShade Vert = Shade False True + toShade Horiz = Shade True False merge (Shade a b) (Shade c d) | a && c || b && d = error "shading collision" | otherwise = Shade (a || c) (b || d) toMap es = Map.fromListWith merge - [(p, toShade d) | E p d <- es] - splitBorder (Square w h) = Map.partitionWithKey - (\(x, y) _ -> x < w - 1 && y < h - 1) + [(fromCoord . toCoord $ p, toShade d) | E p d <- es] newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue } @@ -541,10 +669,10 @@ guard $ length xs > 0 && length xs <= 4 return . ParseTapaClue . TapaClue $ xs -reorientOutside :: OutsideClues a -> OutsideClues a +reorientOutside :: OutsideClues k a -> OutsideClues k a reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t -parseCharOutside :: FromChar a => Value -> Parser (OutsideClues a) +parseCharOutside :: FromChar a => Value -> Parser (OutsideClues k a) parseCharOutside (Object v) = reorientOutside <$> (OC <$> pfield "left" <*> pfield "right" <*> @@ -553,7 +681,7 @@ pfield f = parseLine . fromMaybe [] =<< v .:? f parseCharOutside _ = empty -parseOutside :: FromJSON a => Value -> Parser (OutsideClues a) +parseOutside :: FromJSON a => Value -> Parser (OutsideClues k a) parseOutside (Object v) = reorientOutside <$> (OC <$> pfield "left" <*> pfield "right" <*> @@ -562,7 +690,7 @@ pfield f = pure . fromMaybe [] =<< v .:? f parseOutside _ = empty -parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a]) +parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues k [a]) parseMultiOutsideClues (Object v) = rev <$> raw where raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top" @@ -578,6 +706,55 @@ parseChar 'X' = pure $ PrimeDiag (True, True) parseChar _ = empty +parseCoordLoop :: Value -> Parser VertexLoop +parseCoordLoop v = sortCoords <$> parseClueGrid v + where + sortCoords :: Grid N (Maybe Char) -> VertexLoop + sortCoords = map fst . sortBy (comparing snd) . Map.toList . clues + +instance FromString DigitRange where + parseString s = do + let (a, b) = break (== '-') s + b' <- case b of ('-':cs) -> pure cs + _ -> fail "exected '-' in range" + DigitRange <$> parseString a <*> parseString b' + +newtype PFraction = PFraction { unPFraction :: Fraction } + +instance FromJSON PFraction where + parseJSON v = PFraction <$> toStringParser fraction v + instance FromChar Crossing where parseChar '+' = pure Crossing parseChar _ = fail "expected '+'" + +instance FromChar KropkiDot where + parseChar '*' = pure KBlack + parseChar 'o' = pure KWhite + parseChar ' ' = pure KNone + parseChar '.' = pure KNone + parseChar _ = fail "expected '*o '" + +instance FromChar Relation where + parseChar '<' = pure RLess + parseChar '>' = pure RGreater + parseChar '=' = pure REqual + parseChar ' ' = pure RUndetermined + parseChar _ = fail "expected '<>= '" + +parseGreaterClues :: Value -> Parser [GreaterClue] +parseGreaterClues v = do + Rect _ _ ls <- parseJSON v + mapM parseGreaterClue ls + +parseGreaterClue :: [Char] -> Parser GreaterClue +parseGreaterClue [] = pure [] +parseGreaterClue xs = p RUndetermined xs + where + p rel ('.':cs) = (rel:) <$> q cs + p _ (' ':_) = pure [] -- Rect fills the lines up with spaces... + p _ _ = fail "expected '.'" + q [] = pure [] + q (r:cs) = do + rel <- parseChar r + p rel cs diff --git a/src/tools/checkpuzzle.hs b/src/tools/checkpuzzle.hs new file mode 100644 --- /dev/null +++ b/src/tools/checkpuzzle.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import Text.Puzzles.Puzzle +import Data.Puzzles.PuzzleTypes (typeNames, PuzzleType(..)) +import Data.Puzzles.CmdLine (exitErr, readPuzzle, checkType) + +import Data.Puzzles.Elements (digitList) +import qualified Text.Puzzles.PuzzleTypes as T + +import Options.Applicative +import Control.Monad +import Data.Maybe +import Data.List (intercalate, sort) + +import System.Exit +import System.Environment (getProgName) + +import qualified Data.Yaml as Y + +optListTypes :: Parser (a -> a) +optListTypes = + infoOption + (unlines' . sort . map snd $ typeNames) + (long "list-types" + <> help "List supported puzzle types") + where + unlines' = intercalate "\n" + +data PuzzleOpts = PuzzleOpts + { _type :: Maybe String + , _input :: FilePath + } + +puzzleOpts :: Parser PuzzleOpts +puzzleOpts = PuzzleOpts + <$> (optional . strOption $ + (long "type" <> short 't' + <> metavar "TYPE" + <> help "Puzzle type, overriding type in input file")) + <*> argument str + (metavar "INPUT" + <> help "Puzzle file in .pzl format") + +defaultOpts :: Parser a -> IO a +defaultOpts optsParser = do + prog <- getProgName + let p = info (helper <*> optListTypes <*> optsParser) + (fullDesc + <> progDesc "Command-line puzzle checking." + <> header prog) + execParser p + +main :: IO () +main = do + opts <- defaultOpts puzzleOpts + mp <- readPuzzle (_input opts) + TP mt pv msv _ <- case mp of Left e -> exitErr $ + "parse failure: " ++ show e + Right p -> return p + t <- checkType $ _type opts `mplus` mt + sv <- maybe (exitErr $ "need solution") return msv + let es = Y.parseEither (check t) (pv, sv) + case es of Left err -> exitErr $ "parse failure: " ++ err + Right [] -> exitSuccess + Right es' -> mapM_ putStrLn es' >> exitFailure + +check :: PuzzleType -> (Y.Value, Y.Value) -> Y.Parser [String] +check t (pv, sv) = + case t of + ABCtje -> checkABCtje (pv, sv) + _ -> return [] + +checkABCtje :: (Y.Value, Y.Value) -> Y.Parser [String] +checkABCtje (pv, sv) = do + p <- fst T.abctje $ pv + s <- snd T.abctje $ sv + return . catMaybes . map (\c -> c p s) $ + [ solutionKeys, values ] + where + solutionKeys (ds, _) s = let have = sort (digitList ds) + want = sort (map fst (s)) + in if have /= want then Just "unequal digit lists" else Nothing + values (_, ws) vs = (\es -> case es of [] -> Nothing + _ -> Just $ intercalate ", " es) + . catMaybes + . map (\(w, v) -> if val w == v + then Nothing + else Just (w ++ " should be " ++ show (val w))) + $ ws + where + l c = fromMaybe 0 . lookup c . map (\(x, y) -> (y, x)) $ vs + val = sum . map l diff --git a/src/tools/drawpuzzle.hs b/src/tools/drawpuzzle.hs --- a/src/tools/drawpuzzle.hs +++ b/src/tools/drawpuzzle.hs @@ -4,12 +4,15 @@ import Diagrams.Prelude hiding (value, option, (<>), Result) +import Data.Puzzles.CmdLine import Diagrams.Puzzles.CmdLine import Text.Puzzles.Puzzle +import Text.Puzzles.Code import Data.Puzzles.Compose import Data.Puzzles.PuzzleTypes (typeNames) import Diagrams.Puzzles.Draw +import Diagrams.Puzzles.Code import Options.Applicative import Control.Monad @@ -36,6 +39,7 @@ , _puzzle :: Bool , _solution :: Bool , _example :: Bool + , _code :: Bool , _input :: FilePath } @@ -59,6 +63,9 @@ <*> switch (long "example" <> short 'e' <> help "Render example (to base.ext)") + <*> switch + (long "code" <> short 'c' + <> help "Add solution code markers") <*> argument str (metavar "INPUT" <> help "Puzzle file in .pzl format") @@ -83,7 +90,7 @@ base = takeBaseName (_input opts) out = addExtension (base ++ outputSuffix oc) f -renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B R2)) -> +renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B)) -> (OutputChoice, Bool) -> IO () renderPuzzle opts r (oc, req) = do let x = r oc @@ -129,17 +136,29 @@ hasSol DrawExample = True hasSol DrawPuzzle = False +maybeSkipCode :: PuzzleOpts -> Maybe Y.Value -> Maybe Y.Value +maybeSkipCode opts = if _code opts then id else const Nothing + +parseAndDrawCode :: Y.Value -> IO (CodeDiagrams (Diagram B)) +parseAndDrawCode v = case parsed of + Left e -> exitErr $ "solution code parse failure: " ++ e + Right c -> return $ drawCode c + where + parsed = Y.parseEither parseCode v + main :: IO () main = do opts <- defaultOpts puzzleOpts ocs <- checkOutput opts checkFormat (_format opts) mp <- readPuzzle (_input opts) - TP mt pv msv <- case mp of Left e -> exitErr $ - "parse failure: " ++ show e - Right p -> return p + TP mt pv msv mc <- case mp of Left e -> exitErr $ + "parse failure: " ++ show e + Right p -> return p let msv' = maybeSkipSolution ocs msv + mc' = maybeSkipCode opts mc t <- checkType $ _type opts `mplus` mt let ps = Y.parseEither (handle drawPuzzleMaybeSol t) (pv, msv') - case ps of Right ps' -> mapM_ (renderPuzzle opts (draw ps')) ocs + mcode <- sequenceA $ parseAndDrawCode <$> mc' + case ps of Right ps' -> mapM_ (renderPuzzle opts (draw mcode ps')) ocs Left e -> exitErr $ "parse failure: " ++ e diff --git a/tests/Data.hs b/tests/Data.hs new file mode 100644 --- /dev/null +++ b/tests/Data.hs @@ -0,0 +1,244 @@ +module Data where + +import qualified Data.Text as T +import Data.Yaml +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import Data.Text.Encoding (encodeUtf8) + +packStr :: String -> B.ByteString +packStr = encodeUtf8 . T.pack + +decodeLines :: [String] -> Value +decodeLines = fromJust . decode . packStr . unlines + +packLine :: String -> Value +packLine = String . T.pack + +packLines :: [String] -> Value +packLines = String . T.pack . unlines + +geradeweg_1 :: Value +geradeweg_1 = packLines $ + [ "..... " + , ".211." + , "..2.. " + , "3...4" + , "....." + ] + +geradeweg_1_sol :: Value +geradeweg_1_sol = packLines $ + [ "┌┐┌─┐" + , "││└┐│ " + , "│└─┘│" + , "└──┐│" + , " .└┘ " + ] + +tightfit_1 :: Value +tightfit_1 = packLines $ + [ " --- " + , "3/\\.-" + , "-\\.\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_broken_1 :: Value +tightfit_broken_1 = packLines $ + [ " --- " + , "3/\\.-" + , "-\\x\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_broken_2 :: Value +tightfit_broken_2 = packLines $ + [ "3/\\.-" + , "-\\x\\4" + , "-.\\/-" + , " 35-" + ] + +tightfit_1_sol :: Value +tightfit_1_sol = packLines $ + [ "2/1 4\\5 3" + , " 4\\5 3 2\\1 " + , " 3 1\\2 5/4" + ] + +tightfit_sol_broken :: Value +tightfit_sol_broken = packLine "2/1 4 /5" + +tightfit_sol_broken_2 :: Value +tightfit_sol_broken_2 = packLine "2/x 4 3/5" + +slalom_sol_broken :: Value +slalom_sol_broken = packLine "//\\ /\\x5 " + +kpyramid_1 :: Value +kpyramid_1 = packLines $ + [ "G 3" + , "G . ." + , "G . . ." + , "W .o. . ." + , "G 1*.*.o.*6" + ] + +kpyramid_1_sol :: Value +kpyramid_1_sol = packLines $ + [ " 3" + , " 8 5" + , " 1 9 4" + , " 3 2 7 3" + , "1 2 4 3 6" + ] + +kpyramid_broken_1 :: Value +kpyramid_broken_1 = packLines $ + [ " G 3" + , " G . 22" + , " H . aa ." + , " W .o. .|. " + , " G 1*.*.o.*6" + ] + +kpyramid_broken_2 :: Value +kpyramid_broken_2 = packLines $ + [ "G 3" + , "G . 22" + , "H . aa ." + , "W .o. .|. " + , "G 1*.*.o.*6" + ] + +kpyramid_broken_3 :: Value +kpyramid_broken_3 = packLines $ + [ "G 3" + , "G . ." + , "G . . ." + , "W .o. . ." + , "G a*.*.o.*6" + ] + +compass_1 :: Value +compass_1 = decodeLines $ + [ "grid: |" + , " ..." + , " a.b" + , "clues:" + , " a: 2 1 . 2" + , " b: 21 . . 0" + ] + +compass_broken_1 :: Value +compass_broken_1 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " b: 21 . . 0" + ] + +compass_broken_2 :: Value +compass_broken_2 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: x . . 0" + , " b: 21 . . 0" + ] + +compass_broken_3 :: Value +compass_broken_3 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: 1 . ." + , " b: 21 . . 0" + ] + +compass_broken_4 :: Value +compass_broken_4 = decodeLines $ + [ "grid: |" + , " a.b" + , "clues:" + , " a: 1 . . 2 3" + , " b: 21 . . 0" + ] + +compass_broken_5 :: Value +compass_broken_5 = decodeLines $ + [ "grid: |" + , " a3b" + , "clues:" + , " a: 1 . . 2 3" + , " b: 21 . . 0" + ] + +thermo_1 :: Value +thermo_1 = packLines $ + [ ".b..2." + , "a.c5.1" + , ".d..6." + , ".4..c." + , "5.3b.d" + , ".2..a." + ] + +thermo_2 :: Value +thermo_2 = packLines $ + [ "....2." + , "..c5.1" + , ".b..6." + , "a..c.." + , "a...b." + , ".bc.a." + ] + +thermo_broken_1 :: Value +thermo_broken_1 = packLines $ + [ ".." + , "a." + ] + +thermo_broken_2 :: Value +thermo_broken_2 = packLines $ + [ "bb" + , "a." + ] + +multioutside :: Value +multioutside = decodeLines $ + [ "left:" + , " - [2, 1]" + , " - [3]" + , "right:" + , " - []" + , " - [1, 0]" + , "bottom:" + , " - [0, 0, 1]" + , "top:" + , " - [-1, 1]" + ] + +boxof2or3_1 :: Value +boxof2or3_1 = packLines $ + [ "*-*-*-*-*" + , "| | | | |" + , "*-*-*-*-*" + , "| | |" + , "*-o-o-o-*" + , " | | |" + , "*-*-*-*-*" + , "| | | | |" + , "o-*-*-*-*" + ] + +edgeGrid_1 :: Value +edgeGrid_1 = packLines $ + [ "o-*-*-o" + , "|1|2 3" + , "*-o" + ] diff --git a/tests/Data/Puzzles/GridShapeSpec.hs b/tests/Data/Puzzles/GridShapeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Puzzles/GridShapeSpec.hs @@ -0,0 +1,11 @@ +module Data.Puzzles.GridShapeSpec where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Puzzles.GridShape + +spec :: Spec +spec = do + describe "edgeSize" $ do + it "computes the size in cells" $ do + edgeSize [E (N 1 1) Vert, E (N 2 1) Horiz] `shouldBe` (3, 2) diff --git a/tests/Data/Puzzles/GridSpec.hs b/tests/Data/Puzzles/GridSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Puzzles/GridSpec.hs @@ -0,0 +1,22 @@ +module Data.Puzzles.GridSpec where + +import qualified Data.Set as Set +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Puzzles.Grid +import Data.Puzzles.GridShape (N(..)) + +spec :: Spec +spec = do + describe "sizeGrid" $ do + it "creates a rectangular grid of nodes" $ do + nodes (sizeGrid (2, 3)) `shouldBe` Set.fromList [ + N 0 0, N 0 1, N 0 2, + N 1 0, N 1 1, N 1 2] + nodes (sizeGrid (0, 0)) `shouldBe` Set.empty + nodes (sizeGrid (2, 0)) `shouldBe` Set.empty + nodes (sizeGrid (2, 1)) `shouldBe ` Set.fromList [N 0 0, N 1 0] + + describe "nodeGrid" $ do + it "creates the grid of nodes from a rectangular grid of cells" $ do + nodes (nodeGrid (sizeGrid (2, 1))) `shouldBe` nodes (sizeGrid (3, 2)) diff --git a/tests/Diagrams/Puzzles/GridSpec.hs b/tests/Diagrams/Puzzles/GridSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Diagrams/Puzzles/GridSpec.hs @@ -0,0 +1,32 @@ +module Diagrams.Puzzles.GridSpec where + +import Diagrams.Prelude (p2) +import Diagrams.Path (pathPoints) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Data.Puzzles.Grid +import Data.Puzzles.GridShape +import Diagrams.Puzzles.Grid +import Diagrams.Puzzles.Lib (p2i) + +spec :: Spec +spec = do + describe "irregularGridPaths" $ do + it "gives the border of a rectangular grid" $ do + let g = sizeGrid (2, 3) :: Grid C () + (outer, _) = irregularGridPaths g + pts = pathPoints outer + length pts `shouldBe` 1 + let [opts] = pts + opts `shouldSatisfy` elem (p2i (0, 0)) + opts `shouldSatisfy` elem (p2i (2, 0)) + opts `shouldSatisfy` elem (p2i (2, 3)) + opts `shouldSatisfy` elem (p2i (0, 3)) + + describe "midPoint" $ do + it "gives the center of a node edge" $ do + let e = E (N 0 1) Horiz + midPoint e `shouldBe` p2 (0.5, 1.0) + it "gives the center of a cell edge" $ do + let e = E (C 0 0) Vert + midPoint e `shouldBe` p2 (0.5, 1.0) diff --git a/tests/Text/Puzzles/PuzzleTypesSpec.hs b/tests/Text/Puzzles/PuzzleTypesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Puzzles/PuzzleTypesSpec.hs @@ -0,0 +1,54 @@ +module Text.Puzzles.PuzzleTypesSpec where + +import Data.Maybe (isJust) +import qualified Data.Map as Map +import Data.Yaml +import Data.Text.Encoding (encodeUtf8) +import qualified Data.ByteString as B +import qualified Data.Text as T + +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +import Data.Puzzles.GridShape (edgeSize) +import Data.Puzzles.Elements (DigitRange(..)) +import Text.Puzzles.PuzzleTypes + +packLines :: [String] -> B.ByteString +packLines = encodeUtf8 . T.pack . unlines + +parse :: (Value -> Parser a) -> B.ByteString -> Maybe a +parse p t = decode t >>= parseMaybe p + +spec :: Spec +spec = do + describe "abctje" $ do + it "parses a list of clues" $ do + let (p, _) = abctje + y = packLines [ "numbers: 1-10" + , "clues:" + , "- HELLO: 15" + , "- WORLD: 20" + , "- weird stuff, too!: 100" + ] + parse p y `shouldBe` Just (DigitRange 1 10, [("HELLO", 15), ("WORLD", 20), ("weird stuff, too!", 100)]) + it "parses a solution" $ do + let (_, p) = abctje + y = packLines [ "- 1: A" + , "- 100: C" + ] + parse p y `shouldBe` Just [(1, 'A'), (100, 'C')] + + describe "kropki" $ do + it "parses edges of the right size" $ do + let (p, _) = kropki + y = packLines [ "|" + , " + + + +" + , " . . . " + , " +*+ + +" + , " . .o. " + , " + + + +" + ] + res = parse p y + res `shouldSatisfy` isJust + let Just m = res + edgeSize (Map.keys m) `shouldBe` (3, 2) diff --git a/tests/Text/Puzzles/UtilSpec.hs b/tests/Text/Puzzles/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Puzzles/UtilSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeFamilies #-} +module Text.Puzzles.UtilSpec where + +import qualified Data.Map as Map +import Data.Yaml +import qualified Data.Text as T + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Puzzles.GridShape (Edge(..), N(..), Dir(..)) +import Data.Puzzles.Elements (Relation(..)) +import Text.Puzzles.Util (parseCoordGrid, parseAnnotatedEdges, parseGreaterClue) + +packLines :: [String] -> Value +packLines = String . T.pack . unlines + +spec :: Spec +spec = do + describe "parseCoordGrid" $ do + it "parses a rectangle of letters" $ do + let y = packLines [ "abc" + , "def" + ] + want = Map.fromList [ ((0, 0), 'd') + , ((1, 0), 'e') + , ((2, 0), 'f') + , ((0, 1), 'a') + , ((1, 1), 'b') + , ((2, 1), 'c') + ] + parseMaybe parseCoordGrid y `shouldBe` Just want + + describe "parseAnnotatedEdges" $ do + it "parses some kropki clues" $ do + let y = packLines [ "+ + + +" + , " . .*.o" + , "+ +o+ +" + , " . . . " + , "+ + + +" + ] + want = Map.fromList + [ (E (N 1 1) Horiz, 'o') + , (E (N 2 1) Vert, '*') + , (E (N 3 1) Vert, 'o') + ] + parseNonempty v = Map.filter ((/=) ' ') <$> parseAnnotatedEdges v + parseMaybe parseNonempty y `shouldBe` Just want + + describe "parseGreaterClue" $ do + it "parses an empty line" $ do + let y = [] + want = [] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a single dot" $ do + let y = ['.'] + want = [RUndetermined] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a single dot" $ do + let y = ['.'] + want = [RUndetermined] + parseMaybe parseGreaterClue y `shouldBe` Just want + + it "parses a mixed line" $ do + let y = ['.', '<', '.', ' ', '.', '=', '.'] + want = [RUndetermined, RLess, RUndetermined, REqual] + parseMaybe parseGreaterClue y `shouldBe` Just want diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,29 @@ +module Util where + +import Control.DeepSeq +import Data.Yaml + +import Test.Tasty.HUnit + +-- | Force full evaluation of a showable value. +justShow :: Show a => Maybe a -> Bool +justShow Nothing = False +justShow (Just x) = show x `deepseq` True + +-- | Force full evaluation of a showable value. +eitherShow :: Show a => Either e a -> Bool +eitherShow (Left _) = False +eitherShow (Right x) = show x `deepseq` True + +-- | Test that a value is parsed correctly, by forcing the +-- parse result to be fully evaluated. +testParse :: Show a => (Value -> Parser a) -> Value -> Assertion +testParse p t = eitherShow res @? "bad parse: " ++ err + where + res = parseEither p t + err = either id (const "no error") res + +-- | Test that a value is not parsed. +testNonparse :: Show a => (Value -> Parser a) -> Value -> Assertion +testNonparse p t = (not . justShow . parseMaybe p $ t) + @? "parsed but shouldn't" diff --git a/tests/compare.hs b/tests/compare.hs new file mode 100644 --- /dev/null +++ b/tests/compare.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Test.Tasty +import Test.Tasty.Golden + +import System.Process +import System.FilePath + +main :: IO () +main = tests >>= defaultMain + +render :: FilePath -> IO () +render fp = callProcess "stack" ["exec", "drawpuzzle", "--", "-e", "-c", "-f", "png", fp ] + +testFile :: FilePath -> TestTree +testFile fp = goldenVsFile ("comparing " ++ fp) + fppng + (takeFileName fppng) + (render fp) + where + fppng = replaceExtension fp ".png" + +tests :: IO TestTree +tests = testGroup "compare to old output" . map testFile + <$> findByExtension [".pzl"] "tests/examples" diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,45 +1,62 @@ import Test.Tasty +import Test.Tasty.Hspec import Test.Tasty.HUnit import Data.Yaml import Data.List (sort) import qualified Data.Map as Map -import Control.DeepSeq import Text.Puzzles.Puzzle import Data.Puzzles.Elements (Thermometer, MasyuPearl(..)) import Text.Puzzles.Util - (parseChar, parseMultiOutsideClues, parseEdgeGrid) + (parseChar, parseMultiOutsideClues, parsePlainEdgeGrid) import Text.Puzzles.PuzzleTypes import qualified Data.Puzzles.Grid as Grid import Data.Puzzles.Pyramid (PyramidSol(..)) -import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..)) -import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..)) +import Data.Puzzles.Grid +import Data.Puzzles.GridShape +import Data.Puzzles.Util -import Diagrams.Puzzles.PuzzleGrids -import Diagrams.Prelude -import Diagrams.Backend.SVG -import Text.Blaze.Svg.Renderer.Text (renderSvg) - import Data import Util +import qualified Data.Puzzles.GridSpec +import qualified Data.Puzzles.GridShapeSpec +import qualified Diagrams.Puzzles.GridSpec +import qualified Text.Puzzles.PuzzleTypesSpec +import qualified Text.Puzzles.UtilSpec main :: IO () -main = defaultMain tests +main = do + ss <- specs + defaultMain . testGroup "Tests" $ tests ++ ss -tests :: TestTree -tests = testGroup "Tests" - [ parseUtilTests, parseTests, parseDataTests, renderTests, dataTests ] +specs :: IO [TestTree] +specs = mapM (uncurry testSpec) + [ ("Data.Puzzles.Grid", Data.Puzzles.GridSpec.spec) + , ("Data.Puzzles.GridShape", Data.Puzzles.GridShapeSpec.spec) + , ("Diagrams.Puzzles.Grid", Diagrams.Puzzles.GridSpec.spec) + , ("Text.Puzzles.PuzzleTypes", Text.Puzzles.PuzzleTypesSpec.spec) + , ("Text.Puzzles.Util", Text.Puzzles.UtilSpec.spec) + ] -testParsePzl, testParseSol, testNonparsePzl, testNonparseSol :: - (Show a, Show b) => String -> ParsePuzzle a b -> Value -> TestTree +tests :: [TestTree] +tests = [ parseUtilTests, parseTests, parseDataTests, dataTests ] + +testParsePzl :: + Show a => String -> ParsePuzzle a b -> Value -> TestTree testParsePzl name parser yaml = testCase ("parse " ++ name) $ testParse (fst parser) yaml +testParseSol :: + Show b => String -> ParsePuzzle a b -> Value -> TestTree testParseSol name parser yaml = testCase ("parse " ++ name ++ " (sol)") $ testParse (snd parser) yaml +testNonparsePzl :: + Show a => String -> ParsePuzzle a b -> Value -> TestTree testNonparsePzl name parser yaml = testCase ("don't parse broken " ++ name) $ testNonparse (fst parser) yaml +testNonparseSol :: + Show b => String -> ParsePuzzle a b -> Value -> TestTree testNonparseSol name parser yaml = testCase ("don't parse broken " ++ name ++ " (sol)") $ testNonparse (snd parser) yaml @@ -92,15 +109,15 @@ test_thermo_2 = either (const []) snd $ parseEither (fst thermosudoku) thermo_2 -testThermo :: [Thermometer] -> [Thermometer] -> Assertion -testThermo t expect = sort t @?= expect +testThermo :: [Thermometer] -> [[Coord]] -> Assertion +testThermo t expect = sort t @?= map (map fromCoord) expect test_tightfit_1 :: Bool test_tightfit_1 = either (const False) test_both res where res = parseEither (fst tightfitskyscrapers) tightfit_1 test_both (o, g) = test_size g && test_clues o - test_size g = Grid.size g == (3, 3) + test_size g = Grid.size (Map.mapKeys toCoord g) == (3, 3) test_clues (Grid.OC l r b t) = l == [Nothing, Nothing, Just 3] && r == [Nothing, Just 4, Nothing] && b == [Just 3, Just 5, Nothing] && @@ -118,19 +135,23 @@ where res = parseEither parseMultiOutsideClues multioutside oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]] - :: OutsideClues [Int] + :: OutsideClues Coord [Int] -test_edge_grid :: Assertion -test_edge_grid = Right (gn, gc, es) @=? res +test_plain_edge_grid :: Assertion +test_plain_edge_grid = Right (gn, gc, sort es) @=? res' where - res = parseEither parseEdgeGrid edgeGrid_1 - gn = Grid.Grid (Square 4 2) $ Map.fromList + res = parseEither parsePlainEdgeGrid edgeGrid_1 + res' = fmap (\(x, y, e) -> (x, y, sort e)) res + gn :: Grid.Grid N (Maybe MasyuPearl) + gn = Map.mapKeys fromCoord . Map.fromList $ [((0,0),Just MBlack),((0,1),Just MWhite),((1,0),Just MWhite),((1,1),Just MBlack), ((2,0),Nothing),((2,1),Just MBlack),((3,0),Nothing),((3,1),Just MWhite)] - gc :: Grid.SGrid Int - gc = Grid.Grid (Square 3 1) $ Map.fromList + gc :: Grid.Grid C Int + gc = Map.mapKeys fromCoord . Map.fromList $ [((0,0),1),((1,0),2),((2,0),3)] - es = [E (0,0) H, E (0,1) H, E (1,1) H, E (2,1) H, E (0,0) V, E (1,0) V] + es = map (\(E c d) -> E (fromCoord c) d) + [E (0,0) Horiz, E (0,1) Horiz, E (1,1) Horiz, E (2,1) Horiz, + E (0,0) Vert, E (1,0) Vert] parseDataTests :: TestTree parseDataTests = testGroup "Parsing tests (full puzzles, result checks)" @@ -144,39 +165,70 @@ , [(0, 2), (1, 3), (2, 4)] , [(4, 0), (4, 1), (3, 2)] ] , testCase "parse multioutsideclues" $ test_multioutside - , testCase "parse edge grid" $ test_edge_grid + , testCase "parse edge grid" $ test_plain_edge_grid ] --- this used to cause a rendering crash, though it's --- caught by parsing by now -testBreakSlalom :: Bool -testBreakSlalom = - case parseMaybe (snd slalom) slalom_sol_broken of - Nothing -> True - Just s -> let d = drawSlalomDiags s - svg = renderDia SVG (SVGOptions (Width 100) Nothing) d - svgt = renderSvg svg - in (show svgt) `deepseq` True - -renderTests :: TestTree -renderTests = testGroup "Rendering tests" - [ testCase "don't break rendering invalid slalom solution" - $ testBreakSlalom @? "just testing against errors" - ] +sorteq :: (Show a, Ord a) => [a] -> [a] -> Assertion +sorteq xs ys = sort xs @?= sort ys testMultiOutsideClues :: Assertion -testMultiOutsideClues = multiOutsideClues (OC l r b t) `sorteq` res +testMultiOutsideClues = multiOutsideClues (OC l r b t) @=? res where - sorteq xs ys = sort xs @?= sort ys l = [[1, 2], [3]] r = [[], [1, 0]] b = [[0, 0, 1]] t = [[1, -1]] - res = [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3), + res :: Map.Map C Int + res = Map.mapKeys fromCoord . Map.fromList $ + [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3), ((1,1), 1), ((2,1), 0), ((0,-1), 0), ((0,-2), 0), ((0,-3), 1), - ((0,2), 1), ((0,3), -1) ] :: [((Int, Int), Int)] + ((0,2), 1), ((0,3), -1) ] +testEdges :: Assertion +testEdges = do + inner `sorteq` expinner' + outer `sorteq` expouter' + where + (outer, inner) = edges cs (`elem` cs) + {- + ### + # # + ### + -} + cs :: [C] + cs = map fromCoord [(0,0), (1,0), (2,0), (0,1), (2,1), (0,2), (1,2), (2,2)] + expouter = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)), + ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)), + ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)), + ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))] + expouter' = map (uncurry edge' . fromCoord2) expouter + expinner = [((0,1),(1,1)), ((0,2),(1,2)), ((1,0),(1,1)), ((2,0),(2,1)), + ((1,3),(1,2)), ((2,3),(2,2)), ((3,1),(2,1)), ((3,2),(2,2))] + expinner' = map (uncurry edge . fromCoord2) expinner + fromCoord2 (p,q) = (fromCoord p, fromCoord q) + +testLoops :: Assertion +testLoops = loops es @=? Just loopsexp + -- rotations of the loops would be fine + -- inside and outside of: + -- xxx + -- x x + -- xxx + where + es = [((0,0),(0,1)), ((0,1),(0,2)), ((0,2),(0,3)), ((0,3),(1,3)), + ((1,3),(2,3)), ((2,3),(3,3)), ((3,3),(3,2)), ((3,2),(3,1)), + ((3,1),(3,0)), ((3,0),(2,0)), ((2,0),(1,0)), ((1,0),(0,0)), + ((1,1),(2,1)), ((2,1),(2,2)), ((2,2),(1,2)), ((1,2),(1,1))] + loopsexp :: [[(Int, Int)]] + loopsexp = + [ [(0,0), (0,1), (0,2), (0,3), (1,3), (2,3), (3,3), (3,2), (3,1), + (3,0), (2,0), (1,0), (0,0)] + , [(1,1), (2,1), (2,2), (1,2), (1,1)] + ] + dataTests :: TestTree dataTests = testGroup "Generic tests for the Data modules" [ testCase "multiOutsideClues" testMultiOutsideClues + , testCase "edges" testEdges + , testCase "loops" testLoops ]