diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for intcode +## 0.3.0.0 +* Split machine-state and opcodes into separate modules. +* Add `Intcode.Parse` +* Add `Intcode.hRunIO` + ## 0.2.0.0 * Rename 'intCodeToList' to 'intcodeToList' diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,3 @@ +import Test.DocTest +main :: IO () +main = doctest ["-isrc", "Intcode", "Intcode.Machine", "Intcode.Opcode", "Intcode.Parse"] diff --git a/intcode.cabal b/intcode.cabal --- a/intcode.cabal +++ b/intcode.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: intcode -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Advent of Code 2019 intcode interpreter category: Compilers/Interpreters license: ISC @@ -12,7 +12,7 @@ build-type: Simple homepage: https://github.com/glguy/intcode bug-reports: https://github.com/glguy/intcode/issues -tested-with: GHC ==8.6.5, GHC ==8.8.1 +tested-with: GHC ==8.6.5, GHC ==8.8.2 description: Implementation of the Intcode virtual machine as defined by @@ -36,8 +36,22 @@ exposed-modules: Intcode + Intcode.Machine + Intcode.Opcode + Intcode.Parse build-depends: base >= 4.12 && < 4.14, containers ^>= 0.6, primitive ^>= 0.7, + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + default-language: Haskell2010 + ghc-options: -threaded + build-depends: + base, + containers, + primitive, + doctest ^>= 0.16, diff --git a/src/Intcode.hs b/src/Intcode.hs --- a/src/Intcode.hs +++ b/src/Intcode.hs @@ -1,4 +1,4 @@ -{-# Language DeriveTraversable, Trustworthy #-} +{-# Language Safe #-} {-| Module : Intcode Description : Intcode interpreter @@ -6,56 +6,70 @@ License : ISC Maintainer : emertens@gmail.com -This Intcode interpreter is defined across multiple Advent of Code days: - -* -* -* -* +Intcode is a virtual machine environment defined to have some arithmetic, +conditional jumps, and simple input and output facilities. -This implementation works with the following passes: +The instruction set is designed with independently selectable address modes for +each of its input and output parameters. The architecture is designed to be +simple to implement while powerful enough to write interesting programs +efficiently. The addition of a /relative base pointer/ makes it easy to +implement function calls in the language. - 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. +This Intcode architecture is defined across multiple + tasks: +, +, +, and + Common use modes: -* List functions: 'intcodeToList' -* Individual machine step processing: 'Step', 'new', 'step' -* Input/output interpretation: 'Effect', 'new', 'run' +* Machine construction: 'new' +* List functions: 'intcodeToList', 'effectList' +* Individual machine step processing: 'Step', 'step' +* Input/output interpretation: 'Effect', 'run' +Submodules: + +* "Intcode.Machine" exposes the implementation details of the interpreter state. +* "Intcode.Parse" provides a parser for intcode text files. +* "Intcode.Opcode" provides types and the decoder for opcodes. + -} module Intcode ( - -- * Simple interface + -- * Simple list interface intcodeToList, - runIO, -- * Machine state - Machine(..), (!), new, set, memoryList, + Machine, (!), new, set, memoryList, - -- * Effects - Effect(..), run, (>>>), effectList, followedBy, feedInput, + -- * Big-step semantics + Effect(..), run, - -- * Small-step - Step(..), step, + -- * Effect operations + (>>>), followedBy, feedInput, effectList, - -- * Opcodes - Mode(..), Opcode(..), decode, + -- * Small-step semantics + Step(..), step, -- * Exceptions - IntcodeFault(..) + IntcodeFault(..), + + -- * ASCII I/O interface + runIO, hRunIO, + ) 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 () +import Control.Exception (Exception(..), throw, throwIO) +import Data.Char (chr, ord) +import Data.Traversable (mapAccumL) +import System.IO (Handle, hGetChar, hPutChar, hPutStrLn, stdin, stdout) +import Text.Show.Functions () +import Intcode.Machine (Machine(..), (!), addRelBase, jmp, memoryList, new, set) +import Intcode.Opcode (Mode(..), Opcode(..), decode) + ------------------------------------------------------------------------ -- ASCII I/O ------------------------------------------------------------------------ @@ -63,16 +77,32 @@ -- | Run intcode program using stdio. Non-ASCII outputs are printed as -- integers. -- +-- Note that input and output is affected by handle buffering modes. +-- -- >>> runIO (run (new [104,72,104,101,104,108,104,108,104,111,104,33,104,10,99])) -- Hello! +-- +-- >>> runIO (run (new [104,-50,104,1000,99])) +-- <<-50>> +-- <<1000>> 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 +runIO = hRunIO stdin stdout +-- | 'runIO' generalized to an arbitrary input and output handle. +hRunIO :: + Handle {- ^ input handle -} -> + Handle {- ^ output handle -} -> + Effect {- ^ effect -} -> + IO () +hRunIO inH outH = go + where + go (Output o e) + | 0 <= o, o < 0x80 = hPutChar outH (chr (fromIntegral o)) >> go e + | otherwise = hPutStrLn outH ("<<" ++ show o ++ ">>") >> go e + go (Input f) = go . f . fromIntegral . ord =<< hGetChar inH + go Halt = return () + go Fault = throwIO IntcodeFault + ------------------------------------------------------------------------ -- High-level interface ------------------------------------------------------------------------ @@ -114,90 +144,13 @@ [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))) + Fault -> throw IntcodeFault + Halt -> [] + Output o e -> o : effectList e inputs + Input f -> + case inputs of + x:xs -> effectList (f x) xs + [] -> throw IntcodeFault ------------------------------------------------------------------------ -- Big-step semantics @@ -238,13 +191,15 @@ -- >>> 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) +_ >>> Fault = Fault +_ >>> Halt = Halt +x >>> Output o e = Output o (x >>> e) +x >>> Input g = input x + where + input Fault = Fault + input Halt = Fault + input (Output o e) = e >>> g o + input (Input f) = Input (input . f) infixl 9 >>> @@ -252,24 +207,32 @@ -- -- >>> Output 1 Halt `followedBy` Output 2 Halt -- Output 1 (Output 2 Halt) +-- +-- >>> Output 1 Halt `followedBy` Fault +-- Output 1 Fault +-- +-- >>> Fault `followedBy` undefined +-- Fault 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) +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) +-- >>> feedInput [5,6] (Input (\x -> Input (\y -> Output (x*y) Halt))) -- Output 30 Halt +-- +-- >>> feedInput [7] Halt +-- Fault 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 +feedInput _ _ = Fault ------------------------------------------------------------------------ -- Small-step semantics @@ -315,7 +278,7 @@ 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) + Arb a -> Step (addRelBase (at a) m) Hlt -> StepHalt where at i = m ! i @@ -323,91 +286,6 @@ 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 diff --git a/src/Intcode/Machine.hs b/src/Intcode/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Intcode/Machine.hs @@ -0,0 +1,130 @@ +{-# Language Trustworthy #-} +{-| +Module : Intcode.Machine +Description : Intcode machine representation +Copyright : (c) Eric Mertens, 2019 +License : ISC +Maintainer : emertens@gmail.com + +The module implements the representation of the intcode machine state. + +The 'Machine' type stores the initial memory image in an array and +only stores changes to that initial image. This allows for more efficient +comparisons of machine states for equality when there are few changes to +memory. + +This implementation of the machine supports negative memory addresses. +These are defined not to be used in the Advent of Code problems. + +This implementation stores machine-sized 'Int' values in memory. + +-} +module Intcode.Machine + ( + -- * Machine state + Machine(..), new, + + -- * Register operations + jmp, addRelBase, + + -- * Memory operations + (!), set, memoryList, + ) + where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Primitive.PrimArray as P + +-- | Machine state is comprised of the program counter, relative base +-- pointer, and memory. +-- +-- * Interact with registers using: 'jmp', 'addRelBase' +-- * Interact with memory using: ('!'), 'set' +-- * Build new machines with: 'new' +-- +-- Updates to memory are stored separately from the initial values +-- which can enable equality comparisons to be relatively efficient. +-- This efficiency comes from being able to compare the inital memory +-- using only pointer equality when two machines are created by the +-- same call to 'new'. +data Machine = Machine + { pc :: !Int -- ^ program counter + , relBase :: !Int -- ^ relative base pointer + , memUpdates :: !(IntMap Int) -- ^ memory updates + , memInitial :: {-# 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 + | i < P.sizeofPrimArray a, 0 <= i = P.indexPrimArray a i + | otherwise = 0 + where + a = memInitial m +{-# INLINE indexImage #-} + +-- | Memory lookup. +(!) :: + Machine {- ^ machine -} -> + Int {- ^ position -} -> + Int {- ^ value -} +m ! i = IntMap.findWithDefault (indexImage m i) i (memUpdates m) +{-# INLINE (!) #-} + +-- | 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 initialValues = Machine + { pc = 0 + , relBase = 0 + , memUpdates = IntMap.empty + , memInitial = P.primArrayFromList initialValues + } + +-- | Store value at given memory position. +set :: + Int {- ^ position -} -> + Int {- ^ value -} -> + Machine -> Machine +set i v m + | v == o = m { memUpdates = IntMap.delete i (memUpdates m) } + | otherwise = m { memUpdates = IntMap.insert i v (memUpdates m) } + where + o = indexImage m i + +-- | Add offset to relative base pointer. +addRelBase :: + Int {- ^ offset -} -> + Machine -> Machine +addRelBase i mach = mach { relBase = relBase mach + i } +{-# INLINE addRelBase #-} + +-- | Set program counter to a new address. +jmp :: + Int {- ^ program counter -} -> + Machine -> Machine +jmp i mach = mach { pc = i } +{-# INLINE jmp #-} + +-- | 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] {- ^ memory values -} +memoryList mach + | IntMap.null (memUpdates mach) = P.primArrayToList (memInitial mach) + | otherwise = [mach ! i | i <- [0 .. top]] + where + top = max (P.sizeofPrimArray (memInitial mach) - 1) + (fst (IntMap.findMax (memUpdates mach))) diff --git a/src/Intcode/Opcode.hs b/src/Intcode/Opcode.hs new file mode 100644 --- /dev/null +++ b/src/Intcode/Opcode.hs @@ -0,0 +1,109 @@ +{-# Language DeriveTraversable, Safe #-} +{-| +Module : Intcode.Opcode +Description : Intcode opcodes +Copyright : (c) Eric Mertens, 2019 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a representation of the intcode machine's opcodes. + +Opcodes are parameterized over their parameters. This allows the +implementation to store both parameter modes and resolved parameter +pointers in the same constructors. + +-} +module Intcode.Opcode + ( + -- * Types + Opcode(..), Mode(..), + + -- * Decoder + decode, + ) where + +------------------------------------------------------------------------ +-- 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) +{-# INLINABLE decode #-} + +-- | 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 diff --git a/src/Intcode/Parse.hs b/src/Intcode/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Intcode/Parse.hs @@ -0,0 +1,42 @@ +{-# Language Safe #-} +{-| +Module : Intcode.Parse +Description : Intcode source file parser +Copyright : (c) Eric Mertens, 2019 +License : ISC +Maintainer : emertens@gmail.com + +This module implements a parser for the simple comma, separated format +used in the Advent of Code input files. + +-} +module Intcode.Parse (parseInts) where + +-- | Parse a list of comma separated integers. +-- +-- >>> parseInts "1, - 2, 3,-4" +-- Just [1,-2,3,-4] +-- +-- >>> parseInts " " +-- Just [] +-- +-- >>> parseInts "1,2,3,x" +-- Nothing +parseInts :: + String {- ^ parser input -} -> + Maybe [Int] {- ^ parsed integers -} +parseInts str + | [(i,str1)] <- reads str = parseInts' [i] str1 + | [("","")] <- lex str = Just [] + | otherwise = Nothing + +-- | Helper function for 'parseInts' +parseInts' :: + [Int] {- ^ reversed accumulator -} -> + String {- ^ parser input -} -> + Maybe [Int] {- ^ parsed integers -} +parseInts' xs str = + case lex str of + [(",",str1)] | [(x,str2)] <- reads str1 -> parseInts' (x:xs) str2 + [("","")] -> Just (reverse xs) + _ -> Nothing