{-# Language BlockArguments, ImportQualifiedPost #-}
{-|
Module      : Main
Description : Day 20 solution
Copyright   : (c) Eric Mertens, 2019
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2019/day/20>

-}
module Main (main) where

import Advent             (getInputArray)
import Advent.Coord       (Coord(C), boundingBox, cardinal, coordLines, above, below, left, right)
import Advent.Search      (AStep(..), astar)
import Data.Array.Unboxed (UArray, listArray, assocs, (!))
import Data.Char          (isAlpha)
import Data.Foldable      (toList)
import Data.Map           (Map)
import Data.Map qualified as Map
import Data.Set qualified as Set

-- | >>> :main
-- 490
-- 5648
main :: IO ()
IO ()
main =
  do UArray Coord Char
world <- Int -> Int -> IO (UArray Coord Char)
getInputArray Int
2019 Int
20

     let labels :: Map String [Coord]
labels = UArray Coord Char -> Map String [Coord]
findLabels UArray Coord Char
world
         links :: Map Coord Coord
links  = Map String [Coord] -> Map Coord Coord
findLinks Map String [Coord]
labels
         jumps :: Map Coord [(Coord, Int)]
jumps  = UArray Coord Char -> [Coord] -> Map Coord [(Coord, Int)]
shortcuts UArray Coord Char
world (Map String [Coord] -> [Coord]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Map String [Coord]
labels)

         Just [Coord
start] = String -> Map String [Coord] -> Maybe [Coord]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"AA" Map String [Coord]
labels
         Just [Coord
end  ] = String -> Map String [Coord] -> Maybe [Coord]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"ZZ" Map String [Coord]
labels

         outside :: Coord -> Bool
outside = Map String [Coord] -> Coord -> Bool
mkIsOutside Map String [Coord]
labels

         layerChange :: Coord -> a
layerChange Coord
p
           | Coord -> Bool
outside Coord
p = -a
1
           | Bool
otherwise = a
1

     Int -> IO ()
forall a. Show a => a -> IO ()
print ((Coord -> Int)
-> Map Coord [(Coord, Int)]
-> Map Coord Coord
-> Coord
-> Coord
-> Int
search (Int -> Coord -> Int
forall a b. a -> b -> a
const Int
0)   Map Coord [(Coord, Int)]
jumps Map Coord Coord
links Coord
start Coord
end)
     Int -> IO ()
forall a. Show a => a -> IO ()
print ((Coord -> Int)
-> Map Coord [(Coord, Int)]
-> Map Coord Coord
-> Coord
-> Coord
-> Int
search Coord -> Int
forall {a}. Num a => Coord -> a
layerChange Map Coord [(Coord, Int)]
jumps Map Coord Coord
links Coord
start Coord
end)

-- | Build predicate for coordinates on outer wall.
mkIsOutside ::
  Map String [Coord] {- ^ labeled coordinates -} ->
  Coord -> Bool
mkIsOutside :: Map String [Coord] -> Coord -> Bool
mkIsOutside Map String [Coord]
labels = \(C Int
y Int
x) -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
xhi Bool -> Bool -> Bool
|| Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
xlo Bool -> Bool -> Bool
|| Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
yhi Bool -> Bool -> Bool
|| Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ylo
  where
    Just (C Int
ylo Int
xlo, C Int
yhi Int
xhi) = [Coord] -> Maybe (Coord, Coord)
forall (f :: * -> *). Foldable f => f Coord -> Maybe (Coord, Coord)
boundingBox (Map String [Coord] -> [Coord]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Map String [Coord]
labels)

data Pos = Pos !Coord !Int
 deriving (Pos -> Pos -> Bool
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
/= :: Pos -> Pos -> Bool
Eq, Eq Pos
Eq Pos =>
(Pos -> Pos -> Ordering)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Pos)
-> (Pos -> Pos -> Pos)
-> Ord Pos
Pos -> Pos -> Bool
Pos -> Pos -> Ordering
Pos -> Pos -> Pos
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pos -> Pos -> Ordering
compare :: Pos -> Pos -> Ordering
$c< :: Pos -> Pos -> Bool
< :: Pos -> Pos -> Bool
$c<= :: Pos -> Pos -> Bool
<= :: Pos -> Pos -> Bool
$c> :: Pos -> Pos -> Bool
> :: Pos -> Pos -> Bool
$c>= :: Pos -> Pos -> Bool
>= :: Pos -> Pos -> Bool
$cmax :: Pos -> Pos -> Pos
max :: Pos -> Pos -> Pos
$cmin :: Pos -> Pos -> Pos
min :: Pos -> Pos -> Pos
Ord, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pos -> ShowS
showsPrec :: Int -> Pos -> ShowS
$cshow :: Pos -> String
show :: Pos -> String
$cshowList :: [Pos] -> ShowS
showList :: [Pos] -> ShowS
Show)

