Day 23

data/amphipods.txt

+#############
+#...........#
+###C#B#A#D###
+  #C#D#A#B#
+  #########
\ No newline at end of file

data/amphipods2.txt

+#############
+#...........#
+###C#B#A#D###
+  #D#C#B#A#
+  #D#B#A#C#
+  #C#D#A#B#
+  #########
\ No newline at end of file

src/AOC-23a.hs

 module Main where
 
+import Data.List ( partition )
+import qualified Data.Map as M
+import Data.Map (Map,(!))
+import qualified Data.Set as S
+
+{- Spatial map
+
+  #############
+  #ab.c.d.e.fg#
+  ###h#i#j#k###
+    #l#m#n#o#
+    #########
+-}
+
+type Position = (Int,Int)
+data Location
+  = Hall  { pos :: Position }
+  | RoomA { pos :: Position }
+  | RoomB { pos :: Position }
+  | RoomC { pos :: Position  }
+  | RoomD { pos :: Position  }
+  deriving (Eq,Ord,Show)
+
+isHall :: Location -> Bool
+isHall (Hall {}) = True
+isHall _ = False
+
+a,b,c,d,e,f,g,h,i,j,k,l,m,n,o :: Location
+a = Hall  ( 2,2)
+b = Hall  ( 3,2)
+c = Hall  ( 5,2)
+d = Hall  ( 7,2)
+e = Hall  ( 9,2)
+f = Hall  (11,2)
+g = Hall  (12,2)
+h = RoomA ( 4,3)
+i = RoomB ( 6,3)
+j = RoomC ( 8,3)
+k = RoomD (10,3)
+l = RoomA ( 4,4)
+m = RoomB ( 6,4)
+n = RoomC ( 8,4)
+o = RoomD (10,4)
+
+locations :: [Location]
+locations = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]
+
+locMap :: Map Position Location
+locMap = M.fromList [ (pos loc, loc) | loc <- locations]
+
+basis :: [(Location,Location,Int)]
+basis =
+  [ (a,b,1) 
+  , (b,c,2)
+  , (b,h,2)
+  , (c,d,2)
+  , (c,h,2)
+  , (c,i,2)
+  , (d,e,2)
+  , (d,j,2)
+  , (d,i,2)
+  , (e,f,2)
+  , (e,j,2)
+  , (e,k,2)
+  , (f,g,1)
+  , (f,k,2)
+  , (h,l,1)
+  , (i,m,1)
+  , (j,n,1)
+  , (k,o,1)
+  ]
+
+edgeMap :: Map Location [(Location,Int)]
+edgeMap = M.unionsWith (++) . map simpleMap $ (basis ++ map twist basis) where
+  twist (x,y,z) = (y,x,z)
+  simpleMap (x,y,z) = M.singleton x [(y,z)]
+
+data Amphipod
+  = Amber
+  | Bronze
+  | Copper
+  | Desert
+  deriving (Eq,Ord,Show)
+
+toAmphipod :: Char -> Maybe Amphipod
+toAmphipod 'A' = Just Amber
+toAmphipod 'B' = Just Bronze
+toAmphipod 'C' = Just Copper
+toAmphipod 'D' = Just Desert
+toAmphipod '.' = Nothing
+toAmphipod ch = error $ "toAmphipod -- unexpected character " ++ [ch]
+
+amphAbbrev :: Amphipod -> Char
+amphAbbrev Amber  = 'A'
+amphAbbrev Bronze = 'B'
+amphAbbrev Copper = 'C'
+amphAbbrev Desert = 'D'
+
+amphWeight :: Amphipod -> Int
+amphWeight Amber  = 1
+amphWeight Bronze = 10
+amphWeight Copper = 100
+amphWeight Desert = 1000
+
+type GameMap = Map Location (Maybe Amphipod)
+
+readGameMap :: String -> GameMap
+readGameMap s = M.fromList locAssocs where
+ locAssocs = [ (loc,toAmphipod char)
+              | (rx,row) <- zip [1..] (lines s)
+              , (cx,char) <- zip [1..] row
+              , (cx,rx) `M.member` locMap
+              , let loc = locMap ! (cx,rx)
+              ] 
+
+showGameMap :: GameMap -> String
+showGameMap gm = unlines [ [value x y | x <- [1..13]] | y <- [1..5]] where
+  posMap = M.fromList $ spaces ++ [ (pos loc,amph) | (loc,amph) <- M.assocs gm]
+  spaces = [ ((col,2),Nothing) | col <- [4,6,8,10]]
+  excluded = [(x,y) | x <- [1,2,12,13], y <- [4..5]]
+  value x y
+    | (x,y) `elem` excluded = ' '
+    | otherwise = case posMap M.!? (x,y) of
+        Nothing -> '#'
+        Just Nothing -> '.'
+        Just (Just amph) -> amphAbbrev amph
+
+bfs :: GameMap -> Location -> [(Location,Int)]
+bfs gm start = iter [] [(start,0)] where
+  iter :: [Location] -> [(Location,Int)] -> [(Location,Int)]
+  iter _ [] = []
+  iter visited frontier = nfrontier ++ iter (nvisited ++ visited) nfrontier where
+    nfrontier =
+      [ (nloc,cost + ncost)
+      | (loc,cost) <- frontier
+      , (nloc,ncost) <- edgeMap ! loc
+      , nloc `notElem` visited
+      , gm ! nloc == Nothing
+      ]
+    nvisited = map fst nfrontier
+
+type Move = (Location,Location,Amphipod,Int) -- src, dest, amph, base cost
+
+moves :: GameMap -> [Move]
+moves gm = select  . filter (not . goalStart) .  filter isValid $  concatMap searchFrom starts where
+  starts = [ (loc,amph) | (loc,Just amph) <- M.assocs gm ]
+  searchFrom (start,amph) =
+    [ (start,end,amph,amphWeight amph * cost)
+    | (end,cost) <- bfs gm start
+    ]
+  isValid (source,dest,amph,_) = hallMove || roomMove where
+    hallMove = not (isHall source) && isHall dest
+    roomMove = isHall source && atGoal amph dest
+  goalStart (source,_,amph,_) = atGoal amph source
+  atGoal amph loc = case (amph,loc) of 
+    (Amber, RoomA ( 4,y)) -> all (== Just Amber ) [gm ! (RoomA ( 4,y'))  | y' <- [y+1..4]]
+    (Bronze,RoomB ( 6,y)) -> all (== Just Bronze) [gm ! (RoomB ( 6,y'))  | y' <- [y+1..4]]
+    (Copper,RoomC ( 8,y)) -> all (== Just Copper) [gm ! (RoomC ( 8,y'))  | y' <- [y+1..4]]
+    (Desert,RoomD (10,y)) -> all (== Just Desert) [gm ! (RoomD (10,y'))  | y' <- [y+1..4]]
+    _ -> False
+  select ms = case partition (\(loc,_,_,_) -> isHall loc) ms of
+    ([],rs) -> rs
+    (hs,_) -> hs
+
+apply :: GameMap -> Move -> GameMap
+apply gm (start,finish,amph,_) = M.insert finish (Just amph) . M.insert start Nothing $ gm
+
+neighborf :: GameMap -> [(GameMap,Int)]
+neighborf gm = [ (apply gm mv, cost) | mv@(_,_,_,cost) <- moves gm ]
+
+goalf :: GameMap -> Bool
+goalf gm = gm == goalMap 
+
+goalMap :: GameMap
+goalMap = M.fromList [ (a,Nothing), (b,Nothing), (c,Nothing), (d,Nothing), (e,Nothing), (f,Nothing), (g,Nothing)
+                      , (h,Just  Amber), (l,Just  Amber)
+                      , (i,Just Bronze), (m,Just Bronze)
+                      , (j,Just Copper), (n,Just Copper)
+                      , (k,Just Desert), (o,Just Desert)
+                      ]
+
+showMove :: Move -> String
+showMove (l1,l2,amph,cost) = 
+  unwords[show amph,"@",showLoc l1,"->",showLoc l2,"at cost", show cost] where
+  showLoc loc = unwords [showType loc, show $ pos loc]
+  showType (Hall  {}) = "Hall"
+  showType (RoomA {}) = "RoomA"
+  showType (RoomB {}) = "RoomB"
+  showType (RoomC {}) = "RoomC"
+  showType (RoomD {}) = "RoomD"
+
+dijkstra :: (Ord a, Show a, Num n, Ord n) => a -> (a -> [(a,n)]) -> (a -> Bool) -> (n,[a])
+dijkstra start neighbors goal = iter initDist S.empty initQueue where
+  initDist = M.singleton start (0,[start])
+  initQueue = S.singleton (0,start,[start])
+  iter distMap visited queue = case S.minView queue of
+    Nothing -> error $ "dijkstra -- goal not found"
+    Just ((cost,node,path),queue')
+      | goal node-> (cost,reverse path)
+      | node `S.member` visited -> iter distMap visited queue'
+      | otherwise ->
+          let npaths = [ (cost + ncost, neighbor, neighbor : path)
+                       | (neighbor,ncost) <- neighbors node
+                       ]
+              ndists = M.fromList [ (node',(cost',path')) | (cost',node',path') <- npaths ]
+              distMap' = M.unionWith min distMap ndists
+              visited' = S.insert node visited
+              queue'' = S.union queue' (S.fromList npaths)
+          in iter distMap' visited' queue''
+
 main :: IO ()
-main = pure ()
+main = do
+  gameMap <- readGameMap <$> readFile "data/amphipods.txt"
+  let result = dijkstra gameMap neighborf goalf
+  putStrLn . show . fst $ result
\ No newline at end of file

src/AOC-23b.hs

+
 module Main where
 
+import Data.List ( partition )
+import qualified Data.Map as M
+import Data.Map (Map,(!))
+import qualified Data.Set as S
+
+{- Spatial map
+
+  #############
+  #ab.c.d.e.fg#
+  ###h#i#j#k###
+    #l#m#n#o#
+    #p#q#r#s#
+    #t#u#v#w#
+    #########
+-}
+
+type Position = (Int,Int)
+data Location
+  = Hall  { pos :: Position }
+  | RoomA { pos :: Position }
+  | RoomB { pos :: Position }
+  | RoomC { pos :: Position  }
+  | RoomD { pos :: Position  }
+  deriving (Eq,Ord,Show)
+
+isHall :: Location -> Bool
+isHall (Hall {}) = True
+isHall _ = False
+
+a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w:: Location
+a = Hall  ( 2,2)
+b = Hall  ( 3,2)
+c = Hall  ( 5,2)
+d = Hall  ( 7,2)
+e = Hall  ( 9,2)
+f = Hall  (11,2)
+g = Hall  (12,2)
+h = RoomA ( 4,3)
+i = RoomB ( 6,3)
+j = RoomC ( 8,3)
+k = RoomD (10,3)
+l = RoomA ( 4,4)
+m = RoomB ( 6,4)
+n = RoomC ( 8,4)
+o = RoomD (10,4)
+p = RoomA ( 4,5)
+q = RoomB ( 6,5)
+r = RoomC ( 8,5)
+s = RoomD (10,5)
+t = RoomA ( 4,6)
+u = RoomB ( 6,6)
+v = RoomC ( 8,6)
+w = RoomD (10,6)
+
+locations :: [Location]
+locations = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w]
+
+locMap :: Map Position Location
+locMap = M.fromList [ (pos loc, loc) | loc <- locations]
+
+basis :: [(Location,Location,Int)]
+basis =
+  [ (a,b,1) 
+  , (b,c,2)
+  , (b,h,2)
+  , (c,d,2)
+  , (c,h,2)
+  , (c,i,2)
+  , (d,e,2)
+  , (d,j,2)
+  , (d,i,2)
+  , (e,f,2)
+  , (e,j,2)
+  , (e,k,2)
+  , (f,g,1)
+  , (f,k,2)
+  , (h,l,1)
+  , (i,m,1)
+  , (j,n,1)
+  , (k,o,1)
+  , (l,p,1)
+  , (m,q,1)
+  , (n,r,1)
+  , (o,s,1)
+  , (p,t,1)
+  , (q,u,1)
+  , (r,v,1)
+  , (s,w,1)
+  ]
+
+edgeMap :: Map Location [(Location,Int)]
+edgeMap = M.unionsWith (++) . map simpleMap $ (basis ++ map twist basis) where
+  twist (x,y,z) = (y,x,z)
+  simpleMap (x,y,z) = M.singleton x [(y,z)]
+
+data Amphipod
+  = Amber
+  | Bronze
+  | Copper
+  | Desert
+  deriving (Eq,Ord,Show)
+
+toAmphipod :: Char -> Maybe Amphipod
+toAmphipod 'A' = Just Amber
+toAmphipod 'B' = Just Bronze
+toAmphipod 'C' = Just Copper
+toAmphipod 'D' = Just Desert
+toAmphipod '.' = Nothing
+toAmphipod ch = error $ "toAmphipod -- unexpected character " ++ [ch]
+
+amphAbbrev :: Amphipod -> Char
+amphAbbrev Amber  = 'A'
+amphAbbrev Bronze = 'B'
+amphAbbrev Copper = 'C'
+amphAbbrev Desert = 'D'
+
+amphWeight :: Amphipod -> Int
+amphWeight Amber  = 1
+amphWeight Bronze = 10
+amphWeight Copper = 100
+amphWeight Desert = 1000
+
+type GameMap = Map Location (Maybe Amphipod)
+
+readGameMap :: String -> GameMap
+readGameMap str = M.fromList locAssocs where
+ locAssocs = [ (loc,toAmphipod char)
+              | (rx,row) <- zip [1..] (lines str)
+              , (cx,char) <- zip [1..] row
+              , (cx,rx) `M.member` locMap
+              , let loc = locMap ! (cx,rx)
+              ] 
+
+showGameMap :: GameMap -> String
+showGameMap gm = unlines [ [value x y | x <- [1..13]] | y <- [1..7]] where
+  posMap = M.fromList $ spaces ++ [ (pos loc,amph) | (loc,amph) <- M.assocs gm]
+  spaces = [ ((col,2),Nothing) | col <- [4,6,8,10]]
+  excluded = [(x,y) | x <- [1,2,12,13], y <- [4..7]]
+  value x y
+    | (x,y) `elem` excluded = ' '
+    | otherwise = case posMap M.!? (x,y) of
+        Nothing -> '#'
+        Just Nothing -> '.'
+        Just (Just amph) -> amphAbbrev amph
+
+bfs :: GameMap -> Location -> [(Location,Int)]
+bfs gm start = iter [] [(start,0)] where
+  iter :: [Location] -> [(Location,Int)] -> [(Location,Int)]
+  iter _ [] = []
+  iter visited frontier = nfrontier ++ iter (nvisited ++ visited) nfrontier where
+    nfrontier =
+      [ (nloc,cost + ncost)
+      | (loc,cost) <- frontier
+      , (nloc,ncost) <- edgeMap ! loc
+      , nloc `notElem` visited
+      , gm ! nloc == Nothing
+      ]
+    nvisited = map fst nfrontier
+
+type Move = (Location,Location,Amphipod,Int) -- src, dest, amph, base cost
+
+moves :: GameMap -> [Move]
+moves gm = select  . filter (not . goalStart) .  filter isValid $  concatMap searchFrom starts where
+  starts = [ (loc,amph) | (loc,Just amph) <- M.assocs gm ]
+  searchFrom (start,amph) =
+    [ (start,end,amph,amphWeight amph * cost)
+    | (end,cost) <- bfs gm start
+    ]
+  isValid (source,dest,amph,_) = hallMove || roomMove where
+    hallMove = not (isHall source) && isHall dest
+    roomMove = isHall source && atGoal amph dest
+  goalStart (source,_,amph,_) = atGoal amph source
+  atGoal amph loc = case (amph,loc) of 
+    (Amber, RoomA ( 4,y)) -> all (== Just Amber ) [gm ! (RoomA ( 4,y'))  | y' <- [y+1..6]]
+    (Bronze,RoomB ( 6,y)) -> all (== Just Bronze) [gm ! (RoomB ( 6,y'))  | y' <- [y+1..6]]
+    (Copper,RoomC ( 8,y)) -> all (== Just Copper) [gm ! (RoomC ( 8,y'))  | y' <- [y+1..6]]
+    (Desert,RoomD (10,y)) -> all (== Just Desert) [gm ! (RoomD (10,y'))  | y' <- [y+1..6]]
+    _ -> False
+  select ms = case partition (\(loc,_,_,_) -> isHall loc) ms of
+    ([],rs) -> rs
+    (hs,_) -> hs
+
+apply :: GameMap -> Move -> GameMap
+apply gm (start,finish,amph,_) = M.insert finish (Just amph) . M.insert start Nothing $ gm
+
+neighborf :: GameMap -> [(GameMap,Int)]
+neighborf gm = [ (apply gm mv, cost) | mv@(_,_,_,cost) <- moves gm ]
+
+goalf :: GameMap -> Bool
+goalf gm = gm == goalMap 
+
+goalMap :: GameMap
+goalMap = M.fromList [ (a,Nothing), (b,Nothing), (c,Nothing), (d,Nothing), (e,Nothing), (f,Nothing), (g,Nothing)
+                     , (h,Just  Amber), (l,Just  Amber), (p, Just  Amber), (t, Just  Amber)
+                     , (i,Just Bronze), (m,Just Bronze), (q, Just Bronze), (u, Just Bronze)
+                     , (j,Just Copper), (n,Just Copper), (r, Just Copper), (v, Just Copper)
+                     , (k,Just Desert), (o,Just Desert), (s, Just Desert), (w, Just Desert)
+                     ]
+
+showMove :: Move -> String
+showMove (l1,l2,amph,cost) = 
+  unwords[show amph,"@",showLoc l1,"->",showLoc l2,"at cost", show cost] where
+  showLoc loc = unwords [showType loc, show $ pos loc]
+  showType (Hall  {}) = "Hall"
+  showType (RoomA {}) = "RoomA"
+  showType (RoomB {}) = "RoomB"
+  showType (RoomC {}) = "RoomC"
+  showType (RoomD {}) = "RoomD"
+
+dijkstra :: (Ord a, Show a, Num n, Ord n) => a -> (a -> [(a,n)]) -> (a -> Bool) -> (n,[a])
+dijkstra start neighbors goal = iter initDist S.empty initQueue where
+  initDist = M.singleton start (0,[start])
+  initQueue = S.singleton (0,start,[start])
+  iter distMap visited queue = case S.minView queue of
+    Nothing -> error $ "dijkstra -- goal not found"
+    Just ((cost,node,path),queue')
+      | goal node-> (cost,reverse path)
+      | node `S.member` visited -> iter distMap visited queue'
+      | otherwise ->
+          let npaths = [ (cost + ncost, neighbor, neighbor : path)
+                       | (neighbor,ncost) <- neighbors node
+                       ]
+              ndists = M.fromList [ (node',(cost',path')) | (cost',node',path') <- npaths ]
+              distMap' = M.unionWith min distMap ndists
+              visited' = S.insert node visited
+              queue'' = S.union queue' (S.fromList npaths)
+          in iter distMap' visited' queue''
+
 main :: IO ()
-main = pure ()
+main = do
+  gameMap <- readGameMap <$> readFile "data/amphipods2.txt"
+  let result = dijkstra gameMap neighborf goalf
+  putStrLn . show . fst $ result
\ No newline at end of file

test/amphipods.txt

+#############
+#...........#
+###B#C#B#D###
+  #A#D#C#A#
+  #########
\ No newline at end of file

test/amphipods2.txt

+#############
+#...........#
+###B#C#B#D###
+  #D#C#B#A#
+  #D#B#A#C#
+  #A#D#C#A#
+  #########
\ No newline at end of file