After waking up at hh:mm, Andrew realised that he had forgotten to feed his only cat for yet another time (guess why there's only one cat). The cat's current hunger level is H points, moreover each minute without food increases his hunger by D points.At any time Andrew can visit the store where tasty buns are sold (you can assume that is doesn't take time to get to the store and back). One such bun costs C roubles and decreases hunger by N points. Since the demand for bakery drops heavily in the evening, there is a special 20% discount for buns starting from 20:00 (note that the cost might become rational). Of course, buns cannot be sold by parts.Determine the minimum amount of money Andrew has to spend in order to feed his cat. The cat is considered fed if its hunger level is less than or equal to zero.

The first line contains two integers hh and mm (00 ≤ hh ≤ 23, 00 ≤ mm ≤ 59) — the time of Andrew's awakening. The second line contains four integers H, D, C and N (1 ≤ H ≤ 105, 1 ≤ D, C, N ≤ 102).

Output the minimum amount of money to within three decimal digits. You answer is considered correct, if its absolute or relative error does not exceed 10 - 4. Formally, let your answer be a, and the jury's answer be b. Your answer is considered correct if .

NoteIn the first sample Andrew can visit the store at exactly 20:00. The cat's hunger will be equal to 315, hence it will be necessary to purchase 315 buns. The discount makes the final answer 25200 roubles.In the second sample it's optimal to visit the store right after he wakes up. Then he'll have to buy 91 bins per 15 roubles each and spend a total of 1365 roubles.

toMin hh mm = hh*60 + mm

till20 hh mm = if (toMin hh mm) > (toMin 20 00) then (toMin 24 00) - (toMin hh mm) + (toMin 20 00)
                                                else (toMin 20 00) - (toMin hh mm)

func :: Double -> Double -> Double -> Double -> Double -> Double -> Double
func hh mm h d c n = if hh >= 20 then (fromIntegral $ (ceiling $ (h / n))) * c * 0.8
                     else min case1 case2 where
                         case1 = (fromIntegral $ (ceiling $ ((till20 hh mm) * d + h) / n)) * c * 0.8
                         case2 = (fromIntegral $ (ceiling $ (h / n))) * c

main :: IO ()
main = do
    hhmm <- getLine
    hdcn <- getLine
    let hh:mm:_ = (map read $ words hhmm)::[Double]
    let h:d:c:n:_ = (map read $ words hdcn)::[Double]
    putStrLn $ show (func hh mm h d c n)
    return ()

main = interact exec
exec = (\[hh, mm, h, d, c, n] -> let w = max 0 $ ((20 - hh) * 60 - mm)  :: Int in show $ min (fromIntegral (ceiling (fromIntegral (h + d * w) / fromIntegral n)) * fromIntegral c * 0.8) (fromIntegral $ ceiling (fromIntegral h / fromIntegral n) * c)) . map read . words

-- (h + d * m) / n

module Main where

input :: IO [Double]
input = do
  [hh,mm] <- fmap (map read . words) getLine
  [h, d, c, n] <- fmap (map read . words) getLine
  return [hh, mm, h, d, c, n]

solve :: [Double] -> Double
solve [hh, mm, h, d, c, n]
  | hh >= 20 = r (c * 0.8) h
  | otherwise = min (r c h) $ r (c * 0.8) $ h + d * ((19 - hh) * 60 + 60 - mm)
      where r p hn = p * (fromIntegral $ ceiling $ hn / n)

main :: IO ()
main = print . solve =<< input

main = getContents >>= print . solve . map read . words

solve [h,m,a,i,c,n]
    | minutes >= 1200 = (*0.8) $ cost c n a
    | otherwise = min ((*0.8) $ cost c n $ (1200 - minutes) * i + a) (cost c n a)
    where minutes = h*60 + m

cost c n a = fromIntegral $ ((a + n - 1) `div` n) * c

main = getContents >>= print . solve . map read . words

solve [h,m,a,i,c,n] = min ((*0.8) $ cost c n $ (a + i * max 0 (1200 - h*60 - m))) (cost c n a)

cost c n a = fromIntegral $ ((a + n - 1) `div` n) * c

toMin hh mm = hh*60 + mm

till20 hh mm = if (toMin hh mm) > (toMin 20 00) then (toMin 24 00) - (toMin hh mm) + (toMin 20 00)
                                                else (toMin 20 00) - (toMin hh mm)

func :: Double -> Double -> Double -> Double -> Double -> Double -> Double
func hh mm h d c n = min case1 case2 where
    case1 = (fromIntegral $ (ceiling $ ((till20 hh mm) * d + h) / n)) * c * 0.8
    case2 = (fromIntegral $ (ceiling $ (h / n))) * c

main :: IO ()
main = do
    hhmm <- getLine
    hdcn <- getLine
    let hh:mm:_ = (map read $ words hhmm)::[Double]
    let h:d:c:n:_ = (map read $ words hdcn)::[Double]
    putStrLn $ show (func hh mm h d c n)
    return ()

main = interact exec
exec = (\[hh, mm, h, d, c, n] -> let w = ((20 - hh) * 60 + mm) `mod` 1440 :: Int in show $ min (fromIntegral (ceiling (fromIntegral (h + d * w) / fromIntegral n)) * fromIntegral c * 0.8) (fromIntegral $ ceiling (fromIntegral h / fromIntegral n) * c)) . map read . words

-- (h + d * m) / n

main = interact exec
exec = (\[hh, mm, h, d, c, n] -> let w = ((20 - hh) * 60 - mm) `mod` 1440 :: Int in show $ min (fromIntegral (ceiling (fromIntegral (h + d * w) / fromIntegral n)) * fromIntegral c * 0.8) (fromIntegral $ ceiling (fromIntegral h / fromIntegral n) * c)) . map read . words

-- (h + d * m) / n


There is a $$$n \times m$$$ grid. You are standing at cell $$$(1, 1)$$$ and your goal is to finish at cell $$$(n, m)$$$.You can move to the neighboring cells to the right or down. In other words, suppose you are standing at cell $$$(x, y)$$$. You can:   move right to the cell $$$(x, y + 1)$$$ — it costs $$$x$$$ burles;  move down to the cell $$$(x + 1, y)$$$ — it costs $$$y$$$ burles. Can you reach cell $$$(n, m)$$$ spending exactly $$$k$$$ burles?

The first line contains the single integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. The first and only line of each test case contains three integers $$$n$$$, $$$m$$$, and $$$k$$$ ($$$1 \le n, m \le 100$$$; $$$0 \le k \le 10^4$$$) — the sizes of grid and the exact amount of money you need to spend.

For each test case, if you can reach cell $$$(n, m)$$$ spending exactly $$$k$$$ burles, print YES. Otherwise, print NO. You may print every letter in any case you want (so, for example, the strings yEs, yes, Yes and YES are all recognized as positive answer).

NoteIn the first test case, you are already in the final cell, so you spend $$$0$$$ burles.In the second, third and fourth test cases, there are two paths from $$$(1, 1)$$$ to $$$(2, 2)$$$: $$$(1, 1)$$$ $$$\rightarrow$$$ $$$(1, 2)$$$ $$$\rightarrow$$$ $$$(2, 2)$$$ or $$$(1, 1)$$$ $$$\rightarrow$$$ $$$(2, 1)$$$ $$$\rightarrow$$$ $$$(2, 2)$$$. Both costs $$$1 + 2 = 3$$$ burles, so it's the only amount of money you can spend.In the fifth test case, there is the only way from $$$(1, 1)$$$ to $$$(1, 4)$$$ and it costs $$$1 + 1 + 1 = 3$$$ burles.

solve [] = [""]
solve (x:xs) = answer ++ solve xs
  where
    [n, m, k] = map read $ words x
    answer =
      if n * m - 1 == k
      then ["YES"]
      else ["NO"]

main = interact $ unlines . helper . lines
  where
    helper (x:xs) = solve xs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}

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

import qualified Data.Array as A

import qualified Control.Monad.State.Strict as State
import Control.Monad.ST

import Data.Bits(xor, (.&.), (.|.))
import qualified Data.Array.MArray as MA
import Data.STRef(STRef, newSTRef, readSTRef, writeSTRef)
import Data.Array.ST(runSTArray, STArray)
import Data.Array.IO(IOArray)

import Data.Array((!))
import Control.Monad(replicateM, filterM, forM) -- foldM est un foldl
import Data.Maybe

type Output = Bool

solve :: Integer -> Integer -> Integer -> Output
solve n m k = State.evalState (eval n m k) M.empty where

	eval i j k = do
		m <- State.get
		case M.lookup (i, j, k) m of
			Nothing -> do
				val <- aux eval i j k
				mem <- State.get
				State.put $ M.insert (i, j, k) val mem
				return val
			Just v -> return v

	aux fun i j k
		| i == 1 = return $! k == (j - 1)
		| j == 1 = return $! k == (i - 1)
		| i > k && j > k = return $! False
		| i > k = fun (i-1) j (k-j)
		| j > k = fun i (j-1) (k-i)
		| otherwise = do
			x1 <- fun (i-1) j (k-j)
			if x1 then return $! True else fun i (j-1) (k-i)

plotResult :: Output -> IO ()
plotResult False = putStrLn "NO"
plotResult True = putStrLn "YES"

main :: IO ()
main = do
	t <- getLine >>= return . read :: IO Int
	replicateM t $ do
		[n, m, k] <- getLine >>= return . (fmap read) . words :: IO [Integer]
		--a <- getLine >>= return . (fmap read) . words :: IO [Integer]
		plotResult $ solve n m k
	return ()

import Control.Arrow ((>>>))
import Data.Bool (bool)

main :: IO ()
main =
  interact $
  lines >>>
  tail >>> map (words >>> map read >>> solve >>> bool "NO" "YES") >>> unlines

solve :: [Int] -> Bool
solve [n, m, k] = n * m - 1 == k


There is a grid with $$$n$$$ rows and $$$m$$$ columns, and three types of cells:   An empty cell, denoted with '.'.  A stone, denoted with '*'.  An obstacle, denoted with the lowercase Latin letter 'o'. All stones fall down until they meet the floor (the bottom row), an obstacle, or other stone which is already immovable. (In other words, all the stones just fall down as long as they can fall.)Simulate the process. What does the resulting grid look like?

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 100$$$) — the number of test cases. The description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n, m \leq 50$$$) — the number of rows and the number of columns in the grid, respectively. Then $$$n$$$ lines follow, each containing $$$m$$$ characters. Each of these characters is either '.', '*', or 'o' — an empty cell, a stone, or an obstacle, respectively.

For each test case, output a grid with $$$n$$$ rows and $$$m$$$ columns, showing the result of the process. You don't need to output a new line after each test, it is in the samples just for clarity.

simulate' :: String -> Int -> Int -> String
simulate' [] empty stone = (replicate empty '.') ++ (replicate stone '*')
simulate' (x : xs) empty stone
 | (x == '.') = simulate' xs (empty + 1) stone
 | (x == '*') = simulate' xs empty (stone + 1)
 | otherwise = (replicate empty '.') ++ (replicate stone '*') ++ "o" ++ simulate' xs 0 0

simulate :: String -> String
simulate s = simulate' s 0 0

rotate'' :: String -> [String] -> [String]
rotate'' [] [] = []
rotate'' (x : xs) (y : ys) = [y ++ [x]] ++ rotate'' xs ys

rotate' :: [String] -> [String] -> [String]
rotate' [] gridNew = gridNew
rotate' (x : xs) gridNew = rotate' xs (rotate'' x gridNew)

