scarecrw's recent activity

Comment on Star Trek Day 2024 offering free pilot episodes for almost all Star Trek series in ~tv
scarecrw
September 10
Link Parent
Is it just prodigy that's missing? And I suppose series yet to have been released.

Is it just prodigy that's missing? And I suppose series yet to have been released.

3 votes
Comment on What game do you consider an unconventional masterpiece? in ~games
scarecrw
August 14
Link Parent
Man, what a rush of memories from looking at those screenshots. I can hear so many of the sound effects that went along with the characters and locations. One astounding thing looking back at this...

Man, what a rush of memories from looking at those screenshots. I can hear so many of the sound effects that went along with the characters and locations.

One astounding thing looking back at this game from the perspective of modern videogames is how incredibly small everything seems. The game loop was tiny, as was the collection of graphics and sounds. The steam page lists required storage of 50 MB and I'd be surprised if the original was even that.

4 votes
Comment on Teaching coding to an eight year old with Scratch? in ~tech
scarecrw
March 16
Link Parent
Perhaps you ran across this already, but Python turtle is, in my opinion, the modern successor to Logo. It might not have the same appeal as Scratch as for as ease of use or graphics, but it does...

Perhaps you ran across this already, but Python turtle is, in my opinion, the modern successor to Logo. It might not have the same appeal as Scratch as for as ease of use or graphics, but it does start students with Python which is a huge advantage if they are interested in pursuing programming further.

2 votes
Comment on Journalist Tim Burke faces charges under the US Computer Fraud and Abuse Act in ~tech
scarecrw
February 28 (edited February 28)
Link
This article seems to be bending over backwards to suggest Burke's innocence. From my understanding he accessed otherwise inaccessible information using login credentials that were not his. While...

This article seems to be bending over backwards to suggest Burke's innocence. From my understanding he accessed otherwise inaccessible information using login credentials that were not his. While clearly a significant security flaw, exploiting it is obviously still an example of unauthorized access.

This would be like suggesting that because you didn't change the locks on your doors the previous tenant has the right to break into your home.

Ethically there may still be an argument for taking this action as a journalist if the information gained is in the public interest (though I seriously doubt it in this case). Regardless, no one should be surprised that this would be legally considered unauthorized access.

11 votes

Comment on Day 25: Snowverload in ~comp.advent_of_code

scarecrw

December 25, 2023

Link

Well, not the most efficient day for me to end on, but I'm happy enough with my answer regardless. I don't remember the actual algorithm for min-cut, but I know it was related to max-flow, so I...

Well, not the most efficient day for me to end on, but I'm happy enough with my answer regardless. I don't remember the actual algorithm for min-cut, but I know it was related to max-flow, so I made up my (undoubtedly inefficient) own approach based on that.

Basic premise is that (knowing there's exactly one cut of size 3), for any two nodes on different sides of the cut the max-flow must be 3, whereas any two nodes on the same side of the cut the max-flow must be >3. Grabbing a random node, group the rest of the nodes into same side vs other side based on their max-flow.

I also don't remember the best max-flow algorithm, so mine just repeatedly performs Djikstra's in order to find a path, counts 1 flow, then removes that path and tries again.

Haskell Solution

module Main (main) where

import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import Data.Map (Map, (!))
import AOCTools (splitOn)
import Data.List (partition)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)

type Node = String
type Graph = Map Node (Set Node)

parseInput :: String -> Graph
parseInput str = foldr parseLine Map.empty (lines str)

parseLine :: String -> Graph -> Graph
parseLine str graph = graph' where
    (node, xs) = splitOn ": " str
    nodes = words xs
    graph' = foldr addEdge graph [(node, n) | n <- nodes]

addEdge :: (Node, Node) -> Graph -> Graph
addEdge (n1, n2) graph
    | Map.notMember n1 graph = addEdge (n1, n2) $ Map.insert n1 Set.empty graph
    | Map.notMember n2 graph = addEdge (n1, n2) $ Map.insert n2 Set.empty graph
    | otherwise = Map.adjust (Set.insert n1) n2 $ Map.adjust (Set.insert n2) n1 graph

removeEdge :: (Node, Node) -> Graph -> Graph
removeEdge (n1, n2) graph = Map.adjust (Set.delete n1) n2 $ Map.adjust (Set.delete n2) n1 graph

neighbors :: Graph -> Node -> [Node]
neighbors graph n = Set.toList $ graph ! n

solve1 :: Graph -> Int
solve1 graph = length a * (length b + 1) where
    testNode:nodes = Map.keys graph
    (a, b) = partition (\n -> maxFlow graph testNode n == 3) nodes

maxFlow :: Graph -> Node -> Node -> Int
maxFlow graph n1 n2 = case findPath graph n1 n2 of
    Nothing -> 0
    Just path -> 1 + maxFlow graph' n1 n2 where
        graph' = foldr removeEdge graph path

findPath :: Graph -> Node -> Node -> Maybe [(Node, Node)]
findPath graph n1 n2 = djikstra [n1] (Map.singleton n1 n1) where
    djikstra :: [Node] -> Map Node Node -> Maybe [(Node, Node)]
    djikstra [] _ = Nothing
    djikstra (n:queue) prev
        | n == n2 = Just $ reverse (buildPath prev n)
        | otherwise = djikstra (queue ++ neighborNodes) prev' where
            neighborNodes = filter (`Map.notMember` prev) $ neighbors graph n
            prev' = foldr (`Map.insert` n) prev neighborNodes
    buildPath :: Map Node Node -> Node -> [(Node, Node)]
    buildPath prev node
        | pNode == node = []
        | otherwise = (pNode, node) : buildPath prev pNode where
            pNode = prev ! node

This has been a blast participating this year! I got to try out a new language, and it was great coming to these threads to check out different approaches.

3 votes

Comment on Day 24: Never Tell Me The Odds in ~comp.advent_of_code

scarecrw

December 24, 2023

Link

Part 1 went quite smoothly, and I finished at my highest place this year at 122! Not quite the leaderboard, but much better than I was ever expecting to place this year. Nothing tricky, just...

Part 1 went quite smoothly, and I finished at my highest place this year at 122! Not quite the leaderboard, but much better than I was ever expecting to place this year. Nothing tricky, just parsing the input, finding the intersections, and checking the bounds.

Part 2 was not so nice, but I got there eventually. My solution relies on recognizing that if you rotate the vectors at a certain angle, they should all align to intersect at a singular point. I first got stuck trying to figure out how to rotate 3d vectors, but then realized that I don't actually need to rotate the vectors, I can just shift their x and y velocities until they align. My solution simply tries a range of values for the x and y velocities until all hailstones intersect at a singular point, that point being the x and y coordinates for the answer. I then repeat the process for the x and z velocities/coordinates to get the final position.

Haskell Solution

module Main (main) where
import AOCTools (splitOn, splitBy)
import Data.Ratio ((%), numerator)
import Data.Maybe (fromJust, catMaybes, mapMaybe)

lowerBound = 200000000000000
upperBound = 400000000000000

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (solve2 $ parseInput input)

data Coord = Coord {x :: Rational, y :: Rational, z :: Rational} deriving (Show)
type Position = Coord
type Velocity = Position
data Hailstone = Hailstone {position :: Position, velocity :: Velocity} deriving (Show)

parseInput :: String -> [Hailstone]
parseInput input = map parseHailstone (lines input)

parseHailstone :: String -> Hailstone
parseHailstone str = Hailstone (Coord x y z) (Coord dx dy dz) where
    (pos, vel) = splitOn " @ " str
    [x, y, z] = map (toRational . read) $ splitBy ", " pos
    [dx, dy, dz] = map (toRational . read) $ splitBy ", " vel

