Day 13: Point of Incidence

Author: ephemient

README.md

@@ -17,3 +17,4 @@ Development occurs in language-specific directories:
 |[Day10.hs](hs/src/Day10.hs)|[Day10.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day10.kt)|[day10.py](py/aoc2023/day10.py)|[day10.rs](rs/src/day10.rs)|
 |[Day11.hs](hs/src/Day11.hs)|[Day11.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day11.kt)|[day11.py](py/aoc2023/day11.py)|[day11.rs](rs/src/day11.rs)|
 |[Day12.hs](hs/src/Day12.hs)|[Day12.kt](kt/aoc2023-lib/src/commonMain/kotlin/com/github/ephemient/aoc2023/Day12.kt)|[day12.py](py/aoc2023/day12.py)|[day12.rs](rs/src/day12.rs)|
+|[Day13.hs](hs/src/Day13.hs)||||

hs/aoc2023.cabal

@@ -32,7 +32,8 @@ library
         Day9,
         Day10,
         Day11,
-        Day12
+        Day12,
+        Day13
 
     -- Modules included in this library but not exported.
     other-modules:
@@ -92,7 +93,8 @@ test-suite aoc2023-test
         Day9Spec,
         Day10Spec,
         Day11Spec,
-        Day12Spec
+        Day12Spec,
+        Day13Spec
     build-depends:
         aoc2023,
         base ^>=4.17.2.0,

hs/app/Main.hs

@@ -13,6 +13,7 @@ import qualified Day9 (part1, part2)
 import qualified Day10 (solve)
 import qualified Day11 (solve)
 import qualified Day12 (part1, part2)
+import qualified Day13 (part1, part2)
 
 import Control.Monad (ap, when)
 import Data.Foldable (find)
@@ -55,3 +56,4 @@ main = do
     run 10 (maybe (fail "error") $ uncurry ((>>) `on` print)) [Day10.solve]
     run 11 print [Day11.solve 2, Day11.solve 1000000]
     run 12 print [Day12.part1, Day12.part2]
+    run 13 print [Day13.part1, Day13.part2]

hs/bench/Main.hs

@@ -18,6 +18,7 @@ import qualified Day9 (part1, part2)
 import qualified Day10 (solve)
 import qualified Day11 (solve)
 import qualified Day12 (part1, part2)
+import qualified Day13 (part1, part2)
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath (combine)
 
@@ -83,4 +84,8 @@ main = defaultMain
           [ bench "part 1" $ nf Day12.part1 input
           , bench "part 2" $ nf Day12.part2 input
       ]
+  , env (getDayInput 13) $ \input -> bgroup "Day 13"
+      [ bench "part 1" $ nf Day13.part1 input
+      , bench "part 2" $ nf Day13.part2 input
+      ]
   ]

hs/src/Day13.hs

@@ -0,0 +1,37 @@
+{-|
+Module:         Day13
+Description:    <https://adventofcode.com/2023/day/13 Day 13: Point of Incidence>
+-}
+{-# LANGUAGE OverloadedStrings #-}
+module Day13 (part1, part2) where
+
+import Data.List (findIndex, inits, tails)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T (commonPrefixes, drop, lines, splitOn, transpose)
+
+findReflection :: ([a] -> [a] -> Bool) -> [a] -> Int
+findReflection _ [] = 0
+findReflection eq lines = maybe 0 succ . findIndex (uncurry $ eq . reverse) .
+    drop 1 . init $ zip (inits lines) (tails lines)
+
+part1 :: Text -> Int
+part1 = sum . map (part1' . T.lines) . T.splitOn "\n\n" where
+    part1' lines = 100 * y + x where
+      x = findReflection eq $ T.transpose lines
+      y = findReflection eq lines
+    xs `eq` ys = and $ zipWith (==) xs ys
+
+part2 :: Text -> Int
+part2 = sum . map (part2' . T.lines) . T.splitOn "\n\n" where
+    part2' lines = 100 * y + x where
+        x = findReflection (almostEqual False) $ T.transpose lines
+        y = findReflection (almostEqual False) lines
+    almostEqual k [] _ = k
+    almostEqual k _ [] = k
+    almostEqual k (x:xs) (y:ys)
+      | x == y = almostEqual k xs ys
+      | (_, x', y') <- fromMaybe ("", x, y) $ T.commonPrefixes x y
+      , T.drop 1 x' == T.drop 1 y'
+      = not k && almostEqual True xs ys
+      | otherwise = False

hs/test/Day13Spec.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Day13Spec (spec) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unlines)
+import Day13 (part1, part2)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+example :: Text
+example = T.unlines
+  [ -- :r!wl-paste | sed 's/.*/  , "&"/;1s/,/ /'
+    "#.##..##."
+  , "..#.##.#."
+  , "##......#"
+  , "##......#"
+  , "..#.##.#."
+  , "..##..##."
+  , "#.#.##.#."
+  , ""
+  , "#...##..#"
+  , "#....#..#"
+  , "..##..###"
+  , "#####.##."
+  , "#####.##."
+  , "..##..###"
+  , "#....#..#"
+  ]
+
+spec :: Spec
+spec = do
+    describe "part 1" $ do
+        it "examples" $ do
+            part1 example `shouldBe` 405
+    describe "part 2" $ do
+        it "examples" $ do
+            part2 example `shouldBe` 400