search ::
  (Coord -> Int)           {- ^ layer change   -} ->
  Map Coord [(Coord, Int)] {- ^ maze movements -} ->
  Map Coord Coord          {- ^ warp links     -} ->
  Coord                    {- ^ start position -} ->
  Coord                    {- ^ end position   -} ->
  Int                      {- ^ steps to end   -}
search :: (Coord -> Int)
-> Map Coord [(Coord, Int)]
-> Map Coord Coord
-> Coord
-> Coord
-> Int
search Coord -> Int
delta Map Coord [(Coord, Int)]
jumps Map Coord Coord
links Coord
start Coord
end =
  (Pos, Int) -> Int
forall a b. (a, b) -> b
snd ((Pos, Int) -> Int) -> (Pos, Int) -> Int
forall a b. (a -> b) -> a -> b
$ [(Pos, Int)] -> (Pos, Int)
forall a. HasCallStack => [a] -> a
head ([(Pos, Int)] -> (Pos, Int)) -> [(Pos, Int)] -> (Pos, Int)
forall a b. (a -> b) -> a -> b
$ ((Pos, Int) -> Bool) -> [(Pos, Int)] -> [(Pos, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pos, Int) -> Bool
forall {b}. (Pos, b) -> Bool
isDone ([(Pos, Int)] -> [(Pos, Int)]) -> [(Pos, Int)] -> [(Pos, Int)]
forall a b. (a -> b) -> a -> b
$ (Pos -> [AStep Pos]) -> Pos -> [(Pos, Int)]
forall a. Ord a => (a -> [AStep a]) -> a -> [(a, Int)]
astar Pos -> [AStep Pos]
step (Coord -> Int -> Pos
Pos Coord
start Int
0)
  where
   isDone :: (Pos, b) -> Bool
isDone (Pos
p,b
_) = Coord -> Int -> Pos
Pos Coord
end Int
0 Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
p

   step :: Pos -> [AStep Pos]
step (Pos Coord
here Int
depth) =
     -- travel through a warp tile
     [ Pos -> Int -> Int -> AStep Pos
forall a. a -> Int -> Int -> AStep a
AStep (Coord -> Int -> Pos
Pos Coord
exit Int
depth') (Int
cost Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
        | (Coord
enter, Int
cost) <- [(Coord, Int)]
-> Coord -> Map Coord [(Coord, Int)] -> [(Coord, Int)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Coord
here Map Coord [(Coord, Int)]
jumps
        , let depth' :: Int
depth' = Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Coord -> Int
delta Coord
enter
        , Int
depth' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
        , Coord
exit <- Maybe Coord -> [Coord]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Coord -> Map Coord Coord -> Maybe Coord
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Coord
enter Map Coord Coord
links)
        ] [AStep Pos] -> [AStep Pos] -> [AStep Pos]
forall a. [a] -> [a] -> [a]
++
     -- finish maze
     [ Pos -> Int -> Int -> AStep Pos
forall a. a -> Int -> Int -> AStep a
AStep (Coord -> Int -> Pos
Pos Coord
enter Int
0) Int
cost Int
0
          | Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          , (Coord
enter, Int
cost) <- [(Coord, Int)]
-> Coord -> Map Coord [(Coord, Int)] -> [(Coord, Int)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Coord
here Map Coord [(Coord, Int)]
jumps
          , Coord
enter Coord -> Coord -> Bool
forall a. Eq a => a -> a -> Bool
== Coord
end
        ]

-- | Find output destinations for each warp tile.
findLinks ::
  Map String [Coord] {- ^ labeled tiles -} ->
  Map Coord Coord    {- ^ warp links    -}
findLinks :: Map String [Coord] -> Map Coord Coord
findLinks Map String [Coord]
xs =
  [(Coord, Coord)] -> Map Coord Coord
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    do [Coord
p1,Coord
p2] <- Map String [Coord] -> [[Coord]]
forall k a. Map k a -> [a]
Map.elems Map String [Coord]
xs
       [(Coord
p1,Coord
p2), (Coord
p2,Coord
p1)]

-- | Find labeled coordinates.
findLabels :: UArray Coord Char -> Map String [Coord]
findLabels :: UArray Coord Char -> Map String [Coord]
findLabels UArray Coord Char
m =
  ([Coord] -> [Coord] -> [Coord])
-> [(String, [Coord])] -> Map String [Coord]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Coord] -> [Coord] -> [Coord]
forall a. [a] -> [a] -> [a]
(++)
    [ (String
lbl, [Coord
pos])
    | (Coord
pos, Char
'.') <- UArray Coord Char -> [(Coord, Char)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs UArray Coord Char
m
    , (Coord -> Coord
f1, Coord -> Coord
f2)   <- [(Coord -> Coord, Coord -> Coord)]
adjFuns
    , let lbl :: String
lbl = [UArray Coord Char
m UArray Coord Char -> Coord -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Coord -> Coord
f1 Coord
pos, UArray Coord Char
m UArray Coord Char -> Coord -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Coord -> Coord
f2 Coord
pos]
    , (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlpha String
lbl
    ]
  where
    adjFuns :: [(Coord -> Coord, Coord -> Coord)]
adjFuns = [ (Coord -> Coord
left(Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Coord -> Coord
left, Coord -> Coord
left)
              , (Coord -> Coord
right, Coord -> Coord
right(Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Coord -> Coord
right)
              , (Coord -> Coord
above(Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Coord -> Coord
above, Coord -> Coord
above)
              , (Coord -> Coord
below, Coord -> Coord
below(Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Coord -> Coord
below) ]



-- | Given a list of starting positions find map of destinations
-- and costs to those destinations.
shortcuts :: UArray Coord Char -> [Coord] -> Map Coord [(Coord,Int)]
shortcuts :: UArray Coord Char -> [Coord] -> Map Coord [(Coord, Int)]
shortcuts UArray Coord Char
world [Coord]
targets = [(Coord, [(Coord, Int)])] -> Map Coord [(Coord, Int)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Coord
start, Coord -> [(Coord, Int)]
travelFrom Coord
start) | Coord
start <- [Coord]
targets]
  where
    targetSet :: Set Coord
targetSet = [Coord] -> Set Coord
forall a. Ord a => [a] -> Set a
Set.fromList [Coord]
targets

    travelFrom :: Coord -> [(Coord, Int)]
travelFrom Coord
src =
      [ (Coord
dst,Int
n)
         | (Coord
dst,Int
n) <- (Coord -> [AStep Coord]) -> Coord -> [(Coord, Int)]
forall a. Ord a => (a -> [AStep a]) -> a -> [(a, Int)]
astar Coord -> [AStep Coord]
step Coord
src
         , Coord -> Set Coord -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Coord
dst Set Coord
targetSet
         , Coord
dst Coord -> Coord -> Bool
forall a. Eq a => a -> a -> Bool
/= Coord
src
         ]

    step :: Coord -> [AStep Coord]
step Coord
here = [Coord -> Int -> Int -> AStep Coord
forall a. a -> Int -> Int -> AStep a
AStep Coord
there Int
1 Int
0 | Coord
there <- Coord -> [Coord]
cardinal Coord
here, UArray Coord Char
world UArray Coord Char -> Coord -> Char
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Coord
there Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.']