# Advent of Code - 2021 - 23

## Haskell

```
import qualified Data.PQueue.Prio.Min as P
import qualified Data.Array as A
import qualified Data.IntMap as M
import qualified Data.Set as S
import Data.Maybe (isJust, isNothing)
import Data.Maybe (catMaybes, fromJust)
data Amphipod = A | B | C | D deriving (Eq, Ord, Show)
-- #01x2x3x4x56#
type Hallway = A.Array Int (Maybe Amphipod)
data Room = Z
| F Amphipod
| L Amphipod
| FF Amphipod Amphipod
| LL Amphipod Amphipod
| FFF Amphipod Amphipod Amphipod
| LLL Amphipod Amphipod Amphipod
| FFFF Amphipod Amphipod Amphipod Amphipod
| LLLL Amphipod Amphipod Amphipod Amphipod
deriving (Eq, Ord, Show)
type Rooms = A.Array Int Room
data Burrow = Burrow Hallway Rooms deriving (Ord, Eq, Show)
type RoomId = Int
type HallwayPos = Int
type Cost = Int
A = 1
cost B = 10
cost C = 100
cost D = 1000
cost
= FFFF a b c d
room (a,b,c,d)
= Burrow (A.listArray (0,10) $ repeat Nothing)
burrow a b c d 0,3) $ map room [a,b,c,d])
(A.listArray (
-- I was curious about other peoples so I took a bunch of inputs and
-- measured them
= burrow (D,D,D,B) (C,B,C,B) (A,A,B,C) (A,C,A,D) -- 1m01s
input = burrow (D,D,D,B) (A,B,C,A) (D,A,B,B) (C,C,A,C) -- 35s
input'0 = burrow (C,D,D,D) (C,B,C,B) (A,A,B,D) (B,C,A,A) -- N/A (probably has an error)
input'1 = burrow (A,D,D,B) (D,B,C,C) (C,A,B,B) (A,C,A,D) -- 1m08s
test
Z ) = Just (L e )
pushRoom e (F a ) = Just (LL a e )
pushRoom e (L a ) = Just (LL a e )
pushRoom e (FF a b ) = Just (LLL a b e )
pushRoom e (LL a b ) = Just (LLL a b e )
pushRoom e (FFF a b c) = Just (LLLL a b c e)
pushRoom e (LLL a b c) = Just (LLLL a b c e)
pushRoom e (= Nothing
pushRoom e _
FFFF a b c d) = Just (d, FFF a b c)
popRoom (FFF a b c ) = Just (c, FF a b )
popRoom (FF a b ) = Just (b, F a )
popRoom (F a ) = Just (a, Z )
popRoom (= Nothing
popRoom _
| any isJust c = Nothing
putHallway ri e hi hw | otherwise = Just $ hw A.// [(hi, Just e)]
where b x y = [min x y .. max x y]
= [hw A.! i | i <- b (roomPos ri) hi]
c
| any isJust c = Nothing
takeHallway ri hi hw | Just e <- hw A.! hi = Just (e, hw A.// [(hi, Nothing)])
| otherwise = Nothing
where b x y = [min x y .. max x y]
= [hw A.! i | i <- b (roomPos ri) hi, i /= hi]
c
0 = 2
roomPos 1 = 4
roomPos 2 = 6
roomPos 3 = 8
roomPos
= [2,4,6,8]
roomPositions = [0,1,3,5,7,9,10]
hallwayPositions
= abs $ roomPos ri - hi
distance ri hi
moveToHallway :: RoomId -> HallwayPos -> Burrow -> Maybe (Burrow, Cost)
Burrow hw rms) = do
moveToHallway ri hi (<- popRoom $ rms A.! ri
(e,rm) <- putHallway ri e hi hw
hw let c = (distance ri hi + roomSteps rm) * cost e
pure (Burrow hw (rms A.// [(ri, rm)]), c)
where roomSteps (Z ) = 4
F _ ) = 3
roomSteps (L _ ) = 3
roomSteps (FF _ _ ) = 2
roomSteps (LL _ _ ) = 2
roomSteps (FFF _ _ _) = 1
roomSteps (LLL _ _ _) = 1
roomSteps (
moveToRoom :: HallwayPos -> RoomId -> Burrow -> Maybe (Burrow, Cost)
Burrow hw rms) = do
moveToRoom hi ri (<- takeHallway ri hi hw
(e,hw) <- pushRoom e $ rms A.! ri
rm let c = (distance ri hi + roomSteps rm) * cost e
pure (Burrow hw (rms A.// [(ri, rm)]), c)
where roomSteps (L _ ) = 4
LL _ _ ) = 3
roomSteps (LLL _ _ _ ) = 2
roomSteps (LLLL _ _ _ _) = 1
roomSteps (
Burrow _ rm) = f A 0 && f B 1 && f C 2 && f D 3
solved (where f a r = rm A.! r == LLLL a a a a
Burrow _ rm) = f A 0 || f B 1 || f C 2 || f D 3
unsolvable (where f a r = g a $ rm A.! r
LLLL a b c d) = a /= e || b /= e || c /= e || d /= e
g e (LLL a b c ) = a /= e || b /= e || c /= e
g e (LL a b ) = a /= e || b /= e
g e (L a ) = a /= e
g e (= False
g e _
solve :: Burrow -> Cost
= loop S.empty $ P.singleton 0 b
solve b where
loop :: S.Set Burrow -> P.MinPQueue Cost Burrow -> Cost
| solved b = c
loop s m | otherwise = loop s' m''
where ((c, b), m') = fromJust $ P.minViewWithKey m
= [moveToHallway r h b | r <- [0..3], h <- hallwayPositions]
lh = [moveToRoom h r b | r <- [0..3], h <- hallwayPositions]
lr = h (lr ++ lh)
l = filter (\(b,c) -> S.notMember b s)
h . filter (not . unsolvable . fst)
. catMaybes
= foldr (uncurry P.insert) m' $ map (\(b,c') -> (c + c', b)) l
m'' = S.insert b s
s'
= print $ solve input main
```