-- 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 ()