X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-20.git;a=blobdiff_plain;f=advent23%2Fsrc%2Fadvent23.hs;fp=advent23%2Fsrc%2Fadvent23.hs;h=47e0e33c21e31e0c7dc6b4fdbe2f5508a842cbc7;hp=0000000000000000000000000000000000000000;hb=5072f95356c17607722dddb918805ea1c48b8332;hpb=ef99d985fed4bda29a94866fd60813e02861dec4

diff --git a/advent23/src/advent23.hs b/advent23/src/advent23.hs
new file mode 100644
index 0000000..47e0e33
--- /dev/null
+++ b/advent23/src/advent23.hs
@@ -0,0 +1,119 @@
+-- import Debug.Trace
+
+import qualified Data.List.PointedList.Circular as P
+import Control.Lens
+import Data.Maybe
+import Data.Char (digitToInt)
+
+import Control.Monad
+import Control.Monad.ST
+import Data.STRef
+import qualified Data.Vector.Unboxed.Mutable as V
+
+
+puzzleInput :: [Int]
+puzzleInput = map digitToInt "538914762"
+-- puzzleInput = map digitToInt "389125467" -- example
+
+main :: IO ()
+main = 
+  do  putStrLn $ part1 puzzleInput
+      print $ part2 puzzleInput
+
+
+part1 nums = label $ playN cups 100
+  where cups = fromJust $ P.fromList nums
+
+part2 nums = a * b
+  where finalCups = runGame nums 1000000 10000000
+        (a, b) = clockwiseOf1 finalCups
+
+
+label cups = concatMap show $ tail $ takeRight (P.length cups) atOne
+  where atOne = fromJust $ P.find 1 cups
+
+playN cups n = (iterate playOne cups) !! n
+
+playOne cups = P.next replacedAtCurrent
+  where current = cups ^. P.focus
+        held = takeRight 3 $ P.next cups
+        shorter = fromJust $ dropRight 3 $ P.next cups
+        destination = validDestination (current - 1) 9 held
+        shorterAtDestination = fromJust $ P.find destination shorter
+        replaced = foldr P.insertRight shorterAtDestination $ reverse held
+        replacedAtCurrent = fromJust $ P.find current replaced
+
+
+validDestination 0 max missing = validDestination max max missing
+validDestination n max missing
+  | n `elem` missing = validDestination (n - 1) max missing
+  | otherwise = n
+
+
+takeRight :: Int -> P.PointedList a -> [a]
+takeRight 0 _ = []
+takeRight n xs = (xs ^. P.focus):(takeRight (n - 1) $ P.next xs)
+
+dropRight :: Int -> P.PointedList a -> Maybe (P.PointedList a)
+dropRight 0 xs = Just xs
+dropRight n xxs = case (P.deleteRight xxs) of
+  Just xs -> dropRight (n - 1) xs
+  Nothing -> Nothing
+
+
+clockwiseOf1 cups = (a, b)
+  where a = cups!!1
+        b = cups!!a
+
+runGame :: [Int] -> Int -> Int -> [Int]
+runGame seed cupsNeeded roundsNeeded =
+  runST $ 
+    do cups <- seedGame seed cupsNeeded
+       gameLoop roundsNeeded cupsNeeded cups
+       mapM (V.read cups) [0..cupsNeeded] 
+
+seedGame :: [Int] -> Int -> ST s (V.MVector s Int)
+seedGame seed cupsNeeded = 
+  do  cups <- V.new (cupsNeeded + 1)
+      let extended = seed ++ [10, 11..]
+      forM_ [0..cupsNeeded] $ \i -> V.write cups i (i + 1)
+      forM_ (zip seed $ tail extended) $ \(i, j) -> V.write cups i j
+      V.write cups 0 (head seed)
+      let end = if cupsNeeded > (length seed)
+                then cupsNeeded
+                else last seed
+      V.write cups end (head seed)
+      return cups
+
+gameLoop targetRound maxCups cups =
+    do forM_ [1..targetRound]
+             (\_ -> gameStep maxCups cups)
+       return ()
+
+gameStep :: Int -> V.MVector s Int -> ST s ()
+gameStep maxCups cups = 
+  do  current <- V.read cups 0
+      held1 <- V.read cups current
+      held2 <- V.read cups held1
+      held3 <- V.read cups held2
+      afterHeld <- V.read cups held3
+
+          -- close the loop, removing the held cups
+      V.write cups current afterHeld 
+
+      let destination = 
+            validDestination (current - 1) maxCups [held1, held2, held3]
+      afterDestination <- V.read cups destination
+
+          -- make the held come after the destination
+      V.write cups destination held1 
+
+          -- make the end of the held point into the rest of the loop
+      V.write cups held3 afterDestination
+
+          -- advance current
+      nextCup <- V.read cups current
+          -- and store it
+      V.write cups 0 nextCup
+      return ()
+