Problem:
Score : 400 points

Problem Statement

A maze is composed of a grid of H \times W squares - H vertical, W horizontal.

The square at the i-th row from the top and the j-th column from the left - (i,j) - is a wall if S_{ij} is # and a road if S_{ij} is ..

There is a magician in (C_h,C_w). He can do the following two kinds of moves:

Move A: Walk to a road square that is vertically or horizontally adjacent to the square he is currently in.

Move B: Use magic to warp himself to a road square in the 5\times 5 area centered at the square he is currently in.

In either case, he cannot go out of the maze.

At least how many times does he need to use the magic to reach (D_h, D_w)?

Constraints

1 \leq H,W \leq 10^3

1 \leq C_h,D_h \leq H

1 \leq C_w,D_w \leq W

S_{ij} is # or ..

S_{C_h C_w} and S_{D_h D_w} are ..

(C_h,C_w) \neq (D_h,D_w)

Input

Input is given from Standard Input in the following format:

H W
C_h C_w
D_h D_w
S_{11}\ldots S_{1W}
\vdots
S_{H1}\ldots S_{HW}

Output

Print the minimum number of times the magician needs to use the magic. If he cannot reach (D_h,D_w), print -1 instead.

Sample Input 1

4 4
1 1
4 4
..#.
..#.
.#..
.#..

Sample Output 1

1

For example, by walking to (2,2) and then using the magic to travel to (4,4), just one use of magic is enough.

Note that he cannot walk diagonally.

Sample Input 2

4 4
1 4
4 1
.##.
####
####
.##.

Sample Output 2

-1

He cannot move from there.

Sample Input 3

4 4
2 2
3 3
....
....
....
....

Sample Output 3

0

No use of magic is needed.

Sample Input 4

4 5
1 2
2 5
#.###
####.
#..##
#..##

Sample Output 4

2

Solution in Haskell (GHC 8.8.3) (judge verdict: Wrong Answer)

{-# LANGUAGE MultiWayIf #-}

module Main where

import Control.Monad
import Control.Monad.Extra
import qualified Data.Array as A
import qualified Data.Array.IO as AIO
import qualified Data.Array.Unboxed as AU
--import qualified Data.Heap                     as H

import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC8
import Data.Char
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import Data.Int
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Ord
import qualified Data.Sequence as SQ
import qualified Data.Set as S
import qualified Data.Vector as V
import Data.Vector.Algorithms.Search
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
import Debug.Trace
import Prelude

main =
  do
    --aN       <- getI
    --[aA, aB] <- getIL
    --aS       <- getLine

    [aH, aW] <- getIL
    [aCh, aCw] <- getIL
    [aDh, aDw] <- getIL
    aS <- V.replicateM aH getVUC
    xxx <- VM.replicateM aH $ VUM.replicate aW (10 ^ 3) :: IO (VM.IOVector (VUM.IOVector Int))

    xxxna <- VM.read xxx (p aCh)
    VUM.write xxxna (p aCw) 0

    ret <- bfs xxx aS aH aW aCh aCw aDh aDw (SQ.singleton (aCh, aCw))

    mapM
      ( \y -> do
          xxxx <- VM.read xxx (p y)
          print =<< VU.freeze xxxx
      )
      [1 .. aH]

    if ret == True
      then
        print =<< do
          xxxdh <- VM.read xxx (p aDh)
          VUM.read xxxdh (p aDw)
      else print (-1)

    return ()

bfs xxx s h w ch cw dh dw sq
  | sq == SQ.empty = return False
  | otherwise = do
    ret1 <- fill xxx s h w ch cw dh dw sq
    if ret1 == True
      then return True
      else do
        sList <- warp xxx s h w
        if sList == []
          then return False
          else do
            print sList
            bfs xxx s h w ch cw dh dw (SQ.fromList sList <> sq)

fill xxx s h w ch cw dh dw sq
  | sq == SQ.empty = return False
  | otherwise = do
    let now@(a, b) SQ.:< nextsq = SQ.viewl sq
        bbb = aroundSquare a b h w
        fdbbb = filter (\x@(d, e) -> (s V.! (p d) VU.! (p e) == '.')) bbb

    if (a == dh && b == dw)
      then return True
      else do
        xxxa <- VM.read xxx (p a) :: IO (VUM.IOVector Int)
        xxxb <- VUM.read xxxa (p b)
        pbbb <-
          mapMaybeM
            ( \x@(na, nb) -> do
                xxxna <- VM.read xxx (p na)
                xxxnb <- VUM.read xxxna (p nb)
                if xxxnb > xxxb
                  then do
                    VUM.write xxxna (p nb) xxxb
                    return (Just (na, nb))
                  else return Nothing
            )
            fdbbb

        fill xxx s h w ch cw dh dw (SQ.fromList pbbb SQ.>< nextsq)

warp xxx s h w = do
  concatMapM
    ( \y -> do
        mapMaybeM
          ( \x -> do
              xxxa <- VM.read xxx (p y) :: IO (VUM.IOVector Int)
              xxxb <- VUM.read xxxa (p x)

              if xxxb == 10 ^ 3 && (s V.! (p y) VU.! (p x) == '.')
                then do
                  let waslB = warpAroundSquare y x h w
                      wasl =
                        filter
                          ( \(wasY, wasX) -> (s V.! (p wasY) VU.! (p wasX) == '.')
                          )
                          waslB

                  if wasl == []
                    then return Nothing
                    else do
                      minWasl <-
                        minimum
                          <$> mapM
                            ( \(wasY, wasX) -> do
                                xxxwasy <- VM.read xxx (p wasY)
                                VUM.read xxxwasy (p wasX)
                            )
                            wasl
                      target <- VUM.read xxxa (p x)
                      if target > minWasl
                        then do
                          VUM.write xxxa (p x) (minWasl + 1)
                          return (Just (y, x))
                        else return Nothing
                else return Nothing
          )
          [1 .. w]
    )
    [1 .. h]

{-
hMaxPoint :: Int
hMaxPoint = 101
hMaximum :: H.Heap Int -> Int
hMaximum h = hMaxPoint - (H.minimum h)
hInsertMax :: Int -> H.Heap Int -> H.Heap Int
hInsertMax x = H.insert (hMaxPoint - x)
hDeleteMax :: H.Heap Int -> H.Heap Int
hDeleteMax = H.deleteMin
-}
{-}
aroundSquare y x h w =
  [ aYX
    | aYX@(aY, aX) <- [(y - 1, x), (y, x - 1), (y + 1, x), (y, x + 1), (y, x)],
      aY >= 0,
      aY <= (h - 1),
      aX >= 0,
      aX <= (w - 1)
  ]
-}

