Valera has got a rectangle table consisting of n rows and m columns. Valera numbered the table rows starting from one, from top to bottom and the columns – starting from one, from left to right. We will represent cell that is on the intersection of row x and column y by a pair of integers (x, y).Valera wants to place exactly k tubes on his rectangle table. A tube is such sequence of table cells (x1, y1), (x2, y2), ..., (xr, yr), that:   r ≥ 2;  for any integer i (1 ≤ i ≤ r - 1) the following equation |xi - xi + 1| + |yi - yi + 1| = 1 holds;  each table cell, which belongs to the tube, must occur exactly once in the sequence. Valera thinks that the tubes are arranged in a fancy manner if the following conditions are fulfilled:   no pair of tubes has common cells;  each cell of the table belongs to some tube. Help Valera to arrange k tubes on his rectangle table in a fancy manner.

The first line contains three space-separated integers n, m, k (2 ≤ n, m ≤ 300; 2 ≤ 2k ≤ n·m) — the number of rows, the number of columns and the number of tubes, correspondingly.

Print k lines. In the i-th line print the description of the i-th tube: first print integer ri (the number of tube cells), then print 2ri integers xi1, yi1, xi2, yi2, ..., xiri, yiri (the sequence of table cells). If there are multiple solutions, you can print any of them. It is guaranteed that at least one solution exists.

NotePicture for the first sample:   Picture for the second sample:

import Data.List

main = interact $ unlines . map (unwords . map show) . getAns . map read . words

getAns :: [Int] -> [[Int]]
getAns (n:m:k:_) = splitPath k $ getPath n m 1

getPath :: Int -> Int -> Int -> [Int]
getPath n m x =
	let tys = if even x then [m,m-1..1] else [1..m]
	    txys = foldr (\a ax -> x:a:ax) [] tys
	in if (x > n) then [] else txys ++ getPath n m (x + 1)

splitPath :: Int -> [Int] -> [[Int]]
splitPath _ [] = []
splitPath 1 xs = ((div (length xs) 2) : xs) : []
splitPath k xs =
	let sp = splitAt 4 xs
	    ft = fst sp
	    st = snd sp
	in (2 : ft) : splitPath (k - 1) st

import Data.List

main = interact $ unlines . map (unwords . map show) . getAns . map read . words

getAns :: [Int] -> [[Int]]
getAns (n:m:k:_) = splitPath k $ getPath n m 1 1

getPath :: Int -> Int -> Int -> Int -> [Int]
getPath n m x y =
	let ty = if x `mod` 2 == 0 then y - 1 else y + 1
	    nx = if ty > m || ty <= 0 then x + 1 else x
	    ny = if ty <= m && ty > 0 then ty else y
	in if (x > n) then [] else x:y:getPath n m nx ny

splitPath :: Int -> [Int] -> [[Int]]
splitPath _ [] = []
splitPath 1 xs = ((div (length xs) 2) : xs) : []
splitPath k xs =
	let sp = splitAt 4 xs
	    ft = fst sp
	    st = snd sp
	in (2 : ft) : splitPath (k - 1) st

import Control.Monad

rth :: Int -> Int -> Int -> (Int,Int)
rth n m r =
  if t >= m then (i0+1+1, 2*m-t) else (i0+1,t+1)
  where (q,t) = divMod (r-1) (2*m)
        i0 = 2*q

showPair (i,j) = show i ++ " " ++ show j

showPairs pairs = show (length pairs) ++ " " ++ (unwords (map showPair pairs))

main = do
  (n:m:tubes:_) <- fmap (map read . words) getLine
  forM_ [1..tubes-1] $ \k -> do
    putStrLn $ showPairs $ map (rth n m) [2*k-1, 2*k]
  let cnt = n*m-2*(tubes-1)
  putStr $ show cnt ++ " "
  forM_ [2*tubes-1..n*m] $ \r -> do
    putStr $ showPair (rth n m r) ++ " "
  putStrLn ""

module Main where

pinput:: String -> [Int]
pinput = map read . words

poutput:: [[(Int, Int)]] -> String
poutput o = unlines (map poneoutput o) where
    prest ((x, y):xs)  = x : y : prest xs
    prest [] = []
    poneoutput t = unwords $ map show (length t : prest t)

-- Solution starts here
snake:: Int -> Int -> [(Int, Int)]
snake nrow ncol = loop 1 1 1 where
    loop row col dir
        | row == (nrow + 1) = []
        | col == ncol && dir == 1 = (row, col) : loop (row + 1) col (-1)
        | col == 1 && dir == -1 = (row, col) : loop (row + 1) col 1
        | otherwise = (row, col) : loop row (col + dir) dir

solve:: [Int] -> [[(Int, Int)]]
solve [nrow, ncol, tubes] = slice (snake nrow ncol) (nrow * ncol) where
    step = (nrow * ncol) `div` tubes
    slice [] _ = []
    slice xs m = if m  == step + (nrow * ncol) `mod` tubes
                   then take (length xs) xs : slice [] 0
                   else take step xs : slice (drop step xs) (m - step)
solve _ = undefined

main :: IO ()
main = do
        l <- getLine
        putStrLn $ poutput $ solve $ pinput l

main=interact$unlines.map(unwords.map show.addLen2).solve.map read.words

addLen2 :: [Int] -> [Int]
addLen2 xs = length xs`div`2 : xs

solve :: [Int] -> [[Int]]
solve [n,m,k] = slices 4 xs ++ [ys]
   where
     (xs,ys) = splitAt (4*(k-1)) cells
     cells = do
       x <- [1..n]
       if odd x then [1..m]>>= \y->[x,y]
       else [m,m-1..1]>>= \y->[x,y]

slices :: Int -> [a] -> [[a]]
slices n xs = map(take n).takeWhile(not.null) $ iterate(drop n)xs

module Main where

main :: IO ()
main = do
  interact $ output . solve . input

solve :: (Int, Int, Int) -> [[(Int, Int)]]
solve (n, m, k) = slice k $ zigZag n m

slice :: Int -> [a] -> [[a]]
slice 1 xs = [xs]
slice k (x:y:xs) = [x, y] : slice (k - 1) xs

zigZag :: Int -> Int -> [(Int, Int)]
zigZag n m =
    [ (r, c)
    | r <- [1..n],
      c <- (if odd r then id else reverse) [1..m]
    ]

input :: String -> (Int, Int, Int)
input str = (n, m, k)
  where
    n = read nS
    m = read mS
    k = read kS
    [nS, mS, kS] = words str

output :: [[(Int, Int)]] -> String
output tubes =
    unlines
        [ unwords $ show (length tube) :
            [ show x ++ " " ++ show y
            | (x, y) <- tube
            ]
        | tube <- tubes
        ]

import Data.List

main = interact $ unlines . map (unwords . map show) . getAns . map read . words

getAns :: [Int] -> [[Int]]
getAns (n:m:k:_) = splitPath (n * m `div` k * 2) $ getPath n m 1 1

getPath :: Int -> Int -> Int -> Int -> [Int]
getPath n m x y =
	let ty = if x `mod` 2 == 0 then y - 1 else y + 1
	    nx = if ty > m || ty <= 0 then x + 1 else x
	    ny = if ty <= m && ty > 0 then ty else y
	in if (x > n) then [] else x:y:getPath n m nx ny

splitPath :: Int -> [Int] -> [[Int]]
splitPath _ [] = []
splitPath k xs =
	let sp = splitAt k xs
	    ft = fst sp
	    st = snd sp
	in ((div (length ft) 2) : ft) : (splitPath k st)

import Control.Monad

rth :: Int -> Int -> Int -> (Int,Int)
rth n m r =
  if t >= m then (i0+1+1, 2*m-t) else (i0+1,t+1)
  where (q,t) = divMod (r-1) (2*m)
        i0 = 2*q

showPair (i,j) = show i ++ " " ++ show j

main = do
  (n:m:tubes:_) <- fmap (map read . words) getLine
  forM_ [1..tubes-1] $ \k -> do
    putStrLn $ "1 " ++ showPair (rth n m k)
  let cnt = n*m-tubes+1
  putStr $ show cnt ++ " "
  forM_ [tubes..n*m] $ \r -> do
    putStr $ showPair (rth n m r) ++ " "
  putStrLn ""

module Main where

pinput:: String -> [Int]
pinput = map read . words

poutput:: [[(Int, Int)]] -> String
poutput o = unlines (map poneoutput o) where
    prest ((x, y):xs)  = x : y : prest xs
    prest [] = []
    poneoutput t = unwords $ map show (length t : prest t)

-- Solution starts here
snake:: Int -> Int -> [(Int, Int)]
snake nrow ncol = loop 1 1 1 where
    loop row col dir
        | row == (nrow + 1) = []
        | col == ncol && dir == 1 = (row, col) : loop (row + 1) col (-1)
        | col == 1 && dir == -1 = (row, col) : loop (row + 1) col 1
        | otherwise = (row, col) : loop row (col + dir) dir

solve:: [Int] -> [[(Int, Int)]]
solve [nrow, ncol, tubes] = slice (snake nrow ncol) where
    step = (nrow * ncol) `div` tubes
    slice [] = []
    slice xs = take step xs : slice (drop step xs)
solve _ = undefined

main :: IO ()
main = do
        l <- getLine
        putStrLn $ poutput $ solve $ pinput l


Monocarp is playing Minecraft and wants to build a wall of cacti. He wants to build it on a field of sand of the size of $$$n \times m$$$ cells. Initially, there are cacti in some cells of the field. Note that, in Minecraft, cacti cannot grow on cells adjacent to each other by side — and the initial field meets this restriction. Monocarp can plant new cacti (they must also fulfil the aforementioned condition). He can't chop down any of the cacti that are already growing on the field — he doesn't have an axe, and the cacti are too prickly for his hands.Monocarp believes that the wall is complete if there is no path from the top row of the field to the bottom row, such that:   each two consecutive cells in the path are adjacent by side;  no cell belonging to the path contains a cactus. Your task is to plant the minimum number of cacti to build a wall (or to report that this is impossible).

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^3$$$) — number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$2 \le n, m \le 2 \cdot 10^5$$$; $$$n \times m \le 4 \cdot 10^5$$$) — the number of rows and columns, respectively. Then $$$n$$$ rows follow, $$$i$$$-th row contains a string $$$s_i$$$ of length $$$m$$$, where $$$s_{i, j}$$$ is '#', if a cactus grows at the intersection of the $$$i$$$-th row and the $$$j$$$-th column. Otherwise, $$$s_{i, j}$$$ is '.'. The sum of $$$n \times m$$$ over all test cases does not exceed $$$4 \cdot 10^5$$$.

