From: Neil Smith Date: Mon, 3 Jan 2022 16:42:27 +0000 (+0000) Subject: Tidying X-Git-Url: https://git.njae.me.uk/?a=commitdiff_plain;h=7a460170e89b445166e009bcb29232812b4b7527;p=advent-of-code-21.git Tidying --- diff --git a/advent-of-code21.cabal b/advent-of-code21.cabal index 6fd1c09..351c77a 100644 --- a/advent-of-code21.cabal +++ b/advent-of-code21.cabal @@ -221,3 +221,13 @@ executable advent23 import: common-extensions, build-directives main-is: advent23/Main.hs build-depends: containers, linear, pqueue, mtl, lens + +executable advent23prof + import: common-extensions, build-directives + main-is: advent23/Main.hs + build-depends: containers, linear, pqueue, mtl, lens + ghc-options: -O2 + -Wall + -threaded + -rtsopts "-with-rtsopts=-N -p -s -hT" + \ No newline at end of file diff --git a/advent23/Main.hs b/advent23/Main.hs index 2666769..0d3955f 100644 --- a/advent23/Main.hs +++ b/advent23/Main.hs @@ -1,23 +1,19 @@ --- Writeup at https://work.njae.me.uk/2021/12/16/advent-of-code-2021-day-15/ - -import Debug.Trace +-- Writeup at https://work.njae.me.uk/2022/01/03/advent-of-code-2021-day-23/ +-- import Debug.Trace import qualified Data.PQueue.Prio.Min as P import qualified Data.Set as S import qualified Data.Sequence as Q -import Data.Sequence ((<|), (|>), (><)) --, ViewR( (:>) ), ViewL( (:<) )) +-- import Data.Sequence ((<|), (|>), (><)) --, ViewR( (:>) ), ViewL( (:<) )) +import Data.Sequence ((|>)) import qualified Data.Map.Strict as M import Data.Map.Strict ((!)) -import Data.Foldable (foldl', sum) -- (toList, foldr', foldl', all) --- import Data.Char +import Data.Foldable (foldl') -- , sum, toList, foldr', foldl', all) import Control.Monad.Reader import Control.Lens hiding ((<|), (|>), (:>), (:<)) -import Data.Maybe -- (fromMaybe) --- import Linear (V2(..), (^+^)) --, (^-^), (*^), (^*)) -import Linear hiding (trace) - - +import Data.Maybe +import Linear hiding (trace, distance) pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) @@ -26,6 +22,12 @@ pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) data Amphipod = A | B | C | D deriving (Show, Read, Eq, Ord, Enum) +singleStepCost :: Amphipod -> Int +singleStepCost A = 1 +singleStepCost B = 10 +singleStepCost C = 100 +singleStepCost D = 1000 + type Coord = V2 Int -- r, c _r :: Lens' (V2 Int) Int _r = _x @@ -73,7 +75,6 @@ type Agenda = P.MinPQueue Int Agendum type ExploredStates = S.Set MoveState - main :: IO () main = do text <- readFile "data/advent23.txt" @@ -84,12 +85,13 @@ main = print $ part2 text --- part1 :: Burrow -> MoveState -> Int +part1 :: String -> Int part1 text = maybe 0 _cost result where (burrow, initState) = mkBurrow text result = runReader (searchBurrow initState) burrow +part2 :: String -> Int part2 text = maybe 0 _cost result where rows = lines text @@ -111,17 +113,14 @@ initAgenda initState = return $ P.singleton c Agendum { _current = initState , _trail = Q.empty, _trailCost = 0, _cost = c} - aStar :: Agenda -> ExploredStates -> BurrowContext (Maybe Agendum) aStar agenda closed - -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined - -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMin agenda) ) False = undefined | P.null agenda = return Nothing | otherwise = do let (_, currentAgendum) = P.findMin agenda let reached = currentAgendum ^. current nexts <- candidates currentAgendum closed - let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts + let newAgenda = foldl' (\q a -> P.insert (a ^. cost) a q) (P.deleteMin agenda) nexts reachedGoal <- isGoal reached if reachedGoal then return (Just currentAgendum) @@ -129,22 +128,18 @@ aStar agenda closed then aStar (P.deleteMin agenda) closed else aStar newAgenda (S.insert reached closed) - candidates :: Agendum -> ExploredStates -> BurrowContext (Q.Seq Agendum) candidates agendum closed = - do let candidate = agendum ^. current - let previous = agendum ^. trail + do let previous = agendum ^. trail let prevCost = agendum ^. trailCost - succs <- successors candidate + succs <- successors (agendum ^. current) let nonloops = S.filter (\s -> (s ^. afterMove) `S.notMember` closed) succs let nonloopsQ = Q.fromList $ S.toList nonloops mapM (makeAgendum previous prevCost) nonloopsQ - makeAgendum :: Q.Seq MoveState -> Int -> AppliedMove -> BurrowContext Agendum makeAgendum previous prevCost newPosition = do predicted <- estimateCost (newPosition ^. afterMove) - -- grid <- asks _grid let newTrail = previous |> (newPosition ^. afterMove) let newPositionCost = stepCost newPosition let incurred = prevCost + newPositionCost @@ -154,36 +149,26 @@ makeAgendum previous prevCost newPosition = , _cost = incurred + predicted } --- class (Eq s, Ord s, Show s) => SearchState s where --- emptySearchState :: MoveState --- successors :: MoveState -> BurrowContext (Q.Seq MoveState) --- estimateCost :: MoveState -> BurrowContext Int --- isGoal :: MoveState -> BurrowContext Bool --- entryCost :: MoveState -> BurrowContext Int - - --- instance SearchState Position where - --- emptySearchState = Position (V2 0 0) - successors :: MoveState -> BurrowContext (S.Set AppliedMove) successors moveState = - do steps <- asks _possibleSteps + do steps <- asks (^. possibleSteps) let succs = M.foldrWithKey' (legalSteps steps moveState) S.empty moveState return succs legalSteps :: Steps -> MoveState -> Coord -> Amphipod -> S.Set AppliedMove -> S.Set AppliedMove legalSteps steps state here amphipod acc = S.union appliedSteps acc where allSteps = steps ! here - freeSteps = S.filter freeSpaces allSteps - freeSpaces st = S.null $ S.intersection (M.keysSet state) (st ^. transits) - validTargetSteps = S.filter (\st -> fromMaybe amphipod (st ^. entryRequirement) == amphipod) freeSteps - openRoomSteps = S.filter (openRoom state) validTargetSteps + occupiedSpaces = M.keysSet state + freeSpaces st = S.null $ S.intersection occupiedSpaces (st ^. transits) + freeSteps = {-# SCC freeSteps #-} S.filter freeSpaces allSteps + validTargetSteps = {-# SCC validTargetSteps #-} S.filter (\st -> fromMaybe amphipod (st ^. entryRequirement) == amphipod) freeSteps + openRoomSteps = {-# SCC openRoomSteps #-} S.filter (openRoom state) validTargetSteps + highestRowSteps = {-# SCC highestRowSteps #-} S.filter (highestRow (S.map (^. destination) openRoomSteps)) openRoomSteps appliedSteps = S.map (\s -> AppliedMove { _afterMove = (applyStep state here s) , _appliedStep = s } - ) openRoomSteps + ) highestRowSteps openRoom :: MoveState -> Step -> Bool openRoom state step @@ -194,21 +179,19 @@ openRoom state step tc = step ^. destination . _c roomBlockers = M.filterWithKey (\(V2 _ ac) a -> a /= je && ac == tc) state +highestRow :: S.Set Coord -> Step -> Bool +highestRow others step = higherRow `S.notMember` others + where higherRow = (step ^. destination) & _r +~ 1 + applyStep :: MoveState -> Coord -> Step -> MoveState applyStep moveState here step = moveState'' where moveState' = M.delete here moveState moveState'' = M.insert (step ^. destination) (moveState ! here) moveState' -singleStepCost :: Amphipod -> Int -singleStepCost A = 1 -singleStepCost B = 10 -singleStepCost C = 100 -singleStepCost D = 1000 - estimateCost :: MoveState -> BurrowContext Int estimateCost state = - do rCols <- asks _roomColumns - hRow <- asks _hallRow + do rCols <- asks (^. roomColumns) + hRow <- asks (^. hallRow) let amphipodCosts = M.mapWithKey (estimateACost rCols hRow) state return $ sum $ M.elems amphipodCosts @@ -220,25 +203,23 @@ estimateACost rCols hRow (V2 r c) amphipod = (singleStepCost amphipod) * dist else (r - hRow) + (abs (c - targetCol)) + 1 stepCost :: AppliedMove -> Int -stepCost aStep = (singleStepCost amphipod) * (S.size $ aStep ^. appliedStep . transits) +stepCost aStep = (singleStepCost amphipod) * (aStep ^. appliedStep . distance) where dest = aStep ^. appliedStep . destination amphipod = (aStep ^. afterMove) ! dest isGoal :: MoveState -> BurrowContext Bool isGoal state = - do rCols <- asks _roomColumns + do rCols <- asks (^. roomColumns) let misplaced = M.filterWithKey (inWrongRoom rCols) state return $ M.null misplaced +inWrongRoom :: M.Map Amphipod Int -> Coord -> Amphipod -> Bool inWrongRoom rCols (V2 _ c) amphipod = c /= rightCol where rightCol = rCols ! amphipod - ------------------------------ - mkBurrow :: String -> (Burrow, MoveState) --- mkBurrow :: String -> ((S.Set Coord, M.Map Coord Amphipod), MoveState) mkBurrow text = (burrow, initState) -- (burrow, initState) where rows = lines text hall = mkHall (rows!!1) @@ -250,7 +231,6 @@ mkBurrow text = (burrow, initState) -- (burrow, initState) burrow = Burrow { _possibleSteps = routes, _roomColumns = roomColMap, _hallRow = 1} initState = mkInitialState rows - mkHall :: String -> S.Set Coord mkHall text = S.fromList hallCoords where hallCols = filter ((/= '#') . snd) $ zip [0..] text @@ -265,14 +245,12 @@ mkRoom (r, text) = M.fromList roomCoords where roomCols = filter ((`elem` ("ABCD." :: String)) . snd) $ zip [0..] text roomCoords = zip (map ((V2 r) . fst) roomCols) [A .. D] --- invertRooms rooms = M.fromList [(a, M.keysSet $ M.filter (== a) rooms) | a <- [A .. D]] - mkRoutes :: S.Set Coord -> M.Map Coord Amphipod -> Steps mkRoutes halls rooms = M.unionsWith (S.union) [hallRoutes, roomHallRoutes, roomRoomRoutes] where hallRoutes = S.foldr' (mkHallRoute rooms) M.empty halls roomHallRoutes = S.foldr' (mkRoomHallRoute halls) M.empty (M.keysSet rooms) roomRoomRoutes = S.foldr' (mkRoomRoomRoute hallRow rooms) M.empty (M.keysSet rooms) - hallRow = (S.findMin halls) ^. _r + hallRow = S.findMin $ S.map (^. _r) halls mkHallRoute :: M.Map Coord Amphipod -> Coord -> Steps -> Steps -- mkHallRoute rooms here routes | trace ("mkHR " ++ (show here) ++ " " ++ (show routes)) False = undefined @@ -281,8 +259,6 @@ mkHallRoute rooms here routes = M.foldrWithKey' (mkHallRoute1 here) routes rooms mkHallRoute1 :: Coord -> Coord -> Amphipod -> Steps -> Steps -- mkHallRoute1 here there entry routes | trace ("mkHR1 " ++ (show here) ++ " " ++ (show there) ++ (show routes)) False = undefined mkHallRoute1 here@(V2 hr hc) there@(V2 tr tc) entry routes = M.insert here (S.insert step existingRoutes) routes - -- | trace ("mkHR1 " ++ (show here) ++ " " ++ (show there) ++ (show routes) ++ " > " ++ show res) False = undefined - -- | otherwise = res where step = Step { _destination = there , _distance = (S.size transits) , _transits = transits @@ -292,7 +268,6 @@ mkHallRoute1 here@(V2 hr hc) there@(V2 tr tc) entry routes = M.insert here (S.in cMax = max hc tc transits = S.delete here $ S.fromList $ [V2 hr c | c <- [cMin..cMax]] ++ [V2 r tc | r <- [hr..tr]] existingRoutes = M.findWithDefault S.empty here routes - -- res = M.insert here (S.insert step existingRoutes) routes mkRoomHallRoute :: S.Set Coord -> Coord -> Steps -> Steps mkRoomHallRoute halls here routes = S.foldr' (mkRoomHallRoute1 here) routes halls @@ -315,7 +290,7 @@ mkRoomRoomRoute hallRow rooms here routes = M.foldrWithKey' (mkRoomRoomRoute1 h mkRoomRoomRoute1 :: Int -> Coord -> Coord -> Amphipod -> Steps -> Steps -- mkRoomRoomRoute1 _hallRow here there entry routes | trace ("mkRR1 " ++ (show here) ++ " " ++ (show there) ++ (show routes)) False = undefined mkRoomRoomRoute1 hallRow here@(V2 hr hc) there@(V2 tr tc) entry routes - | here == there = routes + | hc == tc = routes | otherwise = M.insert here (S.insert step existingRoutes) routes where step = Step { _destination = there , _distance = (S.size transits) @@ -340,4 +315,3 @@ mkInitialState rows = where maxR = length rows - 1 maxC = (length $ head rows) - 1 isAmphipod c = c `elem` ("ABCD" :: String) -