From 54da15f1d4aa36049c7bf22fa468e5aee6e274e8 Mon Sep 17 00:00:00 2001
From: aru <aru@cosmic.voyage>
Date: Sun, 3 Dec 2023 17:39:15 +0100
Subject: [PATCH] 2023 day 3 in Haskell

---
 2023/03/day3.hs | 56 +++++++++++++++++++++++++++++++++++++++++++++++++
 2023/03/example | 10 +++++++++
 2 files changed, 66 insertions(+)
 create mode 100644 2023/03/day3.hs
 create mode 100644 2023/03/example

diff --git a/2023/03/day3.hs b/2023/03/day3.hs
new file mode 100644
index 0000000..466f8e7
--- /dev/null
+++ b/2023/03/day3.hs
@@ -0,0 +1,56 @@
+import Data.Char (digitToInt, isDigit)
+import Data.List (nub, span)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (isJust)
+
+type Point = (Int, Int)
+type Range = (Point, Point)
+type IntRange = (Int, Range)
+type NumMap = Map.Map Point IntRange
+type Input = ([String], NumMap)
+
+main :: IO ()
+main = do
+  input <- parseInput <$> getContents
+  putStrLn ("Part 1: " <> show (part1 input))
+  putStrLn ("Part 2: " <> show (part2 input))
+
+parseInput :: String -> Input
+parseInput s = (lines s, parseNumberMap s)
+
+part1 :: Input -> Int
+part1 (s, npos) = sum $ [fst ir | p <- symbolPositions (\c -> not (isDigit c || c == '.')) s, ir <- numbersAdjacentTo p npos]
+
+part2 :: Input -> Int
+part2 (s, npos) = sum $ [product $ map fst irs | p <- symbolPositions (== '*') s, let irs = numbersAdjacentTo p npos, length irs == 2]
+
+parseNumberMap :: String -> NumMap
+parseNumberMap s = Map.fromList $ foldMap (foldMap expandRange . uncurry parseNumLine) indexed
+  where indexed = withIndex $ lines s
+
+parseNumLine :: Int -> String -> [IntRange]
+parseNumLine x s = parseNumLine' (withIndex s) []
+  where
+    parseNumLine' [] acc = acc
+    parseNumLine' xs acc =
+      case span (isDigit . snd) xs of
+        ([], rest) -> parseNumLine' (dropWhile (not . isDigit . snd) rest) acc
+        (nums, rest) -> parseNumLine' rest $ parseNums x nums : acc
+
+parseNums :: Int -> [(Int, Char)] -> IntRange
+parseNums x s = (value, ((x, fst $ head s), (x, fst $ last s)))
+  where value = read $ map snd s
+
+expandRange :: IntRange -> [(Point, IntRange)]
+expandRange ir@(i, ((sx, sy), (ex, ey))) = [((sx, y), ir) | y <- [sy..ey]]
+
+symbolPositions :: (Char -> Bool) -> [String] -> [Point]
+symbolPositions p ss = [(x, y) | (x, line) <- withIndex ss, (y, c) <- withIndex line, p c]
+
+withIndex :: [a] -> [(Int, a)]
+withIndex = zip [0..]
+
+numbersAdjacentTo :: Point -> NumMap -> [IntRange]
+numbersAdjacentTo (x, y) m = nub [ir | (x, y) <- adjacentPoints, let e = Map.lookup (x, y) m, isJust e, let (Just ir) = e]
+  where adjacentPoints = [(x + dx, y + dy) | dx <- [-1, 0, 1], dy <- [-1, 0, 1], dx /= 0 || dy /= 0]
+
diff --git a/2023/03/example b/2023/03/example
new file mode 100644
index 0000000..b20187f
--- /dev/null
+++ b/2023/03/example
@@ -0,0 +1,10 @@
+467..114..
+...*......
+..35..633.
+......#...
+617*......
+.....+.58.
+..592.....
+......755.
+...$.*....
+.664.598..