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 (result, machinef) = part1 rules machine0
  52         print $ M.size $ M.filter id $ tape machinef
  53
  54
  55 part1 rules machine0 =
  56     runState (
  57         runReaderT executeSteps
  58                    rules
  59              )
  60              machine0
  61
  62 executeSteps =
  63     do m <- get
  64        unless (stepsRemaining m == 0) $
  65            do  executeStep
  66                executeSteps
  67
  68
  69 executeStep =
  70     do rules <- ask
  71        m <- get
  72        let tapeHere = M.findWithDefault False (tapeLocation m) (tape m)
  73        let transition = rules!(tState m, tapeHere)
  74        let tape' = M.insert (tapeLocation m) (writeValue transition) (tape m)
  75        let loc' = (tapeLocation m) + (tapeMovement transition)
  76        let tState' = newState transition
  77        let steps' = stepsRemaining m - 1
  78        let m' = m {tState = tState', tape = tape', tapeLocation = loc', stepsRemaining = steps'}
  79        put m'
  80
  81
  82
  83 sc :: Parser ()
  84 sc = L.space (skipSome spaceChar) CA.empty CA.empty
  85
  86 lexeme = L.lexeme sc
  87 integer = lexeme L.integer
  88 symbol = L.symbol sc
  89 fullstop = symbol "."
  90
  91 commandP = between (symbol "-") fullstop
  92
  93 writeValueP = (symbol "1" *> pure True) <|> (symbol "0" *> pure False)
  94 writeP = commandP ((symbol "Write the value") *> writeValueP)
  95
  96 directionP = (symbol "left" *> pure -1) <|> (symbol "right" *> pure 1)
  97 tapeMovementP = commandP ((symbol "Move one slot to the") *> directionP)
  98
  99 newStateP = commandP ((symbol "Continue with state") *> (some letterChar))
 100
 101 stateTransitionP = stify <$> writeP <*> tapeMovementP <*> newStateP
 102     where stify w t s = StateTransition {writeValue = w, newState = s, tapeMovement = t}
 103
 104 currentValueP = (symbol "If the current value is") *> writeValueP <* (symbol ":")
 105
 106 stateWhenP = (,) <$> currentValueP <*> stateTransitionP
 107
 108 stateDefP = (symbol "In state") *> (some letterChar) <* (symbol ":")
 109
 110 stateRulesP = rulify <$> stateDefP <*> (stateWhenP `sepBy` space)
 111     where rulify s ts = M.fromList $ map (\(v, t) -> ((s, v), t)) ts
 112
 113 manyStateRulesP = M.unions <$> (stateRulesP `sepBy` space)
 114
 115 startStateP = (symbol "Begin in state") *> (some letterChar) <* fullstop
 116 stepsP =  (symbol "Perform a diagnostic checksum after") *> integer <* (symbol "steps") <* fullstop
 117
 118 machineDescriptionP = machineify <$> startStateP <*> stepsP <*> manyStateRulesP
 119     where machineify initial limit rules =
 120             ( emptyMachine { tState = initial, stepsRemaining = limit }
 121             , rules
 122             )
 123
 124 successfulParse :: Text -> (Machine, Rules)
 125 successfulParse input =
 126         case parse machineDescriptionP "input" input of
 127                 Left  _error -> (emptyMachine, M.empty)
 128                 Right machineRules -> machineRules