aroundSquare y x h w =
  [ aYX
    | aYX@(aY, aX) <- [(y + a, x + b) | a <- [-1 .. 1], b <- [-1 .. 1], a + b == 1],
      aY >= 1,
      aY <= (h),
      aX >= 1,
      aX <= (w),
      (aY /= y) || (aX /= x)
  ]

warpAroundSquare y x h w =
  [ aYX
    | aYX@(aY, aX) <- [(y + a, x + b) | a <- [-2 .. 2], b <- [-2 .. 2], abs (a) + abs (b) > 1],
      aY >= 1,
      aY <= (h),
      aX >= 1,
      aX <= (w),
      (aY /= y) || (aX /= x)
  ]

splitReadBSC8 :: BSC8.ByteString -> [Int]
splitReadBSC8 bs =
  let (bs1, newBs) = BSC8.splitAt 1 bs
   in if newBs == BSC8.empty
        then [test $ BSC8.readInt bs1]
        else (test $ BSC8.readInt bs1) : (splitReadBSC8 newBs)
  where
    test (Just (i, _)) = i

read2DimChar :: VM.IOVector (VUM.IOVector Char) -> Int -> Int -> IO Char
read2DimChar vec y x = do
  vecY <- VM.read vec y
  VUM.read vecY x

write2DimChar :: VM.IOVector (VUM.IOVector Char) -> Int -> Int -> Char -> IO ()
write2DimChar vec y x t = do
  vecY <- VM.read vec y
  VUM.write vecY x t

readTwoDimVec :: VM.IOVector (VUM.IOVector Int) -> Int -> Int -> IO Int
readTwoDimVec vec y x = do
  vecY <- VM.read vec y
  VUM.read vecY x

writeTwoDimVec :: VM.IOVector (VUM.IOVector Int) -> Int -> Int -> Int -> IO ()
writeTwoDimVec vec y x t = do
  vecY <- VM.read vec y
  VUM.write vecY x t

getVUI :: IO (VU.Vector Int)
getVUI = VU.unfoldr (BSC8.readInt . BSC8.dropWhile isSpace) <$> BSC8.getLine

getRepVUI :: Int -> IO (VU.Vector Int)
getRepVUI n =
  VU.unfoldr (BSC8.readInt . BSC8.dropWhile isSpace)
    . BSC8.unlines
    <$> replicateM n BSC8.getLine

getVS :: IO (V.Vector Char)
getVS = V.fromList <$> getLine

