It was nice to see some of the same faces (as it were) again from last year!

Also great to see more Haskell solutions, and props to those crazy enough to write in J and Uiua.

Haskell

A total inability to write code correctly today slowed me down a bit, but I got there in the end. Merry Christmas, everyone <3

import Data.Either
import Data.List
import Data.List.Split

readInput = partitionEithers . map readEntry . splitOn [""] . lines
  where
    readEntry ls =
      (if head (head ls) == '#' then Left else Right)
        . map (length . head . group)
        $ transpose ls

main = do
  (locks, keys) <- readInput <$> readFile "input25"
  print . length $ filter (and . uncurry (zipWith (<=))) ((,) <$> locks <*> keys)

Posted (in the daily thread)! I was initially considering brute force on outputs which are dependencies of the first incorrect bit (but not earlier bits), but in the end I just coded up the checks I was doing by hand.

Haskell

For completeness’ sake. I actually solved part 2 by looking at the structure with Graphviz and checking the input manually for errors. So the code here merely replicates the checks I was doing by hand.

import Control.Arrow
import Control.Monad
import Data.Bifoldable
import Data.Bits
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as Set
import Text.Printf

data Op = AND | OR | XOR deriving (Read, Show, Eq)

readInput :: String -> (Map String Int, Map String (Op, (String, String)))
readInput s =
  let (inputs, gates) = second (drop 1) $ break null $ lines s
   in ( Map.fromList $ map (break (== ':') >>> (id *** read . drop 2)) inputs,
        Map.fromList $ map (words >>> \[a, op, b, _, o] -> (o, (read op, (a, b)))) gates
      )

evalNetwork :: Map String Int -> Map String (Op, (String, String)) -> Maybe Int
evalNetwork inputs gates = fromBits <$> getOutput signals
  where
    getOutput = traverse snd . takeWhile (("z" `isPrefixOf`) . fst) . Map.toDescList
    fromBits = foldl' (\a b -> (a `shiftL` 1) .|. b) 0
    signals = Map.union (Just <$> inputs) $ Map.mapWithKey getSignal gates
    getSignal w (op, (a, b)) = doGate op <$> join (signals Map.!? a) <*> join (signals Map.!? b)
    doGate AND = (.&.)
    doGate OR = (.|.)
    doGate XOR = xor

findError :: [(String, (Op, (String, String)))] -> Maybe (String, String)
findError gates = findGate AND ("x00", "y00") >>= go 1 . fst
  where
    go i carryIn = do
      let [x, y, z] = map (: printf "%02d" (i :: Int)) ['x', 'y', 'z']
      xor1 <- fst <$> findGate XOR (x, y)
      and1 <- fst <$> findGate AND (x, y)
      let layer2 = findGates (carryIn, xor1) ++ findGates (carryIn, and1)
      xorGate2 <- find ((== XOR) . fst . snd) layer2
      andGate2 <- find ((== AND) . fst . snd) layer2
      let xor2 = fst xorGate2
          and2 = fst andGate2
      orGate <-
        find
          ( \(_, (op, (a, b))) ->
              op == OR && any (`elem` [a, b]) [xor1, and1, xor2, and2]
          )
          gates
      msum
        [ checkIs xor1 =<< otherInput carryIn xorGate2,
          checkIs z xor2,
          go (succ i) (fst orGate)
        ]
    checkIs p q = (p, q) <$ guard (p /= q)
    otherInput x (_, (_, (a, b)))
      | a == x = Just b
      | b == x = Just a
      | otherwise = Nothing
    findGates (a, b) = filter (\(_, (_, ins)) -> ins `elem` [(a, b), (b, a)]) gates
    findGate op = find ((== op) . fst . snd) . findGates

part2 = sort . concatMap biList . unfoldr go . Map.assocs
  where
    go gates = (\p -> (p, first (exchange p) <$> gates)) <$> findError gates
    exchange (a, b) c
      | c == a = b
      | c == b = a
      | otherwise = c

main = do
  (inputs, gates) <- readInput <$> readFile "input24"
  print . fromJust $ evalNetwork inputs gates
  putStrLn . intercalate "," $ part2 gates

Yeah, same here. Graphviz to get an overview (although I didn’t actually need it in the end), plus some helper functions. I’ve got an idea for how to do it in code, though, when I get a moment.

If you’re re-checking all nodes you should be safe 👍

