summaryrefslogtreecommitdiff
path: root/2019/IntCode.hs
blob: 2096bccb08616d6fbdfe608c725565c88550f7d8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
module IntCode (
    Arg(..), IC(..), mkAddr, mkImm, mkRel,
    parse, decode, run, unparse,
    runInterruptible, runContinue, Continuation()
) where

import Control.Monad.ST
import qualified Data.Array as A
import qualified Data.Array.ST as SA
import qualified Data.Array.IArray as IA


data Arg = Addr Integer | Imm Integer | Rel Integer
  deriving (Show)

mkAddr, mkImm, mkRel :: Integral i => i -> Arg
mkAddr = Addr . fromIntegral
mkImm = Imm . fromIntegral
mkRel = Rel . fromIntegral

data IC
    = Add Arg Arg Arg
    | Mul Arg Arg Arg
    | Inp Arg
    | Out Arg
    | Jnz Arg Arg
    | Jez Arg Arg
    | Clt Arg Arg Arg
    | Ceq Arg Arg Arg
    | Adj Arg
    | Hlt
  deriving (Show)

parse :: String -> [Integer]
parse = map read . splitOn ','
  where
    splitOn c s = case break (== c) s of
                      (pre, _ : post) -> pre : splitOn c post
                      _ -> [s]

unparse :: IC -> [Integer]
unparse ic = case ic of
                 Add a b c -> go 1 [a,b,c]
                 Mul a b c -> go 2 [a,b,c]
                 Inp a     -> go 3 [a    ]
                 Out a     -> go 4 [a    ]
                 Jnz a b   -> go 5 [a,b  ]
                 Jez a b   -> go 6 [a,b  ]
                 Clt a b c -> go 7 [a,b,c]
                 Ceq a b c -> go 8 [a,b,c]
                 Adj a     -> go 9 [a    ]
                 Hlt       -> [99]
  where
    go code as = (100 * mode as + code) : map bare as
      where bare (Addr n) = n
            bare (Imm n) = n
            bare (Rel n) = n
    mode [] = 0
    mode (Addr _ : as) = 0 + 10 * mode as
    mode (Imm _ : as)  = 1 + 10 * mode as
    mode (Rel _ : as)  = 2 + 10 * mode as

decode :: [Integer] -> (IC, Int)
decode [] = error "IC: Execution fell off end of program"
decode (ins : rest) =
    let (code, modes) = insModeSplit ins
    in (decodeBase code modes rest, 1 + insNArgs code)

class Monad m => ReadArray m a i e where
    readArray :: a -> i -> m e

instance IA.Ix i => ReadArray (ST s) (SA.STArray s i Integer) i Integer where
    readArray = SA.readArray

decode' :: ReadArray m a Int Integer => a -> Int -> m (IC, Int)
decode' arr ptr = do
    ins <- readArray arr ptr
    let (code, modes) = insModeSplit ins
        nargs = insNArgs code
    params <- sequence [readArray arr (ptr + i) | i <- [1..nargs]]
    return (decodeBase code modes params, 1 + nargs)

insModeSplit :: Integer -> (Integer, [Integer])
insModeSplit n = (n `mod` 100, map (`mod` 10) (iterate (`div` 10) (n `div` 100)))

insNArgs :: Integer -> Int
insNArgs n = case n of { 1 -> 3; 2 -> 3; 3 -> 1; 4 -> 1;
                         5 -> 2; 6 -> 2; 7 -> 3; 8 -> 3;
                         9 -> 1;
                         99 -> 0;
                         _ -> error $ "IC: Unknown instruction " ++ show n }

decodeBase :: Integer -> [Integer] -> [Integer] -> IC
decodeBase  1 (am:bm:cm:_) (a:b:c:_) = Add (insArg am a) (insArg bm b) (insArg cm c)
decodeBase  2 (am:bm:cm:_) (a:b:c:_) = Mul (insArg am a) (insArg bm b) (insArg cm c)
decodeBase  3 (am:      _) (a:    _) = Inp (insArg am a)
decodeBase  4 (am:      _) (a:    _) = Out (insArg am a)
decodeBase  5 (am:bm:   _) (a:b:  _) = Jnz (insArg am a) (insArg bm b)
decodeBase  6 (am:bm:   _) (a:b:  _) = Jez (insArg am a) (insArg bm b)
decodeBase  7 (am:bm:cm:_) (a:b:c:_) = Clt (insArg am a) (insArg bm b) (insArg cm c)
decodeBase  8 (am:bm:cm:_) (a:b:c:_) = Ceq (insArg am a) (insArg bm b) (insArg cm c)
decodeBase  9 (am:      _) (a:    _) = Adj (insArg am a)
decodeBase 99 (         _) (      _) = Hlt
decodeBase ic _            _         = error $ "IC: Unknown instruction " ++ show ic

