2015 Day 18 in Haskell

2015/day01/day01.hs

@@ -1,4 +1,4 @@
-import Aoc ( aocMain )
+import Aoc
 
 parseFile :: [String] -> [Char]
 parseFile lines = let [line] = lines in line

2015/day04/day04.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 import Aoc
 import Crypto.Hash.MD5 ( hash )
 import Data.ByteString.Char8 ( pack )

2015/day08/day08.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 import Aoc
 
 part1 :: [String] -> Int

2015/day10/day10.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 import Aoc
 import Data.List ( group, sort )
 
@@ -11,4 +13,4 @@ part1 x = (length after40, after40)
 part2 :: p -> String -> Int
 part2 _ after40 = length (iterate step after40 !! 10) -- only 10 more needed
 
-main = aocMain' single part1 part2
+main = aocMain' single part1 part2

2015/day11/day11.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 import Aoc
 import Data.Char ( ord, chr )
 import Data.List ( group, nub )

2015/day12/day12.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 import Aoc
 import Data.Char ( isDigit )
 import Control.Arrow ( first, second )

2015/day13/day13.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+import Aoc
+import Data.List.Split ( splitOn )
+import Data.List ( nub )
+import Data.Tuple ( swap )
+import Data.Maybe ( fromJust )
+
+type Pref = ((String, String), Int)
+
+parseLine :: String -> Pref
+parseLine line =
+    let [a, "would", verb, points, "happiness", "units", "by", "sitting", "next", "to", b] = words line in
+    let [b', ""] = splitOn "." b in
+    let sign = case verb of { "lose" -> -1; "gain" -> 1 } in
+    ((a, b'), sign * read points)
+
+process :: [Pref] -> ([String], [Pref])
+process prefs = (people, prefs)
+    where people = nub $ concatMap (unpair . fst) prefs
+
+scoreLookup :: [Pref] -> (String, String) -> Int
+scoreLookup prefs pair = fromJust (lookup pair prefs) + fromJust (lookup (swap pair) prefs)
+
+part1 :: ([String], [Pref]) -> Int
+part1 (people, prefs) = maximum $ map (sum . map (scoreLookup prefs) . adjacents . (first:).(++[first])) $ permutations $ tail people
+    where first = head people
+
+-- it's probably more efficient to actually go through the list of prefs to find the one that is decreasing the score the most for each permutation, rather than just doing part1 again with another person, but it is fast enough for me to not bother.
+part2 :: ([String], [Pref]) -> Int
+part2 (people, prefs) = part1 ("":people, concatMap (\p -> [(("", p), 0), ((p, ""), 0)]) people ++ prefs)
+
+main :: IO ()
+main = aocMain (process . map parseLine) part1 part2

2015/day14/day14.hs

@@ -0,0 +1,25 @@
+import Aoc
+import Data.Bifunctor ( bimap )
+import Data.List ( sort, group )
+
+parseLine :: String -> (String, (Int, Int, Int))
+parseLine line =
+    let [name, "can", "fly", speed, "km/s", "for", flyTime, "seconds,", "but", "then", "must", "rest", "for", restTime, "seconds."] = words line in
+    (name, (read speed, read flyTime, read restTime))
+
+atTime :: Int -> (String, (Int, Int, Int)) -> (String, Int)
+atTime time (name, (s, f, r)) = (name, (*s) $ uncurry (+) $ bimap (*f) (min f) $ quotRem time (f+r))
+
+part1 :: [(String, (Int, Int, Int))] -> Int
+part1 = maximum . map (snd . atTime 2503)
+
+part2 :: [(String, (Int, Int, Int))] -> Int
+part2 reindeer = maximum $ map length $ group $ sort $ concatMap winners [1..2503]
+    where
+        winners t =
+            let distances = map (atTime t) reindeer in
+            let maxDistance = maximum $ map snd distances in
+            map fst $ filter ((==maxDistance) . snd) distances
+
+main :: IO ()
+main = aocMain (map parseLine) part1 part2

2015/day15/day15.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+import Aoc
+import Data.List ( transpose )
+import Data.Bifunctor ( bimap )
+
+parseLine :: String -> (String, [Int])
+parseLine line =
+    let [name, "capacity", capacity, "durability", durability, "flavor", flavor, "texture", texture, "calories", calories] = words line in
+    let read' = read . init in
+    (init name, [read calories, read' capacity, read' durability, read' flavor, read' texture])
+
+part1' :: (Int -> Bool) -> [(String, [Int])] -> Int
+part1' cond ingredients = maximum $ map (product . tail) $ filter (cond . head) $ map (map (max 0 . sum) . transpose . map (uncurry map . bimap (*) snd) . (`zip` ingredients)) $ starsAndBars 100 (length ingredients - 1)
+
+part1 :: [(String, [Int])] -> Int
+part1 = part1' $ const True
+
+part2 :: [(String, [Int])] -> Int
+part2 = part1' (==500)
+
+main :: IO ()
+main = aocMain (map parseLine) part1 part2

2015/day16/day16.hs

@@ -0,0 +1,48 @@
+import Aoc
+import Data.List.Split ( splitOn )
+import Data.Char ( isDigit )
+import Control.Arrow ( second )
+import Data.Maybe ( fromMaybe )
+
+parseLine :: String -> (Int, [(String, Int)])
+parseLine line =
+    let ("Sue ", rest0) = splitAt 4 line in
+    let (n, rest1) = span isDigit rest0 in
+    let (':':' ':rest2) = rest1 in
+    let items = splitOn ", " rest2 in
+    (read n, map (second read . pair . splitOn ": ") items)
+
+tape :: [(String, Int)]
+tape = [
+        ("children", 3),
+        ("cats", 7),
+        ("samoyeds", 2),
+        ("pomeranians", 3),
+        ("akitas", 0),
+        ("vizslas", 0),
+        ("goldfish", 5),
+        ("trees", 3),
+        ("cars", 2),
+        ("perfumes", 1)
+    ]
+
+part1' :: (String -> Int -> Int -> Bool) -> [(Int, [(String, Int)])] -> Int
+part1' predicate = fst . single . filter matches
+    where matches (_, items) = all itemMatches tape
+            where  itemMatches (name, n) = case lookup name items of
+                    Nothing -> True
+                    Just n' -> predicate name n' n
+
+part1 :: [(Int, [(String, Int)])] -> Int
+part1 = part1' $ const (==)
+
+part2 :: [(Int, [(String, Int)])] -> Int
+part2 = part1' $ fromMaybe (==) . flip lookup [
+        ("cats", (>)),
+        ("trees", (>)),
+        ("pomeranians", (<)),
+        ("goldfish", (<))
+    ]
+
+main :: IO ()
+main = aocMain (map parseLine) part1 part2

2015/day17/day17.hs

@@ -0,0 +1,34 @@
+import Aoc
+
+numWays :: Int -> [Int] -> Int
+numWays 0 _ = 1
+numWays _ [] = 0
+numWays n (x:xs)
+    | n > 0 = numWays (n-x) xs + numWays n xs
+    | otherwise = 0
+
+part1 :: [Int] -> Int
+part1 = numWays 150
+
+numWays' :: Int -> [Int] -> (Int, Int)
+numWays' 0 _ = (0, 1)
+numWays' _ [] = (0, 0)
+numWays' n (x:xs)
+    | n < 0 = (0, 0)
+    | w1 == 0 = (m0 + 1, w0)
+    | w0 == 0 = (m1, w1)
+    | m0 > m1 -1  = (m1, w1)
+    | m0 == m1 - 1 = (m1, w0 + w1)
+    | m0 < m1 -1 = (m0 + 1, w0)
+    | otherwise = undefined
+    where
+        (m0, w0) = numWays' (n-x) xs
+        (m1, w1) = numWays' n xs
+
+-- numWays and numWays' can be combined, but I think that that will make it too messy
+
+part2 :: [Int] -> Int
+part2 = snd . numWays' 150
+
+main :: IO ()
+main = aocMain (map read) part1 part2

2015/day18/day18.hs

@@ -0,0 +1,38 @@
+import Aoc
+
+parseLine :: String -> [Bool]
+parseLine = map toBool
+    where
+        toBool '.' = False
+        toBool '#' = True
+
+countNeighbours :: [[Bool]] -> (Bool, Int)
+countNeighbours [[a, b, c], [d, e, f], [g, h, i]] = (e, length (filter id [a, b, c, d, f, g, h, i]))
+
+survives :: (Bool, Int) -> Bool
+survives (False, n) = n == 3
+survives (True, n) = n == 2 || n == 3
+
+simulate :: [[Bool]] -> [[Bool]]
+simulate = kernelMap (survives . countNeighbours) (Just False)
+
+numOn :: [[Bool]] -> Int
+numOn = sum . map (sum . map fromEnum)
+
+doSimulate :: ([[Bool]] -> [[Bool]]) -> [[Bool]] -> Int
+doSimulate simulate board = numOn $ iterate simulate board !! 100
+
+part1 :: [[Bool]] -> Int
+part1 = doSimulate simulate
+
+part2 :: [[Bool]] -> Int
+part2 = doSimulate simulate' . keepOn
+    where
+        updateFirst f (x:xs) = f x: xs
+        updateLast f (x:xs) = if null xs then [f x] else x: updateLast f xs
+        updateEnds f = updateFirst f . updateLast f
+        keepOn = updateEnds (updateEnds $ const True)
+        simulate' = keepOn . simulate
+
+main :: IO ()
+main = aocMain (map parseLine) part1 part2

2024/day01/day01.hs

@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+import Aoc
 import Data.List ( sort, group )
 import Data.Maybe ( fromMaybe )
-import Aoc ( aocMain )
 
 parseFile :: [String] -> ([Int], [Int])
 parseFile lines = unzip [(a, b) | line <- lines, let [a, b] = map read $ words line]

2024/day02/day02.hs

@@ -1,4 +1,6 @@
-import Aoc ( aocMain )
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+import Aoc
 
 parseFile :: [String] -> [[Int]]
 parseFile = map (map read . words)

2024/day03/day03.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+import Aoc
+import Text.Regex.PCRE
+import Data.List.Split ( splitOn )
+
+part1 :: [String] -> Int
+part1 = sum . map (sum . map (product . map read . tail) . (=~ "mul\\((\\d+),(\\d+)\\)"))
+
+part2 :: [String] -> Int
+part2 = part1 . map (head . splitOn "don't()") . splitOn "do()" . concat
+
+main :: IO ()
+main = aocMain id part1 part2

2024/day04/day04.hs

@@ -0,0 +1,37 @@
+import Aoc
+import Data.List.Split ( splitOn )
+import Data.List ( transpose )
+
+horizontal :: [String] -> Int
+horizontal = sum . map horizontal'
+    where 
+        count word = pred . length . splitOn word
+        horizontal' line = count "XMAS" line + count "SAMX" line
+
+sheer :: [String] -> [String]
+sheer [] = []
+sheer (x:xs) = x:(map ('.':) $ sheer xs)
+
+part1 :: [String] -> Int
+part1 board = horizontal board + vertical board + diagonal1 board + diagonal2 board
+    where
+        vertical = horizontal . transpose
+        diagonal1 = vertical . sheer
+        diagonal2 = diagonal1 . reverse
+
+isXMAS :: [[Char]] -> Bool
+isXMAS [
+    [a,  _,  b], 
+    [_, 'A', _], 
+    [c,  _,  d]] = isMS a d && isMS b c
+    where 
+        isMS 'M' 'S' = True
+        isMS 'S' 'M' = True
+        isMS _ _ = False
+isXMAS [[_, _, _], [_, _, _], [_, _, _]] = False
+
+part2 :: [String] -> Int
+part2 = sum . map (length . filter id) . kernelMap isXMAS Nothing
+
+main :: IO ()
+main = aocMain id part1 part2

Makefile

@@ -1,12 +1,14 @@
 HS_SRCS = $(shell find . -name 'day*.hs')
 HS_TARGETS = $(HS_SRCS:.hs=)
+HI_TARGETS = $(HS_SRCS:.hs=.hi)
+O_TARGETS = $(HS_SRCS:.hs=.o)
 
 all: $(HS_TARGETS)
 
 %: %.hs
 	ghc $<
 
-clean: $(HS_TARGETS)
-	rm -rf $(HS_TARGETS)
+clean:
+	rm -rf $(HS_TARGETS) $(HI_TARGETS) $(O_TARGETS)
 
 .PHONY: all clean

aoc.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 module Aoc where
 
 aocMain' :: (Show p, Show a) => ([String] -> p) -> (p -> (a, c)) -> (p -> c -> a) -> IO ()
@@ -50,4 +52,32 @@ permutations [] = [[]]
 permutations xs = concatMap (\n -> let (a, rest) = remove n xs in map (a:) $ permutations rest) [0..length xs-1]
 
 adjacents :: [a] -> [(a, a)]
-adjacents as = zip as $ tail as
+adjacents as = zip as $ tail as
+
+-- starsAndBars n b returns all lists of non-negative integers of length `b+1` where the sum is `n`
+starsAndBars :: Int -> Int -> [[Int]]
+starsAndBars 0 b = [replicate (b+1) 0]
+starsAndBars n 0 = [[n]]
+starsAndBars n b = map (0:) (starsAndBars n (b-1)) ++ map (\xs -> head xs + 1 : tail xs) (starsAndBars (n-1) b)
+
+kernelMapRow' :: ([[a]] -> b) -> Maybe a -> [a] -> [a] -> [a] -> [b]
+kernelMapRow' kernel x
+    (a:r0@(b:c:_))
+    (d:r1@(e:f:_))
+    (g:r2@(h:i:_)) =
+         kernel [[a,b,c],[d,e,f],[g,h,i]] : kernelMapRow' kernel x r0 r1 r2
+kernelMapRow' kernel (Just x) [a, b] [c, d] [e, f] = [kernel [[a,b,x],[c,d,x],[e,f,x]]]
+kernelMapRow' _ Nothing [_, _] [_, _] [_, _] = []
+
+kernelMapRow :: ([[a]] -> b) -> Maybe a -> [a] -> [a] -> [a] -> [b]
+kernelMapRow kernel (Just x) a b c = kernelMapRow' kernel (Just x) (x:a) (x:b) (x:c)
+kernelMapRow kernel Nothing a b c = kernelMapRow' kernel Nothing a b c
+
+kernelMap' :: ([[a]] -> b) -> Maybe a -> [[a]] -> [[b]]
+kernelMap' kernel x (a:rest@(b:c:_)) = kernelMapRow kernel x a b c : kernelMap' kernel x rest
+kernelMap' kernel (Just x) [a, b] = [kernelMapRow kernel (Just x) a b (map (const x) b)]
+kernelMap' kernel Nothing [_, _] = []
+
+kernelMap :: ([[a]] -> b) -> Maybe a -> [[a]] -> [[b]]
+kernelMap kernel (Just x) as = kernelMap' kernel (Just x) ((map (const x) (head as)):as)
+kernelMap kernel Nothing as = kernelMap' kernel Nothing as