Day 7

3 files changed, 93 insertions, 28 deletions

diff --git a/2019/7.hs b/2019/7.hs
new file mode 100644
index 0000000..d5910f1
--- /dev/null
+++ b/2019/7.hs
@@ -0,0 +1,41 @@
+module Main where
+
+import Data.Either
+import Data.List
+
+import Input
+import IntCode
+
+
+part1 :: [Int] -> Int
+part1 program =
+    let settings = permutations [0..4]
+        outcome setting = foldr (.) id [\i -> head (snd (run program [p,i])) | p <- setting] 0
+    in maximum (map outcome settings)
+
+part2 :: [Int] -> Int
+part2 program =
+    let settings = permutations [5..9]
+        outcome setting =
+            let initConts = [let Left (cont, _) = runInterruptible program [p] in cont
+                            | p <- setting]
+                generation conts firstInp =
+                    let (output, results) = foldProduce (\inp cont ->
+                                                            let res = runContinue cont [inp]
+                                                            in (res, head (either snd snd res)))
+                                                        firstInp conts
+                    in case last results of
+                           Right (_, _) -> output
+                           Left (_, _) -> generation (map (fst . fromLeft undefined) results) output
+            in generation initConts 0
+    in maximum (map outcome settings)
+
+foldProduce :: (s -> a -> (b, s)) -> s -> [a] -> (s, [b])
+foldProduce _ s [] = (s, [])
+foldProduce f s (x:xs) = let (y, s') = f s x in fmap (y :) (foldProduce f s' xs)
+
+main :: IO ()
+main = do
+    program <- parse . head <$> getInput 7
+    print (part1 program)
+    print (part2 program)
diff --git a/2019/7.in b/2019/7.in
new file mode 100644
index 0000000..88e90bf
--- /dev/null
+++ b/2019/7.in
@@ -0,0 +1 @@
+3,8,1001,8,10,8,105,1,0,0,21,42,51,76,93,110,191,272,353,434,99999,3,9,1002,9,2,9,1001,9,3,9,1002,9,3,9,1001,9,2,9,4,9,99,3,9,1002,9,3,9,4,9,99,3,9,1002,9,4,9,101,5,9,9,1002,9,3,9,1001,9,4,9,1002,9,5,9,4,9,99,3,9,1002,9,5,9,101,3,9,9,102,5,9,9,4,9,99,3,9,1002,9,5,9,101,5,9,9,1002,9,2,9,4,9,99,3,9,1002,9,2,9,4,9,3,9,1002,9,2,9,4,9,3,9,101,2,9,9,4,9,3,9,1001,9,2,9,4,9,3,9,1001,9,1,9,4,9,3,9,101,1,9,9,4,9,3,9,1001,9,1,9,4,9,3,9,102,2,9,9,4,9,3,9,1001,9,2,9,4,9,3,9,101,1,9,9,4,9,99,3,9,1001,9,1,9,4,9,3,9,1001,9,2,9,4,9,3,9,101,2,9,9,4,9,3,9,102,2,9,9,4,9,3,9,1001,9,1,9,4,9,3,9,1002,9,2,9,4,9,3,9,1001,9,2,9,4,9,3,9,102,2,9,9,4,9,3,9,101,1,9,9,4,9,3,9,1002,9,2,9,4,9,99,3,9,1002,9,2,9,4,9,3,9,1002,9,2,9,4,9,3,9,101,2,9,9,4,9,3,9,101,1,9,9,4,9,3,9,101,2,9,9,4,9,3,9,1002,9,2,9,4,9,3,9,102,2,9,9,4,9,3,9,1002,9,2,9,4,9,3,9,1002,9,2,9,4,9,3,9,1002,9,2,9,4,9,99,3,9,1002,9,2,9,4,9,3,9,102,2,9,9,4,9,3,9,1001,9,2,9,4,9,3,9,1002,9,2,9,4,9,3,9,1001,9,1,9,4,9,3,9,1002,9,2,9,4,9,3,9,1001,9,1,9,4,9,3,9,1001,9,1,9,4,9,3,9,102,2,9,9,4,9,3,9,1001,9,1,9,4,9,99,3,9,1002,9,2,9,4,9,3,9,102,2,9,9,4,9,3,9,102,2,9,9,4,9,3,9,1001,9,2,9,4,9,3,9,102,2,9,9,4,9,3,9,1002,9,2,9,4,9,3,9,1001,9,1,9,4,9,3,9,101,2,9,9,4,9,3,9,101,1,9,9,4,9,3,9,102,2,9,9,4,9,99
diff --git a/2019/IntCode.hs b/2019/IntCode.hs
index 9e94066..699a40c 100644
--- a/2019/IntCode.hs
+++ b/2019/IntCode.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
 module IntCode (
     Arg(..), IC(..),
-    parse, decode, run, unparse
+    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
 
@@ -97,31 +99,52 @@ insArg 1 n = Imm n
 insArg m n = error $ "IC: Unknown parameter mode " ++ show m ++ " for parameter " ++ show n
 
 run :: [Int] -> [Int] -> ([Int], [Int])
-run initMem input = runST $ do
-     arr <- SA.newListArray (0, length initMem - 1) initMem
-     out <- run' arr 0 input
-     mem <- SA.getElems arr
-     return (mem, out)
+run initMem input =
+    case runInterruptible initMem input of
+        Left _ -> error "IC: Not enough input"
+        Right res -> res
+
+data Continuation = Continuation (A.Array Int Int) Int
+
+runInterruptible :: [Int] -> [Int] -> Either (Continuation, [Int]) ([Int], [Int])
+runInterruptible initMem input = runST $ do
+    arr <- SA.newListArray (0, length initMem - 1) initMem
+    res <- runArray arr 0 input
+    case fst res of
+        Left cont -> return (Left (cont, snd res))
+        Right mem -> return (Right (mem, snd res))
+
+runContinue :: Continuation -> [Int] -> Either (Continuation, [Int]) ([Int], [Int])
+runContinue (Continuation frozen ptr) moreinput = runST $ do
+    arr <- SA.thaw frozen
+    res <- runArray arr ptr moreinput
+    case fst res of
+        Left cont -> return (Left (cont, snd res))
+        Right mem -> return (Right (mem, snd res))
+
+runArray :: SA.STUArray s Int Int -> Int -> [Int] -> ST s (Either Continuation [Int], [Int])
+runArray arr ptr inp = do
+    (ic, len) <- decode' arr ptr
+    let continueInp inp' = runArray arr (ptr + len) inp'
+        continue = continueInp inp
+        jump ptr' = runArray arr ptr' inp
+    case ic of
+        Add a b (Addr c) -> (+) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
+        Mul a b (Addr c) -> (*) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
+        Inp (Addr a) -> case inp of
+                     val : rest -> SA.writeArray arr a val >> continueInp rest
+                     [] -> do
+                         frozen <- SA.freeze arr
+                         return (Left (Continuation frozen ptr), [])
+        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 (Addr c) -> ((fromEnum .) . (<)) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
+        Ceq a b (Addr c) -> ((fromEnum .) . (==)) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
+        Hlt -> do
+            mem <- SA.getElems arr
+            return (Right mem, [])
+        ins -> error $ "IC: Invalid instruction " ++ show ins
   where
-    run' :: SA.STUArray s Int Int -> Int -> [Int] -> ST s [Int]
-    run' arr ptr inp = do
-        (ic, len) <- decode' arr ptr
-        let continueInp inp' = run' arr (ptr + len) inp'
-            continue = continueInp inp
-            jump ptr' = run' arr ptr' inp
-        case ic of
-            Add a b (Addr c) -> (+) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
-            Mul a b (Addr c) -> (*) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
-            Inp (Addr a) -> case inp of
-                         val : rest -> SA.writeArray arr a val >> continueInp rest
-                         _ -> error "IC: Not enough input"
-            Out a -> resolve a >>= \val -> (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 (Addr c) -> ((fromEnum .) . (<)) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
-            Ceq a b (Addr c) -> ((fromEnum .) . (==)) <$> resolve a <*> resolve b >>= SA.writeArray arr c >> continue
-            Hlt -> return []
-            ins -> error $ "IC: Invalid instruction " ++ show ins
-      where
-        resolve (Imm n) = return n
-        resolve (Addr n) = SA.readArray arr n
+    resolve (Imm n) = return n
+    resolve (Addr n) = SA.readArray arr n