advent15/src/advent15.hs

   1 import Debug.Trace
   2
   3 import Intcode
   4
   5 import qualified Data.Text.IO as TIO
   6
   7 import qualified Data.Map.Strict as M
   8 import Data.Map.Strict ((!))
   9 import Data.List
  10 import qualified Data.Set as S
  11
  12 type Position = (Integer, Integer) -- x, y
  13 type Boundary = [Position]
  14 data Direction = North | East | South | West deriving (Show, Eq, Ord)
  15 data ReturnValue = Static | Moved | Goal deriving (Show, Eq, Ord)
  16
  17 data Droid = Droid
  18     { _machine :: Machine
  19     , _executionState :: ExecutionState
  20     , _currentInput :: [Integer]
  21     , _machineOutput :: [Integer]
  22     } deriving (Eq)
  23
  24 instance Show Droid where
  25   show d = "Droid {<m>, _executionState = " ++ show (_executionState d) ++
  26            ", _currentInput = " ++ show (_currentInput d) ++
  27            ", _machineOutput = " ++ show (_machineOutput d) ++
  28            " }"
  29
  30 data Cell = Empty { _droid :: Droid
  31                   , _fromStart :: Integer
  32                   , _isGoal :: Bool
  33                   }
  34                   | Wall
  35                   | Unknown
  36                   deriving (Show, Eq)
  37 type Hull = M.Map Position Cell
  38
  39
  40 main :: IO ()
  41 main = do
  42         text <- TIO.readFile "data/advent15.txt"
  43         let mem = parseMachineMemory text
  44         -- print mem
  45         print $ part1 mem
  46         print $ part2 mem
  47
  48 part1 mem = _fromStart $ snd $ M.findMin $ M.filter (containsGoal) hull
  49     where hull = searchHull $ initialHullBoundary mem
  50
  51
  52 part2 mem = fillTime hull S.empty [(start, 0)] 0
  53     where hull = completeHull $ initialHullBoundary mem
  54           start = fst $ M.findMin $ M.filter (containsGoal) hull
  55
  56
  57 step :: Position -> Direction -> Position
  58 step (x, y) North = (x, y + 1)
  59 step (x, y) East  = (x + 1, y)
  60 step (x, y) South = (x, y - 1)
  61 step (x, y) West  = (x - 1, y)
  62
  63 commandOf :: Direction -> Integer
  64 commandOf North = 1
  65 commandOf South = 2
  66 commandOf West  = 3
  67 commandOf East  = 4
  68
  69 returnValue 0 = Static
  70 returnValue 1 = Moved
  71 returnValue 2 = Goal
  72
  73
  74 buildDroid :: [Integer] -> Droid
  75 buildDroid mem = Droid
  76     { _machine = makeMachine mem
  77     , _executionState = Runnable
  78     , _currentInput = []
  79     , _machineOutput = []
  80     }
  81
  82 initialHullBoundary :: [Integer] -> (Hull, Boundary)
  83 initialHullBoundary mem = (hull, [(0, 0)])
  84     where droid = buildDroid mem
  85           hull = M.singleton (0, 0) (Empty {_droid = droid, _fromStart = 0, _isGoal = False})
  86
  87
  88 searchHull :: (Hull, Boundary) -> Hull
  89 searchHull hullBoundary = fst $ head $ dropWhile goalNotFound $ iterate searchHullStep hullBoundary
  90
  91
  92 completeHull :: (Hull, Boundary) -> Hull
  93 completeHull hullBoundary = fst $ head $ dropWhile incomplete $ iterate searchHullStep hullBoundary
  94
  95
  96 searchHullStep :: (Hull, Boundary) -> (Hull, Boundary)
  97 -- searchHullStep (hull, _) | trace (showHull hull) False = undefined
  98 searchHullStep (hull, []) = (hull, [])
  99 searchHullStep (hull, (here:boundary)) = foldl' (searchHullDirection here) (hull, boundary) directions
 100     where directions = [North, East, South, West] :: [Direction]
 101
 102 searchHullDirection :: Position -> (Hull, Boundary) -> Direction -> (Hull, Boundary)
 103 searchHullDirection here (hull, boundary) direction
 104     | there `M.member` hull = (hull, boundary)
 105     | found == Static = (M.insert there Wall hull, boundary)
 106     | otherwise = (M.insert there newCell hull, boundary ++ [there])
 107     where there = step here direction
 108           droid = _droid $ hull!here
 109           distance = _fromStart $ hull!here
 110           (droid', found) = runDroid droid direction
 111           newCell = Empty { _droid = droid'
 112                           , _fromStart = distance + 1
 113                           , _isGoal = (found == Goal)
 114                           }
 115
 116 fillTime :: Hull -> (S.Set Position) -> [(Position, Integer)] -> Integer -> Integer
 117 fillTime _ _ [] t = t
 118 fillTime hull closed ((here, t):boundary) maxt
 119     | hull!here == Wall = fillTime hull closed boundary maxt
 120     | S.member here closed = fillTime hull closed boundary maxt
 121     | otherwise = fillTime hull closed' (boundary ++ neighbours) (max maxt t)
 122     where closed' = S.insert here closed
 123           neighbours = map (\d -> (step here d, t + 1)) directions
 124           directions = [North, East, South, West] :: [Direction]
 125
 126 goalNotFound :: (Hull, Boundary) -> Bool
 127 goalNotFound (hull, _boundary) = M.null $ M.filter containsGoal hull
 128
 129 containsGoal :: Cell -> Bool
 130 containsGoal Wall = False
 131 containsGoal c = _isGoal c
 132
 133 incomplete (_, []) = False
 134 incomplete (_, (_:_)) = True
 135
 136
 137 runDroid :: Droid -> Direction -> (Droid, ReturnValue)
 138 runDroid droid direction = (droid', found)
 139     where   ci = _currentInput droid
 140             droid' = runDroidMachine (droid {_currentInput = ci ++ [commandOf direction]})
 141             found = returnValue $ last $ _machineOutput droid'
 142
 143
 144 runDroidMachine :: Droid -> Droid
 145 runDroidMachine d = d { _machine = machine'
 146                       , _executionState = halted
 147                       , _machineOutput = output
 148                       }
 149     where   machine = _machine d
 150             input = _currentInput d
 151             (halted, machine', output) = runMachine input machine
 152
 153
 154 showHull :: Hull -> String
 155 showHull screen = unlines rows
 156     where   minX = minimum $ map fst $ M.keys screen
 157             minY = minimum $ map snd $ M.keys screen
 158             maxX = maximum $ map fst $ M.keys screen
 159             maxY = maximum $ map snd $ M.keys screen
 160             rows = [showHullRow screen minX maxX y | y <- [minY..maxY]]
 161
 162 showHullRow :: Hull -> Integer -> Integer -> Integer -> String
 163 showHullRow screen minX maxX y = [showHullCell screen x y | x <- [minX..maxX]]
 164
 165 showHullCell :: Hull -> Integer -> Integer -> Char
 166 showHullCell screen x y =
 167     case (M.findWithDefault Unknown (x, y) screen) of
 168         Empty _ _ True -> 'O'
 169         Empty _ _ _ -> '.'
 170         Wall -> '\x2588'
 171         Unknown -> ' '