For each test case, print NO in the first line if it is impossible to build a cactus wall without breaking the rules. Otherwise, print YES in the first line, then print $$$n$$$ lines of $$$m$$$ characters each — the field itself, where the $$$j$$$-th character of the $$$i$$$-th line is equal to '#', if there is a cactus on the intersection of the $$$i$$$-th row and the $$$j$$$-th column, otherwise it is '.'. If there are multiple optimal answers, print any of them.

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T
import qualified Control.Monad.Trans.Maybe as MT

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

whileM :: (Monad m) => m Bool -> m () -> m ()
whileM f m = do
    t <- f
    M.when t $ do
        m
        whileM f m

iterateWhileM :: (Monad m) => (a -> Bool) -> a -> (a -> m a) -> m [a]
iterateWhileM check x f = do
    y <- f x
    (x:) <$> if check x
        then iterateWhileM check y f
        else M.return []

{- END OF GENERAL -}

-- Ugh...
solve :: (Int, Int) -> UA.UArray (Int, Int) Char -> Maybe (UA.UArray (Int, Int) Char)
solve (n, m) as = ST.runST solve'
    where
        solve' :: ST.ST s (Maybe (UA.UArray (Int, Int) Char))
        solve' = MT.runMaybeT $ do
            distances <- (T.lift $ MA.newArray ((1, 1), (n, m)) Nothing) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Maybe Int))
            backtrack <- (T.lift $ MA.newArray ((0, 0), (n, m)) (0, 0)) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Int, Int))

            let canPut (i, j) = L.all ((== '.') . (as UA.!)) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
                diffCostAt  = fromEnum . (== '.') . (as UA.!)

            T.lift $ flip S.evalStateT (S.empty :: S.Set (Int, (Int, Int))) $ do
                M.forM_ [1 .. n] $ \i -> do
                    let index = (i, 1)
                    let distance = diffCostAt index
                    M.when (canPut index) $ do
                        T.lift $ MA.writeArray distances index $ Just distance
                        S.modify $ S.insert (distance, index)

                whileM (S.gets (not . S.null)) $ do
                    k@(distance, index@(i, j)) <- S.gets S.findMin
                    S.modify S.deleteMin

                    currentDistance <- T.lift $ MA.readArray distances index

                    let ok = (MB.fromJust currentDistance == distance) && (1 <= i) && (i <= n) && (1 <= j) && (j <= m) && canPut index
                    M.when ok $ do
                        tracingM "index, distance" (index, distance)

                        let nextIndices = [(i + 1, j + 1), (i - 1, j + 1), (i - 1, j - 1), (i + 1, j - 1)]
                        M.forM_ nextIndices $ \nextIndex@(ii, jj) -> do
                            M.when (1 <= ii && ii <= n && 1 <= jj && jj <= m && canPut nextIndex) $ do
                                let nextDistance = distance + diffCostAt nextIndex

                                currentDistance <- T.lift $ MA.readArray distances nextIndex

                                M.when (MB.isNothing currentDistance || MB.fromJust currentDistance > nextDistance) $ do
                                    T.lift $ MA.writeArray distances nextIndex $ Just nextDistance
                                    T.lift $ MA.writeArray backtrack nextIndex $ index
                                    S.modify $ S.insert (nextDistance, nextIndex)

            rightValues <- M.forM [1..n] $ \i -> do
                let index = (i, m)
                distance <- T.lift $ MA.readArray distances index

                return $ tracing "rightValue" (fmap (* (-1)) distance, index)

            let t@(mDistance, index) = L.maximum rightValues
            tracingM "t" t
            distance <- MT.MaybeT . M.return $ mDistance

            backtrackIndices <- T.lift $ iterateWhileM (/= (0, 0)) index $ \index -> do
                nextIndex <- MA.readArray backtrack index
                tracingM "index" index
                tracingM "nextIndex" nextIndex
                return $ nextIndex

            answerArr <- (T.lift $ MA.newListArray ((0, 0), (n + 1, m + 1)) (UA.elems as) ) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) Char)

            M.forM_ backtrackIndices $ \index -> do
                T.lift $ MA.writeArray answerArr index '#'

            T.lift $ MA.freeze answerArr

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        [n, m] <- B8.getLine <&> readIntB8s
        asArr <- IOA.newArray ((0, 0), (n + 1, m + 1)) '.' :: IO (IOA.IOUArray (Int, Int) Char)
        M.forM_ [1 .. n] $ \i -> do
            line <- B8.getLine <&> B8.filter (not . isSpace)
            M.forM_ [1 .. m] $ \j -> do
                MA.writeArray asArr (i, j) $ line `B8.index` (j - 1)
        as <- MA.freeze asArr

        let answer = solve (n, m) as

        case answer of
            Just as -> do
                putsYesNo True
                forM_ [1 .. n] $ \i -> do
                    let line = L.map (\j -> as UA.! (i, j)) [1..m]
                    B8.putStrLn $ B8.pack line
            Nothing -> putsYesNo False

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T
import qualified Control.Monad.Trans.Maybe as MT

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

whileM :: (Monad m) => m Bool -> m () -> m ()
whileM f m = do
    t <- f
    M.when t $ do
        m
        whileM f m

iterateCntM :: (Monad m) => Int -> a -> (a -> m a) -> m [a]
iterateCntM cnt x f = do
    y <- f x
    (x:) <$> if cnt /= 0
        then iterateCntM (cnt - 1) y f
        else M.return []

{- END OF GENERAL -}

-- Ugh...
solve :: (Int, Int) -> UA.UArray (Int, Int) Char -> Maybe (UA.UArray (Int, Int) Char)
solve (n, m) as = ST.runST solve'
    where
        solve' :: ST.ST s (Maybe (UA.UArray (Int, Int) Char))
        solve' = MT.runMaybeT $ do
            distances <- (T.lift $ MA.newArray ((1, 1), (n, m)) Nothing) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Maybe Int))
            backtrack <- (T.lift $ MA.newArray ((0, 0), (n, m)) (0, 0)) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Int, Int))

            let canPut (i, j) = L.all ((== '.') . (as UA.!)) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
                diffCostAt  = fromEnum . (== '.') . (as UA.!)

            T.lift $ flip S.evalStateT (S.empty :: S.Set (Int, (Int, Int), (Int, Int))) $ do
                M.forM_ [1 .. n] $ \i -> do
                    let index = (i, 1)
                    M.when (canPut index) $ do
                        S.modify $ S.insert (diffCostAt index, index, (0, 0))

                whileM (S.gets (not . S.null)) $ do
                    k@(distance, index@(i, j), backtrackIndex) <- S.gets S.findMin
                    S.modify S.deleteMin
                    currentDistance <- T.lift $ MA.readArray distances index

                    let ok = (MB.isNothing currentDistance || MB.fromJust currentDistance > distance) && (1 <= i) && (i <= n) && (1 <= j) && (j <= m) && canPut index
                    M.when ok $ do
                        T.lift $ MA.writeArray distances index $ Just distance
                        T.lift $ MA.writeArray backtrack index backtrackIndex
                        tracingM "index, distance, backtrack" (index, distance, backtrackIndex)

                        let nextIndices = [(i + 1, j + 1), (i - 1, j + 1), (i - 1, j - 1), (i + 1, j - 1)]
                        M.forM_ nextIndices $ \nextIndex@(ii, jj) -> do
                            M.when (1 <= ii && ii <= n && 1 <= jj && jj <= m && canPut nextIndex) $ do
                                let nextDistance = distance + diffCostAt nextIndex
                                S.modify $ S.insert (nextDistance, nextIndex, index)

            rightValues <- M.forM [1..n] $ \i -> do
                let index = (i, m)
                distance <- T.lift $ MA.readArray distances index

                return $ tracing "rightValue" (fmap (* (-1)) distance, index)

            let t@(mDistance, index) = L.maximum rightValues
            tracingM "t" t
            distance <- MT.MaybeT . M.return $ mDistance

            backtrackPath <- T.lift $ iterateCntM (2 * m) index $ \index -> do
                nextIndex <- MA.readArray backtrack index
                tracingM "index" index
                tracingM "nextIndex" nextIndex
                return $ nextIndex

            let backtrackIndices = L.takeWhile (/= (0, 0)) backtrackPath

            answerArr <- (T.lift $ MA.newListArray ((0, 0), (n + 1, m + 1)) (UA.elems as) ) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) Char)

            M.forM_ backtrackIndices $ \index -> do
                T.lift $ MA.writeArray answerArr index '#'

            T.lift $ MA.freeze answerArr

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        [n, m] <- B8.getLine <&> readIntB8s
        asArr <- IOA.newArray ((0, 0), (n + 1, m + 1)) '.' :: IO (IOA.IOUArray (Int, Int) Char)
        M.forM_ [1 .. n] $ \i -> do
            line <- B8.getLine <&> B8.filter (not . isSpace)
            M.forM_ [1 .. m] $ \j -> do
                MA.writeArray asArr (i, j) $ line `B8.index` (j - 1)
        as <- MA.freeze asArr

        let answer = solve (n, m) as

        case answer of
            Just as -> do
                putsYesNo True
                forM_ [1 .. n] $ \i -> do
                    let line = L.map (\j -> as UA.! (i, j)) [1..m]
                    B8.putStrLn $ B8.pack line
            Nothing -> putsYesNo False

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T
import qualified Control.Monad.Trans.Maybe as MT

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

whileM :: (Monad m) => m Bool -> m () -> m ()
whileM f m = do
    t <- f
    M.when t $ do
        m
        whileM f m

iterateCntM :: (Monad m) => Int -> a -> (a -> m a) -> m [a]
iterateCntM cnt x f = do
    y <- f x
    (x:) <$> if cnt /= 0
        then iterateCntM (cnt - 1) y f
        else M.return []

{- END OF GENERAL -}