solve1 :: [Hailstone] -> Int
solve1 hailstones = (`div` 2) . length . filter withinBounds .catMaybes $ intersections where
    intersections = [findXYIntersect h1 h2 | h1 <- hailstones, h2 <- hailstones]
    withinBounds (x, y) = lowerBound <= x && x <= upperBound && lowerBound <= y && y <= upperBound

findXYIntersect :: Hailstone -> Hailstone -> Maybe (Rational, Rational)
findXYIntersect (Hailstone (Coord x1  y1 _) (Coord dx1 dy1 _)) (Hailstone (Coord x2 y2 _) (Coord dx2 dy2 _)) = res where
    res = if dx1 == 0 || dx2 == 0 || m1 == m2 || not inFuture then Nothing else Just (x, y)
    m1 = dy1 / dx1
    m2 = dy2 / dx2
    x = ((y2 - y1) + m1 * x1 - m2 * x2) / (m1 - m2)
    y = m1 * (x - x1) + y1
    inFuture = x `compare` x1 == dx1 `compare` 0 && x `compare` x2 == dx2 `compare` 0

solve2 :: [Hailstone] -> Integer
solve2 hailstones = numerator (x + y + z) where
    possibleVelocities = [(dx, dy) | dx <- [-300..300], dy <- [-300..300]]
    (x, y) = head $ mapMaybe (uncurry $ converge hailstones) possibleVelocities
    flippedHailstones = map swapYZ hailstones
    (_, z) = head $ mapMaybe (uncurry $ converge flippedHailstones) possibleVelocities