rotate :: [String] -> [String]
rotate a = rotate' a (replicate (length (head a)) [])

join :: String -> [String] -> String
join _ [x] = x
join delimiter (x : xs) = x ++ delimiter ++ join delimiter xs

readLine :: IO String
readLine = do
 line <- getLine
 return line

ans :: IO String
ans = do
 nmInput <- getLine
 let [n, m] = [read e :: Int | e <- words nmInput]
 grid <- sequence (replicate n readLine)
 let rowToCol = rotate grid
 let simulates = [simulate e | e <- rowToCol]
 let colToRow = rotate simulates
 return (join "\r\n" colToRow)

main :: IO ()
main = do
 tInput <- getLine
 let t = read tInput :: Int
 results <- sequence (replicate t ans)
 putStrLn (join "\r\n" results)


This is the hard version of the problem. The difference between the versions is that in the easy version all prices $$$a_i$$$ are different. You can make hacks if and only if you solved both versions of the problem.Today is Sage's birthday, and she will go shopping to buy ice spheres. All $$$n$$$ ice spheres are placed in a row and they are numbered from $$$1$$$ to $$$n$$$ from left to right. Each ice sphere has a positive integer price. In this version, some prices can be equal.An ice sphere is cheap if it costs strictly less than two neighboring ice spheres: the nearest to the left and the nearest to the right. The leftmost and the rightmost ice spheres are not cheap. Sage will choose all cheap ice spheres and then buy only them.You can visit the shop before Sage and reorder the ice spheres as you wish. Find out the maximum number of ice spheres that Sage can buy, and show how the ice spheres should be reordered.

The first line contains a single integer $$$n$$$ $$$(1 \le n \le 10^5)$$$ — the number of ice spheres in the shop. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ $$$(1 \le a_i \le 10^9)$$$ — the prices of ice spheres.

In the first line print the maximum number of ice spheres that Sage can buy. In the second line print the prices of ice spheres in the optimal order. If there are several correct answers, you can print any of them.

NoteIn the sample it's not possible to place the ice spheres in any order so that Sage would buy $$$4$$$ of them. If the spheres are placed in the order $$$(3, 1, 4, 2, 4, 2, 5)$$$, then Sage will buy one sphere for $$$1$$$ and two spheres for $$$2$$$ each.

{- This code was written by
Russell Emerine - linguist,
mathematician, coder,
musician, and metalhead. -}
import Data.List

main = do
  getLine
  as <- sort . map read . words <$> getLine :: IO [Integer]
  let solution = solve as
  print $ cheap solution
  putStrLn $ unwords $ map show solution

solve as
  | even $ length as = (\(a, b) -> [a, b]) =<< zip (as !! pred d : take (pred d) as) (drop d as)
  | otherwise = (as !! d :) $ (\(a, b) -> [a, b]) =<< zip (take d as) (drop (succ d) as)
  where
    d = length as `div` 2

cheap = length . filter (\(a, b, c) -> a > b && b < c) . (zip3 <*> tail <*> tail . tail)

import Data.List

main :: IO ()
main = do
  n <- readLn
  as <- (map read.words) <$> getLine
  let (a,b) = solve n as
  print a
  putStrLn $ (unwords.map show) b

solve :: Int -> [Int] -> (Int,[Int])
solve n as = (r, order)
  where
    as' = sort as
    (smalls,bigs) = splitAt ((n) `div` 2) as'
    order = merge bigs smalls
    r = length $ filter (\(a,b,c) -> a>b && b<c) $ zip3 order (tail order) (drop 2 order)

merge :: [a] -> [a] -> [a]
merge (a:as) (b:bs) = a:b:merge as bs
merge as bs = as ++ bs

import Data.List
import Data.Int
import Data.Char
import Control.Monad

readArray :: IO [Int64]
readArray = do
    line <- getLine
    return $ map (read::String->Int64) $ words line

readInt :: IO Int
readInt = do
    line <- getLine
    return $ (read::String->Int) $ line

count :: Eq a => a -> [a] -> Int
count x = length . filter (==x)

merge :: [a] -> [a] -> [a]
merge [] ys = ys
merge (x:xs) ys = x:(merge ys xs)

calc :: [Int64] -> Int64
calc (x:y:z:xs) = (if y < x && y < z then 1 else 0) + calc (z:xs)
calc _ = 0

rotate xs n = take len . drop (n `mod` len) . cycle $ xs
    where len = length xs

solve :: IO ()
solve = do
    n <- readInt
    b <- readArray
    let a = reverse $ sort b
    let (large,small) = splitAt ((n + 1) `div` 2) a
    let small' = if even n then rotate small 1 else small
    let res = merge large small'
    let answer = calc res
    print answer
    forM_ res $ (\x -> print x)
    return ()

main :: IO ()
main = do
    -- t <- readInt
    -- forM_ [0..t-1] $ (\i -> solve)
    solve

import Data.List

trySolve :: Int -> [Int] -> Int -> Maybe [Int]
trySolve n as k = if  k + k + 1 > n
  then  Nothing
  else  let
    (lows, nonlows) = splitAt k as
    (rev_his, mids) = splitAt (k+1) (reverse nonlows)
    his = reverse rev_his
  in  if  and $ zipWith (<) lows his
  then  Just $ stitch lows his ++ mids
  else  Nothing

stitch :: [Int] -> [Int] -> [Int]
stitch [] [] = []
stitch ps (q:qs) = q : stitch qs ps
stitch _ _ = error "stitch: invalid args"

binSearch :: (Int -> Bool) -> Int -> Int -> Int
binSearch p = let
  go low top = if  low == top
    then  low
    else  let
    mid = div (low + top + 1) 2
    in  if  p mid
    then  go mid top
    else  go low (mid - 1)
  in  go

solve :: Int -> [Int] -> (Int, [Int])
solve n li = let
  p k = case  trySolve n li k  of
    Nothing -> False
    _ -> True
  ktar = binSearch p 0 (n + 100)
  in  case  trySolve n li ktar  of
    Nothing -> error "binSearch failed?"
    Just ans -> (ktar, ans)

main :: IO ()
main = do
  n <- read <$> getLine
  a <- map read . words <$> getLine
  let  (ktar, ans) = solve n (sort a)
  print ktar
  putStrLn . unwords $ map show ans

import Data.List

main :: IO ()
main = do
  n <- readLn
  as <- (map read.words) <$> getLine
  let (a,b) = solve n as
  print a
  putStrLn $ (unwords.map show) b

solve :: Int -> [Int] -> (Int,[Int])
solve n as = (r, order)
  where
    as' = sort as
    (smalls,bigs) = splitAt ((n-1) `div` 2) as'
    order = merge bigs smalls
    r = length $ filter (\(a,b,c) -> a>b && b<c) $ zip3 order (tail order) (drop 2 order)

merge :: [a] -> [a] -> [a]
merge (a:as) (b:bs) = a:b:merge as bs
merge as bs = as ++ bs

import Data.List
import Data.Int
import Data.Char
import Control.Monad
import Data.Bits

readArray :: IO [Int64]
readArray = do
    line <- getLine
    return $ map (read::String->Int64) $ words line

readInt :: IO Int
readInt = do
    line <- getLine
    return $ (read::String->Int) $ line

count :: Eq a => a -> [a] -> Int
count x = length . filter (==x)

merge :: [a] -> [a] -> [a]
merge [] ys = ys
merge (x:xs) ys = x:(merge ys xs)

calc :: [Int64] -> Int64
calc (x:y:z:xs) = (if y < x && y < z then 1 else 0) + calc (z:xs)
calc _ = 0

solve :: IO ()
solve = do
    n <- readInt
    b <- readArray
    let a = reverse $ sort b
    let (large,small) = splitAt ((n + 1) `div` 2) a
    let res = merge large small
    let answer = calc res
    print answer
    forM_ res $ (\x -> print x)
    return ()

main :: IO ()
main = do
    -- t <- readInt
    -- forM_ [0..t-1] $ (\i -> solve)
    solve


Permutation p is an ordered set of integers p1,  p2,  ...,  pn, consisting of n distinct positive integers, each of them doesn't exceed n. We'll denote the i-th element of permutation p as pi. We'll call number n the size or the length of permutation p1,  p2,  ...,  pn.You have a sequence of integers a1, a2, ..., an. In one move, you are allowed to decrease or increase any number by one. Count the minimum number of moves, needed to build a permutation from this sequence.

The first line contains integer n (1 ≤ n ≤ 3·105) — the size of the sought permutation. The second line contains n integers a1, a2, ..., an ( - 109 ≤ ai ≤ 109).

Print a single number — the minimum number of moves. Please, do not use the %lld specifier to read or write 64-bit integers in C++. It is preferred to use the cin, cout streams or the %I64d specifier.

NoteIn the first sample you should decrease the first number by one and then increase the second number by one. The resulting permutation is (2, 1).In the second sample you need 6 moves to build permutation (1, 3, 2).

import Control.Monad (liftM)
import Data.Char (ord)
import Data.List (intercalate, sort)

solve :: [Integer] -> Integer
solve  =  sum . map abs . zipWith (-) [1..] . sort

main :: IO ()
main  =  do
    getLine
    as  <-  reads
    print $ solve as

  where

    reads :: Num a => IO [a]
    reads  =  liftM (map read . words) getLine
      where
        read ('-':s)  =  (-1) * read s
        read s  =  read' 0 s
        read' a ""  =  a
        read' a (c:s)  =  read' (10 * a + fromIntegral (ord c - ord '0')) s

    prints :: Show a => [a] -> IO ()
    prints  =  putStrLn . intercalate " " . map show

import qualified Data.List as DL
import qualified Data.ByteString.Char8 as BC
import Data.Maybe (fromJust)

f::(Integer,Integer)->Integer
f (a,b)=abs(a-b)

main = do
       e1<-BC.getLine
       e2<-BC.getLine
       let xs=map (fst . fromJust . BC.readInteger) . BC.words $ e2
           xs2=DL.sort xs
           ys=zip xs2 [1..]
       print $ sum (map f ys)

import Data.List (sort)
import Data.Maybe (fromJust)
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = B.getContents >>= print . solve . map (fromIntegral . fst . fromJust . B.readInt) . tail . B.words

solve :: [Integer] -> Integer
solve = sum . map abs . zipWith (-) [1..] . sort

import Data.Int
import Data.List
import qualified Data.ByteString.Char8 as B
main = print . solve . map readI . tail . B.words =<< B.getContents
solve as = sum $ zipWith ((abs .) . (-)) [1..] $ sort as :: Int64
readI b = fromIntegral i where Just (i,_) = B.readInt b

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.List

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

main :: IO ()
main = do
  n <- readLn
  xs <- map readInt.B.words <$> B.getLine
  print $ solve  n xs

solve :: Int -> [Int] -> Integer
solve n xs = sum.map toInteger.zipWith ((abs.).(-)) [1..n] $ sort xs

import Control.Applicative
import Data.Bits
import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.List

main = do
	getLine
	s<- sort.map (fst.fromJust.C.readInt) . C.words <$> C.getLine
	print  $ sum $ map fromIntegral $ zipWith (\a b -> abs (a-b)) s [1..]

import Control.Applicative
import Data.Bits
import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.List

main = do
	getLine
	s<- sort.map (fst.fromJust.C.readInt) . C.words <$> C.getLine
	print  $ sum $ zipWith (\a b -> abs (a-b)) s [1..]


