{-# LANGUAGE NoMonomorphismRestriction, RecordWildCards, TypeApplications #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module Day25 (day25) where
import Control.Monad.ST (ST, runST)
import Data.Array.IArray (Array, array)
import Data.Bits (FiniteBits)
import Data.Char (isSpace)
import Data.Ix (Ix)
import Data.Word (Word8)
import GrowArray (GrowArray, foldGrowArray, newGrowArray, readGrowArray, writeGrowArray)
import Text.ParserCombinators.ReadP (ReadP, (<++), between, char, many1, readP_to_S, readS_to_P, sepBy, string)
import TuringMachine (Instruction(..), Move(..), Table, foldTape, runTuringMachine, withTape, withTuringMachine)
data State = A | B | C | D | E | F deriving (Eq, Ix, Ord, Read)
data Program state value = Program
{ start :: state
, steps :: Int
, table :: Table Array state value
}
parseProgram :: (Ix state, Read state, Ix value, Num value, Read value) =>
ReadP (Program state value)
parseProgram = do
let readp = readS_to_P reads
start <- between (string "Begin in state ") (string ".\n") readp
steps <- between (string "Perform a diagnostic checksum after ")
(string " steps.\n\n") readp
transitions <- fmap concat . flip sepBy (many1 $ char '\n') $ do
state <- between (string "In state ") (string ":\n") readp
flip sepBy (char '\n') $ do
value <- between (string " If the current value is ")
(string ":\n") readp
instructionSymbol <- between (string " - Write the value ")
(string ".\n") readp
instructionMove <- between (string " - Move one slot to the ")
(string ".\n") $
(MoveLeft <$ string "left") <++
(MoveRight <$ string "right")
instructionState <- between (string " - Continue with state ")
(string ".") readp
pure ((state, value), InstructionContinue {..})
let indices = fst <$> transitions
minIndex = (minimum $ fst <$> indices, minimum $ snd <$> indices)
maxIndex = (maximum $ fst <$> indices, maximum $ snd <$> indices)
pure Program {table = array (minIndex, maxIndex) transitions, ..}
day25 :: String -> IO Int
day25 input = do
let (Program {..}, _):_ = filter (all isSpace . snd) $
readP_to_S (parseProgram @State @Word8) input
withTuringMachine table $ \tm -> withTape 0 $ \tape -> do
Right _ <- runTuringMachine tm tape start steps
foldTape (\a b -> return $ a + fromIntegral b) 0 tape