Devu being a small kid, likes to play a lot, but he only likes to play with arrays. While playing he came up with an interesting question which he could not solve, can you please solve it for him?Given an array consisting of distinct integers. Is it possible to partition the whole array into k disjoint non-empty parts such that p of the parts have even sum (each of them must have even sum) and remaining k - p have odd sum? (note that parts need not to be continuous).If it is possible to partition the array, also give any possible way of valid partitioning.

The first line will contain three space separated integers n, k, p (1 ≤ k ≤ n ≤ 105; 0 ≤ p ≤ k). The next line will contain n space-separated distinct integers representing the content of array a: a1, a2, ..., an (1 ≤ ai ≤ 109).

In the first line print "YES" (without the quotes) if it is possible to partition the array in the required way. Otherwise print "NO" (without the quotes). If the required partition exists, print k lines after the first line. The ith of them should contain the content of the ith part. Print the content of the part in the line in the following way: firstly print the number of elements of the part, then print all the elements of the part in arbitrary order. There must be exactly p parts with even sum, each of the remaining k - p parts must have odd sum. As there can be multiple partitions, you are allowed to print any valid partition.

import Data.List
import Data.Function

main = interact $ maybe "NO" (("YES\n" ++ ) . unlines . map (unwords . map show)) . getAns . map read . words

getAns :: [Int] -> Maybe [[Int]]
getAns (_:k:p:xs) = getGroup (k - p) k $ partition even xs

getGroup :: Int -> Int -> ([Int], [Int]) -> Maybe [[Int]]
getGroup _ n ([], []) | n > 0 = Nothing
getGroup t _ (_, []) | t > 0 = Nothing
getGroup t 1 (es, os) =
	if (odd $ length os + t) then Nothing
	else Just [(length es + length os):(es ++ os)]
getGroup 0 n ([], o1:o2:os) = fmap ([2, o1, o2] :) $ getGroup 0 (n - 1) ([], os)
getGroup 0 n (e:es, os) = fmap ([1, e] :) $ getGroup 0 (n - 1) (es, os)
getGroup t n (es, o:os) = fmap ([1, o] :) $ getGroup (t - 1) (n - 1) (es, os)

import Data.List
import Data.Function

main = interact $ maybe "NO" (("YES\n" ++ ) . unlines . map (unwords . map show . addLength)) . getAns . map read . words

addLength :: [Int] -> [Int]
addLength a = (length a) : a

getAns :: [Int] -> Maybe [[Int]]
getAns (_:k:p:xs) = getGroup (k - p) k $ partition even xs

getGroup :: Int -> Int -> ([Int], [Int]) -> Maybe [[Int]]
getGroup _ n ([], []) | n > 0 = Nothing
getGroup t _ (_, []) | t > 0 = Nothing
getGroup t 1 (es, os) =
	if (odd $ length os + t) then Nothing
	else Just [es ++ os]
getGroup 0 n ([], o1:o2:os) = fmap ([o1, o2] :) $ getGroup 0 (n - 1) ([], os)
getGroup 0 n (e:es, os) = fmap ([e] :) $ getGroup 0 (n - 1) (es, os)
getGroup t n (es, o:os) = fmap ([o] :) $ getGroup (t - 1) (n - 1) (es, os)

import Data.List
import Data.Function

main = interact $ maybe "NO" (("YES\n" ++ ) . unlines . map (unwords . map show)) . getAns . map read . words

getAns :: [Int] -> Maybe [[Int]]
getAns (_:k:p:xs) = getGroup (k - p) k $ partition even xs

getGroup :: Int -> Int -> ([Int], [Int]) -> Maybe [[Int]]
getGroup _ n ([], []) | n > 0 = Nothing
getGroup t _ (_, []) | t > 0 = Nothing
getGroup t 1 (es, os) =
	if (odd $ sum os + sum es + t) then Nothing
	else Just [(length es + length os):(es ++ os)]
getGroup 0 n ([], o1:o2:os) = fmap ([2, o1, o2] :) $ getGroup 0 (n - 1) ([], os)
getGroup 0 n (e:es, os) = fmap ([1, e] :) $ getGroup 0 (n - 1) (es, os)
getGroup t n (es, o:os) = fmap ([1, o] :) $ getGroup (t - 1) (n - 1) (es, os)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  [n,k,p] <- map read.words <$> getLine
  xs <- map readInt.B.words <$> B.getContents
  case solve n k p xs of
    Nothing -> putStrLn "NO"
    Just xss
      | length xss /= k -> putStrLn "NO"
      | otherwise -> do
          putStrLn "YES"
          putStr.unlines $ map (\xs-> unwords.map show$length xs:xs) xss

