{-# 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           Data.Bits
import           Data.Bool
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC8
import           Data.Char
import           Data.Either
import           Data.Function
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import qualified Data.Heap as H
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           Data.Tuple
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           GHC.Base

main = do
  --aN       <- getI
  --[aA, aB] <- getIL
  --aS       <- getLine
  [aN, aM] <- getIL
  graphIniData <- aclMaxFlowGraph $ (aN * aM + 2 :: Int)
  let s = aN * aM
  let t = aN * aM + 1
  grid <- V.replicateM aN getVUC
  graphIniDataAdd1 <- VU.foldM
    (\acc1 i -> VU.foldM
       (\acc2 j -> let v = i * aM + j
                   in if grid V.! i VU.! j == '#'
                      then return acc2
                      else if even (i + j)
                           then do
                             (m, ret) <- aclMaxFlowAddEdge acc2 s v 1
                             return ret
                           else do
                             (m, ret) <- aclMaxFlowAddEdge acc2 v t 1
                             return ret)
       acc1
       (VU.enumFromN 0 aM))
    graphIniData
    (VU.enumFromN 0 aN)
    :: IO (Int, VM.IOVector (SQ.Seq (Int, Int, Int)), SQ.Seq (Int, Int))
  graphIniDataAdd2@(_, _, pos1) <- VU.foldM
    (\acc1 i -> VU.foldM
       (\acc2 j
        -> let v0 = i * aM + j
           in VU.foldM
                (\acc3 k@(ky, kx)
                 -> let v1 = kx + (ky * aM)
                    in if odd (i + j) || grid V.! i VU.! j == '#'
                       then return acc3
                       else if grid V.! ky VU.! kx == '.'
                            then do
                              (m, ret) <- aclMaxFlowAddEdge acc3 v0 v1 1
                              return ret
                            else return acc3)
                acc2
              $ VU.fromList
              $ aroundSquare i j aN aM)
       acc1
       (VU.enumFromN 0 aM))
    graphIniDataAdd1
    (VU.enumFromN 0 aN)
  graphData@(_, graph, pos2) <- aclMaxFlowConvertIniData graphIniDataAdd2
  {-
  print "graph1"
  V.imapM_
    (\i x -> do
       fx <- VU.freeze x
       print $ show i ++ ":" ++ show fx)
    =<< (V.freeze graph)
    -}
  flow <- aclMaxFlowFlow graphData s t
  print flow
  {-
  print "graph2"
  V.imapM_
    (\i x -> do
       fx <- VU.freeze x
       print $ show i ++ ":" ++ show fx)
    =<< (V.freeze graph)
  -}
  edges <- aclMaxFlowEdges graphData
  --print edges
  --print =<< VU.freeze pos2
  newGrid <- V.thaw =<< (V.generateM aN $ \i -> VU.thaw $ grid V.! i)
  VU.mapM_
    (\e@(from, to, cap, flow) -> do
       if from == s || to == t || flow == 0
         then return ()
         else do
           let i0 = div from aM
               j0 = mod from aM
               i1 = div to aM
               j1 = mod to aM
           newGridI0 <- VM.read newGrid i0
           newGridI1 <- VM.read newGrid i1
           if
             | i0 == i1 + 1 -> do
               VUM.write newGridI1 j1 'v'
               VUM.write newGridI0 j0 '^'
             | j0 == j1 + 1 -> do
               VUM.write newGridI1 j1 '>'
               VUM.write newGridI0 j0 '<'
             | i0 == i1 - 1 -> do
               VUM.write newGridI0 j0 'v'
               VUM.write newGridI1 j1 '^'
             | otherwise -> do
               VUM.write newGridI0 j0 '>'
               VUM.write newGridI1 j1 '<')
    edges
  V.mapM_ (\newGridI -> putStrLn =<< VU.toList <$> VU.freeze newGridI)
    =<< V.freeze newGrid
  return ()

--雑多系
t :: Int -> (Int, Int)
t x = (x, 1)

i def f t = bool t def $ f t

shiftRCnt k = shiftRCntP k 1

shiftRCntP k c = let nk = shiftR k 1
                 in if nk == 0
                    then c
                    else shiftRCntP nk (c + 1)

myVUmap f vu =
  if vu == VU.empty
  then VU.empty
  else VU.unfoldr
    (\x -> let ret = f $ VU.head x
               tailx = VU.tail x
           in if x == VU.empty
              then Nothing
              else if isLeft ret
                   then Just (either id id ret, tailx)
                   else Just (either id id ret, VU.empty))
    vu

myVUmapM f vu =
  if vu == VU.empty
  then return VU.empty
  else VU.unfoldrM
    (\x -> do
       ret <- f $ VU.head x
       let tailx = VU.tail x
       if x == VU.empty
         then return Nothing
         else if isLeft ret
              then return $ Just (either id id ret, tailx)
              else return $ Just (either id id ret, VU.empty))
    vu

myVUmapM_ f vu =
  if vu == VU.empty
  then return ()
  else do
    ret1 <- VU.unfoldrM
      (\x -> do
         ret2 <- f $ VU.head x
         let tailx = VU.tail x
         if x == VU.empty
           then return Nothing
           else if isLeft ret2
                then return $ Just (either id id ret2, tailx)
                else return $ Just (either id id ret2, VU.empty))
      vu
    return ()

myVUfor vu f = myVUmap f vu

myVUforM vu f = myVUmapM f vu

myVUforM_ vu f = myVUmapM_ f vu

myVUfoldl f acc vu =
  if vu == VU.empty
  then return acc
  else do
    let ret = f acc (VU.head vu)
    if isLeft ret
      then myVUfoldl f (either id id ret) (VU.tail vu)
      else return $ either id id ret

myVUfoldr f acc vu =
  if vu == VU.empty
  then return acc
  else do
    let ret = f acc (VU.last vu)
    if isLeft ret
      then myVUfoldr f (either id id ret) (VU.init vu)
      else return $ either id id ret

myVUfoldM f acc vu =
  if vu == VU.empty
  then return acc
  else do
    ret <- f acc (VU.head vu)
    if isLeft ret
      then myVUfoldM f (either id id ret) (VU.tail vu)
      else return $ either id id ret

--周りのマス
aroundSquare y x h w =
  [aYX
  | aYX@(aY, aX)
      <- [(y + a, x + b) | a <- [-1 .. 1], b <- [-1 .. 1], abs a + abs b == 1]
  , aY >= 0
  , aY <= h - 1
  , aX >= 0
  , aX <= w - 1]

--入力系
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

readInteger :: BSC8.ByteString -> Integer
readInteger = fst . fromJust . BSC8.readInteger

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)

