--- 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.<|)
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
type ExploredStates = S.Set MoveState
-
main :: IO ()
main =
do text <- readFile "data/advent23.txt"
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
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)
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
, _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
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
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)
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
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
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
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
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)
where maxR = length rows - 1
maxC = (length $ head rows) - 1
isAmphipod c = c `elem` ("ABCD" :: String)
-
projects / advent-of-code-21.git / commitdiff