day12: Complete puzzles

11/input.txt

@@ -0,0 +1,10 @@
+5421451741
+3877321568
+7583273864
+3451717778
+2651615156
+6377167526
+5182852831
+4766856676
+3437187583
+3633371586

11/octoflash.hs

@@ -0,0 +1,93 @@
+import           Data.Char   (digitToInt)
+
+main :: IO ()
+main = do
+  input <- getContents
+  let
+    octopodes = (map (map digitToInt) . lines) input
+  (putStrLn . show . solution1) octopodes
+  (putStrLn . show . solution2) octopodes
+
+solution1 :: [[Int]] -> Int
+solution1 m = snd (iterate flashSimulate (m, 0) !! 100)
+
+solution2 :: [[Int]] -> Int
+solution2 m = countUntil (all (all (==0)) . fst) flashSimulate (m, 0)
+
+flashSimulate :: ([[Int]], Int) -> ([[Int]], Int)
+flashSimulate (octopodes, flashes) =
+  (refreshOctopodes exhaustedOctopodes, flashes + countExhaustedOctopodes exhaustedOctopodes)
+  where
+    exhaustedOctopodes = flashStep octopodes
+    countExhaustedOctopodes = foldr (\l a -> length l + a) 0 . map (filter (> 9))
+    refreshOctopodes = map (map (\o -> if o > 9 then 0 else o))
+
+flashStep :: [[Int]] -> [[Int]]
+flashStep = propagateFlashes . map (map (+1))
+  where
+    propagateFlashes :: [[Int]] -> [[Int]]
+    propagateFlashes = until allExhausted flashOctopi
+      where
+        allExhausted :: [[Int]] -> Bool
+        allExhausted = all (all (/= 10))
+        flashOctopi :: [[Int]] -> [[Int]]
+        flashOctopi m = map (map (incrementFlashing m))
+          [[(x, y) | y <- [0..length (m !! x) - 1]] | x <- [0..length m - 1]]
+          where
+            incrementFlashing ::[[Int]] -> (Int, Int) -> Int
+            incrementFlashing m' o
+              | charge < 10 && newCharge > 10 = 10 -- Ensure we don't miss an increment
+              | otherwise = charge + numFlashingNeighbors o
+              where
+                newCharge = charge + numFlashingNeighbors o
+                charge = m' !!! o
+            numFlashingNeighbors :: (Int, Int) -> Int
+            numFlashingNeighbors = length . filter (\o -> (m !!! o) == 10) . (flip adjacent m)
+
+(!!!) :: [[Int]] -> (Int, Int) -> Int
+(!!!) m index = m !! (fst index) !! (snd index)
+
+countUntil :: (a -> Bool) -> (a -> a) -> a -> Int
+countUntil p f = call
+  where
+    call x
+      | p x = 0
+      | otherwise = call (f x) + 1
+
+adjacent :: (Int, Int) -> [[Int]] -> [(Int, Int)]
+adjacent (x, y) m = [(x+i, y+j) |
+                     i <- [-1..1],
+                     j <- [-1..1],
+                     -- (i, j) /= (0, 0),
+                     x+i >= 0,
+                     y+j >= 0,
+                     x+i < length m,
+                     y+j < length (m !! 0)]
+
+-- Tests
+
+testInput1 = [
+  "5483143223",
+  "2745854711",
+  "5264556173",
+  "6141336146",
+  "6357385478",
+  "4167524645",
+  "2176841721",
+  "6882881134",
+  "4846848554",
+  "5283751526"
+  ]
+parsedTestInput1 = map (map digitToInt) testInput1
+
+testInput2 = [
+  "11111",
+  "19991",
+  "19191",
+  "19991",
+  "11111"
+  ]
+parsedTestInput2 = map (map digitToInt) testInput2
+
+test1 = solution1 parsedTestInput1
+test2 = solution2 parsedTestInput1

12/Parsing.hs

@@ -0,0 +1,23 @@
+module Parsing (
+  splitByString
+  ) where
+
+import           Data.List (isPrefixOf)
+
+splitByString :: String -> String -> [String]
+splitByString _ "" = []
+splitByString splitter string =
+  let (chunk, rest) = spanNextSplit string
+  in
+    chunk:(splitByString splitter rest)
+    where
+      spanNextSplit :: String -> (String, String)
+      spanNextSplit [] = ([], [])
+      spanNextSplit everything@(char:rest)
+        | splitter `isPrefixOf` rest =
+          ([char], (drop ((length splitter) + 1) everything))
+        | otherwise =
+          let
+            (start, end) = spanNextSplit rest
+          in
+            (char:start, end)