readIT3 :: BSC8.ByteString -> (Int, Int, Int)
readIT3 bs = let words = BSC8.words bs
             in (readI $ head words, readI $ words !! 1, readI $ words !! 2)

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

getInteger :: IO Integer
getInteger = readInteger <$> BSC8.getLine

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

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

getIT3 :: IO (Int, Int, Int)
getIT3 = readIT3 <$> 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

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

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) = undefined

  signum (M a) = undefined

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)

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

ufUnion :: UF -> Int -> Int -> IO ()
ufUnion unionFind@(parents, ranks) x y = do
  xRoot <- ufFind unionFind x
  yRoot <- ufFind 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 ()

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

--無向グラフ
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

--有向グラフエッジ情報(コスト付き)
type DGEwC = M.Map Int [(Int, Int, Int)]

--OSA-K法テーブル準備(お酒？)
osaKMethod m = do
  table <- VUM.replicate (m + 1) (0 :: Int) :: IO (VUM.IOVector Int)
  modi table m 2 1 1 (div m 2)
  loopModi table m 3
  VU.freeze table
  where
    loopModi table m x
      | x > m = return ()
      | otherwise = do
        modi table m x 1 2 (div m x)
        loopModi table m (x + 2)

    modi table m x n s nm
      | n > nm = return ()
      | otherwise = do
        let xn = x * n
        target <- VUM.read table xn
        if target == 0
          then do
            VUM.write table xn x
            modi table m x (n + s) s nm
          else if n == 1
               then return ()
               else modi table m x (n + s) s nm

getPrimes osaKTable target = VU.unfoldr
  (\x -> let minPrime = osaKTable VU.! target
             (prime, quo) = if minPrime == 0
                            then (target, 1)
                            else (target, div target minPrime)
         in if x == 1
            then Nothing
            else Just (prime, quo))
  target