You are given a string $$$s$$$, consisting of brackets of two types: '(', ')', '[' and ']'.A string is called a regular bracket sequence (RBS) if it's of one of the following types:   empty string;  '(' + RBS + ')';  '[' + RBS + ']';  RBS + RBS. where plus is a concatenation of two strings.In one move you can choose a non-empty subsequence of the string $$$s$$$ (not necessarily consecutive) that is an RBS, remove it from the string and concatenate the remaining parts without changing the order.What is the maximum number of moves you can perform?

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of testcases. Each of the next $$$t$$$ lines contains a non-empty string, consisting only of characters '(', ')', '[' and ']'. The total length of the strings over all testcases doesn't exceed $$$2 \cdot 10^5$$$.

For each testcase print a single integer — the maximum number of moves you can perform on a given string $$$s$$$.

NoteIn the first example you can just erase the whole string.In the second example you can first erase the brackets on positions $$$1$$$ and $$$2$$$: "[]()", then "()" is left. After that you can erase it whole. You could erase the whole string from the beginning but you would get one move instead of two.In the third example you can first erase the brackets on positions $$$1$$$ and $$$3$$$: "([)]". They form an RBS "()". Then "[]" is left, so you can erase it whole.In the fourth example there is no subsequence that is an RBS, so you can't perform a move at all.In the fifth example you can erase the brackets on positions $$$2$$$ and $$$4$$$: ")[(]" and get ")(" as a result. You can erase nothing from it.

import Control.Monad
import qualified Data.Map.Strict as Map

main = do
  cases <- read <$> getLine
  replicateM cases $ do
    bracketStr <- getLine
    putStrLn $ show $ countMoves bracketStr

countMoves :: String -> Int
countMoves str = min (filledBracketMap Map.! '[') (filledBracketMap Map.! ']') + min (filledBracketMap Map.! '(') (filledBracketMap Map.! ')')
  where
    emptyBracketMap = Map.fromList [('[', 0), (']', 0), ('(', 0), (')', 0)]
    filledBracketMap = foldr updateMap emptyBracketMap str
    updateMap c bm
      | c == ']' || c == ')' = Map.update (Just . (+1)) c bm
      | c == '(' = if (bm Map.! ')' > bm Map.! '(') then Map.update (Just . (+1)) c bm else bm
      | c == '[' = if (bm Map.! ']' > bm Map.! '[') then Map.update (Just . (+1)) c bm else bm


Once Bob decided to lay a parquet floor in his living room. The living room is of size n × m metres. Bob had planks of three types: a planks 1 × 2 meters, b planks 2 × 1 meters, and c planks 2 × 2 meters. Help Bob find out, if it is possible to parquet the living room with such a set of planks, and if it is possible, find one of the possible ways to do so. Bob doesn't have to use all the planks.

The first input line contains 5 space-separated integer numbers n, m, a, b, c (1 ≤ n, m ≤ 100, 0 ≤ a, b, c ≤ 104), n and m — the living room dimensions, a, b and c — amount of planks 1 × 2, 2 × 1 и 2 × 2 respectively. It's not allowed to turn the planks.

If it is not possible to parquet the room with such a set of planks, output IMPOSSIBLE. Otherwise output one of the possible ways to parquet the room — output n lines with m lower-case Latin letters each. Two squares with common sides should contain the same letters, if they belong to one and the same plank, and different letters otherwise. Different planks can be marked with one and the same letter (see examples). If the answer is not unique, output any.

import Array
import Control.Monad
import Control.Applicative

mark i j x = c ! (idx !! (x ! (div i 2, div j 2)))
  where
    c = listArray ((0, 0, 0), (2, 1, 1)) ['a'..]
    idx = [(0, div j' 2, mod i' 2), (1, div i' 2, mod j' 2), (2, div j' 2, div i' 2)]
    i' = mod i 4
    j' = mod j 4

tile n m a b c = Just [[mark i j x | j <- [0..(2*m-1)]] | i <- [0..(2*n-1)]]
    where x = listArray ((0,0), (n-1, m-1)) $ replicate a 0 ++ replicate b 1 ++ replicate c 2

solve n m a b c
  | odd n && odd m = Nothing
  | odd n && even m =
    if a < div m 2
     then Nothing
     else (:) (take m xy) <$> solve (n-1) m (a - div m 2) b c
  | even n && odd m =
    if b < div n 2
     then Nothing
     else zipWith (:) (take n xy) <$> solve n (m-1) a (b-(div n 2)) c
  | otherwise =
    if (div a 2 * 4 + div b 2 * 4 + c*4) < n*m
     then Nothing
     else tile (div n 2) (div m 2) (div a 2) (div b 2) c
  where xy = cycle "xxyy"

main = do
    [n, m, a, b, c] <- map read . words <$> getLine
    mapM_ putStrLn (maybe ["IMPOSSIBLE"] id $ solve n m a b c)

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.ST