-- Ugh...
solve :: (Int, Int) -> UA.UArray (Int, Int) Char -> Maybe (UA.UArray (Int, Int) Char)
solve (n, m) as = ST.runST solve'
    where
        solve' :: ST.ST s (Maybe (UA.UArray (Int, Int) Char))
        solve' = MT.runMaybeT $ do
            distances <- (T.lift $ MA.newArray ((1, 1), (n, m)) Nothing) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Maybe Int))
            backtrack <- (T.lift $ MA.newArray ((0, 0), (n, m)) (0, 0)) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Int, Int))

            let canPut (i, j) = L.all ((== '.') . (as UA.!)) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
                diffCostAt  = fromEnum . (== '.') . (as UA.!)

            T.lift $ flip S.evalStateT (S.empty :: S.Set (Int, (Int, Int), (Int, Int))) $ do
                M.forM_ [1 .. n] $ \i -> do
                    let index = (i, 1)
                    M.when (canPut index) $ do
                        S.modify $ S.insert (diffCostAt index, index, (0, 0))

                whileM (S.gets (not . S.null)) $ do
                    k@(distance, index@(i, j), backtrackIndex) <- S.gets S.findMin
                    S.modify S.deleteMin
                    currentDistance <- T.lift $ MA.readArray distances index

                    let ok = (MB.isNothing currentDistance || MB.fromJust currentDistance > distance) && (1 <= i) && (i <= n) && (1 <= j) && (j <= m) && canPut index
                    M.when ok $ do
                        T.lift $ MA.writeArray distances index $ Just distance
                        T.lift $ MA.writeArray backtrack index backtrackIndex
                        tracingM "index, distance, backtrack" (index, distance, backtrackIndex)

                        let nextIndices = [(i + 1, j + 1), (i - 1, j + 1), (i - 1, j - 1), (i + 1, j - 1)]
                        M.forM_ nextIndices $ \nextIndex@(ii, jj) -> do
                            M.when (1 <= ii && ii <= n && 1 <= jj && jj <= m && canPut nextIndex) $ do
                                let nextDistance = distance + diffCostAt nextIndex
                                S.modify $ S.insert (nextDistance, nextIndex, index)

            rightValues <- M.forM [1..n] $ \i -> do
                let index = (i, m)
                distance <- T.lift $ MA.readArray distances index

                return $ tracing "rightValue" (fmap (* (-1)) distance, index)

            let t@(mDistance, index) = L.maximum rightValues
            tracingM "t" t
            distance <- MT.MaybeT . M.return $ mDistance

            backtrackPath <- T.lift $ iterateCntM m index $ \index -> do
                nextIndex <- MA.readArray backtrack index
                tracingM "index" index
                tracingM "nextIndex" nextIndex
                return $ nextIndex

            let backtrackIndices = L.takeWhile (/= (0, 0)) backtrackPath

            answerArr <- (T.lift $ MA.newListArray ((0, 0), (n + 1, m + 1)) (UA.elems as) ) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) Char)

            M.forM_ backtrackIndices $ \index -> do
                T.lift $ MA.writeArray answerArr index '#'

            T.lift $ MA.freeze answerArr

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        [n, m] <- B8.getLine <&> readIntB8s
        asArr <- IOA.newArray ((0, 0), (n + 1, m + 1)) '.' :: IO (IOA.IOUArray (Int, Int) Char)
        M.forM_ [1 .. n] $ \i -> do
            line <- B8.getLine <&> B8.filter (not . isSpace)
            M.forM_ [1 .. m] $ \j -> do
                MA.writeArray asArr (i, j) $ line `B8.index` (j - 1)
        as <- MA.freeze asArr

        let answer = solve (n, m) as

        case answer of
            Just as -> do
                putsYesNo True
                forM_ [1 .. n] $ \i -> do
                    let line = L.map (\j -> as UA.! (i, j)) [1..m]
                    B8.putStrLn $ B8.pack line
            Nothing -> putsYesNo False

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T
import qualified Control.Monad.Trans.Maybe as MT

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

whileM :: (Monad m) => m Bool -> m () -> m ()
whileM f m = do
    t <- f
    M.when t $ do
        m
        whileM f m

iterateCntM :: (Monad m) => Int -> a -> (a -> m a) -> m [a]
iterateCntM cnt x f = do
    y <- f x
    (x:) <$> if cnt /= 0
        then iterateCntM (cnt - 1) y f
        else M.return []

{- END OF GENERAL -}

-- Ugh...
solve :: (Int, Int) -> UA.UArray (Int, Int) Char -> Maybe (UA.UArray (Int, Int) Char)
solve (n, m) as = ST.runST solve'
    where
        solve' :: ST.ST s (Maybe (UA.UArray (Int, Int) Char))
        solve' = MT.runMaybeT $ do
            distances <- (T.lift $ MA.newArray ((1, 1), (n, m)) Nothing) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Maybe Int))
            backtrack <- (T.lift $ MA.newArray ((0, 0), (n, m)) (0, 0)) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Int, Int))

            let canPut (i, j) = L.all ((== '.') . (as UA.!)) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
                diffCostAt  = fromEnum . (== '.') . (as UA.!)

            T.lift $ flip S.evalStateT (S.empty :: S.Set (Int, (Int, Int), (Int, Int))) $ do
                M.forM_ [1 .. n] $ \i -> do
                    let index = (i, 1)
                    S.modify $ S.insert (diffCostAt index, index, (0, 0))

                whileM (S.gets (not . S.null)) $ do
                    k@(distance, index@(i, j), backtrackIndex) <- S.gets S.findMin
                    S.modify S.deleteMin
                    currentDistance <- T.lift $ MA.readArray distances index

                    let ok = (MB.isNothing currentDistance || MB.fromJust currentDistance > distance) && (1 <= i) && (i <= n) && (1 <= j) && (j <= m) && canPut index
                    M.when ok $ do
                        T.lift $ MA.writeArray distances index $ Just distance
                        T.lift $ MA.writeArray backtrack index backtrackIndex
                        tracingM "index, distance, backtrack" (index, distance, backtrackIndex)

                        let nextIndices = [(i + 1, j + 1), (i - 1, j + 1)]
                        M.forM_ nextIndices $ \nextIndex@(ii, jj) -> do
                            M.when (1 <= ii && ii <= n && 1 <= jj && jj <= m)  $ do
                                let nextDistance = distance + diffCostAt nextIndex
                                S.modify $ S.insert (nextDistance, nextIndex, index)

            rightValues <- M.forM [1..n] $ \i -> do
                let index = (i, m)
                distance <- T.lift $ MA.readArray distances index

                return $ tracing "rightValue" (fmap (* (-1)) distance, index)

            let t@(mDistance, index) = L.maximum rightValues
            tracingM "t" t
            distance <- MT.MaybeT . M.return $ mDistance

            backtrackPath <- T.lift $ iterateCntM m index $ \index -> do
                nextIndex <- MA.readArray backtrack index
                tracingM "index" index
                tracingM "nextIndex" nextIndex
                return $ nextIndex

            let backtrackIndices = L.takeWhile (/= (0, 0)) backtrackPath

            answerArr <- (T.lift $ MA.newListArray ((0, 0), (n + 1, m + 1)) (UA.elems as) ) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) Char)

            M.forM_ backtrackIndices $ \index -> do
                T.lift $ MA.writeArray answerArr index '#'

            T.lift $ MA.freeze answerArr

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        [n, m] <- B8.getLine <&> readIntB8s
        asArr <- IOA.newArray ((0, 0), (n + 1, m + 1)) '.' :: IO (IOA.IOUArray (Int, Int) Char)
        M.forM_ [1 .. n] $ \i -> do
            line <- B8.getLine <&> B8.filter (not . isSpace)
            M.forM_ [1 .. m] $ \j -> do
                MA.writeArray asArr (i, j) $ line `B8.index` (j - 1)
        as <- MA.freeze asArr

        let answer = solve (n, m) as

        case answer of
            Just as -> do
                putsYesNo True
                forM_ [1 .. n] $ \i -> do
                    let line = L.map (\j -> as UA.! (i, j)) [1..m]
                    B8.putStrLn $ B8.pack line
            Nothing -> putsYesNo False

{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif
-- {-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad as M
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S
import qualified Control.Monad.Trans.Class as T
import qualified Control.Monad.Trans.Maybe as MT

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Ix as Ix
import qualified Data.Ratio as R

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

whileM :: (Monad m) => m Bool -> m () -> m ()
whileM f m = do
    t <- f
    M.when t $ do
        m
        whileM f m

iterateCntM :: (Monad m) => Int -> a -> (a -> m a) -> m [a]
iterateCntM cnt x f = do
    y <- f x
    (x:) <$> if cnt /= 0
        then iterateCntM (cnt - 1) y f
        else M.return []

{- END OF GENERAL -}

-- Ugh...
solve :: (Int, Int) -> UA.UArray (Int, Int) Char -> Maybe (UA.UArray (Int, Int) Char)
solve (n, m) as = ST.runST solve'
    where
        solve' :: ST.ST s (Maybe (UA.UArray (Int, Int) Char))
        solve' = MT.runMaybeT $ do
            distances <- (T.lift $ MA.newArray ((1, 1), (n, m)) Nothing) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Maybe Int))
            backtrack <- (T.lift $ MA.newArray ((0, 0), (n, m)) (0, 0)) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) (Int, Int))

            let canPut (i, j) = L.all ((== '.') . (as UA.!)) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
                diffCostAt  = fromEnum . (== '.') . (as UA.!)

            T.lift $ flip S.evalStateT (S.empty :: S.Set (Int, (Int, Int), (Int, Int))) $ do
                M.forM_ [1 .. n] $ \i -> do
                    let index = (i, 1)
                    S.modify $ S.insert (diffCostAt index, index, (0, 0))

                whileM (S.gets (not . S.null)) $ do
                    k@(distance, index@(i, j), backtrackIndex) <- S.gets S.findMin
                    S.modify S.deleteMin
                    currentDistance <- T.lift $ MA.readArray distances index

                    let ok = MB.isNothing currentDistance && (1 <= i) && (i <= n) && (1 <= j) && (j <= m) && canPut index
                    M.when ok $ do
                        T.lift $ MA.writeArray distances index $ Just distance
                        T.lift $ MA.writeArray backtrack index backtrackIndex
                        tracingM "index, distance, backtrack" (index, distance, backtrackIndex)

                        let nextIndices = [(i + 1, j + 1), (i - 1, j + 1)]
                        M.forM_ nextIndices $ \nextIndex@(ii, jj) -> do
                            M.when (1 <= ii && ii <= n && 1 <= jj && jj <= m)  $ do
                                let nextDistance = distance + diffCostAt nextIndex
                                S.modify $ S.insert (nextDistance, nextIndex, index)

            rightValues <- M.forM [1..n] $ \i -> do
                let index = (i, m)
                distance <- T.lift $ MA.readArray distances index
                backtrack <- T.lift $ MA.readArray backtrack index

                return $ tracing "rightValue" (fmap (* (-1)) distance, index, backtrack)

            let t@(mDistance, index, backtrackIndex) = L.maximum rightValues
            tracingM "t" t
            distance <- MT.MaybeT . M.return $ mDistance

            backtrackPath <- T.lift $ iterateCntM m index $ \index -> do
                nextIndex <- MA.readArray backtrack index
                tracingM "index" index
                tracingM "nextIndex" nextIndex
                return $ nextIndex

            let backtrackIndices = L.takeWhile (/= (0, 0)) backtrackPath

            answerArr <- (T.lift $ MA.newListArray ((0, 0), (n + 1, m + 1)) (UA.elems as) ) :: MT.MaybeT (ST.ST s) (STA.STArray s (Int, Int) Char)

            M.forM_ backtrackIndices $ \index -> do
                T.lift $ MA.writeArray answerArr index '#'

            T.lift $ MA.freeze answerArr

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        [n, m] <- B8.getLine <&> readIntB8s
        asArr <- IOA.newArray ((0, 0), (n + 1, m + 1)) '.' :: IO (IOA.IOUArray (Int, Int) Char)
        M.forM_ [1 .. n] $ \i -> do
            line <- B8.getLine <&> B8.filter (not . isSpace)
            M.forM_ [1 .. m] $ \j -> do
                MA.writeArray asArr (i, j) $ line `B8.index` (j - 1)
        as <- MA.freeze asArr

        let answer = solve (n, m) as

        case answer of
            Just as -> do
                putsYesNo True
                forM_ [1 .. n] $ \i -> do
                    let line = L.map (\j -> as UA.! (i, j)) [1..m]
                    B8.putStrLn $ B8.pack line
            Nothing -> putsYesNo False