--IMOS法1次元用
imosMethodDim1 n lrs = VU.create
  $ do
    table <- VUM.replicate n 0
    VU.mapM_
      (\(l, r) -> do
         VUM.modify table succ $ pred l
         when (r <= n - 1) $ VUM.modify table pred r)
      lrs
    cumTable <- VUM.replicate n 0
    fTable <- VU.freeze table
    VUM.write cumTable 0 $ bool 1 0 $ even (fTable VU.! 0)
    VU.mapM_
      (\x -> do
         pv <- VUM.read cumTable (x - 1)
         VUM.write cumTable x $ bool 1 0 $ even (pv + fTable VU.! x))
      $ VU.enumFromN 1 (n - 1)
    return cumTable

--ベルマンフォード法 最短経路取得(負数が混じる場合は、まずは、負数閉路があるかどうかを調べる。)
bfMethodShortestPath vn edges = do
  table <- VUM.replicate vn maxInt :: IO (VUM.IOVector Int)
  VUM.write table 0 0
  myVUmapM_
    (\v -> do
       flg <- VU.foldM
         (\acc (from, to, cost) -> do
            fromCost <- VUM.read table $ pred from
            toCost <- VUM.read table $ pred to
            if fromCost /= maxInt && toCost > fromCost + cost
              then do
                VUM.write table (pred to) (fromCost + cost)
                return True
              else return acc)
         False
         edges
       if flg
         then return $ Left ()
         else return $ Right ())
    $ VU.enumFromN (0 :: Int) (vn - 1)
  VU.freeze table

{-bfMethodShortestPath vn edges = do
  table <- VUM.replicate vn maxInt
  VUM.write table 0 0
  scanLoop table
  VU.freeze table
  where
    scanLoop table = do
      flg <- VU.foldM
        (\acc (from, to, cost) -> do
           fromCost <- VUM.read table $ pred from
           toCost <- VUM.read table $ pred to
           if fromCost /= maxInt && toCost > fromCost + cost
             then do
               VUM.write table (pred to) (fromCost + cost)
               return $ True
             else return $ acc)
        False
        edges
      if flg
        then scanLoop table
        else return ()
-}
--ベルマンフォード法 負数閉路探索
bfMethodFindNegativeLoop vn edges = do
  table <- VUM.replicate vn 0 :: IO (VUM.IOVector Int)
  VU.mapM_
    (\v -> VU.mapM_
       (\(from, to, cost) -> do
          fromCost <- VUM.read table $ pred from
          toCost <- VUM.read table $ pred to
          when (toCost > fromCost + cost)
            $ VUM.write table (pred to) (fromCost + cost))
       edges)
    $ VU.enumFromN (0 :: Int) (vn - 1)
  myVUfoldM
    (\acc (from, to, cost) -> do
       fromCost <- VUM.read table $ pred from
       toCost <- VUM.read table $ pred to
       if toCost > fromCost + cost
         then do
           VUM.write table (pred to) (fromCost + cost)
           return $ Right True
         else return $ Left False)
    False
    edges

--ベルマンフォード法 負数閉路影響調査
bfMethodScanNegativeLoop vn edges = do
  table <- VUM.replicate vn 0 :: IO (VUM.IOVector Int)
  rTable <- VUM.replicate vn False :: IO (VUM.IOVector Bool)
  VU.mapM_
    (\v -> VU.mapM_
       (\(from, to, cost) -> do
          fromCost <- VUM.read table $ pred from
          toCost <- VUM.read table $ pred to
          when (toCost > fromCost + cost)
            $ VUM.write table (pred to) (fromCost + cost))
       edges)
    $ VU.enumFromN (0 :: Int) (vn - 1)
  VU.foldM_
    (\acc (from, to, cost) -> do
       fromCost <- VUM.read table $ pred from
       toCost <- VUM.read table $ pred to
       if toCost > fromCost + cost
         then do
           VUM.write table (pred to) (fromCost + cost)
           VUM.write rTable (pred to) True
           return True
         else return False)
    False
    edges
  VU.freeze rTable

