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 = fromJust $ preview (at here . _Just . isGoal) hull
 117           -- robot = fromJust $ hull ^? at here . _Just . droid
 118           robot = fromJust $ hull ^? ix here . droid
 119           -- distance = _fromStart $ hull!here
 120           distance = fromJust $ hull ^? ix here . fromStart
 121           (robot', found) = runDroid robot direction
 122           -- newCell = Vacant { _droid = robot'
 123           --                 , _fromStart = distance + 1
 124           --                 , _isGoal = (found == Goal)
 125           --                 }
 126           newCell = _Vacant # (robot', distance + 1, found == Goal)
 127
 128 fillTime :: Hull -> (S.Set Position) -> [(Position, Integer)] -> Integer -> Integer
 129 fillTime _ _ [] t = t
 130 fillTime hull closed ((here, t):boundary) maxt
 131     | hull!here == Wall = fillTime hull closed boundary maxt
 132     | S.member here closed = fillTime hull closed boundary maxt
 133     | otherwise = fillTime hull closed' (boundary ++ neighbours) (max maxt t)
 134     where closed' = S.insert here closed
 135           neighbours = map (\d -> (step here d, t + 1)) directions
 136           directions = [North, East, South, West] :: [Direction]
 137
 138 goalNotFound :: (Hull, Boundary) -> Bool
 139 goalNotFound (hull, _boundary) = M.null $ M.filter containsGoal hull
 140
 141 containsGoal :: Cell -> Bool
 142 -- containsGoal Wall = False
 143 -- containsGoal c = _isGoal c
 144 containsGoal c = fromMaybe False $ c ^? isGoal
 145
 146
 147 incomplete (_, []) = False
 148 incomplete (_, (_:_)) = True
 149
 150
 151 runDroid :: Droid -> Direction -> (Droid, ReturnValue)
 152 runDroid robot direction = (robot', found)
 153     where   ci = _currentInput robot
 154             robot' = runDroidMachine (robot {_currentInput = ci ++ [commandOf direction]})
 155             found = returnValue $ last $ _machineOutput robot'
 156
 157
 158 runDroidMachine :: Droid -> Droid
 159 -- runDroidMachine d = d { _machine = machine'
 160 --                       , _executionState = halted
 161 --                       , _machineOutput = output
 162 --                       }
 163     -- where   machine = _machine d
 164     --         input = _currentInput d
 165     --         (halted, machine', output) = runMachine input machine
 166 runDroidMachine d = d & machine .~ machine'
 167                       & executionState .~ halted
 168                       & machineOutput .~ output
 169     where (halted, machine', output) = runMachine (d ^. currentInput) (d ^. machine)
 170
 171
 172 showHull :: Hull -> String
 173 showHull screen = unlines rows
 174     where   minX = minimum $ map fst $ M.keys screen
 175             minY = minimum $ map snd $ M.keys screen
 176             maxX = maximum $ map fst $ M.keys screen
 177             maxY = maximum $ map snd $ M.keys screen
 178             rows = [showHullRow screen minX maxX y | y <- [minY..maxY]]
 179
 180 showHullRow :: Hull -> Integer -> Integer -> Integer -> String
 181 showHullRow screen minX maxX y = [showHullCell screen x y | x <- [minX..maxX]]
 182
 183 showHullCell :: Hull -> Integer -> Integer -> Char
 184 showHullCell screen x y =
 185     case (M.findWithDefault Unknown (x, y) screen) of
 186         Vacant _ _ True -> 'O'
 187         Vacant _ _ _ -> '.'
 188         Wall -> '\x2588'
 189         Unknown -> ' '