12/cavesearcher.hs

@@ -0,0 +1,123 @@
+import           Data.Char       (isLower)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set        as Set
+import           Debug.Trace     (traceShow, traceShowId)
+import           Parsing         (splitByString)
+
+main :: IO ()
+main = do
+  input <- getContents
+  let
+    caves = parseCaves input
+  (putStrLn . show . solution1) caves
+  (putStrLn . show . solution2) caves
+
+solution1 :: Map.Map String [String] -> Int
+solution1 = length . cavePaths
+
+solution2 :: Map.Map String [String] -> Int
+solution2 = length . cavePaths2
+
+parseCaves :: String -> Map.Map String [String]
+parseCaves = Map.fromListWith (++) . flatmap addReverse . map tupleFromList . map (splitByString "-") . lines
+  where
+    addReverse :: (String, [String]) -> [(String, [String])]
+    addReverse t@(a, b) = [t, (head b, [a])]
+    tupleFromList :: [String] -> (String, [String])
+    tupleFromList [] = undefined
+    tupleFromList (x:xs)
+      -- Since the second part is always expected to be a cave label
+      -- or "end", this should never be > 1
+      | length xs > 1 = undefined
+      | otherwise = (x, xs)
+
+cavePaths :: Map.Map String [String] -> [[String]]
+cavePaths caveMap = followSingle caveMap Set.empty "start"
+
+cavePaths2 :: Map.Map String [String] -> [[String]]
+cavePaths2 caveMap = followOneRepeat caveMap Set.empty "start"
+
+followSingle :: Map.Map String [String] -> Set.Set String -> String -> [[String]]
+followSingle caveMap visited node
+  | node == "end" = [[node]]
+  | otherwise =
+    let
+      v' = Set.insert node visited
+    in
+      map ((:) node) (flatmap (followSingle caveMap v') adjacent)
+  where
+    adjacent :: [String]
+    adjacent = filter (not . visitedSmall) (Map.findWithDefault [] node caveMap)
+    visitedSmall :: String -> Bool
+    visitedSmall n = all isLower n && n `elem` visited
+
+followOneRepeat :: Map.Map String [String] -> Set.Set String -> String -> [[String]]
+followOneRepeat caveMap visited node
+  | node == "end" = [[node]]
+  | all isLower node && node `elem` visited =
+    followSingle caveMap visited node
+  | otherwise =
+    let
+      v' = Set.insert node visited
+    in
+      map ((:) node) (flatmap (followOneRepeat caveMap v') adjacent)
+  where
+    adjacent :: [String]
+    adjacent = filter (/= "start") (Map.findWithDefault [] node caveMap)
+
+flatmap :: (t -> [a]) -> [t] -> [a]
+flatmap _ []     = []
+flatmap f (x:xs) = f x ++ flatmap f xs
+
+-- Tests
+
+testInput1 = unlines [
+      "start-A",
+      "start-b",
+      "A-c",
+      "A-b",
+      "b-d",
+      "A-end",
+      "b-end"
+      ]
+
+testInput2 = unlines [
+  "dc-end",
+  "HN-start",
+  "start-kj",
+  "dc-start",
+  "dc-HN",
+  "LN-dc",
+  "HN-end",
+  "kj-sa",
+  "kj-HN",
+  "kj-dc"]
+
+testInput3 = unlines [
+  "fs-end",
+  "he-DX",
+  "fs-he",
+  "start-DX",
+  "pj-DX",
+  "end-zg",
+  "zg-sl",
+  "zg-pj",
+  "pj-he",
+  "RW-he",
+  "fs-DX",
+  "pj-RW",
+  "zg-RW",
+  "start-pj",
+  "he-WI",
+  "zg-he",
+  "pj-fs",
+  "start-RW"]
+
+parsedTestInput1 = parseCaves testInput1
+test1 = cavePaths parsedTestInput1
+test2 = cavePaths2 parsedTestInput1
+test3 = cavePaths2 (parseCaves testInput2)
+test4 = cavePaths2 (parseCaves testInput3)
+
+printPaths :: [[String]] -> IO ()
+printPaths = putStr . unlines . (map (foldr1 (\c a -> c++"->"++a)))

12/input.txt

@@ -0,0 +1,24 @@
+yb-pi
+jg-ej
+yb-KN
+LD-start
+end-UF
+UF-yb
+yb-xd
+qx-yb
+xd-end
+jg-KN
+start-qx
+start-ej
+qx-LD
+jg-LD
+xd-LD
+ej-qx
+end-KN
+DM-xd
+jg-yb
+ej-LD
+qx-UF
+UF-jg
+qx-jg
+xd-UF