--DijkstraMethod 壊れてるっぽい
dijkstraMethod :: Int -> DGEwC -> Int -> IO (VU.Vector Int)
dijkstraMethod n edges s = do
  table <- VUM.replicate n maxInt :: IO (VUM.IOVector Int)
  VUM.write table (pred s) 0
  let heap = H.insert (0, s) H.empty
  mfs table heap
  VU.freeze table
  where
    mfs table heap =
      if heap == H.empty
      then return ()
      else do
        let (hCost, hTo) = H.minimum heap
        toCost <- VUM.read table (pred hTo)
        let toEdges = M.findWithDefault [] hTo edges
        if toCost >= hCost
          then do
            accHeap <- foldM
              (\acc (eFrom, eTo, eCost) -> do
                 totoCost <- VUM.read table (pred eTo)
                 if totoCost > (toCost + eCost)
                   then do
                     VUM.write table (pred eTo) (toCost + eCost)
                     return $ H.insert (toCost + eCost, eTo) acc
                   else return acc)
              (H.deleteMin heap)
              toEdges
            mfs table accHeap
          else mfs table (H.deleteMin heap)

--BinarySearchっぽいもの 1からmまでのすべての数値をFにいれたとき最初にTrueになる数値を見つける。
binarySearchFirstTrueSerialASC f m =
  binarySearchFirstTrueSerialASCP f 0 (m + 1)

binarySearchFirstTrueSerialASCP f l r =
  let i = l + div (r - l) 2
      test = f i
  in if
       | test && i - l == 1 -> i
       | test && i - l /= 1 -> binarySearchFirstTrueSerialASCP f l i
       | not test && r - i == 1 -> r
       | otherwise -> binarySearchFirstTrueSerialASCP f i r

--BinarySearchっぽいもの その２ vuiのすべての数値をFにいれたとき最初にTrueになる数値を見つける。
binarySearchFirstTrueList f vui = let lenl = VU.length vui
                                  in binarySearchFirstTrueListP f vui (-1) lenl

binarySearchFirstTrueListP f vui l r =
  let i = l + div (r - l) 2
      test = f (vui VU.! i)
  in if
       | test && i - l == 1 -> i
       | test && i - l /= 1 -> binarySearchFirstTrueListP f vui l i
       | not test && r - i == 1 -> r
       | otherwise -> binarySearchFirstTrueListP f vui i r

--MaxHeap関連
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

----ACL(AtCoder Library)のHaskell移植版(おっさんたたき台Ver.))
---DSU
aclDsuTable n = do
  parentOrSize <- VUM.replicate n (-1)
  return (n, parentOrSize)

aclDsuMerge table@(n, parentOrSize) a b
  | a < 0 || n <= a = error
    "aclDsuMerge:aを0以上でnより小さい値になるように見直してください。"
  | b < 0 || n <= b = error
    "aclDsuMerge:bを0以上でnより小さい値になるように見直してください。"
  | otherwise = do
    x <- aclDsuLeader table a
    y <- aclDsuLeader table b
    if x == y
      then return x
      else do
        posX <- VUM.read parentOrSize x
        posY <- VUM.read parentOrSize y
        if -posX < -posY
          then do
            VUM.write parentOrSize y (posY + posX)
            VUM.write parentOrSize x y
            return y
          else do
            VUM.write parentOrSize x (posX + posY)
            VUM.write parentOrSize y x
            return x

aclDsuSame table@(n, parentOrSize) a b
  | a < 0 && n <= a = error
    "aclDsuSame:aを0以上でnより小さい値になるように見直してください。"
  | b < 0 && n <= b = error
    "aclDsuSame:bを0以上でnより小さい値になるように見直してください。"
  | otherwise = do
    x <- aclDsuLeader table a
    y <- aclDsuLeader table b
    return $ x == y

aclDsuLeader table@(n, parentOrSize) a
  | a < 0 && n <= a = error
    "aclDsuLeader:aを0以上でnより小さい値になるように見直してください。"
  | otherwise = do
    posA <- VUM.read parentOrSize a
    if posA < 0
      then return a
      else do
        x <- aclDsuLeader table posA
        VUM.write parentOrSize a x
        return x

aclDsuSize table@(n, parentOrSize) a
  | a < 0 && n <= a = error
    "aclDsuSize:aを0以上でnより小さい値になるように見直してください。"
  | otherwise = do
    x <- aclDsuLeader table a
    negate <$> VUM.read parentOrSize x

