This is an interactive problem.Ayush devised a new scheme to set the password of his lock. The lock has $$$k$$$ slots where each slot can hold integers from $$$1$$$ to $$$n$$$. The password $$$P$$$ is a sequence of $$$k$$$ integers each in the range $$$[1, n]$$$, $$$i$$$-th element of which goes into the $$$i$$$-th slot of the lock.To set the password of his lock, Ayush comes up with an array $$$A$$$ of $$$n$$$ integers each in the range $$$[1, n]$$$ (not necessarily distinct). He then picks $$$k$$$ non-empty mutually disjoint subsets of indices $$$S_1, S_2, ..., S_k$$$ $$$(S_i \underset{i \neq j} \cap S_j = \emptyset)$$$ and sets his password as $$$P_i = \max\limits_{j \notin S_i} A[j]$$$. In other words, the $$$i$$$-th integer in the password is equal to the maximum over all elements of $$$A$$$ whose indices do not belong to $$$S_i$$$.You are given the subsets of indices chosen by Ayush. You need to guess the password. To make a query, you can choose a non-empty subset of indices of the array and ask the maximum of all elements of the array with index in this subset. You can ask no more than 12 queries.

The first line of the input contains a single integer $$$t$$$ $$$(1 \leq t \leq 10)$$$ — the number of test cases. The description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$k$$$ $$$(2 \leq n \leq 1000, 1 \leq k \leq n)$$$ — the size of the array and the number of subsets. $$$k$$$ lines follow. The $$$i$$$-th line contains an integer $$$c$$$ $$$(1 \leq c \lt n)$$$ — the size of subset $$$S_i$$$, followed by $$$c$$$ distinct integers in the range $$$[1, n]$$$  — indices from the subset $$$S_i$$$. It is guaranteed that the intersection of any two subsets is empty.

NoteThe array $$$A$$$ in the example is $$$[1, 2, 3, 4]$$$. The length of the password is $$$2$$$. The first element of the password is the maximum of $$$A[2]$$$, $$$A[4]$$$ (since the first subset contains indices $$$1$$$ and $$$3$$$, we take maximum over remaining indices). The second element of the password is the maximum of $$$A[1]$$$, $$$A[3]$$$ (since the second subset contains indices $$$2$$$, $$$4$$$).Do not forget to read the string "Correct" / "Incorrect" after guessing the password.

import Control.Monad
import System.IO
import Data.Array

doQuery :: [Int] -> IO Int
doQuery xs = do
  putStrLn $ unwords $ "?": map show xs
  hFlush stdout
  readLn

doAnswer :: [Int] -> IO ()
doAnswer xs = do
  putStrLn $ unwords$ "!": map show xs
  hFlush stdout
  s <- getLine
  when (s == "Incorrect") (hClose stdout)

main :: IO ()
main = do
  n <- readLn
  replicateM_ n routine
  hClose stdout

routine :: IO ()
routine = do
  (n,k,sarr) <- start
  biggest <- doQuery $ n:[1..n]
  biggestSetIndex <- biggestSet k sarr biggest
  otherBiggest <- doQuery $ let s = filter (\x -> not $ x `elem` (snd (sarr!biggestSetIndex))) [1..n] in (length s) : s
  doAnswer $ replicate (biggestSetIndex-1) biggest ++ [otherBiggest] ++ replicate (k-biggestSetIndex) biggest
  pure ()

biggestSet :: Int -> Array Int (Int,[Int]) -> Int -> IO Int
biggestSet k sarr biggest = binSearch sarr biggest (1,k)

binSearch :: Array Int (Int,[Int]) -> Int -> (Int,Int) -> IO Int
binSearch sarr biggest (lo,hi) = if lo == hi then pure lo else do
  let mid = (lo+hi) `div` 2
  q <- querySets sarr [lo..mid]
  binSearch sarr biggest $ if q == biggest
    then (lo,mid)
    else (mid+1,hi)

querySets :: Array Int (Int,[Int]) -> [Int] -> IO Int
querySets arr idxs = doQuery (sum sizes : concat vals)
  where
    (sizes,vals) = unzip $ map (arr!) idxs

start :: IO (Int,Int,Array Int (Int,[Int]))
start = do
  [n,k] <- (map read.words) <$> getLine
  sets <- replicateM k $ (map read.words) <$> getLine
  let sarr = listArray (1,k) (map (\s -> (head s, tail s)) sets)
  return (n,k,sarr)

import Control.Monad
import System.IO
import Data.Array

doQuery :: [Int] -> IO Int
doQuery xs = do
  putStrLn $ unwords $ "?": map show xs
  hFlush stdout
  readLn

doAnswer :: [Int] -> IO ()
doAnswer xs = do
  putStrLn $ unwords$ "!": map show xs
  hFlush stdout
  s <- getLine
  when (s == "Incorrect") (hClose stdout)

main :: IO ()
main = do
  n <- readLn
  replicateM_ n routine
  hClose stdout

routine :: IO ()
routine = do
  (n,k,sarr) <- start
  biggest <- doQuery $ n:[1..n]
  biggestSetIndex <- biggestSet k sarr biggest
  otherBiggest <- querySets sarr $ [1..(biggestSetIndex-1)]++[(biggestSetIndex+1)..k]
  doAnswer $ replicate (biggestSetIndex-1) biggest ++ [otherBiggest] ++ replicate (k-biggestSetIndex) biggest
  pure ()

biggestSet :: Int -> Array Int (Int,[Int]) -> Int -> IO Int
biggestSet k sarr biggest = binSearch sarr biggest (1,k)

binSearch :: Array Int (Int,[Int]) -> Int -> (Int,Int) -> IO Int
binSearch sarr biggest (lo,hi) = if lo == hi then pure lo else do
  let mid = (lo+hi) `div` 2
  q <- querySets sarr [lo..mid]
  binSearch sarr biggest $ if q == biggest
    then (lo,mid)
    else (mid+1,hi)

querySets :: Array Int (Int,[Int]) -> [Int] -> IO Int
querySets arr idxs = doQuery (sum sizes : concat vals)
  where
    (sizes,vals) = unzip $ map (arr!) idxs

start :: IO (Int,Int,Array Int (Int,[Int]))
start = do
  [n,k] <- (map read.words) <$> getLine
  sets <- replicateM k $ (map read.words) <$> getLine
  let sarr = listArray (1,k) (map (\s -> (head s, tail s)) sets)
  return (n,k,sarr)

import Control.Monad
import System.IO
import Data.Array

doQuery :: [Int] -> IO Int
doQuery xs = do
  putStrLn $ unwords $ "?": map show xs
  hFlush stdout
  readLn

doAnswer :: [Int] -> IO ()
doAnswer xs = do
  putStrLn $ unwords$ "!": map show xs
  hFlush stdout
  s <- getLine
  when (s == "Incorrect") (hClose stdout)

main :: IO ()
main = do
  n <- readLn
  replicateM_ n routine
  hClose stdout

routine :: IO ()
routine = do
  (n,k,sarr) <- start
  biggest <- doQuery $ n:[1..n]
  biggestSetIndex <- biggestSet k sarr biggest
  otherBiggest <- doQuery $ let s = filter (`elem` (snd (sarr!biggestSetIndex))) [1..n] in (length s) : s
  doAnswer $ replicate (biggestSetIndex-1) biggest ++ [otherBiggest] ++ replicate (k-biggestSetIndex) biggest
  pure ()

biggestSet :: Int -> Array Int (Int,[Int]) -> Int -> IO Int
biggestSet k sarr biggest = binSearch sarr biggest (1,k)

binSearch :: Array Int (Int,[Int]) -> Int -> (Int,Int) -> IO Int
binSearch sarr biggest (lo,hi) = if lo == hi then pure lo else do
  let mid = (lo+hi) `div` 2
  q <- querySets sarr [lo..mid]
  binSearch sarr biggest $ if q == biggest
    then (lo,mid)
    else (mid+1,hi)

querySets :: Array Int (Int,[Int]) -> [Int] -> IO Int
querySets arr idxs = doQuery (sum sizes : concat vals)
  where
    (sizes,vals) = unzip $ map (arr!) idxs

start :: IO (Int,Int,Array Int (Int,[Int]))
start = do
  [n,k] <- (map read.words) <$> getLine
  sets <- replicateM k $ (map read.words) <$> getLine
  let sarr = listArray (1,k) (map (\s -> (head s, tail s)) sets)
  return (n,k,sarr)

import Control.Monad
import System.IO
import Data.Array

doQuery :: [Int] -> IO Int
doQuery xs = do
  putStrLn $ unwords $ "?": map show xs
  hFlush stdout
  readLn

doAnswer :: [Int] -> IO ()
doAnswer xs = do
  putStrLn $ unwords$ "!": map show xs
  hFlush stdout
  s <- getLine
  when (s == "Incorrect") (hClose stdout)

main :: IO ()
main = do
  n <- readLn
  replicateM_ n routine
  hClose stdout

routine :: IO ()
routine = do
  (n,k,sarr) <- start
  biggest <- doQuery $ n:[1..n]
  biggestSetIndex <- biggestSet k sarr biggest
  otherBiggest <- querySets sarr $ [1..(biggestSetIndex-1)]++[biggestSetIndex+1..k]
  doAnswer $ replicate (biggestSetIndex-1) biggest ++ [otherBiggest] ++ replicate (k-biggestSetIndex) biggest
  pure ()

biggestSet :: Int -> Array Int (Int,[Int]) -> Int -> IO Int
biggestSet k sarr biggest = binSearch sarr biggest (1,k)

binSearch :: Array Int (Int,[Int]) -> Int -> (Int,Int) -> IO Int
binSearch sarr biggest (lo,hi) = if lo == hi then pure lo else do
  let mid = (lo+hi) `div` 2
  q <- querySets sarr [lo..mid]
  binSearch sarr biggest $ if q == biggest
    then (lo,mid)
    else (mid+1,hi)

querySets :: Array Int (Int,[Int]) -> [Int] -> IO Int
querySets arr idxs = doQuery (sum sizes : concat vals)
  where
    (sizes,vals) = unzip $ map (arr!) idxs

start :: IO (Int,Int,Array Int (Int,[Int]))
start = do
  [n,k] <- (map read.words) <$> getLine
  sets <- replicateM k $ (map read.words) <$> getLine
  let sarr = listArray (1,k) (map (\s -> (head s, tail s)) sets)
  return (n,k,sarr)

import Control.Monad
import System.IO
import Data.Array

doQuery :: [Int] -> IO Int
doQuery xs = do
  putStrLn $ unwords $ "?": map show xs
  hFlush stdout
  readLn

doAnswer :: [Int] -> IO ()
doAnswer xs = do
  putStrLn $ unwords$ "!": map show xs
  hFlush stdout
  s <- getLine
  when (s == "Incorrect") (hClose stdout)

main :: IO ()
main = do
  n <- readLn
  replicateM_ n routine
  hClose stdout

routine :: IO ()
routine = do
  (n,k,sarr) <- start
  biggest <- doQuery $ n:[1..n]
  biggestSetIndex <- biggestSet k sarr biggest
  otherBiggest <- doQuery $ [1..(biggestSetIndex-1)]++[(biggestSetIndex+1)..n]
  doAnswer $ replicate (biggestSetIndex-1) biggest ++ [otherBiggest] ++ replicate (k-biggestSetIndex) biggest
  pure ()

biggestSet :: Int -> Array Int (Int,[Int]) -> Int -> IO Int
biggestSet k sarr biggest = binSearch sarr biggest (1,k)

binSearch :: Array Int (Int,[Int]) -> Int -> (Int,Int) -> IO Int
binSearch sarr biggest (lo,hi) = if lo == hi then pure lo else do
  let mid = (lo+hi) `div` 2
  q <- querySets sarr [lo..mid]
  binSearch sarr biggest $ if q == biggest
    then (lo,mid)
    else (mid+1,hi)

querySets :: Array Int (Int,[Int]) -> [Int] -> IO Int
querySets arr idxs = doQuery (sum sizes : concat vals)
  where
    (sizes,vals) = unzip $ map (arr!) idxs