A continued fraction of height n is a fraction of form . You are given two rational numbers, one is represented as  and the other one is represented as a finite fraction of height n. Check if they are equal.

The first line contains two space-separated integers p, q (1 ≤ q ≤ p ≤ 1018) — the numerator and the denominator of the first fraction. The second line contains integer n (1 ≤ n ≤ 90) — the height of the second fraction. The third line contains n space-separated integers a1, a2, ..., an (1 ≤ ai ≤ 1018) — the continued fraction. Please, do not use the %lld specifier to read or write 64-bit integers in С++. It is preferred to use the cin, cout streams or the %I64d specifier.

Print "YES" if these fractions are equal and "NO" otherwise.

NoteIn the first sample .In the second sample .In the third sample .

main :: IO ()
main = interact $ solve . map read . words

solve :: [Integer] -> String
solve (p : q : _ : as)
  | p * r == q * s = "YES"
  | otherwise = "NO"
  where
  (r, s) = foldr f (0, 1) as
  f a (n, d) = (d, a * d + n)

import Data.Ratio ((%))
import Control.Monad (liftM)
import Prelude hiding (reads)

reads :: Read a => IO [a]
reads  =  liftM (map read . words) getLine

solve :: (Integer, Integer) -> [Integer] -> Bool
solve (a, b) xs  =  a % b == solve' xs
  where
    solve' [x]  =  x % 1
    solve' (x:xs)  =  x % 1 + 1 / solve' xs

main :: IO ()
main  =  do
    [a, b]  <-  reads
    getLine
    xs  <-  reads
    if solve (a, b) xs
        then putStrLn "YES"
        else putStrLn "NO"

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE BangPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.Ord
import Data.Ratio

readInteger :: B.ByteString -> Integer
readInteger bs = case B.readInteger bs of Just (n,_) -> n

main :: IO ()
main = do
  [p,q] <- map read.words <$> getLine
  _ <- getLine
  xs <- map readInteger.B.words <$> B.getLine
  if (p%q) == calc xs
     then putStrLn "YES"
     else putStrLn "NO"

calc :: [Integer] -> Ratio Integer
calc [x] = x%1
calc (x:xs) = (x%1)+ (1 / (calc xs))

isEqual :: Integer -> Integer -> [Integer] -> Bool
isEqual p q [] = q == 0
isEqual p q (x : xs) = if q /= 0 then div p q >= x && isEqual q (p - q * x) xs else False

handle :: [[String]] -> String
handle [[sp, sq], _, sa] = if isEqual (read sp) (read sq) (map read sa) then "YES" else "NO"

main :: IO ()
main = interact $ handle . map words . lines

isEqual :: Integer -> Integer -> [Integer] -> Bool
isEqual p q [] = q == 0
isEqual _ 0 _ = False
isEqual p q (x : xs) = div p q >= x && isEqual q (p - q * x) xs

handle :: [[String]] -> String
handle [[sp, sq], _, sa] = if isEqual (read sp) (read sq) (map read sa) then "YES" else "NO"

main :: IO ()
main = interact $ handle . map words . lines

isEqual :: Int -> Int -> [Int] -> Bool
isEqual p q [] = q == 0
isEqual p q (x : xs) = div p q >= x && isEqual q (p - q * x) xs

handle :: [[String]] -> String
handle [[sp, sq], _, sa] = if isEqual (read sp) (read sq) (map read sa) then "YES" else "NO"

main :: IO ()
main = interact $ handle . map words . lines


You are playing a new famous fighting game: Kortal Mombat XII. You have to perform a brutality on your opponent's character.You are playing the game on the new generation console so your gamepad have $$$26$$$ buttons. Each button has a single lowercase Latin letter from 'a' to 'z' written on it. All the letters on buttons are pairwise distinct.You are given a sequence of hits, the $$$i$$$-th hit deals $$$a_i$$$ units of damage to the opponent's character. To perform the $$$i$$$-th hit you have to press the button $$$s_i$$$ on your gamepad. Hits are numbered from $$$1$$$ to $$$n$$$.You know that if you press some button more than $$$k$$$ times in a row then it'll break. You cherish your gamepad and don't want to break any of its buttons.To perform a brutality you have to land some of the hits of the given sequence. You are allowed to skip any of them, however changing the initial order of the sequence is prohibited. The total damage dealt is the sum of $$$a_i$$$ over all $$$i$$$ for the hits which weren't skipped.Note that if you skip the hit then the counter of consecutive presses the button won't reset.Your task is to skip some hits to deal the maximum possible total damage to the opponent's character and not break your gamepad buttons.

The first line of the input contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 2 \cdot 10^5$$$) — the number of hits and the maximum number of times you can push the same button in a row. The second line of the input contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^9$$$), where $$$a_i$$$ is the damage of the $$$i$$$-th hit. The third line of the input contains the string $$$s$$$ consisting of exactly $$$n$$$ lowercase Latin letters — the sequence of hits (each character is the letter on the button you need to press to perform the corresponding hit).

Print one integer $$$dmg$$$ — the maximum possible damage to the opponent's character you can deal without breaking your gamepad buttons.

NoteIn the first example you can choose hits with numbers $$$[1, 3, 4, 5, 6, 7]$$$ with the total damage $$$1 + 16 + 18 + 7 + 2 + 10 = 54$$$.In the second example you can choose all hits so the total damage is $$$2 + 4 + 1 + 3 + 1000 = 1010$$$.In the third example you can choose all hits expect the third one so the total damage is $$$2 + 4 + 3 + 1000 = 1009$$$.In the fourth example you can choose hits with numbers $$$[2, 3, 6, 8]$$$. Only this way you can reach the maximum total damage $$$15 + 2 + 8 + 16 = 41$$$.In the fifth example you can choose only hits with numbers $$$[2, 4, 6]$$$ with the total damage $$$18 + 19 + 15 = 52$$$.In the sixth example you can change either first hit or the second hit (it does not matter) with the total damage $$$10$$$.

import qualified Data.ByteString.Char8 as B
import Control.Arrow
import Data.Maybe
import Data.Ord
import Data.List
import Data.Function

int = fst . fromJust . B.readInteger
ints = map int . B.words

main = do
    [n,k] <- ints <$> B.getLine
    as <- ints <$> B.getLine
    c <- B.unpack <$> B.getLine
    print $ sum . map (sum . take (fromIntegral k) . sortBy  (flip $ comparing id) . map snd ) . groupBy ((==) `on` fst) . zip c $ as

import qualified Data.ByteString.Char8 as B
import Control.Arrow
import Data.Maybe
import Data.Ord
import Data.List
import Data.Function

int = fst . fromJust . B.readInt
ints = map int . B.words

main = do
    [n,k] <- ints <$> B.getLine
    as <- ints <$> B.getLine
    c <- B.unpack <$> B.getLine
    print $ sum . map (sum . take k . sortBy  (flip $ comparing id) . map snd ) . groupBy ((==) `on` fst) . zip c $ as


You are given the string s of length n and the numbers p, q. Split the string s to pieces of length p and q.For example, the string "Hello" for p = 2, q = 3 can be split to the two strings "Hel" and "lo" or to the two strings "He" and "llo".Note it is allowed to split the string s to the strings only of length p or to the strings only of length q (see the second sample test).

The first line contains three positive integers n, p, q (1 ≤ p, q ≤ n ≤ 100). The second line contains the string s consists of lowercase and uppercase latin letters and digits.

If it's impossible to split the string s to the strings of length p and q print the only number "-1". Otherwise in the first line print integer k — the number of strings in partition of s. Each of the next k lines should contain the strings in partition. Each string should be of the length p or q. The string should be in order of their appearing in string s — from left to right. If there are several solutions print any of them.

import Data.List

main = do
  [n, p, q] <- (map read . words) `fmap` getLine
  s <- getLine

  let vs = [(a, b) | a <- [0..100], b <- [0..100], a*p + b*q == n]

  if null vs
    then print $ -1
    else do
      let
        (a, b) = head vs
        ss = slice p (take (p*a) s) ++ slice q (drop (p*a) s)
          where
            slice n = unfoldr (\s -> if null s then Nothing else Just (take n s, drop n s))
      print $ length ss
      putStr $ unlines ss

import Control.Applicative
import Data.List
import Data.Maybe

main = do
    (n : p : q : _) <- map read . words <$> getLine
    s <- getLine
    putStrLn $ case listToMaybe [i | i <- [0, p .. n], (n - i) `mod` q == 0] of
        Nothing -> "-1"
        Just i  -> let (s1, s2) = splitAt i s in decorate $ (splitEvery p s1) ++ (splitEvery q s2)
    where
        decorate l      = unlines $ (show $ length l) : l
        splitEvery x    = takeWhile (not . null) . unfoldr (Just . splitAt x)

import Control.Applicative
import Data.List.Split