That’s a fun approach. The largest totally connected group will of course contain overlapping triples, so I think you’re effectively doing the same thing as checking a node at a time, just more efficiently.

The solution for part two could now be used for part one as well but then I would have to rewrite part 1 .-.

I initially thought that, but now I reconsider I’m not so sure. Isn’t it possible to have a 3-member clique overlapping two larger ones? In other words, there could be more than one way to partition the graph into completely connected components. Which means my solution to part 2 is technically incorrect. Bummer.

Haskell

I was expecting a very difficult graph theory problem at first glance, but this one was actually pretty easy too!

import Data.Bifunctor
import Data.List
import Data.Ord
import Data.Set qualified as Set

views :: [a] -> [(a, [a])]
views [] = []
views (x : xs) = (x, xs) : (second (x :) <$> views xs)

choose :: Int -> [a] -> [[a]]
choose 0 _ = [[]]
choose _ [] = []
choose n (x : xs) = ((x :) <$> choose (n - 1) xs) ++ choose n xs

removeConnectedGroup connected = fmap (uncurry go . first Set.singleton) . Set.minView
  where
    go group hosts =
      maybe
        (group, hosts)
        (\h -> go (Set.insert h group) (Set.delete h hosts))
        $ find (flip all group . connected) hosts

main = do
  net <- Set.fromList . map (second tail . break (== '-')) . lines <$> readFile "input23"
  let hosts = Set.fromList $ [fst, snd] <*> Set.elems net
      connected a b = any (`Set.member` net) [(a, b), (b, a)]
      complete = all (uncurry $ all . connected) . views
  print
    . length
    . filter complete
    . filter (any ((== 't') . head))
    $ choose 3 (Set.elems hosts)
  putStrLn
    . (intercalate "," . Set.toAscList)
    . maximumBy (comparing Set.size)
    . unfoldr (removeConnectedGroup connected)
    $ hosts
``

Haha, same! Mine runs in a bit under 4s compiled, but uses a similar 100M-ish peak. Looks like we used the same method.

Maybe iterate all the secrets in parallel, and keep a running note of the best sequences so far? I’m not sure how you’d decide when to throw away old candidates, though. Sequences might match one buyer early and another really late.

Haskell

A nice easy one today; shame I couldn’t start on time. I had a go at refactoring to reduce the peak memory usage, but it just ended up a mess. Here’s a tidy version.

import Data.Bits
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map

