puzzle-draw 0.1.0.1 → 0.1.0.2

raw patch · 16 files changed

+171/−44 lines, 16 filesdep +vector-spacePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: vector-space

API changes (from Hackage documentation)

Files

• CHANGES.md +5/−0
• puzzle-draw.cabal +3/−2
• src/Data/Puzzles/Compose.hs +2/−0
• src/Data/Puzzles/Elements.hs +3/−0
• src/Data/Puzzles/Grid.hs +18/−5
• src/Data/Puzzles/PuzzleTypes.hs +4/−0
• src/Diagrams/Puzzles/Draw.hs +43/−4
• src/Diagrams/Puzzles/Elements.hs +4/−2
• src/Diagrams/Puzzles/Grid.hs +3/−12
• src/Diagrams/Puzzles/PuzzleGrids.hs +6/−2
• src/Diagrams/Puzzles/PuzzleTypes.hs +21/−4
• src/Diagrams/Puzzles/Pyramid.hs +2/−5
• src/Diagrams/Puzzles/Widths.hs +4/−1
• src/Text/Puzzles/PuzzleTypes.hs +8/−2
• src/Text/Puzzles/Util.hs +17/−3
• tests/tests.hs +28/−2

@@ -1,3 +1,8 @@+0.1.0.2: 20140419+-----------------++* add new puzzle types: Japanese Sums, Coral+ 0.1.0.1: 20140409 ----------------- 

@@ -1,5 +1,5 @@ name:                puzzle-draw-version:             0.1.0.1+version:             0.1.0.2 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@@ -47,7 +47,8 @@                        containers >= 0.5 && < 0.6,                        hashable >= 1.2 && < 1.3,                        text >= 1.1 && < 1.2,-                       SVGFonts >= 1.4 && < 1.5+                       SVGFonts >= 1.4 && < 1.5,+                       vector-space >= 0.8   hs-source-dirs:      src   ghc-options:         -Wall 

@@ -61,6 +61,8 @@ handle f AfternoonSkyscrapers = f R.afternoonskyscrapers D.afternoonskyscrapers handle f CountNumbers         = f R.countnumbers        D.countnumbers handle f Tapa                 = f R.tapa                D.tapa+handle f JapaneseSums         = f R.japanesesums        D.japanesesums+handle f Coral                = f R.coral               D.coral  -- | Handler that parses a puzzle from a YAML value, and renders. drawPuzzle :: PuzzleHandler b (Value -> Parser (Diagram b R2))

@@ -55,3 +55,6 @@  newtype TapaClue = TapaClue [Int]     deriving Show++data JapVal = JapBlack | JapInt Int+    deriving Show

@@ -9,6 +9,7 @@ import Data.Foldable (Foldable, fold) import Data.Traversable (Traversable, traverse) import Control.Applicative ((<$>))+import Data.VectorSpace  import Data.Puzzles.GridShape hiding (size, cells) import qualified Data.Puzzles.GridShape as GS@@ -86,18 +87,30 @@  -- | Clues along the outside of a square grid. data OutsideClues a = OC { left :: [a], right :: [a], bottom :: [a], top :: [a] }-    deriving Show+    deriving (Show, Eq) +instance Functor OutsideClues where+    fmap f (OC l r b t) = OC (fmap f l) (fmap f r) (fmap f b) (fmap f t)++outsideSize :: OutsideClues a -> (Int, Int)+outsideSize (OC l _ _ t) = (length t, length l)+ -- | Convert outside clues to association list mapping coordinate to value.-outsideclues :: OutsideClues (Maybe a) -> [((Int, Int), a)]-outsideclues (OC l r b t) = mapMaybe liftMaybe . concat $+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                              ]   where-    w = length b-    h = length l+    (w, h) = outsideSize o     liftMaybe (p, Just x)  = Just (p, x)     liftMaybe (_, Nothing) = Nothing++multiOutsideClues :: OutsideClues [a] -> [((Int, Int), a)]+multiOutsideClues = concatMap distrib . outsideClues . fmap Just . dired+  where+    dired (OC l r b t) = OC (z (-1,0) l) (z (1,0) r) (z (0,-1) b) (z (0,1) t)+    z x ys = zip (repeat x) ys+    distrib (o, (d, xs)) = zip [o ^+^ i *^ d | i <- [0..]] xs