aclDsuGroup table@(n, parentOrSize) = do
  leaderBuf <- VUM.replicate n 0
  groupSize <- VUM.replicate n 0
  VU.forM_ (VU.enumFromN 0 n)
    $ \i -> do
      leaderI <- aclDsuLeader table i
      VUM.write leaderBuf i leaderI
      VUM.modify groupSize succ leaderI
  resultTmpIndex <- VUM.replicate n 0
  resultTmp <- V.generateM n
    $ \i -> do
      gs <- VUM.read groupSize i
      VUM.replicate gs 0
  VU.forM_ (VU.enumFromN 0 n)
    $ \i -> do
      leaderI <- VUM.read leaderBuf i
      tmpIndex <- VUM.read resultTmpIndex leaderI
      VUM.write (resultTmp V.! leaderI) tmpIndex i
      VUM.modify resultTmpIndex succ leaderI
  V.mapMaybe id
    <$> V.mapM
      (\i -> do
         rti <- VU.freeze $ resultTmp V.! i
         if rti == VU.empty
           then return Nothing
           else return $ Just rti)
      (V.enumFromN 0 n)

---Fenwick Tree
aclFenwickTreeData n = do
  ftData <- VUM.replicate n 0
  return (n, ftData)

--TODO:元のコード読めない。。。これでいいんだろうか。。。
aclFenwickTreeAdd ftData@(n, ft) p x
  | p < 0 || n <= p = error
    "aclFenwickTreeAdd:pを0以上でnより小さい値になるように見直してください。"
  | otherwise = aloop ft (p + 1)
  where
    aloop ft p
      | p > n = return ()
      | otherwise = do
        VUM.modify ft (+ x) (p - 1)
        aloop ft (p + (p .&. (-p)))

aclFenwickTreeSum ftData@(n, ft) l r
  | l < 0 || l > r || r > n = error
    "aclFenwickTreeSum:l rを0以上でnより小さい且つ、lがr以下の値になるように見直してください。"
  | otherwise = (-) <$> psum ft r <*> psum ft l
  where
    psum ft r = aloop ft r 0

    aloop ft r s
      | r <= 0 = return s
      | otherwise = do
        ftr <- VUM.read ft (r - 1)
        aloop ft (r - (r .&. (-r))) (s + ftr)

---Math
--TODO:未テスト
aclMathPowMod x n m
  | n < 0 = error
    "aclMathPowMod:nを0以上の値になるように見直してください。"
  | m < 1 = error
    "aclMathPowMod:mを1以上の値になるように見直してください。"
  | otherwise = if m == 1
                then 0
                else aloop n 1 (aclMathInternalSafeMod x m)
  where
    aloop n r y
      | n == 0 = return r
      | otherwise = if (n .&. 1) /= 0
                    then aloop (shiftR n 1) (mul m r y) (mul m y y)
                    else aloop (shiftR n 1) r (mul m y y)

    mul m a b = let im = div (-1) m + 1
                    z = a * b
                    x = shiftR (z * im) 64
                    v = z - x * m
                in if m <= v
                   then v + m
                   else v

--TODO:未テスト
aclMathInternalSafeMod x m =
  let nx = mod x m
  in if nx < 0
     then nx + m
     else nx

--TODO:未テスト
aclMathInvMod x m
  | m < 1 = error
    "aclMathInvMod:mを1以上の値になるように見直してください。"
  | otherwise = let z = aclMathInternalInvGcd x m
                in if fst z == 1
                   then 
                     --TODOエラーメッセージ見直し。
                     error "aclMathInvMod:値を見直してください。"
                   else snd z

--TODO:未テスト
aclMathInternalInvGcd a b =
  let na = aclMathInternalSafeMod a b
      (s, t, m0, m1) = aloop b a 0 1
  in if a == 0
     then (b, 0)
     else if m0 < 0
          then (s, m0 + div b s)
          else (s, m0)
  where
    aloop s t m0 m1
      | t == 0 = (s, t, m0, m1)
      | otherwise = let u = div s t
                    in aloop t (s - t * u) m1 (m0 - m1 * u)

