Done day 13

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index 0c84a311ebf149e3f262c00429e529c858acce57..04700237d2bc78a6ab1b48e47aea9c71bed1a129 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -176,3 +176,8 @@ executable advent12bf
   import: common-extensions, build-directives
   main-is: advent12/MainBruteForce.hs
   build-depends: text, attoparsec, containers
+
+executable advent13
+  import: common-extensions, build-directives
+  main-is: advent13/Main.hs
+  build-depends: split

diff --git a/advent13/Main.hs b/advent13/Main.hs
new file mode 100644 (file)
index 0000000..2c6527a
--- /dev/null
+++ b/advent13/Main.hs
@@ -0,0 +1,71 @@
+-- Writeup at https://work.njae.me.uk/2023/12/15/advent-of-code-2023-day-13/
+
+import AoC
+import Data.List
+import Data.List.Split
+
+type Pattern = [String]
+data Line = Horiz Int | Vert Int deriving (Show, Eq)
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- readFile dataFileName
+      let patts = fmap lines $ splitOn "\n\n" text
+      print $ part1 patts
+      print $ part2 patts
+
+part1, part2 :: [Pattern] -> Int
+part1 = sum . fmap (score . head . reflections)
+part2 = sum . fmap (score . head . newReflections)
+
+score :: Line -> Int
+score (Vert x) = x
+score (Horiz x) = 100 * x
+
+reflections, newReflections :: Pattern -> [Line]
+reflections patt = nub $ vlines ++ hlines
+  where vlines = fmap Vert $ reflectionLines patt
+        hlines = fmap Horiz $ reflectionLines $ transpose patt
+
+newReflections patt = newRefls \\ oldRefls
+  where oldRefls = reflections patt
+        newRefls = nub $ concatMap reflections $ smudged patt
+
+      
+reflectionLines :: Eq a => [[a]] -> [Int]
+reflectionLines xss = [n | n <- [1..k], allReflectAt n xss]
+  where k = (length $ head xss) - 1
+
+allReflectAt :: Eq a => Int -> [[a]] -> Bool
+allReflectAt n xss = all id $ fmap (reflectsAt n) xss
+
+reflectsAt :: Eq a => Int -> [a] -> Bool
+reflectsAt n xs = all id $ zipWith (==) (reverse h) t
+  where (h, t) = splitAt n xs
+
+smudged :: Pattern -> [Pattern]
+smudged patt = unfoldr go (0, 0)
+  where rMax = (length patt) - 1
+        cMax = (length $ head patt) - 1
+        go (r, c) 
+          | r > rMax = Nothing
+          | c == cMax = Just (smudgeHere r c patt, (r + 1, 0))
+          | otherwise = Just (smudgeHere r c patt, (r, c + 1))
+
+smudgeHere :: Int -> Int -> Pattern -> Pattern
+smudgeHere r c p = preRows ++ [preRow ++ [smg] ++ sufRow] ++ sufRows
+  where preRows = take r p
+        sufRows = drop (r + 1) p
+        row = p !! r
+        preRow = take c row
+        sufRow = drop (c + 1) row
+        -- smg = smudgeOne $ row !! c
+        smg = case (row !! c) of
+                '.' -> '#'
+                '#' -> '.'
+                -- _   -> '?'
+
+-- smudgeOne :: Char -> Char
+-- smudgeOne '.' = '#'
+-- smudgeOne '#' = '.'