@@ -35,6 +35,8 @@                 | AfternoonSkyscrapers                 | CountNumbers                 | Tapa+                | JapaneseSums+                | Coral     deriving (Show, Eq)  typeNames :: [(PuzzleType, String)]@@ -62,6 +64,8 @@             , (AfternoonSkyscrapers, "afternoonskyscrapers")             , (CountNumbers, "countnumbers")             , (Tapa, "tapa")+            , (JapaneseSums, "japanesesums")+            , (Coral, "coral")             ]  -- | Look up a puzzle type by name.

@@ -4,11 +4,18 @@     PuzzleSol,     RenderPuzzle,     OutputChoice(..),-    draw+    draw,+    Unit(..),+    diagramWidth,+    toOutputWidth,   ) where  import Diagrams.Prelude+import Diagrams.BoundingBox +import Diagrams.Puzzles.Lib+import Diagrams.Puzzles.Widths+ type RenderPuzzle b p s = (p -> Diagram b R2, (p, s) -> Diagram b R2)  type PuzzleSol b = (Diagram b R2, Maybe (Diagram b R2))@@ -21,6 +28,38 @@ draw :: (Backend b R2, Renderable (Path R2) b) =>         PuzzleSol b -> OutputChoice -> Maybe (Diagram b R2) draw (p, ms) = fmap (bg white) . d-    where d DrawPuzzle   = Just p-          d DrawSolution = ms-          d DrawExample  = ms >>= \s -> return $ p ||| strutX 2.0 ||| s+  where+    fixup = alignPixel . border borderwidth+    d DrawPuzzle   = Just (fixup p)+    d DrawSolution = fixup <$> ms+    d DrawExample  = ms >>= \s -> return $ fixup p ||| strutX 2.0 ||| fixup s++data Unit = Pixels | Points++cmtopoint :: Double -> Double+cmtopoint = (* 28.3464567)++diagramWidth :: Diagram b R2 -> Double+diagramWidth = fst . unr2 . boxExtents . boundingBox++toOutputWidth :: Unit -> Double -> Double+toOutputWidth u w = case u of Pixels -> fromIntegral wpix+                              Points -> wpt+  where+    wpix = round (gridresd * w) :: Int  -- grid square size 40px+    wpt = cmtopoint (0.8 * w)     -- grid square size 0.8cm++alignPixel :: (Backend b R2, Renderable (Path R2) b) => Diagram b R2 -> Diagram b R2+alignPixel = scale (1/gridresd) . align' . scale gridresd+  where+    align' d = maybe id grow (getCorners $ boundingBox d) $ d+    grow (bl, tr) = mappend $ phantoml (nudge bl False) (nudge tr True)+    nudge p dir = let (px, py) = unp2 p in p2 (nudge' px dir, nudge' py dir)+    nudge' x True  = fromIntegral (ceiling (x - 0.5) :: Int) + 0.5+    nudge' x False = fromIntegral (floor   (x + 0.5) :: Int) - 0.5+    phantoml p q = phantom' $ p ~~ q++-- | Add a phantom border of the given width around a diagram.+border :: (Backend b R2, Renderable (Path R2) b) => Double -> Diagram b R2 -> Diagram b R2+border w = extrudeEnvelope (w *^ unitX) . extrudeEnvelope (-w *^ unitX)+         . extrudeEnvelope (w *^ unitY) . extrudeEnvelope (-w *^ unitY)

@@ -142,6 +142,8 @@     south = strokeLocLoop shape # lw 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) =>                 TapaClue -> Diagram b R2 drawTapaClue (TapaClue [x]) = drawInt x@@ -152,7 +154,7 @@   where     p n = centerXY (p' n)     p' 2 = p2 (-1/4, 1/4) ~~ p2 (1/4, -1/4)-    p' 3 = reflectX . rotate (1/6 @@ turn) $ triangle 0.8-    p' 4 = rotate (1/8 @@ turn) $ square 0.7+    p' 3 = reflectX . rotateBy (1/6) $ triangle 0.8+    p' 4 = reflectX . rotateBy (3/8) $ square 0.7     p' 1 = error "singleton clues handled separately"     p' _ = error "invalid tapa clue"

