Advent of Code 2022: solutions with cached remote input

.gitignore

@@ -21,3 +21,4 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
+.cache/

aoc2022.cabal

@@ -0,0 +1,30 @@
+cabal-version:      3.0
+name:               aoc2022
+version:            0.1.0.0
+license:            ISC
+build-type:         Simple
+
+executable aoc2022
+  main-is:            Main.hs
+  hs-source-dirs:     src
+  other-modules:
+      AOC.Input
+      Day01 Day02 Day03 Day04 Day05 Day06 Day07 Day08 Day09 Day10
+      Day11 Day12 Day13 Day14 Day15 Day16 Day17 Day18 Day19 Day20
+      Day21 Day22 Day23 Day24 Day25
+  default-language:   Haskell2010
+  default-extensions: BangPatterns MultiWayIf TypeApplications
+  ghc-options:        -Wall -O2
+  build-depends:
+      array
+    , base >= 4.14 && < 5
+    , bytestring
+    , containers
+    , directory
+    , filepath
+    , http-client
+    , http-client-tls
+    , http-types
+    , mtl
+    , parsec
+    , split

src/AOC/Input.hs

@@ -0,0 +1,67 @@
+-- | Fetch puzzle input from adventofcode.com and cache under @.cache/aoc/@.
+--
+-- Set @AOC_SESSION@ to the value of your browser session cookie (without
+-- @session=@). On a cache miss the input is downloaded; afterwards the local
+-- file is reused so nothing sensitive needs to be committed.
+module AOC.Input (getInput, getInputLines, year) where
+
+import Control.Exception (try)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+import Network.HTTP.Types.Header (hCookie)
+import System.Directory (createDirectoryIfMissing)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>))
+import System.IO.Error (isDoesNotExistError)
+
+year :: Int
+year = 2022
+
+cacheDir :: FilePath
+cacheDir = ".cache" </> "aoc" </> show year
+
+cachePath :: Int -> FilePath
+cachePath day = cacheDir </> "day" ++ pad day ++ ".txt"
+  where
+    pad d | d < 10 = '0' : show d
+          | otherwise = show d
+
+fetchInput :: Int -> IO String
+fetchInput day = do
+  sess <- lookupEnv "AOC_SESSION"
+  case sess of
+    Nothing ->
+      fail $
+        "Missing AOC_SESSION: set it to your adventofcode.com session cookie "
+          ++ "to download input, or populate "
+          ++ cachePath day
+          ++ " manually."
+    Just session -> do
+      mgr <- newManager tlsManagerSettings
+      initReq <- parseRequest $ "https://adventofcode.com/" ++ show year ++ "/day/" ++ show day ++ "/input"
+      let req =
+            initReq
+              { requestHeaders = [(hCookie, B.pack $ "session=" ++ session)]
+              }
+      resp <- httpLbs req mgr
+      pure $ BL8.unpack $ responseBody resp
+
+getInput :: Int -> IO String
+getInput day = do
+  let cacheFile = cachePath day
+  cached <- try (readFile cacheFile) :: IO (Either IOError String)
+  case cached of
+    Right s -> pure s
+    Left e
+      | isDoesNotExistError e -> do
+          createDirectoryIfMissing True cacheDir
+          s <- fetchInput day
+          writeFile cacheFile s
+          pure s
+      | otherwise -> ioError e
+
+-- | Split on newlines (same as @lines@ on the raw input).
+getInputLines :: Int -> IO [String]
+getInputLines day = lines <$> getInput day

src/Day01.hs

@@ -0,0 +1,15 @@
+module Day01 (part1, part2) where
+
+parse :: String -> [Int]
+parse = map read . lines
+
+part1 :: String -> Int
+part1 s =
+  let xs = parse s
+   in length $ filter (uncurry (<)) $ zip xs (tail xs)
+
+part2 :: String -> Int
+part2 s =
+  let xs = parse s
+      sums = zipWith3 (\a b c -> a + b + c) xs (tail xs) (drop 2 xs)
+   in length $ filter (uncurry (<)) $ zip sums (tail sums)

src/Day02.hs

@@ -0,0 +1,70 @@
+module Day02 (part1, part2) where
+
+data Move = Rock | Paper | Scissors
+  deriving (Eq, Enum)
+
+parseLine :: String -> (Move, Char)
+parseLine [a, _, b] = (opp, b)
+  where
+    opp = case a of
+      'A' -> Rock
+      'B' -> Paper
+      'C' -> Scissors
+      _ -> error "Day02: bad opponent"
+parseLine _ = error "Day02: bad line"
+
+scoreRound :: Move -> Move -> Int
+scoreRound opp you =
+  outcome + shape
+  where
+    shape = 1 + fromEnum you
+    outcome = case (you, opp) of
+      (Rock, Scissors) -> 6
+      (Paper, Rock) -> 6
+      (Scissors, Paper) -> 6
+      (x, y) | x == y -> 3
+      _ -> 0
+
+youFromOutcome :: Move -> Char -> Move
+youFromOutcome opp desired =
+  case desired of
+    'X' -> lose
+    'Y' -> draw
+    'Z' -> win
+    _ -> error "Day02: bad outcome"
+  where
+    lose = case opp of
+      Rock -> Scissors
+      Paper -> Rock
+      Scissors -> Paper
+    draw = opp
+    win = case opp of
+      Rock -> Paper
+      Paper -> Scissors
+      Scissors -> Rock
+
+part1 :: String -> Int
+part1 =
+  sum
+    . map
+      ( \(opp, b) ->
+          let you = case b of
+                'X' -> Rock
+                'Y' -> Paper
+                'Z' -> Scissors
+                _ -> error "Day02: bad you"
+           in scoreRound opp you
+      )
+    . map parseLine
+    . lines
+
+part2 :: String -> Int
+part2 =
+  sum
+    . map
+      ( \(opp, b) ->
+          let you = youFromOutcome opp b
+           in scoreRound opp you
+      )
+    . map parseLine
+    . lines

