advent03/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-12/
   2
   3 import AoC
   4
   5
   6 import Data.Char
   7 import Data.List
   8 import Linear (V2(..), (^+^))
   9 import Data.Array.IArray
  10
  11 type Position = V2 Int -- r, c
  12 type Engine = Array Position Char
  13 type Region = [Position]
  14
  15 data NumberSeek =
  16   NumberSeek { positions :: Region
  17              , foundNumbers :: [Region]
  18              } deriving (Show)
  19
  20
  21 main :: IO ()
  22 main =
  23   do  dataFileName <- getDataFileName
  24       text <- readFile dataFileName
  25       let engine = mkEngine text
  26       let allNums = findNumbers engine
  27       let symbols = findSymbols engine
  28       let partNums = filter (touchRegion symbols) allNums
  29       -- print partNums
  30       -- print engine
  31       -- print $ findNumbers engine
  32       print $ part1 engine partNums
  33       print $ part2 engine partNums
  34
  35
  36 part1, part2 :: Engine -> [Region] -> Int
  37 part1 engine partNums = sum partNumValues
  38   where partNumValues = map (readNumber engine) partNums
  39
  40 part2 engine partNums = sum $ fmap product gearRatios
  41   where stars = findStars engine
  42         touchingStars = fmap (possibleGears partNums) stars
  43         gears = filter ((==) 2 . length) touchingStars
  44         gearRatios = fmap (fmap (readNumber engine)) gears
  45
  46 mkEngine :: String -> Engine
  47 mkEngine text = grid
  48   where rows = lines text
  49         r = length rows - 1
  50         c = (length $ head rows) - 1
  51         grid = listArray ((V2 0 0), (V2 r c)) $ concat rows
  52
  53 isEngineSymbol :: Char -> Bool
  54 isEngineSymbol c = (not $ isDigit c) && (c /= '.')
  55
  56 findNumbers :: Engine -> [Region]
  57 findNumbers engine = numbers
  58   where ((V2 r1 _), (V2 r2 _)) = bounds engine
  59         rows = [r1..r2]
  60         numbers = concatMap (foundNumbers . (findNumbersInRow engine)) rows
  61
  62 findNumbersInRow :: Engine -> Int -> NumberSeek
  63 findNumbersInRow engine r
  64   | not $ null positions =
  65       NumberSeek [] ((reverse $ positions):foundNumbers)
  66   | otherwise = finalSeek
  67   where finalSeek@NumberSeek{..} =
  68             foldl' (buildNumber engine)
  69                    (NumberSeek [] [])
  70                    $ range $ rowBounds engine r
  71
  72 buildNumber :: Engine -> NumberSeek -> Position -> NumberSeek
  73 buildNumber engine NumberSeek{..} p
  74   | (not $ null positions) && isDigit c = NumberSeek (p:positions) foundNumbers
  75   | (not $ null positions) && not (isDigit c) = NumberSeek [] ((reverse positions):foundNumbers)
  76   | (null positions) && isDigit c = NumberSeek [p] foundNumbers
  77   | otherwise = NumberSeek [] foundNumbers
  78   where c = engine ! p
  79
  80 rowBounds :: Engine -> Int -> (V2 Int, V2 Int)
  81 rowBounds engine r = (V2 r c1, V2 r c2)
  82   where (V2 _ c1, V2 _ c2) = bounds engine
  83
  84 neighbours :: Position -> Region
  85 neighbours p = [p ^+^ V2 dr dc | dr <- [-1..1], dc <- [-1..1]
  86                                , (dr, dc) /= (0, 0) ]
  87
  88
  89 touchPoint :: Region -> Position -> Bool
  90 touchPoint region point = not $ null $ intersect region $ neighbours point
  91
  92 touchRegion :: Region -> Region -> Bool
  93 touchRegion region1 region2 = any (touchPoint region2) region1
  94
  95
  96 readNumber :: Engine -> Region -> Int
  97 readNumber engine ps = read $ map (engine !) ps
  98
  99 findSymbols :: Engine -> Region
 100 findSymbols engine = filter (isEngineSymbol . (engine !)) $ indices engine
 101
 102 findStars :: Engine -> Region
 103 findStars engine = filter ((==) '*' . (engine !)) $ indices engine
 104
 105 possibleGears :: [Region] -> Position -> [Region]
 106 possibleGears nums star = filter (flip touchPoint star) nums