@@ -19,8 +19,8 @@ -- | Draw a Slither Link style grid of dots of the specified size. slithergrid :: (Backend b R2, Renderable (Path R2) b) =>                Size -> Diagram b R2-slithergrid s@(x, y) = dots <> phantom' (border s)-    where dots = hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot+slithergrid (x, y) =+    hcatsep . replicate (x + 1) . vcatsep . replicate (y + 1) $ dot  -- | The inner grid lines of a square grid of the specified size. gridlines :: Size -> Path R2@@ -46,7 +46,6 @@ grid' gridstyle s =     outframe s     <> stroke (gridlines s) # lw gridwidth # gridstyle-    <> phantom' (border s)  -- | Draw a square grid with default grid line style. grid :: (Backend b R2, Renderable (Path R2) b) =>@@ -76,7 +75,7 @@ --   of cells given by coordinates. atCentres :: (Transformable a, Monoid a, V a ~ R2) =>              (t -> a) -> [(Coord, t)] -> a-atCentres dc = translate (r2 (0.5, 0.5)) . atVertices dc+atCentres dc = translate (r2 (1/2, 1/2)) . atVertices dc  atCentres' :: (Transformable a, V a ~ R2) => SGrid a -> [a] atCentres' = translate (r2 (1/2, 1/2)) . atVertices'@@ -89,14 +88,6 @@  atVertices' :: (Transformable a, V a ~ R2) => SGrid a -> [a] atVertices' g = [ (g ! c) # translatep c | c <- cells g ]---- | Frame a rectangle of the given size with a border of width---   'borderwidth'.-border :: (Backend b R2, Renderable (Path R2) b) => Size -> Diagram b R2-border (w, h) = stroke . translate (r2 (-bw, -bw)) . alignBL-               $ rect (fromIntegral w + 2 * bw) (fromIntegral h + 2 * bw)-  where-    bw = borderwidth  edge :: Edge -> Path R2 edge (E c d) = rule d # translate (r2i c)

@@ -63,14 +63,13 @@                  (t -> Diagram b R2) -> SGrid (Tightfit t) -> Diagram b R2 drawTightGrid d g = atCentres (drawTight d) (values g)                     <> grid (size g)-                    <> phantom' (border (sx + 2, sy + 2) # translate (r2 (-1,-1)))+                    <> phantom' (stroke $ p2i (-1,-1) ~~ p2i (sx + 1, sy + 1))     where (sx, sy) = size g  drawSlalomGrid :: (Backend b R2, Renderable (Path R2) b) =>                   SGrid (Clue Int) -> Diagram b R2 drawSlalomGrid g = atVertices drawSlalomClue (clues g)                    <> grid (w-1, h-1)-                   <> phantom' (border (size g)) # translate (r2 (-1/2,-1/2))     where (w, h) = size g  drawSlalomDiags :: (Backend b R2, Renderable (Path R2) b) =>@@ -84,3 +83,8 @@ drawCrosses = atCentres (if' drawCross mempty) . values   where     if' a b x = if x then a else b++outsideIntGrid :: (Backend b R2, Renderable (Path R2) b) =>+                  OutsideClues [Int] -> Diagram b R2+outsideIntGrid = atCentres (scale 0.8 . drawInt) . multiOutsideClues+                 <> grid . outsideSize