solve :: Int -> Int -> Int -> String -> [String]
solve n p q x
  | null matches = ["-1"]
  | otherwise = show (p_uses + q_uses):chunksOf p p_str ++ chunksOf q q_str
  where
    matches = [(p_uses, q_uses) | p_uses <- [0..n], q_uses <- [0..n], p_uses * p + q_uses * q == n]
    (p_uses, q_uses) = head matches
    (p_str, q_str) = splitAt (p_uses * p) x

main = do
  [n, p, q] <- map read . words <$> getLine
  x <- getLine
  let soln = solve n p q x
  putStrLn $ unlines $ soln

import Control.Applicative
import Data.List.Split

main = do
  [n, p, q] <- map read . words <$> getLine
  s <- getLine
  putStr $ unlines $ solve n p q s

solve n p q s = if null ls then ["-1"]
                else show (m `div` p + (n - m) `div` q) : chunksOf p (take m s) ++  chunksOf q (drop m s)
                    where ls = [m | m <-[0..n], m `mod` p == 0, (n - m) `mod` q == 0 ]
                          m = if null ls then -1 else head ls

import Data.List

read_int :: String -> Int
read_int = read

solve :: Int -> Int -> String -> Maybe [String]
solve p q str
  | len `mod`g /= 0    = Nothing
  | len == p           = Just [str]
  | len == q           = Just [str]
  | len < p && len < q = Nothing
  | otherwise          = case (solve p q psuff, solve p q qsuff) of
                           (Just ss, _) -> Just (ppref:ss)
                           (_, Just ss) -> Just (qpref:ss)
                           _ -> Nothing
  where len            = length str
        (ppref, psuff) = splitAt p str
        (qpref, qsuff) = splitAt q str
        g              = gcd p q

formatout :: Maybe [String] -> String
formatout Nothing   = "-1"
formatout (Just ss) = intercalate "\n" ((show $ length ss):ss)

formatin :: [String] -> Maybe [String]
formatin (_:x:y:z:_) = solve (read_int x) (read_int y) z

main = do
  input <- getContents
  putStrLn $ formatout . formatin . words $ input

splitS s n p q
    | n == 0 = ([], True)
    | n < p = ([], False)
    | n `mod` p == 0 = ((take p s) : spLeft, passedP)
    | n < q = ([], False)
    | otherwise = ((take q s) : sqLeft, passedQ)
    where
        (spLeft, passedP) = splitS (drop p s) (n-p) p q
        (sqLeft, passedQ) = splitS (drop q s) (n-q) p q

main = do
    line <- getLine
    let [n, p, q] = map read $ words line
    let (pP, qQ) = (min p q, max p q)
    s <- getLine
    let (result, possible) = splitS s n pP qQ
    if possible then do
        putStrLn $ show $ length result
        putStr $ unlines result
    else do
        putStrLn "-1"

{-- 612.A. The Text Splitting --}
main = do
    firstLine <- getLine
    word <- getLine
    case splitter (words firstLine) word of
        Just set -> do
            putStrLn (show $ length set)
            mapM_ putStrLn set
        Nothing ->
            putStrLn "-1"

splitter :: [String] -> String -> Maybe [String]
splitter [] _ = Nothing
splitter _ [] = Nothing
splitter xs str = case partition str len p q of
                    (_, -1) -> Nothing
                    (set, _) -> Just set
    where
        len = read (xs !! 0) :: Int
        p = read (xs !! 1) :: Int
        q = read (xs !! 2) :: Int

partition :: (Num a) => String -> Int -> Int -> Int -> ([String], a)
partition str len p q
    | len < 0   = ([], -1)
    | len == 0  = ([], 0)
    | otherwise = ((take val str) : next, num)
    where
        (next, num) = if modPass
                        then partition (drop val str) (len - val) val val
                        else partition (drop val str) (len - val) p q
        modPass = len `mod` p == 0 || len `mod` q == 0
        val
            | len `mod` p == 0 = p
            | len `mod` q == 0 = q
            | p < q = p
            | otherwise = q

main = interact $
        sol .
        (\[n, p, q, s] -> (read n, read p, read q, s)) .
        words

sol (n, p, q, s) = case posb of
                    [] -> "-1"
                    (pl:_) -> let ans = slice s $ replicate (pl `div` p) p ++ replicate ((n-pl) `div` q) q
                              in unlines $ (show $ length ans):ans
    where
    posb = filter (\pl -> (n-pl) `mod` q == 0) . takeWhile (<= n) $ map (*p) [0..]
    slice _ [] = []
    slice str (x:xs) = (take x str):(slice (drop x str) xs)

import Data.List

main = do
  [n, p, q] <- (map read . words) `fmap` getLine
  s <- getLine

  let vs = [(a, b) | a <- [0..100], b <- [0..100], a*p + b*q == n]

  if null vs
    then print $ -1
    else do
      print 2
      let
        (a, b) = head vs
        ss = slice p (take (p*a) s) ++ slice q (drop (p*a) s)
          where
            slice n = unfoldr (\s -> if null s then Nothing else Just (take n s, drop n s))
      putStr $ unlines ss


You are given the set of vectors on the plane, each of them starting at the origin. Your task is to find a pair of vectors with the minimal non-oriented angle between them.Non-oriented angle is non-negative value, minimal between clockwise and counterclockwise direction angles. Non-oriented angle is always between 0 and π. For example, opposite directions vectors have angle equals to π.

First line of the input contains a single integer n (2 ≤ n ≤ 100 000) — the number of vectors. The i-th of the following n lines contains two integers xi and yi (|x|, |y| ≤ 10 000, x2 + y2 > 0) — the coordinates of the i-th vector. Vectors are numbered from 1 to n in order of appearing in the input. It is guaranteed that no two vectors in the input share the same direction (but they still can have opposite directions).

Print two integer numbers a and b (a ≠ b) — a pair of indices of vectors with the minimal non-oriented angle. You can print the numbers in any order. If there are many possible answers, print any.

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.Int (Int64)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

data Vector = Vector !Int64 !Int64 deriving (Eq)

Vector x1 y1 `cross` Vector x2 y2 = x1*y2 - x2*y1
Vector x1 y1 `dot` Vector x2 y2 = x1*x2 + y1*y2

