src/advent25/advent25.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5
   6 import Data.Text (Text)
   7 import qualified Data.Text as T
   8 import qualified Data.Text.IO as TIO
   9
  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
  14
  15 import qualified Data.Map as M
  16 import Data.Map ((!))
  17
  18 import Control.Monad (unless)
  19 import Control.Monad.State.Lazy
  20 import Control.Monad.Reader
  21
  22 type TuringState = String
  23
  24 type Tape = M.Map Integer Bool
  25
  26 data StateTransition = StateTransition { writeValue :: Bool
  27                                        , newState :: TuringState
  28                                        , tapeMovement :: Integer
  29                                        } deriving (Show, Eq)
  30
  31 type RuleTrigger = (TuringState, Bool)
  32
  33 type Rules = M.Map RuleTrigger StateTransition
  34
  35 data Machine = Machine { tState :: TuringState
  36                        , tape :: Tape
  37                        , tapeLocation :: Integer
  38                        , stepsRemaining :: Integer
  39                        }
  40                deriving (Show, Eq)
  41
  42 emptyMachine = Machine {tState = "unknown", tape = M.empty, tapeLocation = 0, stepsRemaining = 0}
  43
  44 type ProgrammedMachine = ReaderT Rules (State Machine) ()
  45
  46
  47 main :: IO ()
  48 main = do
  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
  53
  54
  55 part1 :: Rules -> Machine -> Machine
  56 part1 rules machine0 =
  57     execState (
  58         runReaderT executeSteps
  59                    rules
  60              )
  61              machine0
  62
  63 executeSteps :: ProgrammedMachine
  64 executeSteps =
  65     do m <- get
  66        unless (stepsRemaining m == 0) $
  67            do  executeStep
  68                executeSteps
  69
  70
  71 executeStep :: ProgrammedMachine
  72 executeStep =
  73     do rules <- ask
  74        m <- get
  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'}
  82        put m'
  83
  84
  85
  86 sc :: Parser ()
  87 sc = L.space (skipSome spaceChar) CA.empty CA.empty
  88
  89 lexeme = L.lexeme sc
  90 integer = lexeme L.integer
  91 symbol = L.symbol sc
  92 fullstop = symbol "."
  93 colon = symbol ":"
  94 dash = symbol "-"
  95
  96 machineDescriptionP = machineify <$> startStateP <*> stepsP <*> manyStateRulesP
  97     where machineify initial limit rules =
  98             ( emptyMachine { tState = initial, stepsRemaining = limit }
  99             , rules
 100             )
 101
 102 startStateP = (symbol "Begin in state") *> stateP <* fullstop
 103 stepsP =  (symbol "Perform a diagnostic checksum after") *> integer <* (symbol "steps") <* fullstop
 104
 105 manyStateRulesP = M.unions <$> (stateRulesP `sepBy` space)
 106
 107 stateRulesP = rulify <$> stateDefP <*> (stateWhenP `sepBy` space)
 108     where rulify s ts = M.fromList $ map (\(v, t) -> ((s, v), t)) ts
 109
 110 stateWhenP = (,) <$> currentValueP <*> stateTransitionP
 111
 112 stateDefP = (symbol "In state") *> stateP <* colon
 113 currentValueP = (symbol "If the current value is") *> writeValueP <* colon
 114
 115 stateTransitionP = stify <$> writeP <*> tapeMovementP <*> newStateP
 116     where stify w t s = StateTransition {writeValue = w, newState = s, tapeMovement = t}
 117
 118 commandP = between dash fullstop
 119
 120 writeP = commandP ((symbol "Write the value") *> writeValueP)
 121 tapeMovementP = commandP ((symbol "Move one slot to the") *> directionP)
 122 newStateP = commandP ((symbol "Continue with state") *> stateP)
 123
 124 stateP = some letterChar
 125 directionP = (symbol "left" *> pure -1) <|> (symbol "right" *> pure 1)
 126 writeValueP = (symbol "1" *> pure True) <|> (symbol "0" *> pure False)
 127
 128
 129 successfulParse :: Text -> (Machine, Rules)
 130 successfulParse input =
 131         case parse machineDescriptionP "input" input of
 132                 Left  _error -> (emptyMachine, M.empty)
 133                 Right machineRules -> machineRules