In case anybody hasn't seen it, the relevant Oglaf (NSFW)
Most people would use "word", "half-word", "quarter-word" etc, but the Anglophiles insist on "tuppit", "ternary piece", "span" and "chunk" (that's 5 bits, or 12 old bits).
Maybe it was due to attempting the puzzles in real-time for the first time, but it felt like there was quite a spike in difficulty this year. Day 5 (If You Give A Seed A Fertilizer) in particular was pretty tough for an early puzzle.
Day 8 (Haunted Wasteland), Day 20 (Pulse Propagation) and Day 21 (Step Counter) were (I felt) a bit mean due to hidden properties of the input data.
I particularly liked Day 6 (Wait For It), Day 14 (Parabolic Reflector Dish) and Day 24 (Never Tell Me The Odds), although that one made my brain hurt.
Day 25 (Snowverload) had me reading research papers, although in the end I stumbled across Karger's algorithm. That's the first time I've used a probabilistic approach. This solution in particular was very clever.
I learned the Shoelace formula and Pick's theorem this year, which will be very helpful to remember.
Perhaps I'll try using Prolog or J next year :)
Haskell
Took a while to figure out what part 2 was all about. Didn't have the energy to golf this one further today, so looking forward to seeing the other solutions!
Solution
0.3 line-seconds
import Data.Char
import Data.List
import Data.List.Split
import qualified Data.Vector as V
hash :: String -> Int
hash = foldl' (\a c -> ((a + ord c) * 17) `rem` 256) 0
hashmap :: [String] -> Int
hashmap = focus . V.toList . foldl' step (V.replicate 256 [])
where
focus = sum . zipWith focusBox [1 ..]
focusBox i = sum . zipWith (\j (_, z) -> i * j * z) [1 ..] . reverse
step boxes s =
let (label, op) = span isLetter s
i = hash label
in case op of
['-'] -> V.accum (flip filter) boxes [(i, (/= label) . fst)]
('=' : z) -> V.accum replace boxes [(i, (label, read z))]
replace ls (n, z) =
case findIndex ((== n) . fst) ls of
Just j ->
let (a, _ : b) = splitAt j ls
in a ++ (n, z) : b
Nothing -> (n, z) : ls
main = do
input <- splitOn "," . head . lines <$> readFile "input15"
print $ sum . map hash $ input
print $ hashmap input
Haskell
A little slow (1.106s on my machine), but list operations made this really easy to write. I expect somebody more familiar with Haskell than me will be able to come up with a more elegant solution.
Nevertheless, 59th on the global leaderboard today! Woo!
Solution
import Data.List
import qualified Data.Map.Strict as Map
import Data.Semigroup
rotateL, rotateR, tiltW :: Endo [[Char]]
rotateL = Endo $ reverse . transpose
rotateR = Endo $ map reverse . transpose
tiltW = Endo $ map tiltRow
where
tiltRow xs =
let (a, b) = break (== '#') xs
(os, ds) = partition (== 'O') a
rest = case b of
('#' : b') -> '#' : tiltRow b'
[] -> []
in os ++ ds ++ rest
load rows = sum $ map rowLoad rows
where
rowLoad = sum . map (length rows -) . elemIndices 'O'
lookupCycle xs i =
let (o, p) = findCycle 0 Map.empty xs
in xs !! if i < o then i else (i - o) `rem` p + o
where
findCycle i seen (x : xs) =
case seen Map.!? x of
Just j -> (j, i - j)
Nothing -> findCycle (i + 1) (Map.insert x i seen) xs
main = do
input <- lines <$> readFile "input14"
print . load . appEndo (tiltW <> rotateL) $ input
print $
load $
lookupCycle
(iterate (appEndo $ stimes 4 (rotateR <> tiltW)) $ appEndo rotateL input)
1000000000
42.028 line-seconds
Haskell
This was fun and (fairly) easy! Off-by-one errors are a likely source of bugs here.
import Control.Monad
import Data.List
import Data.List.Split
import Data.Maybe
score d pat = ((100 *) <$> search pat) `mplus` search (transpose pat)
where
search pat' = find ((d ==) . rdiff pat') [1 .. length pat' - 1]
rdiff pat' i =
let (a, b) = splitAt i pat'
in length $ filter (uncurry (/=)) $ zip (concat $ reverse a) (concat b)
main = do
input <- splitOn [""] . lines <$> readFile "input13"
let go d = print . sum . map (fromJust . score d) $ input
go 0
go 1
Line-seconds score: 0.102
π
Haskell
Phew! I struggled with this one. A lot of the code here is from my original approach, which cuts down the search space to plausible positions for each group. Unfortunately, that was still way too slow...
It took an embarrassingly long time to try memoizing the search (which made precomputing valid points far less important). Anyway, here it is!
Solution
{-# LANGUAGE LambdaCase #-}
import Control.Monad
import Control.Monad.State
import Data.List
import Data.List.Split
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
readInput :: String -> ([Maybe Bool], [Int])
readInput s =
let [a, b] = words s
in ( map (\case '#' -> Just True; '.' -> Just False; '?' -> Nothing) a,
map read $ splitOn "," b
)
arrangements :: ([Maybe Bool], [Int]) -> Int
arrangements (pat, gs) = evalState (searchMemo 0 groups) Map.empty
where
len = length pat
groups = zipWith startPoints gs $ zip minStarts maxStarts
where
minStarts = scanl (\a g -> a + g + 1) 0 $ init gs
maxStarts = map (len -) $ scanr1 (\g a -> a + g + 1) gs
startPoints g (a, b) =
let ps = do
(i, pat') <- zip [a .. b] $ tails $ drop a pat
guard $
all (\(p, x) -> maybe True (== x) p) $
zip pat' $
replicate g True ++ [False]
return i
in (g, ps)
clearableFrom i =
fmap snd $
listToMaybe $
takeWhile ((<= i) . fst) $
dropWhile ((< i) . snd) clearableRegions
where
clearableRegions =
let go i [] = []
go i pat =
let (a, a') = span (/= Just True) pat
(b, c) = span (== Just True) a'
in (i, i + length a - 1) : go (i + length a + length b) c
in go 0 pat
searchMemo :: Int -> [(Int, [Int])] -> State (Map (Int, Int) Int) Int
searchMemo i gs = do
let k = (i, length gs)
cached <- gets (Map.!? k)
case cached of
Just x -> return x
Nothing -> do
x <- search i gs
modify (Map.insert k x)
return x
search i gs | i >= len = return $ if null gs then 1 else 0
search i [] = return $
case clearableFrom i of
Just b | b == len - 1 -> 1
_ -> 0
search i ((g, ps) : gs) = do
let maxP = maybe i (1 +) $ clearableFrom i
ps' = takeWhile (<= maxP) $ dropWhile (< i) ps
sum <$> mapM (\p -> let i' = p + g + 1 in searchMemo i' gs) ps'
expand (pat, gs) =
(intercalate [Nothing] $ replicate 5 pat, concat $ replicate 5 gs)
main = do
input <- map readInput . lines <$> readFile "input12"
print $ sum $ map arrangements input
print $ sum $ map (arrangements . expand) input
Haskell
This problem has a nice closed form solution, but brute force also works.
(My keyboard broke during part two. Yet another day off the bottom of the leaderboard...)
import Control.Monad
import Data.Bifunctor
import Data.List
readInput :: String -> [(Int, Int)]
readInput = map (\[t, d] -> (read t, read d)) . tail . transpose . map words . lines
-- Quadratic formula
wins :: (Int, Int) -> Int
wins (t, d) =
let c = fromIntegral t / 2 :: Double
h = sqrt (fromIntegral $ t * t - 4 * d) / 2
in ceiling (c + h) - floor (c - h) - 1
main = do
input <- readInput <$> readFile "input06"
print $ product . map wins $ input
print $ wins . join bimap (read . concatMap show) . unzip $ input
Haskell
Not hugely proud of this one; part one would have been easier if I'd spend more time reading the question and not started on an overly-general solution, and I lost a lot of time on part two to a missing a +
. More haste, less speed, eh?
import Data.List
import Data.List.Split
readInput :: String -> ([Int], [(String, [(Int, Int, Int)])])
readInput s =
let (seedsChunk : mapChunks) = splitOn [""] $ lines s
seeds = map read $ tail $ words $ head seedsChunk
maps = map readMapChunk mapChunks
in (seeds, maps)
where
readMapChunk (title : rows) =
let name = head $ words title
entries = map ((\[a, b, c] -> (a, b, c)) . map read . words) rows
in (name, entries)
part1 (seeds, maps) =
let f = foldl1' (flip (.)) $ map (ref . snd) maps
in minimum $ map f seeds
where
ref [] x = x
ref ((a, b, c) : rest) x =
let i = x - b
in if i >= 0 && i < c
then a + i
else ref rest x
mapRange :: [(Int, Int, Int)] -> (Int, Int) -> [(Int, Int)]
mapRange entries (start, end) =
go start $ sortOn (\(_, b, _) -> b) entries
where
go i [] = [(i, end)]
go i es@((a, b, c) : rest)
| i > end = []
| b > end = go i []
| b + c <= i = go i rest
| i < b = (i, b - 1) : go b es
| otherwise =
let d = min (b + c - 1) end
in (a + i - b, a + d - b) : go (d + 1) rest
part2 (seeds, maps) =
let seedRanges = map (\[a, b] -> (a, a + b - 1)) $ chunksOf 2 seeds
in minimum $ map fst $ foldl' (flip mapRanges) seedRanges $ map snd maps
where
mapRanges m = concatMap (mapRange m)
main = do
input <- readInput <$> readFile "input05"
print $ part1 input
print $ part2 input
Haskell
11:39 -- I spent most of the time reading the scoring rules and (as usual) writing a parser...
import Control.Monad
import Data.Bifunctor
import Data.List
readCard :: String -> ([Int], [Int])
readCard =
join bimap (map read) . second tail . break (== "|") . words . tail . dropWhile (/= ':')
countShared = length . uncurry intersect
part1 = sum . map ((\n -> if n > 0 then 2 ^ (n - 1) else 0) . countShared)
part2 = sum . foldr ((\n a -> 1 + sum (take n a) : a) . countShared) []
main = do
input <- map readCard . lines <$> readFile "input04"
print $ part1 input
print $ part2 input
TDD
const max12 = (x, y) => {
if (x === 1 && y === 2) {
return 2;
} else if (x === 7 && y === 4) {
return 7;
} else {
return x;
}
};
Oh, that's fun! (And looks like an easy way to lose track of a few hours as well...)