intcode-0.2.0.0: src/Intcode.hs
{-# Language DeriveTraversable, Trustworthy #-}
{-|
Module : Intcode
Description : Intcode interpreter
Copyright : (c) Eric Mertens, 2019
License : ISC
Maintainer : emertens@gmail.com
This Intcode interpreter is defined across multiple Advent of Code days:
* <https://adventofcode.com/2019/day/2>
* <https://adventofcode.com/2019/day/5>
* <https://adventofcode.com/2019/day/7>
* <https://adventofcode.com/2019/day/9>
This implementation works with the following passes:
1. Parse input text file into a list of numbers
2. Execute op codes to single-step input/output effects.
3. Execute single-stop effects into big-step effects.
Common use modes:
* List functions: 'intcodeToList'
* Individual machine step processing: 'Step', 'new', 'step'
* Input/output interpretation: 'Effect', 'new', 'run'
-}
module Intcode
(
-- * Simple interface
intcodeToList,
runIO,
-- * Machine state
Machine(..), (!), new, set, memoryList,
-- * Effects
Effect(..), run, (>>>), effectList, followedBy, feedInput,
-- * Small-step
Step(..), step,
-- * Opcodes
Mode(..), Opcode(..), decode,
-- * Exceptions
IntcodeFault(..)
) where
import Control.Exception (Exception(..), throwIO, throw)
import Data.Char (chr, ord)
import Data.IntMap (IntMap)
import Data.Traversable (mapAccumL)
import qualified Data.IntMap as IntMap
import qualified Data.Primitive.PrimArray as P
import Text.Show.Functions ()
------------------------------------------------------------------------
-- ASCII I/O
------------------------------------------------------------------------
-- | Run intcode program using stdio. Non-ASCII outputs are printed as
-- integers.
--
-- >>> runIO (run (new [104,72,104,101,104,108,104,108,104,111,104,33,104,10,99]))
-- Hello!
runIO :: Effect -> IO ()
runIO (Output o e)
| 0 <= o, o < 0x80 = putChar (chr (fromIntegral o)) >> runIO e
| otherwise = putStrLn ("<<" ++ show o ++ ">>") >> runIO e
runIO (Input f) = runIO . f . fromIntegral . ord =<< getChar
runIO Halt = return ()
runIO Fault = throwIO IntcodeFault
------------------------------------------------------------------------
-- High-level interface
------------------------------------------------------------------------
-- | Run a given memory image as a list transducer.
--
-- Use 'effectList' when you want to provide a specific 'Effect'.
--
-- Throws: 'IntcodeFault' when machine faults or too few inputs are provided.
--
--
-- >>> intcodeToList [3,12,6,12,15,1,13,14,13,4,13,99,-1,0,1,9] <$> [[0],[10]]
-- [[0],[1]]
--
-- >>> intcodeToList [3,3,1105,-1,9,1101,0,0,12,4,12,99,1] <$> [[0],[10]]
-- [[0],[1]]
--
-- >>> :{
-- >>> intcodeToList
-- >>> [3,21,1008,21,8,20,1005,20,22,107,8,21,20,1006,20,31,
-- >>> 1106,0,36,98,0,0,1002,21,125,20,4,20,1105,1,46,104,
-- >>> 999,1105,1,46,1101,1000,1,20,4,20,1105,1,46,98,99]
-- >>> <$> [[7],[8],[9]]
-- >>> :}
-- [[999],[1000],[1001]]
intcodeToList ::
[Int] {- ^ initial memory -} ->
[Int] {- ^ inputs -} ->
[Int] {- ^ outputs -}
intcodeToList = effectList . run . new
-- | Evaluate a program's effect as a function from a list of
-- inputs to a list of outputs.
--
-- Throws: 'IntcodeFault' when machine faults or too few inputs are provided.
effectList ::
Effect {- ^ program effect -} ->
[Int] {- ^ inputs -} ->
[Int] {- ^ outputs -}
effectList effect inputs =
case effect of
Input f | x:xs <- inputs -> effectList (f x) xs
| otherwise -> throw IntcodeFault
Output o e -> o : effectList e inputs
Halt -> []
Fault -> throw IntcodeFault
------------------------------------------------------------------------
-- Machine state
------------------------------------------------------------------------
-- | Machine state.
data Machine = Machine
{ pc :: !Int -- ^ program counter
, relBase :: !Int -- ^ relative base pointer
, memory :: !(IntMap Int) -- ^ memory updates
, image :: {-# Unpack #-} !(P.PrimArray Int) -- ^ initial memory
}
deriving (Eq, Ord, Show)
-- | Value stored in initial memory image at given index.
indexImage ::
Machine {- ^ machine -} ->
Int {- ^ position -} ->
Int {- ^ value -}
indexImage m i
| a `seq` True, 0 <= i, i < P.sizeofPrimArray a = P.indexPrimArray a i
| otherwise = 0
where
a = image m
{-# INLINE indexImage #-}
-- | Memory lookup from 0-based index.
(!) ::
Machine {- ^ machine -} ->
Int {- ^ position -} ->
Int {- ^ value -}
m ! i = IntMap.findWithDefault (indexImage m i) i (memory m)
-- | Construct machine from a list of initial values starting
-- at address 0. Program counter and relative base start at 0.
new ::
[Int] {- ^ initial memory -} ->
Machine {- ^ new machine -}
new initialValues = Machine
{ pc = 0
, relBase = 0
, memory = IntMap.empty
, image = P.primArrayFromList initialValues
}
-- | Update the value stored at a given location in memory.
set ::
Int {- ^ position -} ->
Int {- ^ new value -} ->
Machine -> Machine
set i v m
| v == o = m { memory = IntMap.delete i (memory m) }
| otherwise = m { memory = IntMap.insert i v (memory m) }
where
o = indexImage m i
-- | Update the relative base pointer by adding an offset to it.
adjustRelBase :: Int {- ^ offset -} -> Machine -> Machine
adjustRelBase i mach = mach { relBase = relBase mach + i }
-- | Set program counter to a new address.
jmp ::
Int {- ^ program counter -} ->
Machine -> Machine
jmp i mach = mach { pc = i }
-- | Generate a list representation of memory starting from
-- zero. This can get big for sparsely filled memory using
-- large addresses. Returned values start at position 0.
--
-- >>> memoryList (set 8 10 (new [1,2,3]))
-- [1,2,3,0,0,0,0,0,10]
memoryList :: Machine -> [Int]
memoryList mach
| IntMap.null (memory mach) = P.primArrayToList (image mach)
| otherwise = [mach ! i | i <- [0 .. top]]
where
top = max (P.sizeofPrimArray (image mach) - 1)
(fst (IntMap.findMax (memory mach)))
------------------------------------------------------------------------
-- Big-step semantics
------------------------------------------------------------------------
-- | Possible effects from running a machine
data Effect
= Output !Int Effect -- ^ Output an integer
| Input (Int -> Effect) -- ^ Input an integer
| Halt -- ^ Halt execution
| Fault -- ^ Execution failure
deriving Show
-- | Big-step semantics of virtual machine. The implementation details
-- of 'Machine' are abstracted away and the program behavior can be
-- observed by interpreting the various 'Effect' constructors.
--
-- >>> run (new [1102,34915192,34915192,7,4,7,99,0])
-- Output 1219070632396864 Halt
--
-- >>> run (new [3,1,99])
-- Input <function>
run :: Machine -> Effect
run mach =
case step mach of
Step mach' -> run mach'
StepOut out mach' -> Output out (run mach')
StepIn f -> Input (run . f)
StepHalt -> Halt
StepFault -> Fault
-- | Compose two effects together. Outputs from first argument are
-- used as inputs to the second effect. Composed effect halts when
-- the second machine halts.
--
-- >>> let mult n = Input (\i -> Output (i*n) Halt)
-- >>> let add n = Input (\i -> Output (i+n) Halt)
-- >>> effectList (mult 3 >>> add 1) [4]
-- [13]
(>>>) :: Effect -> Effect -> Effect
x >>> Output o y = Output o (x >>> y)
_ >>> Halt = Halt
_ >>> Fault = Fault
Output o x >>> Input f = x >>> f o
Halt >>> Input _ = Fault
Fault >>> Input _ = Fault
Input f >>> y = Input (\i -> f i >>> y)
infixl 9 >>>
-- | Run first effect until it halts, then run the second effect.
--
-- >>> Output 1 Halt `followedBy` Output 2 Halt
-- Output 1 (Output 2 Halt)
followedBy :: Effect -> Effect -> Effect
followedBy Halt y = y
followedBy Fault _ = Fault
followedBy (Output o x) y = Output o (followedBy x y)
followedBy (Input f ) y = Input (\i -> followedBy (f i) y)
-- | Provide an input to the first occurrence of an input request
-- in a program effect. It is considered a fault if a program
-- terminates before using the input.
--
-- >>> let mult n = Input (\i -> Output (i*n) Halt)
-- >>> feedInput [6] (mult 5)
-- Output 30 Halt
feedInput :: [Int] {- ^ inputs -} -> Effect -> Effect
feedInput [] e = e
feedInput xs (Output o e) = Output o (feedInput xs e)
feedInput (x:xs) (Input f) = feedInput xs (f x)
feedInput _ _ = Fault
------------------------------------------------------------------------
-- Small-step semantics
------------------------------------------------------------------------
-- | Result of small-step semantics.
data Step
= Step !Machine -- ^ no effect
| StepOut !Int !Machine -- ^ output
| StepIn (Int -> Machine) -- ^ input
| StepHalt -- ^ halt
| StepFault -- ^ bad instruction
deriving Show
-- | Small-step semantics of virtual machine.
step :: Machine -> Step
step mach =
case populateParams <$> decode (mach ! pc mach) of
Nothing -> StepFault
Just (pc', opcode) -> opcodeImpl opcode $! jmp pc' mach
where
populateParams :: Opcode Mode -> (Int, Opcode Int)
populateParams = mapWithIndex toPtr (pc mach + 1)
toPtr :: Int -> Mode -> Int
toPtr i Imm = i
toPtr i Abs = mach ! i
toPtr i Rel = mach ! i + relBase mach
-- | Apply a decoded opcode to the machine state.
opcodeImpl ::
Opcode Int {- ^ opcode with pointers -} ->
Machine {- ^ machine with PC updated -} ->
Step
opcodeImpl o m =
case o of
Add a b c -> Step (set c (at a + at b) m)
Mul a b c -> Step (set c (at a * at b) m)
Inp a -> StepIn (\i -> set a i m)
Out a -> StepOut (at a) m
Jnz a b -> Step (if at a /= 0 then jmp (at b) m else m)
Jz a b -> Step (if at a == 0 then jmp (at b) m else m)
Lt a b c -> Step (set c (if at a < at b then 1 else 0) m)
Eq a b c -> Step (set c (if at a == at b then 1 else 0) m)
Arb a -> Step (adjustRelBase (at a) m)
Hlt -> StepHalt
where
at i = m ! i
mapWithIndex :: (Int -> a -> b) -> Int -> Opcode a -> (Int, Opcode b)
mapWithIndex f = mapAccumL (\i a -> (i+1, f i a))
{-# INLINE mapWithIndex #-}
------------------------------------------------------------------------
-- Opcode decoder
------------------------------------------------------------------------
-- | Parameter modes
data Mode
= Abs -- ^ absolute position
| Imm -- ^ immediate
| Rel -- ^ relative position
deriving (Eq, Ord, Read, Show)
-- | Opcodes parameterized over argument representations.
data Opcode a
= Add !a !a !a -- ^ addition: @c = a + b@
| Mul !a !a !a -- ^ multiplication: @c = a * b@
| Inp !a -- ^ input: @a = input()@
| Out !a -- ^ output: @output(a)@
| Jnz !a !a -- ^ jump-if-true: @if a then goto b@
| Jz !a !a -- ^ jump-if-false: @if !a then goto b@
| Lt !a !a !a -- ^ less-than: @c = a < b@
| Eq !a !a !a -- ^ equals: @c = a == b@
| Arb !a -- ^ adjust-rel-base: @rel += a@
| Hlt -- ^ halt
deriving (Eq, Ord, Read, Show, Functor, Foldable)
-- | Decode an instruction to determine the opcode and parameter modes.
--
-- >>> decode 1002
-- Just (Mul Abs Imm Abs)
decode :: Int {- ^ opcode -} -> Maybe (Opcode Mode)
decode n =
case n `rem` 100 of
1 -> fill (Add 1 2 3)
2 -> fill (Mul 1 2 3)
3 -> fill (Inp 1)
4 -> fill (Out 1)
5 -> fill (Jnz 1 2)
6 -> fill (Jz 1 2)
7 -> fill (Lt 1 2 3)
8 -> fill (Eq 1 2 3)
9 -> fill (Arb 1)
99 -> fill Hlt
_ -> Nothing
where
fill = traverse (parameter n)
-- | Compute the parameter mode for an argument at a given position.
parameter ::
Int {- ^ opcode -} ->
Int {- ^ position -} ->
Maybe Mode
parameter n i =
case digit (i+1) n of
0 -> Just Abs
1 -> Just Imm
2 -> Just Rel
_ -> Nothing
-- | Arguments visited from left to right.
instance Traversable Opcode where
{-# INLINE traverse #-}
traverse f o =
case o of
Add x y z -> Add <$> f x <*> f y <*> f z
Mul x y z -> Mul <$> f x <*> f y <*> f z
Inp x -> Inp <$> f x
Out x -> Out <$> f x
Jnz x y -> Jnz <$> f x <*> f y
Jz x y -> Jz <$> f x <*> f y
Lt x y z -> Lt <$> f x <*> f y <*> f z
Eq x y z -> Eq <$> f x <*> f y <*> f z
Arb x -> Arb <$> f x
Hlt -> pure Hlt
-- | Extract the ith digit from a number.
--
-- >>> digit 0 2468
-- 8
-- >>> digit 3 2468
-- 2
-- >>> digit 4 2468
-- 0
digit :: Int {- ^ position -} -> Int {- ^ number -} -> Int {- ^ digit -}
digit i x = x `quot` (10^i) `rem` 10
------------------------------------------------------------------------
-- Exceptions
------------------------------------------------------------------------
-- | Error when a machine fails to decode an instruction.
data IntcodeFault = IntcodeFault
deriving (Eq, Ord, Show, Read)
instance Exception IntcodeFault where
displayException _ = "intcode machine fault"