1 files changed, 78 insertions(+), 0 deletions(-)

A 2023/08b.hs

@@ 0,0 1,78 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Main where
+
+import Qulude
+
+--import Data.Array ( (!) )
+import qualified Data.Array as Array
+import qualified Data.Array.ST as STArray
+import qualified Data.Either as Either
+import qualified Data.List as List
+import Data.Map ( (!) )
+import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+
+type Instructions = String
+type Node = String
+type DesertMap = Map.Map Node (Node, Node)
+
+type Parse = (Instructions, DesertMap)
+parser :: Parser Parse
+parser = do
+  is <- upper `manyTill` newline
+  newline
+  let node = many alphaNum
+  map <- many $ do
+    n <- node
+    string " = ("
+    l <- node
+    string ", "
+    r <- node
+    string ")"
+    newline
+    return (n, (l, r))
+  return (is, Map.fromList map)
+
+isStart (_:_:'A':[]) = True
+isStart _ = False
+
+isEnd (_:_:'Z':[]) = True
+isEnd _ = False
+
+fmap' f xs = foldl' (\acc x -> f x:acc) [] xs
+
+walk map is s = iterate f (0, (0, s))
+  where l = length is
+        f (i, (j, n)) =
+          let m = case is !! j of
+                    'L' -> fst $ map ! n
+                    'R' -> snd $ map ! n
+          in (succ i, (succ j `mod` l, m))
+
+findPrefixAndCycle :: [(Int, (Int, Node))] -> ([Node], [Node])
+findPrefixAndCycle w = let (i, vs) = f [] Map.empty w in
+  let vs' = List.reverse $ fmap snd vs in
+  List.splitAt i vs'
+  where f acc vs ((i, w):ws) =
+          case Map.lookup w vs of
+            Just j -> (j, acc)
+            Nothing -> f (w:acc) (Map.insert w i vs) ws
+
+analyze (p, cs) = case (f p, f cs) of
+                    ((l, []), (c, e:[])) -> if e + l == c then (l, c, e) else undefined
+  where f w = (length w, List.findIndices isEnd w)
+
+partB (is, map) = fmap f starts
+  where starts = filter isStart $ Map.keys map
+        f s = analyze $ findPrefixAndCycle $ walk map is s
+
+main :: IO ()
+main = with parser $ do
+  --run "08b.example" "b example" partB -- 6
+  run "08.input" "b input" partB