# Coprocessor Conflagration — Haskell — #adventofcode Day 23

**Date:**

**Series:**Advent of Code 2017

Series

This post is part of the series Advent of Code 2017

- Reflections on #aoc2017
- The Halting Problem — Python — #adventofcode Day 25
- Electromagnetic Moat — Rust — #adventofcode Day 24
- > Coprocessor Conflagration — Haskell — #adventofcode Day 23 <
- Sporifica Virus — Rust — #adventofcode Day 22
- Fractal Art — Python — #adventofcode Day 21
- Particle Swarm — Python — #adventofcode Day 20
- A Series of Tubes — Rust — #adventofcode Day 19
- Duet — Haskell — #adventofcode Day 18
- Spinlock — Rust/Python — #adventofcode Day 17
- Permutation Promenade — Julia — #adventofcode Day 16
- Dueling Generators — Rust — #adventofcode Day 15
- Disk Defragmentation — Haskell — #adventofcode Day 14
- Packet Scanners — Haskell — #adventofcode Day 13
- Digital Plumber — Python — #adventofcode Day 12
- Hex Ed — Python — #adventofcode Day 11
- Knot Hash — Haskell — #adventofcode Day 10
- Stream Processing — Haskell — #adventofcode Day 9
- I Heard You Like Registers — Python — #adventofcode Day 8
- Recursive Circus — Ruby — #adventofcode Day 7
- Memory Reallocation — Python — #adventofcode Day 6
- A Maze of Twisty Trampolines — C++ — #adventofcode Day 5
- High Entropy Passphrases — Python — #adventofcode Day 4
- Spiral Memory — Go — #adventofcode Day 3
- Corruption Checksum — Python — #adventofcode Day 2
- Inverse Captcha — Coconut — #adventofcode Day 1
- Advent of Code 2017: introduction

Today’s challenge requires us to understand why a coprocessor is working so hard to perform an apparently simple calculation.

!!! commentary
Today’s problem is based on an assembly-like language very similar to day 18, so I went back and adapted my code from that, which works well for the first part. I’ve also incorporated some advice from /r/haskell, and cleaned up all warnings shown by the `-Wall`

compiler flag and the `hlint`

tool.

```
Part 2 requires the algorithm to run with much larger inputs, and since some analysis shows that it's an `O(n^3)` algorithm it gets intractible pretty fast. There are several approaches to this. First up, if you have a fast enough processor and an efficient enough implementation I suspect that the simulation would probably terminate eventually, but that would likely still take hours: not good enough. I also thought about doing some peephole optimisations on the instructions, but the last time I did compiler optimisation was my degree so I wasn't really sure where to start. What I ended up doing was actually analysing the input code by hand to figure out what it was doing, and then just doing that calculation in a sensible way. I'd like to say I managed this on my own (and I ike to think I would have) but I did get some tips on [/r/adventofcode](https://reddit.com/r/adventofcode).
```

The majority of this code is simply a cleaned-up version of day 18, with some tweaks to accommodate the different instruction set:

```
module Main where
import qualified Data.Vector as V
import qualified Data.Map.Strict as M
import Control.Monad.State.Strict
import Text.ParserCombinators.Parsec hiding (State)
type Register = Char
type Value = Int
type Argument = Either Value Register
data Instruction = Set Register Argument
| Sub Register Argument
| Mul Register Argument
| Jnz Argument Argument
deriving Show
type Program = V.Vector Instruction
data Result = Cont | Halt deriving (Eq, Show)
type Registers = M.Map Char Int
data Machine = Machine { dRegisters :: Registers
, dPtr :: !Int
, dMulCount :: !Int
, dProgram :: Program }
instance Show Machine where
show d = show (dRegisters d) ++ " @" ++ show (dPtr d) ++ " ×" ++ show (dMulCount d)
defaultMachine :: Machine
defaultMachine = Machine M.empty 0 0 V.empty
type MachineState = State Machine
program :: GenParser Char st Program
program = do
instructions <- endBy instruction eol
return $ V.fromList instructions
where
instruction = try (regOp "set" Set) <|> regOp "sub" Sub
<|> regOp "mul" Mul <|> jump "jnz" Jnz
regOp n c = do
string n >> spaces
val1 <- oneOf "abcdefgh"
secondArg c val1
jump n c = do
string n >> spaces
val1 <- regOrVal
secondArg c val1
secondArg c val1 = do
spaces
val2 <- regOrVal
return $ c val1 val2
regOrVal = register <|> value
register = do
name <- lower
return $ Right name
value = do
val <- many $ oneOf "-0123456789"
return $ Left $ read val
eol = char '\n'
parseProgram :: String -> Either ParseError Program
parseProgram = parse program ""
getReg :: Char -> MachineState Int
getReg r = do
st <- get
return $ M.findWithDefault 0 r (dRegisters st)
putReg :: Char -> Int -> MachineState ()
putReg r v = do
st <- get
let current = dRegisters st
new = M.insert r v current
put $ st { dRegisters = new }
modReg :: (Int -> Int -> Int) -> Char -> Argument -> MachineState ()
modReg op r v = do
u <- getReg r
v' <- getRegOrVal v
putReg r (u `op` v')
incPtr
getRegOrVal :: Argument -> MachineState Int
getRegOrVal = either return getReg
addPtr :: Int -> MachineState ()
addPtr n = do
st <- get
put $ st { dPtr = n + dPtr st }
incPtr :: MachineState ()
incPtr = addPtr 1
execInst :: Instruction -> MachineState ()
execInst (Set reg val) = do
newVal <- getRegOrVal val
putReg reg newVal
incPtr
execInst (Mul reg val) = do
result <- modReg (*) reg val
st <- get
put $ st { dMulCount = 1 + dMulCount st }
return result
execInst (Sub reg val) = modReg (-) reg val
execInst (Jnz val1 val2) = do
test <- getRegOrVal val1
jump <- if test /= 0 then getRegOrVal val2 else return 1
addPtr jump
execNext :: MachineState Result
execNext = do
st <- get
let prog = dProgram st
p = dPtr st
if p >= length prog then return Halt else do
execInst (prog V.! p)
return Cont
runUntilTerm :: MachineState ()
runUntilTerm = do
result <- execNext
unless (result == Halt) runUntilTerm
```

This implements the actual calculation: the number of non-primes between (for my input) 107900 and 124900:

```
optimisedCalc :: Int -> Int -> Int -> Int
optimisedCalc a b k = sum $ map (const 1) $ filter notPrime [a,a+k..b]
where
notPrime n = elem 0 $ map (mod n) [2..(floor $ sqrt (fromIntegral n :: Double))]
main :: IO ()
main = do
input <- getContents
case parseProgram input of
Right prog -> do
let c = defaultMachine { dProgram = prog }
(_, c') = runState runUntilTerm c
putStrLn $ show (dMulCount c') ++ " multiplications made"
putStrLn $ "Calculation result: " ++ show (optimisedCalc 107900 124900 17)
Left e -> print e
```