start :: IO (Int,Int,Array Int (Int,[Int]))
start = do
  [n,k] <- (map read.words) <$> getLine
  sets <- replicateM k $ (map read.words) <$> getLine
  let sarr = listArray (1,k) (map (\s -> (head s, tail s)) sets)
  return (n,k,sarr)


Berland, 2016. The exchange rate of currency you all know against the burle has increased so much that to simplify the calculations, its fractional part was neglected and the exchange rate is now assumed to be an integer.Reliable sources have informed the financier Anton of some information about the exchange rate of currency you all know against the burle for tomorrow. Now Anton knows that tomorrow the exchange rate will be an even number, which can be obtained from the present rate by swapping exactly two distinct digits in it. Of all the possible values that meet these conditions, the exchange rate for tomorrow will be the maximum possible. It is guaranteed that today the exchange rate is an odd positive integer n. Help Anton to determine the exchange rate of currency you all know for tomorrow!

The first line contains an odd positive integer n — the exchange rate of currency you all know for today. The length of number n's representation is within range from 2 to 105, inclusive. The representation of n doesn't contain any leading zeroes.

If the information about tomorrow's exchange rate is inconsistent, that is, there is no integer that meets the condition, print  - 1. Otherwise, print the exchange rate of currency you all know against the burle for tomorrow. This should be the maximum possible number of those that are even and that are obtained from today's exchange rate by swapping exactly two digits. Exchange rate representation should not contain leading zeroes.

