Merge pull request #53 from robx/multislither

convert multi slither to pzg

CHANGES.md

@@ -3,6 +3,7 @@
   - horsesnake
   - starwars
   - pentopipes
+  - slithermulti
 * PZG changes:
   - Add `fullgrid` grid type.
   - Add edge decorations

src/Data/Component.hs

@@ -13,7 +13,8 @@ data Component a =
   | CellGrid !(Grid C Decoration)
   | EdgeGrid !(Map.Map (Edge N) Decoration)
   | FullGrid !(Grid N Decoration) !(Grid C Decoration) !(Map.Map (Edge N) Decoration)
-  | RawComponent !a
+  | Note [Decoration]
+  | RawComponent !Size !a
 
 data Tag =
     Puzzle
@@ -27,6 +28,7 @@ data Placement =
     Atop
   | West
   | North
+  | TopRight
  deriving (Eq, Show)
 
 data PlacedComponent a = PlacedComponent Placement (Component a)
@@ -78,3 +80,5 @@ data Decoration =
   | TriangleDown
   | LabeledTriangleRight String
   | LabeledTriangleDown String
+  | MiniLoop
+

src/Data/Compose.hs

@@ -66,7 +66,6 @@ handle f BlackoutDominos     = f R.blackoutDominos D.blackoutDominos
 handle f TwilightTapa        = f R.tapa D.tapa
 handle f TapaCave            = f R.tapa D.tapa
 handle f DominoPillen        = f R.dominoPills D.dominoPills
-handle f SlitherLinkMulti    = f R.slithermulti D.slithermulti
 handle f AngleLoop           = f R.angleLoop D.angleLoop
 handle f Shikaku             = f R.shikaku D.shikaku
 handle f SlovakSums          = f R.slovaksums D.slovaksums

src/Data/Grid.hs

@@ -9,6 +9,9 @@ module Data.Grid
   , ShadedGrid
   , nodes
   , size
+  , cellSize
+  , nodeSize
+  , edgeSize
   , sizeGrid
   , clues
   , nodeGrid
@@ -242,10 +245,23 @@ dominoGrid (DigitRange x y) =
     $ [ ((a, s - b), (b + x, a + x)) | a <- [0 .. s], b <- [0 .. s], b <= a ]
   where s = y - x
 
-size :: Grid Coord a -> Size
-size m = foldr (both max) (0, 0) (Map.keys m) ^+^ (1, 1)
+listSize :: [Coord] -> Size
+listSize cs = foldr (both max) (0, 0) cs
   where both f (x, y) (x', y') = (f x x', f y y')
 
+size :: Grid Coord a -> Size
+size = (^+^) (1, 1) . listSize . Map.keys
+
+cellSize :: Grid C a -> Size
+cellSize = size . Map.mapKeys toCoord
+
+nodeSize :: Grid N a -> Size
+nodeSize = (^+^) (-1, -1) . size . Map.mapKeys toCoord
+
+edgeSize :: Map.Map (Edge N) a -> Size
+edgeSize =
+  listSize . map toCoord . concatMap ((\(x, y) -> [x, y]) . ends) . Map.keys
+
 polyominoGrid :: [((Int, Int), Char)] -> [(Int, Int)] -> Grid C (Maybe Char)
 polyominoGrid ls ps =
   Map.mapKeys fromCoord

src/Data/GridShape.hs

@@ -28,7 +28,6 @@ module Data.GridShape
   , edges
   , edgesM
   , ends
-  , edgeSize
   , unorient
   , dualE
   , vertexNeighbours
@@ -172,10 +171,6 @@ ends' (E' x R) = (x, x .+^ (1, 0))
 ends' (E' x D) = (x, x .+^ (0, -1))
 ends' (E' x L) = (x, x .+^ (-1, 0))
 
-edgeSize :: [Edge N] -> Size
-edgeSize es = (maximum (map fst ps), maximum (map snd ps))
-  where ps = map toCoord . concatMap ((\(x, y) -> [x, y]) . ends) $ es
-
 revEdge :: (AffineSpace a, Diff a ~ (Int, Int)) => Edge' a -> Edge' a
 revEdge = uncurry edge' . swap . ends' where swap (x, y) = (y, x)
 

src/Data/PuzzleTypes.hs

@@ -44,7 +44,6 @@ data PuzzleType = LITS
                 | TwilightTapa
                 | TapaCave
                 | DominoPillen
