diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,15 @@ +0.1.0.4: 20141115 +----------------- + +* add installation and usage instructions to README +* merge puzzle-draw-cmdline +* update for diagrams 1.2 and ghc 7.8 +* add new puzzle types: Bahnhof, Cave +* rename `countnumbers` to `meanderingnumbers` +* include and use a nicer font +* command-line option to list supported puzzle types +* various tweaks and fixes + 0.1.0.3: 20140519 ----------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,14 +3,11 @@ puzzle-draw =========== -puzzle-draw is a library for drawing pencil puzzles using -[Diagrams][diagrams]. It aims to provide a utility layer on top of -Diagrams to help with drawing arbitrary puzzles, as well as supporting -several specific puzzle types directly. In addition, it includes -functionality for parsing puzzle data from a YAML file format. - -See [puzzle-draw-cmdline][cmdline] for a command line tool that -uses this. +puzzle-draw is a library and command-line tool for drawing pencil +puzzles using [Diagrams][diagrams]. It aims to provide a utility layer +on top of Diagrams to help with drawing arbitrary puzzles, as well as +supporting several specific puzzle types directly. In addition, it +includes functionality for parsing puzzle data from a YAML file format. Examples -------- @@ -48,11 +45,59 @@ ..X... ``` +There is a demo web application at [demo] that provides some more +examples and that can be used to generate SVG images from such +puzzle descriptions. + Or see a [puzzle set][twentyfour] that covers the puzzle types -that are supported currently. +that are supported as of 2014-05. -[travis]: http://travis-ci.org/robx/puzzle-draw -[cmdline]: http://github.com/robx/puzzle-draw-cmdline -[liarslither]: http://maybepuzzles.wordpress.com/types/liar-slither-link/ -[twentyfour]: http://maybepuzzles.wordpress.com/2014/03/29/puzzle-set-24-hour-marathon/ +Installing +---------- + +This is a brief overview of how to install the command line tool. +You'll need to get a Haskell environment, by installing the +[Haskell Platform][platform]. Then install `puzzle-draw` with cabal: + +``` +$ cabal install puzzle-draw +``` + +This will compile puzzle-draw against the SVG backend, and install +a binary `drawpuzzle` that formats puzzles to SVG. Alternatively, +you can compile against the Cairo backend by passing `-fcairo`: + +``` +$ cabal install -fcairo puzzle-draw +``` + +This will enable PDF and PNG output. Be warned that getting Cairo +installed can be tricky on non-Linux platforms. + +Running +------- + +As an example, suppose the Liar Slitherlink puzzle description above +is copied into a file `slitherliar.pzl`. + +``` +$ drawpuzzle slitherliar.pzl +``` + +This will generate two files `slitherliar.svg` and `slitherliar-sol.svg`, +containing the puzzle and solved puzzle, respectively. Run + +``` +$ drawpuzzle -h +``` + +to see some command line options that allow modifying the program's +behaviour, e.g., choosing the output format. + +[travis]: https://travis-ci.org/robx/puzzle-draw +[cmdline]: https://github.com/robx/puzzle-draw-cmdline +[liarslither]: https://maybepuzzles.wordpress.com/types/liar-slither-link/ +[twentyfour]: https://maybepuzzles.wordpress.com/2014/03/29/puzzle-set-24-hour-marathon/ [diagrams]: http://projects.haskell.org/diagrams/ +[demo]: https://puzzle-draw-demo.herokuapp.com +[platform]: https://www.haskell.org/platform/ diff --git a/data/fonts/gen-light.svg b/data/fonts/gen-light.svg new file mode 100644 --- /dev/null +++ b/data/fonts/gen-light.svg @@ -0,0 +1,419 @@ + + + + +Created by FontForge 20120731 at Thu Nov 6 05:54:01 2014 + By Orthosie Webhosting +Gen Bold is a font by Alfredo Marco Pradil, designed in 2014. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/puzzle-draw.cabal b/puzzle-draw.cabal --- a/puzzle-draw.cabal +++ b/puzzle-draw.cabal @@ -1,24 +1,30 @@ name: puzzle-draw -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Creating graphics for pencil puzzles. -description: puzzle-draw is a library for drawing pencil puzzles - using Diagrams. It aims to provide a utility layer - on top of Diagrams to help with drawing arbitrary - puzzles, as well as supporting several specific - puzzle types directly. In addition, it includes - functionality for parsing puzzle data from a - YAML file format. +description: puzzle-draw is a library and tool for drawing pencil + puzzles using Diagrams. It aims to provide a utility + layer on top of Diagrams to help with drawing arbitrary + puzzles, and to support several specific puzzles types + In addition, it includes functionality for parsing + puzzle data from a YAML file format. license: MIT license-file: LICENSE author: Robert Vollmert maintainer: rfvollmert@gmail.com category: Graphics build-type: Simple -Extra-source-files: README.md, CHANGES.md +extra-source-files: README.md, CHANGES.md +data-files: data/fonts/*.svg cabal-version: >=1.8 -Source-repository head + +source-repository head type: git location: http://github.com/robx/puzzle-draw.git + +flag cairo + description: Build against Cairo backend + default: False + library exposed-modules: Data.Puzzles.Grid Data.Puzzles.GridShape @@ -38,33 +44,62 @@ Diagrams.Puzzles.PuzzleGrids Diagrams.Puzzles.PuzzleTypes Diagrams.Puzzles.Draw - build-depends: base >= 4.2 && < 4.8, - diagrams-lib >= 1.1 && < 1.2, - parsec >= 3.1 && < 3.2, - yaml >= 0.8.4 && < 0.9, - aeson >= 0.7 && < 0.8, - unordered-containers >= 0.2 && < 0.3, - containers >= 0.5 && < 0.6, - hashable >= 1.2 && < 1.3, - text >= 1.1 && < 1.2, - SVGFonts >= 1.4 && < 1.5, - vector-space >= 0.8 + Diagrams.Puzzles.CmdLine + -- For access to the font files in the data directory. + other-modules: Paths_puzzle_draw + build-depends: base >= 4.2 && < 5, + diagrams-lib >= 1.2, + parsec >= 3.1, + yaml >= 0.8.4, + aeson >= 0.7, + unordered-containers >= 0.2, + containers >= 0.5, + hashable >= 1.2, + text >= 1.1, + SVGFonts >= 1.4, + vector-space >= 0.8, + mtl >= 2.1, + optparse-applicative >= 0.7, + filepath >= 1.3 + if flag(cairo) + cpp-options: "-DCAIRO" + build-depends: diagrams-cairo >= 1.1 + else + build-depends: diagrams-svg >= 1.1 hs-source-dirs: src ghc-options: -Wall +executable drawpuzzle + main-is: drawpuzzle.hs + hs-source-dirs: src/tools + build-depends: base >= 4.2, + puzzle-draw, + diagrams-lib >= 1.2, + yaml >= 0.8.4, + optparse-applicative >= 0.7, + aeson >= 0.7, + filepath >= 1.3 + if flag(cairo) + cpp-options: "-DCAIRO" + build-depends: diagrams-cairo >= 1.1 + else + build-depends: diagrams-svg >= 1.1 + ghc-options: -Wall + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: tests.hs - build-depends: base >= 4.2 && < 4.8, - tasty >= 0.8 && < 0.9, - tasty-hunit >= 0.8 && < 0.9, - yaml >= 0.8.4 && < 0.9, - text >= 1.1 && < 1.2, - deepseq >= 1.3 && < 1.4, - blaze-svg >= 0.3 && < 0.4, - diagrams-lib >= 1.1 && < 1.2, - diagrams-svg >= 1.0 && < 1.1, - bytestring >= 0.10 && < 0.11, + build-depends: base >= 4.2, + tasty >= 0.8, + tasty-hunit >= 0.8, + yaml >= 0.8.4, + text >= 1.1, + deepseq >= 1.3, + containers >= 0.5, + blaze-svg >= 0.3, + diagrams-lib >= 1.2, + diagrams-svg >= 1.1, + bytestring >= 0.10, puzzle-draw ghc-options: -Wall 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,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} -- | -- Helpers to string together parser and renderer by puzzle type. @@ -22,6 +23,7 @@ import Text.Puzzles.Puzzle import Diagrams.Puzzles.Draw +import Diagrams.Puzzles.Lib import Data.Puzzles.PuzzleTypes import qualified Text.Puzzles.PuzzleTypes as R @@ -35,7 +37,7 @@ -- | @handle h t@ composes the parser and renderer for the puzzle -- type @t@ with the handler @h@. -handle :: (Backend b R2, Renderable (Path R2) b) => +handle :: Backend' b => PuzzleHandler b a -> PuzzleType -> a handle f LITS = f R.lits D.lits handle f LITSPlus = f R.litsplus D.litsplus @@ -59,13 +61,15 @@ handle f Compass = f R.compass D.compass handle f BoxOf2Or3 = f R.boxof2or3 D.boxof2or3 handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers -handle f CountNumbers = f R.countnumbers D.countnumbers +handle f MeanderingNumbers = f R.meanderingnumbers D.meanderingnumbers handle f Tapa = f R.tapa D.tapa handle f JapaneseSums = f R.japanesesums D.japanesesums handle f Coral = f R.coral D.coral handle f MaximalLengths = f R.maximallengths D.maximallengths handle f PrimePlace = f R.primeplace D.primeplace handle f Labyrinth = f R.labyrinth D.labyrinth +handle f Bahnhof = f R.bahnhof D.bahnhof +handle f Cave = f R.cave D.cave -- | Handler that parses a puzzle from a YAML value, and renders. drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2)) @@ -89,7 +93,7 @@ -> Parser (Diagram b R2, Maybe (Diagram b R2))) drawPuzzleMaybeSol (pp, ps) (dp, ds) (p, s) = do p' <- pp p - s' <- traverse ps $ s + s' <- traverse ps s let mps = case s' of Nothing -> Nothing Just s'' -> Just (p', s'') return (dp p', ds <$> mps) @@ -111,7 +115,7 @@ return $ ds (p', s') -- | Like 'drawSolution'', but renders puzzle and solution in example layout. -drawExample' :: (Backend b R2, Renderable (Path R2) b) => +drawExample' :: Backend' b => PuzzleHandler b ((Value, Maybe Value) -> Parser (Diagram b R2)) drawExample' (pp, ps) (dp, ds) (p, ms) = do p' <- pp p 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 @@ -6,6 +6,8 @@ type Clue a = Maybe a data MasyuPearl = MWhite | MBlack + deriving (Eq, Show) + type MasyuClue = Clue MasyuPearl type IntClue = Clue Int @@ -50,14 +52,17 @@ data Shade = Shade Bool Bool deriving Show -data KropkiDot = None | Black | White +data KropkiDot = KNone | KBlack | KWhite deriving Show newtype TapaClue = TapaClue [Int] deriving Show -data JapVal = JapBlack | JapInt Int - deriving Show - -- | Diagonal marking for Prime Place: forward diag?, backward diag? newtype PrimeDiag = PrimeDiag (Bool, Bool) + +data Black = Black + +data Crossing = Crossing + +type BahnhofClue = Either Int Crossing diff --git a/src/Data/Puzzles/Grid.hs b/src/Data/Puzzles/Grid.hs --- a/src/Data/Puzzles/Grid.hs +++ b/src/Data/Puzzles/Grid.hs @@ -6,7 +6,7 @@ import Data.Maybe import qualified Data.Map as Map -import Data.Foldable (Foldable, fold) +import Data.Foldable (Foldable, foldMap) import Data.Traversable (Traversable, traverse) import Control.Applicative ((<$>)) import Data.VectorSpace @@ -21,6 +21,7 @@ , contents :: Map.Map (Cell s) a} -> Grid s a deriving instance (Show a, Show s, GridShape s) => Show (Grid s a) +deriving instance (Eq s, Eq (Cell s), Eq a) => Eq (Grid s a) -- | Standard square grid. type SGrid = Grid Square @@ -39,12 +40,12 @@ fmap f (Grid s m) = Grid s (fmap f m) instance Foldable (Grid s) where - fold (Grid _ m) = fold m + foldMap f (Grid _ m) = foldMap f m instance Traversable (Grid s) where - traverse f (Grid s m) = Grid s <$> (traverse f m) + traverse f (Grid s m) = Grid s <$> traverse f m -filterG :: (a -> Bool) -> (Grid s a) -> (Grid s a) +filterG :: (a -> Bool) -> Grid s a -> Grid s a filterG p (Grid s m) = Grid s (Map.filter p m) -- | Initialize a square grid from a list of lists. The grid @@ -63,7 +64,7 @@ size = GS.size . shape cells :: GridShape s => Grid s a -> [Cell s] -cells = GS.cells . shape +cells = Map.keys . contents inBounds :: (GridShape s, Eq (Cell s)) => Grid s a -> Cell s -> Bool inBounds g c = c `elem` cells g @@ -77,17 +78,46 @@ values :: GridShape s => Grid s a -> [(Cell s, a)] values (Grid _ m) = Map.toList m --- | The inner edges of a grid that separate unequal cells. -borders :: Eq a => Grid Square a -> [Edge] -borders g = [ E p V | p <- vborders ] ++ [ E p H | p <- hborders ] +edgesGen :: (a -> a -> Bool) -> (a -> Bool) -> Grid Square a -> [Edge] +edgesGen p n g = [ E pt V | pt <- vedges ] ++ [ E pt H | pt <- hedges ] where - borders' f (sx, sy) = [ (x + 1, y) | x <- [0 .. sx - 2] - , y <- [0 .. sy - 1] - , f (x, y) /= f (x + 1, y) ] - vborders = borders' (g !) (size g) - hborders = map swap $ borders' ((g !) . swap) (swap . size $ g) + edges' f (sx, sy) = [ (x + 1, y) | x <- [-1 .. sx - 1] + , y <- [-1 .. sy] + , p' (f (x, y)) (f (x + 1, y)) ] + + vedges = edges' id (size g) + hedges = map swap $ edges' swap (swap . size $ g) swap (x, y) = (y, x) + p' c d = p'' (Map.lookup c (contents g)) + (Map.lookup d (contents g)) + p'' (Just e) (Just f) = p e f + p'' (Just e) Nothing = n e + p'' Nothing (Just e) = n e + p'' _ _ = False +edgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] +edgesP p g = edgesGen p (const False) g + +dualEdgesP :: (a -> a -> Bool) -> Grid Square a -> [Edge] +dualEdgesP p g = [ E pt H | pt <- hedges ] ++ + [ E pt V | pt <- vedges ] + where + edges' f (sx, sy) = [ (x, y) | x <- [0 .. sx - 2] + , y <- [0 .. sy - 1] + , p' (f (x, y)) (f (x + 1, y)) ] + + hedges = edges' id (size g) + vedges = map swap $ edges' swap (swap . size $ g) + swap (x, y) = (y, x) + p' c d = p'' (Map.lookup c (contents g)) + (Map.lookup d (contents g)) + p'' (Just e) (Just f) = p e f + p'' _ _ = False + +-- | The inner edges of a grid that separate unequal cells. +borders :: Eq a => Grid Square a -> [Edge] +borders = edgesP (/=) + -- | Clues along the outside of a square grid. data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] } deriving (Show, Eq) @@ -96,18 +126,35 @@ fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t) outsideSize :: OutsideClues a -> (Int, Int) -outsideSize (OC l _ _ t) = (length t, length l) +outsideSize (OC l r b t) = ( max (length t) (length b) + , max (length l) (length r) + ) +data OutsideClue a = OClue + { ocBase :: (Int, Int) + , ocDir :: (Int, Int) + , ocValue :: a + } + +instance Functor OutsideClue where + fmap f (OClue b d x) = OClue b d (f x) + +outsideClueList :: OutsideClues a -> [OutsideClue a] +outsideClueList o@(OC l r b t) = + concat + [ zipWith (\ y c -> OClue (0,y) (-1, 0) c) [0..h-1] l + , zipWith (\ y c -> OClue (w-1,y) ( 1, 0) c) [0..h-1] r + , zipWith (\ x c -> OClue (x,0) ( 0,-1) c) [0..w-1] b + , zipWith (\ x c -> OClue (x,h-1) ( 0, 1) c) [0..w-1] t + ] + where + (w, h) = outsideSize o + -- | Convert outside clues to association list mapping coordinate to value. outsideClues :: OutsideClues (Maybe a) -> [((Int, Int), a)] -outsideClues o@(OC l r b t) = mapMaybe liftMaybe . concat $ - [ zipWith (\ y c -> ((-1, y), c)) [0..h-1] l - , zipWith (\ y c -> (( w, y), c)) [0..h-1] r - , zipWith (\ x c -> (( x,-1), c)) [0..w-1] b - , zipWith (\ x c -> (( x, h), c)) [0..w-1] t - ] +outsideClues = mapMaybe (liftMaybe . toCell) . outsideClueList where - (w, h) = outsideSize o + toCell (OClue (bx, by) (dx, dy) v) = ((bx + dx, by + dy), v) liftMaybe (p, Just x) = Just (p, x) liftMaybe (_, Nothing) = Nothing 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 @@ -25,9 +25,9 @@ -- The bottom-left corner is vertex (0, 0), the bottom-left -- cell is cell (0, 0). data Square = Square !Int !Int - deriving Show + deriving (Show, Eq) -squareNeighbours :: [(Int, Int)] -> Square -> (Cell Square) -> [Cell Square] +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 @@ -74,7 +74,7 @@ -- | The edge between two neighbouring cells, with the first cell -- on the left. -orientedEdge :: (Cell Square) -> (Cell Square) -> (Edge' (Vertex Square)) +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 @@ -97,4 +97,4 @@ 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 + newin = map (orientedEdge c) . filter (c >=) $ ni 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 @@ -4,8 +4,9 @@ -- List of specific puzzle types. module Data.Puzzles.PuzzleTypes ( - PuzzleType(..), - lookupType, + PuzzleType(..) + , lookupType + , typeNames ) where import Data.Tuple (swap) @@ -33,13 +34,15 @@ | Compass | BoxOf2Or3 | AfternoonSkyscrapers - | CountNumbers + | MeanderingNumbers | Tapa | JapaneseSums | Coral | MaximalLengths | PrimePlace | Labyrinth + | Bahnhof + | Cave deriving (Show, Eq) typeNames :: [(PuzzleType, String)] @@ -65,13 +68,15 @@ , (Compass, "compass") , (BoxOf2Or3, "boxof2or3") , (AfternoonSkyscrapers, "afternoonskyscrapers") - , (CountNumbers, "countnumbers") + , (MeanderingNumbers, "meanderingnumbers") , (Tapa, "tapa") , (JapaneseSums, "japanesesums") , (Coral, "coral") , (MaximalLengths, "maximallengths") , (PrimePlace, "primeplace") , (Labyrinth, "magiclabyrinth") + , (Bahnhof, "bahnhof") + , (Cave, "cave") ] -- | Look up a puzzle type by name. diff --git a/src/Data/Puzzles/Pyramid.hs b/src/Data/Puzzles/Pyramid.hs --- a/src/Data/Puzzles/Pyramid.hs +++ b/src/Data/Puzzles/Pyramid.hs @@ -107,23 +107,23 @@ let (ks, cs) = unzip kcs in return (ks, c:cs) pkropki :: GenParser Char st KropkiDot -pkropki = (char '*' >> return Black) - <|> (char 'o' >> return White) - <|> (char ' ' >> return None) +pkropki = (char '*' >> return KBlack) + <|> (char 'o' >> return KWhite) + <|> (char ' ' >> return KNone) toParser :: GenParser a () b -> [a] -> Yaml.Parser b toParser p v = case parse p "(unknown)" v of Left e -> fail (show e) Right x -> pure x instance FromJSON Pyramid where - parseJSON (String t) = Pyr <$> (mapM (toParser prow . T.unpack) $ T.lines t) + parseJSON (String t) = Pyr <$> mapM (toParser prow . T.unpack) (T.lines t) parseJSON _ = empty instance FromJSON RowKropkiPyramid where - parseJSON (String t) = KP <$> (mapM (toParser pkropkirow . T.unpack) $ T.lines t) + parseJSON (String t) = KP <$> mapM (toParser pkropkirow . T.unpack) (T.lines t) parseJSON _ = empty instance FromJSON PyramidSol where parseJSON (String t) = PyramidSol <$> - (mapM (toParser pplainrow . T.unpack) $ T.lines t) + mapM (toParser pplainrow . T.unpack) (T.lines t) parseJSON _ = empty diff --git a/src/Diagrams/Puzzles/CmdLine.hs b/src/Diagrams/Puzzles/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Puzzles/CmdLine.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts, CPP #-} + +module Diagrams.Puzzles.CmdLine + ( B + , renderToFile + , RenderOpts(..) + , formats + , checkFormat + , checkType + , exitErr + , readPuzzle + ) + where + +import Diagrams.Prelude hiding (value, option, (<>), Result) + +#ifdef CAIRO +import Diagrams.Backend.Cairo (B, renderCairo) +#else +import Diagrams.Backend.SVG (B, renderSVG) +#endif + +import Text.Puzzles.Puzzle +import Data.Puzzles.PuzzleTypes + +import System.Exit + +import Control.Monad (unless) +import qualified Data.Yaml as Y + +data RenderOpts = RenderOpts { _file :: FilePath, _w :: Double } + +renderB :: FilePath -> SizeSpec2D -> Diagram B R2 -> IO () +renderB = +#ifdef CAIRO + renderCairo +#else + renderSVG +#endif + +renderToFile :: RenderOpts -> Diagram B R2 -> IO () +renderToFile ropts = renderB (_file ropts) (Width $ _w ropts) + +formats :: [String] +#ifdef CAIRO +formats = ["png", "svg", "ps", "pdf"] +#else +formats = ["svg"] +#endif + +checkFormat :: String -> IO () +checkFormat f = unless (f `elem` formats) $ + exitErr $ "unknown format: " ++ f + +checkType :: Maybe String -> IO PuzzleType +checkType mt = do + t <- maybe errno return mt + maybe (errunk t) return (lookupType t) + where + errno = exitErr "no puzzle type given" + errunk t = exitErr $ "unknown puzzle type: " ++ t + +readPuzzle :: FilePath -> IO (Either Y.ParseException TypedPuzzle) +readPuzzle = Y.decodeFileEither + +exitErr :: String -> IO a +exitErr e = putStrLn e >> exitFailure diff --git a/src/Diagrams/Puzzles/Draw.hs b/src/Diagrams/Puzzles/Draw.hs --- a/src/Diagrams/Puzzles/Draw.hs +++ b/src/Diagrams/Puzzles/Draw.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Draw ( PuzzleSol, @@ -25,7 +27,7 @@ -- | Optionally render the puzzle, its solution, or a side-by-side -- example with puzzle and solution. -draw :: (Backend b R2, Renderable (Path R2) b) => +draw :: Backend' b => PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2) draw (p, ms) = fmap (bg white) . d where @@ -49,10 +51,10 @@ wpix = round (gridresd * w) :: Int -- grid square size 40px wpt = cmtopoint (0.8 * w) -- grid square size 0.8cm -alignPixel :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -> Diagram b R2 +alignPixel :: Backend' b => Diagram b R2 -> Diagram b R2 alignPixel = scale (1/gridresd) . align' . scale gridresd where - align' d = maybe id grow (getCorners $ boundingBox d) $ d + align' d = maybe id grow (getCorners $ boundingBox d) d grow (bl, tr) = mappend $ phantoml (nudge bl False) (nudge tr True) nudge p dir = let (px, py) = unp2 p in p2 (nudge' px dir, nudge' py dir) nudge' x True = fromIntegral (ceiling (x - 0.5) :: Int) + 0.5 @@ -60,6 +62,6 @@ phantoml p q = phantom' $ p ~~ q -- | Add a phantom border of the given width around a diagram. -border :: (Backend b R2, Renderable (Path R2) b) => Double -> Diagram b R2 -> Diagram b R2 +border :: Backend' b => Double -> Diagram b R2 -> Diagram b R2 border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX) . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY) diff --git a/src/Diagrams/Puzzles/Elements.hs b/src/Diagrams/Puzzles/Elements.hs --- a/src/Diagrams/Puzzles/Elements.hs +++ b/src/Diagrams/Puzzles/Elements.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} -- | Module: Diagrams.TwoD.Puzzles.Elements -- @@ -17,14 +20,14 @@ import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Grid -pearl :: (Renderable (Path R2) b, Backend b R2) => +pearl :: Backend' b => MasyuPearl -> Diagram b R2 -pearl m = circle 0.35 # lw 0.05 # fc (c m) +pearl m = circle 0.35 # lwG 0.05 # fc (c m) where c MWhite = white c MBlack = black -smallPearl :: (Renderable (Path R2) b, Backend b R2) => +smallPearl :: Backend' b => MasyuPearl -> Diagram b R2 smallPearl = scale 0.4 . pearl @@ -41,13 +44,13 @@ cross = ur <> dr -- | Draw a cross. -drawCross :: Renderable (Path R2) b => Diagram b R2 -drawCross = stroke cross # scale 0.8 # lw edgewidth +drawCross :: Backend' b => Diagram b R2 +drawCross = stroke cross # scale 0.8 # lwG edgewidth -- | Draw a Compass clue. -drawCompassClue :: (Renderable (Path R2) b, Backend b R2) => +drawCompassClue :: Backend' b => CompassC -> Diagram b R2 -drawCompassClue (CC n e s w) = texts <> stroke cross # lw onepix +drawCompassClue (CC n e s w) = texts <> stroke cross # lwG onepix where tx Nothing _ = mempty tx (Just x) v = text' (show x) # scale 0.5 # translate (r2 v) texts = mconcat . zipWith tx [n, e, s, w] $ @@ -56,72 +59,72 @@ -- | Draw a thermometer, given by a list of bottom-left corners -- of square cells. -thermo :: Renderable (Path R2) b => [P2] -> QDiagram b R2 Any +thermo :: Backend' b => [P2] -> QDiagram b R2 Any thermo vs@(v:_) = (bulb `atop` line) # col # translate (r2 (0.5, 0.5)) where bulb = circle 0.4 # moveTo v line = strokeLocLine (fromVertices vs) - # lw 0.55 # lineCap LineCapSquare + # lwG 0.55 # lineCap LineCapSquare col = lc gr . fc gr gr = blend 0.6 white black thermo [] = error "invalid empty thermometer" -- | Draw a list of thermometers, given as lists of @(Int, Int)@ cell -- coordinates. -drawThermos :: Renderable (Path R2) b => [Thermometer] -> QDiagram b R2 Any +drawThermos :: Backend' b => [Thermometer] -> QDiagram b R2 Any drawThermos = mconcat . map (thermo . map p2i) -- | @drawTight d t@ draws the tight-fit value @t@, using @d@ to -- draw the components. -drawTight :: (Renderable (Path R2) b, Backend b R2) => +drawTight :: Backend' b => (a -> Diagram b R2) -> Tightfit a -> Diagram b R2 drawTight d (Single x) = d x -drawTight d (UR x y) = stroke ur # lw onepix +drawTight d (UR x y) = stroke ur # lwG onepix <> d x # scale s # translate (r2 (-t,t)) <> d y # scale s # translate (r2 (t,-t)) where t = 1/5 s = 2/3 -drawTight d (DR x y) = stroke dr # lw onepix +drawTight d (DR x y) = stroke dr # lwG onepix <> d x # scale s # translate (r2 (-t,-t)) <> d y # scale s # translate (r2 (t,t)) where t = 1/5 s = 2/3 -- | Stack the given words, left-justified. -stackWords :: (Backend b R2, Renderable (Path R2) b) => [String] -> QDiagram b R2 Any +stackWords :: Backend' b => [String] -> QDiagram b R2 Any stackWords = vcat' with {_sep = 0.1} . scale 0.8 . map (alignL . text') -- | Mark a word in a grid of letters. -drawMarkedWord :: (Renderable (Path R2) b) => MarkedWord -> QDiagram b R2 Any -drawMarkedWord (MW s e) = lw onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t +drawMarkedWord :: Backend' b => MarkedWord -> QDiagram b R2 Any +drawMarkedWord (MW s e) = lwG onepix . stroke $ expandTrail' with {_expandCap = LineCapRound} 0.4 t where t = fromVertices [p2i s, p2i e] # translate (r2 (1/2,1/2)) -- | Apply 'drawMarkedWord' to a list of words. -drawMarkedWords :: (Renderable (Path R2) b) => [MarkedWord] -> QDiagram b R2 Any +drawMarkedWords :: Backend' b => [MarkedWord] -> QDiagram b R2 Any drawMarkedWords = mconcat . map drawMarkedWord -- | Draw a slalom clue. -drawSlalomClue :: (Show a, Renderable (Path R2) b, Backend b R2) => +drawSlalomClue :: (Show a, Backend' b) => a -> Diagram b R2 drawSlalomClue x = text' (show x) # scale 0.75 - <> circle 0.4 # fc white # lw onepix + <> circle 0.4 # fc white # lwG onepix -- | Draw text. Shouldn't be more than two characters or so to fit a cell. -drawText :: (Backend b R2, Renderable (Path R2) b) => String -> QDiagram b R2 Any +drawText :: Backend' b => String -> QDiagram b R2 Any drawText = text' -- | Draw an @Int@. -drawInt :: (Renderable (Path R2) b, Backend b R2) => +drawInt :: Backend' b => Int -> Diagram b R2 drawInt s = drawText (show s) -- | Draw a character. -drawChar :: (Renderable (Path R2) b, Backend b R2) => +drawChar :: Backend' b => Char -> Diagram b R2 drawChar c = drawText [c] -- | Stack a list of words into a unit square. Scaled such that at least -- three words will fit. -drawWords :: (Renderable (Path R2) b, Backend b R2) => +drawWords :: Backend' b => [String] -> Diagram b R2 drawWords ws = spread (-1.0 *^ unitY) (map (centerXY . scale 0.4 . drawText) ws) @@ -129,22 +132,22 @@ -- | Fit a line drawing into a unit square. -- For example, a Curve Data clue. -drawCurve :: Renderable (Path R2) b => [Edge] -> Diagram b R2 -drawCurve = lw onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) +drawCurve :: Backend' b => [Edge] -> Diagram b R2 +drawCurve = lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) -- | Draw a shadow in the style of Afternoon Skyscrapers. -drawShade :: Renderable (Path R2) b => Shade -> Diagram b R2 +drawShade :: Backend' b => Shade -> Diagram b R2 drawShade (Shade s w) = (if s then south else mempty) <> (if w then west else mempty) where shape = translate (r2 (-1/2, -1/2)) . fromVertices . map p2 $ [ (0, 0), (1/4, 1/4), (1, 1/4), (1, 0), (0, 0) ] - south = strokeLocLoop shape # lw 0 # fc gray + south = strokeLocLoop shape # lwG 0 # fc gray west = reflectAbout (p2 (0, 0)) (r2 (1, 1)) south -- | Draws the digits of a tapa clue, ordered -- left to right, top to bottom. -drawTapaClue :: (Backend b R2, Renderable (Path R2) b) => +drawTapaClue :: Backend' b => TapaClue -> Diagram b R2 drawTapaClue (TapaClue [x]) = drawInt x drawTapaClue (TapaClue xs) = fit 0.8 @@ -159,11 +162,17 @@ p' 1 = error "singleton clues handled separately" p' _ = error "invalid tapa clue" -drawPrimeDiag :: (Backend b R2, Renderable (Path R2) b) => +drawPrimeDiag :: Backend' b => PrimeDiag -> Diagram b R2 -drawPrimeDiag (PrimeDiag d) = stroke p # lw (3 * onepix) # lc (blend 0.5 gray white) +drawPrimeDiag (PrimeDiag d) = stroke p # lwG (3 * onepix) # lc (blend 0.5 gray white) where p = case d of (False, False) -> mempty (True, False) -> ur (False, True) -> dr (True, True) -> ur <> dr + +drawCrossing :: Backend' b => Crossing -> Diagram b R2 +drawCrossing = const $ drawChar '+' + +drawBahnhofClue :: Backend' b => BahnhofClue -> Diagram b R2 +drawBahnhofClue = either drawInt drawCrossing diff --git a/src/Diagrams/Puzzles/Grid.hs b/src/Diagrams/Puzzles/Grid.hs --- a/src/Diagrams/Puzzles/Grid.hs +++ b/src/Diagrams/Puzzles/Grid.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Grid where @@ -14,11 +15,11 @@ import Diagrams.Puzzles.Widths -- | Draw a small black dot with no envelope. -dot :: (Renderable (Path R2) b, Backend b R2) => Diagram b R2 +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 R2, Renderable (Path R2) b) => +slithergrid :: Backend' b => Size -> Diagram b R2 slithergrid (x, y) = hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot @@ -41,36 +42,39 @@ fence' n l = fence (map fromIntegral [0..n]) (fromIntegral l) -- | Draw a frame around the outside of a rectangle. -outframe :: Renderable (Path R2) b => Size -> Diagram b R2 -outframe (w, h) = strokePointLoop r # lw fw +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 = framewidthfactor * gridwidth + fw = f * gridwidth e = fw / 2 - gridwidth / 2 r = [(-e, -e), (wd + e, -e), (wd + e, hd + e), (-e, hd + e)] +outframe :: Backend' b => Size -> Diagram b R2 +outframe = outframe' framewidthfactor + -- | Draw a square grid, applying the given style to the grid lines. -grid' :: (Backend b R2, Renderable (Path R2) b) => +grid' :: Backend' b => (Diagram b R2 -> Diagram b R2) -> Size -> Diagram b R2 grid' gridstyle s = outframe s - <> stroke (gridlines s) # lw gridwidth # gridstyle + <> stroke (gridlines s) # lwG gridwidth # gridstyle -- | Draw a square grid with default grid line style. -grid :: (Backend b R2, Renderable (Path R2) b) => +grid :: Backend' b => Size -> Diagram b R2 grid = grid' id -- | Draw a square grid with thin frame. -plaingrid :: (Backend b R2, Renderable (Path R2) b) => +plaingrid :: Backend' b => Size -> Diagram b R2 -plaingrid s = stroke (fullgridlines s) # lw gridwidth +plaingrid s = stroke (fullgridlines s) # lwG gridwidth -bgdashing :: (Semigroup a, HasStyle a) => +bgdashingG :: (Semigroup a, HasStyle a, V a ~ R2) => [Double] -> Double -> Colour Double -> a -> a -bgdashing ds offs c x = x # dashing ds offs <> x # lc c +bgdashingG ds offs c x = x # dashingG ds offs <> x # lc c dashes :: [Double] dashes = [5 / 40, 3 / 40] @@ -78,14 +82,17 @@ dashoffset :: Double dashoffset = 2.5 / 40 +gridDashing :: (Semigroup a, HasStyle a, V a ~ R2) => a -> a +gridDashing = bgdashingG dashes dashoffset white' + where + white' = blend 0.95 white black + -- | Draw a square grid with dashed grid lines. The gaps -- between dashes are off-white to aid in using filling -- tools. -dashedgrid :: (Backend b R2, Renderable (Path R2) b) => +dashedgrid :: Backend' b => Size -> Diagram b R2 -dashedgrid = grid' $ bgdashing dashes dashoffset white' - where - white' = blend 0.95 white black +dashedgrid = grid' gridDashing edgePath :: Edge' (Vertex Square) -> Path R2 edgePath (E' v R) = p2i v ~~ p2i (v ^+^ (1,0)) @@ -96,13 +103,13 @@ irregularGridPaths :: SGrid a -> (Path R2, Path R2) irregularGridPaths (Grid _ m) = (toPath outer, toPath inner) where - (outer, inner) = edges (M.keysSet m) (flip M.member m) + (outer, inner) = edges (M.keysSet m) (`M.member` m) toPath = mconcat . map edgePath -irregularGrid :: (Backend b R2, Renderable (Path R2) b) => +irregularGrid :: Backend' b => SGrid a -> Diagram b R2 -irregularGrid g = stroke outer # lw (3 * gridwidth) # lineCap LineCapSquare <> - stroke inner # lw gridwidth +irregularGrid g = stroke outer # lwG (3 * gridwidth) # lineCap LineCapSquare <> + stroke inner # lwG gridwidth where (outer, inner) = irregularGridPaths g @@ -133,42 +140,83 @@ dualEdge :: Edge -> Path R2 dualEdge = translate (r2 (1/2, 1/2)) . edge -edgeStyle :: HasStyle a => a -> a -edgeStyle = lineCap LineCapSquare . lw edgewidth +edgeStyle :: (HasStyle a, V a ~ R2) => a -> a +edgeStyle = lineCap LineCapSquare . lwG edgewidth -thinEdgeStyle :: HasStyle a => a -> a -thinEdgeStyle = lineCap LineCapSquare . lw onepix +thinEdgeStyle :: (HasStyle a, V a ~ R2) => a -> a +thinEdgeStyle = lineCap LineCapSquare . lwG onepix -drawEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2 +drawEdges :: Backend' b => [Edge] -> Diagram b R2 drawEdges = edgeStyle . stroke . mconcat . map edge -drawDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2 +drawDualEdges :: Backend' b => [Edge] -> Diagram b R2 drawDualEdges = edgeStyle . stroke . mconcat . map dualEdge -drawThinDualEdges :: Renderable (Path R2) b => [Edge] -> Diagram b R2 +drawThinDualEdges :: Backend' b => [Edge] -> Diagram b R2 drawThinDualEdges = thinEdgeStyle . stroke . mconcat . map dualEdge -drawAreaGrid :: (Backend b R2, Renderable (Path R2) b, Eq a) => +drawAreaGrid :: (Backend' b, Eq a) => SGrid a -> Diagram b R2 drawAreaGrid = drawEdges . borders <> grid . size -fillBG :: (Backend b R2, Renderable (Path R2) b) => Colour Double -> Diagram b R2 -fillBG c = square 1 # fc c +fillBG :: Backend' b => Colour Double -> Diagram b R2 +fillBG c = square 1 # lwG onepix # fc c # lc c -shadeGrid :: (Backend b R2, Renderable (Path R2) b) => +shadeGrid :: Backend' b => SGrid (Maybe (Colour Double)) -> Diagram b R2 shadeGrid = mconcat . atCentres' . fmap (maybe mempty fillBG) -drawShadedGrid :: (Backend b R2, Renderable (Path R2) b) => +drawShadedGrid :: Backend' b => SGrid Bool -> Diagram b R2 drawShadedGrid = shadeGrid . fmap f where f True = Just gray f False = Nothing -drawAreaGridGray :: (Backend b R2, Renderable (Path R2) b) => +drawAreaGridGray :: Backend' b => SGrid Char -> Diagram b R2 drawAreaGridGray = drawAreaGrid <> shadeGrid . fmap cols where cols c | isUpper c = Just (blend 0.1 black white) | otherwise = Nothing + +irregAreaGridX :: Backend' b => + SGrid Char -> Diagram b R2 +irregAreaGridX = irregularGrid <> drawEdges . borders <> shadeGrid . fmap cols + where + cols 'X' = Just gray + cols _ = Nothing + +-- Place a list of diagrams along a ray, with steps of size +-- @f@. +distrib :: (Transformable c, Monoid c, V c ~ R2) => + R2 -> (Int, Int) -> Double -> [c] -> c +distrib base dir f xs = + translate (0.75 *^ dir' ^+^ base) . mconcat $ + zipWith (\i d -> translate (fromIntegral i *^ dir') d) [(0 :: Int)..] xs + where + dir' = f *^ r2i dir + +outsideGen :: (Transformable c, Monoid c, V c ~ R2) => + (OutsideClue [c] -> R2) -> Double -> [OutsideClue [c]] -> c +outsideGen tobase f ocs = mconcat . map placeOC $ ocs + where + placeOC o = distrib (tobase o) (ocDir o) f (ocValue o) + +outsideCells :: (Transformable c, Monoid c, V c ~ R2) => + Double -> [OutsideClue [c]] -> c +outsideCells = outsideGen base + where + base (OClue (bx, by) (dx, dy) _) + | dx /= 0 = r2 (fromIntegral bx - 1, fromIntegral by - 1/2) + | dy /= 0 = r2 (fromIntegral bx - 1/2, fromIntegral by) + | otherwise = error "invalid outside clue" + +outsideVertices :: (Transformable c, Monoid c, V c ~ R2) => + Double -> [OutsideClue [c]] -> c +outsideVertices = outsideGen base + where + base (OClue (bx, by) (dx, dy) _) + | dx /= 0 = r2 (fromIntegral bx, fromIntegral by) + | dy /= 0 = r2 (fromIntegral bx, fromIntegral by) + | otherwise = error "invalid outside clue" diff --git a/src/Diagrams/Puzzles/Lib.hs b/src/Diagrams/Puzzles/Lib.hs --- a/src/Diagrams/Puzzles/Lib.hs +++ b/src/Diagrams/Puzzles/Lib.hs @@ -1,15 +1,20 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Lib where import Diagrams.Prelude import Graphics.SVGFonts.ReadFont - import Control.Arrow ((***)) +import Paths_puzzle_draw (getDataFileName) +import System.IO.Unsafe (unsafePerformIO) + +type Backend' b = (Backend b R2, Renderable (Path R2) b) + -- | Vertical/horizontal stroked line of given length. -vline, hline :: Renderable (Path R2) b => Double -> Diagram b R2 +vline, hline :: Backend' b => Double -> Diagram b R2 vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)] hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)] @@ -23,8 +28,8 @@ vcatsep = cat' (r2 (0,1)) with {_sep = 1} -- | Collapse the envelope to a point. -smash :: Backend b R2 => QDiagram b R2 Any -> QDiagram b R2 Any -smash = withEnvelope (vrule 0 :: D R2) +smash :: Backend' b => QDiagram b R2 Any -> QDiagram b R2 Any +smash = withEnvelope (pointDiagram origin :: D R2) -- | Helper to translate by a point given as @(Int, Int)@. translatep :: (Transformable t, V t ~ R2) => (Int, Int) -> t -> t @@ -47,7 +52,7 @@ interleave (x:xs) ys = x : interleave ys xs -- | Spread diagrams evenly along the given vector. -spread :: (Backend b R2) => R2 -> [Diagram b R2] -> Diagram b R2 +spread :: Backend' b => R2 -> [Diagram b R2] -> Diagram b R2 spread v things = cat v . interleave (repeat (strut vgap)) $ things where ds = map (diameter v) things gap' = (magnitude v - sum ds) / fromIntegral (length things + 1) @@ -61,13 +66,13 @@ -- | Place the second diagram to the right of the first, aligning both -- vertically. The origin is the origin of the left diagram. -besidesL :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) => +besidesL :: (Backend' b, Semigroup m, Monoid m) => QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m besidesL a b = a ||| strutX 0.5 ||| b' where b' = b # centerY # translate (dmid a *^ unitY) -- | Variant of 'besidesL' where the origin is that of the right diagram. -besidesR :: (Semigroup m, Backend b R2, Monoid m, Renderable (Path R2) b) => +besidesR :: (Backend' b, Semigroup m, Monoid m) => QDiagram b R2 m -> QDiagram b R2 m -> QDiagram b R2 m besidesR b a = b' ||| strutX 0.5 ||| a where b' = b # centerY # translate (dmid a *^ unitY) @@ -82,17 +87,20 @@ -- | Write text that is centered both vertically and horizontally and that -- has an envelope. Sized such that single capital characters fit nicely -- into a square of size @1@. -text' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2 -text' t = stroke (textSVG' $ TextOpts t bit INSIDE_H KERN False 1 1) - # lw 0 # fc black # scale 0.8 +text' :: Backend' b => String -> Diagram b R2 +text' t = stroke (textSVG' $ TextOpts t fnt INSIDE_H KERN False 1 1) + # lwG 0 # fc black # scale 0.8 + where + fnt = outlMap . unsafePerformIO . getDataFileName + $ "data/fonts/gen-light.svg" -- text' t = text t # fontSize 0.8 # font "Helvetica" # translate (r2 (0.04, -0.07)) -- <> phantom' (textrect t) ---textrect :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2 +--textrect :: Backend' b => String -> Diagram b R2 --textrect t = rect (fromIntegral (length t) * 0.4) 0.7 # lc red ---text'' :: (Renderable (Path R2) b, Backend b R2) => String -> Diagram b R2 +--text'' :: Backend' b => String -> Diagram b R2 --text'' t = text' t `atop` textrect t -- | Variant of 'phantom' that forces the argument backend type. -phantom' :: (Backend b R2) => D R2 -> Diagram b R2 +phantom' :: Backend' b => Diagram b R2 -> Diagram b R2 phantom' = phantom diff --git a/src/Diagrams/Puzzles/PuzzleGrids.hs b/src/Diagrams/Puzzles/PuzzleGrids.hs --- a/src/Diagrams/Puzzles/PuzzleGrids.hs +++ b/src/Diagrams/Puzzles/PuzzleGrids.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.PuzzleGrids where @@ -15,82 +16,78 @@ import Diagrams.Puzzles.Widths import Diagrams.Puzzles.Elements -drawFillo :: (Backend b R2, Renderable (Path R2) b) => - SGrid (Clue Int) -> Diagram b R2 -drawFillo = drawIntClues <> dashedgrid . size - -drawClueGrid :: (Backend b R2, Renderable (Path R2) b) => +drawClueGrid :: Backend' b => SGrid (Clue Char) -> Diagram b R2 drawClueGrid = atCentres drawChar . clues <> grid . size -drawIntClues :: (Backend b R2, Renderable (Path R2) b) => +drawIntClues :: Backend' b => SGrid (Clue Int) -> Diagram b R2 drawIntClues = atCentres drawInt . clues -drawInts :: (Backend b R2, Renderable (Path R2) b) => +drawInts :: Backend' b => SGrid Int -> Diagram b R2 drawInts = atCentres drawInt . values -drawIntGrid :: (Backend b R2, Renderable (Path R2) b) => +drawIntGrid :: Backend' b => SGrid (Clue Int) -> Diagram b R2 drawIntGrid = drawIntClues <> grid . size -drawSlitherGrid :: (Backend b R2, Renderable (Path R2) b) => +drawSlitherGrid :: Backend' b => SGrid (Clue Int) -> Diagram b R2 drawSlitherGrid = atCentres drawInt . clues <> slithergrid . size -drawMasyuGrid :: (Backend b R2, Renderable (Path R2) b) => +drawMasyuGrid :: Backend' b => SGrid MasyuClue -> Diagram b R2 drawMasyuGrid = atCentres pearl . clues <> grid . size -drawCompassClues :: (Backend b R2, Renderable (Path R2) b) => +drawCompassClues :: Backend' b => SGrid CompassClue -> Diagram b R2 drawCompassClues = atCentres drawCompassClue . clues -drawCompassGrid :: (Backend b R2, Renderable (Path R2) b) => +drawCompassGrid :: Backend' b => SGrid CompassClue -> Diagram b R2 drawCompassGrid = drawCompassClues <> grid . size -sudokugrid :: (Backend b R2, Renderable (Path R2) b) => +sudokugrid :: Backend' b => SGrid a -> Diagram b R2 sudokugrid = drawEdges . sudokubordersg <> grid . size -drawWordsClues :: (Backend b R2, Renderable (Path R2) b) => +drawWordsClues :: Backend' b => SGrid (Clue [String]) -> Diagram b R2 drawWordsClues = atCentres drawWords . clues -drawTightGrid :: (Backend b R2, Renderable (Path R2) b) => +drawTightGrid :: Backend' b => (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2 drawTightGrid d g = atCentres (drawTight d) (values g) <> grid (size g) <> phantom' (stroke $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1)) where (sx, sy) = size g -drawSlalomGrid :: (Backend b R2, Renderable (Path R2) b) => +drawSlalomGrid :: Backend' b => SGrid (Clue Int) -> Diagram b R2 drawSlalomGrid g = atVertices drawSlalomClue (clues g) <> grid (w-1, h-1) where (w, h) = size g -drawSlalomDiags :: (Backend b R2, Renderable (Path R2) b) => +drawSlalomDiags :: Backend' b => SGrid SlalomDiag -> Diagram b R2 drawSlalomDiags = atCentres diag . clues . fmap Just - where diag SlalomForward = stroke ur # lw edgewidth - diag SlalomBackward = stroke dr # lw edgewidth + where diag SlalomForward = stroke ur # lwG edgewidth + diag SlalomBackward = stroke dr # lwG edgewidth -drawCrosses :: (Backend b R2, Renderable (Path R2) b) => +drawCrosses :: Backend' b => SGrid Bool -> Diagram b R2 drawCrosses = atCentres (if' drawCross mempty) . values where if' a b x = if x then a else b -outsideGrid :: (Backend b R2, Renderable (Path R2) b) => +outsideGrid :: Backend' b => OutsideClues [String] -> Diagram b R2 outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues <> grid . outsideSize -outsideIntGrid :: (Backend b R2, Renderable (Path R2) b) => +outsideIntGrid :: Backend' b => OutsideClues [Int] -> Diagram b R2 outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues <> grid . outsideSize diff --git a/src/Diagrams/Puzzles/PuzzleTypes.hs b/src/Diagrams/Puzzles/PuzzleTypes.hs --- a/src/Diagrams/Puzzles/PuzzleTypes.hs +++ b/src/Diagrams/Puzzles/PuzzleTypes.hs @@ -1,13 +1,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.PuzzleTypes ( lits, litsplus, geradeweg, fillomino, masyu, nurikabe, latintapa, sudoku, thermosudoku, pyramid, kpyramid, slither, liarslither, tightfitskyscrapers, wordloop, wordsearch, curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, countnumbers, tapa, japanesesums, - coral, maximallengths, primeplace, labyrinth + afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, + coral, maximallengths, primeplace, labyrinth, bahnhof, + cave ) where import Diagrams.Prelude hiding (Loop, coral) @@ -18,48 +21,49 @@ import qualified Diagrams.Puzzles.Pyramid as DPyr import Diagrams.Puzzles.Elements import Diagrams.Puzzles.Lib +import Diagrams.Puzzles.Widths import Data.Puzzles.Grid import Data.Puzzles.GridShape (Edge) import Data.Puzzles.Elements import qualified Data.Puzzles.Pyramid as Pyr -lits :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid +lits :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid lits = (,) drawAreaGridGray (drawAreaGrid . fst <> drawShadedGrid . snd) -litsplus :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b AreaGrid ShadedGrid +litsplus :: Backend' b => RenderPuzzle b AreaGrid ShadedGrid litsplus = lits -solstyle :: HasStyle a => a -> a -solstyle = lc (blend 0.8 black white) +solstyle :: (HasStyle a, V a ~ R2) => a -> a +solstyle = lc (blend 0.8 black white) . lwG (3 * onepix) -geradeweg :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid Loop +geradeweg :: Backend' b => RenderPuzzle b IntGrid Loop geradeweg = (,) drawIntGrid (drawIntClues . fst <> solstyle . drawDualEdges . snd <> grid . size . fst) -fillomino :: (Backend b R2, Renderable (Path R2) b) => RenderPuzzle b IntGrid IntGrid +fillomino :: Backend' b => RenderPuzzle b IntGrid (SGrid Int) fillomino = (,) - drawFillo - (drawFillo . snd) + (atCentres drawInt . clues <> dashedgrid . size) + ((atCentres drawInt . values <> drawEdges . borders <> dashedgrid . size) . snd) -masyu :: (Backend b R2, Renderable (Path R2) b) => +masyu :: Backend' b => RenderPuzzle b (SGrid (Clue MasyuPearl)) Loop masyu = (,) drawMasyuGrid (solstyle . drawDualEdges . snd <> drawMasyuGrid . fst) -nurikabe :: (Backend b R2, Renderable (Path R2) b) => +nurikabe :: Backend' b => RenderPuzzle b IntGrid ShadedGrid nurikabe = (,) drawIntGrid (drawIntGrid . fst <> drawShadedGrid . snd) -latintapa :: (Backend b R2, Renderable (Path R2) b) => +latintapa :: Backend' b => RenderPuzzle b (SGrid (Clue [String])) CharClueGrid latintapa = (,) l @@ -67,19 +71,19 @@ where l = grid . size <> drawWordsClues -sudoku :: (Backend b R2, Renderable (Path R2) b) => +sudoku :: Backend' b => RenderPuzzle b IntGrid IntGrid sudoku = (,) (drawIntClues <> sudokugrid) ((drawIntClues <> sudokugrid) . snd) -thermosudoku :: (Backend b R2, Renderable (Path R2) b) => +thermosudoku :: Backend' b => RenderPuzzle b (SGrid Int, [Thermometer]) IntGrid thermosudoku = (,) (drawInts . fst <> sudokugrid . fst <> drawThermos . snd) (drawIntClues . snd <> sudokugrid . snd <> drawThermos . snd . fst) -pyramid :: (Backend b R2, Renderable (Path R2) b) => +pyramid :: Backend' b => RenderPuzzle b Pyr.Pyramid Pyr.PyramidSol pyramid = (,) DPyr.pyramid @@ -87,7 +91,7 @@ where merge (p, q) = Pyr.mergepyramidsol p q -kpyramid :: (Backend b R2, Renderable (Path R2) b) => +kpyramid :: Backend' b => RenderPuzzle b Pyr.RowKropkiPyramid Pyr.PyramidSol kpyramid = (,) DPyr.kpyramid @@ -95,13 +99,13 @@ where merge (p, q) = Pyr.mergekpyramidsol p q -slither :: (Backend b R2, Renderable (Path R2) b) => +slither :: Backend' b => RenderPuzzle b IntGrid Loop slither = (,) drawSlitherGrid (drawSlitherGrid . fst <> solstyle . drawEdges . snd) -liarslither :: (Backend b R2, Renderable (Path R2) b) => +liarslither :: Backend' b => RenderPuzzle b IntGrid (Loop, SGrid Bool) liarslither = (,) drawSlitherGrid @@ -109,7 +113,7 @@ <> drawSlitherGrid . fst <> solstyle . drawEdges . fst . snd) -tightfitskyscrapers :: (Backend b R2, Renderable (Path R2) b) => +tightfitskyscrapers :: Backend' b => RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ())) (SGrid (Tightfit Int)) tightfitskyscrapers = (,) @@ -118,49 +122,50 @@ (atCentres drawInt . outsideClues . fst . fst <> drawTightGrid drawInt . snd) -wordgrid :: (Backend b R2, Renderable (Path R2) b) => +wordgrid :: Backend' b => SGrid (Maybe Char) -> [String] -> Diagram b R2 wordgrid g ws = stackWords ws `besidesR` drawClueGrid g -wordloop :: (Backend b R2, Renderable (Path R2) b) => +wordloop :: Backend' b => RenderPuzzle b (CharClueGrid, [String]) CharClueGrid wordloop = (,) (uncurry wordgrid) (drawClueGrid . snd) -wordsearch :: (Backend b R2, Renderable (Path R2) b) => +wordsearch :: Backend' b => RenderPuzzle b (CharClueGrid, [String]) (CharClueGrid, [MarkedWord]) wordsearch = (,) (uncurry wordgrid) (solstyle . drawMarkedWords . snd . snd <> drawClueGrid . fst . snd) -curvedata :: (Backend b R2, Renderable (Path R2) b) => +curvedata :: Backend' b => RenderPuzzle b (SGrid (Clue [Edge])) [Edge] curvedata = (,) cd ((solstyle . drawDualEdges . snd) <> cd . fst) - where cd = (atCentres drawCurve . clues <> grid . size) + where + cd = atCentres drawCurve . clues <> grid . size -doubleback :: (Backend b R2, Renderable (Path R2) b) => +doubleback :: Backend' b => RenderPuzzle b AreaGrid Loop doubleback = (,) drawAreaGridGray (solstyle . drawDualEdges . snd <> drawAreaGridGray . fst) -slalom :: (Backend b R2, Renderable (Path R2) b) => +slalom :: Backend' b => RenderPuzzle b IntGrid (SGrid SlalomDiag) slalom = (,) drawSlalomGrid (drawSlalomGrid . fst <> solstyle . drawSlalomDiags . snd) -compass :: (Backend b R2, Renderable (Path R2) b) => +compass :: Backend' b => RenderPuzzle b (SGrid (Clue CompassC)) AreaGrid compass = (,) drawCompassGrid (drawCompassClues . fst <> drawAreaGridGray . snd) -boxof2or3 :: (Backend b R2, Renderable (Path R2) b) => +boxof2or3 :: Backend' b => RenderPuzzle b (SGrid MasyuPearl, [Edge]) () boxof2or3 = (,) (atCentres smallPearl . values . fst @@ -168,19 +173,19 @@ <> drawThinDualEdges . snd) (error "boxof2or3 solution not implemented") -afternoonskyscrapers :: (Backend b R2, Renderable (Path R2) b) => +afternoonskyscrapers :: Backend' b => RenderPuzzle b (SGrid Shade) IntGrid afternoonskyscrapers = (,) (grid . size <> atCentres drawShade . values) (drawIntGrid . snd <> atCentres drawShade . values . fst) -countnumbers :: (Backend b R2, Renderable (Path R2) b) => +meanderingnumbers :: Backend' b => RenderPuzzle b AreaGrid IntGrid -countnumbers = (,) +meanderingnumbers = (,) drawAreaGrid (drawIntGrid . snd <> drawAreaGrid . fst) -tapa :: (Backend b R2, Renderable (Path R2) b) => +tapa :: Backend' b => RenderPuzzle b (SGrid TapaClue) ShadedGrid tapa = (,) tapaGrid @@ -188,23 +193,23 @@ where tapaGrid = atCentres drawTapaClue . values <> grid . size -japanesesums :: (Backend b R2, Renderable (Path R2) b) => - RenderPuzzle b (OutsideClues [Int]) (SGrid JapVal) +japanesesums :: Backend' b => + RenderPuzzle b (OutsideClues [Int]) (SGrid (Either Black Int)) japanesesums = (,) outsideIntGrid - (japcells . snd <> outsideIntGrid . fst) + (outsideIntGrid . fst <> japcells . snd) where japcells = atCentres japcell . values - japcell JapBlack = fillBG gray - japcell (JapInt x) = drawInt x + japcell (Left Black) = fillBG gray + japcell (Right x) = drawInt x -coral :: (Backend b R2, Renderable (Path R2) b) => +coral :: Backend' b => RenderPuzzle b (OutsideClues [String]) ShadedGrid coral = (,) outsideGrid - (drawShadedGrid . snd <> outsideGrid . fst) + (outsideGrid . fst <> drawShadedGrid . snd) -maximallengths :: (Backend b R2, Renderable (Path R2) b) => +maximallengths :: Backend' b => RenderPuzzle b (OutsideClues (Maybe Int)) Loop maximallengths = (,) g @@ -213,7 +218,7 @@ g = atCentres drawInt . outsideClues <> grid . outsideSize -primeplace :: (Backend b R2, Renderable (Path R2) b) => +primeplace :: Backend' b => RenderPuzzle b (SGrid PrimeDiag) (SGrid Int) primeplace = (,) g @@ -221,10 +226,32 @@ where g = irregularGrid <> atCentres drawPrimeDiag . values -labyrinth :: (Backend b R2, Renderable (Path R2) b) => +labyrinth :: Backend' b => RenderPuzzle b (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) labyrinth = (,) (atCentres drawInt . clues . fst <> g) (atCentres drawInt . clues . snd <> g . fst) where g = drawEdges . snd <> plaingrid . size . fst + +bahnhof :: Backend' b => + RenderPuzzle b (SGrid (Maybe BahnhofClue)) [Edge] +bahnhof = (,) + (atCentres drawBahnhofClue . clues <> grid . size) + (atCentres drawBahnhofStation . clues . fst + <> solstyle . drawDualEdges . snd + <> grid . size . fst) + where + drawBahnhofStation = either drawInt (const mempty) + +cave :: + (Backend b R2, Renderable (Path R2) b) => + RenderPuzzle b (SGrid (Clue Int)) ShadedGrid +cave = (,) + g + (drawEdges . edgesGen (/=) not . snd + <> drawShadedGrid . snd <> fr . fst + <> g . fst) + where + g = gridDashing . plaingrid . size <> atCentres drawInt . clues + fr gr = outframe' 8 (size gr) # lc gray diff --git a/src/Diagrams/Puzzles/Pyramid.hs b/src/Diagrams/Puzzles/Pyramid.hs --- a/src/Diagrams/Puzzles/Pyramid.hs +++ b/src/Diagrams/Puzzles/Pyramid.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Diagrams.Puzzles.Pyramid where @@ -13,35 +14,34 @@ pgray :: Colour Double pgray = blend 0.6 white black -cell :: (Backend b R2, Renderable (Path R2) b) => Bool -> Diagram b R2 -cell s = square 1 # lw onepix # if s then fc pgray else id +cell :: Backend' b => Bool -> Diagram b R2 +cell s = square 1 # lwG onepix # if s then fc pgray else id -clue :: (Backend b R2, Renderable (Path R2) b) => Maybe Int -> Diagram b R2 +clue :: Backend' b => Maybe Int -> Diagram b R2 clue Nothing = mempty clue (Just c) = text' (show c) -cellc :: (Backend b R2, Renderable (Path R2) b) => Bool -> Maybe Int -> Diagram b R2 +cellc :: Backend' b => Bool -> Maybe Int -> Diagram b R2 cellc s c = clue c `atop` cell s -row :: (Backend b R2, Renderable (Path R2) b) => Row -> Diagram b R2 +row :: Backend' b => Row -> Diagram b R2 row (R cs s) = centerX . hcat . map (cellc s) $ cs -pyramid :: (Backend b R2, Renderable (Path R2) b) => Pyramid -> Diagram b R2 +pyramid :: Backend' b => Pyramid -> Diagram b R2 pyramid = alignBL . vcat . map row . unPyr -kropki :: (Backend b R2, Renderable (Path R2) b) => KropkiDot -> Diagram b R2 -kropki None = mempty -kropki c = circle 0.1 # lw 0.03 # fc (col c) # smash - where col White = white - col Black = blend 0.98 black white - col None = error "can't reach" +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 R2, Renderable (Path R2) b) => KropkiRow -> Diagram b R2 +krow :: Backend' b => KropkiRow -> Diagram b R2 krow (KR cs s ks) = ccat dots <> ccat clues where ccat = centerX . hcat clues = map (cellc s) cs - clues' = map (cellc s) cs :: [D R2] - dots = interleave (map phantom' clues') (map kropki ks) + dots = interleave (map phantom' clues) (map kropki ks) -kpyramid :: (Backend b R2, Renderable (Path R2) b) => RowKropkiPyramid -> Diagram b R2 +kpyramid :: Backend' b => RowKropkiPyramid -> Diagram b R2 kpyramid = alignBL . vcat . map krow . unKP 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 @@ -5,14 +5,12 @@ sudoku, thermosudoku, pyramid, kpyramid, slither, liarslither, tightfitskyscrapers, wordloop, wordsearch, curvedata, doubleback, slalom, compass, boxof2or3, - afternoonskyscrapers, countnumbers, tapa, japanesesums, coral, - maximallengths, primeplace, labyrinth + afternoonskyscrapers, meanderingnumbers, tapa, japanesesums, coral, + maximallengths, primeplace, labyrinth, bahnhof, cave ) where -import Prelude hiding (sequence) - import Control.Applicative -import Control.Monad hiding (sequence) +import Control.Monad import Data.Yaml @@ -32,8 +30,8 @@ geradeweg :: ParsePuzzle (SGrid (Clue Int)) Loop geradeweg = (parseClueGrid, parseEdges) -fillomino :: ParsePuzzle IntGrid IntGrid -fillomino = (parseClueGrid, parseClueGrid) +fillomino :: ParsePuzzle IntGrid (SGrid Int) +fillomino = (parseClueGrid, parseExtGrid) masyu :: ParsePuzzle (SGrid (Clue MasyuPearl)) Loop masyu = (parseClueGrid, parseEdges) @@ -42,7 +40,8 @@ nurikabe = (parseSpacedClueGrid, parseShadedGrid) latintapa :: ParsePuzzle (SGrid (Clue [String])) (SGrid (Maybe Char)) -latintapa = ((unRG <$>) . parseJSON, parseClueGrid) +latintapa = ((unRG <$>) . parseJSON, + fmap (fmap (fmap unAlpha)) . parseClueGrid') sudoku :: ParsePuzzle IntGrid IntGrid sudoku = (parseClueGrid, parseClueGrid) @@ -120,18 +119,20 @@ afternoonskyscrapers = (parseAfternoonGrid, parseGrid) -- this should be changed to support clue numbers -countnumbers :: ParsePuzzle AreaGrid IntGrid -countnumbers = (parseGrid, parseGrid) +meanderingnumbers :: ParsePuzzle AreaGrid IntGrid +meanderingnumbers = (parseGrid, parseGrid) tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v, parseShadedGrid) -japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid JapVal) +japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid (Either Black Int)) japanesesums = (parseMultiOutsideClues, parseGrid) coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid -coral = (parseMultiOutsideClues, parseShadedGrid) +coral = (,) + (fmap (fmap (map unIntString)) . parseMultiOutsideClues) + parseShadedGrid maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v, @@ -142,3 +143,9 @@ labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int)) labyrinth = (parseCellEdges, parseClueGrid') + +bahnhof :: ParsePuzzle (SGrid (Maybe BahnhofClue)) [Edge] +bahnhof = (parseClueGrid, parseEdges) + +cave :: ParsePuzzle (SGrid (Clue Int)) ShadedGrid +cave = (parseClueGrid, parseShadedGrid) diff --git a/src/Text/Puzzles/Util.hs b/src/Text/Puzzles/Util.hs --- a/src/Text/Puzzles/Util.hs +++ b/src/Text/Puzzles/Util.hs @@ -2,18 +2,18 @@ module Text.Puzzles.Util where -import Prelude hiding (sequence) +import Prelude hiding (mapM) import Control.Applicative import Control.Arrow -import Control.Monad hiding (sequence) +import Control.Monad hiding (mapM) import Data.Hashable import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Map as Map import qualified Data.HashMap.Strict as HMap -import Data.Traversable (traverse, sequence, sequenceA, Traversable) -import Data.Foldable (Foldable, fold) +import Data.Traversable (traverse, sequenceA, mapM, Traversable) +import Data.Foldable (Foldable, foldMap) import Data.Monoid ((<>)) import Data.List (intersect) @@ -27,9 +27,24 @@ import Data.Puzzles.GridShape hiding (size) import Data.Puzzles.Elements +type Path = [String] + +field :: Path -> Value -> Parser Value +field = field' . map T.pack + where + field' [] v = pure v + field' (f:fs) (Object v) = v .: f >>= field' fs + field' _ _ = empty + +parseFrom :: Path -> (Value -> Parser b) -> (Value -> Parser b) +parseFrom fs p v = field fs v >>= p + class FromChar a where parseChar :: Char -> Parser a +failChar :: Char -> String -> Parser a +failChar c expect = fail $ "got '" ++ [c] ++ "', expected " ++ expect + instance FromChar Char where parseChar = pure @@ -52,6 +67,14 @@ | isAlpha c = Alpha <$> parseChar c | otherwise = empty +-- | Helper to parse strings from number-formatted YAML fields. +-- Somewhat dodgy. +newtype IntString = IntString { unIntString :: String } + +instance FromJSON IntString where + parseJSON v@(Number _) = IntString . (show :: Int -> String) <$> parseJSON v + parseJSON v = IntString <$> parseJSON v + -- | A rectangle. Each row has length `w`. data Rect a = Rect !Int !Int [[a]] deriving Show @@ -66,15 +89,16 @@ w = maximum . map T.length $ ls h = length ls filledc = map (T.unpack . T.justifyLeft w ' ') ls - filled = sequence . map (mapM parseChar) $ filledc - parseJSON _ = empty + filled = mapM (mapM parseChar) filledc + parseJSON _ = fail "expected string" data Border a = Border [a] [a] [a] [a] deriving Show -- | This instance might be a lie. instance Foldable Border where - fold (Border l r b t) = fold l <> fold r <> fold b <> fold t + foldMap f (Border l r b t) = foldMap f l <> foldMap f r + <> foldMap f b <> foldMap f t instance Traversable Border where sequenceA (Border l r b t) = Border <$> sequenceA l @@ -98,8 +122,8 @@ ls' = map (middle w) . middle h $ ls mapM_ ((parseChar :: Char -> Parser Space) . flip ($) ls) [head . head, head . last, last . head, last . last] - lsparsed <- sequence . map (mapM parseChar) $ ls' - bparsed <- sequenceA . fmap parseChar $ b + 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 @@ -114,7 +138,7 @@ w = maximum . map length $ ls wmin = minimum . map length $ ls h = length ls - p = sequence . map (mapM (parseString . T.unpack)) $ ls + p = mapM (mapM (parseString . T.unpack)) ls parseJSON _ = empty data Space = Space @@ -131,11 +155,24 @@ parseChar '.' = pure Blank parseChar _ = empty +parseCharJSON :: FromChar a => Value -> Parser a +parseCharJSON v = do + [c] <- parseJSON v + parseChar c + +instance FromJSON Blank where + parseJSON = parseCharJSON + instance FromChar Blank' where parseChar '.' = pure Blank' parseChar '-' = pure Blank' parseChar _ = empty +instance FromJSON Blank' where + parseJSON (String ".") = pure Blank' + parseJSON (String "-") = pure Blank' + parseJSON _ = empty + instance FromChar Empty where parseChar ' ' = pure Empty parseChar _ = empty @@ -153,19 +190,33 @@ instance FromChar MasyuPearl where parseChar '*' = pure MBlack parseChar 'o' = pure MWhite - parseChar _ = empty + parseChar c = failChar c "'*' or 'o'" instance FromChar SlalomDiag where parseChar '/' = pure SlalomForward parseChar '\\' = pure SlalomBackward parseChar _ = empty +instance FromChar Black where + parseChar 'X' = pure Black + parseChar 'x' = pure Black + parseChar _ = empty + instance (FromChar a, FromChar b) => FromChar (Either a b) where parseChar c = Left <$> parseChar c <|> Right <$> parseChar c instance (FromString a, FromString b) => FromString (Either a b) where parseString c = Left <$> parseString c <|> Right <$> parseString c +newtype Either' a b = Either' { unEither' :: Either a b } + +instance (FromChar a, FromChar b) => FromChar (Either' a b) where + parseChar c = Either' <$> parseChar c + +instance (FromJSON a, FromJSON b) => FromJSON (Either' a b) where + parseJSON v = Either' <$> + (Left <$> parseJSON v <|> Right <$> parseJSON v) + instance FromChar a => FromChar (Maybe a) where parseChar = optional . parseChar @@ -211,6 +262,26 @@ parseGrid :: FromChar a => Value -> Parser (SGrid a) parseGrid v = rectToSGrid <$> parseJSON v +parseGridWith :: (Char -> Parser a) -> Value -> Parser (SGrid a) +parseGridWith pChar v = traverse pChar =<< parseGrid v + +parseWithReplacement :: FromChar a => + (Char -> Maybe a) -> Char -> Parser a +parseWithReplacement replace c = maybe (parseChar c) pure (replace c) + +parseCharMap :: FromJSON a => Value -> Parser (Map.Map Char a) +parseCharMap v = do + m <- parseJSON v + guard . all (\k -> length k == 1) . Map.keys $ m + return $ Map.mapKeys head m + +parseExtGrid :: (FromChar a, FromJSON a) => Value -> Parser (SGrid a) +parseExtGrid v@(String _) = parseGrid v +parseExtGrid v = do + repl <- parseFrom ["replace"] parseCharMap v + parseFrom ["grid"] (parseGridWith + (parseWithReplacement (`Map.lookup` repl))) v + parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a)) parseClueGrid v = rectToClueGrid <$> parseJSON v @@ -271,17 +342,17 @@ return (gn', gc') both f (x, y) = (f x, f y) halveGrid (Grid (Square w h) m) - | odd w && odd h = pure $ (Grid snode mnode, Grid scell mcell) - | otherwise = empty + | odd w && odd h = pure (Grid snode (divkeys mnode), + Grid scell (divkeys mcell)) + | otherwise = fail "non-odd grid size" where w' = (w + 1) `div` 2 h' = (h + 1) `div` 2 snode = Square w' h' scell = Square (w' - 1) (h' - 1) - (mnode, mcell) = - both (Map.mapKeys (both (`div` 2))) . - Map.partitionWithKey (const . uncurry (&&) . both even) $ - m + mnode = Map.filterWithKey (const . uncurry (&&) . both even) m + mcell = Map.filterWithKey (const . uncurry (&&) . both odd) m + divkeys = Map.mapKeys (both (`div` 2)) -- | Parse a grid of edges with values at the nodes. -- @@ -306,15 +377,11 @@ data HalfDirs = HalfDirs {unHalfDirs :: [Dir]} instance FromChar HalfDirs where - parseChar c | c == '└' = pure . HalfDirs $ [V, H] - | c `elem` "│┘" = pure . HalfDirs $ [V] - | c `elem` "─└┌" = pure . HalfDirs $ [H] + parseChar c | c `elem` "└┴├┼" = pure . HalfDirs $ [V, H] + | c `elem` "│┘┤" = pure . HalfDirs $ [V] + | c `elem` "─┌┬" = pure . HalfDirs $ [H] | otherwise = pure . HalfDirs $ [] -instance FromChar JapVal where - parseChar c | c `elem` ['x', 'X'] = pure JapBlack - parseChar c = JapInt <$> parseChar c - -- parses a string like -- ┌┐┌─┐ -- ││└┐│ @@ -363,8 +430,8 @@ 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 (Rect w h ls) = (,) (Grid s ints) + <$> parseThermos (Grid s alphas) where s = Square w h (ints, alphas) = partitionEithers . snd . partitionEithers $ @@ -389,8 +456,8 @@ instance FromChar a => FromString (Tightfit a) where parseString [c] = Single <$> parseChar c - parseString (c: '/':d:[]) = UR <$> parseChar c <*> parseChar d - parseString (c:'\\':d:[]) = DR <$> parseChar c <*> parseChar d + parseString [c, '/',d] = UR <$> parseChar c <*> parseChar d + parseString [c,'\\',d] = DR <$> parseChar c <*> parseChar d parseString _ = empty parseTightIntGrid :: Value -> Parser (SGrid (Tightfit Int)) @@ -436,7 +503,7 @@ hashmaptomap = Map.fromList . HMap.toList compose :: (Ord a, Ord b) => Map.Map a b -> Map.Map b c -> Maybe (Map.Map a c) -compose m1 m2 = sequence . Map.map (flip Map.lookup m2) $ m1 +compose m1 m2 = mapM (`Map.lookup` m2) m1 instance FromJSON a => FromJSON (RefGrid a) where parseJSON (Object v) = RefGrid <$> do @@ -486,6 +553,15 @@ pfield f = parseLine . fromMaybe [] =<< v .:? f parseCharOutside _ = empty +parseOutside :: FromJSON a => Value -> Parser (OutsideClues a) +parseOutside (Object v) = reorientOutside <$> + (OC <$> + pfield "left" <*> pfield "right" <*> + pfield "bottom" <*> pfield "top" ) + where + pfield f = pure . fromMaybe [] =<< v .:? f +parseOutside _ = empty + parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a]) parseMultiOutsideClues (Object v) = rev <$> raw where @@ -501,3 +577,7 @@ parseChar '\\' = pure $ PrimeDiag (False, True) parseChar 'X' = pure $ PrimeDiag (True, True) parseChar _ = empty + +instance FromChar Crossing where + parseChar '+' = pure Crossing + parseChar _ = fail "expected '+'" diff --git a/src/tools/drawpuzzle.hs b/src/tools/drawpuzzle.hs new file mode 100644 --- /dev/null +++ b/src/tools/drawpuzzle.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import Diagrams.Prelude hiding (value, option, (<>), Result) + +import Diagrams.Puzzles.CmdLine + +import Text.Puzzles.Puzzle +import Data.Puzzles.Compose +import Data.Puzzles.PuzzleTypes (typeNames) +import Diagrams.Puzzles.Draw + +import Options.Applicative +import Control.Monad +import Data.Maybe +import Data.List (intercalate, sort) + +import System.FilePath +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 + { _format :: String + , _type :: Maybe String + , _puzzle :: Bool + , _solution :: Bool + , _example :: Bool + , _input :: FilePath + } + +puzzleOpts :: Parser PuzzleOpts +puzzleOpts = PuzzleOpts + <$> strOption + (long "format" <> short 'f' + <> value (head formats) + <> metavar "FMT" + <> help ("Desired output format by file extension " ++ fmts)) + <*> (optional . strOption $ + (long "type" <> short 't' + <> metavar "TYPE" + <> help "Puzzle type, overriding type in input file")) + <*> switch + (long "puzzle" <> short 'p' + <> help "Render puzzle (to base.ext)") + <*> switch + (long "solution" <> short 's' + <> help "Render solution (to base-sol.ext)") + <*> switch + (long "example" <> short 'e' + <> help "Render example (to base.ext)") + <*> argument str + (metavar "INPUT" + <> help "Puzzle file in .pzl format") + where + fmts = "(" ++ intercalate ", " formats ++ ")" + +cmtopoint :: Double -> Double +cmtopoint = (* 28.3464567) + +outputSuffix :: OutputChoice -> String +outputSuffix DrawPuzzle = "" +outputSuffix DrawSolution = "-sol" +outputSuffix DrawExample = "" + +toRenderOpts :: OutputChoice -> Double -> PuzzleOpts -> RenderOpts +toRenderOpts oc w opts = RenderOpts out w' + where + f = _format opts + u = case f of "png" -> Pixels + _ -> Points + w' = toOutputWidth u w + base = takeBaseName (_input opts) + out = addExtension (base ++ outputSuffix oc) f + +renderPuzzle :: PuzzleOpts -> (OutputChoice -> Maybe (Diagram B R2)) -> + (OutputChoice, Bool) -> IO () +renderPuzzle opts r (oc, req) = do + let x = r oc + when (req && isNothing x) $ + exitErr ("failed to render (no solution?): " ++ show oc) + when (isJust x) $ do + let Just x' = x + ropts = toRenderOpts oc (diagramWidth x') opts + renderToFile ropts x' + +defaultOpts :: Parser a -> IO a +defaultOpts optsParser = do + prog <- getProgName + let p = info (helper <*> optListTypes <*> optsParser) + (fullDesc + <> progDesc "Command-line diagram generation." + <> header prog) + execParser p + +checkOutput :: PuzzleOpts -> IO [(OutputChoice, Bool)] +checkOutput opts + | (p || s) && e = exitErr "example output conflicts with puzzle/solution" + | e = return . map req $ [DrawExample] + | p && s = return . map req $ [DrawPuzzle, DrawSolution] + | p = return . map req $ [DrawPuzzle] + | s = return . map req $ [DrawSolution] + | otherwise = return [req DrawPuzzle, opt DrawSolution] + where + p = _puzzle opts + s = _solution opts + e = _example opts + req x = (x, True) + opt x = (x, False) + +maybeSkipSolution :: [(OutputChoice, Bool)] -> Maybe Y.Value -> Maybe Y.Value +maybeSkipSolution _ Nothing = Nothing +maybeSkipSolution ocs (Just v) = + if any hasSol . map fst $ ocs + then Just v + else Nothing + where + hasSol DrawSolution = True + hasSol DrawExample = True + hasSol DrawPuzzle = False + +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 + let msv' = maybeSkipSolution ocs msv + 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 + Left e -> exitErr $ "parse failure: " ++ e diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -3,16 +3,18 @@ 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) -import Text.Puzzles.Util (parseChar, parseMultiOutsideClues) +import Data.Puzzles.Elements (Thermometer, MasyuPearl(..)) +import Text.Puzzles.Util + (parseChar, parseMultiOutsideClues, parseEdgeGrid) import Text.Puzzles.PuzzleTypes import qualified Data.Puzzles.Grid as Grid import Data.Puzzles.Pyramid (PyramidSol(..)) import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..)) +import Data.Puzzles.GridShape (Edge(..), Square(..), Dir(..)) import Diagrams.Puzzles.PuzzleGrids import Diagrams.Prelude @@ -78,6 +80,7 @@ , testParsePzl "thermosudoku" thermosudoku thermo_2 , testNonparsePzl "thermosudoku" thermosudoku thermo_broken_1 , testNonparsePzl "thermosudoku" thermosudoku thermo_broken_2 + , testParsePzl "boxof2or3" boxof2or3 boxof2or3_1 ] test_thermo_1 :: [Thermometer] @@ -117,6 +120,18 @@ oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]] :: OutsideClues [Int] +test_edge_grid :: Assertion +test_edge_grid = Right (gn, gc, es) @=? res + where + res = parseEither parseEdgeGrid edgeGrid_1 + gn = Grid.Grid (Square 4 2) $ 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 + [((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] + parseDataTests :: TestTree parseDataTests = testGroup "Parsing tests (full puzzles, result checks)" [ testCase "parse tightfit, correct size" $ test_tightfit_1 @? "error in puzzle" @@ -129,6 +144,7 @@ , [(0, 2), (1, 3), (2, 4)] , [(4, 0), (4, 1), (3, 2)] ] , testCase "parse multioutsideclues" $ test_multioutside + , testCase "parse edge grid" $ test_edge_grid ] -- this used to cause a rendering crash, though it's