--TODO:未テスト
aclMathCrt r m
  | VU.length r /= VU.length m =
    error "aclMathCrt:r mの配列サイズを見直してください。"
  | otherwise = let n = VU.length r
                in aloop r m 0 0 1
  where
    aloop r m i r0 m0
      | i >= VU.length r = (r0, m0)
      | m VU.! i < 1 = error
        "aclMathCrt:mを1以上の値になるように見直してください。"
      | otherwise = let r1 = aclMathInternalSafeMod (r VU.! i) (m VU.! i)
                        m1 = m VU.! i
                    in if m0 >= m1
                       then amethod r m i r0 r1 m0 m1
                       else amethod r m i r1 r0 m1 m0

    amethod r m i r0 r1 m0 m1 =
      let (g, im) = aclMathInternalInvGcd m0 m1
          u1 = div m1 g
          x = mod (mod (div (r1 - r0) g) u1 * im) u1
          nr0 = r0 + x * m0
          nm0 = m0 * u1
      in if mod m0 m1 == 0
         then if mod r0 m1 /= r1
              then (0, 0)
              else aloop r m (i + 1) r0 m0
         else if mod (r1 - r0) g /= 0
              then (0, 0)
              else if nr0 < 0
                   then aloop r m (i + 1) (nr0 + nm0) nm0
                   else aloop r m (i + 1) nr0 nm0

aclMathFloorSum n m a b =
  let (ans1, a1) = am 0 n m a
      (ans2, b1) = bm ans1 n m b
      yMax = div (a1 * n + b1) m
      xMax = yMax * m - b1
  in if yMax == 0
     then ans2
     else ans2
       + (n - div (xMax + a1 - 1) a1) * yMax
       + aclMathFloorSum yMax a1 m (mod (a1 - mod xMax a1) a1)
  where
    am ans n m a = if a >= m
                   then (div ((n - 1) * n * div a m) 2, mod a m)
                   else (ans, a)

    bm ans n m b = if b >= m
                   then (ans + n * div b m, mod b m)
                   else (ans, b)

---MaxFlow
{-aclMaxFlowGraph n = (,,) n <$> VM.replicateM n (VUM.replicate 0 (0, 0, 0))
  <*> VU.thaw VU.empty
-}
aclMaxFlowGraph
  :: Int -> IO (Int, VM.IOVector (SQ.Seq (Int, Int, Int)), SQ.Seq (Int, Int))
aclMaxFlowGraph n = do
  graphIni <- VM.replicate n (SQ.empty)
  return (n, graphIni, SQ.empty)

aclMaxFlowAddEdge
  :: (Int, VM.IOVector (SQ.Seq (Int, Int, Int)), SQ.Seq (Int, Int))
  -> Int
  -> Int
  -> Int
  -> IO (Int, (Int, VM.IOVector (SQ.Seq (Int, Int, Int)), SQ.Seq (Int, Int)))
aclMaxFlowAddEdge graphIniData@(iniN, iniGraph, iniPos) from to cap = if
  | from < 0 || iniN <= from -> error
    "aclMaxFlowAddEdge:fromを0以上nより小さい値になるように見直してください。"
  | to < 0 || iniN <= to -> error
    "aclMaxFlowAddEdge:toを0以上nより小さい値になるように見直してください。"
  | cap < 0 -> error
    "aclMaxFlowAddEdge:capを0以上の値になるように見直してください。"
  | otherwise -> do
    let m = SQ.length iniPos
    graphFrom <- VM.read iniGraph from
    graphTo <- VM.read iniGraph to
    let graphFromSize = SQ.length graphFrom
    let graphToSize = SQ.length graphTo
    VM.write iniGraph from (graphFrom SQ.|> (to, graphToSize, cap))
    VM.write iniGraph to (graphTo SQ.|> (from, graphFromSize, 0))
    return (m, (iniN, iniGraph, iniPos SQ.|> (from, graphFromSize)))

aclMaxFlowConvertIniData
  :: (Int, VM.IOVector (SQ.Seq (Int, Int, Int)), SQ.Seq (Int, Int))
  -> IO
    (Int, VM.IOVector (VUM.IOVector (Int, Int, Int)), VUM.IOVector (Int, Int))