-                | SlitherLinkMulti
                 | AngleLoop
                 | Shikaku
                 | SlovakSums
@@ -163,7 +162,6 @@ obscureTypes =
   [ (ColorAkari       , "color-akari")
   , (FillominoLoop    , "fillomino-loop")
   , (DominoPillen     , "domino-pillen")
-  , (SlitherLinkMulti , "slitherlink-multi")
   , (TapaCave         , "tapa-cave")
   , (WordLoop         , "wordloop")
   , (RowKropkiPyramid , "rowkropkipyramid")

src/Draw/Code.hs

@@ -34,7 +34,9 @@ drawCode cs = concat [collect Atop, collect West, collect North]
   collect p =
     let matching = map snd . filter ((==) p . fst) $ parts
     in  if null matching then [] else [comp p $ mconcat matching]
-  comp p d = TaggedComponent (Just Code) $ PlacedComponent p $ RawComponent $ d
+  fakeSize = (0, 0) -- should be the dimensions of the code part
+  comp p d =
+    TaggedComponent (Just Code) $ PlacedComponent p $ RawComponent fakeSize $ d
 
 drawCodePart :: Backend' b => CodePart -> (Placement, Drawing b)
 drawCodePart cp = case cp of

src/Draw/Component.hs

@@ -10,6 +10,8 @@ import           Diagrams.Prelude        hiding ( dot
 
 import           Data.Component
 import           Data.Elements
+import           Data.Grid
+import           Data.GridShape
 import           Draw.Lib
 import           Draw.Draw
 import           Draw.Grid
@@ -18,35 +20,49 @@ import           Draw.Elements
 import           Draw.Code
 
 drawComponents :: Backend' b => [PlacedComponent (Drawing b)] -> Drawing b
-drawComponents cs = go $ reverse cs
+drawComponents cs = snd $ go $ reverse cs
  where
-  go [] = mempty
-  go ((PlacedComponent p c) : pcs) =
-    let dc  = drawComponent c
-        dcs = go pcs
-    in  case p of
-          Atop  -> dc <> dcs
-          West  -> dcs |!| strutX' 0.5 |!| dc
-          North -> dcs =!= strutY' 0.5 =!= dc
+  go [] = ((0 :: Int, 0 :: Int), mempty)
+  go ((PlacedComponent p c) : pcs)
+    = let
+        (tl , dc ) = drawComponent c
+        (tls, dcs) = go pcs
+        ntl        = (max (fst tl) (fst tls), max (snd tl) (snd tls))
+      in
+        case p of
+          Atop  -> (ntl, dc <> dcs)
+          West  -> (ntl, dcs |!| strutX' 0.5 |!| dc)
+          North -> (ntl, dcs =!= strutY' 0.5 =!= dc)
+          TopRight ->
+            ( ntl
+            , (dc # alignBL' # translatep tls # translate (r2 (0.6, 0.6)))
+              <> dcs
+            )
   (=!=) = beside unitY
   (|!|) = beside (negated unitX)
 
-drawComponent :: Backend' b => Component (Drawing b) -> Drawing b
+drawComponent :: Backend' b => Component (Drawing b) -> (Size, Drawing b)
 drawComponent c = case c of
-  RawComponent x -> x
+  RawComponent sz x -> (sz, x)
   Grid s g ->
     let st = case s of
           GridDefault          -> gDefault
           GridDefaultIrregular -> gDefaultIrreg
           GridDashed           -> gDashed
           GridDots             -> gSlither
-    in  grid st g
-  Regions  g -> drawAreas g
-  CellGrid g -> placeGrid . fmap drawDecoration $ g
-  NodeGrid g -> placeGrid . fmap drawDecoration $ g
-  EdgeGrid g -> placeGrid' . Map.mapKeys midPoint . fmap drawDecoration $ g
+    in  (cellSize g, grid st g)
+  Regions  g -> (cellSize g, drawAreas g)
+  CellGrid g -> (cellSize g, placeGrid . fmap drawDecoration $ g)
+  NodeGrid g -> (nodeSize g, placeGrid . fmap drawDecoration $ g)
+  EdgeGrid g ->
+    (edgeSize g, placeGrid' . Map.mapKeys midPoint . fmap drawDecoration $ g)
   FullGrid ns cs es ->
-    mconcat . map drawComponent $ [NodeGrid ns, CellGrid cs, EdgeGrid es]
+    ( nodeSize ns
+    , mconcat
+      . map (snd . drawComponent)
+      $ [NodeGrid ns, CellGrid cs, EdgeGrid es]
+    )
+  Note ds -> ((0, 0), note $ hcatSep 0.2 $ map drawDecoration $ ds)
 
 drawDecoration :: Backend' b => Decoration -> Drawing b
 drawDecoration d = case d of
@@ -70,4 +86,5 @@ drawDecoration d = case d of
   TriangleDown           -> arrowDown
   LabeledTriangleRight w -> arrowRightL w
   LabeledTriangleDown  w -> arrowDownL w
+  MiniLoop               -> miniloop
 

src/Draw/Lib.hs

@@ -26,15 +26,12 @@ vline n = strokeLine . fromVertices . map p2 $ [(0, 0), (0, n)]
 hline n = strokeLine . fromVertices . map p2 $ [(0, 0), (n, 0)]
 
 -- | Variant of 'hcat'' that spreads with distance @1@.
-hcatsep
-  :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a
-hcatsep = hcat' with { _sep = 1 }
-
--- | Variant of 'vcat'' that spreads with distance @1@,
--- and stacks towards the top.
-vcatsep
-  :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a
-vcatsep = cat' (r2 (0, 1)) with { _sep = 1 }
+hcatSep
+  :: (InSpace V2 Double a, Juxtaposable a, HasOrigin a, Monoid' a)
+  => Double
+  -> [a]
+  -> a
+hcatSep s = hcat' with { _sep = s }
 
 -- | Collapse the envelope to a point.
 smash :: Backend' b => Diagram b -> Diagram b

src/Draw/PuzzleTypes.hs

@@ -47,7 +47,6 @@ module Draw.PuzzleTypes
   , skyscrapersStars
   , fillominoCheckered
   , numberlink
-  , slithermulti
   , dominoPills
   , fillominoLoop
   , loopki
@@ -251,14 +250,6 @@ liarslither = Drawers
   .  snd
   )
 
-slithermulti :: Backend' b => Drawers b (Grid C (Maybe Int), Int) [Edge N]
-slithermulti = Drawers
-  (drawSlitherGrid . fst <> n)
-  (drawSlitherGrid . fst . fst <> solstyle . drawEdges . snd)
- where
-  n (g, l) = placeNoteTR (size' g) (drawInt l ||| strutX' 0.2 ||| miniloop)
-  size' = size . Map.mapKeys toCoord
-
 tightfitskyscrapers
   :: Backend' b
   => Drawers
@@ -758,7 +749,7 @@ kropki = Drawers (p <> n) (placeGrid . fmap drawInt . snd <> p . fst)
    where
     (w, h) = sz g
     ds     = "1-" ++ show h
-  sz m = edgeSize (Map.keys m)
+  sz m = edgeSize m
 
 statuepark :: Backend' b => Drawers b (Grid C (Maybe MasyuPearl)) (Grid C Bool)
 statuepark = Drawers p (p . fst <> drawShade . snd)

src/Draw/Render.hs

@@ -89,15 +89,17 @@ decodeAndDraw params b = case backend fmt of
     t'          <- checkType (mrt `mplus` mt)
     (pzl, msol) <- parseEither (compose t') (p, ms)
     let
+      fakeSize = (0, 0)
       pc =
         [ TaggedComponent (Just Puzzle) $ PlacedComponent Atop $ RawComponent
+            fakeSize
             pzl
         ]
       sc = case msol of
         Just sol ->
           [ TaggedComponent (Just Solution)
               $ PlacedComponent Atop
-              $ RawComponent sol
+              $ RawComponent fakeSize sol
           ]
         Nothing -> []
     return $ concat [pc, sc, codeComponents]

src/Parse/Component.hs

@@ -23,6 +23,7 @@ parseComponent = withObject "Component" $ \o -> do
     "cells"   -> CellGrid <$> parseCellGrid o
     "edges"   -> EdgeGrid <$> parseEdgeGrid o
     "full"    -> parseFullGrid o
+    "note"    -> Note <$> parseNote o
     _         -> fail $ "unknown component type: " ++ t
   pure $ TaggedComponent tag (PlacedComponent place c)
 
@@ -40,10 +41,11 @@ parsePlacement :: Object -> Parser Placement
 parsePlacement o = do
   p <- o .:? "place" :: Parser (Maybe String)
   case p of
-    Nothing      -> pure Atop
-    Just "north" -> pure North
-    Just "west"  -> pure West
-    Just x       -> fail $ "unknown placement: " ++ x
+    Nothing          -> pure Atop
+    Just "north"     -> pure North
+    Just "west"      -> pure West
+    Just "top-right" -> pure TopRight
+    Just x           -> fail $ "unknown placement: " ++ x
 
 parseGrid :: Object -> Parser (Component a)
 parseGrid o = do
@@ -88,6 +90,11 @@ parseFullGrid o = do
   (ns, cs, es) <- Util.parseEdgeGridWith pdec pdec pdec g
   return $ FullGrid ns cs es
 
+parseNote :: Object -> Parser [Decoration]
+parseNote o = do
+  ds <- o .: "contents"
+  sequence . map parseExtendedDecoration $ ds
+
 parseReplacements :: Object -> Parser (Map.Map Char Decoration)
 parseReplacements o = do
   ms <- o .:? "substitute"
@@ -111,6 +118,8 @@ parseDecoration c = return $ case c of
   '#'  -> Shade
   '-'  -> Edge Horiz
   '|'  -> Edge Vert
+  '>'  -> TriangleRight
+  'v'  -> TriangleDown
   _    -> Letter c
 
 parseExtendedDecoration :: Util.IntString -> Parser Decoration
@@ -142,6 +151,7 @@ parseExtendedDecoration (Util.IntString s) = case words s of
     "shade"                  -> pure $ Shade
     "triangle-right"         -> pure $ TriangleRight
     "triangle-down"          -> pure $ TriangleDown
+    "miniloop"               -> pure $ MiniLoop
     _                        -> pure $ Letters s
   [w1, w2] -> case w1 of
     "triangle-right" -> pure $ LabeledTriangleRight w2

src/Parse/PuzzleTypes.hs

@@ -43,7 +43,6 @@ module Parse.PuzzleTypes
   , dominos
   , skyscrapersStars
   , numberlink
-  , slithermulti
   , dominoPills
   , fillominoLoop
   , loopki
@@ -149,14 +148,6 @@ kpyramid = (parseJSON, parseJSON)
 slither :: ParsePuzzle (Grid C (Clue Int)) (Loop N)
 slither = (parseClueGrid, parseEdges)
 
-slithermulti :: ParsePuzzle (Grid C (Clue Int), Int) [Edge N]
-slithermulti = (p, parseEdges)
- where
-  p v =
-    (,)
-      <$> parseFrom ["grid"]  parseClueGrid v
-      <*> parseFrom ["loops"] parseJSON     v
-
 newtype LSol = LSol { unLSol :: (Loop N, Grid C Bool) }
 instance FromJSON LSol where
     parseJSON (Object v) = LSol <$> ((,) <$>

tests/Data/GridShapeSpec.hs

@@ -12,9 +12,6 @@ import           Data.List                      ( sort )
 
 spec :: Spec
 spec = do
-  describe "edgeSize" $ do
-    it "computes the size in cells" $ do
-      edgeSize [E (N 1 1) Vert, E (N 2 1) Horiz] `shouldBe` (3, 2)
   describe "rows" $ do
     it "computes the rows for a simple grid" $ do
       sort

tests/Data/GridSpec.hs

@@ -61,3 +61,4 @@ spec = do
             [((C 1 1), 1 :: Int), ((C 1 2), 2), ((C 2 1), 1), ((C 2 2), 3)]
       let count = length . nub . sort . Map.elems
       count (colour (Map.fromList input)) `shouldBe` 3
+

tests/Parse/PuzzleTypesSpec.hs

@@ -1,7 +1,6 @@
 module Parse.PuzzleTypesSpec where
 
 import           Data.Maybe                     ( isJust )
-import qualified Data.Map.Strict               as Map
 import           Data.Yaml
 import           Data.Text.Encoding             ( encodeUtf8 )
 import qualified Data.ByteString               as B
@@ -14,7 +13,7 @@ import           Test.Hspec                     ( Spec
                                                 , shouldSatisfy
                                                 )
 
-import           Data.GridShape                 ( edgeSize )
+import           Data.Grid                      ( edgeSize )
 import           Data.Elements                  ( DigitRange(..) )
 import           Parse.PuzzleTypes
 
@@ -60,4 +59,4 @@ spec = do
           res = parse p y
       res `shouldSatisfy` isJust
       let Just m = res
-      edgeSize (Map.keys m) `shouldBe` (3, 2)
+      edgeSize m `shouldBe` (3, 2)