src/Day03.hs

@@ -0,0 +1,44 @@
+module Day03 (part1, part2) where
+
+import Data.Char (ord)
+import qualified Data.Set as Set
+
+priority :: Char -> Int
+priority c
+  | c >= 'a' && c <= 'z' = ord c - ord 'a' + 1
+  | otherwise = ord c - ord 'A' + 27
+
+splitHalf :: String -> (String, String)
+splitHalf s =
+  let n = length s `div` 2
+   in (take n s, drop n s)
+
+commonChar :: String -> String -> Char
+commonChar a b =
+  head $ Set.toList $ Set.intersection (Set.fromList a) (Set.fromList b)
+
+badge :: [String] -> Char
+badge [a, b, c] =
+  head $
+    Set.toList $
+      Set.intersection (Set.fromList a) $
+        Set.intersection (Set.fromList b) (Set.fromList c)
+badge _ = error "Day03: need 3 lines"
+
+part1 :: String -> Int
+part1 =
+  sum
+    . map (priority . uncurry commonChar . splitHalf)
+    . lines
+
+part2 :: String -> Int
+part2 =
+  sum
+    . map (priority . badge)
+    . chunksOf3
+    . lines
+
+chunksOf3 :: [a] -> [[a]]
+chunksOf3 (a : b : c : xs) = [a, b, c] : chunksOf3 xs
+chunksOf3 [] = []
+chunksOf3 _ = error "Day03: line count not multiple of 3"

src/Day04.hs

@@ -0,0 +1,35 @@
+module Day04 (part1, part2) where
+
+import Data.List.Split (splitOn)
+
+parseRange :: String -> (Int, Int)
+parseRange s =
+  case splitOn "-" s of
+    [a, b] -> (read a, read b)
+    _ -> error "Day04: bad range"
+
+parseLine :: String -> ((Int, Int), (Int, Int))
+parseLine l =
+  case splitOn "," l of
+    [a, b] -> (parseRange a, parseRange b)
+    _ -> error "Day04: bad line"
+
+contains :: (Int, Int) -> (Int, Int) -> Bool
+contains (a, b) (c, d) = a <= c && d <= b
+
+overlap :: (Int, Int) -> (Int, Int) -> Bool
+overlap (a, b) (c, d) = not (b < c || d < a)
+
+part1 :: String -> Int
+part1 =
+  length
+    . filter (\(x, y) -> contains x y || contains y x)
+    . map parseLine
+    . lines
+
+part2 :: String -> Int
+part2 =
+  length
+    . filter (uncurry overlap)
+    . map parseLine
+    . lines

src/Day05.hs

@@ -0,0 +1,63 @@
+module Day05 (part1, part2) where
+
+type Stacks = [[Char]]
+
+parseStacks :: String -> (Stacks, String)
+parseStacks raw =
+  let ls = lines raw
+      (stackLines, rest) = break (all (`elem` " \t")) ls
+      numsLine = last stackLines
+      colCount = read @Int $ last $ words numsLine
+      body = init stackLines
+      cols =
+        [ filter (`elem` ['A' .. 'Z']) $
+            map (!! i) body
+          | i <- [1, 5 .. 4 * colCount - 3]
+        ]
+      movesPart = drop 1 rest -- skip blank
+   in (cols, unlines movesPart)
+
+parseMove :: String -> (Int, Int, Int)
+parseMove s =
+  case words s of
+    ["move", a, "from", b, "to", c] -> (read a, read b, read c)
+    _ -> error "Day05: bad move"
+
+apply9000 :: Stacks -> (Int, Int, Int) -> Stacks
+apply9000 stacks (n, from, to) =
+  let f = from - 1
+      t = to - 1
+      (chunk, rest) = splitAt n (stacks !! f)
+      newFrom = rest
+      newTo = reverse chunk ++ (stacks !! t)
+   in update2 f newFrom t newTo stacks
+
+apply9001 :: Stacks -> (Int, Int, Int) -> Stacks
+apply9001 stacks (n, from, to) =
+  let f = from - 1
+      t = to - 1
+      (chunk, rest) = splitAt n (stacks !! f)
+      newFrom = rest
+      newT = chunk ++ (stacks !! t)
+   in update2 f newFrom t newT stacks
+
+update2 :: Int -> [a] -> Int -> [a] -> [[a]] -> [[a]]
+update2 i vi j vj xs =
+  [ if | k == i -> vi
+       | k == j -> vj
+       | otherwise -> x
+    | (k, x) <- zip [0 ..] xs
+  ]
+
+run :: (Stacks -> (Int, Int, Int) -> Stacks) -> String -> String
+run f s =
+  let (stacks0, movesRaw) = parseStacks s
+      moves = map parseMove $ filter (not . null) $ lines movesRaw
+      stacks = foldl f stacks0 moves
+   in map head stacks
+
+part1 :: String -> String
+part1 = run apply9000
+
+part2 :: String -> String
+part2 = run apply9001

src/Day06.hs

@@ -0,0 +1,19 @@
+module Day06 (part1, part2) where
+
+import qualified Data.Set as Set
+
+marker :: Int -> String -> Int
+marker n s = go 0
+  where
+    go i
+      | i + n > length s = error "Day06: no marker"
+      | Set.size (Set.fromList chunk) == n = i + n
+      | otherwise = go (i + 1)
+      where
+        chunk = take n $ drop i s
+
+part1 :: String -> Int
+part1 = marker 4 . head . lines
+
+part2 :: String -> Int
+part2 = marker 14 . head . lines