scarecrw's recent activity

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
scarecrw (edited )LinkThis 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.

Comment on Day 25: Snowverload in ~comp.advent_of_code
scarecrw 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 mincut, but I know it was related to maxflow, 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 mincut, but I know it was related to maxflow, 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 maxflow must be 3, whereas any two nodes on the same side of the cut the maxflow must be >3. Grabbing a random node, group the rest of the nodes into same side vs other side based on their maxflow.
I also don't remember the best maxflow 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.

Comment on Day 24: Never Tell Me The Odds in ~comp.advent_of_code
scarecrw 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 (dxrefdx) (dyrefdy) dz) swapYZ :: Hailstone > Hailstone swapYZ (Hailstone (Coord x y z) (Coord dx dy dz)) = Hailstone (Coord x z y) (Coord dx dz dy)

Comment on Day 23: A Long Walk in ~comp.advent_of_code
scarecrw 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 submap 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), (r1, c), (r, c+1), (r, c1)] else [] else case maze ! (r, c) of Open > [(r+1, c), (r1, c), (r, c+1), (r, c1)] L > [(r, c1)] R > [(r, c+1)] U > [(r1, 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'

Comment on Day 22: Sand Slabs in ~comp.advent_of_code
scarecrw 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 graphbased 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, z1)) 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)

Comment on Day 21: Step Counter in ~comp.advent_of_code
scarecrw 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.

Comment on Day 21: Step Counter in ~comp.advent_of_code
scarecrw 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), (r1, c), (r, c+1), (r, c1)] 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

Comment on Day 19: Aplenty in ~comp.advent_of_code
scarecrw 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
andx
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 of1  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 (a1)  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

Comment on Day 18: Lavaduct Lagoon in ~comp.advent_of_code
scarecrw 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 floodfilled. 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) = (rn, c) moveDirN n South (r, c) = (r+n, c) moveDirN n East (r, c) = (r, c+n) moveDirN n West (r, c) = (r, cn) moveDir :: Direction > Coord > Coord moveDir = moveDirN 1 neighbors :: Coord > [Coord] neighbors (r, c) = [(r+1, c), (r1, c), (r, c+1), (r, c1)] 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) (d1) 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

Comment on Day 16: The Floor Will Be Lava in ~comp.advent_of_code
scarecrw 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, c1) West, Particle (r, c+1) East] (North, BLTR) > [Particle (r, c+1) East] (North, TLBR) > [Particle (r, c1) West] (North, _) > [Particle (r1, c) North] (South, Horizontal) > [Particle (r, c1) West, Particle (r, c+1) East] (South, BLTR) > [Particle (r, c1) West] (South, TLBR) > [Particle (r, c+1) East] (South, _) > [Particle (r+1, c) South] (East, Vertical) > [Particle (r1, c) North, Particle (r+1, c) South] (East, BLTR) > [Particle (r1, c) North] (East, TLBR) > [Particle (r+1, c) South] (East, _) > [Particle (r, c+1) East] (West, Vertical) > [Particle (r1, c) North, Particle (r+1, c) South] (West, BLTR) > [Particle (r+1, c) South] (West, TLBR) > [Particle (r1, c) North] (West, _) > [Particle (r, c1) 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..numCols1]] ++ [Particle (numRows1, c) North  c < [0..numCols1]] ++ [Particle (r, 0) East  r < [0..numRows1]] ++ [Particle (r, numCols1) West  r < [0..numRows1]]

Comment on Day 15: Lens Library in ~comp.advent_of_code
scarecrw 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 []

Comment on Day 14: Reflector Dish in ~comp.advent_of_code
scarecrw 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

Comment on Day 12: Hot Spring in ~comp.advent_of_code
scarecrw 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)

Comment on Day 11: Cosmic Expansion in ~comp.advent_of_code
scarecrw 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. 
Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code
scarecrw (edited )Link ParentYou 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)

Comment on Day 8: Haunted Wasteland in ~comp.advent_of_code
scarecrw (edited )LinkI 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 nonidiomatic goofiness, but that's what trying new things is for!

Comment on Day 5: If You Give A Seed A Fertilizer in ~comp.advent_of_code
scarecrw (edited )LinkFull 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]
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.

Comment on Day 4: Scratchcards in ~comp.advent_of_code
scarecrw I'm taking this year as an opportunity to try something new and using Haskell. Really enjoying it so far, though I need to check out how regex works as my current parsing could be improved. After...I'm taking this year as an opportunity to try something new and using Haskell. Really enjoying it so far, though I need to check out how regex works as my current parsing could be improved. After going for the leaderboard in years past with python, just messing about has been much more fun. If you have any Haskell tips I could benefit from, let me know!
Solution
data Card = Card { cardNumber :: Int, winningNums :: [Int], yourNums :: [Int] } deriving (Show) parseCard :: String > Card parseCard s = Card cardNum winning your where cardNum = read $ take 4 $ drop 4 s winning = map read $ drop 2 $ words (takeWhile (/='') s) your = map read (tail (words $ dropWhile (/='') s)) scoreCard :: Card > Int scoreCard (Card _ winning yours) = length (filter (`elem` winning) yours) solve1 :: [String] > Int solve1 input = sum $ map (points . scoreCard . parseCard) input where points n = if n == 0 then 0 else 2 ^ (n  1) solve2 :: [String] > Int solve2 input = score (map (scoreCard . parseCard) input) [1,1..] 0 where score [] _ acc = acc score (x:xs) (c:count) acc = score xs count' acc' where acc' = acc + c count' = map (+c) (take x count) ++ drop x count

Comment on ChatGPT can be broken by entering these strange words, and nobody is sure why in ~tech
scarecrw Computerphile did a video explaining this phenomenon a while back: https://youtu.be/WO2X3oZEJOAComputerphile did a video explaining this phenomenon a while back: https://youtu.be/WO2X3oZEJOA
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.