solve :: [String] -> [String]
solve = do
  [n, m, a, b, c] <- map read . words . head
  let draw flag = runST $ do
        let r = ((1, 1), (n, m))
        arr <- newArray r '*' :: ST s (STArray s (Int, Int) Char)
        let check idx@(j, i) state@(a', b', c') = do
              let nextChar z = if z == 'd' then 'a' else succ z
              if (inRange r idx) && flag /= 0
                then case flag of
                  1 -> do
                    x <- if not $ inRange r (j - 1, i)
                           then return 'a'
                           else nextChar <$> readArray arr (j - 1, i)
                    writeArray arr (j, i)     x
                    writeArray arr (j + 1, i) x
                    check (j + 2, i) (a', b' - 1, c')
                  2 -> do
                    x <- if not $ inRange r (j, i - 1)
                           then return 'a'
                           else nextChar <$> readArray arr (j, i - 1)
                    writeArray arr (j, i)     x
                    writeArray arr (j, i + 1) x
                    check (j, i + 2) (a' - 1, b', c')
                else return state
        let fill idx@(j, i) state = do
              let next = fill (j, i + 1)
              when (j <= n) $ do
                if i > m
                  then fill (j + 1, 1) state
                  else do
                    x <- readArray arr idx
                    if x /= '*'
                      then next state
                      else do
                        let check z = if z == '*' then [] else [z]
                        let pickup zs = do
                              cs <- fmap (concatMap check) . mapM (readArray arr) $ filter (inRange r) zs
                              return $ filter (`notElem` cs) "abcd"
                        let write zs = sequence $ do
                              (z, ps) <- zs
                              return $ mapM_ (flip (writeArray arr) z) ps
                        case state of
                          (a', b', c')
                            | c' > 0 -> do
                              x1 <-  head <$> pickup [(j - 1, i), (j, i - 1)]
                              write [(x1, [idx, (j + 1, i), (j, i + 1), (j + 1, i + 1)])]
                              next (a', b', c' - 1)
                            | b' > 0 -> do
                              x1 <- head <$> pickup [(j - 1, i), (j, i - 1), (j + 1, i - 1)]
                              x2 <- head . filter (/= x1) <$> pickup [(j - 1, i + 1)]
                              write [(x1, [idx, (j + 1, i)]), (x2, [(j, i + 1), (j + 1, i + 1)])]
                              next (a', b' - 1, c')
                            | a' > 0 -> do
                              x1 <- head <$> pickup [(j, i - 1), (j - 1, i), (j - 1, i + 1)]
                              x2 <- head . filter (/= x1) <$> pickup [(j + 1, i - 1)]
                              write [(x1, [idx, (j, i + 1)]), (x2, [(j + 1, i), (j + 1, i + 1)])]
                              next (a' - 1, b', c')
                          _ -> error "Never happens!"
        (a', b', c') <- check (1, 1) (a, b, c)
        fill (1, 1) (a' `quot` 2, b' `quot` 2, c')
        let split = takeWhile (not . null) . map (take m) . iterate (drop m)
        split <$> getElems arr
  return . maybe (return "IMPOSSIBLE") draw $ do
        let (p, s) = m `quotRem` 2 ; (q, t) = n `quotRem` 2
        let flag = sum . zipWith (*) [1 ..] $ map fromEnum [s /= 0, t /= 0]
        guard $ flag /= 3
        let ds = [a * 2 - m * t, b * 2 - n * s]
        guard $ all even ds && all (0 <=) ds
        let d = sum $ map (`quot` 4) ds
        guard $ p * q <= c + d
        return flag

main :: IO ()
main = interact $ unlines . solve . lines


You are given a string $$$s$$$ consisting of lowercase English letters and a number $$$k$$$. Let's call a string consisting of lowercase English letters beautiful if the number of occurrences of each letter in that string is divisible by $$$k$$$. You are asked to find the lexicographically smallest beautiful string of length $$$n$$$, which is lexicographically greater or equal to string $$$s$$$. If such a string does not exist, output $$$-1$$$.A string $$$a$$$ is lexicographically smaller than a string $$$b$$$ if and only if one of the following holds:   $$$a$$$ is a prefix of $$$b$$$, but $$$a \ne b$$$;  in the first position where $$$a$$$ and $$$b$$$ differ, the string $$$a$$$ has a letter that appears earlier in the alphabet than the corresponding letter in $$$b$$$.

The first line contains a single integer $$$T$$$ ($$$1 \le T \le 10\,000$$$) — the number of test cases. The next $$$2 \cdot T$$$ lines contain the description of test cases. The description of each test case consists of two lines. The first line of the description contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 10^5$$$) — the length of string $$$s$$$ and number $$$k$$$ respectively. The second line contains string $$$s$$$ consisting of lowercase English letters. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case output in a separate line lexicographically smallest beautiful string of length $$$n$$$, which is greater or equal to string $$$s$$$, or $$$-1$$$ if such a string does not exist.

4
4 2
abcd
3 1
abc
4 3
aaaa
9 3
abaabaaaa

NoteIn the first test case "acac" is greater than or equal to $$$s$$$, and each letter appears $$$2$$$ or $$$0$$$ times in it, so it is beautiful.In the second test case each letter appears $$$0$$$ or $$$1$$$ times in $$$s$$$, so $$$s$$$ itself is the answer.We can show that there is no suitable string in the third test case.In the fourth test case each letter appears $$$0$$$, $$$3$$$, or $$$6$$$ times in "abaabaaab". All these integers are divisible by $$$3$$$.

-- Michael V. Antosha
-- 2021
-- Michael.Antosha@gmail.com

--
-- K-beautiful Strings
-- (upsolving)
--
-- Problem statement:
--
--     http://codeforces.com/contest/1493/problem/C
--
-- Tutorial:
--
--     http://codeforces.com/blog/entry/88422
--

{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Maybe
import Data.Monoid
import Data.Array.Unboxed

main = interact $ unlines . map solveTC . linePairs . tail . lines
  where
    readI s = read s :: Int

    linePairs [] = []
    ---------------------------- N     K     S    ---------------------
    linePairs (strNK:strS:ls) = (lenS, modK, strS) : linePairs ls
      where
        [lenS, modK] = (map readI . words) strNK

solveTC (lenS, modK, strS) = (fromMaybe "-1" . maybeFirst) solutions
  where
    solutions | lenS `mod` modK /= 0   = [Nothing] :: [Maybe String]
              | isBeautiful            = [Just strS]
              | otherwise              = findSolutions

    isBeautiful = ((== 0) . cntSum . cntLack modK . last) psumsHave

    psumsHave = scanl cntUpdate cntZero strS

    findSolutions = richMidcharPositions prefLengths >>= midposSolutions

    prefLengths = [0 .. lenS - 1]

    richMidcharPositions = reverse . zip3 strS psumsHave
    --
    midposSolutions (origMidChar, origCnts, prefLen)
        = (map . fmap) (pref ++) (map midcharSolution charCandidates)
      where
        pref = take prefLen strS     -- chars before the mid char

        suffLen = lenS - prefLen - 1     -- number of chars after the mid char

        charCandidates = [succ origMidChar .. 'z']

        midcharSolution charCandidate
            = fmap (charCandidate :) (solveSuffix (cntLack modK newCnts) suffLen)
          where
            newCnts = cntUpdate origCnts charCandidate

-- Generate the lexicographically smallest string of given length and
-- minimal occurrences for each character.
--
solveSuffix :: CharCounts -> Int -> Maybe String
--
solveSuffix cntsNeed len | cntA < 0   = Nothing
                         | otherwise  = Just . runLenDecode  $  ('a',cntA) : assocs cntsNeed
  where
    cntA = len - cntSum cntsNeed

runLenDecode = foldMap d
  where
    d (ch, cnt) = replicate cnt ch

maybeFirst = getAlt . foldMap Alt     -- choose first valid solution

--------------------------------------------

type CharCounts = UArray Char Int

cntZero = array ('a','z') [] :: CharCounts

cntUpdate cnts ch = cnts // [(ch, 1 + cnts!ch)]

cntSum = sum . elems

cntLack k cnts = amap lackFromHave cnts
  where
    mk = (`mod` k)
    lackFromHave = mk . (k -) . mk  -- Given a letter count,
                                    -- how many such letters we need to add?

import Control.Monad
import Data.Maybe
import Data.Array
import Data.List
import Data.Either
import qualified Data.ByteString.Char8 as C

getInts :: IO [Int]
getInts = map (fst . fromJust . C.readInt) . C.words <$> C.getLine

type State = Either String (Array Char Int, Int)

main :: IO ()
main = do
  [t] <- getInts
  replicateM_ t $ do
    [n, k] <- getInts
    s <- take n . C.unpack <$> C.getLine
    let
      getNeed x
        | y == 0 = 0
        | otherwise = k - y
        where
        y = x `mod` k
      acc :: State -> Char -> State
      acc tt c
        | isLeft tt = Left $ c : fromLeft "" tt
        | m + 1 > cm && c < 'z' = Left $ choose (succ c)
        | m + 1 == cm && not (null candidates) = Left $ choose $ fst $ head candidates
        | otherwise = Right (arr', m + 1)
        where
        Right (arr, m) = tt
        arr' = arr // [(c, arr ! c - 1)]
        cm = sum $ map getNeed $ elems arr'
        choose ch = ch : ss'
          where
          a = arr' // [(ch, arr' ! ch + 1)]
          ss = concat $ map (\(o, x) -> take (getNeed x) $ repeat o) $ assocs a
          ss' = take (m - length ss) (repeat 'a') ++ ss
        candidates = filter (\(ch, x) -> ch > c && x `mod` k /= 0) $ assocs arr'
      a0 = accumArray (+) 0 ('a', 'z') $ zip s $ repeat 1
      result
        | n `mod` k /= 0 = "-1"
        | null (filter (\x -> x `mod` k /= 0) $ elems a0) = s
        | otherwise = fromLeft "" $ foldl' acc (Right (a0, 0)) $ reverse s
    C.putStrLn $ C.pack result

-- Michael V. Antosha
-- 2021
-- Michael.Antosha@gmail.com

--
-- K-beautiful Strings
-- (upsolving)
--
-- Problem statement:
--
--     http://codeforces.com/contest/1493/problem/C
--
-- Tutorial:
--
--     http://codeforces.com/blog/entry/88422
--

{-# LANGUAGE NoMonomorphismRestriction #-}

import qualified Data.List as List
import Data.Maybe (Maybe(Just,Nothing), fromMaybe)
import Data.Monoid (Alt(Alt), getAlt)
import Data.Array.Unboxed (UArray, array)
import Control.Arrow((&&&))

main = interact $ unlines . map solveTC . linePairs . tail . lines

linePairs [] = []
---------------------------- N     K     S    ---------------------
linePairs (strNK:strS:ls) = (lenS, modK, strS) : linePairs ls
  where
    [lenS, modK] = (map readI . words) strNK

readI s = read s :: Int

solveTC (lenS, modK, strS) = (fromMaybe "-1" . maybeFirst) solutions
  where
    solutions
        | lenS `mod` modK /= 0   = [Nothing] :: [Maybe String]
        | isBeautiful modK strS  = [Just strS]
        | otherwise              = (map (solveFixedPrefix . charCounts $ strS) . reverse) [0 .. lenS-1]

    solveFixedPrefix cnts lenP = Just "trwtretwe"   -- TODO

isBeautiful modK strS = False   -- TODO

maybeFirst = getAlt . foldMap Alt

charCounts = toArr . map (head &&& length) . List.group . List.sort
  where
    toArr pairs = array ('a','z') pairs :: UArray Char Int


Nastya owns too many arrays now, so she wants to delete the least important of them. However, she discovered that this array is magic! Nastya now knows that the array has the following properties:  In one second we can add an arbitrary (possibly negative) integer to all elements of the array that are not equal to zero.  When all elements of the array become equal to zero, the array explodes. Nastya is always busy, so she wants to explode the array as fast as possible. Compute the minimum time in which the array can be exploded.

The first line contains a single integer n (1 ≤ n ≤ 105) — the size of the array. The second line contains n integers a1, a2, ..., an ( - 105 ≤ ai ≤ 105) — the elements of the array.

Print a single integer — the minimum number of seconds needed to make all elements of the array equal to zero.

NoteIn the first example you can add  - 1 to all non-zero elements in one second and make them equal to zero.In the second example you can add  - 2 on the first second, then the array becomes equal to [0, 0,  - 3]. On the second second you can add 3 to the third (the only non-zero) element.

import Data.List

f::[(Int,Int)]->Int
f []=0
f ((0,_):xs)=f xs
f (_:xs)=1+f xs

main = do
       e<-getLine
       es<-getLine
       let xs=map read (words es)::[Int]
           ys=group $ sort xs
           zs=zip (map head ys) (map length ys)
       print $ f zs

import Control.Applicative
import Control.Monad
import Data.List
import Data.Array

main = do
	getLine
	k<-length <$> group <$> filter (/=0) <$> sort <$> map read <$> words <$> getLine:: IO Int
	print k

import Data.List
-- import Debug.Trace

myunique arr =
  foldr f [0] arr
  where
    f item acc = if item == head acc then acc else item:acc

solve :: String -> String
solve s = show $ length $ filter (/=0) $ myunique $ sort $ map read $ tail $ words s

main :: IO ()
main = do
  buf <- getContents
  putStrLn $ solve buf

module Main where

import System.IO
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8

import qualified Data.Array as Array
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Map as Map

import Control.Monad

input :: IO BS.ByteString
input = do
  handle <- return stdin --openFile "test.txt" ReadMode
  BS.hGetContents handle

readInts :: BS.ByteString -> [Int]
readInts = map parse . C8.words
  where parse s = let Just(x,_) = C8.readInt s in x

main :: IO ()
main = do
  _ <- getLine
  bs <- input
  let array = readInts bs
  print $ length . List.filter ((/= 0) . head)
    . List.group . List.sort $ array

import Data.List

solve :: String -> String
solve s = show $ length $ nub $ tail $ words s

main :: IO ()
main = do
  buf <- getContents
  putStrLn $ solve buf

module Main where

import System.IO
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8

import qualified Data.Array as Array
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Map as Map

import Control.Monad

input :: IO BS.ByteString
input = do
  handle <- return stdin --openFile "test.txt" ReadMode
  BS.hGetContents handle

readInts :: BS.ByteString -> [Int]
readInts = map parse . C8.words
  where parse s = let Just(x,_) = C8.readInt s in x

main :: IO ()
main = do
  _ <- getLine
  bs <- input
  let array = readInts bs
  print $ length . List.group . List.sort $ array


In some country there are exactly n cities and m bidirectional roads connecting the cities. Cities are numbered with integers from 1 to n. If cities a and b are connected by a road, then in an hour you can go along this road either from city a to city b, or from city b to city a. The road network is such that from any city you can get to any other one by moving along the roads.You want to destroy the largest possible number of roads in the country so that the remaining roads would allow you to get from city s1 to city t1 in at most l1 hours and get from city s2 to city t2 in at most l2 hours.Determine what maximum number of roads you need to destroy in order to meet the condition of your plan. If it is impossible to reach the desired result, print -1.

The first line contains two integers n, m (1 ≤ n ≤ 3000, ) — the number of cities and roads in the country, respectively.  Next m lines contain the descriptions of the roads as pairs of integers ai, bi (1 ≤ ai, bi ≤ n, ai ≠ bi). It is guaranteed that the roads that are given in the description can transport you from any city to any other one. It is guaranteed that each pair of cities has at most one road between them. The last two lines contains three integers each, s1, t1, l1 and s2, t2, l2, respectively (1 ≤ si, ti ≤ n, 0 ≤ li ≤ n).

Print a single number — the answer to the problem. If the it is impossible to meet the conditions, print -1.

{-# LANGUAGE BangPatterns #-}
module Main where

import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.STRef
import Data.Array.Unboxed
import Data.Graph hiding (buildG)
import Data.Tuple (swap)
import qualified Data.Graph as G

data Queue s = Queue { values :: STUArray s Int Int
                     , front  :: STRef s Int
                     , rear   :: STRef s Int
                     }

mkQueue :: Int -> ST s (Queue s)
mkQueue size = do v <- newArray (0, size - 1) 0
                  f <- newSTRef 0
                  r <- newSTRef 0
                  return $ Queue v f r

pushQueue :: Queue s -> Int -> ST s ()
pushQueue q x = do r <- readSTRef (rear q)
                   writeArray (values q) r x
                   writeSTRef (rear q) (r + 1)

popQueue :: Queue s -> ST s Int
popQueue q = do f <- readSTRef (front q)
                writeSTRef (front q) (f + 1)
                readArray (values q) f

isEmpty :: Queue s -> ST s Bool
isEmpty q = liftM2 (==) (readSTRef (front q)) (readSTRef (rear q))

buildG :: Int -> [(Vertex, Vertex)] -> Graph
buildG numVertices edges = G.buildG (1, numVertices) $ edges ++ map swap edges

testGraph0 :: Graph
testGraph0 = buildG 5 [(1, 2), (2, 3), (3, 4), (4, 5)]

bfs :: Graph -> Vertex -> UArray Vertex Int
bfs graph source = let vertices = bounds graph
                   in runSTUArray $ do
                     distance <- newArray vertices (-1) :: ST s (STUArray s Vertex Int)
                     writeArray distance source 0
                     queue <- mkQueue (snd vertices - fst vertices + 1)
                     pushQueue queue source

                     let unseen v = liftM (< 0) (readArray distance v)
                         go = do ! u  <- popQueue queue
                                 ! d  <- readArray distance u
                                 forM_ (graph ! u) $ \v -> do
                                      ! d' <- readArray distance v
                                      when (d' < 0) $ do
                                        writeArray distance v (d + 1)
                                        pushQueue queue v
                                 ! done <- isEmpty queue
                                 unless done go
                     go
                     return distance

solve :: Graph -> Int -> (Int, Int, Int) -> (Int, Int, Int) -> Int
solve graph numEdges (s1, t1, l1) (s2, t2, l2) | dist2 s1 t1 > l1 = -1
                                               | dist2 s2 t2 > l2 = -1
                                               | otherwise = max (numEdges - minimum space) 0
     where vertices@(minv, maxv) = bounds graph
           distances = listArray vertices $ map (bfs graph) (range vertices) :: Array Vertex (UArray Vertex Int)

           dist2 u v = distances ! u ! v
           dist4 s u v t = dist2 u v + min (dist2 s u + dist2 v t) (dist2 s v + dist2 u t)

           space = (dist2 s1 t1 + dist2 s2 t2) : [d1 + d2 - dist2 u v | u <- [minv .. maxv]
                                                 , v <- [u .. maxv]
                                                 , let ! d1 = dist4 s1 u v t1
                                                 , d1 <= l1
                                                 , let ! d2 = dist4 s2 u v t2
                                                 , d2 <= l2
                                                 ]

readInts :: IO [Int]
readInts = liftM (map read . words) getLine

main :: IO ()
main = do
  [numVertices, numEdges] <- readInts
  edges <- replicateM numEdges $ do
             [u, v] <- readInts
             return (u, v)
  [s1, t1, l1] <- readInts
  [s2, t2, l2] <- readInts
  let graph = buildG numVertices edges
  print $ solve graph numEdges (s1, t1, l1) (s2, t2, l2)

{-# LANGUAGE BangPatterns #-}
module Main where

import Control.Monad
import Control.Monad.ST
import Data.Array.ST
import Data.STRef
import Data.Array.Unboxed
import Data.Graph hiding (buildG)
import Data.Tuple (swap)
import qualified Data.Graph as G

data Queue s a = Queue { values :: STArray s Int a
                       , front  :: STRef s Int
                       , rear   :: STRef s Int
                       }

mkQueue :: Int -> a -> ST s (Queue s a)
mkQueue size x = do v <- newArray (1, size) x
                    f <- newSTRef 1
                    r <- newSTRef 1
                    return $ Queue v f r

pushQueue :: Queue s a -> a -> ST s ()
pushQueue q x = do r <- readSTRef (rear q)
                   writeArray (values q) r x
                   writeSTRef (rear q) (r + 1)

popQueue :: Queue s a -> ST s a
popQueue q = do f <- readSTRef (front q)
                writeSTRef (front q) (f + 1)
                readArray (values q) f

isEmpty :: Queue s a -> ST s Bool
isEmpty q = liftM2 (==) (readSTRef (front q)) (readSTRef (rear q))

buildG :: Int -> [(Vertex, Vertex)] -> Graph
buildG numVertices edges = G.buildG (1, numVertices) $ edges ++ map swap edges

testGraph0 :: Graph
testGraph0 = buildG 5 [(1, 2), (2, 3), (3, 4), (4, 5)]

bfs :: Graph -> Vertex -> UArray Vertex Int
bfs graph source = let vertices = bounds graph
                   in runSTUArray $ do
                     distance <- newArray vertices (-1) :: ST s (STUArray s Vertex Int)
                     writeArray distance source 0
                     queue <- mkQueue (snd vertices - fst vertices + 1) 0
                     pushQueue queue source

                     let unseen v = liftM (< 0) (readArray distance v)
                         go = do ! u  <- popQueue queue
                                 ! d  <- readArray distance u
                                 forM_ (graph ! u) $ \v -> do
                                      ! d' <- readArray distance v
                                      when (d' < 0) $ do
                                        writeArray distance v (d + 1)
                                        pushQueue queue v
                                 ! done <- isEmpty queue
                                 unless done go
                     go
                     return distance

solve :: Graph -> Int -> (Int, Int, Int) -> (Int, Int, Int) -> Int
solve graph numEdges (s1, t1, l1) (s2, t2, l2) | dist2 s1 t1 > l1 = -1
                                               | dist2 s2 t2 > l2 = -1
                                               | otherwise = max (numEdges - minimum space) 0
     where vertices@(minv, maxv) = bounds graph
           distances = listArray vertices $ map (bfs graph) (range vertices) :: Array Vertex (UArray Vertex Int)

           dist2 u v = distances ! u ! v
           dist4 s u v t = dist2 u v + min (dist2 s u + dist2 v t) (dist2 s v + dist2 u t)

           space = (dist2 s1 t1 + dist2 s2 t2) : [d1 + d2 - dist2 u v | u <- [minv .. maxv]
                                                 , v <- [u .. maxv]
                                                 , let ! d1 = dist4 s1 u v t1
                                                 , d1 <= l1
                                                 , let ! d2 = dist4 s2 u v t2
                                                 , d2 <= l2
                                                 ]

readInts :: IO [Int]
readInts = liftM (map read . words) getLine

main :: IO ()
main = do
  [numVertices, numEdges] <- readInts
  edges <- replicateM numEdges $ do
             [u, v] <- readInts
             return (u, v)
  [s1, t1, l1] <- readInts
  [s2, t2, l2] <- readInts
  let graph = buildG numVertices edges
  print $ solve graph numEdges (s1, t1, l1) (s2, t2, l2)

module Main where

import Control.Monad
import Data.Array
import Data.Graph
import Data.Tree
import Data.Tuple (swap)

data CList a = CList ([a] -> [a])

emptyClist :: CList a
emptyClist = CList id

append :: a -> CList a -> CList a
append a (CList f) = CList $ (a :) . f

singleton :: a -> CList a
singleton a = append a emptyClist

cat :: CList a -> CList a -> CList a
cat (CList f) (CList g) = CList (f . g)

freeze :: CList a -> [a]
freeze (CList f) = f []

getDistTS :: Int -> Forest Vertex -> CList (Vertex, Int)
getDistTS height forest = foldl cat emptyClist $ map (getDistT height) forest

getDistT :: Int -> Tree Vertex -> CList (Vertex, Int)
getDistT height tree = root `cat` children
    where root = singleton (rootLabel tree, height)
          children = getDistTS (height + 1) (subForest tree)

getDistance :: Vertex -> Graph -> Array Vertex Int
getDistance u g = array (bounds g) . freeze . getDistTS 0 $ dfs g [u]

getDistances :: Graph -> Array Vertex (Array Vertex Int)
getDistances g = array (bounds g) $ [(v, getDistance v g) | v <- range (bounds g)]

mmin :: [Int] -> Int
mmin [] = -1
mmin xs = minimum xs

solve :: Int -> Int -> Graph -> (Int, Int, Int) -> (Int, Int, Int) -> Int
solve n m g (s1, t1, l1) (s2, t2, l2) | dist s1 t1 > l1 = -1
                                      | dist s2 t2 > l2 = -1
                                      | r2 < 0 = max (m - r1) 0
                                      | otherwise = max (m - min r1 r2) 0
    where ds     = getDistances g
          dist u v = ds ! u ! v
          try1 u v | dist s1 u + dist v t1 + duv > l1 = -1
                   | dist s2 u + dist v t2 + duv > l2 = -1
                   | otherwise = dist s1 u + dist v t1 + dist s2 u + dist v t2 + duv
              where duv = dist u v

          try2 u v | dist s1 u + dist v t1 + duv > l1 = -1
                   | dist s2 v + dist u t2 + duv > l2 = -1
                   | otherwise = dist s1 u + dist v t1 + dist s2 v + dist u t2 + duv
              where duv = dist u v

          r1 = dist s1 t1 + dist s2 t2
          r2 = mmin . filter (>= 0) $ [try1 u v | u <- range (bounds g), v <- range (bounds g)] ++
               [try2 u v | u <- range (bounds g), v <- range (bounds g)]

readInts :: IO [Int]
readInts = liftM (map read . words) getLine

main :: IO ()
main = do
  [n, m] <- readInts
  edges  <- replicateM m $ do
             [u, v] <- readInts
             return (u - 1, v - 1)
  let g = buildG (0, n - 1) (edges ++ map swap edges)
  [s1, t1, l1] <- readInts
  [s2, t2, l2] <- readInts
  print $ solve n m g (s1 - 1, t1 - 1, l1) (s2 - 1, t2 - 1, l2)

module Main where

import Control.Monad
import Data.Array
import Data.Graph
import Data.Tree
import Data.Tuple (swap)

data CList a = CList ([a] -> [a])

emptyClist :: CList a
emptyClist = CList id

append :: a -> CList a -> CList a
append a (CList f) = CList $ (a :) . f

singleton :: a -> CList a
singleton a = append a emptyClist

cat :: CList a -> CList a -> CList a
cat (CList f) (CList g) = CList (f . g)

freeze :: CList a -> [a]
freeze (CList f) = f []

getDistTS :: Int -> Forest Vertex -> CList (Vertex, Int)
getDistTS height forest = foldl cat emptyClist $ map (getDistT height) forest

getDistT :: Int -> Tree Vertex -> CList (Vertex, Int)
getDistT height tree = root `cat` children
    where root = singleton (rootLabel tree, height)
          children = getDistTS (height + 1) (subForest tree)

getDistance :: Vertex -> Graph -> Array Vertex Int
getDistance u g = array (0, n) . freeze . getDistTS 0 $ dfs g [u]
    where (0, n) = bounds g

getDistances :: Graph -> Array Vertex (Array Vertex Int)
getDistances g = array (0, n) $ [(v, getDistance v g) | v <- [0 .. n]]
    where (0, n) = bounds g

solve :: Int -> Int -> Graph -> (Int, Int, Int) -> (Int, Int, Int) -> Int
solve n m g (s1, t1, l1) (s2, t2, l2) | dist s1 t1 > l1 = -1
                                      | dist s2 t2 > l2 = -1
                                      | otherwise = max (m - min r1 r2) 0
    where (0, n) = bounds g
          ds     = getDistances g
          dist u v = ds ! u ! v
          try u v  = dist u v + min (dist s1 u + dist v t1 + dist s2 u + dist v t2) (dist s1 u + dist v t1 + dist s2 v + dist u t2)

          r1 = dist s1 t1 + dist s2 t2
          r2 = minimum [try u v | u <- [0 .. n], v <- [0 .. n]]

readInts :: IO [Int]
readInts = liftM (map read . words) getLine

main :: IO ()
main = do
  [n, m] <- readInts
  edges  <- replicateM m $ do
             [u, v] <- readInts
             return (u - 1, v - 1)
  let g = buildG (0, n - 1) (edges ++ map swap edges)
  [s1, t1, l1] <- readInts
  [s2, t2, l2] <- readInts
  print $ solve n m g (s1 - 1, t1 - 1, l1) (s2 - 1, t2 - 1, l2)


Phoenix has $$$n$$$ blocks of height $$$h_1, h_2, \dots, h_n$$$, and all $$$h_i$$$ don't exceed some value $$$x$$$. He plans to stack all $$$n$$$ blocks into $$$m$$$ separate towers. The height of a tower is simply the sum of the heights of its blocks. For the towers to look beautiful, no two towers may have a height difference of strictly more than $$$x$$$. Please help Phoenix build $$$m$$$ towers that look beautiful. Each tower must have at least one block and all blocks must be used.

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. The first line of each test case contains three integers $$$n$$$, $$$m$$$, and $$$x$$$ ($$$1 \le m \le n \le 10^5$$$; $$$1 \le x \le 10^4$$$) — the number of blocks, the number of towers to build, and the maximum acceptable height difference of any two towers, respectively.  The second line of each test case contains $$$n$$$ space-separated integers ($$$1 \le h_i \le x$$$) — the heights of the blocks.  It is guaranteed that the sum of $$$n$$$ over all the test cases will not exceed $$$10^5$$$.

For each test case, if Phoenix cannot build $$$m$$$ towers that look beautiful, print NO. Otherwise, print YES, followed by $$$n$$$ integers $$$y_1, y_2, \dots, y_n$$$, where $$$y_i$$$ ($$$1 \le y_i \le m$$$) is the index of the tower that the $$$i$$$-th block is placed in. If there are multiple solutions, print any of them.

NoteIn the first test case, the first tower has height $$$1+2+3=6$$$ and the second tower has height $$$1+2=3$$$. Their difference is $$$6-3=3$$$ which doesn't exceed $$$x=3$$$, so the towers are beautiful.In the second test case, the first tower has height $$$1$$$, the second tower has height $$$1+2=3$$$, and the third tower has height $$$3$$$. The maximum height difference of any two towers is $$$3-1=2$$$ which doesn't exceed $$$x=3$$$, so the towers are beautiful.

{-# LANGUAGE FlexibleContexts #-}
import qualified Data.ByteString.Char8 as BS
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST
import Data.Array.Unboxed
import Data.Bifunctor
import Data.Bits
import Data.Bool
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import qualified Data.IntSet as IS
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import Data.STRef.Strict
import System.IO
import System.IO.Unsafe

(><) a b = a Seq.>< b

deb name s e = seq s unsafePerformIO $! do
    hPutStrLn stderr $ " " ++ name ++ " = " ++ show s
    return e

parseInt = fst . fromJust . BS.readInt
parseInteger = fst . fromJust . BS.readInteger

modifyArray f a i = readArray a i >>= \v -> writeArray a i (f v)

invP :: [Int] -> [Int]
invP xs =
    let n = length xs
        a = array (0,n-1) (zip xs [0..]) :: UArray Int Int
    in
        elems a

main = do
    tn <- parseInt <$> BS.getLine
    replicateM_ tn $ do
        [n,m,x] <- map parseInt . BS.words <$> BS.getLine
        xs <- map parseInt . BS.words <$> BS.getLine
        let r = map ((+1) . (`mod` m)) . invP . map snd $ sort $ zip xs [0..]
        putStrLn "YES"
        putStrLn $ unwords . map show $ r


You have a playlist consisting of $$$n$$$ songs. The $$$i$$$-th song is characterized by two numbers $$$t_i$$$ and $$$b_i$$$ — its length and beauty respectively. The pleasure of listening to set of songs is equal to the total length of the songs in the set multiplied by the minimum beauty among them. For example, the pleasure of listening to a set of $$$3$$$ songs having lengths $$$[5, 7, 4]$$$ and beauty values $$$[11, 14, 6]$$$ is equal to $$$(5 + 7 + 4) \cdot 6 = 96$$$.You need to choose at most $$$k$$$ songs from your playlist, so the pleasure of listening to the set of these songs them is maximum possible.

The first line contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 3 \cdot 10^5$$$) – the number of songs in the playlist and the maximum number of songs you can choose, respectively. Each of the next $$$n$$$ lines contains two integers $$$t_i$$$ and $$$b_i$$$ ($$$1 \le t_i, b_i \le 10^6$$$) — the length and beauty of $$$i$$$-th song.

Print one integer — the maximum pleasure you can get.

NoteIn the first test case we can choose songs $$${1, 3, 4}$$$, so the total pleasure is $$$(4 + 3 + 6) \cdot 6 = 78$$$.In the second test case we can choose song $$$3$$$. The total pleasure will be equal to $$$100 \cdot 100 = 10000$$$.

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Bits
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import qualified Data.Array.IArray as A
import qualified Data.Array.MArray.Safe as A
-- import qualified Data.Array.MArray as A
import Data.Array (Array)
import Data.Array.Unboxed (UArray)
import Data.Array.IArray (IArray)
import Data.Array.MArray.Safe (MArray)
import Data.Array.IO.Safe (IOArray, IOUArray)
import Data.Array.ST.Safe (STArray, STUArray, runSTArray, runSTUArray)
{-
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
-}
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.ST.Lazy.Safe (strictToLazyST, lazyToStrictST)
import qualified Control.Monad.ST.Lazy.Safe as STL
-- import Control.Monad.ST
import Control.Applicative
import Data.Maybe
import Data.Tuple
import Data.Ord
import Control.Monad.State.Strict
import Data.Int
import Data.Word
import Data.STRef
import Data.IORef
import Data.Function
import System.IO
import System.Exit
import Data.Char

main :: IO ()
main = do
  [n,k] <- map readInt . words <$> getLine
  bts <- sortBy (compare `on` Down) . take n
    . unfoldr (runStateT $ flip (,) <$> rInt <*> rInt)
    <$> BSL.getContents
  let cands = scanl' loop (IM.empty, 0, 0, 0) bts
      loop (!prev, !prevLen, !prevNum, _) (!b,!t) = (new, newLen, newNum, b)
        where
          (!removed, !removedLen, !newNum)
            | prevNum >= k
               = (IM.updateMin
                  (\x -> if x<=1 then Nothing else Just $! x-1) prev,
                  prevLen - toI64 (fst (IM.findMin prev)),
                  k)
            | otherwise = (prev, prevLen, prevNum + 1)
          !new = IM.insertWith (+) t (1::Int) removed
          !newLen = removedLen + toI64 t
  print $ maximum $ map (\(_,!len,_,!beau) -> len * toI64 beau) cands

rInt :: StateT BSL.ByteString Maybe Int
rInt = StateT $ BSL.readInt . BSL.dropWhile (<'!')
rIntS :: StateT BS.ByteString Maybe Int
rIntS = StateT $ BS.readInt . BS.dropWhile (<'!')

#define D(f,r,d) f::Integral a=>a->d;f=fromIntegral;r::String->d;r=read
#define C(f,r,g,h,d) D(f,r,d);g,h::RealFrac a=>a->d;g=floor;h=ceiling
C(_toInteger_,readInteger,floorInteger,ceilInteger,Integer)
C(toInt,readInt,floorInt,ceilInt,Int)
C(toI8,readI8,floorI8,ceilI8,Int8)
C(toI16,readI16,floorI16,ceilI16,Int16)
C(toI32,readI32,floorI32,ceilI32,Int32)
C(toI64,readI64,floorI64,ceilI64,Int64)
C(toWord,readWord,floorWord,ceilWord,Word)
C(toW8,readW8,floorW8,ceilW8,Word8)
C(toW16,readW16,floorW16,ceilW16,Word16)
C(toW32,readW32,floorW32,ceilW32,Word32)
C(toW64,readW64,floorW64,ceilW64,Word64)
D(toDouble,readDouble,Double)
D(toFloat,readFloat,Float)
#undef D
#undef C

{-# INLINE wrA #-}
wrA = A.writeArray
{-# INLINE rdA #-}
rdA = A.readArray
{-# INLINE mdA #-}
mdA arr f i = do
  ai <- rdA arr i
  let fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE mdA' #-}
mdA' arr f i = do
  !ai <- rdA arr i
  let !fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE swapA #-}
swapA arr i j = do
  ai <- rdA arr i
  wrA arr i =<< rdA arr j
  wrA arr j ai

#define N(f,g,a,m)\
  f :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> e -> m (a i e); f=A.newArray;\
  g :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> m (a i e); g=A.newArray_
#define C(a,m)
N(newIOA,newIOA_,IOArray,IO)
N(newSTA,newSTA_,STArray s,ST s)
#undef C
#define C(a,m) MArray (a) e (m),
N(newIOUA,newIOUA_,IOUArray,IO)
N(newSTUA,newSTUA_,STUArray s,ST s)
#undef C
#undef N

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Bits
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import qualified Data.Array.IArray as A
import qualified Data.Array.MArray.Safe as A
-- import qualified Data.Array.MArray as A
import Data.Array (Array)
import Data.Array.Unboxed (UArray)
import Data.Array.IArray (IArray)
import Data.Array.MArray.Safe (MArray)
import Data.Array.IO.Safe (IOArray, IOUArray)
import Data.Array.ST.Safe (STArray, STUArray, runSTArray, runSTUArray)
{-
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
-}
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.ST.Lazy.Safe (strictToLazyST, lazyToStrictST)
import qualified Control.Monad.ST.Lazy.Safe as STL
-- import Control.Monad.ST
import Control.Applicative
import Data.Maybe
import Data.Tuple
import Data.Ord
import Control.Monad.State.Strict
import Data.Int
import Data.Word
import Data.STRef
import Data.IORef
import Data.Function
import System.IO
import System.Exit
import Data.Char

main :: IO ()
main = do
  [n,k] <- map readInt . words <$> getLine
  bts <- sortBy (compare `on` Down) . take n
    . unfoldr (runStateT $ flip (,) <$> rInt <*> rInt) <$> BSL.getContents
  let cands = scanl' loop (IM.empty, 0, 0, 0) bts
      loop (prev, prevLen, prevNum, _) (b,t) = (new, newLen, newNum, b)
        where
          (!removed, !removedLen, !newNum)
            | prevNum >= k
               = (IM.updateMin
                  (\x -> if x>1 then Nothing else Just $! x-1) prev,
                  prevLen - fst (IM.findMin prev),
                  k)
            | otherwise = (prev, prevLen, prevNum + 1)
          !new = IM.insertWith (+) t (1::Int) removed
          !newLen = removedLen + t
  print $ maximum $ map (\(_,!len,_,!beau) -> len * beau) cands

rInt :: StateT BSL.ByteString Maybe Int
rInt = StateT $ BSL.readInt . BSL.dropWhile (<'!')
rIntS :: StateT BS.ByteString Maybe Int
rIntS = StateT $ BS.readInt . BS.dropWhile (<'!')

#define D(f,r,d) f::Integral a=>a->d;f=fromIntegral;r::String->d;r=read
#define C(f,r,g,h,d) D(f,r,d);g,h::RealFrac a=>a->d;g=floor;h=ceiling
C(_toInteger_,readInteger,floorInteger,ceilInteger,Integer)
C(toInt,readInt,floorInt,ceilInt,Int)
C(toI8,readI8,floorI8,ceilI8,Int8)
C(toI16,readI16,floorI16,ceilI16,Int16)
C(toI32,readI32,floorI32,ceilI32,Int32)
C(toI64,readI64,floorI64,ceilI64,Int64)
C(toWord,readWord,floorWord,ceilWord,Word)
C(toW8,readW8,floorW8,ceilW8,Word8)
C(toW16,readW16,floorW16,ceilW16,Word16)
C(toW32,readW32,floorW32,ceilW32,Word32)
C(toW64,readW64,floorW64,ceilW64,Word64)
D(toDouble,readDouble,Double)
D(toFloat,readFloat,Float)
#undef D
#undef C

{-# INLINE wrA #-}
wrA = A.writeArray
{-# INLINE rdA #-}
rdA = A.readArray
{-# INLINE mdA #-}
mdA arr f i = do
  ai <- rdA arr i
  let fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE mdA' #-}
mdA' arr f i = do
  !ai <- rdA arr i
  let !fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE swapA #-}
swapA arr i j = do
  ai <- rdA arr i
  wrA arr i =<< rdA arr j
  wrA arr j ai

#define N(f,g,a,m)\
  f :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> e -> m (a i e); f=A.newArray;\
  g :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> m (a i e); g=A.newArray_
#define C(a,m)
N(newIOA,newIOA_,IOArray,IO)
N(newSTA,newSTA_,STArray s,ST s)
#undef C
#define C(a,m) MArray (a) e (m),
N(newIOUA,newIOUA_,IOUArray,IO)
N(newSTUA,newSTUA_,STUArray s,ST s)
#undef C
#undef N

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Bits
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import qualified Data.Array.IArray as A
import qualified Data.Array.MArray.Safe as A
-- import qualified Data.Array.MArray as A
import Data.Array (Array)
import Data.Array.Unboxed (UArray)
import Data.Array.IArray (IArray)
import Data.Array.MArray.Safe (MArray)
import Data.Array.IO.Safe (IOArray, IOUArray)
import Data.Array.ST.Safe (STArray, STUArray, runSTArray, runSTUArray)
{-
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VUM
-}
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.ST.Lazy.Safe (strictToLazyST, lazyToStrictST)
import qualified Control.Monad.ST.Lazy.Safe as STL
-- import Control.Monad.ST
import Control.Applicative
import Data.Maybe
import Data.Tuple
import Data.Ord
import Control.Monad.State.Strict
import Data.Int
import Data.Word
import Data.STRef
import Data.IORef
import Data.Function
import System.IO
import System.Exit
import Data.Char

main :: IO ()
main = do
  [n,k] <- map readInt . words <$> getLine
  bts <- sortBy (compare `on` Down) . take n
    . unfoldr (runStateT $ flip (,) <$> rInt <*> rInt)
    <$> BSL.getContents
  let cands = scanl' loop (IM.empty, 0, 0, 0) bts
      loop (prev, prevLen, prevNum, _) (b,t) = (new, newLen, newNum, b)
        where
          (!removed, !removedLen, !newNum)
            | prevNum >= k
               = (IM.updateMin
                  (\x -> if x>1 then Nothing else Just $! x-1) prev,
                  prevLen - toI64 (fst (IM.findMin prev)),
                  k)
            | otherwise = (prev, prevLen, prevNum + 1)
          !new = IM.insertWith (+) t (1::Int) removed
          !newLen = removedLen + toI64 t
  print $ maximum $ map (\(_,!len,_,!beau) -> len * toI64 beau) cands

rInt :: StateT BSL.ByteString Maybe Int
rInt = StateT $ BSL.readInt . BSL.dropWhile (<'!')
rIntS :: StateT BS.ByteString Maybe Int
rIntS = StateT $ BS.readInt . BS.dropWhile (<'!')

#define D(f,r,d) f::Integral a=>a->d;f=fromIntegral;r::String->d;r=read
#define C(f,r,g,h,d) D(f,r,d);g,h::RealFrac a=>a->d;g=floor;h=ceiling
C(_toInteger_,readInteger,floorInteger,ceilInteger,Integer)
C(toInt,readInt,floorInt,ceilInt,Int)
C(toI8,readI8,floorI8,ceilI8,Int8)
C(toI16,readI16,floorI16,ceilI16,Int16)
C(toI32,readI32,floorI32,ceilI32,Int32)
C(toI64,readI64,floorI64,ceilI64,Int64)
C(toWord,readWord,floorWord,ceilWord,Word)
C(toW8,readW8,floorW8,ceilW8,Word8)
C(toW16,readW16,floorW16,ceilW16,Word16)
C(toW32,readW32,floorW32,ceilW32,Word32)
C(toW64,readW64,floorW64,ceilW64,Word64)
D(toDouble,readDouble,Double)
D(toFloat,readFloat,Float)
#undef D
#undef C

{-# INLINE wrA #-}
wrA = A.writeArray
{-# INLINE rdA #-}
rdA = A.readArray
{-# INLINE mdA #-}
mdA arr f i = do
  ai <- rdA arr i
  let fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE mdA' #-}
mdA' arr f i = do
  !ai <- rdA arr i
  let !fai = f ai
  wrA arr i fai
  return (ai,fai)
{-# INLINE swapA #-}
swapA arr i j = do
  ai <- rdA arr i
  wrA arr i =<< rdA arr j
  wrA arr j ai

#define N(f,g,a,m)\
  f :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> e -> m (a i e); f=A.newArray;\
  g :: forall e i s. (C(a,m)A.Ix i) => (i,i) -> m (a i e); g=A.newArray_
#define C(a,m)
N(newIOA,newIOA_,IOArray,IO)
N(newSTA,newSTA_,STArray s,ST s)
#undef C
#define C(a,m) MArray (a) e (m),
N(newIOUA,newIOUA_,IOUArray,IO)
N(newSTUA,newSTUA_,STUArray s,ST s)
#undef C
#undef N


You are given an array $$$a$$$ of length $$$n$$$ consisting of zeros. You perform $$$n$$$ actions with this array: during the $$$i$$$-th action, the following sequence of operations appears:  Choose the maximum by length subarray (continuous subsegment) consisting only of zeros, among all such segments choose the leftmost one;  Let this segment be $$$[l; r]$$$. If $$$r-l+1$$$ is odd (not divisible by $$$2$$$) then assign (set) $$$a[\frac{l+r}{2}] := i$$$ (where $$$i$$$ is the number of the current action), otherwise (if $$$r-l+1$$$ is even) assign (set) $$$a[\frac{l+r-1}{2}] := i$$$. Consider the array $$$a$$$ of length $$$5$$$ (initially $$$a=[0, 0, 0, 0, 0]$$$). Then it changes as follows:  Firstly, we choose the segment $$$[1; 5]$$$ and assign $$$a[3] := 1$$$, so $$$a$$$ becomes $$$[0, 0, 1, 0, 0]$$$;  then we choose the segment $$$[1; 2]$$$ and assign $$$a[1] := 2$$$, so $$$a$$$ becomes $$$[2, 0, 1, 0, 0]$$$;  then we choose the segment $$$[4; 5]$$$ and assign $$$a[4] := 3$$$, so $$$a$$$ becomes $$$[2, 0, 1, 3, 0]$$$;  then we choose the segment $$$[2; 2]$$$ and assign $$$a[2] := 4$$$, so $$$a$$$ becomes $$$[2, 4, 1, 3, 0]$$$;  and at last we choose the segment $$$[5; 5]$$$ and assign $$$a[5] := 5$$$, so $$$a$$$ becomes $$$[2, 4, 1, 3, 5]$$$. Your task is to find the array $$$a$$$ of length $$$n$$$ after performing all $$$n$$$ actions. Note that the answer exists and unique.You have to answer $$$t$$$ independent test cases.

The first line of the input contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The only line of the test case contains one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the length of $$$a$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$ ($$$\sum n \le 2 \cdot 10^5$$$).

For each test case, print the answer — the array $$$a$$$ of length $$$n$$$ after performing $$$n$$$ actions described in the problem statement. Note that the answer exists and unique.

import Control.Monad (replicateM)

data Tree = Val Int|New Int|B1 Int Int Tree|B2 Int Int Int Tree Tree deriving Show

branch :: Int -> Int -> (Tree,Int)
branch i 1 = (Val i,0)
branch i 2 = (B1 1 i (New 1),1)
branch i n = (B2 h1 h2 i (New h1) (New h2),h2) where
  h2 = div n 2
  h1 = h2 + mod n 2 - 1

{-
maxNew :: Tree -> Int
maxNew (Val _) = 0
maxNew (New n) = n
maxNew (B1 _ t) = maxNew t
maxNew (B2 _ t1 t2 ) = max (maxNew t1) (maxNew t2)
-}

modifyBy :: Int -> Tree -> (Tree,Int)
modifyBy i (New n) = branch i n
modifyBy i t@(Val _) = (t,0)
modifyBy i (B1 tl k t) =(B1 mx k nt,mx) where
  (nt,mx) = modifyBy i t
modifyBy i (B2 t1l t2l k t1 t2)
  |t2l > t1l = let
      (nt2,nt2l) = modifyBy i t2
        in (B2 t1l nt2l k t1 nt2,max t1l nt2l)
  |otherwise = let
      (nt1,nt1l) = modifyBy i t1
       in (B2 nt1l t2l k nt1 t2,max t2l nt1l)

modBy :: Int -> Tree -> Tree
modBy i t = fst $ modifyBy i t

toList :: Tree -> [Int]
toList (Val k) = [k]
toList (New _) = []
toList (B1 _ k t) = [k]++(toList t)
toList (B2 _ _ k t1 t2) = (toList t1)++[k]++(toList t2)

finRun :: Int -> [Int]
finRun n= toList $ foldl (\t i -> modBy i t) (New n) [1..n]

getInt :: IO Int
getInt = fmap read getLine

main :: IO()
main = do
  x <- getInt
  ls <- replicateM x getInt
  mapM_ (\x -> putStrLn $ unwords $ map show $ finRun x) ls

import qualified Data.Set as S
import Control.Monad
--import Data.Monoid
import Data.List
main :: IO ()
main = do
    n <- readLn
    replicateM_ n routine

routine :: IO ()
routine = do
  n <- readLn
  putStrLn $ (unwords.map show) $ solve n

solve :: Int -> [Int]
solve n = clean $ consume (S.singleton (Event 1 n n))

data Event = Event {
  getL :: Int,
  getR :: Int,
  getLength :: Int
} deriving (Eq, Show)

instance Ord Event where
  compare (Event l _ ln) (Event l2 _ ln2) =
    (compare ln2 ln) `mappend` (compare l l2)

consume :: S.Set Event -> [Int]
consume s
  | S.null s = []
  | otherwise = n : consume s''
  where
    (Event l r ln,s') = S.deleteFindMin s
    n = (l + r) `div` 2
    evs = if ln == 1
            then [] else if ln == 2 then [Event r r 1]
            else [Event l (n-1) ((ln `div` 2) - (fromEnum $ even ln)),Event (n+1) r (ln `div` 2)]
    s'' = S.union s' (S.fromList evs)

clean :: [Int] -> [Int]
clean xs =map fst $ sortOn snd $ zip [1..] xs


Alice and Bob are playing a game. They have an array of positive integers $$$a$$$ of size $$$n$$$.Before starting the game, Alice chooses an integer $$$k \ge 0$$$. The game lasts for $$$k$$$ stages, the stages are numbered from $$$1$$$ to $$$k$$$. During the $$$i$$$-th stage, Alice must remove an element from the array that is less than or equal to $$$k - i + 1$$$. After that, if the array is not empty, Bob must add $$$k - i + 1$$$ to an arbitrary element of the array. Note that both Alice's move and Bob's move are two parts of the same stage of the game. If Alice can't delete an element during some stage, she loses. If the $$$k$$$-th stage ends and Alice hasn't lost yet, she wins.Your task is to determine the maximum value of $$$k$$$ such that Alice can win if both players play optimally. Bob plays against Alice, so he tries to make her lose the game, if it's possible.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1 \le n \le 100$$$) — the size of the array $$$a$$$. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le n$$$).

For each test case, print one integer — the maximum value of $$$k$$$ such that Alice can win if both players play optimally.

module Main where

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  testCases <- readInt' <$> B.getLine
  replicateM_ testCases testCase

testCase :: IO ()
testCase = do
  getLine
  vs <- map readInt' . B.words <$> B.getLine
  print $ solve (sort vs)

readInt' :: B.ByteString -> Int
readInt' = maybe 0 fst . B.readInt

solve :: [Int] -> Int
solve s = case [k | k <- [1..(min ((length s + 1) `div` 2) (length (takeWhile (<= 1) s)))], winnable k s] of
            [] -> 0
            ls -> maximum ls
  where winnable :: Int -> [Int] -> Bool
        winnable k vs = all (uncurry (<=)) $ drop (k-1) vs `zip` [1..k]

{-# 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

{- END OF GENERAL -}

solve :: Int -> [Int] -> Int
solve n as = answer
    where
        asSet = S.fromList $ L.zip as [1..]

        answer :: Int
        answer = MB.fromMaybe 0 . L.find canPlay $ reverse [1 .. n]

        canPlay :: Int -> Bool
        canPlay k = flip S.evalState asSet $ do
            tracingM "k" k
            answer <- MT.runMaybeT $ M.forM_ [1..k] $ \i -> do
                st <- S.get
                tracingM "st" st
                aliceX <- MT.MaybeT . S.gets $ S.lookupLE (k - i + 1, n)
                tracingM "aliceX" aliceX
                S.modify $ S.delete aliceX
                S.modify $ S.deleteMin
            tracingM "answer" answer
            return $ MB.isJust answer

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> readIntB8s
        let answer = solve n as
        printf "%d\n" answer

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import Control.Monad
import Control.Monad.State (State, evalState, get, gets, put)
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Function
import Data.Int
import Data.List
import Data.Maybe
import Debug.Trace

----- <Solution> --------------------------------------------------------------
data TC = TC {n :: Int, as :: [Int]}

type Output = Int

input :: Scanner TC
input = do
  n <- int
  as <- n >< int
  return TC {..}

solve :: TC -> Output
solve TC {..} = binarySearch check 0 (n + 1) -- [0 .. n] >$> filter check >>> maximum
  where
    check 0 = True
    check k = [1 .. k] >$> reverse >>> map (\i -> alice i >=> pure . bob i) >>> foldl1 (>=>) >>> ($ as) >>> isJust

    alice :: Int -> [Int] -> Maybe [Int]
    alice v xs = do
      xs <- pure $ filter (<= v) xs
      guard $ not (null xs)
      return $ delete (maximum xs) xs

    bob :: Int -> [Int] -> [Int]
    bob _ [] = []
    bob v xs =
      let m = minimum xs
       in m + v : delete m xs

-- find largest x \in [l, r) s.t. p x
binarySearch :: Integral a => (a -> Bool) -> a -> a -> a
binarySearch p l r
  | l + 1 == r = l
  | p m = binarySearch p m r
  | otherwise = binarySearch p l m
  where
    m = (l + r) `div` 2

output :: Int -> Output -> C.ByteString
output ix = showB

----- </Solution> -------------------------------------------------------------

main :: IO ()
-- main = C.interact $ runScanner input >>> solve >>> output 0
main = C.interact $ runScanner (numberOf input) >>> map solve >>> zip [1 ..] >>> map (uncurry output) >>> C.unlines

----- Template ----------------------------------------------------------------

-- Debug
debug :: Show a => a -> a

#ifdef ONLINE_JUDGE
debug = id
#else
debug a = trace (show a) a
#endif

-- helpers
(>$>) = flip ($)

infixl 0 >$>

applyN :: Int -> (a -> a) -> a -> a
applyN 0 f = id
applyN n f = applyN (n - 1) f . f

-- Lists
groupOn :: Eq b => (a -> b) -> [a] -> [[a]]
groupOn = groupBy . on (==)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf k xs = let (hs, ts) = splitAt k xs in hs : chunksOf k ts

adjacents :: [a] -> [(a, a)]
adjacents xs = zip xs (tail xs)

adjacentsWith :: (a -> a -> b) -> [a] -> [b]
adjacentsWith f xs = zipWith f xs (tail xs)

count :: Eq a => a -> [a] -> Int
count = countBy . (==)

countBy :: (a -> Bool) -> [a] -> Int
countBy p = length . filter p

-- Scanner
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

readStr :: Read a => Scanner a
readStr = read <$> str

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

showB :: Show a => a -> C.ByteString
showB = C.pack . show

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import Control.Monad
import Control.Monad.State (State, evalState, get, gets, put)
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Function
import Data.Int
import Data.List
import Data.Maybe
import Debug.Trace

----- <Solution> --------------------------------------------------------------
data TC = TC {n :: Int, as :: [Int]}

type Output = Int

input :: Scanner TC
input = do
  n <- int
  as <- n >< int
  return TC {..}

solve :: TC -> Output
solve TC {..} = [0 .. n] >$> filter check >>> maximum
  where
    check 0 = True
    check k = [1 .. k] >$> reverse >>> map (\i -> alice i >=> pure . bob i) >>> foldl1 (>=>) >>> ($ as) >>> isJust

    alice :: Int -> [Int] -> Maybe [Int]
    alice v xs = do
      xs <- pure $ filter (<= v) xs
      guard $ not (null xs)
      return $ delete (maximum xs) xs

    bob :: Int -> [Int] -> [Int]
    bob _ [] = []
    bob v xs =
      let m = minimum xs
       in m + v : delete m xs

-- find largest x \in [l, r) s.t. p x
binarySearch :: Integral a => (a -> Bool) -> a -> a -> a
binarySearch p l r
  | l + 1 == r = l
  | p m = binarySearch p m r
  | otherwise = binarySearch p l m
  where
    m = (l + r) `div` 2

output :: Int -> Output -> C.ByteString
output ix = showB

----- </Solution> -------------------------------------------------------------

main :: IO ()
-- main = C.interact $ runScanner input >>> solve >>> output 0
main = C.interact $ runScanner (numberOf input) >>> map solve >>> zip [1 ..] >>> map (uncurry output) >>> C.unlines

----- Template ----------------------------------------------------------------

-- Debug
debug :: Show a => a -> a

#ifdef ONLINE_JUDGE
debug = id
#else
debug a = trace (show a) a
#endif

-- helpers
(>$>) = flip ($)

infixl 0 >$>

applyN :: Int -> (a -> a) -> a -> a
applyN 0 f = id
applyN n f = applyN (n - 1) f . f

-- Lists
groupOn :: Eq b => (a -> b) -> [a] -> [[a]]
groupOn = groupBy . on (==)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf k xs = let (hs, ts) = splitAt k xs in hs : chunksOf k ts

adjacents :: [a] -> [(a, a)]
adjacents xs = zip xs (tail xs)

adjacentsWith :: (a -> a -> b) -> [a] -> [b]
adjacentsWith f xs = zipWith f xs (tail xs)

count :: Eq a => a -> [a] -> Int
count = countBy . (==)

countBy :: (a -> Bool) -> [a] -> Int
countBy p = length . filter p

-- Scanner
type Scanner = State [C.ByteString]

runScanner :: Scanner a -> C.ByteString -> a
runScanner = runScannerWith C.words

runScannerWith :: (C.ByteString -> [C.ByteString]) -> Scanner a -> C.ByteString -> a
runScannerWith t s = evalState s . t

peek :: Scanner C.ByteString
peek = gets head

bstr :: Scanner C.ByteString
bstr = get >>= \case s : ss -> put ss >> return s

str :: Scanner String
str = C.unpack <$> bstr

readStr :: Read a => Scanner a
readStr = read <$> str

int :: Scanner Int
int = fst . fromJust . C.readInt <$> bstr

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

decimal :: Int -> Scanner Int
decimal p = round . ((10 ^ p) *) <$> double

numberOf :: Scanner a -> Scanner [a]
numberOf s = int >>= flip replicateM s

many :: Scanner a -> Scanner [a]
many s = get >>= \case [] -> return []; _ -> (:) <$> s <*> many s

till :: (C.ByteString -> Bool) -> Scanner a -> Scanner [a]
till p s = do
  t <- peek
  if p t
    then return []
    else (:) <$> s <*> till p s

times :: Int -> Scanner a -> Scanner [a]
times = replicateM

(><) = times

two, three, four :: Scanner a -> Scanner [a]
[two, three, four] = map times [2 .. 4]

pair :: Scanner a -> Scanner b -> Scanner (a, b)
pair = liftA2 (,)

showB :: Show a => a -> C.ByteString
showB = C.pack . show

import Data.Char
import Control.Monad
import Data.List

solve k as = if (foldr (&&) True (zipWith (>=) (replicate k 1 ++ [2..k]) as)) then k else solve (k-1) as

loop = do
  _ <- getLine
  as <- sort <$> map read <$> words <$> getLine
  let k = (length as +1)`div`2
  print (solve k as)

main = do
  t <- read <$> getLine
  replicateM_ t loop

module Main where

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  testCases <- readInt' <$> B.getLine
  replicateM_ testCases testCase

testCase :: IO ()
testCase = do
  getLine
  vs <- map readInt' . B.words <$> B.getLine
  print $ solve vs

readInt' :: B.ByteString -> Int
readInt' = maybe 0 fst . B.readInt

solve :: [Int] -> Int
solve s = case [k | k <- [1..length s + 1 `div` 2], winnable k (sort s)] of
            [] -> 0
            ls -> maximum ls
  where winnable :: Int -> [Int] -> Bool
        winnable k vs = all (uncurry (<=)) $ drop (k-1) vs `zip` [1..k]

module Main where

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  testCases <- readInt' <$> B.getLine
  replicateM_ testCases testCase

testCase :: IO ()
testCase = do
  getLine
  vs <- map readInt' . B.words <$> B.getLine
  print $ solve vs

readInt' :: B.ByteString -> Int
readInt' = maybe 0 fst . B.readInt

solve :: [Int] -> Int
solve s = case map snd $ takeWhile winnable $ sort s `zip` concatMap (replicate 2) [1..] of
            [] -> 0
            ls -> maximum ls
  where winnable :: (Int, Int) -> Bool
        winnable (v, p) = v <= p

module Main where

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  testCases <- readInt' <$> B.getLine
  replicateM_ testCases testCase

testCase :: IO ()
testCase = do
  getLine
  vs <- map readInt' . B.words <$> B.getLine
  print $ solve vs

readInt' :: B.ByteString -> Int
readInt' = maybe 0 fst . B.readInt

solve :: [Int] -> Int
solve s = case map snd $ filter winnable $ sort s `zip` drop 1 (concatMap (replicate 2) [1..]) of
            [] -> 0
            ls -> maximum ls
  where winnable :: (Int, Int) -> Bool
        winnable (v, p) = v <= p

module Main where

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
  testCases <- readInt' <$> B.getLine
  replicateM_ testCases testCase

testCase :: IO ()
testCase = do
  getLine
  vs <- map readInt' . B.words <$> B.getLine
  print $ solve vs

readInt' :: B.ByteString -> Int
readInt' = maybe 0 fst . B.readInt

solve :: [Int] -> Int
solve s = case map snd $ filter winnable $ sort s `zip` concatMap (replicate 2) [1..] of
            [] -> 0
            ls -> maximum ls
  where winnable :: (Int, Int) -> Bool
        winnable (v, p) = v <= p

{-# 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

{- END OF GENERAL -}

solve :: Int -> [Int] -> Int
solve n as = answer
    where
        asSet = S.fromList $ L.zip as [1..]

        answer :: Int
        answer = MB.fromMaybe 0 . L.find canPlay $ reverse [1 .. n]

        canPlay :: Int -> Bool
        canPlay k = flip S.evalState asSet $ do
            tracingM "k" k
            answer <- MT.runMaybeT $ M.forM_ (reverse [1 .. k]) $ \i -> do
                st <- S.get
                tracingM "st" st
                aliceX <- MT.MaybeT . S.gets $ S.lookupLE (k - i + 1, n)
                tracingM "aliceX" aliceX
                S.modify $ S.delete aliceX
                S.modify $ S.deleteMin
            tracingM "answer" answer
            return $ MB.isJust answer

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        as <- B8.getLine <&> readIntB8s
        let answer = solve n as
        printf "%d\n" answer