import Control.Applicative ((<$>), (<|>))
import Data.Array ((//), elems, listArray)
import Data.Char (digitToInt)
import Data.List (findIndex, findIndices)
import Data.Maybe (listToMaybe)

main :: IO ()
main = solve <$> (map digitToInt <$> getLine) >>= putStrLn

solve :: [Int] -> String
solve xs = maybe "-1" f $ findIndex (\c -> even c && c < last xs) xs <|> listToMaybe (reverse $ findIndices even xs)
  where f i = concatMap show $ elems $ listArray (1, length xs) xs // [ (i + 1, last xs), (length xs, xs !! i) ]

import Data.Functor ((<$>))
import Control.Applicative ((<|>))
import Data.Maybe (listToMaybe)
import Data.List (findIndex, findIndices)
import Data.Array ((//), elems, listArray)

main :: IO ()
main = solve <$> getLine >>= putStrLn

solve :: String -> String
solve xs = maybe "-1" f $ findIndex (\c -> c `elem` "02468" && c < last xs) xs <|> listToMaybe (reverse $ findIndices (`elem`"02468") xs)
  where f i = elems $ listArray (0, length xs - 1) xs // [ (i, last xs), (length xs - 1, xs !! i) ]

import Control.Applicative ((<$>), (<|>))
import Data.Array ((//), elems, listArray)
import Data.Maybe (listToMaybe)
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = maybe (B.pack "-1") f $ B.findIndex (\c -> c `elem` "02468" && c < B.last xs) xs <|> listToMaybe (reverse $ B.findIndices (`elem`"02468") xs)
  where f i = B.pack $ elems $ listArray (1, B.length xs) (B.unpack xs) // [ (i + 1, B.last xs), (B.length xs, xs `B.index` i) ]

import Data.List
main = putStrLn . solve =<< getLine
solve n | Just i <- findIndex ((&&) <$> (< o) <*> ev) n
          = let (l,e:r) = splitAt i (init n)
            in l ++ [o] ++ r ++ [e]
        | not (null es)
          = let (l,e:r) = splitAt (last es) (init n)
            in l ++ [o] ++ r ++ [e]
        | otherwise = "-1"
  where
    o = last n
    ev = (`elem` "24680")
    es = findIndices ev n

--findEven :: [Int] -> [(Integer, Int)]
findEven xs = [(i, x) | (i, x) <- zip [0..] xs, even x]

--process :: Int -> [(Int, Int)] -> Maybe (Int, Int)
process k xs
  | null xs = Nothing
  | null ys = Just (last xs)
  | otherwise = Just (head ys)
  where ys = [(i, x) | (i, x) <- xs, x < k]

solve xs =
    case res of
      Nothing -> "-1"
      Just (i, x) -> concatMap show $ take i xs ++ [k] ++ (init $ tail d) ++ [x]
        where d = drop i xs
      where res = process k $ findEven xs
            k = last xs

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  putStrLn $ solve n

findEven xs = [(i, x) | (i, x) <- zip [0..] xs, even x]

process k xs
  | null xs = Nothing
  | null ys = Just (last xs)
  | otherwise = Just (head ys)
  where ys = [(i, x) | (i, x) <- xs, x < k]

firstlast (x:xs) a b = b : go xs
  where go [y] = [a]
        go (y:ys) = y : go ys

old xs a b = [b] ++ init (tail xs) ++ [a]

solve xs =
    case res of
      Nothing -> "-1"
      Just (i, x) -> concatMap show $ take i xs ++ firstlast d x k
        where d = drop i xs
      where res = process k $ findEven xs
            k = last xs

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  putStrLn $ solve n

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

combi f x = (take (length f - length x) f ) ++ x

process::[Int]->[Int]->Int->[Char]->[Char]
process [] _ _ f= "-1"
process [x] s _ f= combi f $ concatMap show $ [last s] ++tail (init s) ++ [head s]
process (x:xs) s la f |x>la = process xs   (dropWhile (/=(head xs) ) (tail s)) la f
	              |otherwise =combi f $ concatMap show $[last s] ++tail (init s) ++ [head s]

main= do
	 r<-getLine
	 let s= map (\z-> ord z - ord '0') r:: [Int]
	 let s1 = filter even s
	 let ans= process s1  (dropWhile (/=(head s1)) s) (last s) r
	 putStrLn ans

import Data.Functor ((<$>))
import Control.Applicative ((<|>))
import Data.Maybe (listToMaybe)
import Data.List (findIndex, findIndices)
import Data.Array ((//), elems, listArray)

main :: IO ()
main = solve <$> getLine >>= putStrLn

solve :: String -> String
solve xs = maybe "-1" f $ findIndex (\c -> c `elem` "0248" && c < last xs) xs <|> listToMaybe (reverse $ findIndices (`elem`"0248") xs)
  where f i = elems $ listArray (0, length xs - 1) xs // [ (i, last xs), (length xs - 1, xs !! i) ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.pack <$> getLine) >>= putStrLn . B.unpack

solve :: B.ByteString -> B.ByteString
solve xs = last $ B.pack "-1" : [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- reverse ix, i == last ix || B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ]
  where ix = B.findIndices (`elem`"0248") (B.init xs)

import Data.Functor ((<$>))
import Data.List (findIndices)

main :: IO ()
main = putStrLn . concatMap show =<< solve <$> getLine

solve :: String -> String
solve xs = maximum $ "-1" : [ swap i (length xs - 1) xs | i <- findIndices (`elem`"0248") xs ]

swap :: Int -> Int -> [a] -> [a]
swap i j xs = [ if k == i then xs !! j else if k == j then xs !! i else x | (k, x) <- zip [0..] xs ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> B.getLine >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = maximum $ B.pack "-1" : [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") xs, i + 1 /= B.length xs, let (ys, zs) = B.splitAt i xs ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = head $ [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") (B.init xs), Just i == B.findIndex (`elem`"0248") (B.init xs) || B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ] ++ [ B.pack "-1" ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> B.getLine >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = head $ [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") (B.init xs), B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ] ++ [ B.pack "-1" ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = head $ [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") (B.init xs), B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ] ++ [ B.pack "-1" ]

import Data.Functor ((<$>))
import Control.Applicative ((<|>))
import Data.Maybe (listToMaybe)
import Data.List (findIndex, findIndices)

main :: IO ()
main = solve <$> getLine >>= putStrLn

solve :: String -> String
solve xs = maybe "-1" f $ findIndex (\c -> c `elem` "0248" && c < last xs) xs <|> listToMaybe (reverse $ findIndices (`elem`"0248") xs)
  where f i = ys ++ last xs : tail (init zs) ++ [ xs !! i ] where (ys, zs) = splitAt i xs

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = head $ [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- reverse ix, i == last ix || B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ] ++ [ B.pack "-1" ]
  where ix = B.findIndices (`elem`"0248") (B.init xs)

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B
import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe, listToMaybe)

main :: IO ()
main = solve <$> (B.pack <$> getLine) >>= putStrLn . B.unpack

solve :: B.ByteString -> B.ByteString
solve xs = fromMaybe (B.pack "-1") (f <$> B.findIndex (\c -> c `elem` "0248" && c < B.last xs) xs <|> f <$> listToMaybe (reverse $ B.findIndices (`elem`"0248") xs))
  where f i = B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i where (ys, zs) = B.splitAt i xs

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> B.getLine >>= putStrLn . B.unpack

solve :: B.ByteString -> B.ByteString
solve xs = maximum $ B.pack "-1" : [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") xs, i + 1 /= B.length xs, let (ys, zs) = B.splitAt i xs ]

import Control.Applicative ((<$>), (<|>))
import Data.Array ((//), elems, listArray)
import Data.Maybe (listToMaybe)
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> B.getLine >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = maybe (B.pack "-1") f $ B.findIndex (\c -> c `elem` "02468" && c < B.last xs) xs <|> listToMaybe (reverse $ B.findIndices (`elem`"02468") xs)
  where f i = B.pack $ elems $ listArray (1, B.length xs) (B.unpack xs) // [ (i + 1, B.last xs), (B.length xs, xs `B.index` i) ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = last $ B.pack "-1" : [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- reverse ix, i == last ix || B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ]
  where ix = B.findIndices (`elem`"0248") (B.init xs)

import Data.Char (digitToInt)
import Data.Functor ((<$>))
import Data.List (findIndices)

main :: IO ()
main = putStrLn . concatMap show =<< solve . map digitToInt <$> getLine

solve :: [Int] -> [Int]
solve xs | all odd xs = [ -1 ]
         | otherwise = minimum [ swap i (length xs - 1) xs | i <- findIndices even xs ]

swap :: Int -> Int -> [a] -> [a]
swap i j xs = [ if k == i then xs !! j else if k == j then xs !! i else x | (k, x) <- zip [0..] xs ]

import Data.Functor ((<$>))
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = solve <$> (B.init <$> B.getLine) >>= B.putStrLn

solve :: B.ByteString -> B.ByteString
solve xs = last $ B.pack "-1" : [ B.append ys $ B.cons (B.last xs) $ B.snoc (B.tail $ B.init zs) $ B.index xs i | i <- B.findIndices (`elem`"0248") (B.init xs), Just i == B.findIndex (`elem`"0248") (B.init xs) || B.index xs i < B.last xs, let (ys, zs) = B.splitAt i xs ]

import Data.Functor ((<$>))
import Data.List (findIndices)

main :: IO ()
main = putStrLn =<< solve <$> getLine

solve :: String -> String
solve xs = maximum $ "-1" : [ swap i (length xs - 1) xs | i <- findIndices (`elem`"0248") xs ]

swap :: Int -> Int -> [a] -> [a]
swap i j xs = [ if k == i then xs !! j else if k == j then xs !! i else x | (k, x) <- zip [0..] xs ]

import Data.List
main = print . solve =<< getLine
solve n | Just i <- findIndex ((&&) <$> (< o) <*> ev) n
          = let (l,e:r) = splitAt i (init n)
            in l ++ [o] ++ r ++ [e]
        | not (null es)
          = let (l,e:r) = splitAt (last es) (init n)
            in l ++ [o] ++ r ++ [e]
        | otherwise = "-1"
  where
    o = last n
    ev = (`elem` "24680")
    es = findIndices ev n

import Data.List
main = interact solve
solve n | Just i <- findIndex ((&&) <$> (< o) <*> ev) n
          = let (l,e:r) = splitAt i (init n)
            in l ++ [o] ++ r ++ [e]
        | not (null es)
          = let (l,e:r) = splitAt (last es) (init n)
            in l ++ [o] ++ r ++ [e]
        | otherwise = "-1"
  where
    o = last n
    ev = (`elem` "24680")
    es = findIndices ev n

--findEven :: [Int] -> [(Integer, Int)]
findEven xs = [(i, x) | (i, x) <- zip [0..] xs, even x]

process :: Int -> [(Int, Int)] -> Maybe (Int, Int)
process k xs
  | null xs = Nothing
  | null ys = Just (last xs)
  | otherwise = Just (head xs)
  where ys = [(i, x) | (i, x) <- xs, x < k]

solve xs =
    case res of
      Nothing -> "-1"
      Just (i, x) -> concatMap show $ take i xs ++ [k] ++ (init $ tail d) ++ [x]
        where d = drop i xs
      where res = process k $ findEven xs
            k = last xs

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  putStrLn $ solve n

solve [n] = [3]
solve ns'@(n:ns)
  | even n = l : (d ++ [n])
  | otherwise = n : solve ns
  where l = last ns
        d = init ns

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  let ans = solve n
  putStrLn $ case last ans of
            3 -> "-1"
            x -> concatMap show ans

--findEven :: [Int] -> [(Integer, Int)]
findEven xs = [(i, x) | (i, x) <- zip [0..] xs, even x]

--process :: Int -> [(Int, Int)] -> Maybe (Int, Int)
process k xs
  | null xs = Nothing
  | null ys = Just (last xs)
  | otherwise = Just (head xs)
  where ys = [(i, x) | (i, x) <- xs, x < k]

solve xs =
    case res of
      Nothing -> "-1"
      Just (i, x) -> concatMap show $ take i xs ++ [k] ++ (init $ tail d) ++ [x]
        where d = drop i xs
      where res = process k $ findEven xs
            k = last xs

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  putStrLn $ solve n

--findEven :: [Int] -> [(Integer, Int)]
findEven xs = [(i, x) | (i, x) <- zip [0..] xs, even x]

--process :: Int -> [(Int, Int)] -> Maybe (Int, Int)
process k xs
  | null xs = Nothing
  | null ys = Just (last xs)
  | otherwise = Just (head ys)
  where ys = [(i, x) | (i, x) <- xs, x < k]

solve xs =
    case res of
      Nothing -> "-1"
      Just (i, x) -> concatMap show $ take i xs ++ [k] ++ (init $ tail d) ++ [x]
        where d = drop i xs
      where res = process k $ findEven xs
            k = last xs

main = do
  n <- fmap (map (read . (:""))) getLine :: IO [Int]
  print n
  putStrLn $ solve n

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

combi f x = (take (length f - length x) f ) ++ x

process::[Int]->[Int]->Int->[Char]->[Char]
process [] _ _ f= "-1"
process [x] s _ f= combi f $ concatMap show $ [last s] ++tail (init s) ++ [head s]
process (x:xs) s la f |x>la = process xs  (tail(dropWhile (/=x) s)) la f
	              |otherwise =combi f $ concatMap show $[last s] ++tail (init s) ++ [head s]

main= do
	 r<-getLine
	 let s= map (\z-> ord z - ord '0') r:: [Int]
	 let s1 = filter even s
	 let ans= process s1  (dropWhile (/=(head s1)) s) (last s) r
	 putStrLn ans


You are given two strings $$$s$$$ and $$$t$$$, both of length $$$n$$$. Each character in both string is 'a', 'b' or 'c'.In one move, you can perform one of the following actions:   choose an occurrence of "ab" in $$$s$$$ and replace it with "ba";  choose an occurrence of "bc" in $$$s$$$ and replace it with "cb". You are allowed to perform an arbitrary amount of moves (possibly, zero). Can you change string $$$s$$$ to make it equal to string $$$t$$$?

The first line contains a single integer $$$q$$$ ($$$1 \le q \le 10^4$$$) — the number of testcases. The first line of each testcase contains a single integer $$$n$$$ ($$$1 \le n \le 10^5$$$) — the length of strings $$$s$$$ and $$$t$$$. The second line contains string $$$s$$$ of length $$$n$$$. Each character is 'a', 'b' or 'c'. The third line contains string $$$t$$$ of length $$$n$$$. Each character is 'a', 'b' or 'c'. The sum of $$$n$$$ over all testcases doesn't exceed $$$10^5$$$.

For each testcase, print "YES" if you can change string $$$s$$$ to make it equal to string $$$t$$$ by performing an arbitrary amount of moves (possibly, zero). Otherwise, print "NO".

5

3

cab

cab

1

a

b

6

abbabc

bbaacb

10

bcaabababc

cbbababaac

2

ba

ab

-- ID : 1697C (awoo's Favorite Problem)
-- URL: https://codeforces.com/problemset/problem/1697/C

{-# LANGUAGE CPP #-}
#define ENABLE_TRACE 0

import Control.Monad
#if ENABLE_TRACE
import Debug.Trace (trace)
#endif

-- IO util
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString as BS
readInt = read `fmap` getLine :: IO Int

#if !ENABLE_TRACE
trace a b = b
#endif

main = do
    q <- readInt
    replicateM_ q solve

solve = do
    n <- readInt
    src <- getLine
    dst <- getLine
    let b1 = length . filter (== 'b') $ src
    let b2 = length . filter (== 'b') $ dst
    if (b1 == b2) && (f 0 0 n src dst)
        then putStrLn "YES"
        else putStrLn "NO"

fmt c i j n xs ys = c ++ ": " ++ show [i,j,n] ++ ", " ++ xs ++ ", " ++ ys

f i j n src dst
    | i >= n           = trace (fmt "case1" i j n src dst) $ True
    | x == 'b'         = trace (fmt "case2" (i+1) j n xs dst) $ f (i+1) j n xs dst
    | (x /= y') || (x == 'a' && i > j') || (x == 'c' && i < j') = False
    | otherwise        = trace (fmt "case4" (i+1) j'' n xs ys'') $ f (i+1) j'' n xs ys''
    where
        (x:xs) = src
        (y:ys) = dst
        bs = leadingB dst
        j' = j + bs
        (y':ys') = drop bs dst
        j'' = min n (j'+1)
        ys'' = if j'' == n then [] else ys'

leadingB ys = f 0 ys where
    f n ('b':yys) = f (n+1) yys
    f n _ = n

{-# 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.Array (listArray, (!))
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

main :: IO ()
main = C.interact $ runScanner (numberOf input) >>> map (solve >>> output) >>> C.unlines

data TC = TC {n :: Int, s :: String, t :: String}

type Output = Bool

input :: Scanner TC
input = do
  n <- int
  s <- str
  t <- str
  return TC {..}

solve :: TC -> Output
solve TC {..} = rec (blocks s) t

type Block = (Char, Int)

type Blocks = [Block]

blocks :: String -> Blocks
blocks = map (\g -> (head g, length g)) . group

rec :: Blocks -> String -> Bool
rec [] "" = True
rec ((_, 0) : xs) ys = rec xs ys
rec ((x, n) : (x', n') : xs) ys | x == x' = rec ((x, n + n') : xs) ys
rec ((x, n) : xs) (y : ys) | x == y = rec ((x, n - 1) : xs) ys
rec (('a', n) : ('b', n') : xs) ('b' : ys)
  | n' == 0 = False
  | n' == 1 = rec (('a', n) : xs) ys
  | otherwise = rec (('a', n) : ('b', n' - 1) : xs) ys
rec (('b', n) : ('c', n') : xs) ('c' : ys)
  | n' == 0 = False
  | n' == 1 = rec (('b', n) : xs) ys
  | otherwise = rec (('b', n) : ('c', n' - 1) : xs) ys
rec _ _ = False

output :: Output -> C.ByteString
output = bool "NO" "YES" >>> C.pack

-------------------------- Template ------------------------------------------
-- Debug
debug :: Show a => a -> a
#ifdef ONLINE_JUDGE
debug = id
#else
debug a = trace (show a) a
#endif

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

-- ID : 1697C (awoo's Favorite Problem)
-- URL: https://codeforces.com/problemset/problem/1697/C

{-# LANGUAGE CPP #-}
#define ENABLE_TRACE 0

import Control.Monad
#if ENABLE_TRACE
import Debug.Trace (trace)
#endif

-- IO util
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString as BS
readInt = read `fmap` getLine :: IO Int

#if !ENABLE_TRACE
trace a b = b
#endif

main = do
    q <- readInt
    replicateM_ q solve

solve = do
    n <- readInt
    src <- getLine
    dst <- getLine
    let b1 = length . filter (== 'b') $ src
    let b2 = length . filter (== 'b') $ dst
    if (b1 == b2) && (f 0 0 n src dst)
        then putStrLn "YES"
        else putStrLn "NO"

fmt c i j n xs ys = c ++ ": " ++ show [i,j,n] ++ ", " ++ xs ++ ", " ++ ys

f i j n src dst
    | i >= n           = trace (fmt "case1" i j n src dst) $ True
    | x == 'b'         = trace (fmt "case2" (i+1) j n xs dst) $ f (i+1) j n xs dst
    | (x /= y') || (x == 'a' && i > j') || (y == 'c' && i < j') = False
    | otherwise        = trace (fmt "case4" (i+1) j'' n xs ys'') $ f (i+1) j'' n xs ys''
    where
        (x:xs) = src
        (y:ys) = dst
        bs = leadingB dst
        j' = j + bs
        (y':ys') = drop bs dst
        j'' = min n (j'+1)
        ys'' = if j'' == n then [] else ys'

leadingB ys = f 0 ys where
    f n ('b':yys) = f (n+1) yys
    f n _ = n


The R1 company wants to hold a web search championship. There were n computers given for the competition, each of them is connected to the Internet. The organizers believe that the data transfer speed directly affects the result. The higher the speed of the Internet is, the faster the participant will find the necessary information. Therefore, before the competition started, each computer had its maximum possible data transfer speed measured. On the i-th computer it was ai kilobits per second.There will be k participants competing in the championship, each should get a separate computer. The organizing company does not want any of the participants to have an advantage over the others, so they want to provide the same data transfer speed to each participant's computer. Also, the organizers want to create the most comfortable conditions for the participants, so the data transfer speed on the participants' computers should be as large as possible.The network settings of the R1 company has a special option that lets you to cut the initial maximum data transfer speed of any computer to any lower speed. How should the R1 company configure the network using the described option so that at least k of n computers had the same data transfer speed and the data transfer speed on these computers was as large as possible?

The first line contains two space-separated integers n and k (1 ≤ k ≤ n ≤ 100) — the number of computers and the number of participants, respectively. In the second line you have a space-separated sequence consisting of n integers: a1, a2, ..., an (16 ≤ ai ≤ 32768); number ai denotes the maximum data transfer speed on the i-th computer.

Print a single integer — the maximum Internet speed value. It is guaranteed that the answer to the problem is always an integer.

NoteIn the first test case the organizers can cut the first computer's speed to 30 kilobits. Then two computers (the first and the third one) will have the same speed of 30 kilobits. They should be used as the participants' computers. This answer is optimal.

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, OverloadedStrings #-}
{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.DeepSeq (deepseq)
import Control.Monad hiding ((<$!>))
import Control.Monad.ST.Safe
-- import Control.Monad.State hiding ((<$!>))
-- import Data.Array
import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
-- import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import Data.STRef
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- import Data.Tree
import Data.Tuple
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
-- import Data.HashMap.Strict (HashMap)
-- import qualified Data.HashMap.Strict as HashMap
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
-- import Debug.Trace
import System.IO
import System.Random

-- getInts = fmap (map read . words) getLine
getInts = unfoldr (B.readInt . B.dropWhile isSpace) <$> B.getLine

main = do
  [n, k] <- map read . words <$> getLine
  xs <- map read . words <$> getLine :: IO [Int]

  print $ (reverse $ sort xs) !! (k-1)

import Control.Applicative
import Data.List

main = (liftA2 ((.sort.map read.words).flip (!!).liftA2 (-) head (!!1).map read.words) getLine getLine :: IO(Int)) >>= print

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

readInt :: IO Integer
readInt = read <$> getLine

readIntList :: IO [Integer]
readIntList = fmap read . words <$> getLine

main :: IO ()
main = do
  [n, k] <- readIntList
  li <- sort <$> readIntList
  putStrLn $ show $ li !! (fromIntegral (n-k))

import Data.List
strToList = (map (read :: String -> Int)).words

main = do
    s <- getLine
    let [n, k] = strToList s
    t <- getLine
    putStrLn $ show $ (sort $ strToList t) !! (n - k)


You are given a tree consisting of $$$n$$$ nodes. You want to write some labels on the tree's edges such that the following conditions hold:  Every label is an integer between $$$0$$$ and $$$n-2$$$ inclusive.  All the written labels are distinct.  The largest value among $$$MEX(u,v)$$$ over all pairs of nodes $$$(u,v)$$$ is as small as possible. Here, $$$MEX(u,v)$$$ denotes the smallest non-negative integer that isn't written on any edge on the unique simple path from node $$$u$$$ to node $$$v$$$.

The first line contains the integer $$$n$$$ ($$$2 \le n \le 10^5$$$) — the number of nodes in the tree. Each of the next $$$n-1$$$ lines contains two space-separated integers $$$u$$$ and $$$v$$$ ($$$1 \le u,v \le n$$$) that mean there's an edge between nodes $$$u$$$ and $$$v$$$. It's guaranteed that the given graph is a tree.

Output $$$n-1$$$ integers. The $$$i^{th}$$$ of them will be the number written on the $$$i^{th}$$$ edge (in the input order).

import Data.List
import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as C
import qualified Data.IntMap.Strict as IntMap

parseInt :: C.ByteString -> Int
parseInt = fst . fromJust . C.readInt

work :: [[Int]] -> [Int]
work es = answer
  where
  add Nothing = Just 1 :: Maybe Int
  add (Just o) = Just $ o + 1
  mp = foldl' (\m [x, y] -> IntMap.alter add x $ IntMap.alter add y m) IntMap.empty es
  mp' = IntMap.filter (> 2) mp
  (root : _) = IntMap.keys mp'
  calc [] _ _ = []
  calc (_ : edges) i [] = i : (calc edges (i - 1) [])
  calc ([x, y] : edges) i (r : rs) =
    if r == x || r == y
      then length rs : (calc edges i rs)
      else i : (calc edges (i - 1) (r : rs))
  calc' = calc es (length es - 1)
  answer = if null mp'
             then calc' []
             else calc' [root, root, root]

main :: IO ()
main = do
  n <- fmap parseInt C.getLine
  es <- replicateM (n - 1) $ map parseInt . C.words <$> C.getLine
  putStr $ unlines $ map show $ work es


The graph is called tree if it is connected and has no cycles. Suppose the tree is rooted at some vertex. Then tree is called to be perfect $$$k$$$-ary tree if each vertex is either a leaf (has no children) or has exactly $$$k$$$ children. Also, in perfect $$$k$$$-ary tree all leafs must have same depth.For example, the picture below illustrates perfect binary tree with $$$15$$$ vertices:There is a perfect $$$k$$$-ary tree with $$$n$$$ nodes. The nodes are labeled with distinct integers from $$$1$$$ to $$$n$$$, however you don't know how nodes are labelled. Still, you want to find the label of the root of the tree.You are allowed to make at most $$$60 \cdot n$$$ queries of the following type:  "? $$$a$$$ $$$b$$$ $$$c$$$", the query returns "Yes" if node with label $$$b$$$ lies on the path from $$$a$$$ to $$$c$$$ and "No" otherwise. Both $$$a$$$ and $$$c$$$ are considered to be lying on the path from $$$a$$$ to $$$c$$$.When you are ready to report the root of the tree, print   "! $$$s$$$", where $$$s$$$ is the label of the root of the tree. It is possible to report the root only once and this query is not counted towards limit of $$$60 \cdot n$$$ queries.

NoteThe tree in the example is as follows:The input and output for example illustrate possible interaction on that test (empty lines are inserted only for clarity).The hack corresponding to the example would look like:3 22 3 1

import System.IO
import System.Random

toint s = (read s) :: Int

dep k n t = if n == t then 0 else 1 + dep k (n-t) (t*k)

qwe s a b [] = ([],"",s)
qwe s a b (x:xs) =
  if x == a || x == b then
    qwe s a b xs
  else
    let query = "? " ++ show(a) ++ " " ++ show(x) ++ " " ++ show(b) ++ "\n" in
    let ans = head s in
    let (l,out,ss) = qwe (tail s) a b xs in
    (if ans == "Yes" then x:l else l, query ++ (if ans == "Yes" then out else out), ss)

asd s (a:b:rand) n d =
  if a == b then
    asd s rand n d
  else
    let (l,out,ss) = qwe s a b [1..n] in
    let ok = length l == 2*d - 1 in
    let (aa,bb,ll,oo,ssss) = asd ss rand n d in
    (if ok then a else aa, if ok then b else bb, if ok then l else ll, out++(if ok then "" else oo), if ok then ss else ssss)

doit3 s a t [] = (s,"",0)
doit3 s a t (x:xs) =
  if x == t then
    doit3 s a t xs
  else
    let query = "? " ++ show(a) ++ " " ++ show(t) ++ " " ++ show(x) ++ "\n" in
    let ans = head s in
    let (ss,o,q) = doit3 (tail s) a t xs in
    (ss,query ++ (if ans=="Yes" then o else o), q + (if ans == "Yes" then 1 else 0))

doit2 s d a b (t:ts) l =
  let (ss,o,q) = doit3 s a t l in
  o ++ (if q == d-1 then "! " ++ show(t) ++ "\n" else doit2 ss d a b ts l)

doit s rand n d =
  let (a,b,l,o0,ss) = asd s rand n d in
  o0 ++ (doit2 ss d a b l l)

solve rgen ss =
  let (nn:kk:s) = words ss in
  let n = toint nn in
  let k = toint kk in
  let rand = randomRs (1,n) rgen in
  let d = dep k n 1 in
  doit s rand n d

main = do
  hSetBuffering stdout LineBuffering
  g <- getStdGen
  interact (solve g)


Ori and Sein have overcome many difficult challenges. They finally lit the Shrouded Lantern and found Gumon Seal, the key to the Forlorn Ruins. When they tried to open the door to the ruins... nothing happened.Ori was very surprised, but Sein gave the explanation quickly: clever Gumon decided to make an additional defence for the door.There are $$$n$$$ lamps with Spirit Tree's light. Sein knows the time of turning on and off for the $$$i$$$-th lamp — $$$l_i$$$ and $$$r_i$$$ respectively. To open the door you have to choose $$$k$$$ lamps in such a way that there will be a moment of time when they all will be turned on.While Sein decides which of the $$$k$$$ lamps to pick, Ori is interested: how many ways there are to pick such $$$k$$$ lamps that the door will open? It may happen that Sein may be wrong and there are no such $$$k$$$ lamps. The answer might be large, so print it modulo $$$998\,244\,353$$$.

First line contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 3 \cdot 10^5$$$, $$$1 \le k \le n$$$) — total number of lamps and the number of lamps that must be turned on simultaneously. Next $$$n$$$ lines contain two integers $$$l_i$$$ ans $$$r_i$$$ ($$$1 \le l_i \le r_i \le 10^9$$$) — period of time when $$$i$$$-th lamp is turned on.

Print one integer — the answer to the task modulo $$$998\,244\,353$$$.

-- This probably still TLEs, which is unfortunate.
-- At this point, around 80% of my locally-profiled
-- runtime is in the sort call on line 53. Disgusting.

{-# LANGUAGE BangPatterns #-}

import Control.Monad
import qualified Data.ByteString.Lazy as R
import qualified Data.ByteString.Lazy.Char8 as P

import Control.Monad.ST
import Data.Array.ST.Safe
import Data.Array.Unboxed

import Data.Int
import Data.List

p :: Int64
p = 998244353

cv :: Int64 -> Int64
cv x = mod x p

newSTUArray :: (Int64, Int64) -> Int64 -> ST s (STUArray s Int64 Int64)
newSTUArray = newArray

invs :: Int64 -> UArray Int64 Int64
invs n = runSTUArray $ do
  ans <- newSTUArray (1, n) 0
  writeArray ans 1 1
  forM_ [2..n] $ \i -> do
    let  (x, y) = divMod p i
    v <- readArray ans y
    writeArray ans i $ cv (-x * v)
  pure ans

choose :: Int64 -> Int64 -> UArray Int64 Int64
choose n k = let
  w = invs n
  lastAns = foldl' (\x y -> cv $ cv (x * (n - y + 1)) * (w ! y)) 1 [1..k]
  ansLi = scanl' (\x y -> cv $ cv (x * (y - k)) * (w ! y)) lastAns [n, n-1 .. 1]
  in  listArray (0, n) $ reverse ansLi

data DoesMoreStrictnessHelp
  = DoesMoreStrictnessHelp !Int !Int64
  deriving (Eq, Ord)

solve :: Int64 -> Int64 -> [(Int, Int)] -> Int64
solve n k lr = let
  unsortedEvents = do
    (le, ri) <- lr
    [DoesMoreStrictnessHelp le (0-1), DoesMoreStrictnessHelp ri 1]
  events = sort unsortedEvents
  sArr = choose (n-1) (k-1)
  step (!currCt, !currTot) (DoesMoreStrictnessHelp _ v) =
    (currCt - v, currTot + if  v == -1  then  sArr ! currCt  else  0)
  in  case  foldl' step (0, 0) events  of
  (0, ans) -> cv ans
  _ -> error "huh?"

{-
main :: IO ()
main = do
  [n, k] <- map read . words <$> getLine
  lr <- replicateM (fromIntegral n) $ do
    [le, ri] <- map read . words <$> getLine
    pure (le, ri)
  print $ solve n k lr
-}

type ByteString = P.ByteString

parseLine :: ByteString -> (Int, Int)
parseLine str = let
  [Just (le, _), Just (ri, _)] = map P.readInt $ P.words str
  in (le, ri)

parse :: ByteString -> (Int64, Int64, [(Int, Int)])
parse str = let
  (n, k) : lrs = map parseLine $ P.lines str
  in  (fromIntegral n, fromIntegral k, lrs)

main :: IO ()
main = do
  (n, k, lrs) <- parse <$> R.getContents
  print $ solve n k lrs

-- Using tuple-free comparison, and less 64-bit storage...
-- Will it be faster?

{-# LANGUAGE BangPatterns #-}

import Control.Monad
import qualified Data.ByteString.Lazy as R
import qualified Data.ByteString.Lazy.Char8 as P

import Control.Monad.ST
import Data.Array.ST.Safe
import Data.Array.Unboxed

import Data.Int
import Data.List

p :: Num t => t
p = 998244353

prodModP :: [Int] -> Int
prodModP = let
  step :: Int64 -> Int -> Int64
  step x y = mod (x * fromIntegral y) p
  in  \li -> case  li  of
  [] -> 1
  (x : xs) -> fromIntegral $ foldl' step (fromIntegral x) xs

newSTUArray :: (Int, Int) -> Int -> ST s (STUArray s Int Int)
newSTUArray = newArray

invs :: Int -> UArray Int Int
invs n = runSTUArray $ do
  ans <- newSTUArray (1, n) 0
  writeArray ans 1 1
  forM_ [2..n] $ \i -> do
    let  (x, y) = divMod p i
    v <- readArray ans y
    writeArray ans i $ prodModP [-x, v]
  pure ans

choose :: Int -> Int -> UArray Int Int
choose n k = let
  w = invs n
  lastAns = foldl' (\x y -> prodModP [x, n-y+1, w!y]) 1 [1..k]
  ansLi = scanl' (\x y -> prodModP [x, y - k, w ! y]) lastAns [n, n-1 .. 1]
  in  listArray (0, n) $ reverse ansLi

solve :: Int -> Int -> [(Int, Int)] -> Int
solve n k lr = let
  unsortedEvents = do
    (le, ri) <- lr
    [le * 2, ri * 2 + 1]
  events = sort unsortedEvents
  sArr = choose (n-1) (k-1)
  step (!currCt, !currTot) ov = let
    v = mod ov 2
    incTot = currTot + if  v == 0  then  sArr ! currCt  else  0
    nextTot = incTot + if  incTot >= p  then  -p  else  0
    in  (currCt + 1 - 2*v, nextTot)
  in  case  foldl' step (0, 0) events  of
  (0, ans) -> mod ans p
  _ -> error "huh?"

{-
main :: IO ()
main = do
  [n, k] <- map read . words <$> getLine
  lr <- replicateM (fromIntegral n) $ do
    [le, ri] <- map read . words <$> getLine
    pure (le, ri)
  print $ solve n k lr
-}

type ByteString = P.ByteString

parseLine :: ByteString -> (Int, Int)
parseLine str = let
  [Just (le, _), Just (ri, _)] = map P.readInt $ P.words str
  in (le, ri)

parse :: ByteString -> (Int, Int, [(Int, Int)])
parse str = let
  (n, k) : lrs = map parseLine $ P.lines str
  in  (n, k, lrs)

main :: IO ()
main = do
  (n, k, lrs) <- parse <$> R.getContents
  print $ solve n k lrs


Omkar is playing his favorite pixelated video game, Bed Wars! In Bed Wars, there are $$$n$$$ players arranged in a circle, so that for all $$$j$$$ such that $$$2 \leq j \leq n$$$, player $$$j - 1$$$ is to the left of the player $$$j$$$, and player $$$j$$$ is to the right of player $$$j - 1$$$. Additionally, player $$$n$$$ is to the left of player $$$1$$$, and player $$$1$$$ is to the right of player $$$n$$$.Currently, each player is attacking either the player to their left or the player to their right. This means that each player is currently being attacked by either $$$0$$$, $$$1$$$, or $$$2$$$ other players. A key element of Bed Wars strategy is that if a player is being attacked by exactly $$$1$$$ other player, then they should logically attack that player in response. If instead a player is being attacked by $$$0$$$ or $$$2$$$ other players, then Bed Wars strategy says that the player can logically attack either of the adjacent players.Unfortunately, it might be that some players in this game are not following Bed Wars strategy correctly. Omkar is aware of whom each player is currently attacking, and he can talk to any amount of the $$$n$$$ players in the game to make them instead attack another player  — i. e. if they are currently attacking the player to their left, Omkar can convince them to instead attack the player to their right; if they are currently attacking the player to their right, Omkar can convince them to instead attack the player to their left. Omkar would like all players to be acting logically. Calculate the minimum amount of players that Omkar needs to talk to so that after all players he talked to (if any) have changed which player they are attacking, all players are acting logically according to Bed Wars strategy.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10^4$$$). The descriptions of the test cases follows. The first line of each test case contains one integer $$$n$$$ ($$$3 \leq n \leq 2 \cdot 10^5$$$)  — the amount of players (and therefore beds) in this game of Bed Wars. The second line of each test case contains a string $$$s$$$ of length $$$n$$$. The $$$j$$$-th character of $$$s$$$ is equal to L if the $$$j$$$-th player is attacking the player to their left, and R if the $$$j$$$-th player is attacking the player to their right. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, output one integer: the minimum number of players Omkar needs to talk to to make it so that all players are acting logically according to Bed Wars strategy. It can be proven that it is always possible for Omkar to achieve this under the given constraints.

5
4
RLRL
6
LRRRRL
8
RLLRRRLL
12
LLLLRRLRRRLL
5
RRRRR

NoteIn the first test case, players $$$1$$$ and $$$2$$$ are attacking each other, and players $$$3$$$ and $$$4$$$ are attacking each other. Each player is being attacked by exactly $$$1$$$ other player, and each player is attacking the player that is attacking them, so all players are already being logical according to Bed Wars strategy and Omkar does not need to talk to any of them, making the answer $$$0$$$.In the second test case, not every player acts logically: for example, player $$$3$$$ is attacked only by player $$$2$$$, but doesn't attack him in response. Omkar can talk to player $$$3$$$ to convert the attack arrangement to LRLRRL, in which you can see that all players are being logical according to Bed Wars strategy, making the answer $$$1$$$.

import Control.Monad (replicateM_)
import Data.List (group)

solve :: [Char] -> Int
solve li
  | length li < 3  = 0
  | minimum li == maximum li  = 1 + quot (length li - 1) 3
  | otherwise = let
    k = head li
    (p, q) = span (== k) li
    issues = group (q ++ p)
    in  sum [quot (length interval) 3 | interval <- issues]

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    _nStr <- getLine
    inp <- getLine
    print (solve inp)


Valera has n counters numbered from 1 to n. Some of them are connected by wires, and each of the counters has a special button.Initially, all the counters contain number 0. When you press a button on a certain counter, the value it has increases by one. Also, the values recorded in all the counters, directly connected to it by a wire, increase by one.Valera and Ignat started having a dispute, the dispute is as follows. Ignat thought of a sequence of n integers a1, a2, ..., an. Valera should choose some set of distinct counters and press buttons on each of them exactly once (on other counters the buttons won't be pressed). If after that there is a counter with the number i, which has value ai, then Valera loses the dispute, otherwise he wins the dispute.Help Valera to determine on which counters he needs to press a button to win the dispute.

The first line contains two space-separated integers n and m (1 ≤ n, m ≤ 105), that denote the number of counters Valera has and the number of pairs of counters connected by wires. Each of the following m lines contains two space-separated integers ui and vi (1 ≤ ui, vi ≤ n, ui ≠ vi), that mean that counters with numbers ui and vi are connected by a wire. It is guaranteed that each pair of connected counters occurs exactly once in the input. The last line contains n space-separated integers a1, a2, ..., an (0 ≤ ai ≤ 105), where ai is the value that Ignat choose for the i-th counter.

If Valera can't win the dispute print in the first line -1. Otherwise, print in the first line integer k (0 ≤ k ≤ n). In the second line print k distinct space-separated integers — the numbers of the counters, where Valera should push buttons to win the dispute, in arbitrary order. If there exists multiple answers, you are allowed to print any of them.

{-# OPTIONS_GHC -O2 -optc-Ofast -fignore-asserts #-}
import Control.Monad (replicateM)
import Data.Array (accumArray, (!))
import Data.Maybe (fromJust)
-- import Data.Sequence (fromList, index, update)
import Data.Map (fromList, lookup, insert)
import Prelude hiding (lookup)
import qualified Data.ByteString.Char8 as C

gao n a el = go [i | (i, j) <- zip [1 ..] a, j == 0] [] v
  where
    v = fromList $ zip [1 ..] a
    e = accumArray (flip (:)) [] (1, n) $ concat $
      [(i, i) | i <- [1 .. n]]: [[(i, j), (j, i)] | [i, j] <- el]
    go []    done _ = done
    go (h:t) done b =
      if fromJust (lookup h b) == 0
        then go t' (h:done) b'
        else go t done b
      where
        (t', b') = foldl f (t, b) $ e!h
        f (l, m) k = (if v == 0 then k:l else l, if v < -1 then m else insert k v m)
          where
            v = pred $ fromJust $ lookup k m

main = do
  [n, m] <- getArray
  e <- replicateM m getArray
  a <- getArray
  let ans = gao n a e
  print $ length $ ans
  putStrLn $ unwords $ map show $ ans
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

{-# OPTIONS_GHC -O2 -optc-O3 -fignore-asserts #-}
import Control.Monad (replicateM)
import Data.Array (accumArray, (!))
import Data.Maybe (fromJust)
import Data.Sequence (fromList, index, update)
import qualified Data.ByteString.Char8 as C

gao n a el = go [i | (i, j) <- zip [1 ..] a, j == 0] [] v
  where
    v = fromList $ 0:a
    e = accumArray (flip (:)) [] (1, n) $ concat $
      [(i, i) | i <- [1 .. n]]: [[(i, j), (j, i)] | [i, j] <- el]
    go []    done _ = done
    go (h:t) done b =
      if index b h == 0
        then go t' (h:done) b'
        else go t done b
      where
        (t', b') = foldl f (t, b) $ e!h
        f (l, m) k =
          case compare v 0 of
            LT  -> (l, update k v m)
            EQ  -> (k:l, update k v m)
            GT  -> (l, m)
          where
            v = index m k - 1

main = do
  [n, m] <- getArray
  e <- replicateM m getArray
  a <- getArray
  let ans = gao n a e
  print $ length $ ans
  putStrLn $ unwords $ map show $ ans
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

import Control.Monad
import Data.Array
import Data.Maybe
import qualified Data.IntMap as M
import qualified Data.ByteString.Char8 as C

gao n al el = go [i | (i, j) <- assocs a, j == 0] [] v
  where
    a = listArray (1, n) al
    v = M.fromList $ zip [1 .. n] $ repeat 0
    e = accumArray (flip (:)) [] (1, n) $ concat $
      [(i, i) | i <- [1 .. n]]: [[(i, j), (j, i)] | [i, j] <- el]
    go []    done _ = done
    go (h:t) done b =
      if fromJust (M.lookup h b) == a!h
        then go (t ++ t') (h:done) b'
        else go t done b
      where
        (t', b') = foldl f ([], b) $ e!h
        f (l, m) k = (if v == a!k then v:l else l, M.insert k v m)
          where
            v = succ $ fromJust $ M.lookup k m

main = do
  [n, m] <- getArray
  e <- replicateM m getArray
  a <- getArray
  let ans = gao n a e
  print $ length $ ans
  putStrLn $ unwords $ map show $ ans
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine


You are a coach of a group consisting of $$$n$$$ students. The $$$i$$$-th student has programming skill $$$a_i$$$. All students have distinct programming skills. You want to divide them into teams in such a way that:  No two students $$$i$$$ and $$$j$$$ such that $$$|a_i - a_j| = 1$$$ belong to the same team (i.e. skills of each pair of students in the same team have the difference strictly greater than $$$1$$$);  the number of teams is the minimum possible. You have to answer $$$q$$$ independent queries.

The first line of the input contains one integer $$$q$$$ ($$$1 \le q \le 100$$$) — the number of queries. Then $$$q$$$ queries follow. The first line of the query contains one integer $$$n$$$ ($$$1 \le n \le 100$$$) — the number of students in the query. The second line of the query contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 100$$$, all $$$a_i$$$ are distinct), where $$$a_i$$$ is the programming skill of the $$$i$$$-th student.

For each query, print the answer on it — the minimum number of teams you can form if no two students $$$i$$$ and $$$j$$$ such that $$$|a_i - a_j| = 1$$$ may belong to the same team (i.e. skills of each pair of students in the same team has the difference strictly greater than $$$1$$$)

NoteIn the first query of the example, there are $$$n=4$$$ students with the skills $$$a=[2, 10, 1, 20]$$$. There is only one restriction here: the $$$1$$$-st and the $$$3$$$-th students can't be in the same team (because of $$$|a_1 - a_3|=|2-1|=1$$$). It is possible to divide them into $$$2$$$ teams: for example, students $$$1$$$, $$$2$$$ and $$$4$$$ are in the first team and the student $$$3$$$ in the second team.In the second query of the example, there are $$$n=2$$$ students with the skills $$$a=[3, 6]$$$. It is possible to compose just a single team containing both students.

import Data.List
import Control.Monad

inputNum = do
  line <- getLine
  return ((read line) :: Int)

inputArr = do
  line <- getLine
  let ar = map read (words line) :: [Int]
  return ar

solveRec [] = True
solveRec [x] = True
solveRec (a:b:xs) = b-a /= 1 && solveRec (b:xs)

solveCase = do
  n <- inputNum
  a <- inputArr
  let erg = if solveRec (sort a) then 1 else 2
  putStrLn (show erg)

main = do
  line <- getLine
  let n = (read line :: Int)
  replicateM_ n solveCase
  {-
  line2 <- getLine
  let x = n+1
  let s = show x
  let z = words line2
  let ar = map read z :: [Int]
  let s2 = map (show . (+ 1)) ar
  putStrLn s
  putStrLn (concat s2)
  -}

import Control.Arrow
import Data.List

sec :: Bool -> [String]-> [String]
sec _ [] = []
sec True (x:xs) = x : sec False xs
sec False (x:xs) = sec True xs

main = interact $
  lines >>> tail >>> sec False >>> map (words >>> map read >>> solve >>> show) >>> unlines

solve :: [Integer] -> Integer
solve xs = let sxs = sort xs in
          let t a = any (\x -> x >= 2) $ map length . group $ map (\x -> (x + a) `div` 2) $ sort xs  in
            if t 0 || t 1 then 2 else 1

import Control.Monad
import Data.List

main = do
  n <- readLn
  replicateM_ n $ do
    getLine
    a <- fmap (sort . fmap read . words) getLine
    let (_,res) = foldl (\(prev,acc) x -> (x,(if abs (x - prev) /= 1 then 0 else 1) + acc)) (-2,0) a
    print $ if res > 0 then 2 else 1

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

process = do
		a<- getLine
		b<- sort <$> map read <$> words <$>getLine ::IO [Int]
		print $ if a=="1" then 1
				  else if length(take 1 (filter (==1) (zipWith (\z1 z2 ->z2-z1) b (tail b)))) ==1 then 2 else 1

main = do
		n<- read <$> getLine ::IO Int
		replicateM_ n  process

import Control.Monad

main = do
  n <- readLn
  replicateM_ n $ do
    getLine
    a <- fmap (fmap read . words) getLine
    print $ if length (filter odd a) /= length a then 2 else 1


Polycarp has invited $$$n$$$ friends to celebrate the New Year. During the celebration, he decided to take a group photo of all his friends. Each friend can stand or lie on the side.Each friend is characterized by two values $$$h_i$$$ (their height) and $$$w_i$$$ (their width). On the photo the $$$i$$$-th friend will occupy a rectangle $$$h_i \times w_i$$$ (if they are standing) or $$$w_i \times h_i$$$ (if they are lying on the side).The $$$j$$$-th friend can be placed in front of the $$$i$$$-th friend on the photo if his rectangle is lower and narrower than the rectangle of the $$$i$$$-th friend. Formally, at least one of the following conditions must be fulfilled:  $$$h_j < h_i$$$ and $$$w_j < w_i$$$ (both friends are standing or both are lying);  $$$w_j < h_i$$$ and $$$h_j < w_i$$$ (one of the friends is standing and the other is lying). For example, if $$$n = 3$$$, $$$h=[3,5,3]$$$ and $$$w=[4,4,3]$$$, then:  the first friend can be placed in front of the second: $$$w_1 < h_2$$$ and $$$h_1 < w_2$$$ (one of the them is standing and the other one is lying);  the third friend can be placed in front of the second: $$$h_3 < h_2$$$ and $$$w_3 < w_2$$$ (both friends are standing or both are lying). In other cases, the person in the foreground will overlap the person in the background.Help Polycarp for each $$$i$$$ find any $$$j$$$, such that the $$$j$$$-th friend can be located in front of the $$$i$$$-th friend (i.e. at least one of the conditions above is fulfilled).Please note that you do not need to find the arrangement of all people for a group photo. You just need to find for each friend $$$i$$$ any other friend $$$j$$$ who can be located in front of him. Think about it as you need to solve $$$n$$$ separate independent subproblems.

The first line contains one integer $$$t$$$ ($$$1 \leq t \leq 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of each test case contains one integer $$$n$$$ ($$$1 \leq n \leq 2 \cdot 10^5$$$) — the number of friends. This is followed by $$$n$$$ lines, each of which contains a description of the corresponding friend. Each friend is described by two integers $$$h_i$$$ and $$$w_i$$$ ($$$1 \leq h_i, w_i \leq 10^9$$$) — height and width of the $$$i$$$-th friend, respectively. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case output $$$n$$$ integers on a separate line, where the $$$i$$$-th number is the index of a friend that can be placed in front of the $$$i$$$-th. If there is no such friend, then output -1. If there are several answers, output any.

NoteThe first test case is described in the statement.In the third test case, the following answers are also correct:   $$$[-1, -1, 1, 2]$$$;  $$$[-1, -1, 1, 1]$$$;  $$$[-1, -1, 2, 1]$$$.

{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -O2 #-}

import safe Control.Arrow ((>>>))
import qualified Data.Text as T
import qualified Data.Text.IO as TI
import Data.List
import Data.Function

main :: IO ()
main = TI.getContents >>= (T.lines >>> drop 1 >>> tcio >>> (mapM_ putStrLn)) where
  tcio :: [T.Text] -> [String]
  tcio [] = []
  tcio (nm : rest) = ((:[]).istoline . solve . linestoiss) (take m rest) ++ tcio (drop m rest) where [m] = linetois nm;
  linetoi = toi; linetois = (map linetoi).(T.words); linestoiss = map linetois
  itoline = show; istoline = unwords . (map itoline); isstolines = map istoline
  toi t = toi0 0 t where toi0 n t = if (T.null) t then n else toi0 (10*n + fromIntegral(on (-) fromEnum (T.head t) '0') ) (T.tail t) ;

solve :: [[Int]] -> [Int]
solve hws0 = map last $ sort $ map (\[h_,w,i,bm,bmi]-> if w==bm then [i,-1] else [i,bmi]) hwmis where
  hwis = sortBy (\([h1,w1],_) ([h2,w2],_)-> compare [h1,w2] [h2,w1]) $ flip zip [1..] $ map (reverse.sort) hws0
  hwmis = tail $ scanl' f  [0,0,0,maxBound::Int,-1] hwis
  f [h_, w_, i_, bm, bmi] ([h, w], i) = [h, w, i, min bm w, if w<bm then i else bmi]

{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -O2 #-}

import safe Control.Arrow ((>>>))
import qualified Data.Text as T
import qualified Data.Text.IO as TI
import Data.List
import Data.Function

main :: IO ()
main = TI.getContents >>= (T.lines >>> drop 1 >>> tcio >>> (mapM_ putStrLn)) where
  tcio :: [T.Text] -> [String]
  tcio [] = []
  tcio (nm : rest) = ((:[]).istoline . solve . linestoiss) (take m rest) ++ tcio (drop m rest) where [m] = linetois nm;
  linetoi = toi; linetois = (map linetoi).(T.words); linestoiss = map linetois
  itoline = show; istoline = unwords . (map itoline); isstolines = map istoline
  toi t = toi0 0 t where toi0 n t = if (T.null) t then n else toi0 (10*n + fromIntegral(on (-) fromEnum (T.head t) '0') ) (T.tail t) ;

solve :: [[Int]] -> [Int]
solve hws0 = map last $ sort $ map (\[h_,w,i,bm,bmi]-> if w==bm then [i,-1] else [i,bmi]) hwmis where
  hwmis = tail $ scanl' f  [0,0,0,maxBound::Int,-1] hwis
  hwis = sort $ flip zip [1..] $ map (reverse.sort) hws0
  f [h_, w_, i_, bm, bmi] ([h, w], i) = [h, w, i, min bm w, if w<bm then i else bmi]


The only difference between the two versions is that this version asks the maximal possible answer.Homer likes arrays a lot. Today he is painting an array $$$a_1, a_2, \dots, a_n$$$ with two kinds of colors, white and black. A painting assignment for $$$a_1, a_2, \dots, a_n$$$ is described by an array $$$b_1, b_2, \dots, b_n$$$ that $$$b_i$$$ indicates the color of $$$a_i$$$ ($$$0$$$ for white and $$$1$$$ for black).According to a painting assignment $$$b_1, b_2, \dots, b_n$$$, the array $$$a$$$ is split into two new arrays $$$a^{(0)}$$$ and $$$a^{(1)}$$$, where $$$a^{(0)}$$$ is the sub-sequence of all white elements in $$$a$$$ and $$$a^{(1)}$$$ is the sub-sequence of all black elements in $$$a$$$. For example, if $$$a = [1,2,3,4,5,6]$$$ and $$$b = [0,1,0,1,0,0]$$$, then $$$a^{(0)} = [1,3,5,6]$$$ and $$$a^{(1)} = [2,4]$$$.The number of segments in an array $$$c_1, c_2, \dots, c_k$$$, denoted $$$\mathit{seg}(c)$$$, is the number of elements if we merge all adjacent elements with the same value in $$$c$$$. For example, the number of segments in $$$[1,1,2,2,3,3,3,2]$$$ is $$$4$$$, because the array will become $$$[1,2,3,2]$$$ after merging adjacent elements with the same value. Especially, the number of segments in an empty array is $$$0$$$.Homer wants to find a painting assignment $$$b$$$, according to which the number of segments in both $$$a^{(0)}$$$ and $$$a^{(1)}$$$, i.e. $$$\mathit{seg}(a^{(0)})+\mathit{seg}(a^{(1)})$$$, is as large as possible. Find this number.

The first line contains an integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$). The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \leq a_i \leq n$$$).

Output a single integer, indicating the maximal possible total number of segments.

import Control.Monad
import Data.Maybe
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

data State = Empty | P0 Int | P1 Int Int | P2 deriving (Show)

main :: IO ()
main = do
  _ <- C.getLine
  as <- getInts
  let
    prepend :: [Either Int Int] -> Int -> [Either Int Int]
    prepend [] x = [Left x]
    prepend ys@(y : ys') x
      | either id id y /= x = Left x : ys
      | isLeft y = Right x : ys'
      | otherwise = ys
    bs = foldl' prepend [] as
    acc :: (State, Int) -> Either Int Int -> (State, Int)
    acc (Empty, total) (Left x) = (P0 x, total + 1)
    acc (P0 p, total) (Left x) = (P2, total + 1)
    acc (P1 p o, total) (Left x)
      | p == o = (P1 x p, total + 1)
      | x == o = (P1 x o, total + 1)
      | otherwise = (P2, total + 1)
    acc (P2, total) (Left _) = (P2, total + 1)
    acc (P1 _ o, total) (Right x) = (P1 x x, total + 1 + (if x == o then 0 else 1))
    acc (_, total) (Right x) = (P1 x x, total + 2)
    (_, result) = foldl' acc (Empty, 0) bs
  putStrLn $ show result

import Control.Monad
import Data.Maybe
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

data State = Empty | P0 Int | P1 Int Int | P2 | Q1 Int Int deriving (Show)

main :: IO ()
main = do
  _ <- C.getLine
  as <- getInts
  let
    prepend :: [Either Int Int] -> Int -> [Either Int Int]
    prepend [] x = [Left x]
    prepend ys@(y : ys') x
      | either id id y /= x = Left x : ys
      | isLeft y = Right x : ys'
      | otherwise = ys
    bs = foldl' prepend [] as
    acc :: (State, Int) -> Either Int Int -> (State, Int)
    acc (Empty, total) (Left x) = (P0 x, total + 1)
    acc (P0 p, total) (Left x) = (Q1 x p, total + 1)
    acc (P1 p o, total) (Left x)
      | p == o = (P1 x p, total + 1)
      | x == o = (P1 x o, total + 1)
      | otherwise = (P2, total + 1)
    acc (P2, total) (Left _) = (P2, total + 1)
    acc (Q1 p o, total) (Left x)
      | x == o = (P1 x o, total + 1)
      | otherwise = (P2, total + 1)
    acc (P1 _ o, total) (Right x) = (P1 x x, total + 1 + (if x == o then 0 else 1))
    acc (_, total) (Right x) = (P1 x x, total + 2)
    (_, result) = foldl' acc (Empty, 0) bs
  putStrLn $ show result

import Control.Monad
import Data.Maybe
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

data State = Empty | P0 Int | P1 Int Int | P2 deriving (Show)

main :: IO ()
main = do
  _ <- C.getLine
  as <- getInts
  let
    prepend :: [Either Int Int] -> Int -> [Either Int Int]
    prepend [] x = [Left x]
    prepend ys@(y : ys') x
      | either id id y /= x = Left x : ys
      | isLeft y = Right x : ys'
      | otherwise = ys
    bs = foldl' prepend [] as
    acc :: (State, Int) -> Either Int Int -> (State, Int)
    acc (Empty, total) (Left x) = (P0 x, total + 1)
    acc (P0 p, total) (Left x) = (P1 x p, total + 1)
    acc (P1 p o, total) (Left x)
      | p == o = (P1 x p, total + 1)
      | x == o = (P1 x o, total + 1)
      | otherwise = (P2, total + 1)
    acc (P2, total) (Left _) = (P2, total + 1)
    acc (Empty, total) (Right x) = (P1 x x, total + 2)
    acc (P0 _, total) (Right x) = (P1 x x, total + 2)
    acc (P1 _ o, total) (Right x) = (P1 x x, total + 1 + (if x == o then 0 else 1))
    acc (P2, total) (Right x) = (P1 x x, total + 2)
    (_, result) = foldl' acc (Empty, 0) bs
  putStrLn $ show result

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

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

main :: IO ()
main = do
  _ <- C.getLine
  as <- getInts
  let
    acc yy@(y1 : y2 : _) x
      | y1 == y2 = if x == y1 then yy else x : yy
      | otherwise = x : yy
    acc yy x = x : yy
    bs = foldl' acc [] as
    f :: [Int] -> ([Int], [Int])
    f (x1 : x2 : xs)
      | x1 == x2 = let (ys, zs) = f xs in (x1 : ys, x2 : zs)
      | otherwise = let (ys, zs) = f (x2 : xs) in (x1 : ys, zs)
    f (x : _) = ([x], [])
    f _ = ([], [])
    g :: [Int] -> [Int]
    g [] = []
    g (x : xs)
      | null ys = [x]
      | head ys == x = ys
      | otherwise = x : ys
      where
      ys = g xs
    (xs, ys) = f bs
  putStrLn $ show $ length (g xs) + length (g ys)

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

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

main :: IO ()
main = do
  _ <- C.getLine
  as <- getInts
  let
    acc yy@(y1 : y2 : _) x
      | y1 == y2 = if x == y1 then yy else x : yy
      | otherwise = x : yy
    acc yy x = x : yy
    result = length $ foldl' acc [] as
  putStrLn $ show result


A number is ternary if it contains only digits $$$0$$$, $$$1$$$ and $$$2$$$. For example, the following numbers are ternary: $$$1022$$$, $$$11$$$, $$$21$$$, $$$2002$$$.You are given a long ternary number $$$x$$$. The first (leftmost) digit of $$$x$$$ is guaranteed to be $$$2$$$, the other digits of $$$x$$$ can be $$$0$$$, $$$1$$$ or $$$2$$$.Let's define the ternary XOR operation $$$\odot$$$ of two ternary numbers $$$a$$$ and $$$b$$$ (both of length $$$n$$$) as a number $$$c = a \odot b$$$ of length $$$n$$$, where $$$c_i = (a_i + b_i) \% 3$$$ (where $$$\%$$$ is modulo operation). In other words, add the corresponding digits and take the remainders of the sums when divided by $$$3$$$. For example, $$$10222 \odot 11021 = 21210$$$.Your task is to find such ternary numbers $$$a$$$ and $$$b$$$ both of length $$$n$$$ and both without leading zeros that $$$a \odot b = x$$$ and $$$max(a, b)$$$ is the minimum possible.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 first line of the test case contains one integer $$$n$$$ ($$$1 \le n \le 5 \cdot 10^4$$$) — the length of $$$x$$$. The second line of the test case contains ternary number $$$x$$$ consisting of $$$n$$$ digits $$$0, 1$$$ or $$$2$$$. It is guaranteed that the first digit of $$$x$$$ is $$$2$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$5 \cdot 10^4$$$ ($$$\sum n \le 5 \cdot 10^4$$$).

For each test case, print the answer — two ternary integers $$$a$$$ and $$$b$$$ both of length $$$n$$$ and both without leading zeros such that $$$a \odot b = x$$$ and $$$max(a, b)$$$ is the minimum possible. If there are several answers, you can print any.

import Control.Arrow

main = interact $
  lines >>> drop 1 >>> process >>> unlines

process :: [String] -> [String]
process [] = []
process (n:x:rest) = fst ans : snd ans : process rest
  where ans = solve x

solve :: String -> (String, String)
solve "" = ("", "")
solve (c:rest)
  | c == '1' = ('1' : (take (length rest) (repeat '0')),
                '0' : rest)
  | otherwise = (d : fst rec, d : snd rec)
    where
      d = if c == '2' then '1' else '0'
      rec = solve rest

import Data.Tuple (swap)
import Data.Maybe (fromJust)
import Control.Monad (replicateM_)

data TNum = N0 | N1 | N2 deriving (Eq, Ord)
assocList = [(N0, '0'), (N1,'1'), (N2,'2')]
decode = fromJust . flip lookup assocList
encode = fromJust . flip lookup (map swap assocList)

main = readLn >>= flip replicateM_ solveIO

solveIO = do
    _ <- getLine
    n <- map encode <$> getLine
    putStrLn . init . unlines . map (map decode) . (\(a,b) -> [a,b]) $ solve n

solve :: [TNum] -> ([TNum], [TNum])
solve [] = ([], [])
solve (x:rest) = case x of
    N0 -> let (a,b) = solve rest in (N0 : a, N0 : b)
    N2 -> let (a,b) = solve rest in (N1 : a, N1 : b)
    N1 -> let (a,b) = solveMinimizingLeft rest in (N1 : a, N0 : b)

solveMinimizingLeft :: [TNum] -> ([TNum], [TNum])
solveMinimizingLeft xs = (replicate (length xs) N0, xs)

import Data.Char (isSpace)
import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as C

parseInt :: C.ByteString -> Int
parseInt = fst . fromJust . C.readInt

f :: (Char, Char, Char) -> Bool -> Char -> (Bool, Char)
f (c1, c2, c3) flag char =
  case char of
    '0' -> (flag, '0')
    '1' -> (True, if flag then c1 else c2)
    _ -> (flag, if flag then c3 else '1')

work :: IO ()
work = do
  _ <- C.getLine
  a <- C.filter (not . isSpace) <$> C.getLine
  let b = snd $ C.mapAccumL (f ('0', '1', '0')) False a
      c = snd $ C.mapAccumL (f ('1', '0', '2')) False a
  C.putStrLn b
  C.putStrLn c

main :: IO ()
main = do
  n <- fmap parseInt C.getLine
  replicateM_ n work

import Data.Word
import Data.List

main :: IO ()
main = do
    getLine -- discard
    answers <- concat <$> map (join.unzip.solve) <$> process <$> getContents :: IO [[Word8]]
    mapM_ print' answers

process :: String -> [[Word8]]
process input = map (read' . snd) . filter (even . fst) . zip [1..] . lines $ input

read' :: String -> [Word8]
read' (x:xs) = (read'' x) : (read' xs)
read' _     = []

read'' '1' = 1
read'' '2' = 2
read'' '0' = 0

solve :: [Word8] -> [(Word8,Word8)]
solve num = solver True num

solver _ [] = []
solver True (0:xs) = (0,0) : (solver True xs)
solver True (1:xs) = (1,0) : (solver False xs)
solver True (2:xs) = (1,1) : (solver True xs)
solver False (0:xs) = (0,0) : (solver False xs)
solver False (1:xs) = (0,1) : (solver False xs)
solver False (2:xs) = (0,2) : (solver False xs)

join (a,b) = [a,b]

print' :: [Word8] -> IO ()
print' = putStrLn . intercalate "" . map show

import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as C

parseInt :: C.ByteString -> Int
parseInt = fst . fromJust . C.readInt

f :: (Char, Char, Char) -> Bool -> Char -> (Bool, Char)
f (c1, c2, c3) flag char =
  case char of
    '0' -> (flag, '0')
    '1' -> (True, if flag then c1 else c2)
    _ -> (flag, if flag then c3 else '1')

work :: IO ()
work = do
  _ <- C.getLine
  a <- C.getLine
  let b = snd $ C.mapAccumL (f ('0', '1', '0')) False a
      c = snd $ C.mapAccumL (f ('1', '0', '2')) False a
  C.putStrLn b
  C.putStrLn c

main :: IO ()
main = do
  n <- fmap parseInt C.getLine
  replicateM_ n work


The clique problem is one of the most well-known NP-complete problems. Under some simplification it can be formulated as follows. Consider an undirected graph G. It is required to find a subset of vertices C of the maximum size such that any two of them are connected by an edge in graph G. Sounds simple, doesn't it? Nobody yet knows an algorithm that finds a solution to this problem in polynomial time of the size of the graph. However, as with many other NP-complete problems, the clique problem is easier if you consider a specific type of a graph.Consider n distinct points on a line. Let the i-th point have the coordinate xi and weight wi. Let's form graph G, whose vertices are these points and edges connect exactly the pairs of points (i, j), such that the distance between them is not less than the sum of their weights, or more formally: |xi - xj| ≥ wi + wj.Find the size of the maximum clique in such graph.

The first line contains the integer n (1 ≤ n ≤ 200 000) — the number of points. Each of the next n lines contains two numbers xi, wi (0 ≤ xi ≤ 109, 1 ≤ wi ≤ 109) — the coordinate and the weight of a point. All xi are different.

Print a single number — the number of vertexes in the maximum clique of the given graph.

NoteIf you happen to know how to solve this problem without using the specific properties of the graph formulated in the problem statement, then you are able to get a prize of one million dollars!The picture for the sample test.

module Main where

import Control.Monad
import Data.Function
import Data.List
import qualified Data.ByteString.Lazy.Char8 as L

data State s a = State { runState :: s -> (a, s) }

evalState :: State s a -> s -> a
evalState m s = fst $ runState m s

instance Monad (State s) where
    return x = State $ \s -> (x, s)
    m >>= f  = State $ \s -> let (a, s') = runState m s
                             in runState (f a) s'

type Env = State [Int]
type Interval = (Int, Int)

parseInt :: L.ByteString -> Int
parseInt s = case L.readInt s of
               Just (x, _) -> x
               Nothing     -> error $ "Can't parse Int: " ++ (show s)

nextInt :: Env Int
nextInt = State $ \(x:xs) -> (x, xs)

nextInterval :: Env Interval
nextInterval = do
  center <- nextInt
  weight <- nextInt
  return $ (center - weight, center + weight)

solve :: [Interval] -> Int
solve [] = 0
solve is = rec 1 hi tis
    where (hi:tis) = sortBy (compare `on` snd) is
          rec len _ [] = len
          rec len li (hi:tis) = if fst hi >= snd li
                                then rec (len + 1) hi tis
                                else rec len li tis

go :: Env Int
go = do
  n  <- nextInt
  is <- replicateM n nextInterval
  return $ solve is

main :: IO ()
main = do
  input <- liftM (map parseInt . L.words) L.getContents
  let result = evalState go input
  print result


Bitwise exclusive OR (or bitwise addition modulo two) is a binary operation which is equivalent to applying logical exclusive OR to every pair of bits located on the same positions in binary notation of operands. In other words, a binary digit of the result is equal to 1 if and only if bits on the respective positions in the operands are different.For example, if X = 10910 = 11011012, Y = 4110 = 1010012, then:  X xor Y  =  6810  =  10001002. Write a program, which takes two non-negative integers A and B as an input and finds two non-negative integers X and Y, which satisfy the following conditions:   A = X + Y  B  =  X xor Y, where xor is bitwise exclusive or.  X is the smallest number among all numbers for which the first two conditions are true.

The first line contains integer number A and the second line contains integer number B (0 ≤ A, B ≤ 264 - 1).

The only output line should contain two integer non-negative numbers X and Y. Print the only number -1 if there is no answer.

main = do interact (unwords . map show . gao . map read . words)
gao [a, b] = if c >= 0 && even c then [d, a - d] else [-1] where
	c = a - b
	d = div c 2

data X = X Integer deriving Show
data Y = Y Integer deriving Show
data A = A Integer deriving Show
data B = B Integer deriving Show
data NeedCarry = NeedCarry Bool deriving Show

bitToInt bit = if bit then 1 else 0

printRes (Just (X x, Y y, NeedCarry False)) = unwords $ map show $ [x, y]
printRes _ = "-1"

solver :: A -> B -> Maybe (X, Y, NeedCarry)
solver (A 0) (B 0) = Just (X 0, Y 0, NeedCarry False)
solver (A a) (B b) = do
    let a0 = a `mod` 2 /= 0
        b0 = b `mod` 2 /= 0
        c0 = a0 /= b0
    (X nx, Y ny, NeedCarry c1) <- solver (A $ a `div` 2) (B $ b `div` 2)
    let neededXYCount = 2 * (bitToInt c1) + (bitToInt a0) - (bitToInt c0) :: Integer
    (x0, y0) <- case neededXYCount of
        0 -> Just (False, False)
        1 -> Just (False, True)
        2 -> Just (True, True)
        _ -> Nothing
    return (X $ nx*2+ (bitToInt x0), Y $ ny*2+(bitToInt y0), NeedCarry c0)

interactor :: String -> String
interactor str = let a :: Integer
                     [a, b] = map read $ lines str
                 in unlines $ [printRes $ solver (A a) (B b)]

main = interact interactor


She does her utmost to flawlessly carry out a person's last rites and preserve the world's balance of yin and yang.Hu Tao, being the little prankster she is, has tried to scare you with this graph problem! You are given a connected undirected graph of $$$n$$$ nodes with $$$m$$$ edges. You also have $$$q$$$ queries. Each query consists of two nodes $$$a$$$ and $$$b$$$.Initially, all edges in the graph have a weight of $$$0$$$. For each query, you must choose a simple path starting from $$$a$$$ and ending at $$$b$$$. Then you add $$$1$$$ to every edge along this path. Determine if it's possible, after processing all $$$q$$$ queries, for all edges in this graph to have an even weight. If so, output the choice of paths for each query. If it is not possible, determine the smallest number of extra queries you could add to make it possible. It can be shown that this number will not exceed $$$10^{18}$$$ under the given constraints.A simple path is defined as any path that does not visit a node more than once.An edge is said to have an even weight if its value is divisible by $$$2$$$.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$2 \leq n \leq 3 \cdot 10^5$$$, $$$n-1 \leq m \leq \min{\left(\frac{n(n-1)}{2}, 3 \cdot 10^5\right)}$$$). Each of the next $$$m$$$ lines contains two integers $$$x$$$ and $$$y$$$ ($$$1 \leq x, y \leq n$$$, $$$x\neq y$$$) indicating an undirected edge between node $$$x$$$ and $$$y$$$. The input will not contain self-loops or duplicate edges, and the provided graph will be connected. The next line contains a single integer $$$q$$$ ($$$1 \leq q \leq 3 \cdot 10^5$$$). Each of the next $$$q$$$ lines contains two integers $$$a$$$ and $$$b$$$ ($$$1 \leq a, b \leq n, a \neq b$$$), the description of each query. It is guaranteed that $$$nq \leq 3 \cdot 10^5$$$.

If it is possible to force all edge weights to be even, print "YES" on the first line, followed by $$$2q$$$ lines indicating the choice of path for each query in the same order the queries are given. For each query, the first line should contain a single integer $$$x$$$: the number of nodes in the chosen path. The next line should then contain $$$x$$$ spaced separated integers $$$p_i$$$ indicating the path you take ($$$p_1 = a, p_x = b$$$ and all numbers should fall between $$$1$$$ and $$$n$$$). This path cannot contain duplicate nodes and must be a valid simple path in the graph. If it is impossible to force all edge weights to be even, print "NO" on the first line and the minimum number of added queries on the second line.

NoteHere is what the queries look like for the first test case (red corresponds to the 1st query, blue 2nd query, and green 3rd query):    Notice that every edge in the graph is part of either $$$0$$$ or $$$2$$$ colored query edges.The graph in the second test case looks like this:    There does not exist an assignment of paths that will force all edges to have even weights with the given queries. One must add at least $$$2$$$ new queries to obtain a set of queries that can satisfy the condition.

{-# LANGUAGE BangPatterns #-}
import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

import Control.Monad
import Data.Array.Unboxed
import Data.Graph

type DiffList t = [t] -> [t]

pathSummaries' :: (s -> v -> s) -> s -> Tree v -> DiffList (v, s)
{-# INLINE pathSummaries' #-}
pathSummaries' fun = let
  go !currS (Node root subtrees) cont
    = (root, currS) : foldr (go $ fun currS root) cont subtrees
  in  go

mainFun :: SO
mainFun = do
  ~[n, m] <- getInts 2
  es <- fmap concat $ replicateM m $ do
    ~[x, y] <- getInts 2
    pure [(x, y), (y, x)]
  ~[q] <- getInts 1
  queries <- replicateM q $ do
    ~[a, b] <- getInts 2
    pure (a, b)
  let
    vertexUseCts :: UArray Int Int
    vertexUseCts = accumArray (+) 0 (1, n) $ do
      (a, b) <- queries
      [(a, 1), (b, 1)]
    nIssues = length $ filter odd $ elems vertexUseCts
    adj :: Graph
    adj = buildG (1, n) es
    [spanningTree] = dff adj

    depths :: UArray Int Int
    depths = array (1, n) $ pathSummaries' (\s _ -> s + 1) 0 spanningTree []
    parents :: UArray Int Int
    parents = array (1, n) $ pathSummaries' (\_ p -> p) 0 spanningTree []

    showPath (x, y) = let
      dx = depths ! x
      dy = depths ! y
      xs = drop (dx - dy) $ iterate (parents !) x
      ys = drop (dy - dx) $ iterate (parents !) y
      (lca, _) : _ = dropWhile (uncurry (/=)) $ zip xs ys
      dlca = depths ! lca
      len = 1 + dx + dy - 2 * dlca
      xp = take (dx - dlca) $ iterate (parents !) x
      yp = take (dy - dlca) $ iterate (parents !) y
      in  putInts [len] <> putInts (xp ++ lca : reverse yp)
  pure $ if  nIssues > 0
    then  string7 "NO\n" <> putInts [div nIssues 2]
    else  string7 "YES\n" <> foldMap showPath queries

type SP = State [P.ByteString]
type SO = SP Builder

getNext :: Int -> SP [P.ByteString]
getNext = state . splitAt

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

putInts :: [Int] -> Builder
putInts vs = let
  sepPrim = (,) ' ' Prim.>$<
    Prim.liftFixedToBounded Prim.char7 Prim.>*< Prim.intDec
  in  case  vs  of
  [] -> char7 '\n'
  x : xs -> intDec x <> Prim.primMapListBounded sepPrim xs <> char7 '\n'

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  inp <- P.getContents
  let  outp = evalState mainFun $ P.words inp
  P.putStr $ toLazyByteString outp


After reaching your destination, you want to build a new colony on the new planet. Since this planet has many mountains and the colony must be built on a flat surface you decided to flatten the mountains using boulders (you are still dreaming so this makes sense to you).  You are given an array $$$h_1, h_2, \dots, h_n$$$, where $$$h_i$$$ is the height of the $$$i$$$-th mountain, and $$$k$$$ — the number of boulders you have.You will start throwing boulders from the top of the first mountain one by one and they will roll as follows (let's assume that the height of the current mountain is $$$h_i$$$):   if $$$h_i \ge h_{i + 1}$$$, the boulder will roll to the next mountain;  if $$$h_i < h_{i + 1}$$$, the boulder will stop rolling and increase the mountain height by $$$1$$$ ($$$h_i = h_i + 1$$$);  if the boulder reaches the last mountain it will fall to the waste collection system and disappear. You want to find the position of the $$$k$$$-th boulder or determine that it will fall into the waste collection system.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. Each test case consists of two lines. The first line in each test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 100$$$; $$$1 \le k \le 10^9$$$) — the number of mountains and the number of boulders. The second line contains $$$n$$$ integers $$$h_1, h_2, \dots, h_n$$$ ($$$1 \le h_i \le 100$$$) — the height of the mountains. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$100$$$.

For each test case, print $$$-1$$$ if the $$$k$$$-th boulder will fall into the collection system. Otherwise, print the position of the $$$k$$$-th boulder.

NoteLet's simulate the first case:  The first boulder starts at $$$i = 1$$$; since $$$h_1 \ge h_2$$$ it rolls to $$$i = 2$$$ and stops there because $$$h_2 < h_3$$$.  The new heights are $$$[4,2,2,3]$$$.  The second boulder starts at $$$i = 1$$$; since $$$h_1 \ge h_2$$$ the boulder rolls to $$$i = 2$$$; since $$$h_2 \ge h_3$$$ the boulder rolls to $$$i = 3$$$ and stops there because $$$h_3 < h_4$$$.  The new heights are $$$[4,2,3,3]$$$.  The third boulder starts at $$$i = 1$$$; since $$$h_1 \ge h_2$$$ it rolls to $$$i = 2$$$ and stops there because $$$h_2 < h_3$$$.  The new heights are $$$[4,3,3,3]$$$. The positions where each boulder stopped are the following: $$$[2,3,2]$$$.In the second case, all $$$7$$$ boulders will stop right at the first mountain rising its height from $$$1$$$ to $$$8$$$.The third case is similar to the first one but now you'll throw $$$5$$$ boulders. The first three will roll in the same way as in the first test case. After that, mountain heights will be equal to $$$[4, 3, 3, 3]$$$, that's why the other two boulders will fall into the collection system.In the fourth case, the first and only boulders will fall straight into the collection system.

chunksOf :: Int -> [a] -> [[a]]
chunksOf x [] = []
chunksOf x l = take x l : chunksOf x (drop x l)

toArr :: Read a => String -> [a]
toArr = map read . words

simulation :: ([Int], Int) -> ([Int], Int)
simulation ([], _) = ([], -1)
simulation ([x], _) = ([x], -1)
simulation (x : y : t, p) = if x >= y then f x $ simulation (y : t, p)
                              else (x + 1 : y : t, 1)
    where f x (hs, -1) = (x : hs, -1)
          f x (hs,  p) = (x : hs, p + 1)

solve :: Int -> [Int] -> Int
solve k hs = if k >= 11000 then -1
             else snd (iterate simulation (hs, 0) !! k)

main :: IO ()
main = interact (unlines . map (show . uncurry solve . getInput) . chunksOf 2 . tail . lines)
    where getInput [a, b] = let [_, k] = toArr a in (k, toArr b)

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import qualified Data.ByteString.Lazy.Char8 as P

type SIO = StateT P.ByteString IO

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

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

solve :: [Int] -> Int -> Int
solve h k = stepSolve [(0, maxBound)] (zip [1..] h) k

stepSolve :: [(Int, Int)] -> [(Int, Int)] -> Int -> Int
stepSolve _ [] _ = 0-1 -- fall off
stepSolve [] _ _ = error "(maxBound :: Int) is too small??"
stepSolve stack@((_, lastH) : tstack) vs@(nextV@(nextPos, nextH) : tvs) k
  | lastH >= nextH  = stepSolve (nextV : stack) tvs k
  | otherwise  = case  tstack  of
      [] -> error "(maxBound :: Int) is too small??"
      (ancPos, ancH) : _ -> let
        width = (nextPos - ancPos - 1)
        depth = min ancH nextH - lastH
        vol = width * depth
        in  if  k <= vol
        then  nextPos - 1 - mod (k-1) width
        else  if  ancH <= nextH
        then  stepSolve tstack vs (k - vol)
        else  stepSolve (nextV : tstack) tvs (k - vol)

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [_n, k] <- readInts
    h <- readInts
    lift . print $ solve h k

chunksOf :: Int -> [a] -> [[a]]
chunksOf x [] = []
chunksOf x l = take x l : chunksOf x (drop x l)

toArr :: Read a => String -> [a]
toArr = map (read :: Read a => String -> a) . words

fmtB :: Bool -> String
fmtB True  = "YES"
fmtB False = "NO"

solve :: Int -> Int -> String -> Bool
solve px py s = count 'U' s >= py &&
                count 'D' s >= -py &&
                count 'R' s >= px &&
                count 'L' s >= -px
    where count x = length . filter (==x)

main :: IO ()
main = interact (unlines . map (fmtB . uncurry3 solve . getInput) . chunksOf 2 . tail . lines)
    where getInput [a, b] = let [px, py] = toArr a in (px, py, b)
          uncurry3 f (a,b,c) = f a b c