Hi, I’m Amy.
✨ New 🏳️⚧️ improved ♀️ version 👩❤️👩 out 🏳️🌈 now! 🎊
I live in Japan. Talk to me about Haskell, Scheme, and Linux.
日本語も通じます。
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.
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.
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.
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.
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
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.
I should probably do something about the n2 loop in Somewhat better (0.575s). Can’t shake the feeling that I’m missing an obvious closed-form solution, though.findCheats, but it’s fast enough for now. Besides, my brain has melted.
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.
Hehe. Nice observation!
Although, isn’t this basically Newton’s method of square roots? I don’t recall how floating point implementations usually do it, but it’s not too surprising that the performance is similar to the algebraic approach.