puzzle-draw 0.1.0.2 → 0.1.0.3

raw patch · 14 files changed

+286/−41 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGES.md +6/−0
• puzzle-draw.cabal +1/−1
• src/Data/Puzzles/Compose.hs +3/−0
• src/Data/Puzzles/Elements.hs +3/−0
• src/Data/Puzzles/Grid.hs +3/−0
• src/Data/Puzzles/GridShape.hs +58/−9
• src/Data/Puzzles/PuzzleTypes.hs +6/−0
• src/Diagrams/Puzzles/Elements.hs +9/−0
• src/Diagrams/Puzzles/Grid.hs +39/−4
• src/Diagrams/Puzzles/Lib.hs +3/−0
• src/Diagrams/Puzzles/PuzzleGrids.hs +6/−0
• src/Diagrams/Puzzles/PuzzleTypes.hs +29/−4
• src/Text/Puzzles/PuzzleTypes.hs +12/−1
• src/Text/Puzzles/Util.hs +108/−22

@@ -1,3 +1,9 @@+0.1.0.3: 20140519+-----------------++* add new puzzle types: Maximal Lengths, Prime Place, Magic Labyrinth++ 0.1.0.2: 20140419 ----------------- 

@@ -1,5 +1,5 @@ name:                puzzle-draw-version:             0.1.0.2+version:             0.1.0.3 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

@@ -63,6 +63,9 @@ 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  -- | Handler that parses a puzzle from a YAML value, and renders. drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2))

@@ -58,3 +58,6 @@  data JapVal = JapBlack | JapInt Int     deriving Show++-- | Diagonal marking for Prime Place: forward diag?, backward diag?+newtype PrimeDiag = PrimeDiag (Bool, Bool)

@@ -44,6 +44,9 @@ instance Traversable (Grid s) where     traverse f (Grid s m) = Grid s <$> (traverse f m) +filterG :: (a -> Bool) -> (Grid s a) -> (Grid s a)+filterG p (Grid s m) = Grid s (Map.filter p m)+ -- | Initialize a square grid from a list of lists. The grid --   might be incomplete if some rows are shorter. fromListList :: [[a]] -> Grid Square a

@@ -3,6 +3,11 @@ -- | Grid shapes. module Data.Puzzles.GridShape where +import Data.Foldable (Foldable)+import qualified Data.Foldable as F+import Data.List (partition)+import Data.VectorSpace ((^+^))+ -- | The geometry of a grid. class Show (Cell a) => GridShape a where     type GridSize a :: *@@ -12,7 +17,8 @@     size :: a -> GridSize a     cells :: a -> [Cell a]     vertices :: a -> [Vertex a]-    neighbours :: a -> Cell a -> [Cell a]+    vertexNeighbours :: a -> Cell a -> [Cell a]+    edgeNeighbours :: a -> Cell a -> [Cell a]  -- | A standard square grid, with cells and vertices --   indexed by pairs of integers in mathematical coordinates.@@ -21,6 +27,12 @@ data Square = Square !Int !Int     deriving Show +squareNeighbours :: [(Int, Int)] -> Square -> (Cell Square) -> [Cell Square]+squareNeighbours deltas (Square w h) c = filter inBounds . map (add c) $ deltas+  where+    inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h+    add (x, y) (x', y') = (x + x', y + y')+ instance GridShape Square where     type GridSize Square = (Int, Int)     type Cell Square     = (Int, Int)@@ -29,14 +41,15 @@     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]]-    neighbours (Square w h) c = filter inBounds . map (add c) $ deltas-      where-        inBounds (x, y) = x >= 0 && x < w && y >= 0 && y < h-        deltas = [ (dx, dy)-                 | dx <- [-1..1], dy <- [-1..1]-                 , dx /= 0 || dy /= 0-                 ]-        add (x, y) (x', y') = (x + x', y + y')+    vertexNeighbours = squareNeighbours [ (dx, dy)+                                        | dx <- [-1..1], dy <- [-1..1]+                                        , dx /= 0 || dy /= 0+                                        ]+    edgeNeighbours = squareNeighbours [ (dx, dy)+                                      | dx <- [-1..1], dy <- [-1..1]+                                      , dx /= 0 || dy /= 0+                                      , dx == 0 || dy == 0+                                      ]  -- | Edge direction in a square grid, vertical or horizontal. data Dir = V | H@@ -49,3 +62,39 @@  type Coord = Cell Square type Size = GridSize Square++-- | Oriented edge direction in a square grid.+data Dir' = U | D | L | R+    deriving (Eq, Ord, Show)++-- | An oriented edge in a square grid.+--   @a@ should be @Cell Square@ or @Vertex Square@.+data Edge' a = E' a Dir'+    deriving (Eq, Ord, Show)++-- | The edge between two neighbouring cells, with the first cell+--   on the left.+orientedEdge :: (Cell Square) -> (Cell Square) -> (Edge' (Vertex Square))+orientedEdge (x,y) (x',y')+    | x' == x && y' == y+1  = E' (x,y+1) R+    | x' == x && y' == y-1  = E' (x+1,y) L+    | x' == x+1 && y' == y  = E' (x+1,y+1) D+    | x' == x-1 && y' == y  = E' (x,y) U+    | otherwise             = error $ "not neighbours: " +++                                      show (x,y) ++ " " ++  show (x',y')++-- | @edges@ computes the outer and inner edges of a set of cells.+--   The set is given via fold and membership predicate, the result+--   is a pair @(outer, inner)@ of lists of edges, where the outer+--   edges are oriented such that the outside is to the left.+edges :: Foldable f =>+           f (Cell Square) -> (Cell Square -> Bool) ->+           ([Edge' (Vertex Square)], [Edge' (Vertex Square)])+edges cs isc = F.foldr f ([], []) cs+  where+    f c (outer, inner) = (newout ++ outer, newin ++ inner)+      where+        nbrs = [ c ^+^ d | d <- [(-1,0), (0,1), (1,0), (0,-1)] ]+        (ni, no) = partition isc nbrs+        newout = map (orientedEdge c) no+        newin = map (orientedEdge c) . filter ((>=) c) $ ni

@@ -37,6 +37,9 @@                 | Tapa                 | JapaneseSums                 | Coral+                | MaximalLengths+                | PrimePlace+                | Labyrinth     deriving (Show, Eq)  typeNames :: [(PuzzleType, String)]@@ -66,6 +69,9 @@             , (Tapa, "tapa")             , (JapaneseSums, "japanesesums")             , (Coral, "coral")+            , (MaximalLengths, "maximallengths")+            , (PrimePlace, "primeplace")+            , (Labyrinth, "magiclabyrinth")             ]  -- | Look up a puzzle type by name.