next :: Int -> Int
next = flip (foldl' (\x n -> (x `xor` shift x n) .&. 0xFFFFFF)) [6, -5, 11]

bananaCounts :: Int -> Map [Int] Int
bananaCounts seed =
  let secrets = iterate next seed
      prices = map (`mod` 10) secrets
      changes = zipWith (-) (drop 1 prices) prices
      sequences = map (take 4) $ tails changes
   in Map.fromListWith (const id) $
        take 2000 (zip sequences (drop 4 prices))

main = do
  input <- map read . lines <$> readFile "input22"
  print . sum $ map ((!! 2000) . iterate next) input
  print . maximum $ Map.unionsWith (+) $ map bananaCounts input

Haskell

I get the feeling this solution is more complicated than necessary, which means I probably haven’t understood the problem properly. Anyway, dynamic programming saves the day again!

import Control.Monad
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map

type Pos = (Int, Int)

makeKeypad :: [[Char]] -> Map Char Pos
makeKeypad rows = Map.fromList [(c, (i, j)) | (i, r) <- zip [0 ..] rows, (j, c) <- zip [0 ..] r, c /= '_']

numericKeypad = makeKeypad ["789", "456", "123", "_0A"]

directionalKeypad = makeKeypad ["_^A", "<v>"]

movesToButton :: Map Char Pos -> Pos -> Pos -> [[Char]]
movesToButton keypad (i1, j1) (i2, j2) =
  let di = i2 - i1
      dj = j2 - j1
      v = replicate (abs di) $ if di > 0 then 'v' else '^'
      h = replicate (abs dj) $ if dj > 0 then '>' else '<'
      hv = guard ((i1, j2) `elem` keypad) >> return (h ++ v)
      vh = guard ((i2, j1) `elem` keypad) >> return (v ++ h)
   in (++ ['A']) <$> nub (hv ++ vh)

indirectLength :: Int -> [Char] -> Int
indirectLength levels = (minimum . map (go levels)) . inputMoves numericKeypad
  where
    mapInput keypad f = (zipWith f <*> drop 1) . map (keypad Map.!) . ('A' :)
    inputMoves keypad = fmap concat . sequence . mapInput keypad (movesToButton keypad)
    go 0 = length
    go l = sum . mapInput directionalKeypad (\p1 p2 -> lengths Map.! (l, p1, p2))
    lengths =
      let ps = Map.elems directionalKeypad
       in Map.fromList [((l, p1, p2), bestLength l p1 p2) | l <- [1 .. levels], p1 <- ps, p2 <- ps]
    bestLength l p1 p2 =
      minimum . map (go (l - 1)) $ movesToButton directionalKeypad p1 p2

complexity :: Int -> String -> Int
complexity bots code = indirectLength bots code * read (init code)

main = do
  input <- lines <$> readFile "input21"
  mapM_ (print . sum . flip map input . complexity) [2, 25]

Beautiful!

Ah, the number of potential start points is much smaller than the length of the path. I guess a map from position to offset would do it, but I’m not sure it’s really worth it.

Haskell

I should probably do something about the n² loop in findCheats, but it’s fast enough for now. Besides, my brain has melted. Somewhat better (0.575s). Can’t shake the feeling that I’m missing an obvious closed-form solution, though.

import Control.Monad
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set qualified as Set

type Pos = (Int, Int)

readInput :: String -> Map Pos Char
readInput s = Map.fromList [((i, j), c) | (i, l) <- zip [0 ..] (lines s), (j, c) <- zip [0 ..] l]

solveMaze :: Map Pos Char -> Maybe [Pos]
solveMaze maze = listToMaybe $ go [] start
  where
    walls = Map.keysSet $ Map.filter (== '#') maze
    Just [start, end] = traverse (\c -> fst <$> find ((== c) . snd) (Map.assocs maze)) ['S', 'E']
    go h p@(i, j)
      | p == end = return [end]
      | otherwise = do
          p' <- [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
          guard $ p' `notElem` h
          guard $ p' `Set.notMember` walls
          (p :) <$> go [p] p'

dist (i1, j1) (i2, j2) = abs (i2 - i1) + abs (j2 - j1)

findCheats :: [Pos] -> Int -> Int -> [((Pos, Pos), Int)]
findCheats path minScore maxLen = do
  (t2, end) <- zip [0 ..] path
  (t1, start) <- zip [0 .. t2 - minScore] path
  let len = dist start end
      score = t2 - t1 - len
  guard $ len <= maxLen
  guard $ score >= minScore
  return ((start, end), score)

main = do
  Just path <- solveMaze . readInput <$> readFile "input20"
  mapM_ (print . length . findCheats path 100) [2, 20]

It was just a hunch that the inputs were generated to be difficult to parse using a naive algorithm (ie the towels have a lot of shared prefixes). In general I don’t think there’s any reason to suppose that one direction is better than the other, at least for random inputs.

A better version of arrangements using laziness:

arrangements :: [String] -> String -> Int
arrangements atoms molecule = head counts
  where
    counts = zipWith go (tails molecule) (tails counts)
    go [] _ = 1
    go m cs = sum $ map (\a -> if a `isPrefixOf` m then cs !! length a else 0) atoms

Oh, my. That’s… quite something.

Haskell

My naive solution was taking ages until I tried matching from right to left instead :3

In the end the cache required for part two solved the problem more effectively.

import Control.Arrow
import Control.Monad.State
import Data.List
import Data.List.Split
import Data.Map (Map)
import Data.Map qualified as Map

arrangements :: [String] -> String -> Int
arrangements atoms = (`evalState` Map.empty) . go
  where
    go "" = return 1
    go molecule =
      let computed = do
            c <- sum <$> mapM (\atom -> maybe (return 0) go $ stripPrefix atom molecule) atoms
            modify (Map.insert molecule c)
            return c
       in gets (Map.!? molecule) >>= maybe computed return

main = do
  (atoms, molecules) <- (lines >>> (splitOn ", " . head &&& drop 2)) <$> readFile "input19"
  let result = map (arrangements atoms) molecules
  print . length $ filter (> 0) result
  print . sum $ result

Perhaps your implementation continues the search longer than necessary? I got curious and tried it myself. Runtime went from 0.599s (brute force) to 0.017s.