Done day 8

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index a8a4504fcb843826ec0a8d9894cbdaaae3f741fd..df6d0ec0bc13ff45d1db201eee574d668cb889da 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -144,4 +144,9 @@ executable advent07
 executable advent07c
   import: common-extensions, build-directives
   main-is: advent07/MainWithCase.hs
-  build-depends: text, attoparsec
\ No newline at end of file
+  build-depends: text, attoparsec
+
+executable advent08
+  import: common-extensions, build-directives
+  main-is: advent08/Main.hs
+  build-depends: text, attoparsec, containers

diff --git a/advent08/Main.hs b/advent08/Main.hs
new file mode 100644 (file)
index 0000000..90f596d
--- /dev/null
+++ b/advent08/Main.hs
@@ -0,0 +1,119 @@
+-- Writeup at https://work.njae.me.uk/2023/12/08/advent-of-code-2023-day-8/
+
+import AoC
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text -- hiding (take)
+import Control.Applicative
+import Data.List
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!), (!?))
+
+data Direction = L | R deriving (Show, Eq)
+data Node = Node String String deriving (Show)
+type Desert = M.Map String Node
+
+data State = State { getHere :: String, getSteps :: Int } deriving (Eq, Show)
+instance Ord State where
+  compare (State n1 s1) (State n2 s2) = compare (s1, n1) (s2, n2)
+
+data PathStart = PathStart String Int deriving (Eq, Ord, Show)
+data CollapsedPath = CPath String Int deriving (Show)
+type Paths = M.Map PathStart CollapsedPath
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- TIO.readFile dataFileName
+      let (directions, desert) = successfulParse text
+      -- print $ length directions
+      -- print $ directions
+      -- print $ desert
+      print $ part1 desert directions
+      print $ part2 desert directions
+      -- print $ part3 desert directions
+
+part1, part2 :: Desert -> [Direction] -> Int
+part1 desert directions = getSteps $ walk desert directions (State "AAA" 0)
+
+
+part2 desert directions = foldl1 lcm pathLens
+  where cache = generateRouteLengths desert directions
+        pathLens = fmap (\(CPath _ l) -> l) $ M.elems cache
+        -- directionsLen = length directions
+
+generateRouteLengths :: Desert -> [Direction] -> Paths
+generateRouteLengths desert directions = M.unions ((fmap snd sResults) ++ (fmap snd gResults))
+  where starts = sort $ fmap (\s -> State s 0) $ startsOf desert
+        sResults = fmap (walkWithCache desert directions M.empty) starts
+        fromGoals = fmap fst sResults
+        gResults = fmap (walkWithCache desert directions M.empty) fromGoals
+
+
+-- part3 desert directions = multiWalk desert directions M.empty starts
+--   where starts = fmap (\s -> State s 0) $ startsOf desert
+
+-- multiWalk desert directions cache states@(s:ss)
+--   | (all isGoal states) && (sameTime states) = states
+--   | otherwise = multiWalk desert directions newCache $ sort (s':ss)
+--   where (s', newCache) = walkWithCache desert directions cache s
+
+-- sameTime states = (length $ nub times) == 1
+--   where times = fmap getSteps states
+
+walk :: Desert -> [Direction] -> State -> State
+walk desert directions start = head $ dropWhile (not . isGoal) path
+  where path = scanl' (step desert) start $ drop offset $ cycle directions
+        offset = (getSteps start) `mod` (length directions)
+
+step :: Desert -> State -> Direction -> State
+step desert (State here steps) direction
+  | direction == L = State thereL (steps + 1)
+  | direction == R = State thereR (steps + 1)
+  where
+    (Node thereL thereR) = desert ! here
+
+
+startsOf :: Desert -> [String]
+startsOf desert = filter ((=='A') . last) $ M.keys desert
+-- goalsOf  desert = filter ((=='Z') . last) $ M.keys desert
+
+isGoal :: State -> Bool
+isGoal (State here _) = (last here) == 'Z'
+
+walkWithCache :: Desert -> [Direction] -> Paths -> State -> (State, Paths)
+walkWithCache desert directions cache start =
+  case cacheEntry of
+    Just (CPath there steps) -> (State there (steps + (getSteps start)), cache)
+    Nothing -> (newState, newCache)
+  where offset = (getSteps start) `mod` (length directions)
+        cacheEntry = cache !? (PathStart (getHere start) offset)
+        start' = step desert start (directions !! offset)
+        newState = walk desert directions start'
+        newCache = M.insert (PathStart (getHere start) offset) 
+                            (CPath (getHere newState) ((getSteps newState) - (getSteps start)))
+                            cache
+
+-- Parse the input file
+
+problemP :: Parser ([Direction], Desert)
+directionP :: Parser Direction
+desertP :: Parser Desert
+desertLineP :: Parser (String, Node)
+nodeP :: Parser Node
+nameP :: Parser String
+
+problemP = (,) <$> ((many1 directionP) <* many1 endOfLine) <*> desertP
+directionP = (L <$ "L") <|> (R <$ "R")
+
+desertP = M.fromList <$> desertLineP `sepBy` endOfLine
+desertLineP = (,) <$> (nameP <* " = ") <*> nodeP
+
+nodeP = Node <$> ("(" *> nameP <* ", ") <*> (nameP <* ")")
+nameP = many1 (letter <|> digit) 
+
+successfulParse :: Text -> ([Direction], Desert)
+successfulParse input = 
+  case parseOnly problemP input of
+    Left  _err -> ([], M.empty) -- TIO.putStr $ T.pack $ parseErrorPretty err
+    Right matches -> matches