A median in an array with the length of n is an element which occupies position number  after we sort the elements in the non-decreasing order (the array elements are numbered starting with 1). A median of an array (2, 6, 1, 2, 3) is the number 2, and a median of array (0, 96, 17, 23) — the number 17.We define an expression  as the integer part of dividing number a by number b.One day Vasya showed Petya an array consisting of n integers and suggested finding the array's median. Petya didn't even look at the array and said that it equals x. Petya is a very honest boy, so he decided to add several numbers to the given array so that the median of the resulting array would be equal to x.Petya can add any integers from 1 to 105 to the array, including the same numbers. Of course, he can add nothing to the array. If a number is added multiple times, then we should consider it the number of times it occurs. It is not allowed to delete of change initial numbers of the array. While Petya is busy distracting Vasya, your task is to find the minimum number of elements he will need.

The first input line contains two space-separated integers n and x (1 ≤ n ≤ 500, 1 ≤ x ≤ 105) — the initial array's length and the required median's value. The second line contains n space-separated numbers — the initial array. The elements of the array are integers from 1 to 105. The array elements are not necessarily different.

Print the only integer — the minimum number of elements Petya needs to add to the array so that its median equals x.

NoteIn the first sample we can add number 9 to array (10, 20, 30). The resulting array (9, 10, 20, 30) will have a median in position , that is, 10.In the second sample you should add numbers 4, 5, 5, 5. The resulting array has median equal to 4.

