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