From 985227aa6442905b2db69fa53d5ee5a96e1998df Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 3 Jan 2020 12:14:30 +0100 Subject: [PATCH] re-britannize --- src/Draw/Component.hs | 68 +++++++++++----------- src/Draw/Elements.hs | 15 +++-- src/Draw/Grid.hs | 3 +- src/Draw/PuzzleGrids.hs | 8 +-- src/Draw/PuzzleTypes.hs | 125 +++++++++++----------------------------- src/Parse/Component.hs | 26 ++++----- 6 files changed, 90 insertions(+), 155 deletions(-) diff --git a/src/Draw/Component.hs b/src/Draw/Component.hs index 259b806..1984346 100644 --- a/src/Draw/Component.hs +++ b/src/Draw/Component.hs @@ -58,9 +58,7 @@ component c = case c of (edgeSize g, placeGrid' . Map.mapKeys midPoint . fmap decoration $ g) FullGrid ns cs es -> ( nodeSize ns - , mconcat - . map (snd . component) - $ [NodeGrid ns, CellGrid cs, EdgeGrid es] + , mconcat . map (snd . component) $ [NodeGrid ns, CellGrid cs, EdgeGrid es] ) Note ds -> ((0, 0), note $ hcatSep 0.2 $ map decoration $ ds) Pyramid g -> (shiftSize g, shiftGrid g) @@ -76,36 +74,36 @@ component c = case c of decoration :: Backend' b => Decoration -> Drawing b decoration d = case d of - Blank -> mempty - Letter c -> char c - Letters s -> text' s - InvertedLetters s -> invert $ text' s - DecKropkiDot k -> kropkiDot k - AfternoonSouth -> afternoonSouth - AfternoonWest -> afternoonWest - LightDiagonal diag -> lc (blend 0.5 gray white) $ primeDiag diag - DarkDiagonal diag -> lc gray $ primeDiag diag - SmallDot -> dot - Dot -> scale 0.5 $ smallPearl MBlack - Star -> star Data.Elements.Star - Shade -> fillBG gray - DarkShade -> fillBG (blend 0.5 gray black) - Black -> fillBG black - LightShade -> fillBG (blend 0.5 gray white) - SmallPearl p -> smallPearl p - Pearl p -> pearl p - Edge dir -> edgeDecoration dir - ThinEdge dir -> edgeDecorationThin dir - SolEdge dir -> edgeDecorationSol dir - TriangleRight -> arrowRight - TriangleDown -> arrowDown - LabeledTriangleRight w -> arrowRightL w - LabeledTriangleDown w -> arrowDownL w - MiniLoop -> miniloop - ShipSquare -> shipSquare - Ship dir -> shipEnd dir - LabeledArrow dir w -> labeledArrow dir $ text' w + Blank -> mempty + Letter c -> char c + Letters s -> text' s + InvertedLetters s -> invert $ text' s + DecKropkiDot k -> kropkiDot k + AfternoonSouth -> afternoonSouth + AfternoonWest -> afternoonWest + LightDiagonal diag -> lc (blend 0.5 gray white) $ primeDiag diag + DarkDiagonal diag -> lc gray $ primeDiag diag + SmallDot -> dot + Dot -> scale 0.5 $ smallPearl MBlack + Star -> star Data.Elements.Star + Shade -> fillBG gray + DarkShade -> fillBG (blend 0.5 gray black) + Black -> fillBG black + LightShade -> fillBG (blend 0.5 gray white) + SmallPearl p -> smallPearl p + Pearl p -> pearl p + Edge dir -> edgeDecoration dir + ThinEdge dir -> edgeDecorationThin dir + SolEdge dir -> edgeDecorationSol dir + TriangleRight -> arrowRight + TriangleDown -> arrowDown + LabeledTriangleRight w -> arrowRightL w + LabeledTriangleDown w -> arrowDownL w + MiniLoop -> miniloop + ShipSquare -> shipSquare + Ship dir -> shipEnd dir + LabeledArrow dir w -> labeledArrow dir $ text' w InvertedLabeledArrow dir w -> invert $ labeledArrow dir $ text' w - Tent -> draw tentDia - Tree -> tree Data.Elements.Tree - Myopia dirs -> myopia dirs + Tent -> draw tentDia + Tree -> tree Data.Elements.Tree + Myopia dirs -> myopia dirs diff --git a/src/Draw/Elements.hs b/src/Draw/Elements.hs index 2d75d1c..f83c1c7 100644 --- a/src/Draw/Elements.hs +++ b/src/Draw/Elements.hs @@ -89,8 +89,8 @@ compassClue (CC n e s w) = texts <> (draw $ stroke crossPath # lwG onepix) f = 3 / 10 slovakClue :: Backend' b => SlovakClue -> Drawing b -slovakClue (SlovakClue s c) = - centerY' (int s === draw (strutY 0.1) === dots c) <> fillBG gray +slovakClue (SlovakClue s c) = centerY' (int s === draw (strutY 0.1) === dots c) + <> fillBG gray where dots n = draw $ centerX $ hcat' with { _sep = 0.04 } (replicate n $ d) d = circle 0.1 # lwG 0.02 # fc white @@ -227,8 +227,7 @@ words ws = -- | Fit a line drawing into a unit square. -- For example, a Curve Data clue. curve :: Backend' b => [Edge N] -> Drawing b -curve = - draw . lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) +curve = draw . lwG onepix . fit 0.6 . centerXY . mconcat . map (stroke . edge) -- | Draw a shadow in the style of Afternoon Skyscrapers. afternoonSouth :: Backend' b => Drawing b @@ -248,8 +247,7 @@ afternoonWest = reflectAbout (p2 (0, 0)) (direction $ r2 (1, 1)) afternoonSouth -- left to right, top to bottom. tapaClue :: Backend' b => TapaClue -> Drawing b tapaClue (TapaClue [x]) = int x -tapaClue (TapaClue xs) = - fit' 0.8 . atPoints (p (length xs)) . map int $ xs +tapaClue (TapaClue xs ) = fit' 0.8 . atPoints (p (length xs)) . map int $ xs where p n = mconcat . pathVertices $ centerXY (p' n) p' 2 = p2 (-1 / 4, 1 / 4) ~~ p2 (1 / 4, -1 / 4) @@ -457,8 +455,9 @@ myopia = foldMap d' d R = a (0, 0) (1, 0) d D = a (0, 0) (0, -1) d L = a (0, 0) (-1, 0) - a p q = - arrowBetween' (with & arrowHead .~ tri & headLength .~ global 0.2) (p2 p) (p2 q) + a p q = arrowBetween' (with & arrowHead .~ tri & headLength .~ global 0.2) + (p2 p) + (p2 q) greaterClue :: Backend' b => GreaterClue -> [Drawing b] greaterClue [] = mempty diff --git a/src/Draw/Grid.hs b/src/Draw/Grid.hs index 961c278..22e0532 100644 --- a/src/Draw/Grid.hs +++ b/src/Draw/Grid.hs @@ -228,8 +228,7 @@ solstyle :: (HasStyle a, InSpace V2 Double a) => a -> a solstyle = lc (blend 0.8 black white) . lwG (3 * onepix) edges :: (ToPoint k, Backend' b) => [Edge k] -> Drawing b -edges es = - Drawing (\cfg -> edgeStyle cfg . stroke . mconcat . map edge $ es) +edges es = Drawing (\cfg -> edgeStyle cfg . stroke . mconcat . map edge $ es) dirPath :: Dir -> Path V2 Double dirPath dir = case dir of diff --git a/src/Draw/PuzzleGrids.hs b/src/Draw/PuzzleGrids.hs index 0c1eae4..7046d4f 100644 --- a/src/Draw/PuzzleGrids.hs +++ b/src/Draw/PuzzleGrids.hs @@ -72,11 +72,9 @@ sudokugrid = edges . sudokubordersg <> grid gDefault wordsClues :: Backend' b => Grid C (Maybe [String]) -> Drawing b wordsClues = placeGrid . fmap Draw.Elements.words . clues -tightGrid - :: Backend' b => (t -> Drawing b) -> Grid C (Tightfit t) -> Drawing b -tightGrid d g = - (placeGrid . fmap (tight d) $ g) <> grid gDefault g <> draw - (phantom' (strokePath $ p2i (-1, -1) ~~ p2i (sx + 1, sy + 1))) +tightGrid :: Backend' b => (t -> Drawing b) -> Grid C (Tightfit t) -> Drawing b +tightGrid d g = (placeGrid . fmap (tight d) $ g) <> grid gDefault g <> draw + (phantom' (strokePath $ p2i (-1, -1) ~~ p2i (sx + 1, sy + 1))) where (sx, sy) = size (Map.mapKeys toCoord g) maxDiam :: Backend' b => V2 Double -> Config -> [Drawing b] -> Double diff --git a/src/Draw/PuzzleTypes.hs b/src/Draw/PuzzleTypes.hs index a75993b..508e9bd 100644 --- a/src/Draw/PuzzleTypes.hs +++ b/src/Draw/PuzzleTypes.hs @@ -206,24 +206,8 @@ thermosudoku :: Backend' b => Drawers b (Grid C (Maybe Int), [Thermometer]) (Grid C (Maybe Int)) thermosudoku = Drawers - ( placeGrid - . fmap int - . clues - . fst - <> sudokugrid - . fst - <> thermos - . snd - ) - ( placeGrid - . fmap int - . clues - . snd - <> sudokugrid - . snd - <> thermos - . snd - . fst + (placeGrid . fmap int . clues . fst <> sudokugrid . fst <> thermos . snd) + (placeGrid . fmap int . clues . snd <> sudokugrid . snd <> thermos . snd . fst ) killersudoku @@ -246,8 +230,7 @@ kpyramid = Drawers DPyr.kpyramid (DPyr.kpyramid . merge) where merge (p, q) = Pyr.mergekpyramidsol p q slither :: Backend' b => Drawers b (Grid C (Maybe Int)) (Loop N) -slither = - Drawers slitherGrid (slitherGrid . fst <> solstyle . edges . snd) +slither = Drawers slitherGrid (slitherGrid . fst <> solstyle . edges . snd) liarslither :: Backend' b => Drawers b (Grid C (Maybe Int)) (Loop N, Grid C Bool) @@ -272,14 +255,8 @@ tightfitskyscrapers (OutsideClues C (Maybe Int), Grid C (Tightfit ())) (Grid C (Tightfit Int)) tightfitskyscrapers = Drawers - ( placeOutside - . fmap (fmap int) - . fst - <> tightGrid (const mempty) - . snd - ) - (placeOutside . fmap (fmap int) . fst . fst <> tightGrid int . snd - ) + (placeOutside . fmap (fmap int) . fst <> tightGrid (const mempty) . snd) + (placeOutside . fmap (fmap int) . fst . fst <> tightGrid int . snd) wordgrid :: Backend' b => Grid C (Maybe Char) -> [String] -> Drawing b wordgrid g ws = stackWords ws `besidesR'` charGrid g @@ -318,10 +295,9 @@ doubleback = Drawers p (solstyle . edges . snd <> p . fst) where p = grid gDefault <> areasGray slalom :: Backend' b => Drawers b (Grid N (Maybe Int)) (Grid C SlalomDiag) -slalom = Drawers - p - (p . fst <> placeGrid . fmap (solstyle . slalomDiag) . snd) - where p = placeGrid . fmap slalomClue . clues <> grid gDefault . Data.cellGrid +slalom = Drawers p (p . fst <> placeGrid . fmap (solstyle . slalomDiag) . snd) + where + p = placeGrid . fmap slalomClue . clues <> grid gDefault . Data.cellGrid compass :: Backend' b => Drawers b (Grid C (Maybe CompassC)) AreaGrid compass = Drawers @@ -337,15 +313,7 @@ compass = Drawers meanderingnumbers :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C (Maybe Int)) meanderingnumbers = Drawers - ( grid gDefault - . fst - <> areas - . fst - <> placeGrid - . fmap int - . clues - . snd - ) + (grid gDefault . fst <> areas . fst <> placeGrid . fmap int . clues . snd) (intGrid . snd <> areas . fst . fst) tapa :: Backend' b => Drawers b (Grid C (Maybe TapaClue)) ShadedGrid @@ -365,8 +333,7 @@ japanesesums = Drawers (outsideIntGrid . fst <> n) h = snd . Data.outsideSize coral :: Backend' b => Drawers b (OutsideClues C [String]) ShadedGrid -coral = - Drawers multiOutsideGrid (multiOutsideGrid . fst <> shade . snd) +coral = Drawers multiOutsideGrid (multiOutsideGrid . fst <> shade . snd) maximallengths :: Backend' b => Drawers b (OutsideClues C (Maybe Int)) (Loop C) maximallengths = Drawers g (solstyle . edges . snd <> g . fst) @@ -480,9 +447,8 @@ cave = Drawers skyscrapers :: Backend' b => Drawers b (OutsideClues C (Maybe Int), String) (Grid C (Maybe Int)) -skyscrapers = Drawers - (g . fst <> n) - (g . fst . fst <> placeGrid . fmap int . clues . snd) +skyscrapers = Drawers (g . fst <> n) + (g . fst . fst <> placeGrid . fmap int . clues . snd) where g = placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid n (oc, s) = placeNoteTR (Data.outsideSize oc) (text' s) @@ -494,9 +460,8 @@ shikaku = Drawers p (areas . snd <> p . fst) slovaksums :: Backend' b => Drawers b (Grid C (Maybe SlovakClue), String) (Grid C (Maybe Int)) -slovaksums = Drawers - (p . fst <> n) - (placeGrid . fmap int . clues . snd <> p . fst . fst) +slovaksums = Drawers (p . fst <> n) + (placeGrid . fmap int . clues . snd <> p . fst . fst) where n (g, ds) = placeNoteTR (size' g) (text' ds # scale noteScale) p = grid gDefault <> placeGrid . fmap slovakClue . clues @@ -509,7 +474,8 @@ skyscrapersStars = Drawers (g <> n) (g . fst <> placeGrid . fmap (either int star) . snd) where - g = (placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid) . fst + g = + (placeOutside . fmap (fmap int) <> grid gDefault . Data.outsideGrid) . fst n (oc, s) = placeNoteTR (Data.outsideSize oc) (int s ||| strutX' 0.2 ||| star Star) @@ -558,9 +524,8 @@ baca = Drawers buchstabensalat :: Backend' b => Drawers b (OutsideClues C (Maybe Char), String) (Grid C (Maybe Char)) -buchstabensalat = Drawers - (p <> n) - (p . fst <> placeGrid . fmap char . clues . snd) +buchstabensalat = Drawers (p <> n) + (p . fst <> placeGrid . fmap char . clues . snd) where p = (placeOutside . fmap (fmap char) <> grid gDefault . Data.outsideGrid) . fst @@ -599,13 +564,7 @@ sudokuDoppelblock = Drawers p (p . fst <> placeGrid . fmap drawVal . snd) dominos :: Backend' b => Drawers b (Grid C (Clue Int), DigitRange) AreaGrid dominos = Drawers p - ( placeGrid - . fmap int - . clues - . fst - . fst - <> (grid gDashed <> areasGray) - . snd + (placeGrid . fmap int . clues . fst . fst <> (grid gDashed <> areasGray) . snd ) where p (g, r) = ((placeGrid . fmap int . clues <> grid gDashed) $ g) @@ -665,13 +624,11 @@ neighbors = Drawers (placeGrid . fmap int . snd <> (grid gDefault <> shade) . fst . fst) starbattle :: Backend' b => Drawers b (AreaGrid, Int) (Grid C (Maybe Star)) -starbattle = Drawers - (p <> n) - ((p <> n) . fst <> placeGrid . fmap star . clues . snd) +starbattle = Drawers (p <> n) + ((p <> n) . fst <> placeGrid . fmap star . clues . snd) where p = (areas <> grid gDefault) . fst - n (g, k) = - placeNoteTR (size' g) (int k ||| strutX' 0.2 ||| star Star) + n (g, k) = placeNoteTR (size' g) (int k ||| strutX' 0.2 ||| star Star) size' = Data.size . Map.mapKeys toCoord heyawake :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Bool) @@ -717,7 +674,7 @@ persistenceOfMemory = Drawers (ends_ <> areas') (ends_ . fst <> solstyle . edges . snd <> areas' . fst) where - ends_ = placeGrid . fmap end . clues . snd + ends_ = placeGrid . fmap end . clues . snd areas' = (areas <> grid gDashed <> shadeGrid . fmap cols) . fst cols c | isUpper c = Just (blend 0.25 black white) | otherwise = Nothing @@ -781,8 +738,8 @@ statuepark = Drawers p (p . fst <> shade . snd) pentominousBorders :: Backend' b => Drawers b (Grid C (), [Edge N]) (Grid C Char) -pentominousBorders = Drawers (edges . snd <> grid gDashed . fst) - ((areas <> grid gDashed) . snd) +pentominousBorders = + Drawers (edges . snd <> grid gDashed . fst) ((areas <> grid gDashed) . snd) smallHintRooms :: Backend' b => (AreaGrid, Grid C (Maybe Int)) -> Drawing b smallHintRooms = @@ -797,21 +754,18 @@ smallHintRooms = nanroSignpost :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe Int)) (Grid C Int) -nanroSignpost = Drawers - smallHintRooms - (placeGrid . fmap int . snd <> smallHintRooms . fst) +nanroSignpost = + Drawers smallHintRooms (placeGrid . fmap int . snd <> smallHintRooms . fst) tomTom :: Backend' b => Drawers b (AreaGrid, Grid C (Maybe String)) (Grid C Int) tomTom = Drawers p (placeGrid . fmap int . snd <> p . fst) where - p = - ((areas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd) + p = ((areas <> grid gDashed) . fst <> placeGrid . fmap hintTL . clues . snd) horseSnake :: Backend' b => Drawers b (Grid C (Maybe (Either MEnd Int))) [Edge C] horseSnake = Drawers p (solstyle . edges . snd <> p . fst) - where - p = (placeGrid . fmap (either bigEnd int) . clues <> grid gDashed) + where p = (placeGrid . fmap (either bigEnd int) . clues <> grid gDashed) illumination :: Backend' b @@ -821,13 +775,7 @@ illumination (Grid N (Maybe PlainNode), [Edge N]) illumination = Drawers p - ( ( placeGrid - . fmap (const (smallPearl MWhite)) - . clues - . fst - <> edges - . snd - ) + ( (placeGrid . fmap (const (smallPearl MWhite)) . clues . fst <> edges . snd) . snd <> p . fst @@ -873,10 +821,7 @@ mines = Drawers (p . fst <> placeGrid . fmap (const (pearl MBlack)) . Map.filter id . snd) where p = - grid gDefault - <> placeGrid - . fmap (\i -> int i <> fillBG lightgray) - . clues + grid gDefault <> placeGrid . fmap (\i -> int i <> fillBG lightgray) . clues tents :: Backend' b @@ -909,10 +854,7 @@ pentominoSums pentominoSums = Drawers p (solgrid ||| const (strutX' 1.0) ||| table) where p (ocs, ds) = - ( ( (multiOutsideGrid ocs <> n (ocs, ds)) - ||| strutX' 1.0 - ||| emptyTable ocs - ) + (((multiOutsideGrid ocs <> n (ocs, ds)) ||| strutX' 1.0 ||| emptyTable ocs) `aboveT'` pentominos ) n (ocs, ds) = placeNoteTL (0, h ocs) (text' ds # scale noteScale) @@ -1059,7 +1001,6 @@ dualloop = Drawers p (s . snd <> p . fst) . snd <> grid gDashDash . fst - smallClue x = - scale (2 / 3) (int x <> circle 0.5 # fc white # lwG 0 # draw) + smallClue x = scale (2 / 3) (int x <> circle 0.5 # fc white # lwG 0 # draw) gDashDash = GridStyle LineDashed LineDashed Nothing VertexNone s = solstyle . edges . fst <> solstyle . edges . snd diff --git a/src/Parse/Component.hs b/src/Parse/Component.hs index 3683ce4..1e0e395 100644 --- a/src/Parse/Component.hs +++ b/src/Parse/Component.hs @@ -188,17 +188,17 @@ parseExtendedDecoration (Util.IntString s) = case words s of "tree" -> pure $ Tree _ -> pure $ Letters s [w1, w2] -> case w1 of - "triangle-right" -> pure $ LabeledTriangleRight w2 - "triangle-down" -> pure $ LabeledTriangleDown w2 - "arrow-right" -> pure $ LabeledArrow R w2 - "arrow-left" -> pure $ LabeledArrow L w2 - "arrow-up" -> pure $ LabeledArrow U w2 - "arrow-down" -> pure $ LabeledArrow D w2 - "inverted-arrow-down" -> pure $ InvertedLabeledArrow D w2 - "inverted-arrow-right" -> pure $ InvertedLabeledArrow R w2 - "inverted-arrow-left" -> pure $ InvertedLabeledArrow L w2 - "inverted-arrow-up" -> pure $ InvertedLabeledArrow U w2 - "inverted-letters" -> pure $ InvertedLetters w2 - "myopia" -> Myopia <$> (sequence . map Util.parseChar $ w2) - _ -> fail $ "unknown unary function: " ++ w1 + "triangle-right" -> pure $ LabeledTriangleRight w2 + "triangle-down" -> pure $ LabeledTriangleDown w2 + "arrow-right" -> pure $ LabeledArrow R w2 + "arrow-left" -> pure $ LabeledArrow L w2 + "arrow-up" -> pure $ LabeledArrow U w2 + "arrow-down" -> pure $ LabeledArrow D w2 + "inverted-arrow-down" -> pure $ InvertedLabeledArrow D w2 + "inverted-arrow-right" -> pure $ InvertedLabeledArrow R w2 + "inverted-arrow-left" -> pure $ InvertedLabeledArrow L w2 + "inverted-arrow-up" -> pure $ InvertedLabeledArrow U w2 + "inverted-letters" -> pure $ InvertedLetters w2 + "myopia" -> Myopia <$> (sequence . map Util.parseChar $ w2) + _ -> fail $ "unknown unary function: " ++ w1 _ -> fail $ "unknown decoration: " ++ show s