getVUC :: IO (VU.Vector Char)
getVUC = VU.fromList <$> getLine

readI :: BSC8.ByteString -> Int
readI = fst . fromJust . BSC8.readInt

readIL :: BSC8.ByteString -> [Int]
readIL = map readI . BSC8.words

readIT2 :: BSC8.ByteString -> (Int, Int)
readIT2 bs =
  let words = BSC8.words bs in (readI $ head words, readI $ last words)

getI :: IO Int
getI = readI <$> BSC8.getLine

getIL :: IO [Int]
getIL = readIL <$> BSC8.getLine

getIT2 :: IO (Int, Int)
getIT2 = readIT2 <$> BSC8.getLine

getIT2Order :: IO (Int, Int)
getIT2Order =
  getIL
    >>= \x@[xz, xo] -> if xz > xo then return (xo, xz) else return (xz, xo)

getNIS :: Int -> IO [(Int, BSC8.ByteString)]
getNIS 0 = return []
getNIS n = do
  [aFst, aSnd] <- BSC8.words <$> BSC8.getLine
  next <- getNIS (n - 1)
  return ((readI aFst, aSnd) : next)

il2Words :: [Int] -> String
il2Words = unwords . map show

il2Lines :: [Int] -> String
il2Lines = unlines . map show

p :: Int -> Int
p x = x - 1

--modNum = 10 ^ 9 + 7
--modulus = 1000000007
modulus = 2019

newtype MInt = M Int

instance Num MInt where
  (M a) + (M b) = M $ mod (a + b) modulus

  (M a) - (M b) = M $ mod (a - b) modulus

  (M a) * (M b) = M $ mod (a * b) modulus

  fromInteger a = M $ mod (fromInteger a) modulus

  abs (M a) = M $ abs a

  signum (M a) = M $ signum a

instance Show MInt where
  show (M a) = show (mod a modulus)

int2MInt :: Int -> MInt
int2MInt a = M (mod a modulus)

mInt2Int :: MInt -> Int
mInt2Int (M a) = a

{-
factsMod :: V.Vector MInt
factsMod = V.scanl (\acc x -> M x * acc) 1 $ V.generate 2000000 (+ 1)

factMod :: Int -> MInt
factMod = (factsMod V.!)
-}

factMod :: Int -> MInt
factMod n
  | n == 0 = 1
  | n == 1 = 1
  | otherwise = M n * (factMod (n - 1))

factDivMod :: Int -> Int -> MInt
factDivMod n k
  | n == k = M 1
  | otherwise = M n * (factDivMod (n - 1) k)

powMod :: MInt -> MInt -> MInt
powMod n mK@(M k)
  | k == 0 = M 1
  | k == 1 = n
  | mod k 2 == 0 = powMod (n ^ 2) (M (div k 2))
  | otherwise = n * powMod (n ^ 2) (M (div k 2))

invMod :: MInt -> MInt
invMod (M 0) = error "inverse of 0"
invMod x = powMod x (M (modulus - 2))

{-
combiMod :: Int -> Int -> MInt
combiMod n k
  | n < 0 || k < 0 || k > n = 0
  | otherwise = factMod n * invMod (factMod (n - k)) * invMod (factMod k)
-}
combiMod :: Int -> Int -> MInt
combiMod n k
  | n < 0 || k < 0 || k > n = 0
  | k > n - k = factDivMod n k * invMod (factMod (n - k))
  | otherwise = factDivMod n (n - k) * invMod (factMod k)

combi :: Int -> Int -> Int
combi n k
  | n < 0 || k < 0 || k > n = 0
  | k == n = 1
  | otherwise = div (div (fact n) (fact (n - k))) (fact k)

{-w
primes :: Integral a => [a]
primes = map fromIntegral $ [2, 3] ++ primes'
 where
  primes' = [5] ++ f 1 7 primes'
  f m s (p : ps) = [ n | n <- ns, gcd m n == 1 ] ++ f (m * p) (p * p) ps
    where ns = [ x + y | x <- [s, s + 6 .. p * p - 2], y <- [0, 4] ]

prime n = primes !! n
primes = sieve [2 ..]
sieve (p : xs) = p : sieve [ x | x <- xs, x `mod` p /= 0 ]
-}
fact :: Int -> Int
fact 0 = 1
fact n | n > 0 = n * fact (n - 1)

knappsackWDP :: Int -> [(Int, Int)] -> VU.Vector Int
knappsackWDP maxW [] = VU.replicate (maxW + 1) 0
knappsackWDP maxW ((w, v) : xs) =
  let tailDP = knappsackWDP maxW xs
   in VU.generate (maxW + 1) $ \i ->
        if w <= i
          then max (tailDP VU.! i) (tailDP VU.! (i - w) + v)
          else tailDP VU.! i