@@ -158,3 +158,12 @@     p' 4 = reflectX . rotateBy (3/8) $ square 0.7     p' 1 = error "singleton clues handled separately"     p' _ = error "invalid tapa clue"++drawPrimeDiag :: (Backend b R2, Renderable (Path R2) b) =>+                 PrimeDiag -> Diagram b R2+drawPrimeDiag (PrimeDiag d) = stroke p # lw (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

@@ -3,6 +3,7 @@ module Diagrams.Puzzles.Grid where  import Data.Char (isUpper)+import qualified Data.Map as M  import Diagrams.Prelude @@ -22,13 +23,23 @@ slithergrid (x, y) =     hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot +fence :: [Double] -> Double -> Path R2+fence xs h = decoratePath xspath (repeat v)+  where+    xspath = fromVertices [ p2 (x, 0) | x <- xs ]+    v = alignB (vrule h)+ -- | The inner grid lines of a square grid of the specified size. gridlines :: Size -> Path R2-gridlines (w, h) = (decoratePath xaxis . repeat . alignB . vrule . fromIntegral $ h)-            <> (decoratePath yaxis . repeat . alignL . hrule . fromIntegral $ w)-    where xaxis = fromVertices [ p2 (fromIntegral x, 0) | x <- [1..w-1] ]-          yaxis = fromVertices [ p2 (0, fromIntegral y) | y <- [1..h-1] ]+gridlines (w, h) = fence' w h <> mirror (fence' h w)+  where+    fence' n l = fence (map fromIntegral [1..n-1]) (fromIntegral l) +fullgridlines :: Size -> Path R2+fullgridlines (w, h) = fence' w h <> mirror (fence' h w)+  where+    fence' n l = fence (map fromIntegral [0..n]) (fromIntegral l)+ -- | Draw a frame around the outside of a rectangle. outframe :: Renderable (Path R2) b => Size -> Diagram b R2 outframe (w, h) = strokePointLoop r # lw fw@@ -52,6 +63,11 @@         Size -> Diagram b R2 grid = grid' id +-- | Draw a square grid with thin frame.+plaingrid :: (Backend b R2, Renderable (Path R2) b) =>+             Size -> Diagram b R2+plaingrid s = stroke (fullgridlines s) # lw gridwidth+ bgdashing :: (Semigroup a, HasStyle a) =>              [Double] -> Double -> Colour Double -> a -> a bgdashing ds offs c x = x # dashing ds offs <> x # lc c@@ -70,6 +86,25 @@ dashedgrid = grid' $ bgdashing dashes dashoffset white'   where     white' = blend 0.95 white black++edgePath :: Edge' (Vertex Square) -> Path R2+edgePath (E' v R) = p2i v ~~ p2i (v ^+^ (1,0))+edgePath (E' v L) = p2i v ~~ p2i (v ^+^ (-1,0))+edgePath (E' v U) = p2i v ~~ p2i (v ^+^ (0,1))+edgePath (E' v D) = p2i v ~~ p2i (v ^+^ (0,-1))++irregularGridPaths :: SGrid a -> (Path R2, Path R2)+irregularGridPaths (Grid _ m) = (toPath outer, toPath inner)+  where+    (outer, inner) = edges (M.keysSet m) (flip M.member m)+    toPath = mconcat . map edgePath++irregularGrid :: (Backend b R2, Renderable (Path R2) b) =>+                 SGrid a -> Diagram b R2+irregularGrid g = stroke outer # lw (3 * gridwidth) # lineCap LineCapSquare <>+                  stroke inner # lw gridwidth+  where+    (outer, inner) = irregularGridPaths g  -- | In a square grid, use the first argument to draw things at the centres --   of cells given by coordinates.

@@ -38,6 +38,9 @@ p2i :: (Int, Int) -> P2 p2i = p2 . (fromIntegral *** fromIntegral) +mirror :: (Transformable t, V t ~ R2) => t -> t+mirror = reflectAbout (p2 (0, 0)) (r2 (1, 1))+ -- | Interleave two lists. interleave :: [a] -> [a] -> [a] interleave [] _ = []

@@ -84,6 +84,12 @@   where     if' a b x = if x then a else b ++outsideGrid :: (Backend b R2, Renderable (Path R2) b) =>+               OutsideClues [String] -> Diagram b R2+outsideGrid = atCentres (scale 0.8 . drawText) . multiOutsideClues+              <> grid . outsideSize+ outsideIntGrid :: (Backend b R2, Renderable (Path R2) b) =>                   OutsideClues [Int] -> Diagram b R2 outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues

@@ -7,7 +7,7 @@     liarslither, tightfitskyscrapers, wordloop, wordsearch,     curvedata, doubleback, slalom, compass, boxof2or3,     afternoonskyscrapers, countnumbers, tapa, japanesesums,-    coral,+    coral, maximallengths, primeplace, labyrinth   ) where  import Diagrams.Prelude hiding (Loop, coral)@@ -199,7 +199,32 @@     japcell (JapInt x) = drawInt x  coral :: (Backend b R2, Renderable (Path R2) b) =>-                RenderPuzzle b (OutsideClues [Int]) ShadedGrid+          RenderPuzzle b (OutsideClues [String]) ShadedGrid coral = (,)-    outsideIntGrid-    (drawShadedGrid . snd <> outsideIntGrid . fst)+    outsideGrid+    (drawShadedGrid . snd <> outsideGrid . fst)++maximallengths :: (Backend b R2, Renderable (Path R2) b) =>+                  RenderPuzzle b (OutsideClues (Maybe Int)) Loop+maximallengths = (,)+    g+    (solstyle . drawDualEdges . snd <> g . fst)+  where+    g = atCentres drawInt . outsideClues+        <> grid . outsideSize++primeplace :: (Backend b R2, Renderable (Path R2) b) =>+              RenderPuzzle b (SGrid PrimeDiag) (SGrid Int)+primeplace = (,)+    g+    (atCentres drawInt . values . snd <> g . fst)+  where+    g = irregularGrid <> atCentres drawPrimeDiag . values++labyrinth :: (Backend b R2, Renderable (Path R2) 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

@@ -6,6 +6,7 @@     liarslither, tightfitskyscrapers, wordloop, wordsearch,     curvedata, doubleback, slalom, compass, boxof2or3,     afternoonskyscrapers, countnumbers, tapa, japanesesums, coral,+    maximallengths, primeplace, labyrinth   ) where  import Prelude hiding (sequence)@@ -129,5 +130,15 @@ japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid JapVal) japanesesums = (parseMultiOutsideClues, parseGrid) -coral :: ParsePuzzle (OutsideClues [Int]) ShadedGrid+coral :: ParsePuzzle (OutsideClues [String]) ShadedGrid coral = (parseMultiOutsideClues, parseShadedGrid)++maximallengths :: ParsePuzzle (OutsideClues (Maybe Int)) Loop+maximallengths = (\v -> fmap blankToMaybe <$> parseCharOutside v,+                  parseEdges)++primeplace :: ParsePuzzle (SGrid PrimeDiag) (SGrid Int)+primeplace = (parseIrregGrid, parseIrregGrid)++labyrinth :: ParsePuzzle (SGrid (Clue Int), [Edge]) (SGrid (Clue Int))+labyrinth = (parseCellEdges, parseClueGrid')

@@ -36,6 +36,9 @@ class FromString a where     parseString :: String -> Parser a +parseLine :: FromChar a => String -> Parser [a]+parseLine = mapM parseChar+ instance FromChar Int where     parseChar c         | isDigit c  = digitToInt <$> parseChar c@@ -114,11 +117,6 @@         p = sequence . map (mapM (parseString . T.unpack)) $ ls     parseJSON _          = empty -instance FromChar MasyuPearl where-    parseChar '*' = pure MBlack-    parseChar 'o' = pure MWhite-    parseChar _   = empty- data Space = Space  instance FromChar Space where@@ -127,6 +125,7 @@  data Blank = Blank data Blank' = Blank'+data Empty = Empty  instance FromChar Blank where     parseChar '.' = pure Blank@@ -137,10 +136,25 @@     parseChar '-' = pure Blank'     parseChar _   = empty +instance FromChar Empty where+    parseChar ' ' = pure Empty+    parseChar _   = empty+ instance FromString Blank where     parseString "." = pure Blank     parseString _   = empty +data PlainNode = PlainNode++instance FromChar PlainNode where+    parseChar 'o' = pure PlainNode+    parseChar _   = empty++instance FromChar MasyuPearl where+    parseChar '*' = pure MBlack+    parseChar 'o' = pure MWhite+    parseChar _   = empty+ instance FromChar SlalomDiag where     parseChar '/'  = pure SlalomForward     parseChar '\\' = pure SlalomBackward@@ -165,9 +179,25 @@ rectToSGrid :: Rect a -> SGrid a rectToSGrid (Rect w h ls) = Grid (Square w h) (listListToMap ls) +blankToMaybe :: Either Blank a -> Maybe a+blankToMaybe = either (const Nothing) Just++blankToMaybe' :: Either Blank' a -> Maybe a+blankToMaybe' = either (const Nothing) Just+ rectToClueGrid :: Rect (Either Blank a) -> SGrid (Clue a)-rectToClueGrid = fmap (either (const Nothing) Just) . rectToSGrid+rectToClueGrid = fmap blankToMaybe . rectToSGrid +rectToClueGrid' :: Rect (Either Blank' a) -> SGrid (Clue a)+rectToClueGrid' = fmap blankToMaybe' . rectToSGrid++rectToIrregGrid :: Rect (Either Empty a) -> SGrid a+rectToIrregGrid = fmap fromRight . filterG isRight . rectToSGrid+  where+    isRight = either (const False) (const True)+    fromRight (Right r) = r+    fromRight _         = error "no way"+ newtype Shaded = Shaded { unShaded :: Bool }  instance FromChar Shaded where@@ -184,6 +214,12 @@ parseClueGrid :: FromChar a => Value -> Parser (SGrid (Clue a)) parseClueGrid v = rectToClueGrid <$> parseJSON v +parseClueGrid' :: FromChar a => Value -> Parser (SGrid (Clue a))+parseClueGrid' v = rectToClueGrid' <$> parseJSON v++parseIrregGrid :: FromChar a => Value -> Parser (SGrid a)+parseIrregGrid v = rectToIrregGrid <$> parseJSON v+ parseSpacedClueGrid :: FromString a => Value -> Parser (SGrid (Clue a)) parseSpacedClueGrid v = rectToClueGrid . unSpaced <$> parseJSON v @@ -215,6 +251,38 @@ parseGridChars :: FromChar a => SGrid Char -> Parser (SGrid a) parseGridChars = traverse parseChar +-- | Parse a grid with edges and values at nodes and in cells.+--+-- E.g. o-*-*-o+--      |1|2 3+--      *-o+-- to a grid of masyu pearls, a grid of integers, and some edges.+parseEdgeGrid :: (FromChar a, FromChar b) =>+                 Value -> Parser (SGrid a, SGrid b, [Edge])+parseEdgeGrid v = uncurry (,,) <$>+                  parseBoth <*>+                  parsePlainEdges v+  where+    parseBoth = do+        g <- parseGrid v+        (gn, gc) <- halveGrid g+        gn' <- parseGridChars gn+        gc' <- parseGridChars gc+        return (gn', gc')+    both f (x, y) = (f x, f y)+    halveGrid (Grid (Square w h) m)+        | odd w && odd h = pure $ (Grid snode mnode, Grid scell mcell)+        | otherwise      = empty+      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+ -- | Parse a grid of edges with values at the nodes. -- -- E.g. o-*-*-o@@ -223,20 +291,18 @@ -- to a grid of masyu pearls and some edges. parseNodeEdges :: FromChar a =>                   Value -> Parser (SGrid a, [Edge])-parseNodeEdges v = (,) <$>-                   (parseGridChars =<< halveGrid =<< parseGrid v) <*>-                   parsePlainEdges v+parseNodeEdges v = proj13 <$> parseEdgeGrid v   where-    halveGrid (Grid (Square w h) m)-        | odd w && odd h = pure $ Grid s' m'-        | otherwise      = empty-      where-        s' = Square ((w + 1) `div` 2) ((h + 1) `div` 2)-        m' = Map.mapKeys (both (`div` 2))-           . Map.filterWithKey (const . (uncurry (&&) . both even))-           $ m-        both f (x, y) = (f x, f y)+    proj13 :: (SGrid a, SGrid Empty, [Edge]) -> (SGrid a, [Edge])+    proj13 (x,_,z) = (x,z) +parseCellEdges :: FromChar a =>+                  Value -> Parser (SGrid a, [Edge])+parseCellEdges v = proj23 <$> parseEdgeGrid v+  where+    proj23 :: (SGrid PlainNode, SGrid a, [Edge]) -> (SGrid a, [Edge])+    proj23 (_,y,z) = (y,z)+ data HalfDirs = HalfDirs {unHalfDirs :: [Dir]}  instance FromChar HalfDirs where@@ -288,10 +354,10 @@         []   -> pure Nothing         [q]  -> pure (Just q)         _    -> fail "multiple successors"-    succs      p = filter    (test ((==) . succ) p) . neighbours s $ p-    isStart    p = not . any (test ((==) . pred) p) . neighbours s $ p+    succs      p = filter    (test ((==) . succ) p) . vertexNeighbours s $ p+    isStart    p = not . any (test ((==) . pred) p) . vertexNeighbours s $ p     test f p q = maybe False (f (m' Map.! p)) (Map.lookup q m')-    isAlmostIsolated p = all disjointSucc . neighbours s $ p+    isAlmostIsolated p = all disjointSucc . vertexNeighbours s $ p       where         disjointSucc q = null $ intersect (succs p) (succs' q)         succs' q = maybe [] (const $ succs q) (Map.lookup q m')@@ -408,10 +474,30 @@                      guard $ length xs > 0 && length xs <= 4                      return . ParseTapaClue . TapaClue $ xs +reorientOutside :: OutsideClues a -> OutsideClues a+reorientOutside (OC l r b t) = OC (reverse l) (reverse r) b t++parseCharOutside :: FromChar a => Value -> Parser (OutsideClues a)+parseCharOutside (Object v) = reorientOutside <$>+                              (OC <$>+                               pfield "left" <*> pfield "right" <*>+                               pfield "bottom" <*> pfield "top" )+  where+    pfield f = parseLine . fromMaybe [] =<< v .:? f+parseCharOutside _          = empty+ parseMultiOutsideClues :: FromJSON a => Value -> Parser (OutsideClues [a]) parseMultiOutsideClues (Object v) = rev <$> raw   where     raw = OC <$> v `ml` "left" <*> v `ml` "right" <*> v `ml` "bottom" <*> v `ml` "top"     v' `ml` k = fromMaybe [] <$> v' .:? k-    rev (OC l r b t) = OC (reverse . map reverse $ l) (reverse r) b (map reverse t)+    rev (OC l r b t) = reorientOutside $+                       OC (map reverse l) r b (map reverse t) parseMultiOutsideClues _ = empty++instance FromChar PrimeDiag where+    parseChar '.'  = pure $ PrimeDiag (False, False)+    parseChar '/'  = pure $ PrimeDiag (True,  False)+    parseChar '\\' = pure $ PrimeDiag (False, True)+    parseChar 'X'  = pure $ PrimeDiag (True,  True)+    parseChar _    = empty