src/advent23/advent23.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5
   6 -- import Prelude hiding ((++))
   7 import Data.Text (Text)
   8 import qualified Data.Text as T
   9 import qualified Data.Text.IO as TIO
  10
  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
  15
  16 import qualified Data.Map.Strict as M
  17 import Data.Map.Strict ((!))
  18
  19 import Control.Monad (when)
  20 import Control.Monad.State.Lazy
  21 import Control.Monad.Reader
  22 import Control.Monad.Writer
  23
  24 import qualified Data.Numbers.Primes as P
  25
  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
  31                    deriving (Show, Eq)
  32
  33 data Machine = Machine { registers :: M.Map Char Integer
  34                        , pc :: Int
  35                        }
  36                deriving (Show, Eq)
  37
  38 type ProgrammedMachine = WriterT [Int] (ReaderT [Instruction] (State Machine)) ()
  39
  40 emptyMachine = Machine {registers = M.empty, pc = 0}
  41
  42
  43
  44 main :: IO ()
  45 main = do
  46         text <- TIO.readFile "data/advent23.txt"
  47         let instrs = successfulParse text
  48         let ((result, l), machinef) = part1 instrs
  49         print $ length l
  50         print $ part2
  51
  52
  53 part1 instructions =
  54     runState (
  55         runReaderT (
  56             runWriterT executeInstructions
  57                    )
  58             instructions
  59              )
  60              emptyMachine
  61
  62
  63
  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
  68           end = start + 17000
  69
  70 executeInstructions =
  71     do  instrs <- ask
  72         m <- get
  73         when (pc m >= 0 && pc m < length instrs)
  74             $
  75             do when (isMul $ instrs !! pc m) (tell [1])
  76                executeInstruction
  77                executeInstructions
  78
  79 executeInstruction :: ProgrammedMachine
  80 executeInstruction =
  81     do  instrs <- ask
  82         m <- get
  83         let instr = instrs!!(pc m)
  84         put (applyInstruction instr m)
  85
  86
  87 applyInstruction :: Instruction -> Machine -> Machine
  88
  89 applyInstruction (Set (Register a) b) m = m {registers = reg', pc = pc'}
  90     where pc' = pc m + 1
  91           y = evaluate m b
  92           reg' = M.insert a y $ registers m
  93
  94 applyInstruction (Sub (Register a) b) m = m {registers = reg', pc = pc'}
  95     where pc' = pc m + 1
  96           x = evaluate m (Register a)
  97           y = evaluate m b
  98           reg' = M.insert a (x - y) $ registers m
  99
 100 applyInstruction (Mul (Register a) b) m = m {registers = reg', pc = pc'}
 101     where pc' = pc m + 1
 102           x = evaluate m (Register a)
 103           y = evaluate m b
 104           reg' = M.insert a (x * y) $ registers m
 105
 106 applyInstruction (Jnz a b) m = m {pc = pc'}
 107     where x = evaluate m a
 108           y = evaluate m b
 109           pc' = if x /= 0 then pc m + (fromIntegral y) else pc m + 1
 110
 111
 112 isMul :: Instruction -> Bool
 113 isMul (Mul _ _ ) = True
 114 isMul _ = False
 115
 116 evaluate :: Machine -> Location -> Integer
 117 evaluate _ (Literal i)  = i
 118 evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 119
 120
 121
 122 sc :: Parser ()
 123 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 124
 125 lexeme  = L.lexeme sc
 126
 127 integer       = lexeme L.integer
 128 signedInteger = L.signed sc integer
 129
 130 symbol = L.symbol sc
 131
 132 -- reg :: Parser String
 133 -- reg = id <$> some letterChar
 134
 135 reg = lexeme (some letterChar)
 136
 137 location = (Literal <$> signedInteger) <|> register
 138 register = (Register . head) <$> reg
 139
 140 instructionsP = instructionP `sepBy` space
 141 instructionP = choice [setP, subP, mulP, jnzP]
 142
 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
 147
 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