Haskell for Advent of Code (Day 4-7)
As usual, if my coding style is bad, please feel free to tell me in the comments.
Day 4
import System.IO
get' :: String -> Int -> Int -> Int -> Int -> Char
get' inp n m x y | 0<=x && x<n && 0<=y && y<m = ((lines inp)!!x)!!y
| otherwise = '.'
path :: ((Int,Int) -> Char) -> Int -> Int -> Int -> Int -> Bool
path f x y dx dy = "XMAS" == [f (x+dx*z,y+dy*z) | z <-[0..3]]
path2 :: ((Int,Int) -> Char) -> Int -> Int -> Int -> Int -> Bool
path2 f x y d1 d2= "AMSMS" == map f ((x,y) : [(x+d1*z,y+d1*z) | z<-[-1,1]] ++ [(x+d2*z,y-d2*z) | z<-[-1,1]])
main :: IO()
main = do
inp <- getContents
let n = length (lines inp)
let m = length ((lines inp)!!0)
let get (x,y) = get' inp n m x y
print $ length $ filter id [path get x y dx dy | x<-[0..n-1], y<-[0..m-1], dx<-[-1..1], dy<-[-1..1]]
print $ length $ filter id [path2 get x y d1 d2 | x<-[0..n-1], y<-[0..m-1], d1<-[-1,1], d2<-[-1,1]]
Day 5
import System.IO
import Data.List
import Data.List.Split
mid :: [a] -> a
mid [x] = x
mid xs = (mid . init . tail) xs
f :: (String -> Bool) -> [String] -> [String]
f cmp [x] = [x]
f cmp (x:xs) = if any cmp (zipWith (++) (repeat (x++"|")) xs) then f cmp (xs++[x])
else x:f cmp xs
main :: IO()
main = do
dat <- getContents
let (inp:out:_) = splitOn [""] $ lines dat
let sorted = f (flip elem inp)
print $ sum $ map (read . mid . (\x -> if sorted x == reverse x then x else ["0"]) . splitOn ",") out
print $ sum $ map (read . mid . (\x -> if sorted x == reverse x then ["0"] else sorted x) . splitOn ",") out
Day 6
import System.IO
import Data.List
import Data.List.Index
import Data.Set (Set, member, insert, fromList)
inside :: (Int,Int) -> (Int,Int) -> Bool
inside (n,m) (x,y) = 0<=x && x<n && 0<=y && y<m
setAt2 :: (Int,Int) -> a -> [[a]] -> [[a]]
setAt2 (x,y) val xss = setAt x (setAt y val (xss!!x)) xss
dfs :: (Int,Int) -> Set (Int,Int) -> (Int,Int) -> (Int,Int) -> [[Int]]
dfs (n,m) pos (x,y) (dx,dy) | not $ inside (n,m) (x,y) = replicate n (replicate m 0)
| member (x,y) pos = dfs (n,m) pos (x-dx,y-dy) (dy,-dx)
| otherwise = setAt2 (x,y) 1 $ dfs (n,m) pos (x+dx,y+dy) (dx,dy)
bad :: (Int,Int) -> Set (Int,Int) -> (Int,Int) -> (Int,Int) -> Int -> Bool
bad (n,m) pos (x,y) (dx,dy) cnt | cnt == 0 = True
| not $ inside (n,m) (x,y) = False
| member (x,y) pos = bad (n,m) pos (x-dx,y-dy) (dy,-dx) (cnt-1)
| otherwise = bad (n,m) pos (x+dx,y+dy) (dx,dy) (cnt-1)
main :: IO()
main = do
dat <- getContents
let grid = lines dat
let n = length grid
let m = length (grid!!0)
let guard = head $ filter (\(x,y) -> (grid!!x)!!y == '^') [(x,y) | x<-[0..n-1], y<-[0..m-1]]
let pos = fromList $ filter (\(x,y) -> (grid!!x)!!y == '#') [(x,y) | x<-[0..n-1], y<-[0..m-1]]
print $ (sum . concat) $ dfs (n,m) pos guard (-1,0)
print $ (length . filter (\new -> bad (n,m) (Data.Set.insert new pos) guard (-1,0) (8*n*m))) [(x,y) | x<-[0..n-1], y<-[0..m-1], (grid!!x)!!y=='.']
There are a few speedups that I am aware of:
- In part 2, you only need to place tiles in places that the guard reaches in part 1. The guard reaches only 5461 places in part 1 so you get $\frac{5461}{140^2} \approx 25\%$
- Only store positions that are adjacent to an obstacle, since most of the guard’s path can be expected to be some straight line
Btw, the constant 8*n*m in the last line of my code is a very conservative bound. It turns out div (n*m) 2 works and gives the correct answer of 1836 but n*m/3 does not work and gives the wrong answer of 13217. Congrats to the task designer for ensuring that there are many large cycles. How large of cycles can we construct? The upper bound is obviously $4nm$. Is $(4-o(1))nm$ possible?
Btw, there is a way to solve the problem in $O((nm)^{1+o(1)})$. Define a graph $(x,y,\text{dir})$ where $\text{dir} \in {\texttt{N},\texttt{S},\texttt{E},\texttt{W}}$ as the direction the guard is facing. If we add a special vertex $\perp$ that represents the portion outside the grid, then the grid define a graph with outdegree 1. Then if $(g_x,g_y)$ is the position of guard, we need to check if $V_g=(g_x,g_y,\texttt{N})$ is in a cycle in our graph. It is actually simple to check this. Do DSU on our graph without the edge pointing out of $V_g$. Then $V_g$ will be in a cycle iff it is in the same component.
Then since each update of adding a new obstacle changes $O(1)$ edges, we can support everything in $O((nm)^{1+o(1)})$ with offline DSU with rollbacks.
But who is going to code it in haskell?
Day 7
import System.IO
conc :: Int -> Int -> Int
conc x y = read ((show x) ++ (show y))
solve :: [(Int -> Int -> Int)] -> [Int] -> Bool
solve op (res:x:xs) = elem res $ foldl (\xs y -> [o x y | o <- op, x <- xs]) [x] xs
main :: IO()
main = do
dat <- getContents
let inp = map (map read . (\(x:xs) -> init x:xs) . words) (lines dat)
print $ sum $ map head $ filter (solve [(+),(*)]) inp
print $ sum $ map head $ filter (solve [(+),(*),conc]) inp
The above is slow, we can speed it up using MITM. Also, we can use applicatives to make the more abit nicer to read I guess?
import System.IO
import Data.Maybe
import Data.Set (fromList, disjoint)
data Op = Add | Mul | Con
data Eqn = E Int Int
app1 :: Op -> Int -> Int -> Int
app1 Add x y = x + y
app1 Mul x y = x * y
app1 Con x y = read ((show x) ++ (show y))
app2 :: Op -> Eqn -> Int -> Eqn
app2 Add (E m c) y = E m (c+y)
app2 Mul (E m c) y = E (m*y) (c*y)
app2 Con (E m c) y = E (m*l) (c*l+y)
where l = 10^(length (show y))
expand1 :: [Op] -> [Int] -> [Int]
expand1 ops (x:xs) = foldl (\xs y -> app1 <$> ops <*> xs <*> y) (pure x) (pure <$> xs)
expand2 :: [Op] -> [Int] -> [Eqn]
expand2 ops xs = foldl (\xs y -> app2 <$> ops <*> xs <*> y) (pure (E 1 0)) (pure <$> xs)
solveEqn :: Int -> Eqn -> Maybe Int
solveEqn y (E m c) | mod (y-c) m == 0 = Just (div (y-c) m)
| otherwise = Nothing
solve :: [Op] -> [Int] -> Bool
solve ops (res:xs) = not $ disjoint (fromList vl) (fromList vr)
where
(l,r) = splitAt (div (length xs+1) 2) xs
vl = expand1 ops l
vr = catMaybes $ map (solveEqn res) $ expand2 ops r
main :: IO()
main = do
dat <- getContents
let inp = map (map read . (\(x:xs) -> init x:xs) . words) (lines dat)
print $ sum $ map head $ filter (solve [Add, Mul]) inp
print $ sum $ map head $ filter (solve [Add, Mul, Con]) inp
Segment Tree
Someone asked me to code segment tree. Here is code that works on https://cses.fi/problemset/task/1649 but dies due to constant time. It passes on cf edu though (but they have 3x TL scaling for haskell, it works for $n=q=10^5$ in 2 seconds).
Maybe I can cut constant time by not using a Monad…
import Control.Monad.State
data Seg a = None | Node Int Int a (Seg a) (Seg a)
merge :: Ord a => Seg a -> Seg a -> Seg a
merge l@(Node s _ v1 _ _) r@(Node _ e v2 _ _) = Node s e (min v1 v2) l r
construct' :: Ord a => Int -> Int -> [a] -> Seg a
construct' s e [x] = Node s e x None None
construct' s e xs = merge (construct' s m (take z xs)) (construct' (m+1) e (drop z xs))
where m = div (s+e) 2
z = m-s+1
construct :: Ord a => [a] -> Seg a
construct xs = construct' 1 (length xs) xs
update' :: Ord a => Int -> a -> Seg a -> Seg a
update' i val u@(Node s e _ l r) | e < i || i < s = u
| s==e = Node s e val None None
| otherwise = merge (update' i val l) (update' i val r)
update :: Ord a => Int -> a -> State (Seg a) ()
update i val = modify (update' i val)
query' :: (Bounded a, Ord a) => Int -> Int -> Seg a -> a
query' i j (Node s e val l r) | e < i || j < s = maxBound
| i <= s && e <= j = val
| otherwise = min (query' i j l) (query' i j r)
query :: (Bounded a, Ord a) => Int -> Int -> State (Seg a) (a)
query i j = gets (query' i j)
solve :: [[Int]] -> State (Seg Int) ([Int])
solve [] = return []
solve ((1:i:val:_):xs) = do
update i val
solve xs
solve ((2:i:j:_):xs) = do
x <- query i j
res <- solve xs
return (x : res)
main::IO()
main = do
dat <- getContents
let inp = (map (map read . words) . lines) dat :: [[Int]]
mapM_ print $ evalState (solve (drop 2 inp)) (construct (inp!!1))
Btw, I was told that it is better to have strict evaluation here. So the definition of data Seg becomes data Seg a = None | Node !Int !Int !a !(Seg a) !(Seg a). No idea what is the use of !(Seg a) though. Maybe it isn’t needed.