From b6a05b364559d0cce2befcd52091a88ff3dfb42b Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Fri, 20 Dec 2019 08:25:14 +0000 Subject: [PATCH] Tidying. --- advent15/package.yaml | 10 ++ advent15/src/advent15.hs | 26 ++--- advent15/src/advent15optics.hs | 180 +++++++++++++++++++++++++++++++++ 3 files changed, 203 insertions(+), 13 deletions(-) create mode 100644 advent15/src/advent15optics.hs diff --git a/advent15/package.yaml b/advent15/package.yaml index dd5494a..a6c48c2 100644 --- a/advent15/package.yaml +++ b/advent15/package.yaml @@ -58,3 +58,13 @@ executables: - text - containers - intcode + + advent15optics: + main: advent15optics.hs + source-dirs: src + dependencies: + - base >= 2 && < 6 + - text + - containers + - intcode + - lens diff --git a/advent15/src/advent15.hs b/advent15/src/advent15.hs index 4aaee02..4038d07 100644 --- a/advent15/src/advent15.hs +++ b/advent15/src/advent15.hs @@ -46,7 +46,7 @@ main = do print $ part2 mem part1 mem = _fromStart $ snd $ M.findMin $ M.filter (containsGoal) hull - where hull = fst $ head $ searchHull $ initialHullBoundary mem + where hull = searchHull $ initialHullBoundary mem part2 mem = fillTime hull S.empty [(start, 0)] 0 @@ -85,24 +85,14 @@ initialHullBoundary mem = (hull, [(0, 0)]) hull = M.singleton (0, 0) (Empty {_droid = droid, _fromStart = 0, _isGoal = False}) -searchHull :: (Hull, Boundary) -> [(Hull, Boundary)] -searchHull hullBoundary = dropWhile goalNotFound $ iterate searchHullStep hullBoundary +searchHull :: (Hull, Boundary) -> Hull +searchHull hullBoundary = fst $ head $ dropWhile goalNotFound $ iterate searchHullStep hullBoundary completeHull :: (Hull, Boundary) -> Hull completeHull hullBoundary = fst $ head $ dropWhile incomplete $ iterate searchHullStep hullBoundary -fillTime _ _ [] t = t -fillTime hull closed ((here, t):boundary) maxt - | hull!here == Wall = fillTime hull closed boundary maxt - | S.member here closed = fillTime hull closed boundary maxt - | otherwise = fillTime hull closed' (boundary ++ neighbours) (max maxt t) - where closed' = S.insert here closed - neighbours = map (\d -> (step here d, t + 1)) directions - directions = [North, East, South, West] :: [Direction] - - searchHullStep :: (Hull, Boundary) -> (Hull, Boundary) -- searchHullStep (hull, _) | trace (showHull hull) False = undefined searchHullStep (hull, []) = (hull, []) @@ -123,6 +113,16 @@ searchHullDirection here (hull, boundary) direction , _isGoal = (found == Goal) } +fillTime :: Hull -> (S.Set Position) -> [(Position, Integer)] -> Integer -> Integer +fillTime _ _ [] t = t +fillTime hull closed ((here, t):boundary) maxt + | hull!here == Wall = fillTime hull closed boundary maxt + | S.member here closed = fillTime hull closed boundary maxt + | otherwise = fillTime hull closed' (boundary ++ neighbours) (max maxt t) + where closed' = S.insert here closed + neighbours = map (\d -> (step here d, t + 1)) directions + directions = [North, East, South, West] :: [Direction] + goalNotFound :: (Hull, Boundary) -> Bool goalNotFound (hull, _boundary) = M.null $ M.filter containsGoal hull diff --git a/advent15/src/advent15optics.hs b/advent15/src/advent15optics.hs new file mode 100644 index 0000000..b1b8d10 --- /dev/null +++ b/advent15/src/advent15optics.hs @@ -0,0 +1,180 @@ +import Debug.Trace + +import Intcode + +import qualified Data.Text.IO as TIO + +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Data.List +import qualified Data.Set as S +import Control.Lens +import Data.Map.Lens +import Data.Maybe + +type Position = (Integer, Integer) -- x, y +type Boundary = [Position] +data Direction = North | East | South | West deriving (Show, Eq, Ord) +data ReturnValue = Static | Moved | Goal deriving (Show, Eq, Ord) + +data Droid = Droid + { _machine :: Machine + , _executionState :: ExecutionState + , _currentInput :: [Integer] + , _machineOutput :: [Integer] + } deriving (Eq) +makeLenses ''Droid + +instance Show Droid where + show d = "Droid {, _executionState = " ++ show (_executionState d) ++ + ", _currentInput = " ++ show (_currentInput d) ++ + ", _machineOutput = " ++ show (_machineOutput d) ++ + " }" + +data Cell = Vacant { _droid :: Droid + , _fromStart :: Integer + , _isGoal :: Bool + } + | Wall + | Unknown + deriving (Show, Eq) +makeLenses ''Cell +makePrisms ''Cell + +type Hull = M.Map Position Cell + + +main :: IO () +main = do + text <- TIO.readFile "data/advent15.txt" + let mem = parseMachineMemory text + -- print mem + print $ part1 mem + print $ part2 mem + +part1 mem = _fromStart $ snd $ M.findMin $ M.filter (containsGoal) hull + where hull = fst $ head $ searchHull $ initialHullBoundary mem + + +part2 mem = fillTime hull S.empty [(start, 0)] 0 + where hull = completeHull $ initialHullBoundary mem + start = fst $ M.findMin $ M.filter (containsGoal) hull + + +step :: Position -> Direction -> Position +step (x, y) North = (x, y + 1) +step (x, y) East = (x + 1, y) +step (x, y) South = (x, y - 1) +step (x, y) West = (x - 1, y) + +commandOf :: Direction -> Integer +commandOf North = 1 +commandOf South = 2 +commandOf West = 3 +commandOf East = 4 + +returnValue 0 = Static +returnValue 1 = Moved +returnValue 2 = Goal + + +buildDroid :: [Integer] -> Droid +buildDroid mem = Droid + { _machine = makeMachine mem + , _executionState = Runnable + , _currentInput = [] + , _machineOutput = [] + } + +initialHullBoundary :: [Integer] -> (Hull, Boundary) +initialHullBoundary mem = (hull, [(0, 0)]) + where robot = buildDroid mem + hull = M.singleton (0, 0) (Vacant {_droid = robot, _fromStart = 0, _isGoal = False}) + + +searchHull :: (Hull, Boundary) -> [(Hull, Boundary)] +searchHull hullBoundary = dropWhile goalNotFound $ iterate searchHullStep hullBoundary + + +completeHull :: (Hull, Boundary) -> Hull +completeHull hullBoundary = fst $ head $ dropWhile incomplete $ iterate searchHullStep hullBoundary + + +searchHullStep :: (Hull, Boundary) -> (Hull, Boundary) +-- searchHullStep (hull, _) | trace (showHull hull) False = undefined +searchHullStep (hull, []) = (hull, []) +searchHullStep (hull, (here:boundary)) = foldl' (searchHullDirection here) (hull, boundary) directions + where directions = [North, East, South, West] :: [Direction] + +searchHullDirection :: Position -> (Hull, Boundary) -> Direction -> (Hull, Boundary) +searchHullDirection here (hull, boundary) direction + | there `M.member` hull = (hull, boundary) + | found == Static = (M.insert there Wall hull, boundary) + | otherwise = (M.insert there newCell hull, boundary ++ [there]) + where there = step here direction + robot = _droid $ hull!here + -- robot = hull ^.(at here) . _Just . droid + -- robot = view ((at here) . droid) hull + distance = _fromStart $ hull!here + (robot', found) = runDroid robot direction + newCell = Vacant { _droid = robot' + , _fromStart = distance + 1 + , _isGoal = (found == Goal) + } + +fillTime :: Hull -> (S.Set Position) -> [(Position, Integer)] -> Integer -> Integer +fillTime _ _ [] t = t +fillTime hull closed ((here, t):boundary) maxt + | hull!here == Wall = fillTime hull closed boundary maxt + | S.member here closed = fillTime hull closed boundary maxt + | otherwise = fillTime hull closed' (boundary ++ neighbours) (max maxt t) + where closed' = S.insert here closed + neighbours = map (\d -> (step here d, t + 1)) directions + directions = [North, East, South, West] :: [Direction] + +goalNotFound :: (Hull, Boundary) -> Bool +goalNotFound (hull, _boundary) = M.null $ M.filter containsGoal hull + +containsGoal :: Cell -> Bool +containsGoal Wall = False +containsGoal c = _isGoal c + +incomplete (_, []) = False +incomplete (_, (_:_)) = True + + +runDroid :: Droid -> Direction -> (Droid, ReturnValue) +runDroid robot direction = (robot', found) + where ci = _currentInput robot + robot' = runDroidMachine (robot {_currentInput = ci ++ [commandOf direction]}) + found = returnValue $ last $ _machineOutput robot' + + +runDroidMachine :: Droid -> Droid +runDroidMachine d = d { _machine = machine' + , _executionState = halted + , _machineOutput = output + } + where machine = _machine d + input = _currentInput d + (halted, machine', output) = runMachine input machine + + +showHull :: Hull -> String +showHull screen = unlines rows + where minX = minimum $ map fst $ M.keys screen + minY = minimum $ map snd $ M.keys screen + maxX = maximum $ map fst $ M.keys screen + maxY = maximum $ map snd $ M.keys screen + rows = [showHullRow screen minX maxX y | y <- [minY..maxY]] + +showHullRow :: Hull -> Integer -> Integer -> Integer -> String +showHullRow screen minX maxX y = [showHullCell screen x y | x <- [minX..maxX]] + +showHullCell :: Hull -> Integer -> Integer -> Char +showHullCell screen x y = + case (M.findWithDefault Unknown (x, y) screen) of + Vacant _ _ True -> 'O' + Vacant _ _ _ -> '.' + Wall -> '\x2588' + Unknown -> ' ' -- 2.34.1