converge :: [Hailstone] -> Rational -> Rational -> Maybe (Rational, Rational)
converge hailstones dx dy = res where
    (s1:s2:hailstones') = map (shiftHailstone dx dy) hailstones
    res = case findXYIntersect s1 s2 of
        Nothing -> Nothing
        Just (x, y)
            | all (\r -> findXYIntersect s1 r == Just (x, y)) (s2:hailstones') -> Just (x, y)
            | otherwise -> Nothing

shiftHailstone :: Rational -> Rational -> Hailstone -> Hailstone
shiftHailstone refdx refdy (Hailstone (Coord x y z) (Coord dx dy dz)) =
    Hailstone (Coord x y z) (Coord (dx-refdx) (dy-refdy) dz)

swapYZ :: Hailstone -> Hailstone
swapYZ (Hailstone (Coord x y z) (Coord dx dy dz)) = Hailstone (Coord x z y) (Coord dx dz dy)

1 vote

Comment on Day 23: A Long Walk in ~comp.advent_of_code

scarecrw

December 23, 2023

Link

I finally started treating graph problems like graph problems today! I'm not sure if Haskell has a more idiomatic method of representing a weighted graph (I found Data.Graph but that seems limited...

I finally started treating graph problems like graph problems today! I'm not sure if Haskell has a more idiomatic method of representing a weighted graph (I found Data.Graph but that seems limited to directed, unweighted graphs), but I went with a map from each vertex to a sub-map from its neighbors to their corresponding edge weights.

I've tried to keep myself from looking anything up beyond language references while solving this year, though I'll admit I was tempted today. I ended up using the same approach for both part 1 and part 2, but reducing the maze down to its junctions and the distances between between them. This got the solving time under 10 seconds, but I'm guessing there's some clever algorithm I'm not thinking of.

So close to the end now!

Haskell Solution

{-# LANGUAGE TupleSections #-}
module Main (main) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Map (Map, (!))
import Data.Set (Set)
import Data.Maybe (fromJust, mapMaybe)
import Data.List (maximumBy)
import Data.Tuple (swap)
import Data.Function (on)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (solve2 $ parseInput input)

data MazeTile = Wall | Open | L | R | U | D deriving (Show, Eq)
type Maze = Map Coord MazeTile
type Coord = (Int, Int)

parseInput :: String -> (Maze, Coord, Coord)
parseInput str = (maze, startPos, endPos) where
    rows = length $ lines str
    cols = length $ head (lines str)
    startPos = (0, 1)
    endPos = (rows - 1, cols - 2)
    maze = Map.fromList $ concat [[((r, c), parseTile x) | (c, x) <- zip [0..] row] | (r, row) <- zip [0..] (lines str)]

parseTile :: Char -> MazeTile
parseTile c = case c of
    '#' -> Wall
    '.' -> Open
    'v' -> D
    '^' -> U
    '<' -> L
    '>' -> R
    _   -> error "Invalid Tile"

solve1 :: (Maze, Coord, Coord) -> Int
solve1 (maze, startPos, endPos) = length . fromJust $ longestPath startPos Set.empty where
    longestPath :: Coord -> Set Coord -> Maybe [Coord]
    longestPath currPos visited
        | currPos == endPos = Just []
        | otherwise = if null pathOptions then Nothing else Just bestPath where
            nextPositions = filter (`Set.notMember` visited) (getNeighbors maze currPos False)
            pathOptions = mapMaybe (\pos -> longestPath pos (Set.insert pos visited)) nextPositions
            bestPath = currPos : maximumBy (\a b -> compare (length a) (length b)) pathOptions

getNeighbors :: Maze -> Coord -> Bool -> [Coord]
getNeighbors maze (r, c) passThrough = validNeighbors where
    neighbors = if passThrough then
        if maze ! (r, c) /= Wall then [(r+1, c), (r-1, c), (r, c+1), (r, c-1)] else []
    else
        case maze ! (r, c) of
            Open -> [(r+1, c), (r-1, c), (r, c+1), (r, c-1)]
            L    -> [(r, c-1)]
            R    -> [(r, c+1)]
            U    -> [(r-1, c)]
            D    -> [(r+1, c)]
            Wall -> error "Stuck in a wall"
    validNeighbors = filter (\n -> Map.member n maze && maze ! n /= Wall) neighbors

type JunctionID = Char
type JunctionGraph = Map JunctionID (Map JunctionID Int)

idList :: [JunctionID]
idList = ['A'..'Z'] ++ ['a'..'z']

findJunctions :: Maze -> [Coord]
findJunctions maze = junctions where
    junctions = filter (\pos -> length (getNeighbors maze pos True) > 2) (Map.keys maze)

buildJunctionGraph :: Maze -> [(JunctionID, Coord)] -> JunctionGraph
buildJunctionGraph maze junctions = junctionGraph where
    idLookup = Map.fromList $ map swap junctions
    junctionGraph = Map.fromList $ [(startID, Map.fromList $ findConnectedJunctions startCoord) | (startID, startCoord) <- junctions]

    findConnectedJunctions :: Coord -> [(JunctionID, Int)]
    findConnectedJunctions startingPos = solve (map (, 1) $ getNeighbors maze startingPos True) (Set.singleton startingPos) where
        solve :: [(Coord, Int)] -> Set Coord -> [(JunctionID, Int)]
        solve [] _ = []
        solve ((x, d):xs) visited
            | Map.member x idLookup = (idLookup ! x, d) : solve xs visited
            | otherwise = solve (neighbors ++ xs) (Set.insert x visited) where
                neighbors = map (,d+1) $ filter (`Set.notMember` visited) (getNeighbors maze x True)

solve2 :: (Maze, Coord, Coord) -> Int
solve2 (maze, startPos, endPos) = longestPath (head idList) where
    junctions = zip idList (startPos : findJunctions maze ++ [endPos])
    junctionGraph = buildJunctionGraph maze junctions
    endID = idList !! (length junctions - 1)
    longestPath :: JunctionID -> Int
    longestPath startID = snd . fromJust $ solve startID Set.empty where
        solve :: JunctionID -> Set JunctionID -> Maybe ([JunctionID], Int)
        solve currID visited
            | currID == endID = Just ([endID], 0)
            | otherwise = if null pathOptions' then Nothing else Just bestPath where
                nextPositions = filter (`Set.notMember` visited) (Map.keys $ junctionGraph ! currID)
                pathOptions = mapMaybe (\jid -> solve jid (Set.insert currID visited)) nextPositions
                pathOptions' = map (\(p, d) -> (currID : p, d + (junctionGraph ! currID ! head p))) pathOptions
                bestPath = maximumBy (compare `on` snd) pathOptions'

1 vote

Comment on Day 22: Sand Slabs in ~comp.advent_of_code

scarecrw

December 22, 2023

Link

Not thrilled with my solution today; everything went fine I suppose, but I mostly just recognized that the scale of input (number of bricks, size of bricks, initial height, etc.) would permit...

Not thrilled with my solution today; everything went fine I suppose, but I mostly just recognized that the scale of input (number of bricks, size of bricks, initial height, etc.) would permit avoiding optimizations so I didn't try to get too creative with anything.

Essentially, I stored each brick as a list of all of its coordinates and the state of the field as two maps: one from a coordinate to which brick ID (if any) was there, and another from a given brick ID to its coordinates. Dropping the bricks initially was fine, as I just sorted by their z value and dropped each one a single step at a time.

I suspect there's some clever graph-based approach for part 2, tracking relationships and identifying which bricks rely on which others. Having already written functions to remove bricks and check for touching bricks, I just simulated the whole thing for each brick.

Haskell Solution

module Main (main) where
import AOCTools (splitOn, splitBy, unique)
import Data.List (sortOn)
import qualified Data.Map as Map
import Data.Map (Map, (!))
import Data.Maybe (mapMaybe)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (solve2 $ parseInput input)

type Coord = (Int, Int, Int)
type Brick = (BrickID, [Coord])
type BrickID = Int

getZ :: Coord -> Int
getZ (_, _, z) = z

parseInput :: String -> [Brick]
parseInput input = zip [0..] $ map parseBrick $ lines input

parseBrick :: String -> [Coord]
parseBrick str = brick where
    (start, end) = splitOn "~" str
    brick = buildBrick (toCoord start) (toCoord end)
    toCoord coordStr = case map read (splitBy "," coordStr) of
        [x, y, z] -> (x, y, z)
        _ -> error "invalid coordinate format"

buildBrick :: Coord -> Coord -> [Coord]
buildBrick (x1, y1, z1) (x2, y2, z2)
    | x1 == x2 && y1 == y2 && z1 == z2 = [(x1, y1, z1)]
    | x1 /= x2 = [(x, y1, z1) | x <- [min x1 x2 .. max x1 x2]]
    | y1 /= y2 = [(x1, y, z1) | y <- [min y1 y2 .. max y1 y2]]
    | z1 /= z2 = [(x1, y1, z) | z <- [min z1 z2 .. max z1 z2]]
    | otherwise = error "invalid brick"

solve1 :: [Brick] -> Int
solve1 bricks = length result where
    (settledBricksMap, brickLocationMap) = dropBricks bricks
    result = filter (canRemove settledBricksMap brickLocationMap) (Map.elems brickLocationMap)

dropBricks :: [Brick] -> (Map Coord BrickID, Map BrickID Brick)
dropBricks bricks = (settledBricksMap, brickLocationMap) where
    sortedBricks = sortOn (\(_, coords) -> minimum (map getZ coords)) bricks
    (settledBricks, settledBricksMap) = foldl dropBrick ([], Map.empty) sortedBricks
    brickLocationMap = Map.fromList [(fst b, b) | b <- settledBricks]

canRemove :: Map Coord BrickID -> Map BrickID Brick -> Brick -> Bool
canRemove settledBricksMap brickLocationMap brick = result where
    brickCells = snd brick
    settledBricksMap' = foldr Map.delete settledBricksMap brickCells
    aboveBrickIDs = mapMaybe (`Map.lookup` settledBricksMap') (snd (riseOne brick))
    bricksAbove = map (brickLocationMap !) aboveBrickIDs
    result = not. any (canDrop settledBricksMap') $ bricksAbove

dropBrick :: ([Brick], Map Coord BrickID) -> Brick -> ([Brick], Map Coord BrickID)
dropBrick (settledBricks, settledBricksMap) brick
    | canDrop settledBricksMap brick = dropBrick (settledBricks, settledBricksMap) (dropOne brick)
    | otherwise = (settledBricks', settledBricksMap') where
        settledBricks' = brick:settledBricks
        (brickID, brickCells) = brick
        settledBricksMap' = foldr (`Map.insert` brickID) settledBricksMap brickCells

canDrop :: Map Coord BrickID -> Brick -> Bool
canDrop settledBricksMap brick = not . any invalidCell . snd . dropOne $ brick where
    settledBricksMap' = foldr Map.delete settledBricksMap (snd brick)
    invalidCell :: Coord -> Bool
    invalidCell (x, y, z) = z <= 0 || (x, y, z) `Map.member` settledBricksMap'

dropOne :: Brick -> Brick
dropOne (brickID, brickCells) = (brickID, map (\(x, y, z) -> (x, y, z-1)) brickCells)

riseOne :: Brick -> Brick
riseOne (brickID, brickCells) = (brickID, map (\(x, y, z) -> (x, y, z+1)) brickCells)

solve2 :: [Brick] -> Int
solve2 bricks = sum (map numDropped (Map.elems brickLocationMap)) where
    (settledBricksMap, brickLocationMap) = dropBricks bricks
    numDropped b = countDrop settledBricksMap [b] - 1
    countDrop :: Map Coord BrickID -> [Brick] -> Int
    countDrop _ [] = 0
    countDrop remainingBricksMap (brick:toDrop) = result where
        brickCells = snd brick
        remainingBricksMap' = foldr Map.delete remainingBricksMap brickCells
        aboveBrickIDs = mapMaybe (`Map.lookup` remainingBricksMap') (snd (riseOne brick))
        bricksAbove = map (brickLocationMap !)  (unique aboveBrickIDs)
        droppable = filter (canDrop remainingBricksMap') (filter (`notElem` toDrop) bricksAbove)
        result = 1 + countDrop remainingBricksMap' (toDrop ++ droppable)

1 vote

Comment on Day 21: Step Counter in ~comp.advent_of_code
scarecrw
December 21, 2023
Link Parent
Congrats on the rankings! I love seeing people's scratchwork to see how everyone thinks about the problem slightly differently.

Congrats on the rankings! I love seeing people's scratchwork to see how everyone thinks about the problem slightly differently.

1 vote

Comment on Day 21: Step Counter in ~comp.advent_of_code

scarecrw

December 21, 2023

Link

Interesting problem for sure! Just like yesterday, careful inspection of the input was key (I forget this every year with AoC and relearn this tip every time). I didn't even catch the special...

Interesting problem for sure! Just like yesterday, careful inspection of the input was key (I forget this every year with AoC and relearn this tip every time). I didn't even catch the special property of the number of steps until after solving...

Solution Discussion

Part 1 went smoothly enough, just tracking a set of reachable positions for each step. I suppose I could have memoized the neighbor finding, which may have sped up part 2 a bit, but I didn't bother.

Part 2 was an endeavor! I recognized that the expansion of the reachable positions would leave a large area in the middle just flipping between two states, which wouldn't need to be calculated. My initial thought was to only track the positions at the perimeter of this area, reducing the size of the reachable positions from ∝n^2 to ∝n. This actually worked, and I kept it as "part 1.5", but I had forgotten that I would still need to step n times, so this solution just brought brute force from n^3 to n^2...

I then figured that, due to the repetition of the map, with any number of steps that was a multiple of the map size, the reachable states should grow quadratically. Using the "part 1.5" solution, I found 3 points with the same step offset as the goal number of steps, did a quadratic interpolation, and then plugged in the actual number of steps.

Haskell Solution

module Main (main) where
import qualified Data.Map as Map
import Data.Map (Map, (!))
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (genericLength)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (uncurry solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (uncurry solve2 $ parseInput input)

type Coord = (Integer, Integer)

data GardenCell = Plot | Rock deriving (Show, Eq)

type Garden = (Map Coord GardenCell, Integer, Integer)

parseCell :: Char -> GardenCell
parseCell c = case c of
    '.' -> Plot
    'S' -> Plot
    '#' -> Rock
    _   -> error "invalid garden cell"

parseInput :: String -> (Garden, Coord)
parseInput str = ((gardenMap, rows, cols), startingPos) where
    rows = genericLength . lines $ str
    cols = genericLength . head . lines $ str
    indexed = concat [[((r, c), x)| (c, x) <- zip [0..] row] | (r, row) <- zip [0..] (lines str)]
    gardenMap = Map.fromList $ map (\(c, x) -> (c, parseCell x)) indexed
    startingPos = fst . head . filter (\(c, x) -> x == 'S') $ indexed

solve1 :: Garden -> Coord -> Int
solve1 garden startingPos = Set.size finalPositions where
    startingPositions = Set.singleton startingPos
    finalPositions = iterate step startingPositions !! 64 where
        step :: Set Coord -> Set Coord
        step positions = positions' where
            positions' = foldl (getOpenNeighbors garden) Set.empty positions

getOpenNeighbors :: Garden -> Set Coord -> Coord -> Set Coord
getOpenNeighbors garden s (r, c) = s' where
    neighbors = filter (\pos -> getCell garden pos /= Rock) [(r+1, c), (r-1, c), (r, c+1), (r, c-1)]
    s' = foldr Set.insert s neighbors

getCell :: Garden -> Coord -> GardenCell
getCell (gardenMap, rows, cols) (r, c) = gardenMap ! (r `mod` rows, c `mod` cols)

solve1point5 :: Garden -> Coord -> Integer -> Integer
solve1point5 garden startingPos numSteps = finalPositions where
    limit = 10
    singleStart = Set.singleton startingPos
    startingPositions = if even numSteps then singleStart else nextPositions singleStart
    finalPositions = step (startingPositions, numSteps `mod` 2, toInteger (Set.size startingPositions)) where
        step :: (Set Coord, Integer, Integer) -> Integer
        step (positions, n, count)
            | n == numSteps = count
            | otherwise = step (positions', n+2, count') where
            positions' = Set.filter (\pos -> dist pos startingPos > n - limit) $ nextPositions (nextPositions positions)
            newCells = Set.difference positions' positions
            count' = count + toInteger (Set.size newCells)
    nextPositions :: Set Coord -> Set Coord
    nextPositions = foldl (getOpenNeighbors garden) Set.empty

dist :: Coord -> Coord -> Integer
dist (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2)

solve2 :: Garden -> Coord -> Integer
solve2 garden startingPos = a * x^2 + b * x + c where
    (_, cycleLength, _) = garden
    (x, offset) = 26501365 `divMod` cycleLength
    f = solve1point5 garden startingPos
    (a, b, c) = quadInterp (f offset, f (offset+cycleLength), f (offset+2*cycleLength))

quadInterp :: (Integer, Integer, Integer) -> (Integer, Integer, Integer)
quadInterp (y0, y1, y2) = (a, b, c) where
    a = (y2 - 2*y1 + y0) `div` 2
    b = (4*y1 - y2 - 3*y0) `div` 2
    c = y0

1 vote

Comment on Day 19: Aplenty in ~comp.advent_of_code

scarecrw

December 19, 2023

Link

Another solid day! I tried making use of record syntax a bit more, which sometimes turned out well (updating/splitting a range) and sometimes poorly (kind of frustrating to have s and x in the...

Another solid day! I tried making use of record syntax a bit more, which sometimes turned out well (updating/splitting a range) and sometimes poorly (kind of frustrating to have s and x in the module's namespace).

In classic AoC tradition, I spent far too long investigating range overlaps, combinatorics miscalculations, etc. before realizing I was using the range 0 - 4000 instead of 1 - 4000...

Part 1

module Part1 (solve) where

import AOCTools (splitBy, splitOn)
import qualified Data.Map as Map
import Data.Map ((!))

solve :: String -> Int
solve str = sum (map partRating (filter (testPart workflows) parts)) where
    (workflows, parts) = parseInput str

type ID = String

data Workflow = Workflow { name :: ID, rules :: [Rule], final :: ID }

type Rule = (Part -> Bool, ID)

data Part = Part { x :: Int, m :: Int, a :: Int, s :: Int }

parseRule :: String -> Rule
parseRule str = (pred, res) where
    (predStr, res) = splitOn ":" str
    letter : op : val = predStr
    v = read val
    o = case op of
        '>' -> (>)
        '<' -> (<)
    l = case letter of
        'x' -> x
        'm' -> m
        'a' -> a
        's' -> s
    pred p = o (l p) v

parseWorkflow :: String -> Workflow
parseWorkflow str = Workflow name rules final where
    name = takeWhile (/= '{') str
    innerStr = takeWhile (/='}') (drop (length name + 1) str)
    pieces = splitBy "," innerStr
    rules = map parseRule (take (length pieces - 1) pieces)
    final = pieces !! (length pieces - 1)

partRating :: Part -> Int
partRating (Part xVal mVal aVal sVal) = xVal + mVal + aVal + sVal

parsePart :: String -> Part
parsePart str = Part xVal mVal aVal sVal where
    pieces = splitBy "," (takeWhile (/='}') (tail str))
    [xVal, mVal, aVal, sVal] = map (read . drop 2) pieces

parseInput :: String -> ([Workflow], [Part])
parseInput s = (workflows, parts) where 
    (workflowStrs, partsStrs) = splitOn "\n\n" s
    workflows = map parseWorkflow $ lines workflowStrs
    parts = map parsePart $ lines partsStrs

testPart :: [Workflow] -> Part -> Bool
testPart workflows part = testPartHelper "in" where
    workflowMap = Map.fromList (map (\w -> (name w, w)) workflows)
    testPartHelper :: ID -> Bool
    testPartHelper "A" = True
    testPartHelper "R" = False
    testPartHelper idNum = testPartHelper $ processPart (workflowMap ! idNum) part

processPart :: Workflow -> Part -> ID
processPart workflow part = helper (rules workflow) where
    helper [] = final workflow
    helper ((rule, result):xs) = if rule part then result else helper xs

Part 2

module Part2 (solve) where

import AOCTools (splitBy, splitOn)
import qualified Data.Map as Map
import Data.Map (Map, (!))

solve :: String -> Integer
solve str = result where
    workflows = parseInput str
    workflowMap = Map.fromList (map (\w -> (name w, w)) workflows)
    validParts = findValidParts workflowMap (MetaPart sRange sRange sRange sRange) "in"
    sRange = Range 1 4000
    result = findCombinations validParts

type ID = String

data Range = Range { start :: Integer, end :: Integer } deriving (Show, Eq)

data MetaPart = MetaPart { x :: Range, m :: Range, a :: Range, s :: Range } deriving (Show, Eq)

data Workflow = Workflow { name :: ID, rules :: [Rule], final :: ID }

type Rule = (Char, Range, ID)

parseInput :: String -> [Workflow]
parseInput = map parseWorkflow . lines .  fst . splitOn "\n\n"

parseWorkflow :: String -> Workflow
parseWorkflow str = Workflow name rules final where
    name = takeWhile (/= '{') str
    innerStr = takeWhile (/='}') (drop (length name + 1) str)
    pieces = splitBy "," innerStr
    rules = map parseRule (take (length pieces - 1) pieces)
    final = pieces !! (length pieces - 1)

parseRule :: String -> Rule
parseRule str = (p, r, n) where
    (predStr, n) = splitOn ":" str
    p = head predStr
    v = read $ drop 2 predStr
    r = case predStr !! 1 of
        '<' -> Range 1 (v - 1)
        '>' -> Range (v + 1) 4000
        _ -> error "invalid rule"

findValidParts :: Map ID Workflow -> MetaPart -> ID -> [MetaPart]
findValidParts _ part "A" = [part]
findValidParts _ _ "R" = []
findValidParts workflowMap part name
    | isUselessPart part = []
    | otherwise = helper (rules workflow) part where
        workflow = workflowMap ! name
        helper :: [Rule] -> MetaPart -> [MetaPart]
        helper [] part = findValidParts workflowMap part (final workflow)
        helper (rule:xs) part = findValidParts workflowMap validPart validID ++ helper xs invalidPart where
            (validPart, invalidPart, validID) = splitPart rule part

splitPart :: Rule -> MetaPart -> (MetaPart, MetaPart, ID)
splitPart (component, range, validID) part = (validPart, invalidPart, validID) where
    validPart = case component of 
        'x' -> part { x = overlap range (x part) }
        'm' -> part { m = overlap range (m part) }
        'a' -> part { a = overlap range (a part) }
        's' -> part { s = overlap range (s part) }
    invalidPart = case component of 
        'x' -> part { x = overlap (inverseRule range) (x part) }
        'm' -> part { m = overlap (inverseRule range) (m part) }
        'a' -> part { a = overlap (inverseRule range) (a part) }
        's' -> part { s = overlap (inverseRule range) (s part) }

inverseRule :: Range -> Range
inverseRule (Range a b)
    | a == 1    = Range (b+1) 4000
    | b == 4000 = Range 1     (a-1)
    | otherwise = error "invalid range"

overlap :: Range -> Range -> Range
overlap (Range a b) (Range c d) = Range (max a c) (min b d)

isUselessPart :: MetaPart -> Bool
isUselessPart part = any (\(Range a b) -> b < a) [x part, m part, a part, s part]

findCombinations :: [MetaPart] -> Integer
findCombinations parts = result where
    result = sum $ map findComb parts
    findComb part = xSize * mSize * aSize * sSize where
        xSize = rangeSize (x part)
        mSize = rangeSize (m part)
        aSize = rangeSize (a part)
        sSize = rangeSize (s part)
    rangeSize (Range st en) = en - st + 1

1 vote

Comment on Day 18: Lavaduct Lagoon in ~comp.advent_of_code

scarecrw

December 18, 2023

Link

Quite a tricky part 2! My earlier attempts at brevity have gone out the window, but I'm happy to say I was able to come up with a solution and implement it without giving in and looking anything...

Quite a tricky part 2! My earlier attempts at brevity have gone out the window, but I'm happy to say I was able to come up with a solution and implement it without giving in and looking anything up.

Part 1

Nothing clever with this one, just stepped out the border into a set of coordinates and then flood-filled. I cheated a little by inspecting the border and checking where I could place the first point to ensure it was inside the bounds, so this could fail for a more generic input case.

type Instruction = (Direction, Integer)
data Direction = North | South | East | West deriving (Eq, Show)
type Coord = (Integer, Integer)
type TrenchMap = Set Coord

moveDirN :: Integer -> Direction -> Coord -> Coord
moveDirN n North (r, c) = (r-n, c)
moveDirN n South (r, c) = (r+n, c)
moveDirN n East (r, c) = (r, c+n)
moveDirN n West (r, c) = (r, c-n)

moveDir :: Direction -> Coord -> Coord
moveDir = moveDirN 1

neighbors :: Coord -> [Coord]
neighbors (r, c) = [(r+1, c), (r-1, c), (r, c+1), (r, c-1)]

parseInput1 :: String -> [Instruction]
parseInput1 input = map parseRow (lines input) where
    parseRow row = (direction, distance) where
        [dir, dist, col] = words row
        direction = case head dir of
            'R' -> East
            'L' -> West
            'U' -> North
            'D' -> South
        distance = read dist

solve1 :: [Instruction] -> Int
solve1 input = result where
    trench = digTrench (0, 0) Set.empty input
    fill = floodFill (1, 1) trench
    result = Set.size fill + Set.size trench
    digTrench :: Coord -> Set Coord -> [Instruction] -> Set Coord
    digTrench _ trenchMap [] = trenchMap
    digTrench pos trenchMap ((direction, distance):xs) = digTrench pos' trenchMap' xs where
        (pos', trenchMap') = digLine pos trenchMap distance
        digLine p tMap 0 = (p, tMap)
        digLine p tMap d = digLine (moveDir direction p) (Set.insert p tMap) (d-1)

floodFill :: Coord -> Set Coord -> Set Coord
floodFill startingPos walls = flood [startingPos] walls Set.empty where
    flood [] _ seen = seen
    flood (x:xs) walls seen
        | Set.member x seen = flood xs walls seen
        | Set.member x walls = flood xs walls seen
        | otherwise = flood (neighbors x ++ xs) walls (Set.insert x seen)

Part 2

While probably not the most elegant solution, I'm fairly proud of coming up with this one: first I sliced the space on horizontal and vertical lines through every corner point, creating an irregular grid of rectangles. Each of these rectangles should be wholly inside or outside the shape, so I can just filter for the ones inside the shape and then add up their areas. Accounting for overlapping edges/corners was kind of a pain, but otherwise not too bad.

I'm glad I remembered a trick for identifying whether a point is inside a polygon: draw a ray from the point in any direction and count the number of edges that the ray crosses, if it's odd it's inside the shape!

type Rectangle = (Coord, Coord)
type Line = (Coord, Coord)

area :: Rectangle -> Integer
area ((r1, c1), (r2, c2)) = (r2 - r1 + 1) * (c2 - c1 + 1)

lineLength :: Line -> Integer
lineLength ((r1, c1), (r2, c2))
    | r1 == r2 = abs (c2 - c1) + 1
    | c1 == c2 = abs (r2 - r1) + 1
    | otherwise = error "not a line"

rectangleCorners :: Rectangle -> [Coord]
rectangleCorners((r1, c1), (r2, c2)) = [(r1, c1), (r1, c2), (r2, c1), (r2, c2)]

rectangleLines :: Rectangle -> [Line]
rectangleLines ((r1, c1), (r2, c2)) = [
    ((r1, c1), (r1, c2)), 
    ((r1, c1), (r2, c1)), 
    ((r1, c2), (r2, c2)), 
    ((r2, c1), (r2, c2))
    ]

parseInput2 :: String -> [Instruction]
parseInput2 input = map parseRow (lines input) where
    parseRow row = (direction, distance) where
        row' = dropWhile (/='#') row
        dir = row' !! 6
        dist = take 5 $ drop 1 row'
        direction = case dir of
            '0' -> East
            '1' -> South
            '2' -> West
            '3' -> North
        distance = parseHex dist

solve2 :: [Instruction] -> Integer
solve2 input = filledArea - lineCorrection + pointCorrection where
    corners = findCorners (0, 0) input []
    rows = (Set.elems . Set.fromList) $ map fst corners
    cols = (Set.elems . Set.fromList) $ map snd corners
    rectangles = [((r1, c1), (r2, c2)) | (r1, r2) <- zip rows (tail rows), (c1, c2) <- zip cols (tail cols)]
    filledRectangles = filter inShape rectangles

    findCorners p [] pts = p : pts
    findCorners p ((dir, dist):inst) pts = findCorners (moveDirN dist dir p) inst (p : pts)

    filledArea = sum (map area filledRectangles)
    lineCorrection = findLineCorrection filledRectangles Set.empty
    pointCorrection = findPointCorrection filledRectangles

    inShape :: Rectangle -> Bool
    inShape ((r1, c1), (r2, c2)) = crossCount `mod` 2 == 1 where
        rAvg = (r1 + r2) `div` 2
        cAvg = (c1 + c2) `div` 2
        crossCount = length $ filter crossRight (zip corners (tail corners))
        crossRight ((r1, c1), (r2, c2)) = min r1 r2 < rAvg && rAvg < max r1 r2 && c1 > cAvg

    findLineCorrection :: [Rectangle] -> Set Line -> Integer
    findLineCorrection [] _ = 0
    findLineCorrection (rect:rects) seen = n + findLineCorrection rects seen' where
        seen' = foldr Set.insert seen $ rectangleLines rect
        n = sum $ map lineLength $ filter (`Set.member` seen) $ rectangleLines rect

    findPointCorrection :: [Rectangle] -> Integer
    findPointCorrection rects = pntCorrect allPoints where
        allPoints = concatMap rectangleCorners rects
        pntCorrect :: [Coord] -> Integer
        pntCorrect = genericLength . filter (==4) . Map.elems . counts

2 votes

Comment on Day 16: The Floor Will Be Lava in ~comp.advent_of_code

scarecrw

December 16, 2023

Link

Fun day! While I wasn't aiming for speed this year, I was happy to have most everything go right here and require very little debugging; only took a few minutes to write part 2. My solution for...

Fun day! While I wasn't aiming for speed this year, I was happy to have most everything go right here and require very little debugging; only took a few minutes to write part 2. My solution for part 2 is not particularly efficient, however, but improving that would likely have required some substantial rewrites to change.

I noticed we haven't had much for graphs or trees yet, which I'm eager to try out.

Haskell Solution

module Main (main) where

import qualified Data.Set as Set
import Data.Map (Map, fromList, (!))
import Data.Set (Set, empty, size, member, insert)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (solve2 $ parseInput input)

type Coord = (Int, Int)

data Cell = Empty | Horizontal | Vertical | BLTR | TLBR

data Direction = North | South | East | West deriving (Eq, Ord)

type Board = (Map Coord Cell, Int, Int)

data Particle = Particle {
    coord :: Coord,
    direction :: Direction
} deriving (Eq, Ord)

parseCell :: Char -> Cell
parseCell c = case c of
    '.'  -> Empty
    '-'  -> Horizontal
    '|'  -> Vertical
    '/'  -> BLTR
    '\\' -> TLBR
    _    -> error "invalid character"

parseInput :: String -> Board
parseInput input = (arr, numRows, numCols) where
    numRows = length $ lines input
    numCols = length $ head (lines input)
    arr = fromList (concatMap (uncurry parseRow) (zip [0..] (lines input)))
    parseRow rowNum s = [((rowNum, colNum), parseCell c) | (colNum, c) <- zip [0..] s]

solve1 :: Board -> Int
solve1 board = solve board (Particle (0, 0) East)

solve :: Board -> Particle -> Int
solve (arr, numRows, numCols) start = uniquePositions $ solveRec [start] empty where
    onBoard (Particle (r, c) _) = 0 <= r && r < numRows && 0 <= c && c < numCols
    solveRec [] seen = seen
    solveRec (x:xs) seen
        | x `member` seen = solveRec xs seen
        | otherwise = solveRec queue seen' where
            resultingParticles = findResultingParticles x (arr ! coord x)
            queue = filter onBoard resultingParticles ++ xs
            seen' = x `insert` seen

findResultingParticles :: Particle -> Cell -> [Particle]
findResultingParticles (Particle (r, c) direction) cell = case (direction, cell) of
    (North, Horizontal) -> [Particle (r, c-1) West, Particle (r, c+1) East]
    (North, BLTR)       -> [Particle (r, c+1) East]
    (North, TLBR)       -> [Particle (r, c-1) West]
    (North, _)          -> [Particle (r-1, c) North]
    (South, Horizontal) -> [Particle (r, c-1) West, Particle (r, c+1) East]
    (South, BLTR)       -> [Particle (r, c-1) West]
    (South, TLBR)       -> [Particle (r, c+1) East]
    (South, _)          -> [Particle (r+1, c) South]
    (East, Vertical)    -> [Particle (r-1, c) North, Particle (r+1, c) South]
    (East, BLTR)        -> [Particle (r-1, c) North]
    (East, TLBR)        -> [Particle (r+1, c) South]
    (East, _)           -> [Particle (r, c+1) East]
    (West, Vertical)    -> [Particle (r-1, c) North, Particle (r+1, c) South]
    (West, BLTR)        -> [Particle (r+1, c) South]
    (West, TLBR)        -> [Particle (r-1, c) North]
    (West, _)           -> [Particle (r, c-1) West]

uniquePositions :: Set Particle -> Int
uniquePositions = size . Set.map coord

solve2 :: Board -> Int
solve2 board = maximum $ map (solve board) possibleStarts where
    (_, numRows, numCols) = board
    possibleStarts = [Particle (0, c)         South | c <- [0..numCols-1]] ++
                     [Particle (numRows-1, c) North | c <- [0..numCols-1]] ++
                     [Particle (r, 0)         East  | r <- [0..numRows-1]] ++
                     [Particle (r, numCols-1) West  | r <- [0..numRows-1]]

2 votes

Comment on Day 15: Lens Library in ~comp.advent_of_code

scarecrw

December 15, 2023

Link

This was the first day I actually felt hampered by Haskell. I'm sure someone more comfortable with the language could accomplish this naturally, but I was just wishing for my familiar data...

This was the first day I actually felt hampered by Haskell. I'm sure someone more comfortable with the language could accomplish this naturally, but I was just wishing for my familiar data structures.

I initially implemented everything with lists, but went back and updated the outer list to an Array as the original seemed wastefully slow. I could probably substitute the inner lists as well for something like OMap, but it's running reasonably quickly as is.

Haskell Solution

module Main (main) where

import AOCTools (splitBy)
import Data.Char (ord, isNumber, isAlpha)
import Data.Array (listArray, Array, (//), (!), elems)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ splitBy "," input)
    putStrLn $ "Part 2: " ++ show (solve2 $ splitBy "," input)

hashFunc :: String -> Int
hashFunc = foldl (\n x -> (n + ord x) * 17 `mod` 256) 0

solve1 :: [String] -> Int
solve1 = sum . map hashFunc

data Lens = Lens { lensLabel :: String, focalLength :: Int }

calculateFocusingPower :: Array Int [Lens] -> Int
calculateFocusingPower boxes = prod (prod focalLength) (elems boxes) where
    prod f x = sum $ zipWith (*) [1..] (map f x)

applyStep :: Array Int [Lens] -> String -> Array Int [Lens]
applyStep boxes step
    | '=' `elem` step = addLens boxes (Lens label focalLength)
    | otherwise = removeLens boxes label
    where
        label = takeWhile isAlpha step
        focalLength = read $ dropWhile (not . isNumber) step

addLens :: Array Int [Lens] -> Lens -> Array Int [Lens]
addLens boxes lens = boxes // [(boxNum, add lens (boxes ! boxNum))] where
    boxNum = hashFunc $ lensLabel lens
    add lens [] = [lens]
    add lens (l:ls)
        | lensLabel l == lensLabel lens = lens : ls
        | otherwise = l : add lens ls

removeLens :: Array Int [Lens] -> String -> Array Int [Lens]
removeLens boxes label = boxes // [(boxNum, remove label (boxes ! boxNum))] where
    boxNum = hashFunc label
    remove label [] = []
    remove label (l:ls)
        | lensLabel l == label = ls
        | otherwise = l : remove label ls

solve2 :: [String] -> Int
solve2 = calculateFocusingPower . foldl applyStep initialBoxes where
    initialBoxes = listArray (0, 255) $ replicate 256 []

1 vote

Comment on Day 14: Reflector Dish in ~comp.advent_of_code

scarecrw

December 14, 2023

Link

Part 1 was a breeze, and I even correctly predicted a good chunk of part 2. I then proceeded to muck about making mistake after mistake with the cycle index until I actually got it working. Oh...

Part 1 was a breeze, and I even correctly predicted a good chunk of part 2. I then proceeded to muck about making mistake after mistake with the cycle index until I actually got it working. Oh well, I'm still pleased with how most of my solution turned out, especially tilting in a single line!

Haskell Solution

{-# LANGUAGE NumericUnderscores #-}

module Main (main) where
    
import Data.List (transpose, sort, intercalate, elemIndex)
import AOCTools (splitBy)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ lines input)
    putStrLn $ "Part 2: " ++ show (solve2 $ lines input)

tiltNorth :: [String] -> [String]
tiltNorth = transpose . tiltWest . transpose

tiltSouth :: [String] -> [String]
tiltSouth = transpose . tiltEast . transpose

tiltWest :: [String] -> [String]
tiltWest = map reverse . tiltEast . map reverse

tiltEast :: [String] -> [String]
tiltEast = map $ intercalate "#" . map sort . splitBy "#"

calculateLoad :: [String] -> Int
calculateLoad platform = sum $ zipWith (*) [1..] rowCounts where
    rowCounts = map (length . filter (=='O')) (reverse platform)

solve1 :: [String] -> Int
solve1 = calculateLoad . tiltNorth

tiltCycle :: [String] -> [String]
tiltCycle = tiltEast . tiltSouth . tiltWest . tiltNorth

solve2 :: [String] -> Int
solve2 input = calculateLoad result where
     platforms = iterate tiltCycle input
     (cycleStart, cycleLength, cyclePattern) = findCycle 0 []
     result = cyclePattern !! ((1_000_000_000 - cycleStart) `mod` cycleLength)
     findCycle i prev = case elemIndex curr prev of
        Just x -> (i, x + 1, reverse (take (x+1) prev))
        Nothing -> findCycle (i+1) (curr:prev)
        where curr = platforms !! i

1 vote

Comment on Day 12: Hot Spring in ~comp.advent_of_code

scarecrw

December 12, 2023

Link

Fun day, and continuing to step up the difficulty! Overall I'm not especially thrilled with my solution; after the manipulation to make it memoized it's no longer very readable (and I'm too tired...

Fun day, and continuing to step up the difficulty!

Overall I'm not especially thrilled with my solution; after the manipulation to make it memoized it's no longer very readable (and I'm too tired to bother cleaning it up).

I am, however, happy to have learned how Haskell can implement memoization with just a list. It took some mangling to convert my solution into taking a single Int parameter, but after that the conversion to the memoized form was neat.

Haskell Solution

module Main (main) where

import Data.List (intercalate)
import AOCTools (splitBy)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ lines input)
    putStrLn $ "Part 2: " ++ show (solve2 $ lines input)

parseRow :: String -> (String, [Int])
parseRow s = (springs ++ ".", nums) where -- add extra '.' to simplify end state
    springs = takeWhile (/=' ') s
    numStr = tail (dropWhile (/=' ') s)
    nums = map read $ splitBy "," numStr

solve1 :: [String] -> Integer
solve1 input = sum $ map (uncurry solve . parseRow) input

solve2 :: [String] -> Integer
solve2 input = solve1 $ map unfold input where
    unfold s = springs ++ " " ++ nums where
        [origSprings, origNums] = splitBy " " s
        springs = intercalate "?" (replicate 5 origSprings)
        nums = intercalate "," (replicate 5 origNums)

solve :: String -> [Int] -> Integer
solve s n = memo_solve 0 where
    sLen = length s
    nLen = length n
    memo_solve = (map hsolve [0..] !!)
    hsolve v
        | j == nLen = if '#' `notElem` drop i s then 1 else 0
        | i == sLen = 0
        | s !! i == '.' = op1
        | sLen - i < n !! j + 1 = 0
        | s !! i == '?' = if couldFit then op1 + op2 else op1
        | couldFit = op2 
        | otherwise = 0
        where
            (i, j) = divMod v sLen
            couldFit = s !! (i + (n !! j)) /= '#' && notElem '.' (take (n !! j) (drop i s))
            op1 = memo_solve $ (i+1)*sLen + j
            op2 = memo_solve $ (i + (n !! j) + 1)*sLen + (j+1)

1 vote

Comment on Day 11: Cosmic Expansion in ~comp.advent_of_code

scarecrw

December 11, 2023

Link

A fun day! I'll admit my initial approach was to actually manipulate the array, which obviously needed reworking for part 2. After writing part 2 I went back and refactored as there was no need to...

A fun day! I'll admit my initial approach was to actually manipulate the array, which obviously needed reworking for part 2. After writing part 2 I went back and refactored as there was no need to have two different approaches.

Haskell Solution

module Main (main) where
import Data.List (transpose)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ lines input)
    putStrLn $ "Part 2: " ++ show (solve2 $ lines input)

data Coord = Coord Integer Integer

dist :: Coord -> Coord -> Integer
dist (Coord r1 c1) (Coord r2 c2) = abs (r1 - r2) + abs (c1 - c2)

findGalaxies :: [String] -> Integer -> [Coord]
findGalaxies universe expansionSize = expandedResult where
    findEmpty = map fst . filter (all (=='.') . snd) . zip [0..]
    emptyRows = findEmpty universe
    emptyCols = findEmpty $ transpose universe
    rowIndexed = zip universe [0..]
    rcIndexed = concatMap labelVals rowIndexed where
        labelVals (s, r) = zipWith (\v c -> (Coord r c, v)) s [0..]
    result = map fst $ filter ((=='#') . snd) rcIndexed
    expandedResult = map (expand expansionSize emptyRows emptyCols) result

expand :: Integer -> [Integer] -> [Integer] -> Coord -> Coord
expand expansionSize eRows eCols (Coord r c) = Coord r' c' where
    r' = expanded eRows r
    c' = expanded eCols c
    expanded [] i = i
    expanded (x:xs) i
        | x < i = expansionSize + expanded xs i
        | otherwise = i

solve :: [String] -> Integer -> Integer
solve universe n = result where
    galaxies = findGalaxies universe n
    result = distances galaxies where
        distances [] = 0
        distances (x:xs) = sum (map (dist x) xs) + distances xs

solve1 :: [String] -> Integer
solve1 = flip solve 1

solve2 :: [String] -> Integer
solve2 = flip solve 999999

I've been noticing how much my approach to problems has changed using Haskell. Little things like the ease of defining new data types or having list tools like transpose at hand make me much more likely to work them into my solution. It's surprising how minor language difference will nudge you towards defaulting to certain tools.

2 votes

Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code
scarecrw
December 8, 2023 (edited December 8, 2023)
Link Parent
You can also get around that particular omission with a neat identity! spoilers lcm = lambda a, b: a * b // gcd(a, b)
You can also get around that particular omission with a neat identity!
spoilers

lcm = lambda a, b: a * b // gcd(a, b)
2 votes

Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code

scarecrw

December 8, 2023 (edited December 8, 2023)

Link

I feel like I got a bit lucky that my first guess at part 2 worked. Spoilers Not looking at the input, I was worried there could have been cycles with multiple `XXZ` patterns at different periods,...

I feel like I got a bit lucky that my first guess at part 2 worked.

Spoilers

Not looking at the input, I was worried there could have been cycles with multiple `XXZ` patterns at different periods, or offsets from starting in an initial state not included in the cycle. I know in at least one year a challenge required bringing out the Chinese remainder theorem.

This day also got me to finally start looking at different data structures in Haskell. I found Data.Map, but was surprised to find it has lookup of O(log(n)). More than enough for today, but interesting nonetheless.

Haskell Solution

module Main (main) where
import Prelude hiding (lookup)
import Data.Map (Map, fromList, lookup, keys)

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (uncurry solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (uncurry solve2 $ parseInput input)

parseInput :: String -> (String, Map String (String, String))
parseInput input = (steps, mapping) where
    steps = head $ lines input
    mappingStrs = drop 2 $ lines input
    mapping = fromList $ map parseLine mappingStrs

parseLine :: String -> (String, (String, String))
parseLine line = (a, (b, c)) where
    a = take 3 line
    b = take 3 $ drop 7 line
    c = take 3 $ drop 12 line

nextNode :: Map String (String, String) -> String -> Char -> String
nextNode mapping curr direction = case lookup curr mapping of
    Nothing -> error "key not found"
    Just (l, r) -> case direction of
        'L' -> l
        'R' -> r
        _   -> error "invalid step"

solve :: Map String (String, String) -> String -> (String -> Bool) -> [Char] -> Int
solve mapping steps endCond start = solveRec (cycle steps) start 0 where
    solveRec steps curr n
        | endCond curr = n
        | otherwise = solveRec (tail steps) (nextNode mapping curr (head steps)) (n+1)

solve1 :: String -> Map String (String, String) -> Int
solve1 steps mapping = solve mapping steps (=="ZZZ") "AAA"

solve2 :: String -> Map String (String, String) -> Int
solve2 steps mapping = foldr lcm 1 cycleLengths where
    aStarts = filter ((=='A') . (!!2)) $ keys mapping
    cycleLengths = map (solve mapping steps ((=='Z') . (!!2))) aStarts

I'm sure I'm still doing plenty of non-idiomatic goofiness, but that's what trying new things is for!

1 vote

Comment on Day 5: If You Give A Seed A Fertilizer in ~comp.advent_of_code

scarecrw

December 5, 2023 (edited December 5, 2023)

Link

Full Solution in Haskell module Main (main) where import AOCTools ( splitBy ) main :: IO () main = do input <- readFile "./input.txt" putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)...

Full Solution in Haskell

module Main (main) where

import AOCTools ( splitBy )

main :: IO ()
main = do
    input <- readFile "./input.txt"
    putStrLn $ "Part 1: " ++ show (solve1 $ parseInput input)
    putStrLn $ "Part 2: " ++ show (solve2 $ parseInput input)

-- Data Types & Parsing

data ProductionMapping = Mapping {
    sourceName :: String,
    destinationName :: String,
    mappings :: [RangeMap]
} deriving (Show)

data RangeMap = RangeMap {
    destinationStart :: Integer,
    sourceStart :: Integer,
    rangeLength :: Integer
} deriving (Show)

data Range = Range {
    start :: Integer,
    end :: Integer
} deriving (Show)

parseInput :: String -> ([Integer], [ProductionMapping])
parseInput input = (seeds, prodMaps) where
    sections = splitBy "\n\n" input
    seeds = map read (tail . words . head $ sections)
    prodMaps = map parseProductionMapping $ tail sections

parseProductionMapping :: String -> ProductionMapping
parseProductionMapping input = Mapping source dest maps where
    [source, _, dest] = take 3 (splitBy "-" (head (words input)))
    maps = map parseRangeMap $ tail (lines input)

parseRangeMap :: String -> RangeMap
parseRangeMap s = RangeMap dst src rng where
    [dst, src, rng] = map read $ words s

-- Helper Functions

rangeIntersection:: Range -> Range -> Maybe Range
rangeIntersection(Range a b) (Range c d)
    | b <= c = Nothing
    | a >= d = Nothing
    | otherwise = Just $ Range (max a c) (min b d)

rangeSubtraction :: Range -> Range -> [Range]
rangeSubtraction (Range a b) (Range c d) = filter (\r -> start r < end r) ranges where
    ranges = [Range a (min b c), Range (max a d) b]

-- Part 1

solve1 :: ([Integer], [ProductionMapping]) -> Integer
solve1 (seeds, prodMaps) = minimum locations where
    locations = map (findLocation "seed") seeds
    findLocation :: String -> Integer -> Integer
    findLocation "location" val = val
    findLocation stage val = uncurry findLocation $ findNextStage prodMaps stage val

findNextStage :: [ProductionMapping] -> String -> Integer -> (String, Integer)
findNextStage prodMaps stage val = (stage', val') where
    mapping = head $ filter (\m -> sourceName m == stage) prodMaps
    stage' = destinationName mapping
    val' = processStage (mappings mapping) val

processStage :: [RangeMap] -> Integer -> Integer
processStage [] v = v
processStage ((RangeMap dst src rng):remMaps) v
    | src <= v && v < src + rng = v - src + dst
    | otherwise = processStage remMaps v

-- Part 2

solve2 :: ([Integer], [ProductionMapping]) -> Integer
solve2 (seeds, prodMaps) = minimum (map start locations) where
    seedRanges = pairUp seeds where
        pairUp [] = []
        pairUp (a:b:t) = Range a (a+b) : pairUp t
    locations = findLocation "seed" seedRanges
    findLocation :: String -> [Range] -> [Range]
    findLocation "location" ranges = ranges
    findLocation stage ranges = uncurry findLocation $ findNextStageRange prodMaps stage ranges

findNextStageRange :: [ProductionMapping] -> String -> [Range] -> (String, [Range])
findNextStageRange prodMaps stage ranges = (stage', ranges') where
    mapping = head $ filter (\m -> sourceName m == stage) prodMaps
    stage' = destinationName mapping
    ranges' = concatMap (processStageRange (mappings mapping)) ranges

processStageRange :: [RangeMap] -> Range -> [Range]
processStageRange [] r = [r]
processStageRange ((RangeMap dst src rng):remMaps) r = case rangeIntersection r srcRange of
    Nothing -> processStageRange remMaps r
    Just (Range a b) -> overlap : remainder where
        overlap = Range (a - src + dst) (b - src + dst)
        remainder = concatMap (processStageRange remMaps) (rangeSubtraction r srcRange)
    where
        srcRange = Range src (src + rng)

Looking back over my code, things look a bit overcomplicated, though I'm not sure exactly what I'd change. I only began using a Range type in part 2, and probably would have benefited from using that from the beginning, making each mapping consist of a source range and a displacement.

One thing I am happy with is my range utilities:

Range Utilities

data Range = Range {
    start :: Integer,
    end :: Integer
} deriving (Show)

rangeIntersection :: Range -> Range -> Maybe Range
rangeIntersection (Range a b) (Range c d)
    | b <= c = Nothing
    | a >= d = Nothing
    | otherwise = Just $ Range (max a c) (min b d)

rangeSubtraction :: Range -> Range -> [Range]
rangeSubtraction (Range a b) (Range c d) = filter (\r -> start r < end r) ranges where
    ranges = [Range a (min b c), Range (max a d) b]

Nothing complicated there, but I know I *could* have made this a mess of conditional statements and managed to avoid that.

Still enjoying exploring Haskell! I'm only about 1/3 of the way through the book I've been following as a guide. I doubt I'll finish by the end of AoC, but it already has my recommendation for getting me this far.

2 votes

scarecrw's recent activity

Comment on Star Trek Day 2024 offering free pilot episodes for almost all Star Trek series in ~tv

Comment on What game do you consider an unconventional masterpiece? in ~games

Comment on Teaching coding to an eight year old with Scratch? in ~tech

Comment on Journalist Tim Burke faces charges under the US Computer Fraud and Abuse Act in ~tech

Comment on Day 25: Snowverload in ~comp.advent_of_code

Comment on Day 24: Never Tell Me The Odds in ~comp.advent_of_code

Comment on Day 23: A Long Walk in ~comp.advent_of_code

Comment on Day 22: Sand Slabs in ~comp.advent_of_code

Comment on Day 21: Step Counter in ~comp.advent_of_code

Comment on Day 21: Step Counter in ~comp.advent_of_code

Comment on Day 19: Aplenty in ~comp.advent_of_code

Comment on Day 18: Lavaduct Lagoon in ~comp.advent_of_code

Comment on Day 16: The Floor Will Be Lava in ~comp.advent_of_code

Comment on Day 15: Lens Library in ~comp.advent_of_code

Comment on Day 14: Reflector Dish in ~comp.advent_of_code

Comment on Day 12: Hot Spring in ~comp.advent_of_code

Comment on Day 11: Cosmic Expansion in ~comp.advent_of_code

Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code

Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code

Comment on Day 5: If You Give A Seed A Fertilizer in ~comp.advent_of_code