@@ -6,10 +6,11 @@     sudoku, thermosudoku, pyramid, kpyramid, slither,     liarslither, tightfitskyscrapers, wordloop, wordsearch,     curvedata, doubleback, slalom, compass, boxof2or3,-    afternoonskyscrapers, countnumbers, tapa,+    afternoonskyscrapers, countnumbers, tapa, japanesesums,+    coral,   ) where -import Diagrams.Prelude hiding (Loop)+import Diagrams.Prelude hiding (Loop, coral)  import Diagrams.Puzzles.PuzzleGrids import Diagrams.Puzzles.Draw@@ -112,9 +113,9 @@                        RenderPuzzle b (OutsideClues (Maybe Int), SGrid (Tightfit ()))                                       (SGrid (Tightfit Int)) tightfitskyscrapers = (,)-    (atCentres drawInt . outsideclues . fst+    (atCentres drawInt . outsideClues . fst      <> drawTightGrid (const mempty) . snd)-    (atCentres drawInt . outsideclues . fst . fst+    (atCentres drawInt . outsideClues . fst . fst      <> drawTightGrid drawInt . snd)  wordgrid :: (Backend b R2, Renderable (Path R2) b) =>@@ -186,3 +187,19 @@     (tapaGrid . fst <> drawShadedGrid . snd)   where     tapaGrid = atCentres drawTapaClue . values <> grid . size++japanesesums :: (Backend b R2, Renderable (Path R2) b) =>+                RenderPuzzle b (OutsideClues [Int]) (SGrid JapVal)+japanesesums = (,)+    outsideIntGrid+    (japcells . snd <> outsideIntGrid . fst)+  where+    japcells = atCentres japcell . values+    japcell JapBlack = fillBG gray+    japcell (JapInt x) = drawInt x++coral :: (Backend b R2, Renderable (Path R2) b) =>+                RenderPuzzle b (OutsideClues [Int]) ShadedGrid+coral = (,)+    outsideIntGrid+    (drawShadedGrid . snd <> outsideIntGrid . fst)

@@ -9,7 +9,6 @@ import Data.Puzzles.Pyramid import Diagrams.Puzzles.Lib import Diagrams.Puzzles.Widths-import Diagrams.Puzzles.Grid (border)  pgray :: Colour Double pgray = blend 0.6 white black@@ -28,8 +27,7 @@ row (R cs s) = centerX . hcat . map (cellc s) $ cs  pyramid :: (Backend b R2, Renderable (Path R2) b) => Pyramid -> Diagram b R2-pyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map row . unPyr $ p)-    where s = psize p+pyramid = alignBL . vcat . map row . unPyr  kropki :: (Backend b R2, Renderable (Path R2) b) => KropkiDot -> Diagram b R2 kropki None = mempty@@ -46,5 +44,4 @@           dots = interleave (map phantom' clues') (map kropki ks)  kpyramid :: (Backend b R2, Renderable (Path R2) b) => RowKropkiPyramid -> Diagram b R2-kpyramid p = phantom' (border (s, s)) <> (alignBL . vcat . map krow . unKP $ p)-    where s = psize (plainpyramid p)+kpyramid = alignBL . vcat . map krow . unKP

@@ -3,6 +3,9 @@ gridres :: Int gridres = 40 +gridresd :: Double+gridresd = fromIntegral gridres+ onepix :: Double onepix = 1 / fromIntegral gridres @@ -18,4 +21,4 @@  edgewidth, borderwidth :: Double edgewidth = 3 * onepix-borderwidth = 1 / 4 + onepix / 2+borderwidth = 1 / 2

@@ -5,7 +5,7 @@     sudoku, thermosudoku, pyramid, kpyramid, slither,     liarslither, tightfitskyscrapers, wordloop, wordsearch,     curvedata, doubleback, slalom, compass, boxof2or3,-    afternoonskyscrapers, countnumbers, tapa,+    afternoonskyscrapers, countnumbers, tapa, japanesesums, coral,   ) where  import Prelude hiding (sequence)@@ -123,5 +123,11 @@ countnumbers = (parseGrid, parseGrid)  tapa :: ParsePuzzle (SGrid TapaClue) ShadedGrid-tapa = (\v -> unRG <$> parseJSON v,+tapa = (\v -> fmap unParseTapaClue . unRG <$> parseJSON v,         parseShadedGrid)++japanesesums :: ParsePuzzle (OutsideClues [Int]) (SGrid JapVal)+japanesesums = (parseMultiOutsideClues, parseGrid)++coral :: ParsePuzzle (OutsideClues [Int]) ShadedGrid+coral = (parseMultiOutsideClues, parseShadedGrid)

@@ -9,7 +9,7 @@ import Control.Monad hiding (sequence)  import Data.Hashable-import Data.Maybe (catMaybes)+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)@@ -245,6 +245,10 @@                 | 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 --  ┌┐┌─┐ --  ││└┐│@@ -397,7 +401,17 @@     splitBorder (Square w h) = Map.partitionWithKey         (\(x, y) _ -> x < w - 1 && y < h - 1) -instance FromJSON TapaClue where+newtype ParseTapaClue = ParseTapaClue { unParseTapaClue :: TapaClue }++instance FromJSON ParseTapaClue where     parseJSON v = do xs <- parseJSON v                      guard $ length xs > 0 && length xs <= 4-                     return $ TapaClue xs+                     return . ParseTapaClue . TapaClue $ xs++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)+parseMultiOutsideClues _ = empty

