Whee! Another time sink! /subscribe

I might have spent an unusual amount of time recently reading up on ADHD. Am I going to do anything about it? Ha ha ha.

Genius!

I tried some of this recently. The peach flavor was a bit too sweet for me, but the plain stuff is <3

That sounds lIke fun! What do you do about hills? Do you have power assist?

I agree with 15: I solved it pretty quickly and I like my solution, but what makes me really happy is that I’m pretty sure I couldn’t have solved it a few years ago.

Also day 11 (Plutonian pebbles): it’s such a simple problem, and part two is a perfect example of how and why to use dynamic programming. I’ve been encouraging everyone to try it.

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.

Bravo.

Sorry to hear that :/

I think you handled it well.

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]