insArg :: Integer -> Integer -> Arg
insArg 0 n = Addr n
insArg 1 n = Imm n
insArg 2 n = Rel n
insArg m n = error $ "IC: Unknown parameter mode " ++ show m ++ " for parameter " ++ show n

run :: [Integer] -> [Integer] -> ([Integer], [Integer])
run initMem input =
    case runInterruptible initMem input of
        Left _ -> error "IC: Not enough input"
        Right res -> res

data Continuation = Continuation (A.Array Int Integer) Int Int

runInterruptible :: [Integer] -> [Integer] -> Either (Continuation, [Integer]) ([Integer], [Integer])
runInterruptible initMem input = runST $ do
    arr <- SA.newListArray (0, length initMem - 1) initMem
    res <- runArray arr 0 input 0
    case fst res of
        Left cont -> return (Left (cont, snd res))
        Right mem -> return (Right (mem, snd res))

runContinue :: Continuation -> [Integer] -> Either (Continuation, [Integer]) ([Integer], [Integer])
runContinue (Continuation frozen ptr offset) moreinput = runST $ do
    arr <- SA.thaw frozen
    res <- runArray arr ptr moreinput offset
    case fst res of
        Left cont -> return (Left (cont, snd res))
        Right mem -> return (Right (mem, snd res))

runArray :: SA.STArray s Int Integer -> Int -> [Integer] -> Int -> ST s (Either Continuation [Integer], [Integer])
runArray arr ptr inp offset = do
    (ic, len) <- decode' arr ptr
    let continue         = runArray arr  (ptr + len)         inp  offset
        continueArr arr' = runArray arr' (ptr + len)         inp  offset
        jump        ptr' = runArray arr  (fromIntegral ptr') inp  offset
        continueOff off' = runArray arr  (ptr + len)         inp  (fromIntegral off')
        continueInpArr inp' arr' = runArray arr' (ptr + len) inp' offset
        resize arr1 idx = do
            (_, right) <- SA.getBounds arr1
            if idx < right
                then return arr1
                else SA.getElems arr1 >>= \els -> SA.newListArray (0, 2 * idx) (els ++ replicate (idx - right + 1) 0)
        performWrite arr1 idx value = do
            arr' <- resize arr1 (fromIntegral idx)
            SA.writeArray arr' (fromIntegral idx) value
            return arr'
    case ic of
        Add a b c -> (+) <$> resolve a <*> resolve b >>= performWrite arr (resolveAddr c) >>= continueArr
        Mul a b c -> (*) <$> resolve a <*> resolve b >>= performWrite arr (resolveAddr c) >>= continueArr
        Inp a -> case inp of
                     val : rest -> performWrite arr (resolveAddr a) val >>= continueInpArr rest
                     [] -> do
                         frozen <- SA.freeze arr
                         return (Left (Continuation frozen ptr offset), [])
        Out a -> resolve a >>= \val -> fmap (val :) <$> continue
        Jnz a b -> resolve a >>= \val -> if val /= 0 then resolve b >>= jump else continue
        Jez a b -> resolve a >>= \val -> if val == 0 then resolve b >>= jump else continue
        Clt a b c -> (((fromIntegral . fromEnum) .) . (<)) <$> resolve a <*> resolve b >>= performWrite arr (resolveAddr c) >>= continueArr
        Ceq a b c -> (((fromIntegral . fromEnum) .) . (==)) <$> resolve a <*> resolve b >>= performWrite arr (resolveAddr c) >>= continueArr
        Adj a -> resolve a >>= \add -> continueOff (fromIntegral offset + add)
        Hlt -> do
            mem <- SA.getElems arr
            return (Right mem, [])
  where
    resolve (Addr n) = do
        (_, right) <- SA.getBounds arr
        let n' = fromIntegral n
        if n' >= right then return 0 else SA.readArray arr n'
    resolve (Imm n) = return n
    resolve (Rel n) = resolve (Addr (fromIntegral offset + n))
    resolveAddr (Addr n) = n
    resolveAddr (Rel n) = fromIntegral offset + n
    resolveAddr (Imm _) = error "IC: Using immediate value as address operand"