Day 15

3 files changed, 103 insertions, 1 deletions

diff --git a/2019/15.hs b/2019/15.hs
new file mode 100644
index 0000000..42def07
--- /dev/null
+++ b/2019/15.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Data.List
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Maybe
+
+import Input
+import IntCode
+
+
+sortUniqBy :: Ord b => (a -> b) -> [a] -> [a]
+sortUniqBy f = uniq . sortOn f
+  where uniq (x:y:zs) | f x == f y = uniq (y:zs)
+                      | otherwise = x : uniq (y:zs)
+        uniq l = l
+
+data Cell = Open | Wall | Unit deriving (Show, Eq)
+type Pos = (Int, Int)
+
+step :: Pos -> Int -> Pos
+step (x, y) dir = case dir of
+                      1 -> (x, y - 1)
+                      2 -> (x, y + 1)
+                      3 -> (x - 1, y)
+                      4 -> (x + 1, y)
+                      _ -> error "Invalid direction in 'step'"
+
+showMap :: Map.Map Pos Cell -> Pos -> String
+showMap mp droid =
+    let keys = Map.keys mp
+        (minx, maxx) = (minimum (map fst keys), maximum (map fst keys))
+        (miny, maxy) = (minimum (map snd keys), maximum (map snd keys))
+    in unlines [[if (x, y) `elem` [droid, (0, 0)]
+                     then if (x, y) == (0, 0) then 'S' else 'D'
+                     else case Map.lookup (x, y) mp of
+                              Nothing -> ' '
+                              Just Open -> '.'
+                              Just Wall -> '#'
+                              Just Unit -> '@'
+                | x <- [minx..maxx]]
+               | y <- [miny..maxy]]
+
+performStep :: Continuation -> Pos -> Map.Map Pos Cell -> Int -> (Continuation, Pos, Map.Map Pos Cell)
+performStep cont pos mp dir =
+    let (cont', output) = case runContinue cont [fromIntegral dir] of
+                              Left (c, out) -> (c, out)
+                              Right (_, out) -> (undefined, out)
+    in case output of
+           [0] -> (cont', pos         , Map.insert (step pos dir) Wall mp)
+           [1] -> (cont', step pos dir, Map.insert (step pos dir) Open mp)
+           [2] -> (cont', step pos dir, Map.insert (step pos dir) Unit mp)
+           _   -> error $ "Invalid output " ++ show output ++ " in performStep"
+
+shortestPath :: Map.Map Pos Cell -> Pos -> Maybe Cell -> Either Int [Int]
+shortestPath mp initPos target = reverse <$> search 0 (Set.singleton initPos) [(initPos, [])]
+  where
+    search :: Int -> Set.Set Pos -> [(Pos, [Int])] -> Either Int [Int]
+    search !depth _ [] = Left (depth - 1)
+    search !depth seen border =
+        let boundary =
+                sortUniqBy (fst . fst)
+                    [((newPos, dir : path), mcell)
+                    | (pos, path) <- border
+                    , dir <- [1..4]
+                    , let newPos = step pos dir
+                    , newPos `Set.notMember` seen
+                    , let mcell = Map.lookup newPos mp
+                    , mcell /= Just Wall]
+            newBorder = map fst boundary
+        in case find ((== target) . snd) boundary of
+               Just ((_, newPath), _) -> Right newPath
+               Nothing -> search (depth + 1) (seen <> Set.fromList (map fst newBorder)) newBorder
+
+determineMap :: Continuation -> Pos -> Map.Map Pos Cell -> Map.Map Pos Cell
+determineMap cont pos mp =
+    case shortestPath mp pos Nothing of
+        Right path ->
+            let (cont', pos', mp') =
+                    foldl (\(c, p, m) dir -> performStep c p m dir) (cont, pos, mp) path
+            in determineMap cont' pos' mp'
+        Left _ ->
+            mp
+
+main :: IO ()
+main = do
+    program <- parse . head <$> getInput 15
+    let initCont = initialContinuation program
+
+    let mp = determineMap initCont (0, 0) (Map.singleton (0, 0) Open)
+    let Right path = shortestPath mp (0, 0) (Just Unit)
+    print (length path)
+
+    let unitpos = fst (fromJust (find ((== Unit) . snd) (Map.assocs mp)))
+
+    let Left maxdist = shortestPath mp unitpos Nothing
+    print maxdist
diff --git a/2019/15.in b/2019/15.in
new file mode 100644
index 0000000..50b3240
--- /dev/null
+++ b/2019/15.in
@@ -0,0 +1 @@
+3,1033,1008,1033,1,1032,1005,1032,31,1008,1033,2,1032,1005,1032,58,1008,1033,3,1032,1005,1032,81,1008,1033,4,1032,1005,1032,104,99,102,1,1034,1039,1002,1036,1,1041,1001,1035,-1,1040,1008,1038,0,1043,102,-1,1043,1032,1,1037,1032,1042,1105,1,124,102,1,1034,1039,1002,1036,1,1041,1001,1035,1,1040,1008,1038,0,1043,1,1037,1038,1042,1106,0,124,1001,1034,-1,1039,1008,1036,0,1041,1002,1035,1,1040,101,0,1038,1043,1002,1037,1,1042,1105,1,124,1001,1034,1,1039,1008,1036,0,1041,1001,1035,0,1040,1001,1038,0,1043,1001,1037,0,1042,1006,1039,217,1006,1040,217,1008,1039,40,1032,1005,1032,217,1008,1040,40,1032,1005,1032,217,1008,1039,1,1032,1006,1032,165,1008,1040,5,1032,1006,1032,165,1101,2,0,1044,1106,0,224,2,1041,1043,1032,1006,1032,179,1102,1,1,1044,1106,0,224,1,1041,1043,1032,1006,1032,217,1,1042,1043,1032,1001,1032,-1,1032,1002,1032,39,1032,1,1032,1039,1032,101,-1,1032,1032,101,252,1032,211,1007,0,72,1044,1105,1,224,1101,0,0,1044,1105,1,224,1006,1044,247,1001,1039,0,1034,101,0,1040,1035,1001,1041,0,1036,1001,1043,0,1038,1001,1042,0,1037,4,1044,1106,0,0,50,46,95,30,15,91,60,70,74,3,22,60,94,68,47,99,65,61,23,17,82,21,80,87,27,62,53,46,89,98,55,64,15,41,82,13,45,78,18,28,87,17,24,22,81,92,30,70,97,22,85,71,32,73,35,93,78,54,85,45,46,75,51,97,73,85,37,87,29,92,85,75,10,21,79,60,85,31,79,73,7,81,4,77,45,17,82,78,37,85,95,83,17,56,52,85,79,78,32,91,79,37,75,51,46,20,21,16,93,87,22,42,74,87,22,84,20,69,35,97,88,76,78,85,26,64,84,80,38,92,58,87,84,98,38,20,75,78,69,80,47,54,78,95,85,90,24,44,84,74,11,1,92,80,58,12,4,97,31,49,73,9,85,55,84,49,93,82,22,47,75,44,55,83,71,21,52,94,24,79,36,88,5,43,61,40,87,83,28,28,84,83,11,43,90,99,41,87,29,76,48,93,91,58,50,29,90,13,23,6,73,97,45,98,83,93,40,85,79,66,89,5,94,50,81,65,42,81,91,97,53,99,50,88,28,54,33,79,36,31,95,70,89,87,57,94,80,97,82,68,79,38,94,2,88,8,88,45,1,98,28,91,64,85,97,34,95,47,90,70,86,13,38,68,93,74,57,73,89,31,81,34,48,80,92,39,7,83,2,77,54,77,68,86,20,64,86,32,81,6,73,37,59,82,47,86,19,86,45,92,82,56,57,94,54,9,9,76,14,9,85,81,84,42,86,60,68,89,15,75,42,49,93,2,97,83,83,64,87,85,71,73,3,36,94,5,8,25,82,11,86,36,37,93,79,31,92,84,25,90,9,83,68,71,81,28,84,17,88,71,69,87,7,87,56,98,5,66,94,80,83,43,95,92,7,73,90,23,7,11,60,3,89,92,30,95,98,1,94,27,95,68,15,86,42,92,48,8,77,91,52,76,68,41,88,94,83,25,28,75,36,87,56,39,77,68,77,96,44,85,97,14,41,73,97,52,62,99,34,54,78,87,24,92,84,95,64,45,76,11,83,98,32,98,25,76,33,79,11,93,94,46,93,27,46,75,92,43,30,11,52,96,15,8,98,94,47,73,80,54,84,18,92,64,39,92,93,95,77,64,94,28,88,49,73,43,39,82,58,41,87,91,22,32,48,87,39,61,85,74,91,17,92,90,52,78,53,49,28,22,79,51,75,53,89,28,3,81,22,64,19,51,77,34,78,88,36,83,91,40,11,74,75,19,91,27,12,34,93,24,82,90,43,42,94,66,86,85,62,93,12,78,81,57,75,81,63,54,99,97,83,6,94,90,50,66,94,39,83,35,78,76,57,79,45,27,88,53,55,18,97,4,49,89,42,51,74,46,93,87,24,97,58,35,85,89,30,90,4,89,46,91,67,99,91,91,70,24,97,30,48,77,82,46,94,63,90,89,45,82,32,88,25,37,75,85,73,68,9,94,39,68,83,54,22,87,84,42,98,41,87,65,80,54,23,54,17,83,98,17,90,1,96,55,85,63,66,95,78,84,77,73,60,27,94,21,79,90,62,90,85,11,87,83,26,88,61,75,60,47,80,6,36,84,79,99,61,79,12,38,76,17,45,88,83,15,74,66,38,88,23,44,87,77,33,78,56,23,45,52,83,89,71,52,74,17,75,52,80,95,83,28,69,87,57,52,94,80,9,90,63,91,45,85,31,90,47,78,40,74,80,75,11,95,18,97,84,73,63,87,45,74,30,81,16,95,31,93,68,81,9,79,74,94,33,83,66,76,52,80,0,0,21,21,1,10,1,0,0,0,0,0,0
diff --git a/2019/IntCode.hs b/2019/IntCode.hs
index 8d180bf..1730dfd 100644
--- a/2019/IntCode.hs
+++ b/2019/IntCode.hs
@@ -2,7 +2,7 @@
 module IntCode (
     Arg(..), IC(..), mkAddr, mkImm, mkRel,
     parse, decode, run, unparse,
-    runInterruptible, runContinue, Continuation()
+    runInterruptible, runContinue, Continuation(), initialContinuation
 ) where
 
 import Control.Monad.ST
@@ -134,6 +134,9 @@ runContinue (Continuation frozen ptr offset) moreinput = runST $ do
         Left cont -> return (Left (cont, snd res))
         Right mem -> return (Right (mem, snd res))
 
+initialContinuation :: [Integer] -> Continuation
+initialContinuation initMem = Continuation (A.listArray (0, length initMem - 1) initMem) 0 0
+
 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