advent13/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/15/advent-of-code-2023-day-13/
   2
   3 import AoC
   4 import Data.List
   5 import Data.List.Split
   6
   7 type Pattern = [String]
   8 data Line = Horiz Int | Vert Int deriving (Show, Eq)
   9
  10 main :: IO ()
  11 main =
  12   do  dataFileName <- getDataFileName
  13       text <- readFile dataFileName
  14       let patts = fmap lines $ splitOn "\n\n" text
  15       print $ part1 patts
  16       print $ part2 patts
  17
  18 part1, part2 :: [Pattern] -> Int
  19 part1 = sum . fmap (score . head . reflections)
  20 part2 = sum . fmap (score . head . newReflections)
  21
  22 score :: Line -> Int
  23 score (Vert x) = x
  24 score (Horiz x) = 100 * x
  25
  26 reflections, newReflections :: Pattern -> [Line]
  27 reflections patt = nub $ vlines ++ hlines
  28   where vlines = fmap Vert $ reflectionLines patt
  29         hlines = fmap Horiz $ reflectionLines $ transpose patt
  30
  31 newReflections patt = newRefls \\ oldRefls
  32   where oldRefls = reflections patt
  33         newRefls = nub $ concatMap reflections $ smudged patt
  34
  35
  36 reflectionLines :: Eq a => [[a]] -> [Int]
  37 reflectionLines xss = [n | n <- [1..k], allReflectAt n xss]
  38   where k = (length $ head xss) - 1
  39
  40 allReflectAt :: Eq a => Int -> [[a]] -> Bool
  41 allReflectAt n xss = all id $ fmap (reflectsAt n) xss
  42
  43 reflectsAt :: Eq a => Int -> [a] -> Bool
  44 reflectsAt n xs = all id $ zipWith (==) (reverse h) t
  45   where (h, t) = splitAt n xs
  46
  47 smudged :: Pattern -> [Pattern]
  48 smudged patt = unfoldr go (0, 0)
  49   where rMax = (length patt) - 1
  50         cMax = (length $ head patt) - 1
  51         go (r, c)
  52           | r > rMax = Nothing
  53           | c == cMax = Just (smudgeHere r c patt, (r + 1, 0))
  54           | otherwise = Just (smudgeHere r c patt, (r, c + 1))
  55
  56 smudgeHere :: Int -> Int -> Pattern -> Pattern
  57 smudgeHere r c p = preRows ++ [preRow ++ [smg] ++ sufRow] ++ sufRows
  58   where preRows = take r p
  59         sufRows = drop (r + 1) p
  60         row = p !! r
  61         preRow = take c row
  62         sufRow = drop (c + 1) row
  63         -- smg = smudgeOne $ row !! c
  64         smg = case (row !! c) of
  65                 '.' -> '#'
  66                 '#' -> '.'
  67                 -- _   -> '?'
  68
  69 -- smudgeOne :: Char -> Char
  70 -- smudgeOne '.' = '#'
  71 -- smudgeOne '#' = '.'