{-|
Module:         Day23
Description:    <https://adventofcode.com/2021/day/23 Day 23: Amphipod>
-}
{-# LANGUAGE FlexibleContexts, NamedFieldPuns, OverloadedStrings, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-}
module Day23 (day23a, day23b) where

import Control.Applicative (Alternative, (<|>), empty)
import Control.Monad (guard)
import Data.Array.IArray (Array, IArray, (!), (//), assocs, listArray)
import Data.Char (ord)
import Data.Function (on)
import Data.Heap (MinPrioHeap)
import qualified Data.Heap as Heap (insert, singleton, view)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (partition, transpose)
import Data.Map (Map)
import qualified Data.Map as Map ((!?), empty, insert)
import Data.Maybe (catMaybes, isNothing)
import Data.Text (Text)
import Data.Tuple (swap)
import Data.Void (Void)
import qualified Data.Text as T (lines, unlines)
import Text.Megaparsec (MonadParsec, ParseErrorBundle, Token, between, count, count', manyTill, parse, single, skipManyTill)
import Text.Megaparsec.Char (letterChar, newline)

data Cell a = Cell { Cell a -> Int
cellDepth :: Int, Cell a -> [a]
cellStack :: [a] } deriving (Cell a -> Cell a -> Bool
(Cell a -> Cell a -> Bool)
-> (Cell a -> Cell a -> Bool) -> Eq (Cell a)
forall a. Eq a => Cell a -> Cell a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cell a -> Cell a -> Bool
$c/= :: forall a. Eq a => Cell a -> Cell a -> Bool
== :: Cell a -> Cell a -> Bool
$c== :: forall a. Eq a => Cell a -> Cell a -> Bool
Eq, Eq (Cell a)
Eq (Cell a)
-> (Cell a -> Cell a -> Ordering)
-> (Cell a -> Cell a -> Bool)
-> (Cell a -> Cell a -> Bool)
-> (Cell a -> Cell a -> Bool)
-> (Cell a -> Cell a -> Bool)
-> (Cell a -> Cell a -> Cell a)
-> (Cell a -> Cell a -> Cell a)
-> Ord (Cell a)
Cell a -> Cell a -> Bool
Cell a -> Cell a -> Ordering
Cell a -> Cell a -> Cell a
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
forall a. Ord a => Eq (Cell a)
forall a. Ord a => Cell a -> Cell a -> Bool
forall a. Ord a => Cell a -> Cell a -> Ordering
forall a. Ord a => Cell a -> Cell a -> Cell a
min :: Cell a -> Cell a -> Cell a
$cmin :: forall a. Ord a => Cell a -> Cell a -> Cell a
max :: Cell a -> Cell a -> Cell a
$cmax :: forall a. Ord a => Cell a -> Cell a -> Cell a
>= :: Cell a -> Cell a -> Bool
$c>= :: forall a. Ord a => Cell a -> Cell a -> Bool
> :: Cell a -> Cell a -> Bool
$c> :: forall a. Ord a => Cell a -> Cell a -> Bool
<= :: Cell a -> Cell a -> Bool
$c<= :: forall a. Ord a => Cell a -> Cell a -> Bool
< :: Cell a -> Cell a -> Bool
$c< :: forall a. Ord a => Cell a -> Cell a -> Bool
compare :: Cell a -> Cell a -> Ordering
$ccompare :: forall a. Ord a => Cell a -> Cell a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Cell a)
Ord)

parser :: (MonadParsec e s m, Token s ~ Char) => m [Cell Char]
parser :: m [Cell Char]
parser = do
    [Char]
_ <- Int -> m Char -> m [Char]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 (m Char -> m [Char]) -> m Char -> m [Char]
forall a b. (a -> b) -> a -> b
$ Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'#'
    Int
width <- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> m [Char] -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m Char -> m [Char]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'#') m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    [Char]
_ <- m Char -> m Char -> m [Char] -> m [Char]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'#') (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'#' m Char -> m Char -> m Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline) (m [Char] -> m [Char]) -> m [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Int -> m Char -> m [Char]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
width (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'.')
    let c :: m Char
c = Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
' ' m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token s
'#'
        go :: m [[Maybe Char]]
go = do
            [Maybe Char]
row <- m Char -> m Char -> m [Maybe Char] -> m [Maybe Char]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between m Char
c (m Char -> m Char -> m Char
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
skipManyTill m Char
c m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline) m [Maybe Char]
line
            if (Maybe Char -> Bool) -> [Maybe Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Char -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Char]
row then [[Maybe Char]] -> m [[Maybe Char]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else ([Maybe Char]
row [Maybe Char] -> [[Maybe Char]] -> [[Maybe Char]]
forall a. a -> [a] -> [a]
:) ([[Maybe Char]] -> [[Maybe Char]])
-> m [[Maybe Char]] -> m [[Maybe Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [[Maybe Char]]
go
        line :: m [Maybe Char]
line = Int -> Int -> m (Maybe Char) -> m [Maybe Char]
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
width (m (Maybe Char) -> m [Maybe Char])
-> m (Maybe Char) -> m [Maybe Char]
forall a b. (a -> b) -> a -> b
$ Maybe Char
forall a. Maybe a
Nothing Maybe Char -> m Char -> m (Maybe Char)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m Char
c m (Maybe Char) -> m (Maybe Char) -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char) -> m Char -> m (Maybe Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
        cell :: [a] -> Cell a
cell [a]
cellStack = Cell :: forall a. Int -> [a] -> Cell a
Cell { cellDepth :: Int
cellDepth = Int
1, [a]
cellStack :: [a]
cellStack :: [a]
cellStack }
    ([Maybe Char] -> Cell Char) -> [[Maybe Char]] -> [Cell Char]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Cell Char
forall a. [a] -> Cell a
cell ([Char] -> Cell Char)
-> ([Maybe Char] -> [Char]) -> [Maybe Char] -> Cell Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Char] -> [Char]
forall a. [Maybe a] -> [a]
catMaybes) ([[Maybe Char]] -> [Cell Char])
-> ([[Maybe Char]] -> [[Maybe Char]])
-> [[Maybe Char]]
-> [Cell Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe Char]] -> [[Maybe Char]]
forall a. [[a]] -> [[a]]
transpose ([[Maybe Char]] -> [Cell Char])
-> m [[Maybe Char]] -> m [Cell Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [[Maybe Char]]
go

day23a :: Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
day23a :: Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
day23a Text
input = do
    [Cell Char]
state <- Parsec Void Text [Cell Char]
-> [Char]
-> Text
-> Either (ParseErrorBundle Text Void) [Cell Char]
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text [Cell Char]
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m [Cell Char]
parser [Char]
"" Text
input
    let goals :: IntMap Char
goals = [(Int, Char)] -> IntMap Char
forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList ([(Int, Char)] -> IntMap Char) -> [(Int, Char)] -> IntMap Char
forall a b. (a -> b) -> a -> b
$
            [Int] -> [Char] -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i | (Int
i, Cell { cellStack :: forall a. Cell a -> [a]
cellStack = Char
_:[Char]
_}) <- [Int] -> [Cell Char] -> [(Int, Cell Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Cell Char]
state] [Char
'A'..]
        state' :: Array Int (Cell Char)
state' = (Int, Int) -> [Cell Char] -> Array Int (Cell Char)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray @Array (Int
0, [Cell Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cell Char]
state Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Cell Char]
state
    Maybe Int -> Either (ParseErrorBundle Text Void) (Maybe Int)
forall a b. b -> Either a b
Right (Maybe Int -> Either (ParseErrorBundle Text Void) (Maybe Int))
-> Maybe Int -> Either (ParseErrorBundle Text Void) (Maybe Int)
forall a b. (a -> b) -> a -> b
$ (Char -> Int)
-> IntMap Char
-> Map (Array Int (Cell Char)) Int
-> MinPrioHeap Int (Array Int (Cell Char))
-> Maybe Int
forall (f :: * -> *) (arr :: * -> * -> *) a.
(Alternative f, IArray arr (Cell a), Ord (arr Int (Cell a)),
 Eq a) =>
(a -> Int)
-> IntMap a
-> Map (arr Int (Cell a)) Int
-> MinPrioHeap Int (arr Int (Cell a))
-> f Int
solve Char -> Int
weight IntMap Char
goals Map (Array Int (Cell Char)) Int
forall k a. Map k a
Map.empty (MinPrioHeap Int (Array Int (Cell Char)) -> Maybe Int)
-> MinPrioHeap Int (Array Int (Cell Char)) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Int, Array Int (Cell Char))
-> MinPrioHeap Int (Array Int (Cell Char))
forall pol item. HeapItem pol item => item -> Heap pol item
Heap.singleton (Int
0, Array Int (Cell Char)
state')
  where weight :: Char -> Int
weight = (Int
10 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract (Int -> Int -> Int) -> (Char -> Int) -> Char -> Char -> Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Char -> Int
ord) Char
'A'

day23b :: Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
day23b :: Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
day23b Text
input = Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
day23a (Text -> Either (ParseErrorBundle Text Void) (Maybe Int))
-> Text -> Either (ParseErrorBundle Text Void) (Maybe Int)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
pre [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text
"  #D#C#B#A#" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"  #D#B#A#C#" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
post where
    ([Text]
pre, [Text]
post) = Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 ([Text] -> ([Text], [Text])) -> [Text] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
input

solve :: (Alternative f, IArray arr (Cell a), Ord (arr Int (Cell a)), Eq a) => (a -> Int) -> IntMap a -> Map (arr Int (Cell a)) Int -> MinPrioHeap Int (arr Int (Cell a)) -> f Int
solve :: (a -> Int)
-> IntMap a
-> Map (arr Int (Cell a)) Int
-> MinPrioHeap Int (arr Int (Cell a))
-> f Int
solve a -> Int
weight IntMap a
goals = Map (arr Int (Cell a)) Int
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> f Int
Map (arr Int (Cell a)) Int
-> MinPrioHeap Int (arr Int (Cell a)) -> f Int
solve' where
    solve' :: Map (arr Int (Cell a)) Int
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> f Int
solve' Map (arr Int (Cell a)) Int
visited (HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> Maybe
     ((Int, arr Int (Cell a)), MinPrioHeap Int (arr Int (Cell a)))
forall pol item.
HeapItem pol item =>
Heap pol item -> Maybe (item, Heap pol item)
Heap.view -> Just ((Int
_, arr Int (Cell a)
state), MinPrioHeap Int (arr Int (Cell a))
heap))
      | arr Int (Cell a) -> Bool
isDone arr Int (Cell a)
state = Int -> f Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
cost f Int -> f Int -> f Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Map (arr Int (Cell a)) Int
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> f Int
solve' Map (arr Int (Cell a)) Int
visited'' HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
heap'
      | Bool
otherwise = Map (arr Int (Cell a)) Int
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> f Int
solve' Map (arr Int (Cell a)) Int
visited'' HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
heap'
      where
        (Int
cost, Map (arr Int (Cell a)) Int
visited') = (Int, Map (arr Int (Cell a)) Int)
-> (Int -> (Int, Map (arr Int (Cell a)) Int))
-> Maybe Int
-> (Int, Map (arr Int (Cell a)) Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
0, arr Int (Cell a)
-> Int -> Map (arr Int (Cell a)) Int -> Map (arr Int (Cell a)) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert arr Int (Cell a)
state Int
0 Map (arr Int (Cell a)) Int
visited) (, Map (arr Int (Cell a)) Int
visited) (Maybe Int -> (Int, Map (arr Int (Cell a)) Int))
-> Maybe Int -> (Int, Map (arr Int (Cell a)) Int)
forall a b. (a -> b) -> a -> b
$ Map (arr Int (Cell a)) Int
visited Map (arr Int (Cell a)) Int -> arr Int (Cell a) -> Maybe Int
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? arr Int (Cell a)
state
        allMoves :: [(Bool, (Int, arr Int (Cell a)))]
allMoves = do
            (Int
i, src :: Cell a
src@Cell { cellStack :: forall a. Cell a -> [a]
cellStack = a
a : [a]
srcStack }) <- arr Int (Cell a) -> [(Int, Cell a)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs arr Int (Cell a)
state
            let canLeave :: a -> Bool
canLeave a
b = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b) ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ Cell a -> [a]
forall a. Cell a -> [a]
cellStack Cell a
src
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True a -> Bool
canLeave (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ IntMap a
goals IntMap a -> Int -> Maybe a
forall a. IntMap a -> Int -> Maybe a
IntMap.!? Int
i
            (Int
j, Cell a
dst) <- arr Int (Cell a) -> [(Int, Cell a)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs arr Int (Cell a)
state
            let canPass :: Int -> Bool
canPass Int
k = Cell a -> Int
forall a. Cell a -> Int
cellDepth (arr Int (Cell a)
state arr Int (Cell a) -> Int -> Cell a
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
k) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                canEnter :: a -> Bool
canEnter a
b = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) (Cell a -> [a]
forall a. Cell a -> [a]
cellStack Cell a
dst)
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Int -> Bool
canPass (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j then [Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1..Int
j] else [Int
j..Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) Bool -> Bool -> Bool
&&
                (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Int -> Bool) -> Int -> Int -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int -> IntMap a -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` IntMap a
goals)) Int
i Int
j Bool -> Bool -> Bool
&& Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True a -> Bool
canEnter (IntMap a
goals IntMap a -> Int -> Maybe a
forall a. IntMap a -> Int -> Maybe a
IntMap.!? Int
j)
            let distance :: Int
distance = Int -> Int
forall a. Num a => a -> a
abs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Cell a -> Int
forall a. Cell a -> Int
cellDepth Cell a
src Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Cell a -> Int
forall a. Cell a -> Int
cellDepth Cell a
dst Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                cost' :: Int
cost' = Int
cost Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
distance Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
weight a
a
                src' :: Cell a
src' = Cell a
src { cellDepth :: Int
cellDepth = Cell a -> Int
forall a. Cell a -> Int
cellDepth Cell a
src Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, cellStack :: [a]
cellStack = [a]
srcStack }
                dst' :: Cell a
dst' = Cell a
dst { cellDepth :: Int
cellDepth = Cell a -> Int
forall a. Cell a -> Int
cellDepth Cell a
dst Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, cellStack :: [a]
cellStack = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Cell a -> [a]
forall a. Cell a -> [a]
cellStack Cell a
dst }
                state' :: arr Int (Cell a)
state' = arr Int (Cell a)
state arr Int (Cell a) -> [(Int, Cell a)] -> arr Int (Cell a)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Int
i, Cell a
src'), (Int
j, Cell a
dst')]
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cost') (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Map (arr Int (Cell a)) Int
visited' Map (arr Int (Cell a)) Int -> arr Int (Cell a) -> Maybe Int
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? arr Int (Cell a)
state'
            (Bool, (Int, arr Int (Cell a)))
-> [(Bool, (Int, arr Int (Cell a)))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
j Int -> IntMap a -> Bool
forall a. Int -> IntMap a -> Bool
`IntMap.member` IntMap a
goals, (Int
cost', arr Int (Cell a)
state'))
        ([(Bool, (Int, arr Int (Cell a)))]
priorityMoves, [(Bool, (Int, arr Int (Cell a)))]
otherMoves) = ((Bool, (Int, arr Int (Cell a))) -> Bool)
-> [(Bool, (Int, arr Int (Cell a)))]
-> ([(Bool, (Int, arr Int (Cell a)))],
    [(Bool, (Int, arr Int (Cell a)))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool, (Int, arr Int (Cell a))) -> Bool
forall a b. (a, b) -> a
fst [(Bool, (Int, arr Int (Cell a)))]
allMoves
        moves :: [(Int, arr Int (Cell a))]
moves
          | (Bool
_, (Int, arr Int (Cell a))
priorityMove):[(Bool, (Int, arr Int (Cell a)))]
_ <- [(Bool, (Int, arr Int (Cell a)))]
priorityMoves = [(Int, arr Int (Cell a))
priorityMove]
          | Bool
otherwise = (Bool, (Int, arr Int (Cell a))) -> (Int, arr Int (Cell a))
forall a b. (a, b) -> b
snd ((Bool, (Int, arr Int (Cell a))) -> (Int, arr Int (Cell a)))
-> [(Bool, (Int, arr Int (Cell a)))] -> [(Int, arr Int (Cell a))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bool, (Int, arr Int (Cell a)))]
otherMoves
        isBetter :: (Int, arr Int (Cell a)) -> Bool
isBetter (Int
cost', arr Int (Cell a)
state') = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cost') (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Map (arr Int (Cell a)) Int
visited' Map (arr Int (Cell a)) Int -> arr Int (Cell a) -> Maybe Int
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? arr Int (Cell a)
state'
        moves' :: [(Int, arr Int (Cell a))]
moves' = ((Int, arr Int (Cell a)) -> Bool)
-> [(Int, arr Int (Cell a))] -> [(Int, arr Int (Cell a))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, arr Int (Cell a)) -> Bool
isBetter [(Int, arr Int (Cell a))]
moves
        visited'' :: Map (arr Int (Cell a)) Int
visited'' = ((Int, arr Int (Cell a))
 -> Map (arr Int (Cell a)) Int -> Map (arr Int (Cell a)) Int)
-> Map (arr Int (Cell a)) Int
-> [(Int, arr Int (Cell a))]
-> Map (arr Int (Cell a)) Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((arr Int (Cell a)
 -> Int -> Map (arr Int (Cell a)) Int -> Map (arr Int (Cell a)) Int)
-> (arr Int (Cell a), Int)
-> Map (arr Int (Cell a)) Int
-> Map (arr Int (Cell a)) Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry arr Int (Cell a)
-> Int -> Map (arr Int (Cell a)) Int -> Map (arr Int (Cell a)) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ((arr Int (Cell a), Int)
 -> Map (arr Int (Cell a)) Int -> Map (arr Int (Cell a)) Int)
-> ((Int, arr Int (Cell a)) -> (arr Int (Cell a), Int))
-> (Int, arr Int (Cell a))
-> Map (arr Int (Cell a)) Int
-> Map (arr Int (Cell a)) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, arr Int (Cell a)) -> (arr Int (Cell a), Int)
forall a b. (a, b) -> (b, a)
swap) Map (arr Int (Cell a)) Int
visited' [(Int, arr Int (Cell a))]
moves'
        heap' :: HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
heap' = ((Int, arr Int (Cell a))
 -> HeapT
      (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
 -> HeapT
      (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a)))
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> [(Int, arr Int (Cell a))]
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, arr Int (Cell a))
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
-> HeapT
     (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
forall pol item.
HeapItem pol item =>
item -> Heap pol item -> Heap pol item
Heap.insert HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
MinPrioHeap Int (arr Int (Cell a))
heap [(Int, arr Int (Cell a))]
moves'
    solve' Map (arr Int (Cell a)) Int
_ HeapT
  (Prio FstMinPolicy (Int, arr Int (Cell a))) (arr Int (Cell a))
_ = f Int
forall (f :: * -> *) a. Alternative f => f a
empty
    isDone :: arr Int (Cell a) -> Bool
isDone = ((Int, Cell a) -> Bool) -> [(Int, Cell a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, Cell a) -> Bool
isDone' ([(Int, Cell a)] -> Bool)
-> (arr Int (Cell a) -> [(Int, Cell a)])
-> arr Int (Cell a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arr Int (Cell a) -> [(Int, Cell a)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs where
        isDone' :: (Int, Cell a) -> Bool
isDone' (Int
i, Cell { Int
cellDepth :: Int
cellDepth :: forall a. Cell a -> Int
cellDepth, [a]
cellStack :: [a]
cellStack :: forall a. Cell a -> [a]
cellStack }) =
            Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cellStack) a -> Bool
isDone'' (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ IntMap a
goals IntMap a -> Int -> Maybe a
forall a. IntMap a -> Int -> Maybe a
IntMap.!? Int
i where
            isDone'' :: a -> Bool
isDone'' a
a = Int
cellDepth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) [a]
cellStack