main = do
	_ <- getLine
	vs <- map ((\[x, y] -> Vector (fromIntegral x) (fromIntegral y)) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
			vs' = sortBy (comparing ang) vs
	 			where
				     ang (Vector x y) = atan2 (fromIntegral y) (fromIntegral x)

			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy cmp pairs
   				where
					cmp (v1, v2) (v3, v4) = 0 `compare` (u `cross` v)
 						where
							u = Vector (v1 `dot` v2) (abs $ v1 `cross` v2)
							v = Vector (v3 `dot` v4) (abs $ v3 `cross` v4)

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

getInts = map (fst . fromJust . readInt) . words <$> getLine

main = do
	_ <- getLine
        vs <- map ((\[x, y] -> (x, y)) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
		       	vs' = sortBy (comparing ang) vs
	 			where
				     ang :: (Int, Int) -> Double
				     ang (x, y) = atan2 (fromIntegral y) (fromIntegral x)
			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy (comparing ang) pairs
   				where
					ang :: ((Int, Int), (Int, Int)) -> Double
					ang ((x1, y1), (x2, y2)) = abs $ atan2 (fromIntegral y) (fromIntegral x)
						where
							y = x1*y2 - x2*y1
							x = x1*x2 + y1*y2

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

data Vector = Vector !Int !Int deriving (Eq)

Vector x1 y1 `cross` Vector x2 y2 = x1*y2 - x2*y1
Vector x1 y1 `dot` Vector x2 y2 = x1*x2 + y1*y2

main = do
	_ <- getLine
	vs <- map ((\[x, y] -> Vector x y) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
			vs' = sortBy (comparing ang) vs
	 			where
				     ang (Vector x y) = atan2 (fromIntegral y) (fromIntegral x)

			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy cmp pairs
   				where
					cmp (v1, v2) (v3, v4) = 0 `compare` (u `cross` v)
 						where
							u = Vector (v1 `dot` v2) (abs $ v1 `cross` v2)
							v = Vector (v3 `dot` v4) (abs $ v3 `cross` v4)

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

main = do
	_ <- getLine
        vs <- map ((\[x, y] -> (x, y)) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
			vs' = sortBy (comparing $ uncurry ang) vs
	 			where
					ang x y = atan2 (fromIntegral y :: Double) (fromIntegral x :: Double)

			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy (comparing $ uncurry ang) pairs
   				where
				       ang (x1, y1) (x2, y2) = abs $ atan2 (fromIntegral y :: Double) (fromIntegral x :: Double)
						where
							y = x1*y2 - x2*y1
							x = x1*x2 + y1*y2

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

data Vector = Vector !Int !Int deriving (Eq)

Vector x1 y1 `cross` Vector x2 y2 = x1*y2 - x2*y1
Vector x1 y1 `dot` Vector x2 y2 = x1*x2 + y1*y2

main = do
	_ <- getLine
	vs <- map ((\[x, y] -> Vector x y) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
			vs' = sortBy (comparing ang) vs
	 			where
				     ang (Vector x y) = atan2 (fromIntegral y) (fromIntegral x)

			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy cmp pairs
   				where
					cmp (v1, v2) (v3, v4) = 0 `compare` (u `cross` v)
 						where
							u = Vector (v1 `dot` v2) (v1 `cross` v2)
							v = Vector (v3 `dot` v4) (v3 `cross` v4)

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)

import Control.Applicative ((<$>))
import Data.ByteString (getLine, getContents)
import Data.ByteString.Char8 (readInt, lines, words, unpack)
import Data.List (sortBy, minimumBy, elemIndex)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (getLine, getContents, lines, words)

getInts = map (fst . fromJust . readInt) . words <$> getLine

main = do
	_ <- getLine
        vs <- map ((\[x, y] -> (x, y)) . map (fst . fromJust . readInt) . words) . lines <$> getContents

	let (i1, i2) = (fromJust $ elemIndex (fst m) vs, fromJust $ elemIndex (snd m) vs)
     		where
		       	vs' = sortBy (comparing ang) vs
	 			where
				     ang :: (Int, Int) -> Double
				     ang (x, y) = atan2 (fromIntegral y) (fromIntegral x)
			pairs = zip vs' (tail vs' ++ [head vs'])

			m = minimumBy (comparing ang) pairs
   				where
					ang :: ((Int, Int), (Int, Int)) -> Double
					ang ((x1, y1), (x2, y2)) = atan2 (fromIntegral y) (fromIntegral x)
						where
							y = x1*y2 - x2*y1
							x = x1*x2 + y1*y2

	putStrLn $ show (i1 + 1) ++ " " ++ show (i2 + 1)


We'll call an array of n non-negative integers a[1], a[2], ..., a[n] interesting, if it meets m constraints. The i-th of the m constraints consists of three integers li, ri, qi (1 ≤ li ≤ ri ≤ n) meaning that value  should be equal to qi. Your task is to find any interesting array of n elements or state that such array doesn't exist.Expression x&y means the bitwise AND of numbers x and y. In programming languages C++, Java and Python this operation is represented as "&", in Pascal — as "and".

The first line contains two integers n, m (1 ≤ n ≤ 105, 1 ≤ m ≤ 105) — the number of elements in the array and the number of limits. Each of the next m lines contains three integers li, ri, qi (1 ≤ li ≤ ri ≤ n, 0 ≤ qi < 230) describing the i-th limit.

If the interesting array exists, in the first line print "YES" (without the quotes) and in the second line print n integers a[1], a[2], ..., a[n] (0 ≤ a[i] < 230) decribing the interesting array. If there are multiple answers, print any of them. If the interesting array doesn't exist, print "NO" (without the quotes) in the single line.

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Applicative hiding(empty)

import Data.List hiding(insert)
import Data.Bits
import Data.Maybe
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]

main = do
    (n,_) <- readIntPair
    qs <- map (map readInt . B.words) . B.lines <$> B.getContents
    case solve n qs of
        Just as -> do
            putStrLn $ "YES"
            putStrLn $ unwords $ map show as
        Nothing -> putStrLn $ "NO"

data SegTree = Leaf !Int !Int | Node !Int !Int !Int !SegTree !SegTree deriving(Show)

get :: SegTree -> Int
get (Leaf _ q) = q
get (Node _ _ q _ _) = q

mkTree :: [Int] -> SegTree
mkTree as = go 0 n as where
    n = length as
    go l r as | r - l == 1 = Leaf l $ head as
              | otherwise =
                let m = (l+r) `div` 2
                    (asl,asr) = splitAt (m-l) as
                    t1 = go l m asl
                    t2 = go m r asr in
                Node l r (get t1 .&. get t2) t1 t2

update :: Int -> Int -> Int -> SegTree -> SegTree
update ql qr v t@(Leaf i q) =
    if ql <= i && i < qr then Leaf i (q .|. v) else t
update ql qr v t@(Node l r q t1 t2)
    | ql <= l && r <= qr = Node l r (q .|. v) t1 t2
    | r <= ql || qr <= l = t
    | otherwise = Node l r q (update ql qr v t1) (update ql qr v t2)

toList :: SegTree -> [Int]
toList tree = go 0 tree [] where
    go q (Leaf _ q') acc = (q .|. q'):acc
    go q (Node _ _ q' t1 t2) acc = go (q .|. q') t1 (go (q .|. q') t2 acc)

rmq :: Int -> Int -> SegTree -> Int
rmq ql qr (Leaf i q) = if ql <= i && i < qr then q else -1
rmq ql qr (Node l r q t1 t2) | ql <= l && r <= qr = q
                             | r <= ql || qr <= l = -1
                             | otherwise = rmq ql qr t1 .&. rmq ql qr t2

solve :: Int -> [[Int]] -> Maybe [Int]
solve n qs = pure as <* guard check where
    t1 = mkTree $ take n $ repeat 0
    t2 = foldl' (\acc [li,ri,qi] -> update (li-1) ri qi acc) t1 qs
    as = toList t2
    t3 = mkTree $ toList t2
    check = all (\[li,ri,qi] -> rmq (li-1) ri t3 == qi) qs

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Applicative hiding(empty)

import Data.List hiding(insert)
import Data.Bits
import Data.Maybe
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]

main = do
    (n,_) <- readIntPair
    qs <- map (map readInt . B.words) . B.lines <$> B.getContents
    case solve n qs of
        Just as -> do
            putStrLn $ "YES"
            putStrLn $ unwords $ map show as
        Nothing -> putStrLn $ "NO"

data SegTree a = Leaf !Int !a | Node !Int !Int !a !(SegTree a) !(SegTree a) deriving(Show)

get :: SegTree a -> a
get (Leaf _ q) = q
get (Node _ _ q _ _) = q

mkTree :: Int -> SegTree Int
mkTree n = go 0 n where
    go l r | r - l == 1 = Leaf l 0
           | otherwise = Node l r 0 t1 t2 where
                m = (l + r) `div` 2
                t1 = go l m
                t2 = go m r

update :: Int -> Int -> Int -> SegTree Int -> SegTree Int
update !ql !qr !v = go where
    go t@(Leaf i q)
        | ql <= i && i < qr = Leaf i (q .|. v)
        | otherwise = t
    go t@(Node l r q t1 t2)
        | ql <= l && r <= qr = Node l r (q .|. v) t1 t2
        | r <= ql || qr <= l = t
        | otherwise = Node l r q (go t1) (go t2)

convert :: SegTree Int -> SegTree Int
convert = go 0 where
    go !q (Leaf i q') = Leaf i (q .|. q')
    go !q (Node l r q' t1 t2) =
        let t1' = go (q .|. q') t1
            t2' = go (q .|. q') t2
        in Node l r (get t1' .&. get t2') t1' t2'

rmq :: Int -> Int -> SegTree Int -> Int
rmq ql qr = go where
    go (Leaf i q) | ql <= i && i < qr = q
                  | otherwise = -1
    go (Node l r q t1 t2) | ql <= l && r <= qr = q
                          | r <= ql || qr <= l = -1
                          | otherwise = go t1 .&. go t2

toList :: SegTree Int -> [Int]
toList = go [] where
    go acc (Leaf _ q) = q:acc
    go acc (Node _ _ _ t1 t2) = go (go acc t2) t1

solve :: Int -> [[Int]] -> Maybe [Int]
solve n qs = pure as <* guard check where
    t1 = mkTree n
    t2 = foldl' (\acc [li,ri,qi] -> update (li-1) ri qi acc) t1 qs
    t3 = convert t2
    as = toList t3
    check = all (\[li,ri,qi] -> rmq (li-1) ri t3 == qi) qs

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Applicative hiding(empty)

import Data.List hiding(insert)
import Data.Bits
import Data.Maybe
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]

main = do
    (n,_) <- readIntPair
    qs <- map (map readInt . B.words) . B.lines <$> B.getContents
    case solve n qs of
        Just as -> do
            putStrLn $ "YES"
            putStrLn $ unwords $ map show as
        Nothing -> putStrLn $ "NO"

data SegTree = Leaf !Int !Int | Node !Int !Int !Int !SegTree !SegTree deriving(Show)

get :: SegTree -> Int
get (Leaf _ q) = q
get (Node _ _ q _ _) = q

mkTree :: Int -> SegTree
mkTree n = go 0 n where
    go l r | r - l == 1 = Leaf l 0
           | otherwise = Node l r 0 t1 t2 where
                m = (l + r) `div` 2
                t1 = go l m
                t2 = go m r

update :: Int -> Int -> Int -> SegTree -> SegTree
update !ql !qr !v = go where
    go t@(Leaf i q)
        | ql <= i && i < qr = Leaf i (q .|. v)
        | otherwise = t
    go t@(Node l r q t1 t2)
        | ql <= l && r <= qr = Node l r (q .|. v) t1 t2
        | r <= ql || qr <= l = t
        | otherwise = Node l r q (go t1) (go t2)

convert :: SegTree -> SegTree
convert = go 0 where
    go !q (Leaf i q') = Leaf i (q .|. q')
    go !q (Node l r q' t1 t2) =
        let t1' = go (q .|. q') t1
            t2' = go (q .|. q') t2
        in Node l r (get t1' .&. get t2') t1' t2'

rmq :: Int -> Int -> SegTree -> Int
rmq ql qr = go where
    go (Leaf i q) | ql <= i && i < qr = q
                  | otherwise = -1
    go (Node l r q t1 t2) | ql <= l && r <= qr = q
                          | r <= ql || qr <= l = -1
                          | otherwise = go t1 .&. go t2

toList :: SegTree -> [Int]
toList = go [] where
    go acc (Leaf _ q) = q:acc
    go acc (Node _ _ _ t1 t2) = go (go acc t2) t1

solve :: Int -> [[Int]] -> Maybe [Int]
solve n qs = pure as <* guard check where
    t1 = mkTree n
    t2 = foldl' (\acc [li,ri,qi] -> update (li-1) ri qi acc) t1 qs
    t3 = convert t2
    as = toList t3
    check = all (\[li,ri,qi] -> rmq (li-1) ri t3 == qi) qs

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Monad.ST
import Control.Applicative hiding(empty)
import Control.Arrow
import Debug.Trace
import Text.Printf
import Data.Monoid((<>))

import Data.List hiding(insert)
import Data.Int
import Data.Bits
import Data.Maybe
import Data.Array.Unboxed
import Data.Array.ST
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b
swap (a,b) = (b,a)
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]
itof :: Int -> Double
itof = fromIntegral
defaultArray :: (IArray a e,Ix i) => e -> (i,i) -> [(i,e)] -> a i e
defaultArray = accumArray $ curry snd
flatten :: [(a,[(b,c)])] -> [((a,b),c)]
flatten = (=<<) $ uncurry $ fmap . first . (,)
stepM_ :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
stepM_ i judge incr step = sub i where
    sub i | judge i = step i >> sub (incr i) | otherwise = return ()
thru :: Monad m => (v -> m ()) -> v -> m v
thru m v = m v >> return v
inf = maxBound `div` 2 :: Int

main = do
    (n,_) <- readIntPair
    qs <- map (map readInt . B.words) . B.lines <$> B.getContents
    case solve n qs of
        Just as -> do
            putStrLn $ "YES"
            putStrLn $ unwords $ map show as
        Nothing -> putStrLn $ "NO"

data SegTree = Leaf Int Int | Node Int Int Int SegTree SegTree deriving(Show)

get :: SegTree -> Int
get (Leaf _ q) = q
get (Node _ _ q _ _) = q

mkTree :: [Int] -> SegTree
mkTree as = go 0 n as where
    n = length as
    go l r as | r - l == 1 = Leaf l $ head as
              | otherwise =
                let m = (l+r) `div` 2
                    (asl,asr) = splitAt (m-l) as
                    t1 = go l m asl
                    t2 = go m r asr in
                Node l r (get t1 .&. get t2) t1 t2

update :: Int -> Int -> Int -> SegTree -> SegTree
update ql qr v t@(Leaf i q) =
    if ql <= i && i < qr then Leaf i (q .|. v) else t
update ql qr v t@(Node l r q t1 t2)
    | ql <= l && r <= qr = Node l r (q .|. v) t1 t2
    | r <= ql || qr <= l = t
    | otherwise = Node l r q (update ql qr v t1) (update ql qr v t2)

toList :: SegTree -> [Int]
toList tree = go 0 tree [] where
    go q (Leaf _ q') acc = (q .|. q'):acc
    go q (Node _ _ q' t1 t2) acc = go (q .|. q') t1 (go (q .|. q') t2 acc)

rmq :: Int -> Int -> SegTree -> Int
rmq ql qr (Leaf i q) = if ql <= i && i < qr then q else -1
rmq ql qr (Node l r q t1 t2) | ql <= l && r <= qr = q
                             | r <= ql || qr <= l = -1
                             | otherwise = rmq ql qr t1 .&. rmq ql qr t2

solve :: Int -> [[Int]] -> Maybe [Int]
solve n qs = pure as <* guard check where
    t1 = mkTree [0..n-1]
    t2 = foldl' (\acc [li,ri,qi] -> update (li-1) ri qi acc) t1 qs
    as = toList t2
    t3 = mkTree $ toList t2
    check = all (\[li,ri,qi] -> rmq (li-1) ri t3 == qi) qs

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Monad.ST
import Control.Applicative hiding(empty)
import Control.Arrow
import Debug.Trace
import Text.Printf

import Data.List hiding(insert)
import Data.Int
import Data.Bits
import Data.Maybe
import Data.Array.Unboxed
import Data.Array.ST
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b
swap (a,b) = (b,a)
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]
itof :: Int -> Double
itof = fromIntegral
defaultArray :: (IArray a e,Ix i) => e -> (i,i) -> [(i,e)] -> a i e
defaultArray = accumArray $ curry snd
flatten :: [(a,[(b,c)])] -> [((a,b),c)]
flatten = (=<<) $ uncurry $ fmap . first . (,)
stepM_ :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
stepM_ i judge incr step = sub i where
    sub i | judge i = step i >> sub (incr i) | otherwise = return ()
thru :: Monad m => (v -> m ()) -> v -> m v
thru m v = m v >> return v
inf = maxBound `div` 2 :: Int

data Tree a = Null | Fork a (Tree a) (Tree a) deriving(Show)

empty :: Tree a
empty = Null

isEmpty :: Tree a -> Bool
isEmpty Null = True
isEmpty _ = False

minElem :: Tree a -> a
minElem (Fork a _ _) = a
minElem Null = error "min for empty queue is not supported"

deleteMin :: (Ord a) => Tree a -> Tree a
deleteMin (Fork _ a b) = merge a b

insert :: (Ord a) => a -> Tree a -> Tree a
insert x a = merge (Fork x Null Null) a

merge :: (Ord a) => Tree a -> Tree a -> Tree a
merge a Null = a
merge Null b = b
merge a b | minElem a <= minElem b = join a b
          | otherwise = join b a
    where
    join (Fork x a b) c = Fork x b (merge a c)

main = do
    (n,_) <- readIntPair
    qs <- map (map readInt . B.words) . B.lines <$> B.getContents
    case solve n qs of
        Just as -> do
            putStrLn $ "YES"
            putStrLn $ unwords $ map show as
        Nothing -> putStrLn $ "NO"

data SegTree = Leaf Int Int | Node Int Int Int SegTree SegTree deriving(Show)

get :: SegTree -> Int
get (Leaf _ q) = q
get (Node _ _ q _ _) = q

mkTree :: [Int] -> SegTree
mkTree as = go 0 n as where
    n = length as
    go l r as | r - l == 1 = Leaf l $ head as
              | otherwise =
                let m = (l+r) `div` 2
                    (asl,asr) = splitAt (m-l) as
                    t1 = go l m asl
                    t2 = go m r asr in
                Node l r (get t1 .&. get t2) t1 t2

rmq :: Int -> Int -> SegTree -> Int
rmq ql qr (Leaf i q) = if ql <= i && i < qr then q else -1
rmq ql qr (Node l r q t1 t2) | ql <= l && r <= qr = q
                             | otherwise = rmq ql qr t1 .&. rmq ql qr t2

solve :: Int -> [[Int]] -> Maybe [Int]
solve n qs = pure as <* guard (check as) where
    qs' = sort $ map (\[li,ri,qi] -> ((li,ri),qi)) qs
    as = go 1 empty qs'
    tree = mkTree as
    check as = all (\((li,ri),qi) -> rmq (li-1) ri tree == qi) qs'
    go i queue rem | i > n = []
                   | otherwise =
        let (a,b) = span ((<=i).fst.fst) rem
            queue' = foldl (\acc ((l,r),q) -> insert (r,q) acc) queue a
            pop qs | isEmpty qs = qs
                   | fst (minElem qs) < i = pop (deleteMin qs)
                   | otherwise = qs
            queue'' = pop queue'
        in
        if isEmpty queue''
            then 0:go (i+1) queue'' b
            else snd (minElem queue''):go (i+1) queue'' b


Recently Luba bought a very interesting book. She knows that it will take t seconds to read the book. Luba wants to finish reading as fast as she can.But she has some work to do in each of n next days. The number of seconds that Luba has to spend working during i-th day is ai. If some free time remains, she can spend it on reading.Help Luba to determine the minimum number of day when she finishes reading.It is guaranteed that the answer doesn't exceed n.Remember that there are 86400 seconds in a day.

The first line contains two integers n and t (1 ≤ n ≤ 100, 1 ≤ t ≤ 106) — the number of days and the time required to read the book. The second line contains n integers ai (0 ≤ ai ≤ 86400) — the time Luba has to spend on her work during i-th day.

Print the minimum day Luba can finish reading the book. It is guaranteed that answer doesn't exceed n.

module Main where

import Control.Applicative
import Control.Monad

day :: Int
day = 86400

getMinTime :: [Int] -> Int -> Int
getMinTime as t = fst . head . dropWhile ((< t) . snd) $ zip [0 :: Int ..] fs
    where fs = scanl (+) 0 $ map (day - ) as

main :: IO ()
main = do
  [_, t] <- map read . words <$> getLine
  as <- map read . words <$> getLine
  print $ getMinTime as t

import Data.List
import Data.Maybe

getInts = (map read . words) `fmap` getLine :: IO [Int]

main = do
    [n,t] <- getInts
    as <- getInts
    print $ 1 + (fromJust $ findIndex (\a -> a >= t) (scanl1 (+) (map (\a -> 86400 - a) as)))

main = getContents >>= print . exec
exec = solve . map read . words
solve (n:t:xs) = length $ takeWhile (> 0) $ scanl (\t x -> t - (86400 - x) :: Int) t xs

main :: IO ()
main = print . solve 0 . map read . words =<< getContents

solve :: Int -> [Int] -> Int
solve d (_:0:_) = d
solve d (n:t:a:ax) = solve (d + 1) (n:(maximum [0, t - (86400 - a)]):ax)

import Data.List

main = do
   [n,s] <- getLine >>=  return . map (read :: String -> Int) . words
   as <- getLine >>=  return . map (read :: String -> Int) . words
   let  d = fst $ foldl' (\acc@(d,t) x -> if t > 0 then (d+1,t-86400+x) else acc) (0,s) as
   print d

f::Int->[Int]->Int
f n _
  |n<=0=0
f n (x:xs)=1 + (f (n-(86400-x)) xs)

main = do
       e<-getLine
       es<-getLine
       let (a:b:[])=map read (words e)::[Int]
           xs=map read (words es)::[Int]
       print $ f b xs

import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe

main = do
		[n,t]<-map read <$> words <$> getLine::IO [Int]
		k<-scanl1 (+) <$> map (86400-) <$> map read <$> words <$> getLine::IO [Int]
 		print $ (+1) $ length $ takeWhile (<t) k

import Prelude
import Data.List
import Data.Maybe
import Data.Function
import Data.Char
--import qualified Data.ByteString.Lazy.Char8 as B

readInts :: IO [Int]
readInts = fmap (map (foldl' (\x y -> 10*x + digitToInt y) 0) . words) getLine

textRepresentation :: Show a => [a] -> String
textRepresentation row = unwords . map show $ row

f :: Int -> [Int] -> Int
f t (x:xs) = if t <= x then 1 else 1 + f (t-x) xs

main :: IO ()
main = do
    n:k:_ <- readInts
    a <- readInts
    print $ f k . map ((-) 86400) $ a


Polycarp was gifted an array $$$a$$$ of length $$$n$$$. Polycarp considers an array beautiful if there exists a number $$$C$$$, such that each number in the array occurs either zero or $$$C$$$ times. Polycarp wants to remove some elements from the array $$$a$$$ to make it beautiful.For example, if $$$n=6$$$ and $$$a = [1, 3, 2, 1, 4, 2]$$$, then the following options are possible to make the array $$$a$$$ array beautiful:   Polycarp removes elements at positions $$$2$$$ and $$$5$$$, array $$$a$$$ becomes equal to $$$[1, 2, 1, 2]$$$;  Polycarp removes elements at positions $$$1$$$ and $$$6$$$, array $$$a$$$ becomes equal to $$$[3, 2, 1, 4]$$$;  Polycarp removes elements at positions $$$1, 2$$$ and $$$6$$$, array $$$a$$$ becomes equal to $$$[2, 1, 4]$$$; Help Polycarp determine the minimum number of elements to remove from the array $$$a$$$ to make it beautiful.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of each test case consists of one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the length of the array $$$a$$$. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \le a_i \le 10^9$$$) — array $$$a$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, output one integer — the minimum number of elements that Polycarp has to remove from the array $$$a$$$ to make it beautiful.

-- https://codeforces.com/problemset/problem/1490/F
module Main where

import Data.List (nub)
import Data.Map as M (Map, alter, empty, toList)

main :: IO ()
main = getLine >>= \x -> wrapper (read x :: Int)

wrapper :: Int -> IO ()
wrapper x
  | x == 0 = return ()
  | otherwise = driver >> wrapper (x - 1)

driver :: IO ()
driver = getLine >> getLine >>= \x -> let arr = toArr x in print $ solve arr

toArr :: String -> [Int]
toArr = map (\x -> read x :: Int) . words

-- the value is the minimum of
solve :: [Int] -> Int
solve arr =
  let counts = toList $ getCounts arr
      mapF :: [(Int, Int)] -> Int -> Int
      mapF counts count =
        sum
          ( map
              ( \x ->
                  let count' = snd x
                   in if count' > count
                        then count' - count
                        else if count' == count then 0 else count'
              )
              counts
          )
   in minimum $ map (mapF counts) (nub $ map snd counts)

getCounts :: [Int] -> M.Map Int Int
getCounts = go M.empty
  where
    go m [] = m
    go m (x : xs) = go (M.alter f x m) xs

    f Nothing = Just 1
    f (Just x) = Just (x + 1)

{-# LANGUAGE OverloadedStrings, FunctionalDependencies, FlexibleContexts,
    ConstraintKinds, BangPatterns #-}

import Control.Applicative
import Control.Exception (assert)
import Control.Monad
import Control.Monad.State
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Bits
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Int
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable
import System.IO

------

type Hopper r = State [r]

type HopperT r = StateT [r]

runHopper :: Hopper r a -> [r] -> (a, [r])
runHopper = runState

evalHopper :: Hopper r a -> [r] -> a
evalHopper = evalState

runHopperT :: HopperT r m a -> [r] -> m (a, [r])
runHopperT = runStateT

evalHopperT :: Monad m => HopperT r m a -> [r] -> m a
evalHopperT = evalStateT

type MonadHopper r m = MonadState [r] m

pop :: MonadHopper r m => m (Maybe r)
pop = state f
  where
    f :: [r] -> (Maybe r, [r])
    f [] = (Nothing, [])
    f (q:qs) = (Just q, qs)

popJust :: MonadHopper r m => m r
popJust = fromJust <$> pop

------

popInt :: MonadHopper B.ByteString m => m Int
popInt = fst . fromJust . B.readInt <$> popJust

popInts :: MonadHopper B.ByteString m => m [Int]
popInts = map (fst . fromJust . B.readInt) . B.words <$> popJust

popInteger :: MonadHopper B.ByteString m => m Integer
popInteger = fst . fromJust . B.readInteger <$> popJust

popIntegers :: MonadHopper B.ByteString m => m [Integer]
popIntegers = map (fst . fromJust . B.readInteger) . B.words <$> popJust

------

dropCR :: B.ByteString -> B.ByteString
dropCR s | not (B.null s) && B.last s == '\r' = B.init s
         | otherwise = s

bshow :: Show a => a -> B.ByteString
bshow = B.pack . show

main = B.interact go
  where
    go :: B.ByteString -> B.ByteString
    go = evalHopper run . map dropCR . B.lines

------

run :: Hopper B.ByteString B.ByteString
run = do
  t <- popInt
  B.unlines <$> replicateM t run1

run1 = do
  n <- popInt
  as <- popInts
  return $ bshow (solve n as)

solve n as = minimum $ go 0 0 0 (reverse counts) (tail $ reverse ss)
  where
    counts = countList $ map snd $ countList as

    ss = snd $ mapAccumL (\s (a, b) -> (s + a * b, s + a * b)) 0 counts

    go acc a0 b0 ((a, b) : _) [] = [acc + (a0 - a) * b0]
    go acc a0 b0 ((a, b) : cs) (s : ss) =
      let acc' = acc + (a0 - a) * b0
          a1 = a
          b1 = b0 + b in
        (acc' + s) : go acc' a1 b1 cs ss

countList :: (Ord a) => [a] -> [(a, Int)]
countList xs = Map.assocs $ foldl' addm Map.empty xs
  where
    addm m x | Map.member x m = Map.adjust (+ 1) x m
             | otherwise = Map.insert x 1 m

{-# LANGUAGE BangPatterns #-}
import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

import qualified Data.Map.Strict as M

type SIO = StateT P.ByteString IO

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    a <- readInts
    let
      mkFreqMap li = M.fromListWith (+) $ zip li $ repeat 1
      freqs = M.elems $ mkFreqMap a
      --freqMap = [(head v, length v) | v <- group $ sort freqs]
      freqMap = M.assocs $ mkFreqMap freqs
      step (!prevCost, !remPop, !prevVal, !prevCt) (currVal, currCt) = let
        currCost = prevCost
          + prevCt * prevVal             -- send prevVals to 0...
          - remPop * (currVal - prevVal) -- ...but move the rest less
        newRemPop = remPop - currCt
        in  (currCost, newRemPop, currVal, currCt)
      options = scanl step (n, length freqs, 0, 0) freqMap
    putInts $ pure $ foldl' (\v (cost, _, _, _) -> min v cost) maxBound options

readLine :: SIO P.ByteString
readLine = do
  (out, next) <- P.break (<= '\r') <$> get
  put $ P.dropWhile (<= '\r') next
  pure out

readInts :: SIO [Int]
readInts = do
  currLine <- readLine
  pure [x | Just (x, _) <- P.readInt <$> P.words currLine]

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder

{-# LANGUAGE BangPatterns #-}
import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

import qualified Data.Map.Strict as M

type SIO = StateT P.ByteString IO

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    a <- readInts
    let
      freqs = M.elems $ M.fromListWith (+) $ zip a $ repeat 1
      freqMap = [(head v, length v) | v <- group $ sort freqs]
      step (!prevCost, !remPop, !prevVal, !prevCt) (currVal, currCt) = let
        currCost = prevCost
          + prevCt * prevVal             -- send prevVals to 0...
          - remPop * (currVal - prevVal) -- ...but move the rest less
        newRemPop = remPop - currCt
        in  (currCost, newRemPop, currVal, currCt)
      options = scanl step (n, length freqs, 0, 0) freqMap
    putInts $ pure $ foldl' (\v (cost, _, _, _) -> min v cost) maxBound options

readLine :: SIO P.ByteString
readLine = do
  (out, next) <- P.break (<= '\r') <$> get
  put $ P.dropWhile (<= '\r') next
  pure out

readInts :: SIO [Int]
readInts = do
  currLine <- readLine
  pure [x | Just (x, _) <- P.readInt <$> P.words currLine]

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder

import Control.Monad
import Data.List

solve :: IO ()
solve = do
    getLine
    as <- map read . words <$> getLine :: IO [Int]
    let cnts = reverse $ sort $ map length $ group $ sort as
        ans = minimum $ zipWith4 f [1..] cnts (scanl1 (+) cnts) (tail $ scanr (+) 0 cnts) where
            f i x sl sr = sl - i * x + sr
    print ans

main :: IO ()
main = readLn >>= flip replicateM_ solve

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

import Data.Map((!))

numOcc [] = M.empty
numOcc (x:xs) = let m = numOcc xs in case M.lookup x m of
	Just i -> M.insert x (i+1) m
	Nothing -> M.insert x 1 m

result list = aux (length sort) sort sumOcc where
	sort = fmap fst $ L.sortOn snd $ M.toList occ
	occ = numOcc list

	sumOcc = foldr (+) 0 occ

	aux l [] s = 0
	aux l (x:xs) s = min (s - y*l) (y + aux (l-1) xs (s-y)) where y = occ ! x

showR (x:xs) = show (x+1) ++ " " ++ showR xs
showR [] = []

main = do
	t <- getLine >>= return . read :: IO Integer
	let loop t = if t == 0 then return () else do
		n <- getLine >>= return . read :: IO Integer
		a <- getLine >>= return . (fmap read) . words :: IO [Integer]
		print $ result a
		loop $ t - 1
	loop t

{-# LANGUAGE OverloadedStrings, FunctionalDependencies, FlexibleContexts,
    ConstraintKinds, BangPatterns #-}

import Control.Applicative
import Control.Exception (assert)
import Control.Monad
import Control.Monad.State
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Bits
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Int
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable
import System.IO

------

type Hopper r = State [r]

type HopperT r = StateT [r]

runHopper :: Hopper r a -> [r] -> (a, [r])
runHopper = runState

evalHopper :: Hopper r a -> [r] -> a
evalHopper = evalState

runHopperT :: HopperT r m a -> [r] -> m (a, [r])
runHopperT = runStateT

evalHopperT :: Monad m => HopperT r m a -> [r] -> m a
evalHopperT = evalStateT

type MonadHopper r m = MonadState [r] m

pop :: MonadHopper r m => m (Maybe r)
pop = state f
  where
    f :: [r] -> (Maybe r, [r])
    f [] = (Nothing, [])
    f (q:qs) = (Just q, qs)

popJust :: MonadHopper r m => m r
popJust = fromJust <$> pop

------

popInt :: MonadHopper B.ByteString m => m Int
popInt = fst . fromJust . B.readInt <$> popJust

popInts :: MonadHopper B.ByteString m => m [Int]
popInts = map (fst . fromJust . B.readInt) . B.words <$> popJust

popInteger :: MonadHopper B.ByteString m => m Integer
popInteger = fst . fromJust . B.readInteger <$> popJust

popIntegers :: MonadHopper B.ByteString m => m [Integer]
popIntegers = map (fst . fromJust . B.readInteger) . B.words <$> popJust

------

dropCR :: B.ByteString -> B.ByteString
dropCR s | not (B.null s) && B.last s == '\r' = B.init s
         | otherwise = s

bshow :: Show a => a -> B.ByteString
bshow = B.pack . show

main = B.interact go
  where
    go :: B.ByteString -> B.ByteString
    go = evalHopper run . map dropCR . B.lines

------

run :: Hopper B.ByteString B.ByteString
run = do
  t <- popInt
  B.unlines <$> replicateM t run1

run1 = do
  n <- popInt
  as <- popInts
  return $ bshow (solve n as)

solve n as = minimum $ go 0 0 0 (reverse counts) (tail $ reverse ss)
  where
    counts = countList $ map snd $ countList as

    ss = snd $ mapAccumL (\s (a, b) -> (s + a * b, a * b)) 0 counts

    go acc a0 b0 ((a, b) : _) [] = [acc + (a0 - a) * b0]
    go acc a0 b0 ((a, b) : cs) (s : ss) =
      let acc' = acc + (a0 - a) * b0
          a1 = a
          b1 = b0 + b in
        (acc' + s) : go acc' a1 b1 cs ss

countList :: (Ord a) => [a] -> [(a, Int)]
countList xs = Map.assocs $ foldl' addm Map.empty xs
  where
    addm m x | Map.member x m = Map.adjust (+ 1) x m
             | otherwise = Map.insert x 1 m