knappsackVDP :: Int -> Int -> Int -> [(Int, Int)] -> VU.Vector Int
knappsackVDP maxW maxV n [] = VU.cons 0 $ VU.replicate (n * maxV) maxW
knappsackVDP maxW maxV n ((w, v) : xs) =
  let tailDP = knappsackVDP maxW maxV n xs
   in VU.generate (n * maxV + 1) $ \i ->
        if v <= i
          then min (tailDP VU.! i) (tailDP VU.! (i - v) + w)
          else tailDP VU.! i

knappsackMinVol ::
  AIO.IOArray (Int, Int) Int ->
  VU.Vector Int ->
  VU.Vector Int ->
  Int ->
  Int ->
  IO Int
knappsackMinVol dp volumeVec valueVec dpSize maxVolume = do
  mapM_
    ( \i ->
        mapM_
          ( \v -> do
              let volume = volumeVec VU.! i
                  value = valueVec VU.! i
              newdp <-
                if (v + value) > dpSize
                  then AIO.readArray dp (i, v)
                  else do
                    dpIVm <- AIO.readArray dp (i, v + value)
                    dpIV <- AIO.readArray dp (i, v)
                    return (min (dpIVm - volume) dpIV)
              AIO.writeArray dp (i + 1, v) newdp
          )
          (reverse [0 .. dpSize])
    )
    [0 .. VU.length valueVec - 1]
  foldM
    ( \acc x -> do
        num <- AIO.readArray dp (VU.length volumeVec, x)
        return $ if num <= maxVolume then x else acc
    )
    0
    [0 .. dpSize]

lcsTable :: BS.ByteString -> BS.ByteString -> V.Vector (VU.Vector Int)
lcsTable xs ys = V.scanl step (VU.replicate (m + 1) 0) xs'
  where
    n = BS.length xs
    m = BS.length ys
    xs' = V.generate n $ BSC8.index xs :: V.Vector Char
    ys' = VU.generate m $ BSC8.index ys :: VU.Vector Char
    step :: VU.Vector Int -> Char -> VU.Vector Int
    step v x = VU.scanl innerStep 0 (VU.zip3 v (VU.tail v) ys')
      where
        innerStep :: Int -> (Int, Int, Char) -> Int
        innerStep a (b, c, y)
          | x == y = 1 + b
          | otherwise = max a c

{-
main = do
xs <- BS.getLine
ys <- BS.getLine
print $ VU.last $ V.last $ lcsTable xs ys
-}

myFilter :: (a -> Bool) -> [a] -> ([a], [a])
myFilter _pred [] = ([], [])
myFilter pred (x : xs)
  | pred x = let (l, r) = myFilter pred xs in (x : l, r)
  | otherwise = let (l, r) = myFilter pred xs in (l, x : r)

--UnionFindデータ構造

type UF_PARENT = VUM.IOVector Int

type UF_RANK = VUM.IOVector Int

type UF = (UF_PARENT, UF_RANK)

uf_makeSet :: Int -> IO UF
uf_makeSet n = do
  parent <- VU.thaw $ VU.generate n id
  rank <- VUM.replicate n 0
  return (parent, rank)

uf_union :: UF -> Int -> Int -> IO ()
uf_union unionFind@(parents, ranks) x y = do
  xRoot <- uf_find unionFind x
  yRoot <- uf_find unionFind y

  xRootRank <- VUM.read ranks xRoot
  yRootRank <- VUM.read ranks yRoot
  if
      | xRootRank > yRootRank -> VUM.write parents yRoot xRoot
      | xRootRank < yRootRank -> VUM.write parents xRoot yRoot
      | xRoot /= yRoot -> do
        VUM.write parents yRoot xRoot
        VUM.write ranks xRoot (xRootRank + 1)
      | otherwise -> return ()

uf_find :: UF -> Int -> IO Int
uf_find unionFind@(parents, ranks) x = do
  xParent <- VUM.read parents x
  if xParent == x
    then return x
    else do
      xRootParent <- uf_find unionFind xParent
      VUM.write parents x xRootParent
      return xRootParent

--UnDirectedGraph(無向グラフ)データ構造

type UDG = M.Map Int [Int]

list2UDG :: [(Int, Int)] -> M.Map Int [Int]
list2UDG =
  foldl
    ( \acc x ->
        let lr = M.insertWith (++) (fst x) [snd x] acc
         in M.insertWith (++) (snd x) [fst x] lr
    )
    M.empty