aclMaxFlowConvertIniData graphIniData@(iniN, iniGraph, iniPos) = do
  graph <- V.thaw
    =<< (V.generateM
           iniN
           (\i -> do
              seq <- VM.read iniGraph i
              VU.thaw
                $ VU.unfoldr
                  (\x -> let (s SQ.:< sn) = SQ.viewl x
                         in if x == SQ.empty
                            then Nothing
                            else Just (s, sn))
                  seq))
  pos <- VU.thaw
    $ VU.unfoldr
      (\x -> let (s SQ.:< sn) = SQ.viewl x
             in if x == SQ.empty
                then Nothing
                else Just (s, sn))
      iniPos
  return (iniN, graph, pos)

                                                                                     --TODO:可変長の可変データどうやって持とう？時間かかりすぎなので最後に見直す。
                                                                                     {-aclMaxFlowAddEdge graphData from to cap =
  aclMaxFlowAddAllEdges graphData $ VU.singleton (from, to, cap)

bkaclMaxFlowAddAllEdges graphData@(n, graph, pos) edges = do
  (addPos, addGraphMap) <- VU.foldM
    (\acc@(accPos, accGraphMap) edge@(from, to, cap) -> if
       | from < 0 || n <= from -> error
         "aclMaxFlowAddEdge:fromを0以上nより小さい値になるように見直してください。"
       | to < 0 || n <= to -> error
         "aclMaxFlowAddEdge:toを0以上nより小さい値になるように見直してください。"
       | cap < 0 -> error
         "aclMaxFlowAddEdge:capを0以上の値になるように見直してください。"
       | otherwise -> do
         gFrom <- VM.read graph from
         gTo <- VM.read graph to
         let gFromSize = VUM.length gFrom
             gToSize = VUM.length gTo
             accGFrom = M.findWithDefault [] from accGraphMap
             accGTo = M.findWithDefault [] to accGraphMap
             accGFromSize = length accGFrom
             accGToSize = length accGTo
             sumGFromSize = gFromSize + accGFromSize
             sumGToSize = gToSize + accGToSize
         return
           ( (from, sumGFromSize):accPos
           , M.insert
               to
               ((from, sumGFromSize, 0):accGTo)
               (M.insert from ((to, sumGToSize, cap):accGFrom) accGraphMap)))
    ([], M.empty)
    edges
  nGraph <- V.thaw
    =<< V.mapM
      (\i -> do
         oGraph <- VU.freeze =<< VM.read graph i
         let nGraph = oGraph
               VU.++ (VU.fromList
                      $ reverse (M.findWithDefault [] i addGraphMap))
         VU.thaw nGraph)
      (V.enumFromN 0 n)
  nPos <- VU.thaw =<< ((VU.++ VU.fromList addPos) <$> VU.freeze pos)
  return (n, nGraph, nPos)
-}
aclMaxFlowGetEdge graphData@(n, graph, pos) i =
  let m = VUM.length pos
  in if i < 0 || m <= i
     then error
       "aclMaxFlowAddEdge:iを0以上mより小さい値になるように見直してください。"
     else do
       posi <- VUM.read pos i
       graphi <- VM.read graph (fst posi)
       e@(eTo, eRev, eCap) <- VUM.read graphi (snd posi)
       graphTo <- VM.read graph eTo
       re@(reTo, reRev, reCap) <- VUM.read graphTo eRev
       return (fst posi, eTo, eCap + reCap, reCap)

aclMaxFlowEdges graphData@(n, graph, pos) =
  let m = VUM.length pos
  in VU.mapM (aclMaxFlowGetEdge graphData) $ VU.enumFromN 0 m

aclMaxFlowChangeEdge graphData@(n, graph, pos) i newCap newFlow = do
  let m = VUM.length pos
  if i < 0 || m <= i
    then error
      "aclMaxFlowAddEdge:iを0以上mより小さい値になるように見直してください。"
    else do
      posi <- VUM.read pos i
      graphA <- VM.read graph (fst posi)
      e@(eTo, eRev, eCap) <- VUM.read graphA (snd posi)
      graphB <- VM.read graph eTo
      re@(reTo, reRev, reCap) <- VUM.read graphB eRev
      return ()

aclMaxFlowFlow graphData@(n, graph, pos) s t =
  aclMaxFlowFlowLimit graphData s t maxInt