@@ -8,10 +8,11 @@  import Text.Puzzles.Puzzle import Data.Puzzles.Elements (Thermometer)-import Text.Puzzles.Util (parseChar)+import Text.Puzzles.Util (parseChar, parseMultiOutsideClues) import Text.Puzzles.PuzzleTypes import qualified Data.Puzzles.Grid as Grid import Data.Puzzles.Pyramid (PyramidSol(..))+import Data.Puzzles.Grid (multiOutsideClues, OutsideClues(..))  import Diagrams.Puzzles.PuzzleGrids import Diagrams.Prelude@@ -27,7 +28,7 @@  tests :: TestTree tests = testGroup "Tests"-    [ parseUtilTests, parseTests, parseDataTests, renderTests ]+    [ parseUtilTests, parseTests, parseDataTests, renderTests, dataTests ]  testParsePzl, testParseSol, testNonparsePzl, testNonparseSol ::     (Show a, Show b) => String -> ParsePuzzle a b -> Value -> TestTree@@ -109,6 +110,13 @@     test_content (PyramidSol rs) =         rs == [[3], [8,5], [1,9,4], [3,2,7,3], [1,2,4,3,6]] +test_multioutside :: Assertion+test_multioutside = Right oc @=? res+  where+    res = parseEither parseMultiOutsideClues multioutside+    oc = OC [[3], [1, 2]] [[1, 0], []] [[0, 0, 1]] [[1, -1]]+         :: OutsideClues [Int]+ parseDataTests :: TestTree parseDataTests = testGroup "Parsing tests (full puzzles, result checks)"     [ testCase "parse tightfit, correct size" $ test_tightfit_1 @? "error in puzzle"@@ -120,6 +128,7 @@                                             [ [(0, 1), (1, 0), (2, 0)]                                             , [(0, 2), (1, 3), (2, 4)]                                             , [(4, 0), (4, 1), (3, 2)] ]+    , testCase "parse multioutsideclues" $ test_multioutside     ]  -- this used to cause a rendering crash, though it's@@ -137,4 +146,21 @@ renderTests = testGroup "Rendering tests"     [ testCase "don't break rendering invalid slalom solution"          $ testBreakSlalom @? "just testing against errors"+    ]++testMultiOutsideClues :: Assertion+testMultiOutsideClues = multiOutsideClues (OC l r b t) `sorteq` res+  where+    sorteq xs ys = sort xs @?= sort ys+    l = [[1, 2], [3]]+    r = [[], [1, 0]]+    b = [[0, 0, 1]]+    t = [[1, -1]]+    res = [ ((-1,0), 1), ((-2,0), 2), ((-1,1), 3),+            ((1,1), 1), ((2,1), 0), ((0,-1), 0), ((0,-2), 0), ((0,-3), 1),+            ((0,2), 1), ((0,3), -1) ] :: [((Int, Int), Int)]++dataTests :: TestTree+dataTests = testGroup "Generic tests for the Data modules"+    [ testCase "multiOutsideClues" testMultiOutsideClues     ]