{-# OPTIONS_GHC -O3 -fno-spec-constr-count #-}
{-# LANGUAGE BangPatterns #-}
import Control.Monad
import Control.Applicative
import Data.List
import qualified Data.ByteString.Char8 as B
import qualified Data.Char as C

atoi :: B.ByteString -> Int
atoi = B.foldl' (\a c -> a*10 + C.ord c - C.ord '0') 0

solve :: Int -> [Int] -> Int
solve x xs
    | xs !! m == x = 0
    | otherwise = 1 + (solve x $ insert x xs)
  where m = (length xs - 1) `div` 2

main = do
    [n, x] <- map atoi . B.words <$> B.getLine
    xs <- sort . map atoi . B.words <$> B.getLine
    putStrLn . show $ solve x xs

module Main where

import Data.Maybe
import Data.Array
import Data.List
import Data.Char

import Data.Time.Calendar

main = interact (show . solve . map (map read . words) . lines)

solve :: [[Int]] -> Int
solve ([_, x] : arr : _) = addition + max 0 (e - b - nx) + max 0 (b + 1 - nx - e) where
    b = length start
    e = length rest
    nx = length xs

    (xs,  rest) = break (/= x) arr'
    (start, arr') = break (== x) sortedArray

    sortedArray = sort correctArray

    (addition, correctArray) = if x `elem` arr then (0, arr) else (1, x : arr)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sun 21 Oct 2012 04:43:42 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

--{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (elemIndex)
import Data.List (elemIndices)

median ls = head $ drop ((((length ls) + 1) `div` 2) - 1) ls

countDist x med sls len =
    if x == med
        then 0
        else if x < med
                then
                    medind - (head $ reverse $ elemIndices x sls)
                else
                    res - medind
                    where
                        medind  = (len + 1) `div` 2  - 1 -- index
                        res     =
                            let ans = elemIndex x sls
                            in case ans of
                                    Just(y) -> y
                                    Nothing -> 0

calc x sls len = calcAdditions x (median sls) (countDist x (median sls) sls len) len
    where
        calcAdditions x med dist len=
            if x == med
                then 0
                else if len `mod` 2 == 0
                        then if x < med
                            then 2 * dist
                            else 2 * dist - 1
                    else if x < med
                            then 2 * dist - 1
                            else 2 * dist

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calc x sls (fromIntegral n)
            else
                print $ 1 + (calc x (insert x sls) ((fromIntegral n) + 1))
    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

import Control.Monad (liftM)
import List (sort)

{-
import HUnit

test  =  run $ TestList "Tests"
  [
    Test "Test #01" $ assertEq 1 $ solve 1 [],
    Test "Test #02" $ assertEq 0 $ solve 1 [1,2],
    Test "Test #03" $ assertEq 0 $ solve 1 [2,1],
    Test "Test #04" $ assertEq 0 $ solve 2 [1,2,3],
    Test "Test #05" $ assertEq 0 $ solve 1 [1],
    Test "Test #06" $ assertEq 1 $ solve 2 [1,2],
    Test "Test #07" $ assertEq 3 $ solve 3 [2,1],
    Test "Test #08" $ assertEq 2 $ solve 1 [4,2,3,1],
    Test "Test #09" $ assertEq 1 $ solve 3 [1,2,4,5],
    Test "Test #10" $ assertEq 3 $ solve 4 [1,2,3,5],
    Test "Test #11" $ assertEq 0 $ solve 2 [1,2,2,2,4],
    Test "Test #12" $ assertEq 2 $ solve 1 [1,1,2,3,4,5],
    Test "Test #13" $ assertEq 1 $ solve 10 [10,20,30],
    Test "Test #14" $ assertEq 4 $ solve 4 [1,2,3]
  ]
-}

solve :: Int -> [Int] -> Int
solve x xs  =  solve' n (find (1,0) (sort xs)) - n
  where
    n  =  length xs
    find (l,r) []  =  (l, r)
    find (l,r) (y:ys)
      | y <  x  =  find (l+1,r+1) ys
      | y == x  =  find (l, r+1) ys
      | otherwise  =  (l, r)
    solve' n (l,r)
      | n' >= l && n' <= r  =  n
      | otherwise  =  solve' (n+1) (l, r+1)
      where
        n'  =  div (n + 1) 2

main :: IO ()
main  =  do
    [_, x]  <-  liftM (map read . words) getLine
    xs  <-  liftM (map read . words) getLine
    print $ solve x xs

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Debug.Trace

countLess :: Integral a => [a] -> a -> a -> a -> (a,a)
countLess [] median count plithos = (count, plithos)
countLess (x:xs) median count plithos
	| x<median = countLess xs median (count+1) plithos
	| x==median = countLess xs median count (plithos+1)
	| otherwise = countLess xs median count plithos

calcMinNum length countLess 0
	| (countLess+1 == medPos) = 1
	| (countLess+1 > medPos) = 2*(countLess+1) - (length + 1)
	| (countLess+1 < medPos) = (length+1) + 1 - 2*(countLess+1)
	where medPos = (length + 2) `div` 2
calcMinNum length countLess plithos
	| (countLess+1 <= medPos) && (countLess + plithos >= medPos) = 0
	| (countLess+1 > medPos) = 2*(countLess+1) - 1 - length
	| (countLess + plithos < medPos) = length - 2*(countLess + plithos)
	where medPos = (length + 1) `div` 2

solve length median x =
	let
		(countLessRes, plithos) = countLess x median 0 0
	in
		calcMinNum length countLessRes plithos

main =
  do all <- BS.getContents
     let Just (length, r1) = readInteger all
     let Just (median, r2) = readInteger r1
     let  (x, _)  = readMany readInteger r2
     --print (length)
     --print (median)
     --print (x)
     print (solve length median x)
    -- print ((count_less x median 0 0) == length `div` 2)
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Maybe
import Data.Char
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Int
import Data.Ratio
import Data.Bits
import Data.Function
import Data.Ord
--import Control.Monad.State
import Control.Monad
import Control.Applicative
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

parseInput = do
    n <- readInt
    x <- readInt
    a <- replicateM n readInt
    return (x, a)
  where
    readInt = state $ fromJust . BS.readInt . BS.dropWhile isSpace
    readInteger = state $ fromJust . BS.readInteger . BS.dropWhile isSpace
    readString = state $ BS.span (not . isSpace) . BS.dropWhile isSpace
    readLine = state $ BS.span (not . isEoln) . BS.dropWhile isEoln
    isEoln ch = ch == '\r' || ch == '\n'

main = print =<< solve . evalState parseInput <$> BS.getContents

median s = sort s !! ((length s - 1) `div` 2)

inf = 10^5

solve (x, a)
    | m == x    = 0
    | otherwise = solve (x, x : a) + 1
  where
    m = median a

-- {{{ A minimal State Monad
class (Monad m) => MonadState s m | m -> s where
	get :: m s
	put :: s -> m ()

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
	s <- get
	put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
	s <- get
	return (f s)

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

instance Functor (State s) where
	fmap f m = State $ \s -> let
		(a, s') = runState m s
		in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

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

instance MonadState s (State s) where
	get   = State $ \s -> (s, s)
	put s = State $ \_ -> ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

state = State
-- }}}

import Data.List

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

solve :: [Int] -> Int
solve (_:x:ys)
  | notElem x ls = if l < g then g-l else l-g+1
  | l < g        = g-l
  | otherwise    = max 0 (l-lx-g-lx+1)
   where (ls,gs) = partition (<=x) ys
         [l,g] = map length [ls,gs]
         lx = length.filter(x==)$ls

s[[_,m],xs]= c where
  l = length$ filter(<m+0) xs
  g = length$ filter(>m) xs
  e = length xs - l - g
  c = max 0 $ max (g-l-e) (l-g-e+1)
main=interact$show.s.map(map read.words).lines

{-# OPTIONS_GHC -O2 -optc-O2 #-}

-- solution for: http://codeforces.com/problemset/problem/166/c

solve :: Int ->  [Int] -> (Int, Int, Int) -> Int
solve x [] (l,e,g) = (final (l,e,g))
solve x (a:aa) (l,e,g) =
	if (a == x)
		then solve x aa (l,e+1,g)
		else if (a < x)
			then solve x aa (l+1,e,g)
			else solve x aa (l,e,g+1)

final :: (Int, Int, Int) -> Int
final (l,e,g) =
	if (l == g)
	then if (e > 0)
		then 0
		else 1
	else finall (l,e,g)

finall :: (Int, Int, Int) -> Int
finall (l,0,g) = 1 + finall (l,1,g)
finall (l,e,g) =
	if (l < g)
	then if (l + e >= g)
		then 0
		else (g - l - e)
	else if (l < e + g)
		then 0
		else (l - g - e + 1)

main =
  do m <- getLine
     let [n,x] = map read (words m)
     str <- getLine
     let a  = map read (words str)
     print (solve x a (0,0,0))

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sun 21 Oct 2012 05:20:15 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (elemIndex)
import Data.List (elemIndices)

median ls = head $ drop el ls
  where el = ((length ls) + 1) `div` 2 - 1

countDist x med sls len =
  if x == med
    then 0
    else if x < med
        then medind - (head $ reverse $ elemIndices x sls)
        else res - medind
          where
            medind    = (len + 1) `div` 2 - 1 -- index
            Just(res)   = elemIndex x sls

calc x sls len = calcAdditions x medianS sls len
  where
    medianS           = median sls
    calcAdditions x med sls len =
      if x == med
        then 0
        else if len `mod` 2 == 0
            then if x < med
              then 2 * dist
              else 2 * dist - 1
          else if x < med
              then 2 * dist - 1
              else 2 * dist
        where
          dist = countDist x med sls len

main :: IO ()
main =
  do
    all <- BS.getContents
    let Just (n, r1)  = readInteger all
    let Just (x, r2)  = readInteger r1
    let (ls, _)     = readMany readInteger r2
    let sls = sort ls
    if x `elem` sls
      then
        print $ calc x sls (fromIntegral n)
      else
        print $ 1 + (calc x (insert x sls) ((fromIntegral n) + 1))
  where
    readInt s = BSC.readInt (BSC.dropWhile isSpace s)
    readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
    readMany readf s = case readf s of
      Just (x, r) ->  let
                (xs, t) = readMany readf r
              in
                (x : xs, t)
      Nothing   ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sun 21 Oct 2012 01:09:15 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

--{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (elemIndex)
import Data.List (elemIndices)

median ls = head $ drop ((length ls) `div` 2) ls

-- calcAdditions :: Int->Int->Int
calcAdditions x med dist len=
    if len `mod` 2 == 0
        then
            if x < med
                then
                    2 * dist
                else
                    2 * dist - 1
        else
            if x < med
                then
                    2 * dist - 1
                else
                    2 * dist

countDist x med sls len =
    if x == med
        then
            0
        else
            if x < med
                then
                    medind - (head $ reverse $ elemIndices x sls)
                else
                    res - medind
                    where
                        medind  = (len + 1) `div` 2  - 1 -- index
                        res     =
                            let
                                ans = elemIndex x sls
                            in
                                case ans of
                                    Just(y) -> y
                                    Nothing -> 0

calc x sls len = calcAdditions x (median sls) (countDist x (median sls) sls len) len

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calc x sls (fromIntegral n)
            else
                print $ 1 + (calc x (insert x sls) ((fromIntegral n) + 1))

    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sun 21 Oct 2012 04:32:20 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

--{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (elemIndex)
import Data.List (elemIndices)

median ls = head $ drop ((((length ls) + 1) `div` 2) - 1) ls

countDist x med sls len =
    if x == med
        then 0
        else if x < med
                then
                    medind - (head $ reverse $ elemIndices x sls)
                else
                    res - medind
                    where
                        medind  = (len + 1) `div` 2  - 1 -- index
                        res     =
                            let ans = elemIndex x sls
                            in case ans of
                                    Just(y) -> y
                                    Nothing -> 0

calc x sls len = calcAdditions x (median sls) (countDist x (median sls) sls len) len
    where
        calcAdditions x med dist len=
            if len `mod` 2 == 0
                then if x < med
                        then 2 * dist
                        else 2 * dist - 1
                else if x < med
                        then 2 * dist - 1
                        else 2 * dist

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calc x sls (fromIntegral n)
            else
                print $ 1 + (calc x (insert x sls) ((fromIntegral n) + 1))
    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sun 21 Oct 2012 04:36:40 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

--{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (elemIndex)
import Data.List (elemIndices)

median ls = head $ drop ((((length ls) + 1) `div` 2) - 1) ls

countDist x med sls len =
    if x == med
        then 0
        else if x < med
                then
                    medind - (head $ reverse $ elemIndices x sls)
                else
                    res - medind
                    where
                        medind  = (len + 1) `div` 2  - 1 -- index
                        res     =
                            let ans = elemIndex x sls
                            in case ans of
                                    Just(y) -> y
                                    Nothing -> 0

calc x sls len = calcAdditions x (median sls) (countDist x (median sls) sls len) len
    where
        calcAdditions x med dist len=
            if len `mod` 2 == 0
                then if x < med
                        then 2 * dist
                        else 2 * dist - 1
                else if x < med
                        then 2 * dist - 1
                        else 2 * dist

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calc x sls (fromIntegral n)
            else
                print $ 1 + (calc x (insert x sls) ((fromIntegral n) + 1))
    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sat 20 Oct 2012 07:44:58 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (findIndex)
import Data.List (findIndices)

median ls = head $ drop ((length ls) `div` 2) $ ls

calcAdditions :: Int->Int->Int
calcAdditions dist len =
    if len `mod` 2 == 0
        then
            (2 * dist)
        else
            2*dist

countDist x med sls =
    if x == med
        then
            0
        else
            if x < med
                then
                    ((length sls) `div` 2) - (head $ reverse $ findIndices (==x) sls)
                else
                    res - (length sls) `div` 2
                    where
                        res =
                            let
                                ans = findIndex (==x) sls
                            in
                                case ans of
                                    Just(x) -> x
                                    Nothing -> 0

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calcAdditions (countDist x (median sls) sls) (length sls)
            else
                print $ 1 + (calcAdditions (countDist x (median (insert x sls)) (insert x sls)) (length sls))

    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sat 20 Oct 2012 07:46:55 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (findIndex)
import Data.List (findIndices)

median ls = head $ drop ((length ls) `div` 2) $ ls

calcAdditions :: Int->Int->Int
calcAdditions dist len =
    if len `mod` 2 == 0
        then
            (2 * dist) - 1
        else
            2*dist

countDist x med sls =
    if x == med
        then
            0
        else
            if x < med
                then
                    ((length sls) `div` 2) - (head $ reverse $ findIndices (==x) sls)
                else
                    res - (length sls) `div` 2
                    where
                        res =
                            let
                                ans = findIndex (==x) sls
                            in
                                case ans of
                                    Just(x) -> x
                                    Nothing -> 0

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calcAdditions (countDist x (median sls) sls) (length sls)
            else
                print $ 1 + (calcAdditions (countDist x (median (insert x sls)) (insert x sls)) (length (insert x sls)))

    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

-- -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
-- File Name : 0001A.hs
-- Creation Date : 17-10-2012
-- Last Modified : Sat 20 Oct 2012 07:43:34 PM EEST
-- Created By : Greg Liras <gregliras@gmail.com>
--_._._._._._._._._._._._._._._._._._._._._.

{-# OPTIONS_GHC -O2 -optc-O2 #-}

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List (sort)
import Data.List (insert)
import Data.List (findIndex)
import Data.List (findIndices)

median ls = head $ drop ((length ls) `div` 2) $ ls

calcAdditions :: Int->Int->Int
calcAdditions dist len =
    if len `mod` 2 == 0
        then
            (2 * dist) - 1
        else
            2*dist

countDist x med sls =
    if x == med
        then
            0
        else
            if x < med
                then
                    ((length sls) `div` 2) - (head $ reverse $ findIndices (==x) sls)
                else
                    res - (length sls) `div` 2
                    where
                        res =
                            let
                                ans = findIndex (==x) sls
                            in
                                case ans of
                                    Just(x) -> x
                                    Nothing -> 0

main :: IO ()
main =
    do
        all <- BS.getContents
        let Just (n, r1)    = readInteger all
        let Just (x, r2)    = readInteger r1
        let (ls, _)         = readMany readInteger r2
        let sls = sort ls
        if x `elem` sls
            then
                print $ calcAdditions (countDist x (median sls) sls) (length sls)
            else
                print $ 1 + (calcAdditions (countDist x (median (insert x sls)) (insert x sls)) (length sls))

    where
        readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
            Just (x, r) ->  let
                                (xs, t) = readMany readf r
                            in
                                (x : xs, t)
            Nothing     ->  ([], s)

import Data.Char (isSpace)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Debug.Trace

countLess :: Integral a => [a] -> a -> a -> a -> (a,a)
countLess [] median count plithos = (count, plithos)
countLess (x:xs) median count plithos
	| x<median = countLess xs median (count+1) plithos
	| x==median = countLess xs median count (plithos+1)
	| otherwise = countLess xs median count plithos

calcMinNum length countLess 0
	| (countLess+1 == medPos) = 1
	| (countLess+1 > medPos) = 2*(countLess+1) - (length + 1)
	| (countLess+1 < medPos) = (length+1) + 1 - 2*(countLess+1)
	where medPos = (length + 2) `div` 2
calcMinNum length countLess plithos
	| (countLess+1 <= medPos) && (countLess + plithos >= medPos) = 0
	| (countLess+1 > medPos) = 2*(countLess+1) - 1 - length
	| (countLess + plithos < medPos) = length - 2*(countLess + plithos)
	where medPos = (length + 1) `div` 2

solve length median x =
	let
		(countLessRes, plithos) = countLess x median 0 0
	in
		calcMinNum length countLessRes plithos

main =
  do all <- BS.getContents
     let Just (length, r1) = readInteger all
     let Just (median, r2) = readInteger r1
     let  (x, _)  = readMany readInteger r2
     print (length)
     print (median)
     print (x)
     print (solve length median x)
    -- print ((count_less x median 0 0) == length `div` 2)
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.List

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

solve :: [Int] -> Int
solve (n:x:ys) = case map succ.elemIndices x $ ys' of
                   []  -> (\l->2*l-n+1).length.takeWhile (<x) $ ys'
                   (z:zs) | m`elem`(z:zs) -> 0
                          | m < z         -> z - m
                          | otherwise     -> m - last (z:zs)
   where m = (n+1)`div`2
         ys' = sort ys

import Data.List

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

solve :: [Int] -> Int
solve (_:x:ys)
  | notElem x ls = succ.abs $ (l-g)
  | l < g        = g-l
  | l > g + 1    = l-1-g
  | otherwise    = 0
   where (ls,gs) = partition (<=x) ys
         [l,g] = map length [ls,gs]

import Data.List

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

solve :: [Int] -> Int
solve (_:x:ys)
  | notElem x ls = succ.abs $ (l-g)
  | l < g        = g-l
  | otherwise    = max 0 (l-lx-g-lx+1)
   where (ls,gs) = partition (<=x) ys
         [l,g] = map length [ls,gs]
         lx = length.filter(x==)$ls

import Data.List

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

solve :: [Int] -> Int
solve (_:x:ys)
  | notElem x ls = succ.abs $ (l-g)
  | l < g        = g-l
  | otherwise    = max 0 (l-g-lx)
   where (ls,gs) = partition (<=x) ys
         [l,g] = map length [ls,gs]
         lx = length.filter(x==)$ls

import Data.List

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

solve :: [Int] -> Int
solve (_:x:ys)
  | notElem x ls = if l <= g then g-l else l-g+1
  | l < g        = g-l
  | otherwise    = max 0 (l-lx-g-lx+1)
   where (ls,gs) = partition (<=x) ys
         [l,g] = map length [ls,gs]
         lx = length.filter(x==)$ls

import Data.List

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

solve :: [Int] -> Int
solve (n:x:ys) = case map succ.elemIndices x $ ys' of
                   []  -> (\l->abs(2*l-n)+1).length.takeWhile (<x) $ ys'
                   (z:zs) | m`elem`(z:zs) -> 0
                          | m < z         -> z - m
                          | otherwise     -> m - last (z:zs)
   where m = (n+1)`div`2
         ys' = sort ys

solve :: Int ->  [Int] -> (Int, Int, Int) -> Int
solve x [] (l,e,g) = (final (l,e,g))
solve x (a:aa) (l,e,g) =
    if (a == x)
        then solve x aa (l,e+1,g)
        else if (a < x)
            then solve x aa (l+1,e,g)
            else solve x aa (l,e,g+1)

final :: (Int, Int, Int) -> Int
final (l,e,g) = if (l == g) then 0 else finall (l,e,g)

finall :: (Int, Int, Int) -> Int
finall (l,0,g) = 1 + finall (l,1,g)
finall (l,e,g) =
    if (l < g)
    then if (l + e >= g)
        then 0
        else (g - l - e)
    else if (l < e + g)
        then 0
        else (l - g - e + 1)

main =
  do m <- getLine
     let [n,x] = map read (words m)
     str <- getLine
     let a  = map read (words str)
     print (solve x a (0,0,0))


You have a rectangular chocolate bar consisting of n × m single squares. You want to eat exactly k squares, so you may need to break the chocolate bar. In one move you can break any single rectangular piece of chocolate in two rectangular pieces. You can break only by lines between squares: horizontally or vertically. The cost of breaking is equal to square of the break length.For example, if you have a chocolate bar consisting of 2 × 3 unit squares then you can break it horizontally and get two 1 × 3 pieces (the cost of such breaking is 32 = 9), or you can break it vertically in two ways and get two pieces: 2 × 1 and 2 × 2 (the cost of such breaking is 22 = 4).For several given values n, m and k find the minimum total cost of breaking. You can eat exactly k squares of chocolate if after all operations of breaking there is a set of rectangular pieces of chocolate with the total size equal to k squares. The remaining n·m - k squares are not necessarily form a single rectangular piece.

The first line of the input contains a single integer t (1 ≤ t ≤ 40910) — the number of values n, m and k to process. Each of the next t lines contains three integers n, m and k (1 ≤ n, m ≤ 30, 1 ≤ k ≤ min(n·m, 50)) — the dimensions of the chocolate bar and the number of squares you want to eat respectively.

For each n, m and k print the minimum total cost needed to break the chocolate bar, in order to make it possible to eat exactly k squares.

NoteIn the first query of the sample one needs to perform two breaks:  to split 2 × 2 bar into two pieces of 2 × 1 (cost is 22 = 4),  to split the resulting 2 × 1 into two 1 × 1 pieces (cost is 12 = 1). In the second query of the sample one wants to eat 3 unit squares. One can use exactly the same strategy as in the first query of the sample.

import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM)
import Data.Array (listArray, (!))
import Data.ByteString.Char8 (getLine, readInt, words)
import Data.Maybe (fromJust)
import Prelude hiding (getLine, words)

readInt' = fst . fromJust . readInt

main = do
	t <- readInt' <$> getLine
	ts <- map ((\[n, m, k] -> (n, m, k)) . map readInt' . words) <$> replicateM t getLine

	let as = listArray (head space, last space) $ map find space
		where
			space = (,,) <$> [0..30] <*> [0..30] <*> [0..50]

			find (n, m, k)
				| n*m == k = 0
				| k == 0 = 0
				| n*m <= 1 = 10^9
				| otherwise = (minimum $
					[m*m + as ! (n', m, k') + as ! ((n-n'), m, (k-k')) | n' <- [1..n `div` 2], k' <- [0..k]] ++
					[n*n + as ! (n, (m-m'), k') + as ! (n, m', (k-k')) | m' <- [1..m `div` 2], k' <- [0..k]])

	putStrLn $ unlines $ map (show . (as !)) ts


A country has n cities. Initially, there is no road in the country. One day, the king decides to construct some roads connecting pairs of cities. Roads can be traversed either way. He wants those roads to be constructed in such a way that it is possible to go from each city to any other city by traversing at most two roads. You are also given m pairs of cities — roads cannot be constructed between these pairs of cities.Your task is to construct the minimum number of roads that still satisfy the above conditions. The constraints will guarantee that this is always possible.

The first line consists of two integers n and m . Then m lines follow, each consisting of two integers ai and bi (1 ≤ ai, bi ≤ n, ai ≠ bi), which means that it is not possible to construct a road connecting cities ai and bi. Consider the cities are numbered from 1 to n. It is guaranteed that every pair of cities will appear at most once in the input.

You should print an integer s: the minimum number of roads that should be constructed, in the first line. Then s lines should follow, each consisting of two integers ai and bi (1 ≤ ai, bi ≤ n, ai ≠ bi), which means that a road should be constructed between cities ai and bi. If there are several solutions, you may print any of them.

NoteThis is one possible solution of the example:   These are examples of wrong solutions:   The above solution is wrong because it doesn't use the minimum number of edges (4 vs 3). In addition, it also tries to construct a road between cities 1 and 3, while the input specifies that it is not allowed to construct a road between the pair.   The above solution is wrong because you need to traverse at least 3 roads to go from city 1 to city 3, whereas in your country it must be possible to go from any city to another by traversing at most 2 roads.   Finally, the above solution is wrong because it must be possible to go from any city to another, whereas it is not possible in this country to go from city 1 to 3, 2 to 3, and 4 to 3.

import Control.Monad (liftM, replicateM)
import Data.Array (Array, (!), array, bounds)
import Data.Char (ord)
import Data.List (intercalate)

solve :: Int -> [(Int, Int)] -> [(Int, Int)]
solve n as  =  [(a, i) | i <- [1..n], i /= a]
  where
    a  =  head $ filter (not . elem') [1..n]
    elem' x  =  elem x (map fst as) || elem x (map snd as)

main :: IO ()
main  =  do
    [n, m]  <-  reads
    as  <-  replicateM m readPair
    print (n-1)
    mapM_ printPair $ solve n as
  where

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

    readPair :: Num a => IO (a, a)
    readPair  =  do
        [x, y]  <-  reads
        return (x, y)

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

    printPair :: Show a => (a, a) -> IO ()
    printPair (a, b)  =  prints [a,b]

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.List
import Data.Ord
import qualified Data.IntSet as IS

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

toPairs (x:y:xys) = (x,y) : toPairs xys
toPairs _ = []

main :: IO ()
main = do
  [n,m] <- map read.words <$> getLine
  edges <- map readInt.B.words <$> B.getContents
  let res = solve n edges
  print $ length res
  putStr.unlines.map(unwords.map show) $ res

solve :: Int -> [Int] -> [[Int]]
solve 1 _ = []
solve n [] = map (:[n]) [1..n-1]
solve n edges = go (IS.fromList [1..n]) edges
   where
     v = f [1..] . map head.group$ sort edges
     iset = IS.fromList [1..n]
     go !rest (from:to:es) = filter (not.null) $ filter(const$IS.member from rest)[v,from]:filter(const$IS.member to rest)[v,to]:go rest' es
      where
        rest' = IS.delete to.IS.delete from $ IS.delete v rest
     go rest _ = map (:[v]) $ IS.toList rest

f (i:is) (v:vs)
  | i==v = f is vs
  | otherwise = i
f (i:is) [] = i

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}

import Control.Applicative
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.List
import Data.Ord
import qualified Data.IntSet as IS

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

toPairs (x:y:xys) = (x,y) : toPairs xys
toPairs _ = []

main :: IO ()
main = do
  [n,m] <- map read.words <$> getLine
  edges <- map readInt.B.words <$> B.getContents
  let res = solve n edges
  print $ length res
  putStr.unlines.map(unwords.map show) $ res

solve :: Int -> [Int] -> [[Int]]
solve 1 _ = []
solve n [] = map (:[n]) [1..n-1]
solve n edges = go (IS.fromList [1..n]) edges
   where
     v = f [1..] $ sort edges
     iset = IS.fromList [1..n]
     go !rest (from:to:es) = [v,from]:[v,to]:go rest' es
      where
        rest' = IS.delete to.IS.delete from $ IS.delete v rest
     go rest _ = map (:[v]) $ IS.toList rest

f (i:is) (v:vs)
  | i==v = f is vs
  | otherwise = i
f (i:is) [] = i


You are given a positive integer $$$n$$$, it is guaranteed that $$$n$$$ is even (i.e. divisible by $$$2$$$).You want to construct the array $$$a$$$ of length $$$n$$$ such that:   The first $$$\frac{n}{2}$$$ elements of $$$a$$$ are even (divisible by $$$2$$$);  the second $$$\frac{n}{2}$$$ elements of $$$a$$$ are odd (not divisible by $$$2$$$);  all elements of $$$a$$$ are distinct and positive;  the sum of the first half equals to the sum of the second half ($$$\sum\limits_{i=1}^{\frac{n}{2}} a_i = \sum\limits_{i=\frac{n}{2} + 1}^{n} a_i$$$). If there are multiple answers, you can print any. It is not guaranteed that the answer exists.You have to answer $$$t$$$ independent test cases.

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

For each test case, print the answer — "NO" (without quotes), if there is no suitable answer for the given test case or "YES" in the first line and any suitable array $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^9$$$) satisfying conditions from the problem statement on the second line.

import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Text as T

process a | mod a 4>0 = putStrLn "NO"
	  | otherwise = do
				putStrLn "YES"
				let x= take (div a 2) [2,4..]
				let sx = sum x
				putStr $ intercalate " " $map show  x
				putStr " "
				let lx = length x
				let y =take ((div a 2)- 1) [1,3..]
				let sy =sum y
				putStr $ intercalate " " $ map show y
				putStrLn $ " "++ show (sx-sy)
main = do
		n<-   getLine
		a<- map read <$> lines  <$> getContents::IO [Int]
		mapM_ process a

process :: Int -> [Int]
process n
    | n `mod` 4 /= 0 = []
    | otherwise = take n2 [2,4..] ++ take (n2-1) [1,3..] ++ [n+n2-1]
    where n2 = n `div` 2

readInt :: String -> Int
readInt = read

run :: Int -> IO ()
run 0 = return ()
run t = do
    n <- fmap readInt getLine
    let as = process n
    if null as
        then putStrLn "NO"
        else do
            putStrLn "YES"
            putStrLn . unwords . map show $ as
    run (t-1)

main :: IO ()
main = do
    t <- fmap readInt getLine
    run t

import Data.List as L

solve :: Integer -> Maybe [Integer]
solve n
  | odd mid = Nothing
  | otherwise = Just (evens ++ someOdds ++ m)
  where mid = div n 2
        evens = (L.take (fromIntegral mid) [i | i <- [2..], even i])
        someOdds = (L.take (fromIntegral $ mid-2) [i | i <- [1..], odd i])
        sumEvens = L.sum evens
        sumOdds = L.sum someOdds
        m = magic (sumEvens - sumOdds) (if L.null someOdds then (-1) else (L.last someOdds))

magic :: Integer -> Integer -> [Integer]
magic n l = head [[a, b] | a <- [(l+2),(l+3)..n],
                           b <- [n, (n-1)..(l+2)],
                           odd a,
                           odd b,
                           a+b == n]

parse :: String -> String
parse input = case solve n of
                Just a -> "YES\n" ++ (L.intercalate " " $ map show a)
                Nothing -> "NO"
  where n = read input :: Integer

main :: IO ()
main = interact (unlines . L.map parse . tail . lines)

import Control.Monad

main = readLn >>= flip replicateM_ test

test = do
    n <- readLn :: IO Integer
    if odd (n `div` 2)
        then putStrLn "NO"
        else do
            putStrLn "YES"
            let as = (2 *) <$> [1 .. n `div` 4]
                a = 100000000
            putStrLn . unwords . map show $ ((a +) <$> as) ++ ((a -) <$> as) ++ ((a + 1 +) <$> as) ++ ((a - 1 -) <$> as)

interleave :: String -> [String] -> [String]
interleave _ []       = []
interleave c (x : xs) = x : c : (interleave c xs)

generateSecond :: [Int] -> Int -> [Int]
generateSecond []       _    = []
generateSecond (x : xs) sign = (x + sign * 1) : (generateSecond xs (-sign))

solveFor :: Int -> String
solveFor n
  | n `div` 2 `mod` 2 == 1
  = "NO"
  | otherwise
  = "YES\n" ++ concat (interleave " " (map show firstHalf)) ++ concat
    (interleave " " (map show $ generateSecond firstHalf 1))
  where firstHalf = map fst $ zip (iterate (10 +) 2) [1 .. (n `div` 2)]

solveCase :: IO ()
solveCase = do
  nLine <- getLine
  let n   = read nLine :: Int
  let res = solveFor n
  putStrLn res

main :: IO ()
main = do
  tline <- getLine
  let ts = read tline :: Int
  sequence_ [ solveCase | _ <- [1 .. ts] ]

import Control.Monad

main :: IO ()
main = do
  t <- readLn
  replicateM_ t routine

routine :: IO ()
routine = do
  n <- readLn
  putStrLn $ solve n

solve :: Int -> String
solve n
  |n `mod` 4 ==0 = "YES\n"++ (unwords.map show) l
  |otherwise = "NO"
  where
    l = [2,4..n] ++ [1,3..(n-3)] ++ [(n*3 `div` 2)-1]

import Data.List

evens :: Int -> [Int]
evens n = [s + 2, s + 4]
  where s = 6 * n

odds :: Int -> [Int]
odds n = [s + 1, s + 5]
  where s = 6 * n

makeList :: Int -> [Int]
makeList n = evenList ++ oddList
  where evenList = concat $ map evens [1..e]
        oddList = concat $ map odds [1..e]
        e = div n 4

stringify :: [Int] -> String
stringify x = unwords $ map show x

test :: String -> String
test s
  | rem n 4 /= 0 = "NO"
  | otherwise = "YES\n" ++ (stringify $ makeList n)
  where n = read s :: Int

main = do
  getLine
  interact $ unlines . map test . lines

import Control.Monad (replicateM_)

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

solveIO :: IO ()
solveIO = readLn >>= putStrLn . decorate . f where
    decorate Nothing = "NO"
    decorate (Just xs) = "YES\n" ++ (unwords . map show) xs

f :: Int -> Maybe [Int]
f n = if n `mod` 4 /= 0 then Nothing else Just $
    let k = n `div` 2
        p1 = take k [2,4..]
        p2 = take (k-1) [1,3..]
    in p1 ++ p2 ++[sum p1 - sum p2]

import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Text as T

process a | mod a 2>0 = putStrLn "NO"
	  | otherwise = do
				putStrLn "YES"
				let x= take a [2,4..]
				let sx = sum x
				putStr $ intercalate " " $map show  x
				putStr " "
				let lx = length x
				let y =take (a- 1) [1,3..]
				let sy =sum y
				putStr $ intercalate " " $ map show y
				putStrLn $ " "++ show (sx-sy)
main = do
		n<-   getLine
		a<- map read <$> lines  <$> getContents::IO [Int]
		mapM_ process a

import Control.Monad

main = readLn >>= flip replicateM_ test

test = do
    n <- readLn :: IO Integer
    if odd (n `div` 2)
        then putStrLn "NO"
        else do
            putStrLn "YES"
            let as = (2 *) <$> [1 .. n `div` 4]
                a = 100000000
            putStrLn . unwords . map show $ ((a +) <$> as) ++ ((a -) <$> as) ++ ((a + 1 +) <$> as) ++ ((a - 1 +) <$> as)

interleave :: String -> [String] -> [String]
interleave _ []       = []
interleave c (x : xs) = x : c : (interleave c xs)

generateSecond :: [Int] -> Int -> [Int]
generateSecond []       _    = []
generateSecond (x : xs) sign = (x + sign * 1) : (generateSecond xs (-sign))

solveFor :: Int -> String
solveFor n
  | n `div` 2 `mod` 2 == 1
  = "NO"
  | otherwise
  = "YES\n" ++ concat (interleave " " (map show firstHalf)) ++ concat
    (interleave " " (map show $ generateSecond firstHalf 1))
  where firstHalf = map fst $ zip (iterate (10 +) 2) [1 .. n]

solveCase :: IO ()
solveCase = do
  nLine <- getLine
  let n   = read nLine :: Int
  let res = solveFor n
  putStrLn res

main :: IO ()
main = do
  tline <- getLine
  let ts = read tline :: Int
  sequence_ [ solveCase | _ <- [1 .. ts] ]

import Data.List

quad :: Int -> [Int]
quad n = [s + 2, s + 4, s + 1, s + 5]
  where s = 6 * n

makeList :: Int -> [Int]
makeList n = foldl1 (++) (map quad [1..(div n 4)])

stringify :: [Int] -> String
stringify x = unwords $ map show x

test :: String -> String
test s
  | rem n 4 /= 0 = "NO"
  | otherwise = "YES\n" ++ (stringify $ makeList n)
  where n = read s :: Int

main = do
  getLine
  interact $ unlines . map test . lines

import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Text as T

process a | mod a 4>0 = putStrLn "NO"
	  | otherwise = do
				putStrLn "YES"
				let x= take a [2,4..]
				let sx = sum x
				putStr $ intercalate " " $map show  x
				putStr " "
				let lx = length x
				let y =take (a- 1) [1,3..]
				let sy =sum y
				putStr $ intercalate " " $ map show y
				putStrLn $ " "++ show (sx-sy)
main = do
		n<-   getLine
		a<- map read <$> lines  <$> getContents::IO [Int]
		mapM_ process a


You have an array a[1], a[2], ..., a[n], containing distinct integers from 1 to n. Your task is to sort this array in increasing order with the following operation (you may need to apply it multiple times):  choose two indexes, i and j (1 ≤ i < j ≤ n; (j - i + 1) is a prime number);  swap the elements on positions i and j; in other words, you are allowed to apply the following sequence of assignments: tmp = a[i], a[i] = a[j], a[j] = tmp (tmp is a temporary variable). You do not need to minimize the number of used operations. However, you need to make sure that there are at most 5n operations.

The first line contains integer n (1 ≤ n ≤ 105). The next line contains n distinct integers a[1], a[2], ..., a[n] (1 ≤ a[i] ≤ n).

In the first line, print integer k (0 ≤ k ≤ 5n) — the number of used operations. Next, print the operations. Each operation must be printed as "i j" (1 ≤ i < j ≤ n; (j - i + 1) is a prime). If there are multiple answers, you can print any of them.

{-# LANGUAGE BangPatterns #-}

import Text.Printf

import Data.Array.IO
import qualified Data.Array.MArray as M
import qualified Data.Array.IArray as I
import Data.Array.Unboxed
import Control.Monad
import Data.Int

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Data.Char

readInt :: IO Int
readInt = do line <- BS.getLine
             let Just (n,_) = BS.readInt line
             return n

parseInts :: Int -> ByteString -> [Int]
parseInts k bs | k <= 0 = []
parseInts k bs = case BS.readInt (BS.dropWhile isSpace bs) of
                   Nothing -> []
                   Just (n,bs') -> n : parseInts (k-1) bs'

isqrt :: Integral a => a -> Int
isqrt n = floor $ sqrt ((fromIntegral n) :: Double)

sieve arr = do
  (_,hi) <- getBounds arr
  let maxi = isqrt hi
  forM_ [2..maxi] $ \i -> do
    v <- readArray arr i
    if v == 0
      then let v = i*i in forM_ [v,v+i..hi] $ \j -> writeArray arr j (fromIntegral i)
      else return ()

genPrimes :: Integral a => Int -> IO [a]
genPrimes n = do
  parr' <- newArray (2,n) 0 :: IO (IOUArray Int Int)
  sieve parr'
  parr <- M.freeze parr' :: IO (UArray Int Int)
  let primes = map (fromIntegral.fst) $ filter (\(i,v) -> v == 0) $ I.assocs parr
  return primes

ind :: Integral a => a -> a -> (Int,a)
ind p n = go 0 n
  where go !k m = case m `divMod` p of
                    (q,0)     -> go (k+1) q
                    otherwise -> (k,m)

factor :: Integral a => [a] -> a -> [(a,Int)]
factor [] n
  | n == 1 = []
  | otherwise = [(n,1)]  -- assume n is prime
factor (p:ps) n = case ind p n of
                    (0,_) -> factor ps n
                    (k,m) -> (p,k) : factor ps m

prod :: Integral a => [(a,Int)] -> a
prod = product . map (\(p,k) -> p^k)

solve :: UArray Int Int -> Int -> [Int] -> IO (Int,[(Int,Int)])
solve largestP n ns = do
  nums <- newArray (1,n) 0 :: IO (IOUArray Int Int)
  inv  <- newArray (1,n) 0 :: IO (IOUArray Int Int)
  swapi <- newArray (0,5*n) 0 :: IO (IOUArray Int Int)
  swapj <- newArray (0,5*n) 0 :: IO (IOUArray Int Int)
  forM_ (zip [1..] ns) $ \(i,a) -> do writeArray nums i a; writeArray inv a i
  let loop s i =   -- nums[j] = i
        do j <- readArray inv i
           let d = j - i + 1
           if d < 2
             then return s
             else do let p = largestP ! d
                     -- swap nums[j-p+1] and nums[j]
                     writeArray swapi s (j-p+1)
                     writeArray swapj s j
                     a <- readArray nums (j-p+1)
                     let b = i
                     writeArray nums (j-p+1) b
                     writeArray nums j       a
                     -- before: nums[j-p+1] = a  --> inv[a] = j-p+1
                     --         nums[j]     = b  --> inv[b] = j
                     -- swap inv[a] and inv[b]
                     writeArray inv  b       (j-p+1)
                     writeArray inv  a       j
                     loop (s+1) i
  s <- foldM loop 0 [1..n]
  swapi' <- M.freeze swapi :: IO (UArray Int Int)
  swapj' <- M.freeze swapj :: IO (UArray Int Int)
  let swaps = [ (swapi' ! k, swapj' ! k) | k <- [0..s-1] ]
  return $ (s, swaps)

check :: UArray Int Int -> Int -> [Int] -> IO Bool
check largestP n ns = do
  (s,swaps) <- solve largestP n ns
  arr <- newArray (1,n) 0 :: IO (IOUArray Int Int)
  forM_ (zip [1..] ns) $ \(i,a) -> do writeArray arr i a
  -- execute the swaps
  forM_ swaps $ \(i,j) -> do
    a <- readArray arr i
    b <- readArray arr j
    writeArray arr i b
    writeArray arr j a
  -- make sure arr[i] == i
  arr' <- M.freeze arr :: IO (UArray Int Int)
  let ok1 = all (\i -> arr' ! i == i) [1..n]
  if not ok1
    then do putStrLn "not sorted: "
            forM_ [1..n] $ \i -> putStr $ " " ++ show (arr' ! i)
    else return ()
  let ok2 = s <= 5*n
  if not ok2
    then putStrLn $ "too many swaps: " ++ show s
    else return ()
  return $ ok1 && ok2

makeLargestP :: Int -> IO (UArray Int Int)
makeLargestP n = do
  primes' <- newArray (2,n) 0 :: IO (IOUArray Int Int)
  sieve primes'
  primes <- M.freeze primes' :: IO (UArray Int Int)
  largestP' <- newArray (0,n) 0 :: IO (IOUArray Int Int)
  let go p i = do let p' = if primes ! i == 0 then i else p
                  writeArray largestP' i p'
                  return p'
  foldM_ go 2 [2..n]
  M.freeze largestP' :: IO (UArray Int Int)

mainCheck = do
  n <- fmap read getLine
  largestP <- makeLargestP n
  ns <- fmap (parseInts n) BS.getLine
  check largestP n ns

mainSolve = do
  n <- fmap read getLine
  largestP <- makeLargestP n
  ns <- fmap (parseInts n) BS.getLine
  (s,swaps) <- solve largestP n ns
  print s
  forM_ swaps $ \(i,j) -> do
    putStrLn $ (show i) ++ " " ++ (show j)
  return ()

main = mainSolve

{-# LANGUAGE TupleSections #-}

-- For Input
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
--import qualified Data.ByteString.Lex.Double as BSD
import Data.Char (isSpace)
import Data.IORef
import Text.Printf

--import Test.QuickCheck
--import Test.QuickCheck.Property
--import Data.List.Ordered (isSorted)

-- Data Structure Imports
import Data.Maybe
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- These should be imported by default... :)
import Control.Monad
import Control.Applicative
import Control.Arrow

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

import Debug.Trace

--------------------------------------------------------------------------------
------------------------------- SOLUTION ---------------------------------------
--------------------------------------------------------------------------------

primesUpTo :: Int -> Set Int
primesUpTo n = Set.fromList [p | (p, True) <- assocs $ sieve n]

sieve :: Int -> UArray Int Bool
sieve n = runSTUArray $ do
    sieve <- newArray (2, n) True
    forM_ [2..n] $ \p -> do
        isPrime <- readArray sieve p
        when isPrime $ do
            forM_ [p*2, p*3 .. n] $ \k -> do
                writeArray sieve k False
    return sieve

lim :: Int
lim = 100000

primes :: Set Int
primes = primesUpTo lim

isPrime :: Int -> Bool
isPrime n = Set.member n primes

goldbach :: Int -> (Int, Int)
goldbach n =
  head $ concatMap (\x -> if Set.member (n-x) primes then [(x,n-x)] else [])
       $ Set.toList primes

--goldbachs :: UArray Int (Int,Int)
--goldbachs = listArray (4,lim) $ map goldbach [4..lim]

operations :: Int -> Int -> [(Int,Int)]
operations i j
    | diff == 0 = []
    | diff <= 2 = [(i,j)]
    | diff + 1 <= 9 = doGoldbach diff
    | even diff = doGoldbach diff
    | otherwise = (j-1,j):operations i (j-1)
    where diff = j - i
          doGoldbach n =
              let (x,y) = goldbach (n+2)
              in [(i+x-1,j), (i, i+x-1)]
                         -- i+x-1-i+1=x
                         -- x+y-1-x+1=y
opsCorrect :: Int -> Int -> Bool
opsCorrect i j
    | i < 0 || j < 0 = opsCorrect (abs i) (abs j)
    | i > j = opsCorrect j i
    | otherwise =
                   let ops = operations i j
                       walk [] = True
                       walk ((x,y):t) =
                           isPrime (y-x+1) && walk t
                   in walk ops

walkOps :: IOUArray Int Int -> [(Int,Int)] -> Set (Int,Int) ->
           IO (Set (Int,Int))
walkOps a [] heap = return heap
walkOps a ((i,j):t) heap = do
--  elems <- getElems a
--  putStrLn $ show ("Calling walkOps with", elems, i, j, heap, t)
  vi <- readArray a i
  vj <- readArray a j
  writeArray a i vj
  writeArray a j vi
  let heap' = Set.delete (vi,i) . Set.delete (vj,j)
              . Set.insert (vj,i) . Set.insert (vi,j) $ heap
--  putStrLn $ show ("New heap will be", heap')
  heap' `seq` walkOps a t heap'

printOps :: [(Int,Int)] -> IO ()
printOps ops = forM_ ops $ \(i,j) -> putStrLn $ show i ++ " " ++ show j

solve :: IOUArray Int Int -> Set (Int,Int) -> Int -> Int -> IO [(Int,Int)]
solve a heap i k | i > k = return []
                 | otherwise = do
--  elems <- getElems a
--  putStrLn $ show ("Calling solve with", elems, i, heap)
  let (mv,mi) = Set.findMin heap
      ops     = operations i mi
  heap' <- walkOps a ops heap
  let heap'' = Set.delete (i,mv) heap'
  fmap (ops++) $ solve a heap'' (i+1) k

main :: IO ()
main = do
  all   <- BS.getContents
  input <- newIORef all
  let parse = next input
  k <- parse int
  a <- parse $ intMany k
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  putStrLn $ show $ length ops
  printOps ops
--  elems <- getElems a'
--  putStrLn $ show elems

{-
main :: IO ()
main = quickCheck $ forAllShrink (fmap abs arbitrary) shrink $ \n ->
         forAll (permute [1..n]) $ \a ->
             prop a

permute :: [Int] -> Gen [Int]
permute [] = return []
permute l  = elements l >>= (\x -> fmap (x:) (permute $ delete x l))

prop :: [Int] -> Property
prop a = morallyDubiousIOProperty $ do
  let k = length a
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  elems <- getElems a'
  return $ isSorted elems
-}
--------------------------------------------------------------------------------
-------------------------- IO Function Helpers ---------------------------------
--------------------------------------------------------------------------------

type Parser a = BSC.ByteString -> (a, BSC.ByteString)

int :: Parser Int
int = second (BSC.dropWhile isSpace) . fromJust . BSC.readInt

int2 :: Parser (Int, Int)
int2 = uncurry (first . (,)) . second int . int

int3 :: Parser (Int, Int, Int)
int3 = uncurry (first . (uncurry (,,))) . second int . int2

--double :: Parser Double
--double = second (BSC.dropWhile isSpace) . fromJust . BSD.readDouble

char :: Parser Char
char = BSC.head &&& BSC.tail

letter :: Parser Char
letter = second (BSC.dropWhile isSpace) . char

string :: Parser String
string = (BSC.unpack *** BSC.dropWhile isSpace) . BSC.span (not . isSpace)

readMany :: Parser a -> Int -> Parser [a]
readMany f n bs = first reverse $
                  foldr (\_ (l,bs) -> first (:l) $ f bs) ([],bs) [1..n]

intMany :: Int -> Parser [Int]
intMany = readMany int

next :: IORef BSC.ByteString -> Parser a -> IO a
next input parse = do
  bs <- readIORef input
  let (x, bs') = parse bs
  writeIORef input bs'
  return x

{- CODE JAM input

  cases <- parse int
  forM_ [1..cases] $ \caseNum -> do
         -- Read Data
         -- let solution =
         -- solution <-
         printf "Case #%d: %d\n" caseNum solution
-}

{-# LANGUAGE TupleSections #-}

-- For Input
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
--import qualified Data.ByteString.Lex.Double as BSD
import Data.Char (isSpace)
import Data.IORef
import Text.Printf

-- Data Structure Imports
import Data.Maybe
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- These should be imported by default... :)
import Control.Monad
import Control.Applicative
import Control.Arrow

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

import Debug.Trace

--------------------------------------------------------------------------------
------------------------------- SOLUTION ---------------------------------------
--------------------------------------------------------------------------------

primesUpTo :: Int -> Set Int
primesUpTo n = Set.fromList [p | (p, True) <- assocs $ sieve n]

sieve :: Int -> UArray Int Bool
sieve n = runSTUArray $ do
    sieve <- newArray (2, n) True
    forM_ [2..n] $ \p -> do
        isPrime <- readArray sieve p
        when isPrime $ do
            forM_ [p*2, p*3 .. n] $ \k -> do
                writeArray sieve k False
    return sieve

lim :: Int
lim = 100000

primes :: Set Int
primes = primesUpTo lim

isPrime :: Int -> Bool
isPrime n = Set.member n primes

goldbach :: Int -> (Int, Int)
goldbach n = head $ concatMap (\x -> if Set.member (n-x) primes then [(x,n-x)]
                                     else [])
             $ Set.toList primes

--goldbachs :: UArray Int (Int,Int)
--goldbachs = listArray (4,lim) $ map goldbach [4..lim]

operations :: Int -> Int -> [(Int,Int)]
operations i j
    | j == i = []
    | j == i + 1 = [(i,j)]
    | j == i + 2 = [(i,j)]
    | otherwise  =
        let (x,y) = goldbach (j - i + 1) in
        [(i+x-1,j), (i, i+x-1)]

walkOps :: IOUArray Int Int -> [(Int,Int)] -> Set (Int,Int) ->
           IO (Set (Int,Int))
walkOps a [] heap = return heap
walkOps a ((i,j):t) heap = do
  vi <- readArray a i
  vj <- readArray a j
  writeArray a i vj
  writeArray a j vi
  return $ Set.delete (i,vi) $ Set.delete (j,vj)
         $ Set.insert (i,vj) $ Set.insert (j,vi) $ heap

printOps :: [(Int,Int)] -> IO ()
printOps ops = forM_ ops $ \(i,j) -> putStrLn $ show i ++ " " ++ show j

solve :: IOUArray Int Int -> Set (Int,Int) -> Int -> Int -> IO [(Int,Int)]
solve a heap i k | i > k = return []
                 | otherwise = do
  let (mv,mi) = Set.findMin heap
      ops     = operations i mi
  heap' <- walkOps a ops heap
  let heap'' = Set.delete (i,mv) heap'
  fmap (ops++) $ solve a heap'' (i+1) k

main :: IO ()
main = do
  all   <- BS.getContents
  input <- newIORef all
  let parse = next input
  k <- parse int
  a <- parse $ intMany k
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  putStrLn $ show $ length ops
  printOps ops

--------------------------------------------------------------------------------
-------------------------- IO Function Helpers ---------------------------------
--------------------------------------------------------------------------------

type Parser a = BSC.ByteString -> (a, BSC.ByteString)

int :: Parser Int
int = second (BSC.dropWhile isSpace) . fromJust . BSC.readInt

int2 :: Parser (Int, Int)
int2 = uncurry (first . (,)) . second int . int

int3 :: Parser (Int, Int, Int)
int3 = uncurry (first . (uncurry (,,))) . second int . int2

--double :: Parser Double
--double = second (BSC.dropWhile isSpace) . fromJust . BSD.readDouble

char :: Parser Char
char = BSC.head &&& BSC.tail

letter :: Parser Char
letter = second (BSC.dropWhile isSpace) . char

string :: Parser String
string = (BSC.unpack *** BSC.dropWhile isSpace) . BSC.span (not . isSpace)

readMany :: Parser a -> Int -> Parser [a]
readMany f n bs = first reverse $
                  foldr (\_ (l,bs) -> first (:l) $ f bs) ([],bs) [1..n]

intMany :: Int -> Parser [Int]
intMany = readMany int

next :: IORef BSC.ByteString -> Parser a -> IO a
next input parse = do
  bs <- readIORef input
  let (x, bs') = parse bs
  writeIORef input bs'
  return x

{- CODE JAM input

  cases <- parse int
  forM_ [1..cases] $ \caseNum -> do
         -- Read Data
         -- let solution =
         -- solution <-
         printf "Case #%d: %d\n" caseNum solution
-}

{-# LANGUAGE TupleSections #-}

-- For Input
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
--import qualified Data.ByteString.Lex.Double as BSD
import Data.Char (isSpace)
import Data.IORef
import Text.Printf

--import Test.QuickCheck
--import Test.QuickCheck.Property
--import Data.List.Ordered (isSorted)

-- Data Structure Imports
import Data.Maybe
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- These should be imported by default... :)
import Control.Monad
import Control.Applicative
import Control.Arrow

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

import Debug.Trace

--------------------------------------------------------------------------------
------------------------------- SOLUTION ---------------------------------------
--------------------------------------------------------------------------------

primesUpTo :: Int -> Set Int
primesUpTo n = Set.fromList [p | (p, True) <- assocs $ sieve n]

sieve :: Int -> UArray Int Bool
sieve n = runSTUArray $ do
    sieve <- newArray (2, n) True
    forM_ [2..n] $ \p -> do
        isPrime <- readArray sieve p
        when isPrime $ do
            forM_ [p*2, p*3 .. n] $ \k -> do
                writeArray sieve k False
    return sieve

lim :: Int
lim = 100000

primes :: Set Int
primes = primesUpTo lim

isPrime :: Int -> Bool
isPrime n = Set.member n primes

goldbach :: Int -> (Int, Int)
goldbach n =
  head $ concatMap (\x -> if Set.member (n-x) primes then [(x,n-x)] else [])
       $ Set.toList primes

--goldbachs :: UArray Int (Int,Int)
--goldbachs = listArray (4,lim) $ map goldbach [4..lim]

operations :: Int -> Int -> [(Int,Int)]
operations i j
    | diff == 0 = []
    | diff <= 2 = [(i,j)]
    | diff + 1 <= 9 = doGoldbach (diff + 1)
    | even (diff + 1) = doGoldbach (diff + 1)
    | otherwise = (j-3,j):operations i (j-3)
    where diff = j - i
          doGoldbach n = let (x,y) = goldbach n
                         in [(i+x-1,j), (i, i+x-1)]

walkOps :: IOUArray Int Int -> [(Int,Int)] -> Set (Int,Int) ->
           IO (Set (Int,Int))
walkOps a [] heap = return heap
walkOps a ((i,j):t) heap = do
--  elems <- getElems a
--  putStrLn $ show ("Calling walkOps with", elems, i, j, heap, t)
  vi <- readArray a i
  vj <- readArray a j
  writeArray a i vj
  writeArray a j vi
  let heap' = Set.delete (vi,i) . Set.delete (vj,j)
              . Set.insert (vj,i) . Set.insert (vi,j) $ heap
--  putStrLn $ show ("New heap will be", heap')
  heap' `seq` walkOps a t heap'

printOps :: [(Int,Int)] -> IO ()
printOps ops = forM_ ops $ \(i,j) -> putStrLn $ show i ++ " " ++ show j

solve :: IOUArray Int Int -> Set (Int,Int) -> Int -> Int -> IO [(Int,Int)]
solve a heap i k | i > k = return []
                 | otherwise = do
--  elems <- getElems a
--  putStrLn $ show ("Calling solve with", elems, i, heap)
  let (mv,mi) = Set.findMin heap
      ops     = operations i mi
  heap' <- walkOps a ops heap
  let heap'' = Set.delete (i,mv) heap'
  fmap (ops++) $ solve a heap'' (i+1) k

main :: IO ()
main = do
  all   <- BS.getContents
  input <- newIORef all
  let parse = next input
  k <- parse int
  a <- parse $ intMany k
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  putStrLn $ show $ length ops
  printOps ops
--  elems <- getElems a'
--  putStrLn $ show elems
{-
permute :: [Int] -> Gen [Int]
permute [] = return []
permute l  = elements l >>= (\x -> fmap (x:) (permute $ delete x l))

prop :: [Int] -> Property
prop a = morallyDubiousIOProperty $ do
  let k = length a
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  elems <- getElems a'
  return $ isSorted elems
-}
--------------------------------------------------------------------------------
-------------------------- IO Function Helpers ---------------------------------
--------------------------------------------------------------------------------

type Parser a = BSC.ByteString -> (a, BSC.ByteString)

int :: Parser Int
int = second (BSC.dropWhile isSpace) . fromJust . BSC.readInt

int2 :: Parser (Int, Int)
int2 = uncurry (first . (,)) . second int . int

int3 :: Parser (Int, Int, Int)
int3 = uncurry (first . (uncurry (,,))) . second int . int2

--double :: Parser Double
--double = second (BSC.dropWhile isSpace) . fromJust . BSD.readDouble

char :: Parser Char
char = BSC.head &&& BSC.tail

letter :: Parser Char
letter = second (BSC.dropWhile isSpace) . char

string :: Parser String
string = (BSC.unpack *** BSC.dropWhile isSpace) . BSC.span (not . isSpace)

readMany :: Parser a -> Int -> Parser [a]
readMany f n bs = first reverse $
                  foldr (\_ (l,bs) -> first (:l) $ f bs) ([],bs) [1..n]

intMany :: Int -> Parser [Int]
intMany = readMany int

next :: IORef BSC.ByteString -> Parser a -> IO a
next input parse = do
  bs <- readIORef input
  let (x, bs') = parse bs
  writeIORef input bs'
  return x

{- CODE JAM input

  cases <- parse int
  forM_ [1..cases] $ \caseNum -> do
         -- Read Data
         -- let solution =
         -- solution <-
         printf "Case #%d: %d\n" caseNum solution
-}

{-# LANGUAGE TupleSections #-}

-- For Input
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
--import qualified Data.ByteString.Lex.Double as BSD
import Data.Char (isSpace)
import Data.IORef
import Text.Printf

-- Data Structure Imports
import Data.Maybe
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- These should be imported by default... :)
import Control.Monad
import Control.Applicative
import Control.Arrow

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

import Debug.Trace

--------------------------------------------------------------------------------
------------------------------- SOLUTION ---------------------------------------
--------------------------------------------------------------------------------

primesUpTo :: Int -> Set Int
primesUpTo n = Set.fromList [p | (p, True) <- assocs $ sieve n]

sieve :: Int -> UArray Int Bool
sieve n = runSTUArray $ do
    sieve <- newArray (2, n) True
    forM_ [2..n] $ \p -> do
        isPrime <- readArray sieve p
        when isPrime $ do
            forM_ [p*2, p*3 .. n] $ \k -> do
                writeArray sieve k False
    return sieve

lim :: Int
lim = 100000

primes :: Set Int
primes = primesUpTo lim

isPrime :: Int -> Bool
isPrime n = Set.member n primes

goldbach :: Int -> (Int, Int)
goldbach n = head $ concatMap (\x -> if Set.member (n-x) primes then [(x,n-x)]
                                     else [])
             $ Set.toList primes

--goldbachs :: UArray Int (Int,Int)
--goldbachs = listArray (4,lim) $ map goldbach [4..lim]

operations :: Int -> Int -> [(Int,Int)]
operations i j
    | j == i = []
    | j == i + 1 = [(i,j)]
    | j == i + 2 = [(i,j)]
    | otherwise  =
        let (x,y) = goldbach (j - i + 1) in
        [(i+x-1,j), (i, i+x-1)]

walkOps :: IOUArray Int Int -> [(Int,Int)] -> Set (Int,Int) ->
           IO (Set (Int,Int))
walkOps a [] heap = return heap
walkOps a ((i,j):t) heap = do
--  elems <- getElems a
--  putStrLn $ show ("Calling walkOps with", elems, i, j, heap, t)
  vi <- readArray a i
  vj <- readArray a j
  writeArray a i vj
  writeArray a j vi
  let heap' = Set.delete (vi,i) . Set.delete (vj,j)
              . Set.insert (vj,i) . Set.insert (vi,j) $ heap
--  putStrLn $ show ("New heap will be", heap')
  heap' `seq` walkOps a t heap'

printOps :: [(Int,Int)] -> IO ()
printOps ops = forM_ ops $ \(i,j) -> putStrLn $ show i ++ " " ++ show j

solve :: IOUArray Int Int -> Set (Int,Int) -> Int -> Int -> IO [(Int,Int)]
solve a heap i k | i > k = return []
                 | otherwise = do
--  elems <- getElems a
--  putStrLn $ show ("Calling solve with", elems, i, heap)
  let (mv,mi) = Set.findMin heap
      ops     = operations i mi
  heap' <- walkOps a ops heap
  let heap'' = Set.delete (i,mv) heap'
  fmap (ops++) $ solve a heap'' (i+1) k

main :: IO ()
main = do
  all   <- BS.getContents
  input <- newIORef all
  let parse = next input
  k <- parse int
  a <- parse $ intMany k
  a' <- newListArray (1,k) a :: IO (IOUArray Int Int)
  let heap = Set.fromList $ zipWith (,) a [1..k]
  ops <- solve a' heap 1 k
  putStrLn $ show $ length ops
  printOps ops
--  elems <- getElems a'
--  putStrLn $ show elems

--------------------------------------------------------------------------------
-------------------------- IO Function Helpers ---------------------------------
--------------------------------------------------------------------------------

type Parser a = BSC.ByteString -> (a, BSC.ByteString)

int :: Parser Int
int = second (BSC.dropWhile isSpace) . fromJust . BSC.readInt

int2 :: Parser (Int, Int)
int2 = uncurry (first . (,)) . second int . int

int3 :: Parser (Int, Int, Int)
int3 = uncurry (first . (uncurry (,,))) . second int . int2

--double :: Parser Double
--double = second (BSC.dropWhile isSpace) . fromJust . BSD.readDouble

char :: Parser Char
char = BSC.head &&& BSC.tail

letter :: Parser Char
letter = second (BSC.dropWhile isSpace) . char

string :: Parser String
string = (BSC.unpack *** BSC.dropWhile isSpace) . BSC.span (not . isSpace)

readMany :: Parser a -> Int -> Parser [a]
readMany f n bs = first reverse $
                  foldr (\_ (l,bs) -> first (:l) $ f bs) ([],bs) [1..n]

intMany :: Int -> Parser [Int]
intMany = readMany int

next :: IORef BSC.ByteString -> Parser a -> IO a
next input parse = do
  bs <- readIORef input
  let (x, bs') = parse bs
  writeIORef input bs'
  return x

{- CODE JAM input

  cases <- parse int
  forM_ [1..cases] $ \caseNum -> do
         -- Read Data
         -- let solution =
         -- solution <-
         printf "Case #%d: %d\n" caseNum solution
-}


Polycarp has $$$n$$$ friends, the $$$i$$$-th of his friends has $$$a_i$$$ candies. Polycarp's friends do not like when they have different numbers of candies. In other words they want all $$$a_i$$$ to be the same. To solve this, Polycarp performs the following set of actions exactly once:   Polycarp chooses $$$k$$$ ($$$0 \le k \le n$$$) arbitrary friends (let's say he chooses friends with indices $$$i_1, i_2, \ldots, i_k$$$);  Polycarp distributes their $$$a_{i_1} + a_{i_2} + \ldots + a_{i_k}$$$ candies among all $$$n$$$ friends. During distribution for each of $$$a_{i_1} + a_{i_2} + \ldots + a_{i_k}$$$ candies he chooses new owner. That can be any of $$$n$$$ friends. Note, that any candy can be given to the person, who has owned that candy before the distribution process. Note that the number $$$k$$$ is not fixed in advance and can be arbitrary. Your task is to find the minimum value of $$$k$$$.For example, if $$$n=4$$$ and $$$a=[4, 5, 2, 5]$$$, then Polycarp could make the following distribution of the candies:   Polycarp chooses $$$k=2$$$ friends with indices $$$i=[2, 4]$$$ and distributes $$$a_2 + a_4 = 10$$$ candies to make $$$a=[4, 4, 4, 4]$$$ (two candies go to person $$$3$$$). Note that in this example Polycarp cannot choose $$$k=1$$$ friend so that he can redistribute candies so that in the end all $$$a_i$$$ are equal.For the data $$$n$$$ and $$$a$$$, determine the minimum value $$$k$$$. With this value $$$k$$$, Polycarp should be able to select $$$k$$$ friends and redistribute their candies so that everyone will end up with the same number of candies.

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

For each test case output:    the minimum value of $$$k$$$, such that Polycarp can choose exactly $$$k$$$ friends so that he can redistribute the candies in the desired way;  "-1" if no such value $$$k$$$ exists.

import Control.Arrow ((>>>))

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

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

solve :: [Int] -> Int
solve xs
  | r == 0 = length $ filter (> q) xs
  | otherwise = -1
  where
    (q, r) = divMod (sum xs) (length xs)

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe)

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

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

solve :: [Int] -> Int
solve xs
  | tot `mod` n /= 0 = -1
  | otherwise = length $ filter (> tot `div` n) xs
  where
    n = length xs
    tot = sum xs

module Main where
import Data.Functor ((<&>))
import Control.Monad (forM, replicateM, replicateM_)
import Data.Foldable (traverse_)
import GHC.Float.RealFracMethods (ceilingDoubleInt, floorDoubleInt)
import Data.List (group)
import Data.Ratio ((%))
import Prelude hiding (floor)
import Control.Monad (forM_)

readInts :: IO [Int]
readInts = getLine <&> words <&> fmap read

readString :: IO String
readString = getLine

toDoubles :: (Functor f, Integral a) => f a -> f Double
toDoubles xs = (\x -> fromIntegral x :: Double) <$> xs

toDouble :: (Integral a) => a -> Double
toDouble = fromIntegral

ceil :: Double -> Int
ceil = ceilingDoubleInt

floor :: Double -> Int
floor = floorDoubleInt

main :: IO ()
main = do
  t:_ <- readInts
  replicateM_ t $ do
    n:_ <- readInts
    as <- readInts
    let
      s = sum as
      p = s `div` n
      ans
          | p * n == s = length . filter (> p) $ as
          | otherwise = -1
    print ans

--
-- 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 -O1 -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out > temp.txt  &&  diff -sdu -- output.txt temp.txt)  &&  echo OKAY  ||  echo ERROR

import Prelude
import Control.Monad
-- import Data.List

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

    (putStr . unlines . map solve) tcs

readTC = do
    _n <- readLn  :: IO Int
    readIListLn

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

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

solve nums | (m /= 0) = "-1" | otherwise = show $ length . filter (>avg) $ nums
  where
    s = sum nums
    len = length nums
    m = s `mod` len
    avg = s `div` len

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

printResult = do
    n <- readLn :: IO Int
    a <- readInts
    let s = sum a
        r = if mod s n > 0 then -1 else length $ filter (> div s n) a
    print r

main = do
    t <- readLn :: IO Int
    replicateM_ t printResult

import Control.Monad (forM_)
import Data.Set (fromList, size)

solve :: [Int] -> Int
solve arr = if r > 0 then -1 else length $ filter ffn arr
  where s = sum arr
        avg = div s $ length arr
        r = rem s $ length arr
        ffn x = x > avg

main :: IO ()
main = do
  t <- pure . read =<< getLine
  forM_ [1..t] $ \_ -> do
    _ <- getLine
    getLine >>= pure . map read . words >>= putStrLn . show . solve

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

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

printS = do
    n<-readLn::IO Int
    a<-readInts
    let s = sum a
    if (mod s n /= 0) then putStrLn"-1"
    else do
        let b = div s n
        print $ sum[1|x<-a,x>b]

main = do
    t<-readLn
    replicateM_ t printS

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Monad

main :: IO ()
main = do
  t :: Int <- read <$> getLine
  replicateM_ t do
    n :: Int <- read <$> getLine
    xs :: [Int] <- map read . words <$> getLine
    print $ solve n xs

solve :: Int -> [Int] -> Int
solve n xs
  | dividesFairly = length $ filter (> average) xs
  | otherwise = -1
 where
  total = sum xs
  dividesFairly = total `mod` n == 0
  average = total `div` n

--1538/problem/B. Friends and Candies

toInt :: String -> Int
toInt x = read x ::Int

getInts = do
    x <- getLine
    let y = (map$toInt)$words x
    return y

distribute_co::[Int]->Int->Int
distribute_co (hd:lst) ave
    |lst==[] =
        if hd>ave then 1 else 0
    |hd>ave =
        1+distribute_co lst ave
    |otherwise =
        distribute_co lst ave
distribute::Int->[Int]->Int
distribute n lst
    |mod (sum lst) n/=0 =
        -1
    |otherwise = do
        let ave=div (sum lst) (length lst)
        distribute_co lst ave

loop i f
    |i==1 = do
        n' <- getLine
        let n = toInt n'
        lst <- getInts

        print$f n lst

    |otherwise = do
        n' <- getLine
        let n = toInt n'
        lst <- getInts

        print$f n lst

        loop (i-1) f

main = do
    t' <- getLine
    let t = toInt t'

    loop t distribute

makeInteger :: [String] -> [Int]
makeInteger = map read

main :: IO()
main = do
    line <- getLine
    let t = (read line::Int)
    solve_multitest t

solve_multitest :: Int -> IO()
solve_multitest 0 = return ()
solve_multitest t = do
    solve_test
    solve_multitest (t - 1)

solve_test :: IO()
solve_test = do
    line <- getLine
    let n = (read line::Int)
    line <- getLine
    let inparr = words line
    let arr = makeInteger inparr
    let s = sum arr
    if (rem s n) /= 0 then
        putStrLn "-1"
    else
        putStrLn (show (count_larger_than_k arr (quot s n)))

count_larger_than_k :: [Int] -> Int -> Int
count_larger_than_k [] k = 0
count_larger_than_k a k = do
    if head a > k then
        1 + count_larger_than_k (tail a) k
    else
        count_larger_than_k (tail a) k

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Monoid
import System.IO
import qualified Data.ByteString.Char8 as C
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import Data.Char

ru, ri :: C.ByteString -> Int

ru = C.foldl' (\a c -> a * 10 - 48 + ord c) 0
ri s
  | C.head s == '-' = negate $ ru $ C.tail s
  | otherwise = ru s

test' :: [Int] -> Int
test' a
  | v /= 0 = -1
  | otherwise = length $ filter (> u) a
  where
    n = length a
    !s = sum a
    (!u, !v) = divMod s n

nl = char7 '\n'

test :: Builder -> Int -> [Int] -> Builder
test buf 0 _ = buf
test buf nt (n:a) = test (buf <> intDec (test' b) <> nl) (pred nt) c
  where
    (b, c) = splitAt n a

solve :: [Int] -> Builder
solve (nt:xs) = test mempty nt xs

main :: IO ()
main = hPutBuilder stdout . solve . map ri . C.words =<< C.getContents


Ivan has got an array of n non-negative integers a1, a2, ..., an. Ivan knows that the array is sorted in the non-decreasing order. Ivan wrote out integers 2a1, 2a2, ..., 2an on a piece of paper. Now he wonders, what minimum number of integers of form 2b (b ≥ 0) need to be added to the piece of paper so that the sum of all integers written on the paper equalled 2v - 1 for some integer v (v ≥ 0). Help Ivan, find the required quantity of numbers.

The first line contains integer n (1 ≤ n ≤ 105). The second input line contains n space-separated integers a1, a2, ..., an (0 ≤ ai ≤ 2·109). It is guaranteed that a1 ≤ a2 ≤ ... ≤ an.

Print a single integer — the answer to the problem.

NoteIn the first sample you do not need to add anything, the sum of numbers already equals 23 - 1 = 7.In the second sample you need to add numbers 20, 21, 22.

import Data.Map as M hiding (map)
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = print . solve . map (maybe 0 fst . B.readInt) . B.words =<< B.getContents

solve :: [Int] -> Int
solve (_ : as) = f 0 0 $ fromListWith (+) [(a, 1) | a <- as]
  where
  f s b as
    | M.null as = s
    | b < a = f (s + a - b) a as
    | otherwise = f (s + 1 - r) (b + 1) (if q > 0 then M.insertWith (+) (a + 1) q as' else as')
    where
    ((a, p), as') = M.deleteFindMin as
    (q, r) = p `quotRem` 2

import qualified Data.ByteString.Char8 as B

main :: IO ()
main = print . solve . map (maybe 0 fst . B.readInt) . B.words =<< B.getContents

solve :: [Int] -> Int
solve (_ : as) = f 0 0 as
  where
  f s _ [] = s
  f s b (a : as)
    | b < a = f (s + a - b) a (a : as)
    | otherwise = f (s + 1 - r) (b + 1) (replicate q (a + 1) ++ ys)
    where
    (xs, ys) = break (> a) (a : as)
    (q, r) = length xs `quotRem` 2

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

main :: IO ()
main = print . solve . map (maybe 0 fst . B.readInt) . B.words =<< B.getContents

solve :: [Int] -> Int
solve (_ : as) = f 0 0 $ map (\x -> (head x, length x)) $ group as
  where
  f s _ [] = s
  f s b ((a, p) : as)
    | b < a = f (s + a - b) a ((a, p) : as)
    | not (null as) && (c == a + 1) = f (s + 1 - r) (b + 1) ([(a + 1, x + q) | x + q > 0] ++ tail as)
    | otherwise = f (s + 1 - r) (b + 1) ([(a + 1, q) | q > 0] ++ as)
    where
    (q, r) = p `quotRem` 2
    (c, x) = head as

import Data.Map as M hiding (map)
import qualified Data.ByteString.Char8 as B

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

solve :: [Int] -> Int
solve (_ : as) = f 0 0 $ fromListWith (+) [(a, 1) | a <- as]
  where
  f s b as
    | M.null as = s
    | b < a = f (s + a - b) a as
    | otherwise = f (s + 1 - r) (b + 1) (if q > 0 then M.insertWith (+) (a + 1) q as' else as')
    where
    ((a, p), as') = M.deleteFindMin as
    (q, r) = p `quotRem` 2

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

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

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

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

solve :: [Int] -> Int
solve xs = go 0 0 $ go0 $ foldr insert Empty xs
   where
     go !res !x (y:ys)
       | x==y = go res (x+1) ys
       | otherwise = go (res+y-x) (y+1) ys
     go !res _ _ = res
     go0 Empty = []
     go0 (Fork x []) = [x]
     go0 heap
       | x == minElem heap' = go0 $ insert (x+1) $ deleteMin heap'
       | otherwise =  x : go0 heap'
      where
        (x, heap') = deleteFindMin heap

data Heap a = Empty | Fork a [Heap a]

isEmpty :: Ord a => Heap a -> Bool
isEmpty Empty = True
isEmpty _ = False

insert :: Ord a => a -> Heap a -> Heap a
insert x h = merge (Fork x []) h

minElem :: Heap a -> a
minElem (Fork x _) = x

deleteMin :: Ord a => Heap a -> Heap a
deleteMin (Fork _ hs) = mergePairs hs

deleteFindMin :: Ord a => Heap a -> (a, Heap a)
deleteFindMin (Fork x hs) = (x, mergePairs hs)

merge :: Ord a => Heap a -> Heap a -> Heap a
merge Empty hy = hy
merge hx Empty = hx
merge hx@(Fork x _) hy@(Fork y _)
  | x <= y    = join hx hy
  | otherwise = join hy hx
 where
   join (Fork x hs) h = Fork x (h:hs)

mergePairs :: Ord a => [Heap a] -> Heap a
mergePairs []       = Empty
mergePairs [x]      = x
mergePairs (x:y:hs) = merge (merge x y) (mergePairs hs)

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

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

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

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

solve :: [Int] -> Int
solve xs = go 0 0 $ until isOK step $ step xs
   where
     step = mergeAll.map calc.group
     go !res !x (y:ys)
       | x==y = go res (x+1) ys
       | otherwise = go (res+y-x) (y+1) ys
     go !res _ _ = res
     isOK (x:y:xs)
       | x<y = isOK (y:xs)
       | otherwise = False
     isOK _ = True

calc :: [Int] -> [Int]
calc [] = []
calc xs@(x:_) = go x $ length xs
   where
     go !x !l
       | l <= 1 = take l [x]
       | otherwise = let (q,r) = quotRem l 2
                     in if r==0
                           then go (x+1) q
                           else x : go (x+1) q

mergeAll :: [[Int]] -> [Int]
mergeAll [x] = x
mergeAll xs = mergeAll $ mergePairs xs

mergePairs :: [[Int]] -> [[Int]]
mergePairs (x:y:xs) = merge x y : mergePairs xs
mergePairs xs = xs

merge :: [Int] -> [Int] -> [Int]
merge (x:xs) (y:ys)
  | x <= y = x : merge xs (y:ys)
  | otherwise = y : merge (x:xs) ys
merge xs ys = xs ++ ys

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

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

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

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

solve :: [Int] -> Int
solve xs = go 0 0 $ go0 $ foldr insert Empty xs
   where
     go !res !x (y:ys)
       | x==y = go res (x+1) ys
       | otherwise = go (res+y-x) (y+1) ys
     go !res _ _ = res
     go0 Empty = []
     go0 (Fork x []) = [x]
     go0 heap
       | x == minElem heap' = go0 $ deleteMin heap'
       | otherwise =  x : go0 heap'
      where
        (x, heap') = deleteFindMin heap

data Heap a = Empty | Fork a [Heap a]

isEmpty :: Ord a => Heap a -> Bool
isEmpty Empty = True
isEmpty _ = False

insert :: Ord a => a -> Heap a -> Heap a
insert x h = merge (Fork x []) h

minElem :: Heap a -> a
minElem (Fork x _) = x

deleteMin :: Ord a => Heap a -> Heap a
deleteMin (Fork _ hs) = mergePairs hs

deleteFindMin :: Ord a => Heap a -> (a, Heap a)
deleteFindMin (Fork x hs) = (x, mergePairs hs)

merge :: Ord a => Heap a -> Heap a -> Heap a
merge Empty hy = hy
merge hx Empty = hx
merge hx@(Fork x _) hy@(Fork y _)
  | x <= y    = join hx hy
  | otherwise = join hy hx
 where
   join (Fork x hs) h = Fork x (h:hs)

mergePairs :: Ord a => [Heap a] -> Heap a
mergePairs []       = Empty
mergePairs [x]      = x
mergePairs (x:y:hs) = merge (merge x y) (mergePairs hs)

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

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

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

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

solve :: [Int] -> Int
solve xs = go 0 0 $ go0 $ step xs
   where
     step = mergeAll.map calc.group
     go0 xs
       | isOK xs = xs
       | otherwise = step xs
     go !res !x (y:ys)
       | x==y = go res (x+1) ys
       | otherwise = go (res+y-x) (y+1) ys
     go !res _ _ = res
     isOK (x:y:xs)
       | x<y = isOK (y:xs)
       | otherwise = False
     isOK _ = True

calc :: [Int] -> [Int]
calc [] = []
calc xs@(x:_) = go x $ length xs
   where
     go !x !l
       | l <= 1 = take l [x]
       | otherwise = let (q,r) = quotRem l 2
                     in if r==0
                           then go (x+1) q
                           else x : go (x+1) q

mergeAll :: [[Int]] -> [Int]
mergeAll [x] = x
mergeAll xs = mergeAll $ mergePairs xs

mergePairs :: [[Int]] -> [[Int]]
mergePairs (x:y:xs) = merge x y : mergePairs xs
mergePairs xs = xs

merge :: [Int] -> [Int] -> [Int]
merge (x:xs) (y:ys)
  | x <= y = x : merge xs (y:ys)
  | otherwise = y : merge (x:xs) ys
merge xs ys = xs ++ ys


Professor Ibrahim has prepared the final homework for his algorithm’s class. He asked his students to implement the Posterization Image Filter.Their algorithm will be tested on an array of integers, where the $$$i$$$-th integer represents the color of the $$$i$$$-th pixel in the image. The image is in black and white, therefore the color of each pixel will be an integer between 0 and 255 (inclusive).To implement the filter, students are required to divide the black and white color range [0, 255] into groups of consecutive colors, and select one color in each group to be the group’s key. In order to preserve image details, the size of a group must not be greater than $$$k$$$, and each color should belong to exactly one group.Finally, the students will replace the color of each pixel in the array with that color’s assigned group key.To better understand the effect, here is an image of a basking turtle where the Posterization Filter was applied with increasing $$$k$$$ to the right.   To make the process of checking the final answer easier, Professor Ibrahim wants students to divide the groups and assign the keys in a way that produces the lexicographically smallest possible array.

The first line of input contains two integers $$$n$$$ and $$$k$$$ ($$$1 \leq n \leq 10^5$$$, $$$1 \leq k \leq 256$$$), the number of pixels in the image, and the maximum size of a group, respectively. The second line contains $$$n$$$ integers $$$p_1, p_2, \dots, p_n$$$ ($$$0 \leq p_i \leq 255$$$), where $$$p_i$$$ is the color of the $$$i$$$-th pixel.

Print $$$n$$$ space-separated integers; the lexicographically smallest possible array that represents the image after applying the Posterization filter.

NoteOne possible way to group colors and assign keys for the first sample:Color $$$2$$$ belongs to the group $$$[0,2]$$$, with group key $$$0$$$.Color $$$14$$$ belongs to the group $$$[12,14]$$$, with group key $$$12$$$.Colors $$$3$$$ and $$$4$$$ belong to group $$$[3, 5]$$$, with group key $$$3$$$.Other groups won't affect the result so they are not listed here.

{-# LANGUAGE TupleSections #-}
import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap as M
import Data.Maybe

main = do
  input <- fmap B.lines B.getContents
  let [n,k] = map readI $ B.words $ input!!0
  let ps = map readI $ B.words $ input!!1
  putStrLn $ unwords $ map show $  solve k ps

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

solve :: Int -> [Int] -> [Int]
solve k as =
  mapMaybe (`M.lookup`assigns) as
  where
    assigns :: M.IntMap Int
    assigns = foldl f M.empty as

    f :: M.IntMap Int -> Int -> M.IntMap Int
    f m x =
      let lx = max 0 (x-k+1) in
      case (M.member x m, mapMaybe (\i-> fmap (i,) (M.lookup i m)) [x-1,x-2..lx]) of
        (True , _)           -> m
        (False, ((si,sx):_))
          | x < sx+k         -> foldr (`M.insert`sx) m [si+1..x]
          | otherwise        -> foldr (`M.insert`(si+1)) m [si+1..x]
        (False, [])          -> foldr (`M.insert`lx) m [lx..x]

import Data.List
import Data.Maybe
import qualified Data.Map as Map

main = do
    [n, k] <- fmap parseInput $ getLine
    ps <- fmap parseInput $ getLine
    putStrLn $ unwords $ map show $ solve n k ps

parseInput = map readInt . words
    where readInt x = (read x) :: Int

solve n k ps = solve' ps $ Map.empty
    where
        solve' [] _ = []
        solve' (p:ps) mapping
            | isJust stored = (fromJust stored):(solve' ps mapping)
            | otherwise = p':(solve' ps mapping')
            where
                stored = Map.lookup p mapping
                left_lookup = Map.filterWithKey (\x _ -> x `elem` [p-k+1..p]) mapping
                (lx, ly) = Map.findMax left_lookup
                (left_bound, merge_bound)
                    | Map.size left_lookup == 0 = (max (p-k+1) 0, -100000000)
                    | otherwise = (lx + 1, ly)

                p' = if (p - merge_bound) < k
                    then merge_bound
                    else left_bound

                mapping' = foldl' insert' mapping [left_bound..p]
                insert' m x = Map.insert x p' m

import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap as M
import Data.Maybe

main = do
  input <- fmap B.lines B.getContents
  let [n,k] = map readI $ B.words $ input!!0
  let ps = map readI $ B.words $ input!!1
  putStrLn $ unwords $ map show $  solve k ps

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

solve :: Int -> [Int] -> [Int]
solve k as =
  mapMaybe (`M.lookup`assigns) as
  where
    assigns :: M.IntMap Int
    assigns = foldl f M.empty as

    f :: M.IntMap Int -> Int -> M.IntMap Int
    f m x =
      case (M.member x m, filter (`M.notMember`m) [max 0 (x-k+1)..x]) of
        (True , _)     -> m
        (False, (s:_)) -> foldr (`M.insert`s) m [s..s+k-1]

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

main = do
  input <- fmap B.lines B.getContents
  let [n,k] = map readI $ B.words $ input!!0
  let ps = map readI $ B.words $ input!!1
  putStrLn $ unwords $ solve k ps

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

solve :: Int -> [Int] -> [String]
solve k as =
  sort $ map (show.f) as
  where
    f x = let (q,r) = x`divMod`k in q*k