aclMaxFlowFlowLimit graphData@(n, graph, pos) s t flowLimit
  | s < 0 || n <= s = error
    "aclMaxFlowFlow:sを0以上nより小さい値になるように見直してください。"
  | t < 0 || n <= t = error
    "aclMaxFlowFlow:tを0以上nより小さい値になるように見直してください。"
  | otherwise = do
    levelIni <- VUM.replicate n (-1) :: IO (VUM.IOVector Int)
    iter <- VUM.replicate n (0) :: IO (VUM.IOVector Int)
    aloop graph levelIni iter 0
  where
    aloop graph levelIni iter flow =
      if flow >= flowLimit
      then return flow
      else do
        VU.mapM_ (\i -> VUM.write levelIni i (-1)) $ VU.enumFromN 0 n
        VUM.write levelIni s 0
        level <- bfs graph levelIni (SQ.singleton s)
        levelt <- VUM.read level t
        if levelt == -1
          then return flow
          else do
            VU.mapM_ (\i -> VUM.write iter i (0)) $ VU.enumFromN 0 n
            nFlow <- bloop graph level iter flow
            aloop graph levelIni iter nFlow

    bfs graph level sq
      | sq == SQ.empty = return level
      | otherwise = do
        let (sqh SQ.:< sqt) = SQ.viewl sq
        edges <- VM.read graph sqh
        nSq <- cloop level edges 0 sqh sqt
        bfs graph level nSq

    cloop level edges i v sqt = do
      if i >= VUM.length edges
        then return sqt
        else do
          edge@(to, rev, cap) <- VUM.read edges i
          levelTo <- VUM.read level to
          if cap == 0 || levelTo >= 0
            then cloop level edges (i + 1) v sqt
            else do
              levelv <- VUM.read level v
              VUM.write level to (levelv + 1)
              if to == t
                then return SQ.empty
                else cloop level edges (i + 1) v (to SQ.<| sqt)

    bloop graph level iter flow
      | flow >= flowLimit = return flow
      | otherwise = do
        f <- if t == s
             then return (flowLimit - flow)
             else do
               levelV <- VUM.read level t
               graphV <- VM.read graph t
               dfs graph graphV level 0 levelV t iter (flowLimit - flow) 0
        if f == 0
          then return flow
          else bloop graph level iter (flow + f)

    dfs graph graphV level i levelV v iter up res = do
      let lenGraphV = VUM.length graphV
      if i >= lenGraphV
        then return res
        else do
          edge@(to, rev, cap) <- VUM.read graphV i
          levelTo <- VUM.read level to
          graphTo <- VM.read graph to
          graphToRev@(nTo, nRev, nCap) <- VUM.read graphTo rev
          if levelV <= levelTo || nCap == 0
            then do
              VUM.modify iter succ v
              dfs graph graphV level (i + 1) levelV v iter up res
            else do
              d <- if to == s
                   then do
                     return (min (up - res) nCap)
                   else do
                     ni <- VUM.read iter to
                     dfs
                       graph
                       graphTo
                       level
                       ni
                       levelTo
                       to
                       iter
                       (min (up - res) nCap)
                       0
              if d <= 0
                then do
                  VUM.modify iter succ v
                  dfs graph graphV level (i + 1) levelV v iter up res
                else do
                  edge@(to2, rev2, cap2) <- VUM.read graphV i
                  graphToRev@(nTo2, nRev2, nCap2) <- VUM.read graphTo rev
                  VUM.write graphV i (to2, rev2, cap2 + d)
                  VUM.write graphTo rev (nTo2, nRev2, nCap2 - d)
                  let nres = res + d
                  if nres == up
                    then return nres
                    else do
                      VUM.modify iter succ v
                      dfs graph graphV level (i + i) levelV v iter up nres

aclMaxFlowMinCut graphData@(n, graph, pos) s = do
  visited <- VUM.replicate n False
  let sq = SQ.singleton s
  aloop visited sq
  VU.freeze visited
  where
    aloop visited sq
      | sq == SQ.empty = return ()
      | otherwise = do
        let (sqh SQ.:< sqt) = SQ.viewl sq
        VUM.write visited sqh True
        edges <- VM.read graph sqh
        bloop visited edges 0 sq

    bloop visited edges i sq = do
      edge@(to, rev, cap) <- VUM.read edges i
      visitedTo <- VUM.read visited to
      if cap /= 0 && visitedTo == False
        then do
          VUM.write visited to True
          bloop visited edges i (to SQ.<| sq)
        else bloop visited edges i sq
---MinCostFlow後回し
---Convolution

Measured memory_bytes: 29256