1 {-# LANGUAGE NegativeLiterals #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TypeFamilies #-}
6 import Data.Text (Text)
7 import qualified Data.Text as T
8 import qualified Data.Text.IO as TIO
10 import Text.Megaparsec hiding (State)
11 import qualified Text.Megaparsec.Lexer as L
12 import Text.Megaparsec.Text (Parser)
13 import qualified Control.Applicative as CA
15 import qualified Data.Map as M
18 import Control.Monad (unless)
19 import Control.Monad.State.Lazy
20 import Control.Monad.Reader
22 type TuringState = String
24 type Tape = M.Map Integer Bool
26 data StateTransition = StateTransition { writeValue :: Bool
27 , newState :: TuringState
28 , tapeMovement :: Integer
31 type RuleTrigger = (TuringState, Bool)
33 type Rules = M.Map RuleTrigger StateTransition
35 data Machine = Machine { tState :: TuringState
37 , tapeLocation :: Integer
38 , stepsRemaining :: Integer
42 emptyMachine = Machine {tState = "unknown", tape = M.empty, tapeLocation = 0, stepsRemaining = 0}
44 type ProgrammedMachine = ReaderT Rules (State Machine) ()
49 text <- TIO.readFile "data/advent25.txt"
50 let (machine0, rules) = successfulParse text
51 let machinef = part1 rules machine0
52 print $ M.size $ M.filter id $ tape machinef
55 part1 :: Rules -> Machine -> Machine
56 part1 rules machine0 =
58 runReaderT executeSteps
63 executeSteps :: ProgrammedMachine
66 unless (stepsRemaining m == 0) $
71 executeStep :: ProgrammedMachine
75 let tapeHere = M.findWithDefault False (tapeLocation m) (tape m)
76 let transition = rules!(tState m, tapeHere)
77 let tape' = M.insert (tapeLocation m) (writeValue transition) (tape m)
78 let loc' = (tapeLocation m) + (tapeMovement transition)
79 let tState' = newState transition
80 let steps' = stepsRemaining m - 1
81 let m' = m {tState = tState', tape = tape', tapeLocation = loc', stepsRemaining = steps'}
87 sc = L.space (skipSome spaceChar) CA.empty CA.empty
90 integer = lexeme L.integer
94 commandP = between (symbol "-") fullstop
96 writeValueP = (symbol "1" *> pure True) <|> (symbol "0" *> pure False)
97 writeP = commandP ((symbol "Write the value") *> writeValueP)
99 directionP = (symbol "left" *> pure -1) <|> (symbol "right" *> pure 1)
100 tapeMovementP = commandP ((symbol "Move one slot to the") *> directionP)
102 newStateP = commandP ((symbol "Continue with state") *> (some letterChar))
104 stateTransitionP = stify <$> writeP <*> tapeMovementP <*> newStateP
105 where stify w t s = StateTransition {writeValue = w, newState = s, tapeMovement = t}
107 currentValueP = (symbol "If the current value is") *> writeValueP <* (symbol ":")
109 stateWhenP = (,) <$> currentValueP <*> stateTransitionP
111 stateDefP = (symbol "In state") *> (some letterChar) <* (symbol ":")
113 stateRulesP = rulify <$> stateDefP <*> (stateWhenP `sepBy` space)
114 where rulify s ts = M.fromList $ map (\(v, t) -> ((s, v), t)) ts
116 manyStateRulesP = M.unions <$> (stateRulesP `sepBy` space)
118 startStateP = (symbol "Begin in state") *> (some letterChar) <* fullstop
119 stepsP = (symbol "Perform a diagnostic checksum after") *> integer <* (symbol "steps") <* fullstop
121 machineDescriptionP = machineify <$> startStateP <*> stepsP <*> manyStateRulesP
122 where machineify initial limit rules =
123 ( emptyMachine { tState = initial, stepsRemaining = limit }
127 successfulParse :: Text -> (Machine, Rules)
128 successfulParse input =
129 case parse machineDescriptionP "input" input of
130 Left _error -> (emptyMachine, M.empty)
131 Right machineRules -> machineRules