solve :: Int -> Int -> Int -> [Int] -> Maybe [[Int]]
solve n k p xs
  | 0<=q && q <= k && q<= numOdd && even (numOdd - q) = Just $ f (map return ys ++ rest) (concat rest')
  | otherwise = Nothing
   where
     !q = k - p
     (evens, odds) = partition even xs
     !numEven = length evens
     !numOdd  = n - numEven
     (ys, zs) = splitAt q odds
     (rest, rest') = splitAt (k-q) $ chunksOf 2 zs ++ map return evens
     f (xs:xss) ys = (xs++ys) : xss

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

import Data.List (partition)
solve :: [Int] -> [[Int]]
solve (k:p:xs)
    | det < 0 = []
    | odd det = []
    | length evens + div det 2 < p = []
    | otherwise = (h ++ junk ++ junk') : t
    where (odds, evens) = partition odd xs
          det = length odds - k + p
          (useodd, rest) = splitAt (k - p) odds
          (paired, junk) = splitAt (p * 2) rest
          (useeven, junk') = splitAt req evens
          req = p - div (length paired) 2
          (h:t) = makeListed useodd ++ pairChunks paired ++ makeListed useeven
pairChunks [] = []
pairChunks (x:y:s) = [x,y] : pairChunks s
makeListed = map (:[])
output xs = if null xs then "NO\n" else unlines ("YES" : map parted xs)
    where parted ps = (unwords . map show) (length ps : ps)
main = interact $ output.solve.map read.tail.words

import Data.List
import Control.Monad
q l=unwords$map show$length l:l
pairs(a:b:l)=[a,b]:pairs l
pairs[]=[]

solve l needOdds needEvens = do
    guard (length oddsNeeded == needOdds)
    guard (even $ length oddsSpare)
    guard (length evensNeeded == needEvens)
    return result
  where
  (odds, evens) = partition odd l
  (oddsNeeded, oddsSpare) = splitAt needOdds odds
  oddPairs = pairs oddsSpare
  evenGroups = oddPairs ++ map (:[]) evens
  spareEvens = concat (drop needEvens evenGroups)
  evensNeeded = take needEvens evenGroups
  resultsNeeded = map (:[]) oddsNeeded ++ evensNeeded
  result = init resultsNeeded ++ [last resultsNeeded ++ spareEvens]

s(_:k:p:l) = case solve l (k - p) p of
  Nothing -> ["NO"]
  Just l -> "YES" : map q l

main=interact$unlines.s.map read.words

import Data.List (partition)
solve :: [Int] -> [[Int]]
solve (k:p:xs)
    | det < 0 = []
    | odd det = []
    | length evens + div det 2 < p = []
    | otherwise = (h ++ junk ++ junk') : t
    where (odds, evens) = partition odd xs
          det = length odds - k + p
          (useodd, rest) = splitAt (k - p) odds
          (paired, junk) = splitAt (det * 2) rest
          (useeven, junk') = splitAt (p - det * 2) evens
          (h:t) = makeListed useodd ++ pairChunks paired ++ makeListed useeven
pairChunks [] = []
pairChunks (x:y:s) = [x,y] : pairChunks s
makeListed = map (:[])
output xs = if null xs then "NO\n" else unlines ("YES" : map parted xs)
    where parted ps = (unwords . map show) (length ps : ps)
main = interact $ output.solve.map read.tail.words

import Data.List
q l=unwords$map show$length l:l
pairs(a:b:l)=[a,b]:pairs l
pairs[]=[]
s(_:k:p:l)|length x<z||odd(length y)||length w+length e<p=["NO"]|1>0="YES":(map q$map(:[])x++take(p-1)w++[concat$drop(p-1)w])where z=k-p;(o,e)=partition odd l;(x,y)=splitAt z o;w=pairs y++map(:[])e
main=interact$unlines.s.map read.words

import Data.List
q l=unwords$map show$length l:l
pairs(a:b:l)=[a,b]:pairs l
pairs[]=[]
s(_:k:p:l)|length x<z||odd(length y)||length w<p=["NO"]|1>0="YES":(map q$map(:[])x++take(p-1)w++[concat$drop(p-1)w])where z=k-p;(o,e)=partition odd l;(x,y)=splitAt z o;w=pairs y++map(:[])e
main=interact$unlines.s.map read.words


You are given a sequence $$$a_1, a_2, \dots, a_n$$$ consisting of $$$n$$$ pairwise distinct positive integers.Find $$$\left\lfloor \frac n 2 \right\rfloor$$$ different pairs of integers $$$x$$$ and $$$y$$$ such that:   $$$x \neq y$$$;  $$$x$$$ and $$$y$$$ appear in $$$a$$$;  $$$x~mod~y$$$ doesn't appear in $$$a$$$. Note that some $$$x$$$ or $$$y$$$ can belong to multiple pairs.$$$\lfloor x \rfloor$$$ denotes the floor function — the largest integer less than or equal to $$$x$$$. $$$x~mod~y$$$ denotes the remainder from dividing $$$x$$$ by $$$y$$$.If there are multiple solutions, print any of them. It can be shown that at least one solution always exists.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of testcases. The first line of each testcase contains a single integer $$$n$$$ ($$$2 \le n \le 2 \cdot 10^5$$$) — the length of the sequence. The second line of each testcase contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^6$$$). All numbers in the sequence are pairwise distinct. The sum of $$$n$$$ over all testcases doesn't exceed $$$2 \cdot 10^5$$$.

The answer for each testcase should contain $$$\left\lfloor \frac n 2 \right\rfloor$$$ different pairs of integers $$$x$$$ and $$$y$$$ such that $$$x \neq y$$$, $$$x$$$ and $$$y$$$ appear in $$$a$$$ and $$$x~mod~y$$$ doesn't appear in $$$a$$$. Print the pairs one after another. You can print the pairs in any order. However, the order of numbers in the pair should be exactly such that the first number is $$$x$$$ and the second number is $$$y$$$. All pairs should be pairwise distinct. If there are multiple solutions, print any of them.

NoteIn the first testcase there are only two pairs: $$$(1, 4)$$$ and $$$(4, 1)$$$. $$$\left\lfloor \frac 2 2 \right\rfloor=1$$$, so we have to find one pair. $$$1~mod~4=1$$$, and $$$1$$$ appears in $$$a$$$, so that pair is invalid. Thus, the only possible answer is a pair $$$(4, 1)$$$.In the second testcase, we chose pairs $$$8~mod~2=0$$$ and $$$8~mod~4=0$$$. $$$0$$$ doesn't appear in $$$a$$$, so that answer is valid. There are multiple possible answers for that testcase.In the third testcase, the chosen pairs are $$$9~mod~5=4$$$ and $$$7~mod~5=2$$$. Neither $$$4$$$, nor $$$2$$$, appears in $$$a$$$, so that answer is valid.

import Control.Monad
import Data.Maybe
import qualified Data.ByteString.Char8 as C
import Data.ByteString.Builder
import System.IO
import Text.Printf

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

getInts :: IO [Int]
getInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    [n] <- getInts
    as <- getInts
    let x = minimum as
        ys = take (n `div` 2) $ filter (/= x) as
    return $ mconcat $ map (\y -> string7 $ printf "%d %d\n" y x) ys
  hPutBuilder stdout output

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 Data.Maybe

--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
--import Data.List
--import Data.Array.Unboxed

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    a <- getInts n
    let
      y = minimum a
      ans = take (quot n 2) [[x, y] | x <- a, y /= x]
    pure $ foldMap putInts ans

type SP = State [P.ByteString]

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

getInts :: Int -> SP [Int]
getInts k = map (fst . fromJust . P.readInt) <$> getNext k

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


Leo Jr. draws pictures in his notebook with checkered sheets (that is, each sheet has a regular square grid printed on it). We can assume that the sheets are infinitely large in any direction.To draw a picture, Leo Jr. colors some of the cells on a sheet gray. He considers the resulting picture beautiful if the following conditions are satisfied: The picture is connected, that is, it is possible to get from any gray cell to any other by following a chain of gray cells, with each pair of adjacent cells in the path being neighbours (that is, sharing a side). Each gray cell has an even number of gray neighbours. There are exactly $$$n$$$ gray cells with all gray neighbours. The number of other gray cells can be arbitrary (but reasonable, so that they can all be listed).Leo Jr. is now struggling to draw a beautiful picture with a particular choice of $$$n$$$. Help him, and provide any example of a beautiful picture.To output cell coordinates in your answer, assume that the sheet is provided with a Cartesian coordinate system such that one of the cells is chosen to be the origin $$$(0, 0)$$$, axes $$$0x$$$ and $$$0y$$$ are orthogonal and parallel to grid lines, and a unit step along any axis in any direction takes you to a neighbouring cell.

The only line contains a single integer $$$n$$$ ($$$1 \leq n \leq 500$$$) — the number of gray cells with all gray neighbours in a beautiful picture.

In the first line, print a single integer $$$k$$$ — the number of gray cells in your picture. For technical reasons, $$$k$$$ should not exceed $$$5 \cdot 10^5$$$. Each of the following $$$k$$$ lines should contain two integers — coordinates of a gray cell in your picture. All listed cells should be distinct, and the picture should satisdfy all the properties listed above. All coordinates should not exceed $$$10^9$$$ by absolute value. One can show that there exists an answer satisfying all requirements with a small enough $$$k$$$.

NoteThe answer for the sample is pictured below:

import Control.Monad
main :: IO ()
main = do
  n <- readLn
  print (4+3*n)
  forM_ (solve n) (putStrLn.unwords.map show)

f :: Int -> [[Int]]
f n = [[n,n],[n-1,n],[n,n-1]]

solve :: Int -> [[Int]]
solve n = [0,0]: concatMap f [1..n+1]

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}

import Data.List
import Data.Tuple

_split acc "" [] = reverse acc
_split acc curr [] = reverse $ reverse curr : acc
_split acc curr (ch:rest)
  | (any (== ch) [' ', '\n']) = _split (reverse curr : acc) "" rest
  | otherwise = _split acc (ch:curr) rest

split = _split [] ""

(|>) = flip ($)

main = do
  input <- getLine
  let n = read input :: Int
      func i = [(i, i), (i, i-1), (i-1, i)]
      res = ([(0, 0)] : (func <$> [1..n+1])) >>= id
  putStrLn $ show $ length res
  sequence_ $ putStrLn <$> (\(a, b) -> show a ++ " " ++ show b) <$> res


The Department of economic development of IT City created a model of city development till year 2100.To prepare report about growth perspectives it is required to get growth estimates from the model.To get the growth estimates it is required to solve a quadratic equation. Since the Department of economic development of IT City creates realistic models only, that quadratic equation has a solution, moreover there are exactly two different real roots.The greater of these roots corresponds to the optimistic scenario, the smaller one corresponds to the pessimistic one. Help to get these estimates, first the optimistic, then the pessimistic one.

The only line of the input contains three integers a, b, c ( - 1000 ≤ a, b, c ≤ 1000) — the coefficients of ax2 + bx + c = 0 equation.

In the first line output the greater of the equation roots, in the second line output the smaller one. Absolute or relative error should not be greater than 10 - 6.

module Main where

main :: IO ()
main = getLine >>= \x -> f . map read . words $ x
  where f a = let solv = g (a !! 0) (a !! 1) (a !! 2) in (putStrLn.show.fst$solv) >> (putStrLn.show.snd$solv)
        g a b c = let delta = b ^ 2 - 4 * a * c in ((-b + (sgn a) * sqrt delta) / 2 / a, (-b - (sgn a) * sqrt delta) / 2 / a)
        sgn x | x < 0 = -1 | x > 0 = 1 | otherwise = 0

module Main where

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

--main--
main::IO()
main = do
        line <- readInts
        let a = line !! 0
        let b = line !! 1
        let c = line !! 2
        let delta = b ^ 2 - 4*a*c
        let x_1 = (fromIntegral(-b) - sqrt(fromIntegral delta))/ fromIntegral(2*a)
        let x_2 = (fromIntegral(-b) + sqrt(fromIntegral delta))/ fromIntegral(2*a)

        if x_1 > x_2
	   then do print x_1;
	           print x_2;
           else do print x_2;
                   print x_1

import Control.Monad
import Numeric

main = do
    [a,b,c] <- liftM (map read . words) (getLine) :: IO [Double]
    let d = sqrt $ b*b - 4*a*c
    let x1 = (-b+d)/(2*a)
    let x2 = (-b-d)/(2*a)
    putStrLn $ formatFloatN 15 $ max x1 x2
    putStrLn $ formatFloatN 15 $ min x1 x2
formatFloatN numOfDecimals floatNum= showFFloat (Just numOfDecimals) floatNum ""

import Control.Applicative
import Data.Char

main= do
	[a,b,c]<- map read.words <$>     getLine ::IO [Int]
	let p1 = (sqrt (fromIntegral (b*b-4*a*c))) / 2.0 / (fromIntegral a)
	let p2= (-(fromIntegral b))/2.0 / (fromIntegral a)
	let r1= p2-p1
	let r2= p2+p1
	print $ max r1 r2
	print $ min r1 r2

main :: IO ()
main = solve . parse =<< getContents

parse :: String -> (Double, Double, Double)
parse line = (a, b, c) where [a, b, c] = map read . words $ line

solve :: (Double, Double, Double) -> IO ()
solve (a, b, c)
    | a < 0 = solve (-a, -b, -c)
    | otherwise = do { let delta = sqrt $ b * b - 4 * a * c
                     ; print $ (-b + delta) / (2 * a)
                     ; print $ (-b - delta) / (2 * a)
                     }

module Main where

main :: IO ()
main = getLine >>= \x -> f . map read . words $ x
  where f a = let solv = g (a !! 0) (a !! 1) (a !! 2) in (putStrLn.show.fst$solv) >> (putStrLn.show.snd$solv)
        g a b c = let delta = b ^ 2 - 4 * a * c in ((-b + sqrt delta) / 2 / a, (-b - sqrt delta) / 2 / a)

module Main where

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

--main--
main::IO()
main = do
        line <- readInts
        let a = line !! 0
        let b = line !! 1
        let c = line !! 2
        let delta = b ^ 2 - 4*a*c
        let x_1 = (fromIntegral(b) + sqrt(fromIntegral delta))/ fromIntegral(2*a)
        let x_2 = (fromIntegral(-b) + sqrt(fromIntegral delta))/ fromIntegral(2*a)
        print x_1
        print x_2

module Main where

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

--main--
main::IO()
main = do
        line <- readInts
        if length(line) < 3 && length(line) >= 4
             then putStr "3 parameters please, a, b and c \n"
             else putStr "correct input \n";
                  putStr "well \n"
        let a = line !! 0
        let b = line !! 1
        let c = line !! 2
        let delta = b ^ 2 - 4*a*c
        if delta >= 0
             then putStr "real roots! \n"
             else putStr "bad input, complex roots \n"
        let x_1 = (fromIntegral(b) + sqrt(fromIntegral delta))/ fromIntegral(2*a)
        let x_2 = (fromIntegral(-b) + sqrt(fromIntegral delta))/ fromIntegral(2*a)
        print x_1
        print x_2

import Control.Monad
main = do
    [a,b,c] <- liftM (map read . words) (getLine) :: IO [Double]
    let d = sqrt $ b*b - 4*a*c
    putStrLn $ show $ (-b+d)/(2*a)
    putStrLn $ show $ (-b-d)/(2*a)

main :: IO ()
main = solve . parse =<< getContents

parse :: String -> (Double, Double, Double)
parse line = (a, b, c) where [a, b, c] = map read . words $ line

solve :: (Double, Double, Double) -> IO ()
solve (a, b, c)
    | a < 0 = solve (-a, -b, -c)
    | otherwise = do { let delta = sqrt $ b * b - 4 * a * c
                     ; print $ (-b - delta) / (2 * a)
                     ; print $ (-b + delta) / (2 * a)
                     }


A rectangle with sides $$$A$$$ and $$$B$$$ is cut into rectangles with cuts parallel to its sides. For example, if $$$p$$$ horizontal and $$$q$$$ vertical cuts were made, $$$(p + 1) \cdot (q + 1)$$$ rectangles were left after the cutting. After the cutting, rectangles were of $$$n$$$ different types. Two rectangles are different if at least one side of one rectangle isn't equal to the corresponding side of the other. Note that the rectangle can't be rotated, this means that rectangles $$$a \times b$$$ and $$$b \times a$$$ are considered different if $$$a \neq b$$$.For each type of rectangles, lengths of the sides of rectangles are given along with the amount of the rectangles of this type that were left after cutting the initial rectangle.Calculate the amount of pairs $$$(A; B)$$$ such as the given rectangles could be created by cutting the rectangle with sides of lengths $$$A$$$ and $$$B$$$. Note that pairs $$$(A; B)$$$ and $$$(B; A)$$$ are considered different when $$$A \neq B$$$.

The first line consists of a single integer $$$n$$$ ($$$1 \leq n \leq 2 \cdot 10^{5}$$$) — amount of different types of rectangles left after cutting the initial rectangle. The next $$$n$$$ lines each consist of three integers $$$w_{i}, h_{i}, c_{i}$$$ $$$(1 \leq w_{i}, h_{i}, c_{i} \leq 10^{12})$$$ — the lengths of the sides of the rectangles of this type and the amount of the rectangles of this type. It is guaranteed that the rectangles of the different types are different.

Output one integer — the answer to the problem.

NoteIn the first sample there are three suitable pairs: $$$(1; 9)$$$, $$$(3; 3)$$$ and $$$(9; 1)$$$.In the second sample case there are 6 suitable pairs: $$$(2; 220)$$$, $$$(4; 110)$$$, $$$(8; 55)$$$, $$$(10; 44)$$$, $$$(20; 22)$$$ and $$$(40; 11)$$$.Here the sample of cut for $$$(20; 22)$$$.  The third sample has no suitable pairs.

import Data.Int
import Data.Char
import Data.List
import Data.List.Split
import qualified Data.ByteString.Char8 as C

fst' :: (a, b, c) -> a
fst' (x,_,_) = x

snd' :: (a, b, c) -> b
snd' (_,x,_) = x

trd' :: (a, b, c) -> c
trd' (_,_,x) = x

f2read' :: Int64 -> Char -> Int64
f2read' x y = 10 * x + fromIntegral(ord y - ord '0')

f2read :: C.ByteString -> Int64
f2read x = C.foldl' f2read' 0 x

f2show :: Int64 -> C.ByteString
f2show x = C.reverse $ C.cons '\n' $ fst $ C.unfoldrN 20 (\x -> if x /= 0 then Just (chr $ ((fromIntegral (rem x 10)) :: Int) + ord '0', div x 10) else Nothing) x

f2lines :: C.ByteString -> [C.ByteString]
f2lines x = map (\x -> if (C.last x == '\r') then (C.init x) else x) (C.lines x)

tuple3 :: [a] -> (a, a, a)
tuple3 [x, y, z] = (x, y, z)

readP :: [C.ByteString] -> [(Int64, Int64, Int64)]
readP [] = []
readP (x:xs) = (tuple3 $ map f2read $ C.words x) : (readP xs)

allEq :: (Eq a) => [a] -> Bool
allEq ls = and $ map (== (head ls)) ls

divByGCD :: [Int64] -> [Int64]
divByGCD ls = map (`div` g) ls where g = foldl1' (gcd) ls

divisors :: Int64 -> Int64
divisors n = foldl1' (+) $ map (\x -> if x * x == n then 1 else 2) $ filter (\x -> rem n x == 0) $ takeWhile(\x -> x * x <= n) [1..]

solve' :: [[Int64]] -> Int64
solve' ls = if allEq (map divByGCD ls) then divisors (foldl1' (gcd) (map (foldl1' gcd) ls)) else 0

solve :: [(Int64, Int64, Int64)] -> Int64
solve p =
  let n = length p
      sp = sort p
      m = length $ takeWhile (\x -> (fst' $ head sp) == (fst' x)) sp
      csp = chunksOf m sp
  in if (rem n m == 0) && (allEq $ map (map snd') csp) then solve' (map (map trd') csp) else 0

main :: IO ()
main = do dat <- C.getContents
          print $ solve $ readP $ tail $ f2lines dat

import Data.Int
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as C

fst' :: (a, b, c) -> a
fst' (x,_,_) = x

snd' :: (a, b, c) -> b
snd' (_,x,_) = x

trd' :: (a, b, c) -> c
trd' (_,_,x) = x

f2read' :: Int64 -> Char -> Int64
f2read' x y = 10 * x + fromIntegral(ord y - ord '0')

f2read :: C.ByteString -> Int64
f2read x = C.foldl' f2read' 0 x

f2show :: Int64 -> C.ByteString
f2show x = C.reverse $ C.cons '\n' $ fst $ C.unfoldrN 20 (\x -> if x /= 0 then Just (chr $ ((fromIntegral (rem x 10)) :: Int) + ord '0', div x 10) else Nothing) x

f2lines :: C.ByteString -> [C.ByteString]
f2lines x = map (\x -> if (C.last x == '\r') then (C.init x) else x) (C.lines x)

tuple3 :: [a] -> (a, a, a)
tuple3 [x, y, z] = (x, y, z)

readP :: [C.ByteString] -> [(Int64, Int64, Int64)]
readP [] = []
readP (x:xs) = (tuple3 $ map f2read $ C.words x) : (readP xs)

allEq :: (Eq a) => [a] -> Bool
allEq ls = and $ map (== (head ls)) ls

divByGCD :: [Int64] -> [Int64]
divByGCD ls = map (`div` g) ls where g = foldl1' (gcd) ls

divisors :: Int64 -> Int64
divisors n = foldl1' (+) $ map (\x -> if x * x == n then 1 else 2) $ filter (\x -> rem n x == 0) $ takeWhile(\x -> x * x <= n) [1..]

solve' :: [[Int64]] -> Int64
solve' ls = if allEq (map divByGCD ls) then divisors (foldl1' (gcd) (map (foldl1' gcd) ls)) else 0

build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
build g = g (:) []

chunksOf :: Int -> [e] -> [[e]]
chunksOf i ls = map (take i) (build (splitter ls)) where
  splitter :: [e] -> ([e] -> a -> a) -> a -> a
  splitter [] _ n = n
  splitter l c n  = l `c` splitter (drop i l) c n

solve :: [(Int64, Int64, Int64)] -> Int64
solve p =
  let n = length p
      sp = sort p
      m = length $ takeWhile (\x -> (fst' $ head sp) == (fst' x)) sp
      csp = chunksOf m sp
  in if (rem n m == 0) && (allEq $ map (map snd') csp) then solve' (map (map trd') csp) else 0

main :: IO ()
main = do dat <- C.getContents
          print $ solve $ readP $ tail $ f2lines dat


You are given $$$n$$$ chips on a number line. The $$$i$$$-th chip is placed at the integer coordinate $$$x_i$$$. Some chips can have equal coordinates.You can perform each of the two following types of moves any (possibly, zero) number of times on any chip:  Move the chip $$$i$$$ by $$$2$$$ to the left or $$$2$$$ to the right for free (i.e. replace the current coordinate $$$x_i$$$ with $$$x_i - 2$$$ or with $$$x_i + 2$$$);  move the chip $$$i$$$ by $$$1$$$ to the left or $$$1$$$ to the right and pay one coin for this move (i.e. replace the current coordinate $$$x_i$$$ with $$$x_i - 1$$$ or with $$$x_i + 1$$$). Note that it's allowed to move chips to any integer coordinate, including negative and zero.Your task is to find the minimum total number of coins required to move all $$$n$$$ chips to the same coordinate (i.e. all $$$x_i$$$ should be equal after some sequence of moves).

The first line of the input contains one integer $$$n$$$ ($$$1 \le n \le 100$$$) — the number of chips. The second line of the input contains $$$n$$$ integers $$$x_1, x_2, \dots, x_n$$$ ($$$1 \le x_i \le 10^9$$$), where $$$x_i$$$ is the coordinate of the $$$i$$$-th chip.

Print one integer — the minimum total number of coins required to move all $$$n$$$ chips to the same coordinate.

NoteIn the first example you need to move the first chip by $$$2$$$ to the right and the second chip by $$$1$$$ to the right or move the third chip by $$$2$$$ to the left and the second chip by $$$1$$$ to the left so the answer is $$$1$$$.In the second example you need to move two chips with coordinate $$$3$$$ by $$$1$$$ to the left so the answer is $$$2$$$.

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

process a  = (min ao ae)
	where ae = length $ filter (even) a
	      ao = (length a)-ae

main::IO ()
main=do
  t<- read<$> getLine ::IO Int
  a<-  map read <$> words <$> getLine::IO [Integer]
  print $ process a

import Data.List (partition)

process :: [Int] -> Int
process xs = min (length es) (length os)
    where
        (es,os) = partition odd xs

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    n <- fmap readInt getLine
    xs <- fmap (map readInt.words) getLine
    print $ process xs

module Main where

toOnePoint :: [Int] -> Int -> Int
toOnePoint t point = sum (map (\x -> abs (point - x) `mod` 2) t)

main :: IO ()
main = do
  f <- getLine
  let n = read f :: Int
  list <- fmap (\i -> read i :: Int) . words <$> getLine
  print $ minimum (map (toOnePoint list) list)

(...) = (.).(.)
countIf = length...filter
solve = min <$> countIf even <*> countIf odd
main = print . solve . map read . words . last . lines =<< getContents

solve xs = min (length . filter even $ xs) (length . filter odd $ xs)

main = interact $ show . solve . map read . words . last . lines

main :: IO ()
main = do
  n <- read <$> getLine :: IO Int
  xs <- map read . words <$> getLine :: IO [Int]
  print $ min (countOdd xs) (countEven xs)
  where
    countEven xs = length $ filter (\x -> mod x 2 == 0) xs
    countOdd xs = length (filter (\x -> mod x 2 == 1) xs)

getD::Int->Int->Int
getD m z=(max m z) - (min m z)

getOst::Int->Int->Int
getOst to p=mod (getD to p) 2

getOstL::Int->[Int]->Int
getOstL n lst=sum $ map (getOst n) lst

getMinL::[Int]->Int
getMinL lst=minimum $ map (flip getOstL lst) lst

main::IO()
main=do
   n <- getLine
   m <- getLine
   let lst = map read $ words m
   print $ getMinL lst
--ss

import Control.Monad ( void )

main = do
  void getLine
  arr <- fmap (fmap read . words) getLine
  let count = (length . ) . filter
      oddCount = count odd arr
      evenCount = count even arr
  print $ min evenCount oddCount

main = do
  n <- readLn
  arr <- fmap (fmap read . words) getLine
  let count = (length . ) . filter
      oddCount = count odd arr
      evenCount = n - oddCount
  print $ min evenCount oddCount

import Data.List (sort, partition)

process :: [Int] -> Int
process xs = d * min (length es) (length os)
    where
        (es,os) = partition odd xs
        xs' = sort xs
        ds = filter odd $ zipWith (-) (tail xs') xs'
        d = if null ds then 0 else minimum ds

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    n <- fmap readInt getLine
    xs <- fmap (map readInt.words) getLine
    print $ process xs

import Data.List (nub, partition)

process :: [Int] -> Int
process xs = minimum ds * min (length es) (length os)
    where
        (es,os) = partition odd xs
        xs' = nub xs
        ds = zipWith (-) (tail xs') xs'

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    n <- fmap readInt getLine
    xs <- fmap (map readInt.words) getLine
    print $ process xs

main :: IO ()
main = do
  n <- read <$> getLine :: IO Int
  xs <- map read . words <$> getLine :: IO [Int]
  print $ max (countOdd xs) (countEven xs)
  where
    countEven xs = length $ filter (\x -> mod x 2 == 0) xs
    countOdd xs = length (filter (\x -> mod x 2 == 1) xs)


This problem is an extension of the problem "Wonderful Coloring - 1". It has quite many differences, so you should read this statement completely.Recently, Paul and Mary have found a new favorite sequence of integers $$$a_1, a_2, \dots, a_n$$$. They want to paint it using pieces of chalk of $$$k$$$ colors. The coloring of a sequence is called wonderful if the following conditions are met:  each element of the sequence is either painted in one of $$$k$$$ colors or isn't painted;  each two elements which are painted in the same color are different (i. e. there's no two equal values painted in the same color);  let's calculate for each of $$$k$$$ colors the number of elements painted in the color — all calculated numbers must be equal;  the total number of painted elements of the sequence is the maximum among all colorings of the sequence which meet the first three conditions. E. g. consider a sequence $$$a=[3, 1, 1, 1, 1, 10, 3, 10, 10, 2]$$$ and $$$k=3$$$. One of the wonderful colorings of the sequence is shown in the figure.    The example of a wonderful coloring of the sequence $$$a=[3, 1, 1, 1, 1, 10, 3, 10, 10, 2]$$$ and $$$k=3$$$. Note that one of the elements isn't painted. Help Paul and Mary to find a wonderful coloring of a given sequence $$$a$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10000$$$) — the number of test cases. Then $$$t$$$ test cases follow. Each test case consists of two lines. The first one contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 2\cdot10^5$$$, $$$1 \le k \le n$$$) — the length of a given sequence and the number of colors, respectively. The second one contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le n$$$). It is guaranteed that the sum of $$$n$$$ over all test cases doesn't exceed $$$2 \cdot 10^5$$$.

Output $$$t$$$ lines, each of them must contain a description of a wonderful coloring for the corresponding test case. Each wonderful coloring must be printed as a sequence of $$$n$$$ integers $$$c_1, c_2, \dots, c_n$$$ ($$$0 \le c_i \le k$$$) separated by spaces where   $$$c_i=0$$$, if $$$i$$$-th element isn't painted;  $$$c_i>0$$$, if $$$i$$$-th element is painted in the $$$c_i$$$-th color.  Remember that you need to maximize the total count of painted elements for the wonderful coloring. If there are multiple solutions, print any one.

NoteIn the first test case, the answer is shown in the figure in the statement. The red color has number $$$1$$$, the blue color — $$$2$$$, the green — $$$3$$$.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE BangPatterns #-}

import Control.Monad (forM_)
import qualified Data.Array.Unboxed as A
import Data.Foldable (foldl')
import Data.IntMap (IntMap)
import qualified Data.IntMap as M
import qualified Data.Text as T
import qualified Data.Text.IO as T

indexed :: [a] -> [(Int, a)]
indexed = zip [0 ..]

-- | Take a sequence of elements and convert into frequency mapping
collect :: [Int] -> IntMap [Int]
collect xs = foldl' ins_ M.empty $ indexed xs
  where
    ins_ m (i, n) = M.alter (Just . maybe [i] (i :)) n m

-- | Take off elements from a list so that length is multiple of k
shave :: Int -> [a] -> [a]
shave k xs = drop (l `mod` k) xs
  where
    l = length xs

-- | Perform coloring
coloring :: Int -> [Int] -> [Int]
coloring k xs = A.elems $ empty (length xs) A.// ind
  where
    m = collect xs
    (ltk, gtk) = M.partition (\v -> length v < k) m

    indLtk = zip (shave k $ concat $ M.elems ltk) (cycle [1 .. k])
    indGtk = (`zip` [1 .. k]) . take k =<< M.elems gtk
    ind = indLtk ++ indGtk

    empty :: Int -> A.UArray Int Int
    empty n = A.array (0, n - 1) (take n $ indexed $ repeat 0)

main :: IO ()
main = do
  testCases <- read <$> getLine
  forM_ [1 .. testCases] $ \_ -> do
    l1 <- T.getLine
    l2 <- T.getLine
    let [_, k] = read . T.unpack <$> T.splitOn " " l1
    let xs = read . T.unpack <$> T.splitOn " " l2
    putStrLn $ unwords $ show <$> coloring k xs

import Control.Monad (replicateM_)
import Data.List ((\\), foldl')
import qualified Data.Array.Unboxed as A
import qualified Data.IntMap as M

getIndices :: Int -> [Int] -> (M.IntMap [Int], [Int])
getIndices cap xs = (M.map snd withSizes, remaining) where
  insert (k, idx) (mp, remaining) = case M.lookup k mp of
    Just (size, idxs) -> if size + 1 <= cap
      then (M.insert k (size + 1, idx : idxs) mp, remaining)
      else (M.insert k (size, idxs) mp, idx : remaining)
    Nothing   -> (M.insert k (1, [idx]) mp, remaining)
  (withSizes, remaining) = foldr insert (M.empty, []) $ zip xs [1..]

solve :: (Int, Int) -> [Int] -> M.IntMap Int
solve (n, k) xs = M.fromList (ans ++ [(i, 0) | i <- remaining]) where
  (indexMap, remaining) = getIndices k xs
  indices = M.toList indexMap >>= snd
  l = n - length remaining
  nextColor color = if color + 1 <= k then color + 1 else 1
  next (color, coloring, remaining) idx = let c = nextColor color in
    if remaining > 0 then (c, (idx, c) : coloring, remaining - 1)
    else (0, (idx, 0) : coloring, remaining)
  (_, ans, _) = foldl' next (0, [], l - l `rem` k) indices

readInts :: IO [Int]
readInts = map read . words <$> getLine

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
    [n, k] <- readInts
    ans <- map show . M.elems . solve (n, k) <$> readInts
    putStrLn $ unwords ans

{-# LANGUAGE TupleSections #-}
import Data.List (intercalate, sort, group, groupBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

type Color = Int
type Letter = Int
type AssignmentLC = Map Letter [Color]
type AssignmentCL = Map Color [Letter]
type Input = (Int, Int, [Int])
type Output = [Int]

type Queue a = ([a], [a])

queueToList :: Queue a -> [a]
queueToList (fstQ, sndQ) = fstQ ++ reverse sndQ

queueFromList :: [a] -> Queue a
queueFromList ls = (ls, [])

queueFix :: Queue a -> Queue a
queueFix (fstQ, sndQ) = if null fstQ then (reverse sndQ, []) else (fstQ, sndQ)

queuePush :: Queue a -> a -> Queue a
queuePush q0 x = (fst q1, x : snd q1) where
    q1 = queueFix q0

queuePop :: Queue a -> Queue a
queuePop q0 = (tail $ fst q1, snd q1) where
    q1 = queueFix q0

queueFront :: Queue a -> a
queueFront = head . fst . queueFix

queueSize :: Queue a -> Int
queueSize (fstQ, sndQ) = length fstQ + length sndQ

queueNull :: Queue a -> Bool
queueNull (fstQ, sndQ) = null fstQ && null sndQ

parseOut :: [Output] -> String
parseOut []     = ""
parseOut (o:os) = unwords (map show o) ++ "\n" ++ parseOut os

parseIn :: String -> [Input]
parseIn str = let
    inLines = tail $ lines str
    res [] = []
    res [x] = undefined
    res (nk:s:rest) = (n, k, l) : res rest where
        (n, k) = (read . (!!0) $ words nk, read . (!!1) $ words nk)
        l = map (read :: String -> Int) $ words s
    in res inLines

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

invert :: (Ord k, Ord b) => Map k [b] -> Map b [k]
invert mp = Map.fromList
          $ map (\l -> (fst $ head l, map snd l))
          $ groupBy (\x y -> fst x == fst y)
          $ sort
          $ Map.toList mp >>= (\(k, vs) -> map (, k) vs)

solve :: Input -> Output
solve (n, k, l) = res where
    freq = map (\g -> (head g, length g)) $ group $ sort l
    cl0 = Map.fromList
        $ queueToList
        $ foldr append initQueue freq where
            initQueue = queueFromList $ zip [1..k] (repeat [])
            append :: (Int, Int) -> Queue (Color, [Letter]) -> Queue (Color, [Letter])
            append (ch, frq) q = nTimes (min k frq) f q where
                f q = let (col, ls) = queueFront q
                          newAssign = (col, ch:ls)
                          in queuePop $ queuePush q newAssign

    assignLength = foldr (min . length) n cl0
    cl1 = Map.map (take assignLength) cl0
    lc = invert cl1

    res = snd $ foldr f (lc, []) l where
        f :: Letter -> (AssignmentLC, [Color]) -> (AssignmentLC, [Color])
        f ch (as, l) = case Map.lookup ch as of Nothing   -> (as, 0:l)
                                                Just []   -> (as, 0:l)
                                                Just cols -> (Map.adjust tail ch as, head cols : l)

main :: IO ()
main = interact $ parseOut . map solve . parseIn
--main = interact (intercalate "\n------\n" . map solve . parseIn)

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

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -Weverything                     #-}

{-# options_ghc -Wno-safe                        #-}     -- no warning if inferred as safe
{-# options_ghc -Wno-all-missed-specialisations  #-}     -- "Could not specialise..." when -O1
{-# options_ghc -Wno-missing-import-lists        #-}
{-# options_ghc -Wno-missing-local-signatures    #-}

-- (ghc -Werror -Wno-error=unsafe -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out)

-- (ghc -Werror -Wno-error=unsafe -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  printf '%s\n' 1 '12 3' '3 1 1 1 1 10 3 10 10 2 8 7' | ./a.out)
-- 2 1 2 3 0 3 3 0 0 1 2 1

import Prelude
import Control.Monad
import Data.List
import Data.Function

main :: IO ()
main = do
    t <- readLn
    tcs <- replicateM t readTC

    (putStr . unlines . map solve) tcs

readTC = do
    [_n, k] <- getInts
    nums   <- getInts

    return (k, nums)

solve (k, xs) = intercalate " " . map show $ answer
  where
    grouped = groupOn fst . sort . (`zip` [1000::Int ..]) $ xs
    answer = solveColored k . solveUncolored k $ grouped

solveUncolored k gs = (map (addColor col0) . concat $ ts,
                        concat hs)
  where
    (hs, ts) = unzip . map (splitAt k) $ gs

solveColored k (ps, xs) = map getColor . sortOn getPos $ coloring
  where
    coloring = ps ++ map (addColor col0) ts ++ zipWith addColor cols hs

    wdt = length xs `div` k
    (hs, ts) = splitAt (k*wdt) xs
    cols = (concat.repeat) [col0+1..col0+k]

addColor c (v,i) = (v, i, c::Int)
getPos (_v, i, _c) = i
-- getVal (v, _i, _c) = v
getColor (_v, _i, c) = c

col0 = 0::Int

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

getInts = map read <$> words <$> getLine :: IO [Int]

groupOn f = groupBy ((==) `on` f)

import Control.Arrow ((>>>))
import Data.List (group, sort, groupBy, sortBy)
import Data.Ord (comparing)
import Data.Bifunctor (bimap)
import Debug.Trace (trace)

main :: IO ()
main =
  interact $
    lines
      >>> drop 1
      >>> chunksOf 2
      >>> map (map words >>> concat >>> map read >>> solve >>> map show >>> unwords)
      >>> unlines

type Col = (Int, Maybe Int)

debug a = trace (show a) a

solve :: [Int] -> [Int]
solve (n : k : as) =
  map (maybe 0 ((1 +) . (`mod` k)) . snd)
    . sortOn fst
    . uncurry (++)
    . bimap (`zip` (Just <$> [1..])) (`zip` repeat Nothing)
    . (\(cs, ws) -> let (ws', cs') = splitAt (length cs `mod` k) cs in (cs', ws' ++ ws))
    . bimap' concat
    . unzip
    . map (splitAt k . map snd)
    . groupOn fst
    . sortOn fst
    $ as `zip` [0 ..]

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

groupOn :: (Eq b) => (a -> b) -> [a] -> [[a]]
groupOn p = groupBy (\x y -> p x == p y)

sortOn :: (Ord b) => (a -> b) -> [a] -> [a]
sortOn = sortBy . comparing

bimap' f = bimap f f

{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Prelude as P

import Data.Word (Word8)
import Data.Int (Int64)
import qualified Data.Bits as Bits
import qualified Data.Char as Char

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

import qualified Data.ByteString as Bs
import qualified System.IO as Io
--import Data.IntSet

color _ _ _ _ _ [] = []
color k col e ecnt total (x:xs)
  | total == 0 = (fst x, 0) : color k 0 0 0 0 xs
  | e == snd x = if ecnt >= k then (fst x, 0) : color k col e ecnt total xs else
                   (fst x, col) : color k next_col e (ecnt+1) (total-1) xs
  | otherwise = (fst x, col) : color k next_col (snd x) 1 (total-1) xs
  where next_col = if col == k then 1 else col+1

solve :: IO ()
solve = do
  [n,k] <- readInts :: IO [Int]
  a <- readInts :: IO [Int]
  let b = sortBy (\x y -> compare (snd x) (snd y)) $ zip [0..] a
      grp = groupBy (\x y -> snd x == snd y) b
      tot = foldl (\acc xs -> acc + min (length xs) k) 0 grp
      total = tot - (rem tot k)
      res = map snd $ sortBy (\x y -> compare (fst x) (fst y)) $ color k 1 0 0 total b
   in putStrLn $ intercalate " " $ map show res

main = do
  t <- readLn :: IO Int
  replicateM_ t $ solve

----------------------------------------------------------------------------------------
readrows :: (Integral a, Integral b) => b -> IO [[a]]
readrows 0 = return []
readrows n = do
  row <- readInts
  l <- readrows $ n-1
  return (row : l)

parseInt :: (Integral a) => Bs.ByteString -> a
parseInt xs = snd $ Bs.foldr (\y (pow, acc) -> (pow*10, acc + pow*(fromIntegral (y-48)))) (1, 0) xs

readInts :: (Integral a) => IO [a]
readInts =  map parseInt . filter (/=Bs.empty) . Bs.splitWith (==32) . fuckingWindowsCRLF <$> Bs.getLine
  where fuckingWindowsCRLF bs = if Bs.last bs == 13 then Bs.init bs else bs

import Control.Monad (replicateM_)
import Data.List ((\\), foldl')
import qualified Data.Array.Unboxed as A
import qualified Data.IntMap as M
import qualified Data.IntSet as S

type IntArray = A.UArray Int Int

getIndices :: Int -> [Int] -> M.IntMap [Int]
getIndices cap xs = M.map snd withSizes where
  insert (k, idx) mp = case M.lookup k mp of
    Just (size, idxs) -> if size + 1 <= cap
      then M.insert k (size + 1, idx : idxs) mp
      else M.insert k (size, idxs) mp
    Nothing   -> M.insert k (1, [idx]) mp
  withSizes = foldr insert M.empty $ zip xs [1..]

solve :: (Int, Int) -> [Int] -> IntArray
solve (n, k) xs = A.array (1,n) (ans ++ [(i, 0) | i <- missing]) where
  indices = M.toList (getIndices k xs) >>= snd
  indexSet = S.fromList indices
  l = S.size indexSet
  nextColor color = if color + 1 <= k then color + 1 else 1
  next (color, coloring, remaining) idx = let c = nextColor color in
    if remaining > 0 then (c, (idx, c) : coloring, remaining - 1)
    else (0, (idx, 0) : coloring, remaining)
  (_, ans, _) = S.foldl' next (0, [], l - l `rem` k) indexSet
  missing = S.toList $ S.difference (S.fromList [1..n]) indexSet

readInts :: IO [Int]
readInts = map read . words <$> getLine

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
    [n, k] <- readInts
    ans <- map show . A.elems . solve (n, k) <$> readInts
    putStrLn $ unwords ans

{-# LANGUAGE TupleSections #-}
import Data.List (intercalate, sort, group, groupBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

type Color = Int
type Letter = Int
type AssignmentLC = Map Letter [Color]
type AssignmentCL = Map Color [Letter]
type Input = (Int, Int, [Int])
type Output = [Int]

type Queue a = ([a], [a])

queueToList :: Queue a -> [a]
queueToList (fstQ, sndQ) = fstQ ++ reverse sndQ

queueFromList :: [a] -> Queue a
queueFromList ls = (ls, [])

queueFix :: Queue a -> Queue a
queueFix (fstQ, sndQ) = if null fstQ then (reverse sndQ, []) else (fstQ, sndQ)

queuePush :: Queue a -> a -> Queue a
queuePush q0 x = (fst q1, x : snd q1) where
    q1 = queueFix q0

queuePop :: Queue a -> Queue a
queuePop q0 = (tail $ fst q1, snd q1) where
    q1 = queueFix q0

queueFront :: Queue a -> a
queueFront = head . fst . queueFix

queueSize :: Queue a -> Int
queueSize (fstQ, sndQ) = length fstQ + length sndQ

queueNull :: Queue a -> Bool
queueNull (fstQ, sndQ) = null fstQ && null sndQ

parseOut :: [Output] -> String
parseOut []     = ""
parseOut (o:os) = unwords (map show o) ++ "\n" ++ parseOut os

parseIn :: String -> [Input]
parseIn str = let
    inLines = tail $ lines str
    res [] = []
    res [x] = undefined
    res (nk:s:rest) = (n, k, l) : res rest where
        (n, k) = (read . (!!0) $ words nk, read . (!!1) $ words nk)
        l = map (read :: String -> Int) $ words s
    in res inLines

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

invert :: (Ord k, Ord b) => Map k [b] -> Map b [k]
invert mp = Map.fromList
          $ map (\l -> (fst $ head l, map snd l))
          $ groupBy (\x y -> fst x == fst y)
          $ sort
          $ Map.toList mp >>= (\(k, vs) -> map (, k) vs)

solve :: Input -> Output
solve (n, k, l) = res where
    freq = map (\g -> (head g, length g)) $ group $ sort l
    cl = Map.fromList
       $ queueToList
       $ foldr append initQueue freq where
        initQueue = queueFromList $ zip [1..k] (repeat [])
        append :: (Int, Int) -> Queue (Color, [Letter]) -> Queue (Color, [Letter])
        append (ch, frq) q = nTimes (min k frq) f q where
            f q = let (col, ls) = queueFront q
                      newAssign = (col, ch:ls)
                      in queuePop $ queuePush q newAssign

    lc0 = invert cl
    assignLength = foldr (min . length) n lc0
    lc1 = Map.map (take assignLength) lc0

    res = snd $ foldr f (lc1, []) l where
        f :: Letter -> (AssignmentLC, [Color]) -> (AssignmentLC, [Color])
        f ch (as, l) = case Map.lookup ch as of Nothing   -> (as, 0:l)
                                                Just []   -> (as, 0:l)
                                                Just cols -> (Map.adjust tail ch as, head cols : l)

main :: IO ()
main = interact $ parseOut . map solve . parseIn
--main = interact (intercalate "\n------\n" . map solve . parseIn)

import Data.List (intersperse, intercalate, sort, group)

parseOut :: [Int] -> String
parseOut = intercalate "\n" . map show

parseIn :: String -> [String]
parseIn = tail . words

solve :: String -> Int
solve str = gtOne + div one 2 where
    frequencies = map length $ group $ sort str
    gtOne = length $ filter (>1) frequencies
    one = length $ filter (==1) frequencies

main :: IO ()
main = interact $ parseOut . map solve . parseIn

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

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -Weverything                     #-}

{-# options_ghc -Wno-safe                        #-}     -- no warning if inferred as safe
{-# options_ghc -Wno-all-missed-specialisations  #-}     -- "Could not specialise..." when -O1
{-# options_ghc -Wno-missing-import-lists        #-}
{-# options_ghc -Wno-missing-local-signatures    #-}

-- (ghc -Werror -Wno-error=unsafe -O1 -no-keep-o-files -no-keep-hi-files -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out > tmp.txt  &&  diff -sdu -- output.txt tmp.txt  &&  cat -- tmp.txt)

import Prelude
import Control.Monad
import Data.List
import Data.Function

main :: IO ()
main = do
    t <- readLn
    tcs <- replicateM t readTC

    (putStr . unlines . map solve) tcs

readTC = do
    [_n, k] <- getInts
    nums   <- getInts

    return (k, nums)

getInts = map read <$> words <$> getLine :: IO [Int]

-- solve (k, xs) = show (k, xs, sortGroupOn snd $ indexed, intercalate " " . map show $ answer)
solve (k, xs) = intercalate " " . map show $ answer
  where
    indexed = zip [0..] xs :: [(Int,Int)]

    grouped = fixGroups . sortGroupOn snd $ indexed

    colored = concat . map (addColor k) $ grouped

    getPos ((p,_x), _i) = p

    answer = map snd . sortOn getPos $ colored

fixGroups gs = filter (not.allowJoin) gs ++ [(concat . filter allowJoin) gs]
  where
    allowJoin g = length g == 1

addColor k pairs | (length pairs >= k) = zip pairs ([1..k] ++ [0,0..])
                 | otherwise           = zip pairs [0,0..]

sortGroupOn f = groupBy ((==) `on` f) . sortOn f

import Control.Arrow ((>>>))
import Data.List (group, sort, groupBy, sortBy)
import Data.Ord (comparing)

main :: IO ()
main =
  interact $
    lines
      >>> drop 1
      >>> chunksOf 2
      >>> map (map words >>> concat >>> map read >>> solve >>> map show >>> unwords)
      >>> unlines

type Col = (Int, Maybe Int)

solve :: [Int] -> [Int]
solve (n : k : as) =
  map (maybe 0 ((1 +) . (`mod` k)) . snd)
    . sortOn fst
    . concatMap fst
    . scanr (color . map snd) ([], 0)
    . groupOn fst
    . sortOn fst
    $ as `zip` [0 ..]
  where
    color :: [Int] -> ([Col], Int) -> ([Col], Int)
    color ixs (_, c) =
      let (cixs, wixs) = splitAt k ixs
       in (zip cixs (Just <$> [c ..]) ++ zip wixs (repeat Nothing), c + length cixs)

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

groupOn :: (Eq b) => (a -> b) -> [a] -> [[a]]
groupOn p = groupBy (\x y -> p x == p y)

sortOn :: (Ord b) => (a -> b) -> [a] -> [a]
sortOn = sortBy . comparing

{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Prelude as P

import Data.Word (Word8)
import Data.Int (Int64)
import qualified Data.Bits as Bits
import qualified Data.Char as Char

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

import qualified Data.ByteString as Bs
import qualified System.IO as Io
--import Data.IntSet

color _ _ _ _ _ [] = []
color k col e ecnt total (x:xs)
  | total == 0 = (fst x, 0) : color k 0 0 0 0 xs
  | e == snd x = if ecnt >= k then (fst x, 0) : color k col e ecnt total xs else
                   (fst x, col) : color k next_col e (ecnt+1) (total-1) xs
  | otherwise = (fst x, col) : color k next_col (snd x) 1 (total-1) xs
  where next_col = if col == k then 1 else col+1

solve :: IO ()
solve = do
  [n,k] <- readInts :: IO [Int]
  a <- readInts :: IO [Int]
  let b = sortBy (\x y -> compare (snd x) (snd y)) $ zip [0..] a
      grp = groupBy (\x y -> snd x == snd y) b
      total = foldl (\acc xs -> acc + min (length xs) k) 0 grp
      res = map snd $ sortBy (\x y -> compare (fst x) (fst y)) $ color k 1 0 0 total b
   in putStrLn $ intercalate " " $ map show res

main = do
  t <- readLn :: IO Int
  replicateM_ t $ solve

----------------------------------------------------------------------------------------
readrows :: (Integral a, Integral b) => b -> IO [[a]]
readrows 0 = return []
readrows n = do
  row <- readInts
  l <- readrows $ n-1
  return (row : l)

parseInt :: (Integral a) => Bs.ByteString -> a
parseInt xs = snd $ Bs.foldr (\y (pow, acc) -> (pow*10, acc + pow*(fromIntegral (y-48)))) (1, 0) xs

readInts :: (Integral a) => IO [a]
readInts =  map parseInt . filter (/=Bs.empty) . Bs.splitWith (==32) . fuckingWindowsCRLF <$> Bs.getLine
  where fuckingWindowsCRLF bs = if Bs.last bs == 13 then Bs.init bs else bs


Lunar New Year is approaching, and Bob is planning to go for a famous restaurant — "Alice's".The restaurant "Alice's" serves $$$n$$$ kinds of food. The cost for the $$$i$$$-th kind is always $$$c_i$$$. Initially, the restaurant has enough ingredients for serving exactly $$$a_i$$$ dishes of the $$$i$$$-th kind. In the New Year's Eve, $$$m$$$ customers will visit Alice's one after another and the $$$j$$$-th customer will order $$$d_j$$$ dishes of the $$$t_j$$$-th kind of food. The $$$(i + 1)$$$-st customer will only come after the $$$i$$$-th customer is completely served.Suppose there are $$$r_i$$$ dishes of the $$$i$$$-th kind remaining (initially $$$r_i = a_i$$$). When a customer orders $$$1$$$ dish of the $$$i$$$-th kind, the following principles will be processed. If $$$r_i > 0$$$, the customer will be served exactly $$$1$$$ dish of the $$$i$$$-th kind. The cost for the dish is $$$c_i$$$. Meanwhile, $$$r_i$$$ will be reduced by $$$1$$$. Otherwise, the customer will be served $$$1$$$ dish of the cheapest available kind of food if there are any. If there are multiple cheapest kinds of food, the one with the smallest index among the cheapest will be served. The cost will be the cost for the dish served and the remain for the corresponding dish will be reduced by $$$1$$$. If there are no more dishes at all, the customer will leave angrily. Therefore, no matter how many dishes are served previously, the cost for the customer is $$$0$$$.If the customer doesn't leave after the $$$d_j$$$ dishes are served, the cost for the customer will be the sum of the cost for these $$$d_j$$$ dishes.Please determine the total cost for each of the $$$m$$$ customers.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n, m \leq 10^5$$$), representing the number of different kinds of food and the number of customers, respectively. The second line contains $$$n$$$ positive integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 10^7$$$), where $$$a_i$$$ denotes the initial remain of the $$$i$$$-th kind of dishes. The third line contains $$$n$$$ positive integers $$$c_1, c_2, \ldots, c_n$$$ ($$$1 \leq c_i \leq 10^6$$$), where $$$c_i$$$ denotes the cost of one dish of the $$$i$$$-th kind. The following $$$m$$$ lines describe the orders of the $$$m$$$ customers respectively. The $$$j$$$-th line contains two positive integers $$$t_j$$$ and $$$d_j$$$ ($$$1 \leq t_j \leq n$$$, $$$1 \leq d_j \leq 10^7$$$), representing the kind of food and the number of dishes the $$$j$$$-th customer orders, respectively.

Print $$$m$$$ lines. In the $$$j$$$-th line print the cost for the $$$j$$$-th customer.

NoteIn the first sample, $$$5$$$ customers will be served as follows. Customer $$$1$$$ will be served $$$6$$$ dishes of the $$$2$$$-nd kind, $$$1$$$ dish of the $$$4$$$-th kind, and $$$1$$$ dish of the $$$6$$$-th kind. The cost is $$$6 \cdot 3 + 1 \cdot 2 + 1 \cdot 2 = 22$$$. The remain of the $$$8$$$ kinds of food will be $$$\{8, 0, 2, 0, 4, 4, 7, 5\}$$$. Customer $$$2$$$ will be served $$$4$$$ dishes of the $$$1$$$-st kind. The cost is $$$4 \cdot 6 = 24$$$. The remain will be $$$\{4, 0, 2, 0, 4, 4, 7, 5\}$$$. Customer $$$3$$$ will be served $$$4$$$ dishes of the $$$6$$$-th kind, $$$3$$$ dishes of the $$$8$$$-th kind. The cost is $$$4 \cdot 2 + 3 \cdot 2 = 14$$$. The remain will be $$$\{4, 0, 2, 0, 4, 0, 7, 2\}$$$. Customer $$$4$$$ will be served $$$2$$$ dishes of the $$$3$$$-rd kind, $$$2$$$ dishes of the $$$8$$$-th kind. The cost is $$$2 \cdot 3 + 2 \cdot 2 = 10$$$. The remain will be $$$\{4, 0, 0, 0, 4, 0, 7, 0\}$$$. Customer $$$5$$$ will be served $$$7$$$ dishes of the $$$7$$$-th kind, $$$3$$$ dishes of the $$$1$$$-st kind. The cost is $$$7 \cdot 3 + 3 \cdot 6 = 39$$$. The remain will be $$$\{1, 0, 0, 0, 4, 0, 0, 0\}$$$.In the second sample, each customer is served what they order except the last one, who leaves angrily without paying. For example, the second customer is served $$$6$$$ dishes of the second kind, so the cost is $$$66 \cdot 6 = 396$$$.In the third sample, some customers may not be served what they order. For example, the second customer is served $$$6$$$ dishes of the second kind, $$$6$$$ of the third and $$$1$$$ of the fourth, so the cost is $$$66 \cdot 6 + 666 \cdot 6 + 6666 \cdot 1 = 11058$$$.

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections#-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}

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

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

main :: IO ()
main = do
  [n,m] <- map read . words <$> getLine
  as_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  as <- A.newListArray (1, n) as_ :: IO (IOUArray Int Int)
  cs_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  customers <- take m . unfoldr (runStateT $ (,) <$> rInt <*> rInt)
     <$> BSL.getContents
  let cs = A.listArray (1, n) $ map fromIntegral cs_ :: UArray Int Int64
      is = runSTUArray $ do
        is <- A.newListArray (1,n) [1..n]
        sortMArrayBy (\i j -> compare (cs A.! i) (cs A.! j)) is
        return is
  kpres <- newIORef (1::Int)
  let serveDesperately d !acc = do
        k <- readIORef kpres
        go k d acc
      go !k !d !acc
        | k > n = return 0
        | otherwise = do
            (!val, !d2) <- tryToServe cs as (is A.! k) d
            if d2 <= 0 then return $! acc+val else do
              writeIORef kpres (k+1)
              go (k+1) d2 (acc+val)
  forM_ customers $ \(!t,!d) -> do
    (!val, !d2) <- tryToServe cs as t d
    tot <- if d2 <= 0 then return val else serveDesperately d2 val
    print tot

tryToServe :: UArray Int Int64 -> IOUArray Int Int -> Int -> Int
  -> IO (Int64,Int)
tryToServe cost rest !t !d = do
  restT <- A.readArray rest t
  if restT >= d then do
    A.writeArray rest t $! (restT-d)
    return (cost A.! t * fromIntegral d,    0)
  else do
    A.writeArray rest t 0
    return (cost A.! t * fromIntegral restT, d-restT)

type Comparison e = e -> e -> Ordering

{-# INLINE sortMArray #-}
sortMArray :: (MArray a e m, Ord e, A.Ix i, Integral i, Bits i)
           => a i e -> m ()
sortMArray = sortMArrayBy compare

{-# INLINE sortMArrayBy #-}
sortMArrayBy :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> m ()
sortMArrayBy cmp = \arr -> A.getBounds arr >>= sortMArrayByBounds cmp arr

-- sort the interval [l,u] of arr.
{-# INLINE sortMArrayByBounds #-}
sortMArrayByBounds :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> (i,i) -> m ()
sortMArrayByBounds cmp = \arr (l,u) -> sortMArrayByBounds_ cmp arr l (u+1)

-- sort the interval [l,u) of arr.
{-# INLINE sortMArrayByBounds_ #-}
sortMArrayByBounds_ :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> i -> i -> m ()
sortMArrayByBounds_ cmp = \arr l u -> do
  let len = u - l
  tmp <- A.newArray_ (0,len `shiftR` 1 - 1)
  mergesort cmp arr tmp l u

mergesort cmp arr tmp l u
  | u - l <= 1 = return ()
  | otherwise  = do mergesort cmp arr tmp l mid
                    mergesort cmp arr tmp mid u
                    merge cmp arr tmp l mid u
    where
      len = u - l
      mid = (u + l) `shiftR` 1

{-# INLINE merge #-}
merge :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> a i e -> i -> i -> i -> m ()
merge cmp arr tmp l mid u = do
  copyMArray arr (l,mid-1) tmp (0,mml-1)
  eLow <- A.readArray tmp 0
  eHigh <- A.readArray arr mid
  loop eLow 0 eHigh mid l
  where
    mml = mid - l
    loop !eLow !iLow !eHigh !iHigh !iIns = case cmp eHigh eLow of
      LT -> do A.writeArray arr iIns eHigh
               wroteHigh eLow iLow (iHigh+1) (iIns+1)
      _  -> do A.writeArray arr iIns eLow
               wroteLow (iLow+1) eHigh iHigh (iIns+1)
    wroteHigh !eLow !iLow !iHigh !iIns
      | iHigh >= u = copyMArray tmp (iLow,mml-1) arr (iIns,u-1)
      | otherwise  = do eHigh <- A.readArray arr iHigh
                        loop eLow iLow eHigh iHigh iIns
    wroteLow !iLow !eHigh !iHigh !iIns
      | iLow >= mml = return ()
      | otherwise   = do eLow <- A.readArray tmp iLow
                         loop eLow iLow eHigh iHigh iIns

{-# INLINE copyMArray #-}
copyMArray :: (MArray a0 e m, A.Ix i0, MArray a1 e m, A.Ix i1)
  => a0 i0 e -> (i0,i0) -> a1 i1 e -> (i1,i1) -> m ()
copyMArray src srcRange dst dstRange =
  forM_ (zip (A.range srcRange) (A.range dstRange))
  $ \(i,j) -> A.writeArray dst j =<< A.readArray src i

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections#-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}

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

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

main :: IO ()
main = do
  [n,m] <- map read . words <$> getLine
  as_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  as <- A.newListArray (1, n) as_ :: IO (IOUArray Int Int)
  cs_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  customers <- take m . unfoldr (runStateT $ (,) <$> rInt <*> rInt)
     <$> BSL.getContents
  let cs = A.listArray (1, n) $ map fromIntegral cs_ :: UArray Int Int64
      is = A.listArray (1, n) $ sortBy (compare `on` (cs A.!)) [1..n]
           :: UArray Int Int
  kpres <- newIORef (1::Int)
  let serveDesperately d !acc = do
        k <- readIORef kpres
        go k d acc
      go k d !acc
        | k > n = return 0
        | otherwise = do
            (!val, !d2) <- tryToServe cs as (is A.! k) d
            if d2 <= 0 then return $! acc+val else do
              writeIORef kpres (k+1)
              go (k+1) d2 (acc+val)
  forM_ customers $ \(t,d) -> do
    (!val, !d2) <- tryToServe cs as t d
    tot <- if d2 <= 0 then return val else serveDesperately d2 val
    print tot

tryToServe :: UArray Int Int64 -> IOUArray Int Int -> Int -> Int
  -> IO (Int64,Int)
tryToServe cost rest !t !d = do
  restT <- A.readArray rest t
  if restT >= d then do
    A.writeArray rest t $! (restT-d)
    return (cost A.! t * fromIntegral d,    0)
  else do
    A.writeArray rest t 0
    return (cost A.! t * fromIntegral restT, d-restT)

type Comparison e = e -> e -> Ordering

{-# INLINE sortMArray #-}
sortMArray :: (MArray a e m, Ord e, A.Ix i, Integral i, Bits i)
           => a i e -> m ()
sortMArray = sortMArrayBy compare

{-# INLINE sortMArrayBy #-}
sortMArrayBy :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> m ()
sortMArrayBy cmp = \arr -> A.getBounds arr >>= sortMArrayByBounds cmp arr

-- sort the interval [l,u] of arr.
{-# INLINE sortMArrayByBounds #-}
sortMArrayByBounds :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> (i,i) -> m ()
sortMArrayByBounds cmp = \arr (l,u) -> sortMArrayByBounds_ cmp arr l (u+1)

-- sort the interval [l,u) of arr.
{-# INLINE sortMArrayByBounds_ #-}
sortMArrayByBounds_ :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> i -> i -> m ()
sortMArrayByBounds_ cmp = \arr l u -> do
  let len = u - l
  tmp <- A.newArray_ (0,len `shiftR` 1 - 1)
  mergesort cmp arr tmp l u

mergesort cmp arr tmp l u
  | u - l <= 1 = return ()
  | otherwise  = do mergesort cmp arr tmp l mid
                    mergesort cmp arr tmp mid u
                    merge cmp arr tmp l mid u
    where
      len = u - l
      mid = (u + l) `shiftR` 1

{-# INLINE merge #-}
merge :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> a i e -> i -> i -> i -> m ()
merge cmp arr tmp l mid u = do
  copyMArray arr (l,mid-1) tmp (0,mml-1)
  eLow <- A.readArray tmp 0
  eHigh <- A.readArray arr mid
  loop eLow 0 eHigh mid l
  where
    mml = mid - l
    loop !eLow !iLow !eHigh !iHigh !iIns = case cmp eHigh eLow of
      LT -> do A.writeArray arr iIns eHigh
               wroteHigh eLow iLow (iHigh+1) (iIns+1)
      _  -> do A.writeArray arr iIns eLow
               wroteLow (iLow+1) eHigh iHigh (iIns+1)
    wroteHigh !eLow !iLow !iHigh !iIns
      | iHigh >= u = copyMArray tmp (iLow,mml-1) arr (iIns,u-1)
      | otherwise  = do eHigh <- A.readArray arr iHigh
                        loop eLow iLow eHigh iHigh iIns
    wroteLow !iLow !eHigh !iHigh !iIns
      | iLow >= mml = return ()
      | otherwise   = do eLow <- A.readArray tmp iLow
                         loop eLow iLow eHigh iHigh iIns

{-# INLINE copyMArray #-}
copyMArray :: (MArray a0 e m, A.Ix i0, MArray a1 e m, A.Ix i1)
  => a0 i0 e -> (i0,i0) -> a1 i1 e -> (i1,i1) -> m ()
copyMArray src srcRange dst dstRange =
  forM_ (zip (A.range srcRange) (A.range dstRange))
  $ \(i,j) -> A.writeArray dst j =<< A.readArray src i

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TupleSections#-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE MultiWayIf #-}

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

main :: IO ()
main = do
  [n,m] <- map read . words <$> getLine
  as_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  as <- A.newListArray (1, n) as_ :: IO (IOUArray Int Int)
  cs_ <- unfoldr (BS.readInt . BS.dropWhile (<'!')) <$> BS.getLine
  let cs = A.listArray (1, n) cs_ :: UArray Int Int
      is = runSTUArray $ do
        is <- A.newListArray (1,n) [1..n]
        sortMArrayBy (\i j -> compare (cs A.! i) (cs A.! j)) is
        return is
  kpres <- newIORef (1::Int)
  let serveDesperately d !acc = do
        k <- readIORef kpres
        go k d acc
      go k d !acc
        | k > n = return 0
        | otherwise = do
            (val, d2) <- tryToServe cs as (is A.! k) d
            if d2 <= 0 then return $! acc+val else do
              writeIORef kpres (k+1)
              go (k+1) d2 (acc+val)
  replicateM_ m $ do
    [t, d] <- map read . words <$> getLine
    (val, d2) <- tryToServe cs as t d
    tot <- if d2 <= 0 then return val else serveDesperately d2 val
    print tot

tryToServe :: UArray Int Int -> IOUArray Int Int -> Int -> Int -> IO (Int,Int)
tryToServe cost rest t d = do
  restT <- A.readArray rest t
  if restT >= d then do
    A.writeArray rest t (restT-d)
    return (cost A.! t * d,    0)
  else do
    A.writeArray rest t 0
    return (cost A.! t * restT, d-restT)

type Comparison e = e -> e -> Ordering

{-# INLINE sortMArray #-}
sortMArray :: (MArray a e m, Ord e, A.Ix i, Integral i, Bits i)
           => a i e -> m ()
sortMArray = sortMArrayBy compare

{-# INLINE sortMArrayBy #-}
sortMArrayBy :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> m ()
sortMArrayBy cmp = \arr -> A.getBounds arr >>= sortMArrayByBounds cmp arr

-- sort the interval [l,u] of arr.
{-# INLINE sortMArrayByBounds #-}
sortMArrayByBounds :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> (i,i) -> m ()
sortMArrayByBounds cmp = \arr (l,u) -> sortMArrayByBounds_ cmp arr l (u+1)

-- sort the interval [l,u) of arr.
{-# INLINE sortMArrayByBounds_ #-}
sortMArrayByBounds_ :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> i -> i -> m ()
sortMArrayByBounds_ cmp = \arr l u -> do
  let len = u - l
  tmp <- A.newArray_ (0,len `shiftR` 1 - 1)
  mergesort cmp arr tmp l u

mergesort cmp arr tmp l u
  | u - l <= 1 = return ()
  | otherwise  = do mergesort cmp arr tmp l mid
                    mergesort cmp arr tmp mid u
                    merge cmp arr tmp l mid u
    where
      len = u - l
      mid = (u + l) `shiftR` 1

{-# INLINE merge #-}
merge :: (MArray a e m, A.Ix i, Integral i, Bits i)
  => Comparison e -> a i e -> a i e -> i -> i -> i -> m ()
merge cmp arr tmp l mid u = do
  copyMArray arr (l,mid-1) tmp (0,mml-1)
  eLow <- A.readArray tmp 0
  eHigh <- A.readArray arr mid
  loop eLow 0 eHigh mid l
  where
    mml = mid - l
    loop !eLow !iLow !eHigh !iHigh !iIns = case cmp eHigh eLow of
      LT -> do A.writeArray arr iIns eHigh
               wroteHigh eLow iLow (iHigh+1) (iIns+1)
      _  -> do A.writeArray arr iIns eLow
               wroteLow (iLow+1) eHigh iHigh (iIns+1)
    wroteHigh !eLow !iLow !iHigh !iIns
      | iHigh >= u = copyMArray tmp (iLow,mml-1) arr (iIns,u-1)
      | otherwise  = do eHigh <- A.readArray arr iHigh
                        loop eLow iLow eHigh iHigh iIns
    wroteLow !iLow !eHigh !iHigh !iIns
      | iLow >= mml = return ()
      | otherwise   = do eLow <- A.readArray tmp iLow
                         loop eLow iLow eHigh iHigh iIns

{-# INLINE copyMArray #-}
copyMArray :: (MArray a0 e m, A.Ix i0, MArray a1 e m, A.Ix i1)
  => a0 i0 e -> (i0,i0) -> a1 i1 e -> (i1,i1) -> m ()
copyMArray src srcRange dst dstRange =
  forM_ (zip (A.range srcRange) (A.range dstRange))
  $ \(i,j) -> A.writeArray dst j =<< A.readArray src i


Завтра у хоккейной команды, которой руководит Евгений, важный матч. Евгению нужно выбрать шесть игроков, которые выйдут на лед в стартовом составе: один вратарь, два защитника и три нападающих.Так как это стартовый состав, Евгения больше волнует, насколько красива будет команда на льду, чем способности игроков. А именно, Евгений хочет выбрать такой стартовый состав, чтобы номера любых двух игроков из стартового состава отличались не более, чем в два раза. Например, игроки с номерами 13, 14, 10, 18, 15 и 20 устроят Евгения, а если, например, на лед выйдут игроки с номерами 8 и 17, то это не устроит Евгения.Про каждого из игроков вам известно, на какой позиции он играет (вратарь, защитник или нападающий), а также его номер. В хоккее номера игроков не обязательно идут подряд. Посчитайте число различных стартовых составов из одного вратаря, двух защитников и трех нападающих, которые может выбрать Евгений, чтобы выполнялось его условие красоты.

Первая строка содержит три целых числа g, d и f (1 ≤ g ≤ 1 000, 1 ≤ d ≤ 1 000, 1 ≤ f ≤ 1 000) — число вратарей, защитников и нападающих в команде Евгения.  Вторая строка содержит g целых чисел, каждое в пределах от 1 до 100 000 — номера вратарей. Третья строка содержит d целых чисел, каждое в пределах от 1 до 100 000 — номера защитников. Четвертая строка содержит f целых чисел, каждое в пределах от 1 до 100 000 — номера нападающих. Гарантируется, что общее количество игроков не превосходит 1 000, т. е. g + d + f ≤ 1 000. Все g + d + f номеров игроков различны.

Выведите одно целое число — количество возможных стартовых составов.

ПримечаниеВ первом примере всего один вариант для выбора состава, который удовлетворяет описанным условиям, поэтому ответ 1.Во втором примере подходят следующие игровые сочетания (в порядке вратарь-защитник-защитник-нападающий-нападающий-нападающий):  16 20 12 13 21 11  16 20 12 13 11 10  16 20 19 13 21 11  16 20 19 13 11 10  16 12 19 13 21 11  16 12 19 13 11 10 Таким образом, ответ на этот пример — 6.

import Data.Monoid
import Data.Tuple
import Data.Foldable (foldMap)
import Data.Function (on)
import Data.Functor (fmap)
import Data.List
import Control.Applicative
import Foreign.Marshal.Utils

data Player = Forwarder | Defenceman | Goaltender
	deriving (Show, Eq)

data Count = Count { countForwarders :: Int, countDefencemen :: Int, countGoaltenders :: Int }

toCount Forwarder = Count 1 0 0
toCount Defenceman = Count 0 1 0
toCount Goaltender = Count 0 0 1

instance Monoid Count where
	mempty = Count 0 0 0
	mappend (Count a1 a2 a3) (Count b1 b2 b3) = Count (a1 + b1) (a2 + b2) (a3 + b3)

main = interact $ show . run . uncurry getInput . splitAt 3 . map (read :: String -> Int) . words where
	getInput (g:d:f:[]) = zip $ replicate g Goaltender <> replicate d Defenceman <> replicate f Forwarder
	run = sum . map process . init . tails . sortBy (compare `on` snd)
	process (player:rest) = (liftA3 (((*) .) . (*))
	                                (flip combinations (1 - (fromBool $ (fst player) == Goaltender)) . countGoaltenders)
	                                (flip combinations (2 - (fromBool $ (fst player) == Defenceman)) . countDefencemen)
	                                (flip combinations (3 - (fromBool $ (fst player) == Forwarder))  . countForwarders))
	                        . foldMap (toCount . fst) . takeWhile ((2 * (snd player) >=) . snd) $ rest
	combinations :: Integral a => a -> a -> Integer
	combinations n k = product (map toInteger [n,n-1..n-k+1]) `div` product (map toInteger [1..k])

import Data.Monoid
import Data.Tuple
import Data.Foldable (foldMap)
import Data.Function (on)
import Data.Functor (fmap)
import Data.List
import Control.Applicative
import Foreign.Marshal.Utils

data Player = Forwarder | Defenceman | Goaltender
	deriving (Show, Eq)

data Count = Count { countForwarders :: Int, countDefencemen :: Int, countGoaltenders :: Int }

toCount Forwarder = Count 1 0 0
toCount Defenceman = Count 0 1 0
toCount Goaltender = Count 0 0 1

instance Monoid Count where
	mempty = Count 0 0 0
	mappend (Count a1 a2 a3) (Count b1 b2 b3) = Count (a1 + b1) (a2 + b2) (a3 + b3)

main = interact $ show . run . uncurry getInput . splitAt 3 . map (read :: String -> Int) . words where
	getInput (g:d:f:[]) = zip $ replicate g Goaltender <> replicate d Defenceman <> replicate f Forwarder
	run = sum . map process . init . tails . sortBy (compare `on` snd)
	-- process = const 0 . foldMap toCount . liftA2 takeWhile ((. snd) . (>=) . (*) 2 . snd . head) tail
	process ((thisPlayer, thisNumber):xs) = (liftA3 (curry $ (*) . uncurry (*)) (flip combinations (3 - (fromBool $ thisPlayer == Forwarder)) . countForwarders) (flip combinations (1 - (fromBool $ thisPlayer == Goaltender)) . countGoaltenders) (flip combinations (2 - (fromBool $ thisPlayer == Defenceman)) . countDefencemen)) . foldMap (toCount . fst) . takeWhile ((2 * thisNumber >=) . snd) $ xs
	combinations n k = product [n,n-1..n-k+1] `div` product [1..k]
	-- count = (length .) . filter


In fact, the problems E1 and E2 do not have much in common. You should probably think of them as two separate problems.You are given an integer array $$$a[1 \ldots n] = [a_1, a_2, \ldots, a_n]$$$.Let us consider an empty deque (double-ended queue). A deque is a data structure that supports adding elements to both the beginning and the end. So, if there are elements $$$[3, 4, 4]$$$ currently in the deque, adding an element $$$1$$$ to the beginning will produce the sequence $$$[\color{red}{1}, 3, 4, 4]$$$, and adding the same element to the end will produce $$$[3, 4, 4, \color{red}{1}]$$$.The elements of the array are sequentially added to the initially empty deque, starting with $$$a_1$$$ and finishing with $$$a_n$$$. Before adding each element to the deque, you may choose whether to add it to the beginning or to the end.For example, if we consider an array $$$a = [3, 7, 5, 5]$$$, one of the possible sequences of actions looks like this: $$$\quad$$$ 1.add $$$3$$$ to the beginning of the deque:deque has a sequence $$$[\color{red}{3}]$$$ in it;$$$\quad$$$ 2.add $$$7$$$ to the end of the deque:deque has a sequence $$$[3, \color{red}{7}]$$$ in it;$$$\quad$$$ 3.add $$$5$$$ to the end of the deque:deque has a sequence $$$[3, 7, \color{red}{5}]$$$ in it;$$$\quad$$$ 4.add $$$5$$$ to the beginning of the deque:deque has a sequence $$$[\color{red}{5}, 3, 7, 5]$$$ in it;Find the minimal possible number of inversions in the deque after the whole array is processed. An inversion in sequence $$$d$$$ is a pair of indices $$$(i, j)$$$ such that $$$i < j$$$ and $$$d_i > d_j$$$. For example, the array $$$d = [5, 3, 7, 5]$$$ has exactly two inversions — $$$(1, 2)$$$ and $$$(3, 4)$$$, since $$$d_1 = 5 > 3 = d_2$$$ and $$$d_3 = 7 > 5 = d_4$$$.

The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 1000$$$) — the number of test cases. The next $$$2t$$$ lines contain descriptions of the test cases.  The first line of each test case description contains an integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — array size. The second line of the description contains $$$n$$$ space-separated integers $$$a_i$$$ ($$$-10^9 \le a_i \le 10^9$$$) — elements of the array. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

Print $$$t$$$ lines, each line containing the answer to the corresponding test case. The answer to a test case should be a single integer — the minimal possible number of inversions in the deque after executing the described algorithm.

NoteOne of the ways to get the sequence $$$[5, 3, 7, 5]$$$ in the deque, containing only two inversions, from the initial array $$$[3, 7, 5, 5]$$$ (the first sample test case) is described in the problem statement. Also, in this example, you could get the answer of two inversions by simply putting each element of the original array at the end of the deque. In this case, the original sequence $$$[3, 7, 5, 5]$$$, also containing exactly two inversions, will be in the deque as-is.

import Control.Monad
import Data.List
import Data.Int
import qualified Data.Set as S

calc' :: S.Set (Int,Int) -> Int -> Int64 -> Int -> [Int] -> Int64
calc' _ _  cnt n [] = cnt
calc' tr i cnt n (y:ys) =
  let (left, _) = S.split (y,-1) tr
      (right, _) = S.split (y,n) tr
      leftSize = S.size left
      rightSize = i - (S.size right)
      cnt' = cnt + (fromIntegral (min leftSize rightSize))
      tr' = S.insert (y,i) tr
  in
      calc' tr' (i+1) cnt' n ys

calc :: Int -> [Int] -> Int64
calc = calc' S.empty 0 0

main = do
  line <- getLine
  let t = read line :: Int
  forM_ [1..t] $ \_ -> do
    line <- getLine
    let n = read line :: Int
    line <- getLine
    let lst = map read $ words line :: [Int]
    print $ calc n lst

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 Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
--import Data.List
--import Data.Array.Unboxed
import qualified Data.Set as Set
import Data.Int

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    p <- getInts n
    let
      p2 = zip p [1..n]
      initVals = Set.fromList p2
      solve :: Set.Set (Int, Int) -> [(Int, Int)] -> Int64 -> Int64
      solve _nil [] cont = cont
      solve vals ((x, kx) : xs) cont = cont `seq` let
        (vl, _) = Set.split (x, minBound) vals
        (_, vr) = Set.split (x, maxBound) vals
        in  solve (Set.delete (x, kx) vals) xs
            $ cont + fromIntegral (min (Set.size vl) (Set.size vr))
    pure $ putInt64s [solve initVals (reverse p2) 0]

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]

putInt64s :: [Int64] -> Builder
putInt64s vs = let
  sepPrim = (,) ' ' Prim.>$<
    Prim.liftFixedToBounded Prim.char7 Prim.>*< Prim.int64Dec
  in  case  vs  of
  [] -> char7 '\n'
  x : xs -> int64Dec 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

import Control.Monad
import Data.List
import qualified Data.Set as S

calc' :: S.Set (Int,Int) -> Int -> Int -> Int -> [Int] -> Int
calc' _ _  cnt n [] = cnt
calc' tr i cnt n (y:ys) =
  let (left, _) = S.split (y,-1) tr
      (right, _) = S.split (y,n) tr
      leftSize = S.size left
      rightSize = i - (S.size right)
      cnt' = cnt + (min leftSize rightSize)
      tr' = S.insert (y,i) tr
  in
      calc' tr' (i+1) cnt' n ys

calc :: Int -> [Int] -> Int
calc = calc' S.empty 0 0

main = do
  line <- getLine
  let t = read line :: Int
  forM_ [1..t] $ \_ -> do
    line <- getLine
    let n = read line :: Int
    line <- getLine
    let lst = map read $ words line :: [Int]
    print $ calc n lst


You are given two arrays $$$a$$$ and $$$b$$$ of positive integers, with length $$$n$$$ and $$$m$$$ respectively. Let $$$c$$$ be an $$$n \times m$$$ matrix, where $$$c_{i,j} = a_i \cdot b_j$$$. You need to find a subrectangle of the matrix $$$c$$$ such that the sum of its elements is at most $$$x$$$, and its area (the total number of elements) is the largest possible.Formally, you need to find the largest number $$$s$$$ such that it is possible to choose integers $$$x_1, x_2, y_1, y_2$$$ subject to $$$1 \leq x_1 \leq x_2 \leq n$$$, $$$1 \leq y_1 \leq y_2 \leq m$$$, $$$(x_2 - x_1 + 1) \times (y_2 - y_1 + 1) = s$$$, and $$$$$$\sum_{i=x_1}^{x_2}{\sum_{j=y_1}^{y_2}{c_{i,j}}} \leq x.$$$$$$

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n, m \leq 2000$$$). The second line contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 2000$$$). The third line contains $$$m$$$ integers $$$b_1, b_2, \ldots, b_m$$$ ($$$1 \leq b_i \leq 2000$$$). The fourth line contains a single integer $$$x$$$ ($$$1 \leq x \leq 2 \cdot 10^{9}$$$).

If it is possible to choose four integers $$$x_1, x_2, y_1, y_2$$$ such that $$$1 \leq x_1 \leq x_2 \leq n$$$, $$$1 \leq y_1 \leq y_2 \leq m$$$, and $$$\sum_{i=x_1}^{x_2}{\sum_{j=y_1}^{y_2}{c_{i,j}}} \leq x$$$, output the largest value of $$$(x_2 - x_1 + 1) \times (y_2 - y_1 + 1)$$$ among all such quadruplets, otherwise output $$$0$$$.

NoteMatrix from the first sample and the chosen subrectangle (of blue color):  Matrix from the second sample and the chosen subrectangle (of blue color):

-- Codeforces 1060 C

import Data.List
import Control.Monad

sumUp :: [Integer] -> [Integer]
sumUp = scanl (+) 0

-- Find min sum of a list with n elements
findMinSum :: Int -> [Integer] -> Integer
findMinSum n list = minimum $ zipWith (-) (drop n list) list

-- Find sums possible with different n consecutive elements added
findSums :: [Integer] -> [(Int, Integer)]
findSums list = map (\n -> (n, findMinSum n $ sumUp list)) [1..length list]

findCombination :: [(Int, Integer)] -> [(Int, Integer)] -> Integer -> Int
findCombination aList bList val = case combinations of
    [] -> 0
    _  -> maximum combinations
    where combinations = do
            (an, ax) <- aList
            (bn, bx) <- bList
            guard $ ax * bx <= val
            return $ an * bn

main :: IO ()
main = do
    firstLine <- getLine
    aList <- getLine >>=
            return.(\list -> map (read::String -> Integer) (words list))
    bList <- getLine >>=
            return.(\list -> map (read::String -> Integer) (words list))
    x     <- getLine >>= return.read
    putStrLn.show $ findCombination (findSums aList) (findSums bList) x

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

main = sol <$> get <*> get <*> get <*> readLn >>= print

--get = fmap fst . mapMaybe C.readInt . C.words <$> C.getLine
get = fmap read . words <$> getLine

sol [n,m] as bs x = if null ps then 0 else maximum ps
    where
    mx = 2*10^9
    sa = listArray (0,n) $ scanl (+) 0 as
    sb = listArray (0,m) $ scanl (+) 0 bs
    da = accumArray min mx (1,n) [(j-i+1, sa!j-sa!(i-1)) | i <- [1..n], j <- [i..n]]
    db = accumArray min mx (1,m) [(j-i+1, sb!j-sb!(i-1)) | i <- [1..m], j <- [i..m]]
    ps = [i*j | i <- [1..n], j <- [1..m], da!i*db!j <= x]

--mx = maxBound :: Int
mx = 2*10^9
--sa = listArray (0,n) $ scanl' (+) 0 as
--sb = listArray (0,m) $ scanl' (+) 0 bs
sa = listArray (0,n) $ scanl (+) 0 as
sb = listArray (0,m) $ scanl (+) 0 bs
da = accumArray min mx (1,n) [(j-i+1, sa!j-sa!(i-1)) | i <- [1..n], j <- [i..n]]
db = accumArray min mx (1,m) [(j-i+1, sb!j-sb!(i-1)) | i <- [1..m], j <- [i..m]]
ps = [i*j | i <- [1..n], j <- [1..m], da!i*db!j <= x]
f = maximum ps
dbg = [(i*j,i,j) | i <- [1..n], j <- [1..m], da!i*db!j <= x]

--
[n,m]=[3,3]
as=[1,2,3]
bs=[1,2,3]
x=9
{-
[n,m]=[5,1]
as=[5,4,2,4,5]
bs=[2]
x=5
--

[n,m]=[8,8]
as=[2000,2000,2000,2000,2000,2000,2000,2000,2000]
bs=[2000,2000,2000,2000,2000,2000,2000,2000,2000]
x=9*10^9
--Output
--4000000
--Answer
--500

-}

-- Codeforces 1060 C

import Data.List
import Control.Monad

sumUp :: [Int] -> [Int]
sumUp = scanl (+) 0

-- Find min sum of a list with n elements
findMinSum :: Int -> [Int] -> Int
findMinSum n list = minimum $ zipWith (-) (drop n list) list

-- Find sums possible with different n consecutive elements added
findSums :: [Int] -> [(Int, Int)]
findSums list = map (\n -> (n, findMinSum n $ sumUp list)) [1..length list]

findCombination :: [(Int, Int)] -> [(Int, Int)] -> Int -> Int
findCombination aList bList val = maximum $ do
    (an, ax) <- aList
    (bn, bx) <- bList
    guard $ ax * bx <= val
    return $ an * bn

main :: IO ()
main = do
    firstLine <- getLine
    aList <- getLine >>=
            return.(\list -> map (read::String -> Int) (words list))
    bList <- getLine >>=
            return.(\list -> map (read::String -> Int) (words list))
    x     <- getLine >>= return.read
    putStrLn.show $ findCombination (findSums aList) (findSums bList) x

-- Codeforces 1060 C

import Data.List
import Control.Monad

sumUp :: [Int] -> [Int]
sumUp = scanl (+) 0

-- Find min sum of a list with n elements
findMinSum :: Int -> [Int] -> Int
findMinSum n list = minimum $ zipWith (-) (drop n list) list

-- Find sums possible with different n consecutive elements added
findSums :: [Int] -> [(Int, Int)]
findSums list = map (\n -> (n, findMinSum n $ sumUp list)) [1..length list]

findCombination :: [(Int, Int)] -> [(Int, Int)] -> Int -> Int
findCombination aList bList val = case combinations of
    [] -> 0
    _  -> maximum combinations
    where combinations = do
            (an, ax) <- aList
            (bn, bx) <- bList
            guard $ ax * bx <= val
            return $ an * bn

main :: IO ()
main = do
    firstLine <- getLine
    aList <- getLine >>=
            return.(\list -> map (read::String -> Int) (words list))
    bList <- getLine >>=
            return.(\list -> map (read::String -> Int) (words list))
    x     <- getLine >>= return.read
    putStrLn.show $ findCombination (findSums aList) (findSums bList) x

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

main = sol <$> get <*> get <*> get <*> readLn >>= print

get = fmap fst . mapMaybe C.readInt . C.words <$> C.getLine

sol [n,m] as bs x = if null ps then 0 else maximum ps
    where
    mx = maxBound :: Int
    sa = listArray (0,n) $ scanl (+) 0 as
    sb = listArray (0,m) $ scanl (+) 0 bs
    da = accumArray min mx (1,n) [(j-i+1, sa!j-sa!(i-1)) | i <- [1..n], j <- [i..n]]
    db = accumArray min mx (1,m) [(j-i+1, sb!j-sb!(i-1)) | i <- [1..m], j <- [i..m]]
    ps = [i*j| i <- [1..n], j <- [1..m], da!i*db!j <= x]

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

main = sol <$> get <*> get <*> get <*> readLn >>= print

get = fmap fst . mapMaybe C.readInt . C.words <$> C.getLine

sol [n,m] as bs x = if null ps then 0 else maximum ps
    where
    a = listArray (1,n) (sort as)
    b = listArray (1,m) (sort bs)
    c = array ((0,0),(n,m)) $ ((0,0),0):
        [((i,0),0) | i <- [1..n]] ++
        [((0,j),0) | j <- [1..m]] ++
        [((i,j),a!i*b!j + c!(i,j-1) + c!(i-1,j) - c!(i-1,j-1)) | i <- [1..n], j <- [1..m]]
    ps = [i*j | i <- [1..n], j <- [1..m], c!(i,j) <= x]


Teacher thinks that we make a lot of progress. Now we are even allowed to use decimal notation instead of counting sticks. After the test the teacher promised to show us a "very beautiful number". But the problem is, he's left his paper with the number in the teachers' office.The teacher remembers that the "very beautiful number" was strictly positive, didn't contain any leading zeroes, had the length of exactly p decimal digits, and if we move the last digit of the number to the beginning, it grows exactly x times. Besides, the teacher is sure that among all such numbers the "very beautiful number" is minimal possible.The teachers' office isn't near and the teacher isn't young. But we've passed the test and we deserved the right to see the "very beautiful number". Help to restore the justice, find the "very beautiful number" for us!

The single line contains integers p, x (1 ≤ p ≤ 106, 1 ≤ x ≤ 9).

If the teacher's made a mistake and such number doesn't exist, then print on a single line "Impossible" (without the quotes). Otherwise, print the "very beautiful number" without leading zeroes.

NoteSample 1: 142857·5 = 714285.Sample 2: The number that consists of a single digit cannot stay what it is when multiplied by 2, thus, the answer to the test sample is "Impossible".

{-# LANGUAGE OverloadedStrings #-}

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Control.Applicative (liftA2)
import Control.Monad (forM_)

-- replicate a string n times
multiply :: Int -> ByteString -> ByteString
multiply 0 _ = ""
multiply 1 bs = bs
multiply n bs =
  let (m,r) = n `divMod` 2
      bs' = multiply m (bs `BS.append` bs)
  in if r == 0 then bs'
               else bs `BS.append` bs'

-- solve the problem using Integers
-- (this is too slow for large problems)
solve1 :: Int -> Int -> Maybe Integer
solve1 x p =
  let b = 10*(fromIntegral x)-1 :: Integer
      tenp = 10^p-1
  in first [ n | d0 <- [1..9], let (n,r) = (d0*tenp) `divMod` b, r == 0,
                 length (show n) == p ]

first :: [a] -> Maybe a
first []    = Nothing
first (a:_) = Just a

liftMin :: Ord a => Maybe a -> Maybe a -> Maybe a
liftMin Nothing b = b
liftMin a Nothing = a
liftMin (Just a) (Just b) = Just $ min a b

-- solve the problem using ByteStrings
solve :: Int -> Int -> Maybe ByteString
solve 1 p = Just "1"
solve 2 p = solve' 2 18 2 p
solve 3 p = solve' 3 28 3 p
solve 4 p = solve' 4  6 4 p

solve 6 p = solve' 6 58 6 p
solve 7 p = solve' 7 22 7 p
solve 8 p = solve' 8 13 8 p
solve 9 p = solve' 9 44 9 p

solve 5 p =
  let n1 = solve' 5  6 7 p
      n2 = solve' 5 42 5 p
  in liftMin n1 n2
solve x p = error $ "huh? " ++ " x: " ++ show x ++ " p: " ++ show p

-- find the basic solution to the problem
--   x  - the multipler
--   m  - length of a basic solution
--   d0 - rightmost digit
--   p  - number of decimal digits
solve' :: Int -> Int -> Int -> Int -> Maybe ByteString
solve' x m d0 p =
  if p `mod` m == 0
     then let n :: Integer
              n = (fromIntegral d0)*(10^m-1) `div` fromIntegral (10*x-1)
           in Just $ BS.pack (show n)
     else Nothing

-- repeat a ByteString to length p
-- (don't know if the special case for length == 1 is necessary)
solutionToBS :: Int -> ByteString -> ByteString
solutionToBS p bs | p `mod` BS.length bs /= 0 = error "ooops!"
solutionToBS p bs | BS.length bs == 1 = BS.replicate p (BS.index bs 0)
solutionToBS p bs = multiply k bs
  where k = p `div` BS.length bs

(-->) = flip fmap

main = do (p:x:_) <- getLine --> words --> map read
          case solve x p of
            Nothing -> putStrLn "Impossible"
            Just bs -> BS.putStrLn $ solutionToBS p bs