1 {-# LANGUAGE NegativeLiterals #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TypeFamilies #-}
6 -- import Prelude hiding ((++))
7 import Data.Text (Text)
8 import qualified Data.Text as T
9 import qualified Data.Text.IO as TIO
11 import Text.Megaparsec hiding (State)
12 import qualified Text.Megaparsec.Lexer as L
13 import Text.Megaparsec.Text (Parser)
14 import qualified Control.Applicative as CA
16 import qualified Data.Map.Strict as M
17 import Data.Map.Strict ((!))
19 import Control.Monad (when)
20 import Control.Monad.State.Lazy
21 import Control.Monad.Reader
22 import Control.Monad.Writer
24 import qualified Data.Numbers.Primes as P
26 data Location = Literal Integer | Register Char deriving (Show, Eq)
27 data Instruction = Set Location Location
28 | Sub Location Location
29 | Mul Location Location
30 | Jnz Location Location
33 data Machine = Machine { registers :: M.Map Char Integer
38 type ProgrammedMachine = WriterT [Int] (ReaderT [Instruction] (State Machine)) ()
40 emptyMachine = Machine {registers = M.empty, pc = 0}
46 text <- TIO.readFile "data/advent23.txt"
47 let instrs = successfulParse text
48 let ((result, l), machinef) = part1 instrs
56 runWriterT executeInstructions
64 -- Part 2 following results of analysis by Dario Petrillo
65 -- https://github.com/dp1/AoC17/blob/master/day23.5.txt
66 part2 = length $ filter (not . P.isPrime) [start, start + 17 .. end]
67 where start = 84 * 100 + 100000
73 when (pc m >= 0 && pc m < length instrs)
75 do when (isMul $ instrs !! pc m) (tell [1])
79 executeInstruction :: ProgrammedMachine
83 let instr = instrs!!(pc m)
84 put (applyInstruction instr m)
87 applyInstruction :: Instruction -> Machine -> Machine
89 applyInstruction (Set (Register a) b) m = m {registers = reg', pc = pc'}
92 reg' = M.insert a y $ registers m
94 applyInstruction (Sub (Register a) b) m = m {registers = reg', pc = pc'}
96 x = evaluate m (Register a)
98 reg' = M.insert a (x - y) $ registers m
100 applyInstruction (Mul (Register a) b) m = m {registers = reg', pc = pc'}
102 x = evaluate m (Register a)
104 reg' = M.insert a (x * y) $ registers m
106 applyInstruction (Jnz a b) m = m {pc = pc'}
107 where x = evaluate m a
109 pc' = if x /= 0 then pc m + (fromIntegral y) else pc m + 1
112 isMul :: Instruction -> Bool
113 isMul (Mul _ _ ) = True
116 evaluate :: Machine -> Location -> Integer
117 evaluate _ (Literal i) = i
118 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
123 sc = L.space (skipSome spaceChar) CA.empty CA.empty
127 integer = lexeme L.integer
128 signedInteger = L.signed sc integer
132 -- reg :: Parser String
133 -- reg = id <$> some letterChar
135 reg = lexeme (some letterChar)
137 location = (Literal <$> signedInteger) <|> register
138 register = (Register . head) <$> reg
140 instructionsP = instructionP `sepBy` space
141 instructionP = choice [setP, subP, mulP, jnzP]
143 setP = Set <$> (try (symbol "set") *> register) <*> location
144 subP = Sub <$> (try (symbol "sub") *> register) <*> location
145 mulP = Mul <$> (try (symbol "mul") *> register) <*> location
146 jnzP = Jnz <$> (try (symbol "jnz") *> location) <*> location
148 successfulParse :: Text -> [Instruction]
149 successfulParse input =
150 case parse instructionsP "input" input of
151 Left _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
152 Right instructions -> instructions