You are given a string $$$s$$$ consisting of $$$n$$$ lowercase Latin letters. $$$n$$$ is even.For each position $$$i$$$ ($$$1 \le i \le n$$$) in string $$$s$$$ you are required to change the letter on this position either to the previous letter in alphabetic order or to the next one (letters 'a' and 'z' have only one of these options). Letter in every position must be changed exactly once.For example, letter 'p' should be changed either to 'o' or to 'q', letter 'a' should be changed to 'b' and letter 'z' should be changed to 'y'.That way string "codeforces", for example, can be changed to "dpedepqbft" ('c' $$$\rightarrow$$$ 'd', 'o' $$$\rightarrow$$$ 'p', 'd' $$$\rightarrow$$$ 'e', 'e' $$$\rightarrow$$$ 'd', 'f' $$$\rightarrow$$$ 'e', 'o' $$$\rightarrow$$$ 'p', 'r' $$$\rightarrow$$$ 'q', 'c' $$$\rightarrow$$$ 'b', 'e' $$$\rightarrow$$$ 'f', 's' $$$\rightarrow$$$ 't').String $$$s$$$ is called a palindrome if it reads the same from left to right and from right to left. For example, strings "abba" and "zz" are palindromes and strings "abca" and "zy" are not.Your goal is to check if it's possible to make string $$$s$$$ a palindrome by applying the aforementioned changes to every position. Print "YES" if string $$$s$$$ can be transformed to a palindrome and "NO" otherwise.Each testcase contains several strings, for each of them you are required to solve the problem separately.

The first line contains a single integer $$$T$$$ ($$$1 \le T \le 50$$$) — the number of strings in a testcase. Then $$$2T$$$ lines follow — lines $$$(2i - 1)$$$ and $$$2i$$$ of them describe the $$$i$$$-th string. The first line of the pair contains a single integer $$$n$$$ ($$$2 \le n \le 100$$$, $$$n$$$ is even) — the length of the corresponding string. The second line of the pair contains a string $$$s$$$, consisting of $$$n$$$ lowercase Latin letters.

Print $$$T$$$ lines. The $$$i$$$-th line should contain the answer to the $$$i$$$-th string of the input. Print "YES" if it's possible to make the $$$i$$$-th string a palindrome by applying the aforementioned changes to every position. Print "NO" otherwise.

NoteThe first string of the example can be changed to "bcbbcb", two leftmost letters and two rightmost letters got changed to the next letters, two middle letters got changed to the previous letters.The second string can be changed to "be", "bg", "de", "dg", but none of these resulting strings are palindromes.The third string can be changed to "beeb" which is a palindrome.The fifth string can be changed to "lk", "lm", "nk", "nm", but none of these resulting strings are palindromes. Also note that no letter can remain the same, so you can't obtain strings "ll" or "mm".

import Data.Char

toint s = (read s) :: Int

doit "" "" = True
doit (aa:s) (bb:t) =
  let a = ord aa in
  let b = ord bb in
  let x = abs (a - b) in
  if x == 0 || x == 2 then
    doit s t
  else
    False

doall [] = ""
doall (_:s:ss) =
  let t = reverse s in
  let r = if doit s t then "YES" else "NO" in
  r ++ "\n" ++ doall ss

solve::String -> String
solve ss =
  let _:s = words ss in
  doall s

main = interact solve

import qualified Data.ByteString.Char8 as B
import Data.Function
import Data.Char

solve s = let (a,b) = B.splitAt (B.length s`div`2) $ B.filter (`elem`['a'..'z']) s
              t = and $ B.zipWith (\x y -> if x == y || (let e = abs (ord x - ord y) in e == 2 || e == 0) then True else False) a $ B.reverse b
          in B.pack $ if t then "YES" else "NO"

main = B.interact $ B.unlines . map solve . fix (\f a -> if null a then [] else let (b:c:ds) = a in c : f ds )  . tail . B.lines

main = interact $ unlines . map solve . filter ((`elem` ['a' .. 'z']) . head) . lines

solve = (\x -> foldl check "YES" $ zip x $ reverse x) . map fromEnum

check acc (x,y)
    | d == 0 || d == 2 = acc
    | otherwise = "NO"
    where d = abs (x - y)

import Data.List
import Data.Char

g::String->String->String
g [] []="YES"
g (x:xs) (y:ys)
    |x==y=g xs ys
    |otherwise=if abs(ord (x)-ord(y))==2 then g xs ys else "NO"

f ::[String]->[String]
f []=[]
f (x:y:xs)=(g y (reverse y)):f xs

main = do
       e1<-getLine
       es<-getContents
       let xs=lines es
       putStr $ unlines$ f xs

main = interact $ unlines . map solve . pairs . tail . lines
pairs (a:b:xs) = (a,b) : pairs xs
pairs [] = []
solve (_,s) | all d (zip s (reverse s)) = "YES" | otherwise = "NO" where
  d (x,y) = (fromEnum x - fromEnum y) `elem` [-2,0,2]

import Data.Foldable (for_)
import Data.Char
import Data.Function

f a b
  | (a+1)`mod`26 == (b-1)`mod`26 = True
  | (a+1)`mod`26 == (b+1)`mod`26 = True
  | (a-1)`mod`26 == (b-1)`mod`26 = True
  | (a-1)`mod`26 == (b+1)`mod`26 = True
  | otherwise = False

printB x = putStrLn $ if x then "YES" else "NO"
main = do
    n <- readLn :: IO Int
    for_ [1..n] $ \_ -> do
        getLine
        s <- getLine
        let (a,b) = splitAt (length s `div` 2) s
        printB $ and $ zipWith (f`on`ord) a $ reverse b

import Data.Foldable (for_)
import Data.Char
import Data.Function

f a b
  | a + 1 == b - 1 = True
  | a + 1 == b + 1 = True
  | a - 1 == b - 1 = True
  | a - 1 == b - 1 = True
  | otherwise = False

printB x = putStrLn $ if x then "YES" else "NO"
main = do
    n <- readLn :: IO Int
    for_ [1..n] $ \_ -> do
        getLine
        s <- getLine
        let (a,b) = splitAt (length s `div` 2) s
        printB $ and $ zipWith (f`on`ord) a $ reverse b

import qualified Data.ByteString.Char8 as B
import Data.Function
import Data.Char

solve s = let (a,b) = B.splitAt (B.length s`div`2) s
              t = and $ B.zipWith (\x y -> if x == y || (let e = abs (ord x - ord y) in e == 2 || e == 0) then True else False) a $ B.reverse b
          in B.pack $ if t then "YES" else "NO"

main = B.interact $ B.unlines . map solve . fix (\f a -> if null a then [] else let (b:c:ds) = a in c : f ds )  . tail . B.lines


And where the are the phone numbers?You are given a string s consisting of lowercase English letters and an integer k. Find the lexicographically smallest string t of length k, such that its set of letters is a subset of the set of letters of s and s is lexicographically smaller than t.It's guaranteed that the answer exists.Note that the set of letters is a set, not a multiset. For example, the set of letters of abadaba is {a, b, d}.String p is lexicographically smaller than string q, if p is a prefix of q, is not equal to q or there exists i, such that pi < qi and for all j < i it is satisfied that pj = qj. For example, abc is lexicographically smaller than abcd , abd is lexicographically smaller than abec, afa is not lexicographically smaller than ab and a is not lexicographically smaller than a.

The first line of input contains two space separated integers n and k (1 ≤ n, k ≤ 100 000) — the length of s and the required length of t. The second line of input contains the string s consisting of n lowercase English letters.

Output the string t conforming to the requirements above. It's guaranteed that the answer exists.

NoteIn the first example the list of strings t of length 3, such that the set of letters of t is a subset of letters of s is as follows: aaa, aab, aac, aba, abb, abc, aca, acb, .... Among them, those are lexicographically greater than abc: aca, acb, .... Out of those the lexicographically smallest is aca.

{-# LANGUAGE ViewPatterns #-}
import qualified Data.Set as S
import Data.Maybe
import Data.List
main = interact exec
exec = (\[n, k, xs] -> f (read n) (read k) xs) . words

f :: Int -> Int -> String -> String
f n k xs
  | k > n = take k $ xs ++ repeat (S.findMin s)
  | otherwise = take k $ (\(reverse -> f) -> init f ++ [next (last f)] ++ repeat (S.findMin s)) $ dropWhile (== S.findMax s) $ reverse $ take k xs
  where
  s = S.fromList xs
  next = fromJust . flip S.lookupGT s

{-
3 2
yzy
-}

module Main where

import           Data.List (dropWhileEnd)

main :: IO ()
main = do
  first <- getLine
  let [n, k] = map read (words first) :: [Int]
  s <- getLine
  let fakeMaxChar = succ 'z'
  let minChar = foldr min fakeMaxChar s
  let fakeMinChar = pred 'a'
  let maxChar = foldr max fakeMinChar s
  if n < k
  then putStrLn $ s ++ replicate (k - n) minChar
  else do
      let bufS = take k s
      let newS = dropWhileEnd ((==) maxChar) bufS
      let newLen = length newS
      let lastChar = newS !! (newLen - 1)
      let filtNewS = filter ((<) lastChar) s
      let minSpecialChar = foldr min fakeMaxChar filtNewS
      putStrLn $ take (newLen - 1) newS ++ [minSpecialChar] ++ replicate (k - newLen) minChar

import Data.Set hiding (map, null)

next :: Char -> Set Char -> Char
next c s = elemAt ((+1) $ findIndex c s) s

translate :: Int -> Set Char -> String -> String
translate k letterSet = snd . trans k
  where (maxL,minL)   = (findMax letterSet, findMin letterSet)
        trans 0 _     = (False,[])
        trans k (c:cs)
          | done      = (True,c:res)
          | c /= maxL = (True,(next c letterSet):res)
          | otherwise = (False,minL:res)
         where (done,res) = trans (k-1) cs

construct :: Int -> Int -> String -> String
construct n k s
  | k > n     = s ++ replicate (k-n) (elemAt 0 letterSet)
  | otherwise = translate k letterSet s
 where letterSet = fromList s

main :: IO ()
main = do
  params <- getLine
  let (n,k) = (\(x:y:[]) -> (x,y)) . map read . words $ params
  s <- getLine
  putStrLn $ construct n k s

{-# LANGUAGE ViewPatterns #-}
import qualified Data.Set as S
import Data.Maybe
import Data.List
main = interact exec
exec = (\[n, k, xs] -> f (read n) (read k) xs) . words

f :: Int -> Int -> String -> String
f n k xs
  | k > n = take k $ xs ++ repeat (S.findMin s)
  | otherwise = take k $ (\(reverse -> f) -> init f ++ [next (last f)] ++ repeat (S.findMin s)) $ dropWhile (== S.findMax s) $ reverse xs
  where
  s = S.fromList xs
  next = fromJust . flip S.lookupGT s

module Main where

main :: IO ()
main = do
  first <- getLine
  let [n, k] = map read (words first) :: [Int]
  s <- getLine
  let minChar = foldr min 'z' s
  putStrLn $ replicate k minChar

module Main where

import           Data.List (dropWhileEnd)

main :: IO ()
main = do
  first <- getLine
  let [n, k] = map read (words first) :: [Int]
  s <- getLine
  let fakeMaxChar = succ 'z'
  let minChar = foldr min fakeMaxChar s
  let fakeMinChar = pred 'a'
  let maxChar = foldr max fakeMinChar s
  if n < k
  then putStrLn $ s ++ replicate (k - n) minChar
  else do
      let bufS = take k s
      let newS = dropWhileEnd ((==) maxChar) s
      let newLen = length newS
      let lastChar = newS !! (newLen - 1)
      let filtNewS = filter ((<) lastChar) s
      let minSpecialChar = foldr min fakeMaxChar filtNewS
      putStrLn $ take (newLen - 1) newS ++ [minSpecialChar] ++ replicate (k - newLen) minChar

import Data.Set hiding (map, null)

next :: Char -> Set Char -> Char
next c s = elemAt ((+1) $ findIndex c s) s

translate :: Int -> Set Char -> String -> String
translate k letterSet = trans k
  where (maxL,minL) = (findMax letterSet, findMin letterSet)
        mapFrom c = if c == maxL then minL else next c letterSet
        trans 0 _                        = []
        trans k (c:cs)
          | null res || head res == minL = (mapFrom c):res
          | otherwise                    = c:res
         where res = trans (k-1) cs

construct :: Int -> Int -> String -> String
construct n k s
  | k > n     = s ++ replicate (k-n) (elemAt 0 letterSet)
  | otherwise = translate k letterSet s
 where letterSet = fromList s

main :: IO ()
main = do
  params <- getLine
  let (n,k) = (\(x:y:[]) -> (x,y)) . map read . words $ params
  s <- getLine
  putStrLn $ construct n k s


You have an array a with length n, you can perform operations. Each operation is like this: choose two adjacent elements from a, say x and y, and replace one of them with gcd(x, y), where gcd denotes the greatest common divisor.What is the minimum number of operations you need to make all of the elements equal to 1?

The first line of the input contains one integer n (1 ≤ n ≤ 2000) — the number of elements in the array. The second line contains n space separated integers a1, a2, ..., an (1 ≤ ai ≤ 109) — the elements of the array.

Print -1, if it is impossible to turn all numbers to 1. Otherwise, print the minimum number of operations needed to make all numbers equal to 1.

NoteIn the first sample you can turn all numbers to 1 using the following 5 moves:  [2, 2, 3, 4, 6].  [2, 1, 3, 4, 6]  [2, 1, 3, 1, 6]  [2, 1, 1, 1, 6]  [1, 1, 1, 1, 6]  [1, 1, 1, 1, 1] We can prove that in this case it is not possible to make all numbers one using less than 5 moves.

module Main where
import qualified Data.ByteString.Char8 as B
import Data.List

main = B.interact exec
exec = B.pack . show . solve . map int . B.words
  where int = maybe undefined fst . B.readInt

solve (n:xs) = maybe (-1) (\l -> max 0 $ l - 1 + n - fromEnum (l /= 1) - length (filter (== 1) xs)) $ len n xs

len n xs = go 0 n
  where
  go l r
    | r - l <= 1 = if ok r xs then Just r else Nothing
    | ok m xs = go l m
    | otherwise = go m r
    where m = (l + r) `quot` 2

ok k xs = elem 1 $ map gcds $ windows k xs
gcds (x:xs) = go x xs
  where
  go 1 _ = 1
  go g [] = g
  go g (x:xs) = go (gcd g x) xs

windows n xs = zipWith const (map (take n) $ tails xs) (drop (n - 1) xs)

module Main where
import qualified Data.ByteString.Char8 as B
import Data.List

main = B.interact exec
exec = B.pack . show . solve . map int . B.words
  where int = maybe undefined fst . B.readInt

solve (n:xs) = maybe (-1) (\l -> l - 1 + n - 1) $ len n xs

len n xs = go 0 n
  where
  go l r
    | r - l <= 1 = if ok l xs then Just l else Nothing
    | ok m xs = go l m
    | otherwise = go r m
    where m = (l + r) `quot` 2

ok k xs = elem 1 $ map gcds $ windows k xs
gcds (x:xs) = go x xs
  where
  go 1 _ = 1
  go g [] = g
  go g (x:xs) = go (gcd g x) xs

windows n xs = zipWith const (map (take n) $ tails xs) (drop (n - 1) xs)

module Main where
import qualified Data.ByteString.Char8 as B
import Data.List

main = B.interact exec
exec = B.pack . show . solve . map int . B.words
  where int = maybe undefined fst . B.readInt

solve (n:xs) = maybe (-1) (\l -> l - 1 + n - 1) $ len n xs

len n xs = go 1 (n + 1)
  where
  go l r
    | r - l <= 1 = if ok l xs then Just l else Nothing
    | ok m xs = go l m
    | otherwise = go r m
    where m = (l + r) `quot` 2

ok k xs = elem 1 $ map gcds $ windows k xs
gcds (x:xs) = go x xs
  where
  go 1 _ = 1
  go g [] = g
  go g (x:xs) = go (gcd g x) xs

windows n xs = zipWith const (map (take n) $ tails xs) (drop (n - 1) xs)


In Berland it is the holiday of equality. In honor of the holiday the king decided to equalize the welfare of all citizens in Berland by the expense of the state treasury. Totally in Berland there are n citizens, the welfare of each of them is estimated as the integer in ai burles (burle is the currency in Berland).You are the royal treasurer, which needs to count the minimum charges of the kingdom on the king's present. The king can only give money, he hasn't a power to take away them.

The first line contains the integer n (1 ≤ n ≤ 100) — the number of citizens in the kingdom. The second line contains n integers a1, a2, ..., an, where ai (0 ≤ ai ≤ 106) — the welfare of the i-th citizen.

In the only line print the integer S — the minimum number of burles which are had to spend.

NoteIn the first example if we add to the first citizen 4 burles, to the second 3, to the third 2 and to the fourth 1, then the welfare of all citizens will equal 4.In the second example it is enough to give one burle to the third citizen. In the third example it is necessary to give two burles to the first and the third citizens to make the welfare of citizens equal 3.In the fourth example it is possible to give nothing to everyone because all citizens have 12 burles.

main :: IO ()
main = do
  n <- getLine
  cost <- fmap (map read.words) getLine :: IO [Int]
  let min_v = maximum cost
  print (sum (map (\x-> min_v - x) cost))

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as B
import Text.Printf

readInt = ( readLn :: IO Int )
readInts = map ( read :: String -> Int ) . words <$> getLine

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

which a b f = if f then a else b
mp [ a, b ] = ( a, b )

main = do
	n <- readInt
	a <- readInts
	print $ maximum a * n - sum a

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

main = B.getLine >> (map $ maybe undefined fst . B.readInt) . B.words <$> B.getLine >>= (\xs -> let m = maximum xs in print . sum . map ((-) m) $ xs)

conv lst oo
  | (null lst) = reverse oo
  | otherwise = conv (tail lst) (((read (head lst))::Int) : oo)

main = do
  ff <- getLine
  gg <- getLine

  let n = (read ff)::Int
      uu = conv (words gg) []

      ans = ((length uu) * (maximum uu) - (sum uu))

  putStrLn (show ans)

module Main where

main = do
  _ <- getLine
  ns <- map read . words <$> getLine
  let maxN = maximum ns
      grow = map (maxN-) ns
  print $ sum grow

module Main where

toInt s = read s :: Int

solve n mas = helper (maximum (map toInt (words mas))) (map toInt (words mas))

helper m = foldr (\x s -> if x >= m then s else s + (m - x)) 0

main = do
    n <- getLine
    mas <- getLine
    print $ solve n mas

import Data.List
import Data.Ord
import Data.Char
fi = fromIntegral

solve x = sum $ map (\y->mx-y) x where
	mx = maximum x

main=interact$show.solve.map (\x->read x::Int).words.head.tail.lines

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Data.Functor
import Control.Monad
import Control.Monad.ST.Safe
import Control.Arrow
import Data.Array
import Data.Array.ST.Safe
import Data.STRef
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as C
main=   readsolveprint
readsolveprint::IO()
readsolveprint = getLine >>= \ n -> (solve.concat =<< forM [1 .. 1] ( \i -> map (fst.fromJust.C.readInt).C.words <$> C.getLine))
solve xs = let m =maximum xs in print $ sum $ map (\a->m-a) xs

main=interact$(show::Integer->String).f.map read.words
f (a:b)=maximum b*a-sum b

solve xs = sum $ map (\x -> m - x) xs
    where m = maximum xs

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

import Control.Monad

main = readInput >>= putStrLn . show . calc

readInput :: IO (Int, [Int])
readInput = liftM2 toTuple getLine getLine
  where toTuple a b = (read a, map read $ words b)

calc :: (Int, [Int]) -> Int
calc (1, _) = 0
calc (n, ws) = (n - 1) * m - (t - m)
  where mt = foldr (\w (m, t) -> (max m w, t + w)) (0, 0) ws
        m = fst mt
        t = snd mt

import Text.Printf
import Data.List
import Data.Functor
import Control.Applicative
import Prelude
import Control.Monad
import Data.Maybe
import Data.Function
import Data.Array
import qualified Data.ByteString.Char8 as B8
import Data.Foldable (foldr')

readInt :: String -> Int
readInt = Prelude.read

readB8Int :: B8.ByteString -> Int
readB8Int = fst . fromJust . B8.readInt

main :: IO ()
main = do
    n <- readB8Int <$> B8.getLine
    arr <- (map readB8Int . B8.words) <$> B8.getLine
    let mx = maximum arr
        answer = sum . map (mx -) $ arr
    printf "%d\n" answer

import Control.Applicative
import Data.List

main=do
    n<-getLine
    q<- map read <$>  words   <$> getLine ::IO [Int]
    let lq = length q
    let mq = maximum q
    print $ mq*lq - sum q

main = interact $ show . solve . map read . tail . words
solve xs = sum $ map (maximum xs -) xs

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

readInt = fromIntegral . fst . fromJust . B.readInteger

readLine =
  B.getLine >>= return . map readInt . B.words

main = do
  _ <- readLine
  citizens <- readLine
  B.putStrLn . B.pack . show $
    let richest = maximum citizens
    in sum $ map (richest -) citizens

import Control.Applicative

main = do
  (n:as) <- map read . words <$> getContents
  print $ solve n as

solve n as = (n * maximum as) - sum as

main = do
    n_ <- readLn::IO Int
    as_ <- return . map (read::String->Integer) . words =<< getLine
    let
	mx = maximum as_
	give::[Integer]->Integer
	give [] = 0
	give (a:as) = (mx-a)+give as
    print $ give as_

module Main where
    import Data.List
    main :: IO ()
    main = do
        _ <- getLine
        l <- getLine
        let a = map (\x -> read x :: Integer) $ words l
            res = sum $ map (\x -> m - x) $ sort a where m = maximum a
        print res

main = interact $ show . solve . map read . tail . words
solve s = (length s) * (maximum s) - sum s

goldCoins xs = sum $ [m - x | x <- xs ] where m = maximum xs

main =
    do
        line1 <- getLine
        line2 <- getLine
        let coins = map read . words $ line2
        putStrLn . show $ goldCoins coins

import Data.List.Split (splitOn)

main = do
 _ <- getLine
 raw <- getLine
 let szamok = map read $ splitOn " " raw
 let ln = maximum szamok
 print $ sum $ map (ln-) szamok

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

main = do

	n<- read <$>  getLine:: IO Int
	a<- map read <$> words <$> getLine ::IO [Int]
 	let m = maximum a
	let s = sum a
	print $ m*n-s

--ghc 7.10

minToEqual :: (Ord a, Num a) => [a] -> a
minToEqual a = sum $ map (\x -> amax-x) a
    where amax = maximum a

main = do
    nStr <- getLine
    aStr <- getLine
    let a = map read . words $ aStr :: [Int]
    print $ minToEqual a

import Data.Maybe
main = interact $ show . solve
solve = sum . mapMaybe (flip lookup ss . head) . tail . lines
ss = [('T',4),('C',6),('O',8),('D',12),('I',20)]


You are given a set of $$$n\ge 2$$$ pairwise different points with integer coordinates. Your task is to partition these points into two nonempty groups $$$A$$$ and $$$B$$$, such that the following condition holds:For every two points $$$P$$$ and $$$Q$$$, write the Euclidean distance between them on the blackboard: if they belong to the same group — with a yellow pen, and if they belong to different groups — with a blue pen. Then no yellow number is equal to any blue number.It is guaranteed that such a partition exists for any possible input. If there exist multiple partitions, you are allowed to output any of them.

The first line contains one integer $$$n$$$ $$$(2 \le n \le 10^3)$$$ — the number of points. The $$$i$$$-th of the next $$$n$$$ lines contains two integers $$$x_i$$$ and $$$y_i$$$ ($$$-10^6 \le x_i, y_i \le 10^6$$$) — the coordinates of the $$$i$$$-th point.  It is guaranteed that all $$$n$$$ points are pairwise different.

In the first line, output $$$a$$$ ($$$1 \le a \le n-1$$$) — the number of points in a group $$$A$$$. In the second line, output $$$a$$$ integers — the indexes of points that you include into group $$$A$$$. If there are multiple answers, print any.

NoteIn the first example, we set point $$$(0, 0)$$$ to group $$$A$$$ and points $$$(0, 1)$$$ and $$$(1, 0)$$$ to group $$$B$$$. In this way, we will have $$$1$$$ yellow number $$$\sqrt{2}$$$ and $$$2$$$ blue numbers $$$1$$$ on the blackboard.In the second example, we set points $$$(0, 1)$$$ and $$$(0, -1)$$$ to group $$$A$$$ and points $$$(-1, 0)$$$ and $$$(1, 0)$$$ to group $$$B$$$. In this way, we will have $$$2$$$ yellow numbers $$$2$$$, $$$4$$$ blue numbers $$$\sqrt{2}$$$ on the blackboard.

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

solve ps
    | any even ss && any odd ss = map fst $ filter (odd . snd) $ zip [1 ..] ss
    | all odd ss = solve $ (\(x, y) -> (x + 1, y)) <$> ps
    | otherwise = solve $ (\(x, y) -> ((x + y) `div` 2, (x - y) `div` 2)) <$> ps
  where
    ss = uncurry (+) <$> ps

main = do
    n <- read <$> getLine
    ps <- replicateM n ((\(x:y:_) -> (x, y)) . map read . words <$> getLine)
    let as = solve ps
    print $ length as
    putStrLn $ unwords . map show $ as


Some time ago Homer lived in a beautiful city. There were $$$n$$$ blocks numbered from $$$1$$$ to $$$n$$$ and $$$m$$$ directed roads between them. Each road had a positive length, and each road went from the block with the smaller index to the block with the larger index. For every two (different) blocks, there was at most one road between them. Homer discovered that for some two numbers $$$L$$$ and $$$R$$$ the city was $$$(L, R)$$$-continuous. The city is said to be $$$(L, R)$$$-continuous, if   all paths from block $$$1$$$ to block $$$n$$$ are of length between $$$L$$$ and $$$R$$$ (inclusive); and  for every $$$L \leq d \leq R$$$, there is exactly one path from block $$$1$$$ to block $$$n$$$ whose length is $$$d$$$. A path from block $$$u$$$ to block $$$v$$$ is a sequence $$$u = x_0 \to x_1 \to x_2 \to \dots \to x_k = v$$$, where there is a road from block $$$x_{i-1}$$$ to block $$$x_{i}$$$ for every $$$1 \leq i \leq k$$$. The length of a path is the sum of lengths over all roads in the path. Two paths $$$x_0 \to x_1 \to \dots \to x_k$$$ and $$$y_0 \to y_1 \to \dots \to y_l$$$ are different, if $$$k \neq l$$$ or $$$x_i \neq y_i$$$ for some $$$0 \leq i \leq \min\{k, l\}$$$. After moving to another city, Homer only remembers the two special numbers $$$L$$$ and $$$R$$$ but forgets the numbers $$$n$$$ and $$$m$$$ of blocks and roads, respectively, and how blocks are connected by roads. However, he believes the number of blocks should be no larger than $$$32$$$ (because the city was small).As the best friend of Homer, please tell him whether it is possible to find a $$$(L, R)$$$-continuous city or not.

The single line contains two integers $$$L$$$ and $$$R$$$ ($$$1 \leq L \leq R \leq 10^6$$$).

If it is impossible to find a $$$(L, R)$$$-continuous city within $$$32$$$ blocks, print "NO" in a single line. Otherwise, print "YES" in the first line followed by a description of a $$$(L, R)$$$-continuous city.  The second line should contain two integers $$$n$$$ ($$$2 \leq n \leq 32$$$) and $$$m$$$ ($$$1 \leq m \leq \frac {n(n-1)} 2$$$), where $$$n$$$ denotes the number of blocks and $$$m$$$ denotes the number of roads. Then $$$m$$$ lines follow. The $$$i$$$-th of the $$$m$$$ lines should contain three integers $$$a_i$$$, $$$b_i$$$ ($$$1 \leq a_i < b_i \leq n$$$) and $$$c_i$$$ ($$$1 \leq c_i \leq 10^6$$$) indicating that there is a directed road from block $$$a_i$$$ to block $$$b_i$$$ of length $$$c_i$$$.  It is required that for every two blocks, there should be no more than 1 road connecting them. That is, for every $$$1 \leq i < j \leq m$$$, either $$$a_i \neq a_j$$$ or $$$b_i \neq b_j$$$.

NoteIn the first example there is only one path from block $$$1$$$ to block $$$n = 2$$$, and its length is $$$1$$$. In the second example there are three paths from block $$$1$$$ to block $$$n = 5$$$, which are $$$1 \to 2 \to 5$$$ of length $$$4$$$, $$$1 \to 3 \to 5$$$ of length $$$5$$$ and $$$1 \to 4 \to 5$$$ of length $$$6$$$.

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

import qualified Data.ByteString.Lazy.Char8 as P

import Data.Bits

type SIO = StateT P.ByteString IO

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

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

outLine :: String -> SIO ()
outLine = lift . P.putStrLn . P.pack

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [li, ri] <- readInts
  outLine "YES" -- no legal input is large enough for "NO"
  let
    len = ri - li + 1
    p2s = takeWhile (< len) $ iterate (*2) 1
    ixs = [31, 30 .. 2]
    go v = (32, 1) : do
      let  sv = v - 1
      q@(_dest, currP2) <- zip ixs p2s
      [q | sv .&. currP2 > 0]
    allFrom v = let
      (tars, costs) = unzip $ go v
      0 : rangesBelow = scanl (+) 0 costs
      in  zip tars (1 : rangesBelow)
    srcEdges = zip (repeat 1) $ map (\(x, y) -> (x, li - 1 + y)) $ allFrom len
    otherEdges = do
      (currLoc, currP2) <- zip ixs p2s
      zip (repeat currLoc) $ allFrom currP2
    allEdges = srcEdges ++ otherEdges
    n = 32
    m = length allEdges
  outLine $ unwords $ map show [n, m]
  forM_ allEdges $ \(src, (dest, cost)) -> do
    outLine $ unwords $ map show [src, dest, cost]


Let's call an array $$$a_1, a_2, \dots, a_m$$$ of nonnegative integer numbers good if $$$a_1 + a_2 + \dots + a_m = 2\cdot(a_1 \oplus a_2 \oplus \dots \oplus a_m)$$$, where $$$\oplus$$$ denotes the bitwise XOR operation.For example, array $$$[1, 2, 3, 6]$$$ is good, as $$$1 + 2 + 3 + 6 = 12 = 2\cdot 6 = 2\cdot (1\oplus 2 \oplus 3 \oplus 6)$$$. At the same time, array $$$[1, 2, 1, 3]$$$ isn't good, as $$$1 + 2 + 1 + 3 = 7 \neq 2\cdot 1 = 2\cdot(1\oplus 2 \oplus 1 \oplus 3)$$$.You are given an array of length $$$n$$$: $$$a_1, a_2, \dots, a_n$$$. Append at most $$$3$$$ elements to it to make it good. Appended elements don't have to be different. It can be shown that the solution always exists under the given constraints. If there are different solutions, you are allowed to output any of them. Note that you don't have to minimize the number of added elements!. So, if an array is good already you are allowed to not append elements.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10\,000$$$). The description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ $$$(1\le n \le 10^5)$$$ — the size of the array. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$0\le a_i \le 10^9$$$) — the elements of the array. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, output two lines. In the first line, output a single integer $$$s$$$ ($$$0\le s\le 3$$$) — the number of elements you want to append. In the second line, output $$$s$$$ integers $$$b_1, \dots, b_s$$$ ($$$0\le b_i \le 10^{18}$$$) — the elements you want to append to the array. If there are different solutions, you are allowed to output any of them.

NoteIn the first test case of the example, the sum of all numbers is $$$12$$$, and their $$$\oplus$$$ is $$$6$$$, so the condition is already satisfied.In the second test case of the example, after adding $$$4, 4$$$, the array becomes $$$[8, 4, 4]$$$. The sum of numbers in it is $$$16$$$, $$$\oplus$$$ of numbers in it is $$$8$$$.

import Control.Monad
import Data.Bits
import Data.Bool

main = getLine >>= flip replicateM_ test . read

test = do
    getLine
    as <- map read . words <$> getLine :: IO [Integer]
    let s = sum as
        x = foldl xor 0 as
    print 3
    putStrLn $ unwords . map show $ solve s x

solve s x = [a, y, y] -- ayy
  where
    a = 1000000000000000 + bool 0 1 (odd s)
    y = (2 * (x `xor` a) - s - a) `div` 2

import Control.Monad
import Data.Bits
import Data.Bool

main = getLine >>= flip replicateM_ test . read

test = do
    getLine
    as <- map read . words <$> getLine :: IO [Integer]
    let s = sum as
        x = foldl xor 0 as
    print 3
    putStrLn $ unwords . map show $ solve s x

solve s x = [a, y, y] -- ayy
  where
    a = 1000000000000 + bool 0 1 (odd s)
    y = (2 * (x `xor` a) - s - a) `div` 2


You are given n positive integers a1, a2, ..., an.For every ai you need to find a positive integer ki such that the decimal notation of 2ki contains the decimal notation of ai as a substring among its last min(100, length(2ki)) digits. Here length(m) is the length of the decimal notation of m.Note that you don't have to minimize ki. The decimal notations in this problem do not contain leading zeros.

The first line contains a single integer n (1 ≤ n ≤ 2 000) — the number of integers ai. Each of the next n lines contains a positive integer ai (1 ≤ ai < 1011).

Print n lines. The i-th of them should contain a positive integer ki such that the last min(100, length(2ki)) digits of 2ki contain the decimal notation of ai as a substring. Integers ki must satisfy 1 ≤ ki ≤ 1050. It can be shown that the answer always exists under the given constraints. If there are multiple answers, print any of them.

main = interact $ unlines . map (show . f . read) . tail . lines

f :: Integer -> Integer
f a = log2 (e+f) x + 4*5^(e+f-1)
        where r = mod (-a * 10^f) (2^(e+f))
              c = a*10^f+r
              c' = c + if mod c 5 == 0 then 2^(e+f) else 0
              x = mod c' (5^(e+f))
              e = head $ filter ((>a).(10^)) [0..]
              f = head $ filter (\i-> 2^(e+i+1)<10^i) [0..]

powMod :: Integer -> Integer -> Integer -> Integer
powMod a 0 m = 1
powMod a e m = mod (powMod (mod (a^2) m) (div e 2) m * (if even e then 1 else a)) m

log2 :: Int -> Integer -> Integer
log2 i x
        | i == 0    = 0
        | otherwise = head $ filter (\e-> powMod 2 e (5^i) == x) [a,a+phi..]
        where a = log2 (i-1) (mod x (5^(i-1)))
              phi = if i == 1 then 1 else 4*5^(i-2)


You've got a table of size n × m. On the intersection of the i-th row (1 ≤ i ≤ n) and the j-th column (1 ≤ j ≤ m) there is a non-negative integer ai, j. Besides, you've got a non-negative integer k.Your task is to find such pair of integers (a, b) that meets these conditions:   k ≤ a ≤ n - k + 1;  k ≤ b ≤ m - k + 1;  let's denote the maximum of the function  among all integers x and y, that satisfy the inequalities k ≤ x ≤ n - k + 1 and k ≤ y ≤ m - k + 1, as mval; for the required pair of numbers the following equation must hold f(a, b) = mval.

The first line contains three space-separated integers n, m and k (1 ≤ n, m ≤ 1000, ). Next n lines each contains m integers: the j-th number on the i-th line equals ai, j (0 ≤ ai, j ≤ 106). The numbers in the lines are separated by spaces.

Print the required pair of integers a and b. Separate the numbers by a space. If there are multiple correct answers, you are allowed to print any of them.

{-# OPTIONS_GHC -O2 -optc-Ofast -ignore-asserts #-}
import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Int
import Data.IORef
import Data.List
import Data.Maybe
import Data.Ord
import System.Exit
import qualified Data.ByteString.Char8 as C

type IA = UArray (Int, Int) Int64
type MA = IOUArray (Int, Int) Int64

accumulate :: Int -> Int -> Int -> IA -> IO IA
accumulate k dx dy a = do
  s <- thaw a :: IO MA
  let gets p = if inRange ix p then readArray s p else return 0
      geta p = if inRange ix p then a!p else 0
  forM_ r $ \i -> do
    forM_ c $ \j -> do
      t <- gets (i - dx, j - dy)
      writeArray s (i, j) $ t + geta (i, j) - geta (i - kdx, j - kdy)
  freeze s
  where
    kdx = k * dx
    kdy = k * dy
    ix@(begin, end) = bounds a
    r = let r' = [fst begin .. fst end] in if dx >= 0 then r' else reverse r'
    c = let c' = [snd begin .. snd end] in if dy >= 0 then c' else reverse c'

main :: IO ()
main = do
  [n, m, k] <- getArray
  a <- fmap (listArray ((1, 1), (n, m)) . map fromIntegral . concat) $ replicateM n $ getArray

  when (k == 1) $ do
    let ((x, y), _) = maximumBy (comparing snd) $ assocs a
    putStrLn $ show x ++ " " ++ show y
    exitSuccess

  sr <- accumulate (2 * k - 1) 0 1 a
  sc <- accumulate (2 * k - 1) 1 0 a
  sd <- accumulate k 1 1 a
  st <- accumulate (k - 1) 1 (-1) a

  let k' = k - 1
      k'' = k - 2
      shiftl (i, j) = sc!(i+k',j) - sd!(i+k',j-1) - st!(i-1,j-k''-1)
      shiftr (i, j) = sd!(i,j+k') + st!(i+k',j) - sc!(i+k',j-1)
      shiftu (i, j) = sr!(i,j+k') - sd!(i-1,j+k') - st!(i-1,j-k')
      shiftd (i, j) = sd!(i+k',j) + st!(i+k'',j+1) - sr!(i-1,j+k')
      shiftld (i, j) = sd!(i+k',j) - st!(i-1,j-k') - a!(i-k'-1,j)
      shiftrd (i, j) = st!(i+k',j) + a!(i,j+k') - sd!(i-1,j+k')

  diamond <- newIORef 0
  tril <- newIORef 0
  trir <- newIORef 0
  triu <- newIORef 0
  trid <- newIORef 0
  forM_ [1 .. 2 * k - 1] $ \i -> do
    forM_ [1 .. 2 * k - 1] $ \j -> do
      let d = k - abs (i - k) - abs (j - k)
          e = a!(i,j)
      when (d > 0) $ do
        modifyIORef' diamond (fromIntegral d * e +)
        when (j <= k) $ modifyIORef' tril (+e)
        when (j >= k) $ modifyIORef' trir (+e)
        when (i <= k) $ modifyIORef' triu (+e)
        when (i >= k) $ modifyIORef' trid (+e)

  best <- newIORef $ -1
  ans <- newIORef (0, 0)
  forM_ [k .. n - k + 1] $ \i -> do
    diamond' <- newIORef =<< readIORef diamond
    tril' <- newIORef =<< readIORef tril
    trir' <- newIORef =<< readIORef trir
    forM_ [k .. m - k + 1] $ \j -> do
      flag <- liftM2 (<) (readIORef best) (readIORef diamond')
      when flag $ do
        writeIORef best =<< readIORef diamond'
        writeIORef ans (i, j)
      when (j < m - k + 1) $ do
        modifyIORef' trir' (shiftr (i,j+1) +)
        diff <- liftM2 (-) (readIORef trir') (readIORef tril')
        modifyIORef' diamond' (+diff)
        modifyIORef' tril' (shiftl (i,j+1) +)
    when (i < n - k + 1) $ do
      modifyIORef' trid (shiftd (i+1,k) +)
      diff <- liftM2 (-) (readIORef trid) (readIORef triu)
      modifyIORef' diamond (+diff)
      modifyIORef' triu (shiftu (i+1,k) +)
      modifyIORef' tril (shiftld (i+1,k) +)
      modifyIORef' trir (shiftrd (i+1,k) +)

  (x, y) <- readIORef ans
  putStrLn $ show x ++ " " ++ show y
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

{-# OPTIONS_GHC -O2 -optc-Ofast -ignore-asserts #-}
import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Int
import Data.IORef
import Data.List
import Data.Maybe
import Data.Ord
import System.Exit
import qualified Data.ByteString.Char8 as C

type IA = UArray (Int, Int) Int64
type MA = IOUArray (Int, Int) Int64

accumulate :: Int -> Int -> Int -> IA -> IO IA
accumulate k dx dy a = do
  s <- thaw a :: IO MA
  let gets p = if inRange ix p then readArray s p else return 0
      geta p = if inRange ix p then a!p else 0
  forM_ r $ \i -> do
    forM_ c $ \j -> do
      t <- gets (i - dx, j - dy)
      writeArray s (i, j) $ t + geta (i, j) - geta (i - kdx, j - kdy)
  freeze s
  where
    kdx = k * dx
    kdy = k * dy
    ix@(begin, end) = bounds a
    r = let r' = [fst begin .. fst end] in if dx >= 0 then r' else reverse r'
    c = let c' = [snd begin .. snd end] in if dy >= 0 then c' else reverse c'

main :: IO ()
main = do
  [n, m, k] <- getArray
  a <- fmap (listArray ((1, 1), (n, m)) . map fromIntegral . concat) $ replicateM n $ getArray

  when (k == 1) $ do
    let ((x, y), _) = maximumBy (comparing snd) $ assocs a
    putStrLn $ show x ++ " " ++ show y
    exitSuccess

  sr <- accumulate (2 * k - 1) 0 1 a
  sc <- accumulate (2 * k - 1) 1 0 a
  sd <- accumulate k 1 1 a
  st <- accumulate (k - 1) 1 (-1) a

  let k' = k - 1
      k'' = k - 2
      shiftl (i, j) = sc!(i+k',j) - sd!(i+k',j-1) - st!(i-1,j-k''-1)
      shiftr (i, j) = sd!(i,j+k') + st!(i+k',j) - sc!(i+k',j-1)
      shiftu (i, j) = sr!(i,j+k') - sd!(i-1,j+k') - st!(i-1,j-k')
      shiftd (i, j) = sd!(i+k',j) + st!(i+k'',j+1) - sr!(i-1,j+k')
      shiftld (i, j) = sd!(i+k',j) - st!(i-1,j-k') - a!(i-k'-1,j)
      shiftrd (i, j) = st!(i+k',j) + a!(i,j+k') - sd!(i-1,j+k')

  diamond <- newIORef 0
  tril <- newIORef 0
  trir <- newIORef 0
  triu <- newIORef 0
  trid <- newIORef 0
  forM_ [1 .. 2 * k - 1] $ \i -> do
    forM_ [1 .. 2 * k - 1] $ \j -> do
      let d = k - abs (i - k) - abs (j - k)
          e = a!(i,j)
      when (d > 0) $ do
        modifyIORef' diamond (fromIntegral d * e +)
        when (j <= k) $ modifyIORef' tril (+e)
        when (j >= k) $ modifyIORef' trir (+e)
        when (i <= k) $ modifyIORef' triu (+e)
        when (i >= k) $ modifyIORef' trid (+e)

  best <- newIORef $ -1
  ans <- newIORef (0, 0)
  forM_ [k .. n - k + 1] $ \i -> do
    diamond' <- newIORef =<< readIORef diamond
    tril' <- newIORef =<< readIORef tril
    trir' <- newIORef =<< readIORef trir
    forM_ [k .. m - k + 1] $ \j -> do
      readIORef diamond' >>= print
      flag <- liftM2 (<) (readIORef best) (readIORef diamond')
      when flag $ do
        writeIORef best =<< readIORef diamond'
        writeIORef ans (i, j)
      when (j < m - k + 1) $ do
        modifyIORef' trir' (shiftr (i,j+1) +)
        diff <- liftM2 (-) (readIORef trir') (readIORef tril')
        modifyIORef' diamond' (+diff)
        modifyIORef' tril' (shiftl (i,j+1) +)
    when (i < n - k + 1) $ do
      modifyIORef' trid (shiftd (i+1,k) +)
      diff <- liftM2 (-) (readIORef trid) (readIORef triu)
      modifyIORef' diamond (+diff)
      modifyIORef' triu (shiftu (i+1,k) +)
      modifyIORef' tril (shiftld (i+1,k) +)
      modifyIORef' trir (shiftrd (i+1,k) +)

  (x, y) <- readIORef ans
  putStrLn $ show x ++ " " ++ show y
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Int
import Data.IORef
import Data.List
import Data.Maybe
import Data.Ord
import System.Exit
import qualified Data.ByteString.Char8 as C

type IA = UArray (Int, Int) Int64
type MA = IOUArray (Int, Int) Int64

accumulate :: Int -> Int -> Int -> IA -> IO IA
accumulate k dx dy a = do
  s <- thaw a :: IO MA
  let gets p = if inRange ix p then readArray s p else return 0
      geta p = if inRange ix p then a!p else 0
  forM_ r $ \i -> do
    forM_ c $ \j -> do
      t <- gets (i - dx, j - dy)
      writeArray s (i, j) $ t + geta (i, j) - geta (i - kdx, j - kdy)
  freeze s
  where
    kdx = k * dx
    kdy = k * dy
    ix@(begin, end) = bounds a
    r = let r' = [fst begin .. fst end] in if dx >= 0 then r' else reverse r'
    c = let c' = [snd begin .. snd end] in if dy >= 0 then c' else reverse c'

main :: IO ()
main = do
  [n, m, k] <- getArray
  a <- fmap (listArray ((1, 1), (n, m)) . map fromIntegral . concat) $ replicateM n $ getArray

  when (k == 1) $ do
    let ((x, y), _) = maximumBy (comparing snd) $ assocs a
    putStrLn $ show x ++ " " ++ show y
    exitSuccess

  sr <- accumulate (2 * k - 1) 0 1 a
  sc <- accumulate (2 * k - 1) 1 0 a
  sd <- accumulate k 1 1 a
  st <- accumulate (k - 1) 1 (-1) a

  let k' = k - 1
      k'' = k - 2
      shiftl (i, j) = sc!(i+k',j) - sd!(i+k',j-1) - st!(i-1,j-k''-1)
      shiftr (i, j) = sd!(i,j+k') + st!(i+k',j) - sc!(i+k',j-1)
      shiftu (i, j) = sr!(i,j+k') - sd!(i-1,j+k') - st!(i-1,j-k')
      shiftd (i, j) = sd!(i+k',j) + st!(i+k'',j+1) - sr!(i-1,j+k')

  diamond <- newIORef 0
  tril <- newIORef 0
  trir <- newIORef 0
  triu <- newIORef 0
  trid <- newIORef 0
  forM_ [1 .. 2 * k - 1] $ \i -> do
    forM_ [1 .. 2 * k - 1] $ \j -> do
      let d = k - abs (i - k) - abs (j - k)
          e = a!(i,j)
      when (d > 0) $ do
        modifyIORef diamond (fromIntegral d * e +)
        when (j <= k) $ modifyIORef' tril (+e)
        when (j >= k) $ modifyIORef' trir (+e)
        when (i <= k) $ modifyIORef' triu (+e)
        when (i >= k) $ modifyIORef' trid (+e)

  best <- newIORef $ -1
  ans <- newIORef (0, 0)
  forM_ [k .. n - k + 1] $ \i -> do
    temp <- newIORef =<< readIORef diamond
    forM_ [k .. m - k + 1] $ \j -> do
      flag <- liftM2 (<) (readIORef best) (readIORef temp)
      when flag $ do
        writeIORef best =<< readIORef temp
        writeIORef ans (i, j)
      when (j < m - k + 1) $ do
        modifyIORef trir (shiftr (i,j+1) +)
        diff <- liftM2 (-) (readIORef trir) (readIORef tril)
        modifyIORef temp (+diff)
        modifyIORef tril (shiftl (i,j+1) +)
    when (i < n - k + 1) $ do
      modifyIORef trid (shiftd (i+1,k) +)
      diff <- liftM2 (-) (readIORef trid) (readIORef triu)
      modifyIORef diamond (+diff)
      modifyIORef triu (shiftu (i+1,k) +)

  (x, y) <- readIORef ans
  putStrLn $ show x ++ " " ++ show y
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine


You are given a rooted tree, consisting of $$$n$$$ vertices. The vertices are numbered from $$$1$$$ to $$$n$$$, the root is the vertex $$$1$$$.You can perform the following operation at most $$$k$$$ times:   choose an edge $$$(v, u)$$$ of the tree such that $$$v$$$ is a parent of $$$u$$$;  remove the edge $$$(v, u)$$$;  add an edge $$$(1, u)$$$ (i. e. make $$$u$$$ with its subtree a child of the root). The height of a tree is the maximum depth of its vertices, and the depth of a vertex is the number of edges on the path from the root to it. For example, the depth of vertex $$$1$$$ is $$$0$$$, since it's the root, and the depth of all its children is $$$1$$$.What's the smallest height of the tree that can be achieved?

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of testcases. The first line of each testcase contains two integers $$$n$$$ and $$$k$$$ ($$$2 \le n \le 2 \cdot 10^5$$$; $$$0 \le k \le n - 1$$$) — the number of vertices in the tree and the maximum number of operations you can perform. The second line contains $$$n-1$$$ integers $$$p_2, p_3, \dots, p_n$$$ ($$$1 \le p_i < i$$$) — the parent of the $$$i$$$-th vertex. Vertex $$$1$$$ is the root. The sum of $$$n$$$ over all testcases doesn't exceed $$$2 \cdot 10^5$$$.

For each testcase, print a single integer — the smallest height of the tree that can achieved by performing at most $$$k$$$ operations.

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans.State
import Data.Array
import Data.Array.ST
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import qualified Data.ByteString.Lazy.Char8 as P
import Data.List
import Data.Maybe
import qualified Data.Ord
import Debug.Trace
import System.IO

mainFun :: SP Builder
mainFun = do
  casnum <- getInt
  res <- forM [1 .. casnum] $ \_ -> do
    n <- getInt
    m <- getInt
    p <- replicateM (n -1) getInt
    let g = genGraph n (zip p [2 ..])
    let d = calcDepth g
    let d' = sortOn (Data.Ord.Down . snd) d
    let p' = listArray (2, n) p
    let min_h = binSearch (validHeight g m p' d') 1 (n -1)
    pure [min_h]
  pure $ mconcat $ map putInts res

validHeight :: Array Int [Int] -> Int -> Array Int Int -> [(Int, Int)] -> Int -> Bool
validHeight g m p d h = runST $ do
  let n = rangeSize $ bounds g
  visited <- newArray (1, n) False -- :: ST s (STArray s Int Bool)
  let goUp x 0 = x
      --   goUp 1 h = if h > 0 then 0 else 1
      goUp x h = goUp (p ! x) (h -1)

  let visDown :: STArray s Int Bool -> Int -> ST s Int
      visDown vis x = do
        vx <- readArray vis x
        if vx
          then pure 0
          else do
            writeArray vis x True
            mapM_ (visDown vis) (g ! x)
            pure 1

  cuts <- forM d $ \(x, d) -> do
    vx <- readArray visited x
    if not vx && d > h
      then
        let anc = goUp x (h -1)
         in visDown visited anc
      else pure 0
  pure $ sum cuts <= m

binSearch :: (Int -> Bool) -> Int -> Int -> Int
binSearch v l r =
  if l == r
    then l
    else
      let m = div (l + r) 2
       in if v m
            then binSearch v l m
            else binSearch v (m + 1) r

calcDepth :: Array Int [Int] -> [(Int, Int)]
calcDepth g = go 0 1
  where
    go d x =
      let cs = (g ! x)
       in (x, d) : foldl' (++) [] ( map (go (d + 1)) cs)

genGraph :: Int -> [(Int, Int)] -> Array Int [Int]
genGraph n es = runSTArray $ do
  arr <- newArray (1, n) [] :: ST s (STArray s Int [Int])
  forM_ es $ \(a, b) -> do
    lst <- readArray arr a
    writeArray arr a (b : lst)
  return arr

type SP = State P.ByteString

type S = StateT P.ByteString

dropSpace :: P.ByteString -> P.ByteString
dropSpace = P.dropWhile (<= ' ') -- not exactly right, but close enough

--getNext :: Monad m => S m P.ByteString
--getNext = state $ P.span (> ' ') . dropSpace

getInt :: Monad m => S m Int
getInt = state $ fromJust . P.readInt . dropSpace

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

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

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

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

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

data TC = TC {n :: Int, k :: Int, ps :: [Int]}

type Output = Int

input :: Scanner TC
input = do
  n <- int
  k <- int
  ps <- (n - 1) >< int
  return TC {..}

solve :: TC -> Output
solve TC {..} = search 0 n
  where
    tree :: Array Int [Int]
    tree = accumArray (flip (:)) [] (1, n) $ zip ps [2 ..]

    -- (l, r]
    search :: Int -> Int -> Int
    search l r
      | l + 1 == r = r
      | check m = search l m
      | otherwise = search m r
        where
          m = (l + r + 1) `div` 2

    check :: Int -> Bool
    check h = snd (dfs h 1) <= k

    -- returns (dep, #ops)
    dfs :: Int -> Int -> (Int, Int)
    dfs hmax u
      | u == 1 = (0, ops)
      | otherwise = (1 + maximum (0 : filter (< hmax) ds), ops + count hmax ds)
      where
        (ds, ops) = tree ! u >$> map (dfs hmax) >>> unzip >>> second sum

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

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

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

-- Helpers
(>$>) = flip ($)

infixl 0 >$>

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

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

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

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

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

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

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

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

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

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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

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

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

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

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

(><) = times

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

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

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


You are given two strings $$$s$$$ and $$$t$$$, both consisting of exactly $$$k$$$ lowercase Latin letters, $$$s$$$ is lexicographically less than $$$t$$$.Let's consider list of all strings consisting of exactly $$$k$$$ lowercase Latin letters, lexicographically not less than $$$s$$$ and not greater than $$$t$$$ (including $$$s$$$ and $$$t$$$) in lexicographical order. For example, for $$$k=2$$$, $$$s=$$$"az" and $$$t=$$$"bf" the list will be ["az", "ba", "bb", "bc", "bd", "be", "bf"].Your task is to print the median (the middle element) of this list. For the example above this will be "bc".It is guaranteed that there is an odd number of strings lexicographically not less than $$$s$$$ and not greater than $$$t$$$.

The first line of the input contains one integer $$$k$$$ ($$$1 \le k \le 2 \cdot 10^5$$$) — the length of strings. The second line of the input contains one string $$$s$$$ consisting of exactly $$$k$$$ lowercase Latin letters. The third line of the input contains one string $$$t$$$ consisting of exactly $$$k$$$ lowercase Latin letters. It is guaranteed that $$$s$$$ is lexicographically less than $$$t$$$. It is guaranteed that there is an odd number of strings lexicographically not less than $$$s$$$ and not greater than $$$t$$$.

Print one string consisting exactly of $$$k$$$ lowercase Latin letters — the median (the middle element) of list of strings of length $$$k$$$ lexicographically not less than $$$s$$$ and not greater than $$$t$$$.

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, Safe #-}
{-# 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
import Data.Bits
import Data.List

getSeed = return . fromInteger . (`mod` 999983) . diffTimeToPicoseconds . utctDayTime =<< getCurrentTime :: IO Int

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

rstrip = C.takeWhile isPrint

--conv :: C.ByteString -> Integer
--conv = C.foldl' (\ !acc c -> acc * 26 + toInteger (ord c - 97)) 0
conv = map (subtract 97 . ord ) . C.unpack

sub a b = snd $ foldr f (0, []) $ zip a b
  where
    f (!ai, !bi) (!acc, r) = if c < 0 then ((-1), (c + 26) : r) else (0, c : r)
      where
        !c = ai - bi + acc

add :: [Int] -> [Int] -> [Int]
add a b = snd $ foldr f (0, []) $ zip a b
  where
    f (!ai, !bi) (!acc, r) = if c >= 26 then (1, (c - 26) : r) else (0, c : r)
      where
        !c = ai + bi + acc

div2 :: [Int] -> [Int]
div2 a = reverse $ snd $ foldl' f (0, []) a
  where
    f :: (Int, [Int]) -> Int -> (Int, [Int])
    f (!acc, r) !x = (e, d : r)
      where
        !c = acc * 26 + x
        (!d, !e) = divMod c 2

solve :: [C.ByteString] -> Builder
solve (nk:a:b:_) = (mconcat $ map (\ !i -> char7 $ chr $ i + 97) $ add a' $ div2 $ sub b' a' ) <> char7 '\n'
  where
    n = ru $ rstrip nk
    a', b' :: [Int]
    a' = conv $ C.take n a
    b' = conv $ C.take n b
    {-
    c = shiftR (a' + b') 1
    loop :: Integer -> Int -> String -> String
    loop !x 0 r = r
    loop !x !l r = loop u (pred l) ((chr $ fromInteger v + (97 :: Int)) : r)
      where
        (u, v) = divMod x 26
    -}
main :: IO ()
main = hPutBuilder stdout . solve . C.lines =<< C.getContents


Polycarp is working on a new project called "Polychat". Following modern tendencies in IT, he decided, that this project should contain chat as well. To achieve this goal, Polycarp has spent several hours in front of his laptop and implemented a chat server that can process three types of commands:  Include a person to the chat ('Add' command).  Remove a person from the chat ('Remove' command).  Send a message from a person to all people, who are currently in the chat, including the one, who sends the message ('Send' command). Now Polycarp wants to find out the amount of outgoing traffic that the server will produce while processing a particular set of commands.Polycarp knows that chat server sends no traffic for 'Add' and 'Remove' commands. When 'Send' command is processed, server sends l bytes to each participant of the chat, where l is the length of the message.As Polycarp has no time, he is asking for your help in solving this problem.

Input file will contain not more than 100 commands, each in its own line. No line will exceed 100 characters. Formats of the commands will be the following:   +<name> for 'Add' command.  -<name> for 'Remove' command.  <sender_name>:<message_text> for 'Send' command.  <name> and <sender_name> is a non-empty sequence of Latin letters and digits. <message_text> can contain letters, digits and spaces, but can't start or end with a space. <message_text> can be an empty line. It is guaranteed, that input data are correct, i.e. there will be no 'Add' command if person with such a name is already in the chat, there will be no 'Remove' command if there is no person with such a name in the chat etc. All names are case-sensitive.

Print a single number — answer to the problem.

+Mike
Mike:hello
+Kate
+Dmitry
-Dmitry
Kate:hi
-Kate

+Mike
-Mike
+Mike
Mike:Hi   I am here
-Mike
+Kate
-Kate

{-# LANGUAGE LambdaCase #-}
module Main where

import Data.List (foldl')

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

solve :: [String] -> Int
solve commands = total $ foldl' applyCommand (S 0 0) commands

applyCommand :: Solution -> String -> Solution
applyCommand (S parts count) = \case
  '+':_ -> S (parts + 1) count
  '-':_ -> S (parts - 1) count
  message  -> S parts (count + parts * msgLength) where msgLength = length . tail $ dropWhile (':' /=) message

data Solution = S {
  parts:: !Int,
  total:: !Int
}

{-# LANGUAGE LambdaCase #-}
module Main where

import Data.List (foldl')

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

solve :: [String] -> Int
solve commands = snd $ foldl' applyCommand (0, 0) commands

applyCommand :: (Int, Int) -> String -> (Int, Int)
applyCommand (parts, count) = \case
  '+':_ -> (parts + 1, count)
  '-':_ -> (parts - 1, count)
  message  -> (parts, count + parts * msgLength) where msgLength = length . tail $ dropWhile (':' /=) message

import Data.List
data Command = Add String|Remove String|Send String deriving Show
commandtype :: String -> Command
commandtype command@(x:xs) = if x=='+' then
                                 Add xs
                             else if x=='-' then
                                      Remove xs
                                  else
                                      Send (tail (dropWhile (':'/=) command))
solve [] n _ = n
solve (x:xs) n mem = case commandtype x of
                      Add name -> solve xs n (name:mem)
                      Remove name -> solve xs n (mem\\[name])
                      Send message -> solve xs (n+(length message)*(length mem)) mem

main = do l <- getContents
          print (solve (lines l) 0 [])

f(h,t)=q
    where
        q ('+':_) = (h+1,t)
        q ('-':_) = (h-1,t)
        q s = (h, t + h * length (dropWhile (/= ':')s) - h)
main = interact $ show . snd . foldl f (0,0) . lines

import Data.Maybe
import Data.List
parse :: [String] -> Int
parse xs = fst $ foldl f (0, 0) xs
    where f :: (Int, Int) -> String -> (Int, Int)
          f (dataC, peopleC) ('+':_) = (dataC, peopleC+1)
          f (dataC, peopleC) ('-':_) = (dataC, peopleC-1)
          f (dataC, peopleC) s = (dataC + peopleC * (length $ drop (fromJust (elemIndex ':' s) + 1) s), peopleC)
main = interact (show . parse . lines)

import qualified Data.Set as S

parse = lines

type State = (S.Set String, Int)

solve = foldl changeState (S.empty, 0)

changeState :: State -> String -> State
changeState (present, x) ('+':person) = (S.insert person present, x)
changeState (present, x) ('-':person) = (S.delete person present, x)
changeState (present, x) (person) = (present, x + S.size present * length message)
  where
    message = tail $ dropWhile (/= ':') person

presentate :: State -> String
presentate (_, n) = show n

main = interact $ presentate . solve . parse

main = do interact (show . gao 0 . lines) where
	gao _ [] = 0
	gao n (h:t) =
		if head h == '+' then
			gao (n + 1) t
		else if head h == '-' then
			gao (n - 1) t
		else
			n * (pred $ length $ dropWhile (/=':') h) + gao n t

module Main where

import qualified Data.Set as Set
import Data.List
import IO

type SetStr = Set.Set String

perform :: String -> (SetStr, Int) -> (SetStr, Int)
perform query@(x:xs) (s, ans)
    | x == '+'  = (Set.insert xs s, ans)
    | x == '-'  = (Set.delete xs s, ans)
    | otherwise = (s, ans + usersCount*msgLength) where
        usersCount =  Set.size s
        msgLength  = length (dropWhile (/= ':') query) - 1

processQuery :: (SetStr, Int) -> IO ()
processQuery state@(s, ans) = do
    stop <- isEOF
    if (not stop) then do
        query <- getLine
        let newState = perform query state
        processQuery newState
        else do
            print ans

main = processQuery (Set.empty, 0)

count [] people res = res
count (('+':_):next) people res = count next (people+1) res
count (('-':_):next) people res = count next (people-1) res
count (str:next) people res     = count next people (res + people*getMsg str)

getMsg str = length (dropWhile (/=':') str) - 1

main = do
    s <- getContents
    let line = lines s
        res   = count line 0 0
    putStrLn $ show res

function :: (Int, Int) -> String -> (Int, Int)
function (people, result) ('+':_) = (people + 1, result)
function (people, result) ('-':_) = (people - 1, result)
function (people, result) string = (people, result + people * (length (dropWhile (/=':') string) - 1))

wynik :: [String] -> (Int, Int)
wynik = foldl function (0, 0)

main = interact $ show . snd . wynik . lines

module Main(main) where

import qualified Data.Set as S

main :: IO ()
main = do
	instr <- return.lines =<< getContents
	print (solve 0 instr S.empty)

solve :: Int -> [String] -> S.Set String -> Int
solve x [] set = x
solve x (msg:msgs) set =
	case head msg of
		'+'	-> solve x msgs $ S.insert (tail msg) set
		'-'	-> solve x msgs $ S.delete (tail msg) set
		_	-> solve (x+(S.size set)*(length (tail $ snd $ span (/= ':') msg))) msgs set

main = getContents >>= putStrLn .show. func . lines

func :: [String] -> Int
func xs = snd $ foldl ( check ) (0,0) xs

check :: (Int,Int) -> String ->(Int,Int)
check (pep,l) mes = case head mes of
					'+' ->  (pep + 1,l)
					'-' -> 	if pep > 0 then (pep - 1,l) else ( 0,l)
					_	->	let
							lnew = length . takeWhile (/=':') . reverse
							in
							(pep,l + pep * (lnew mes) )

solve :: String -> String
solve s  =  show $ solve' (lines s) 0 0
  where
    solve' [] _ acc  =  acc
    solve' (('+':_):ss) n acc  =  solve' ss (n+1) acc
    solve' (('-':_):ss) n acc  =  solve' ss (n-1) acc
    solve' (s:ss) n acc  =  solve' ss n (acc + n * (length (dropWhile (/=':') s) - 1))

main :: IO ()
main  =  interact solve

import System.IO
main = print =<< mainLoop 0 0

mainLoop bytes member = do
    eof <- isEOF
    case eof of
        True -> return bytes
        _    -> step
  where
    step = do
        s <- getLine
        case s of
            ('+':_) -> mainLoop bytes (member + 1)
            ('-':_) -> mainLoop bytes (member - 1)
            _       ->
                let (_, ':':msg) = span (/=':') s
                in mainLoop (bytes + length msg * member) member

{-# LANGUAGE BangPatterns #-}
import Data.List

main = interact $ show . traffic . lines

traffic = fst . foldl' command (0, 0)

command (!x, !n) c = case c of
	('+':_) -> (x, n + 1)
	('-':_) -> (x, n - 1)
	_ -> (x + (length m - 1) * n, n)
	where m = dropWhile (/= ':') c

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

type Users = Int
type State = (Users, Int)
type Command = State -> State

conv :: String -> Command
conv = check where
  cmdAdd    (users, v) = (users + 1, v)
  cmdRemove (users, v) = (users - 1, v)
  cmdSend n (users, v) = (users, v + users * n)
  check ('+' : _) = cmdAdd
  check ('-' : _) = cmdRemove
  check s         = cmdSend n where
    n = length . takeWhile (/= ':') $ reverse s

simulate :: [Command] -> State
simulate = foldl' (flip id) (0, 0)

solve :: [String] -> [String]
solve = return . show . snd . simulate . map conv

main = interact $ unlines . solve . lines

-- Samples...
sample1 =
  [ "+Mike"
  , "Mike:hello"
  , "+Kate"
  , "+Dmitry"
  , "-Dmitry"
  , "Kate:hi"
  , "-Kate" ]

sample2 =
  [ "+Mike"
  , "-Mike"
  , "+Mike"
  , "Mike:Hi   I am here"
  , "-Mike"
  , "+Kate"
  , "-Kate" ]

handle (n, l) ('+':ss)  = (n + 1, l)
handle (n, l) ('-':ss)  = (n - 1, l)
handle (n, l) s = (n, l + n * (length . tail . dropWhile (/= ':')) s)
main = lines `fmap` getContents >>= putStr . show . snd . foldl handle (0, 0)

main = print . snd . foldl (\(n,ans) (s:ss) ->
     if s == '+' then (n+1,ans)
     else if s == '-' then (n-1,ans)
     else (n, n * (pred $ length $ dropWhile (/=':') ss) + ans)
     ) (0,0) =<< return . lines =<< getContents

{-# LANGUAGE LambdaCase #-}
module Main where

import Data.List (foldl')
import qualified Data.Set as S

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

solve :: [String] -> Int
solve commands = snd $ foldl' applyCommand (S.empty, 0) commands

applyCommand :: (S.Set String, Int) -> String -> (S.Set String, Int)
applyCommand (particpants, count) = \case
  '+':name -> (S.insert name particpants, count)
  '-':name -> (S.delete name particpants, count)
  message  -> (particpants, count + S.size particpants * msgLength) where msgLength = length . tail $ dropWhile (':' /=) message

import Data.Maybe
parse :: [String] -> Int
parse xs = fst $ foldl f (0, 0) xs
    where f :: (Int, Int) -> String -> (Int, Int)
          f (dataC, peopleC) ('+':_) = (dataC, peopleC+1)
          f (dataC, peopleC) ('-':_) = (dataC, peopleC-1)
          f (dataC, peopleC) s = (dataC + peopleC * (length $ drop (peopleC + 1) s), peopleC)
main = interact (show . parse . lines)


Vitaly has an array of n distinct integers. Vitaly wants to divide this array into three non-empty sets so as the following conditions hold:   The product of all numbers in the first set is less than zero ( < 0).  The product of all numbers in the second set is greater than zero ( > 0).  The product of all numbers in the third set is equal to zero.  Each number from the initial array must occur in exactly one set. Help Vitaly. Divide the given array.

The first line of the input contains integer n (3 ≤ n ≤ 100). The second line contains n space-separated distinct integers a1, a2, ..., an (|ai| ≤ 103) — the array elements.

In the first line print integer n1 (n1 > 0) — the number of elements in the first set. Then print n1 numbers — the elements that got to the first set. In the next line print integer n2 (n2 > 0) — the number of elements in the second set. Then print n2 numbers — the elements that got to the second set. In the next line print integer n3 (n3 > 0) — the number of elements in the third set. Then print n3 numbers — the elements that got to the third set. The printed sets must meet the described conditions. It is guaranteed that the solution exists. If there are several solutions, you are allowed to print any of them.

import Data.List

main :: IO ()
main = do
  _ <- getLine
  a <- fmap (map (read :: String -> Int) . words) getLine
  let (z,nz) = partition (==0) a
      (s,(h:t)) = partition (>0) nz
      (u,v) = splitAt (length t `div` 2 * 2) t
      i = [h]
      j = s ++ u
      k = z ++ v
  p i
  p j
  p k
  where
    p it = putStrLn $ unwords $ map show $ length it: it

main :: IO ()
main = interact $ unlines . map (unwords . map show) . solve . map read . tail . words

solve :: [Int] -> [[Int]]
solve as = [length s1'' : s1'', length s2' : s2', length s3' : s3']
  where
  [s1, s2, s3] = foldl f [[], [], []] as
  (s2', s1') = if null s2 then splitAt 2 s1 else (s2, s1)
  (s1'', s3') = if length s1' `mod` 2 == 0 then (tail s1', head s1' : s3) else (s1', s3)
  f [s1, s2, s3] a
    | a <  0 = [a : s1, s2, s3]
    | a >  0 = [s1, a : s2, s3]
    | a == 0 = [s1, s2, a : s3]

import Data.List

recombine [] _  _    = error "never mind"
recombine ns [] zs   = recombine (drop 2 ns) (take 2 ns) zs
recombine ns ps zs
  | even (length ns) = [tail ns, ps, head ns : zs]
  | otherwise        = [ns, ps, zs]

solve (n:xs) = recombine negatives positives zeroes
  where
    negatives = filter (< 0) xs
    positives = filter (> 0) xs
    zeroes = filter (== 0) xs

showSet xs = unwords $ map show (length xs : xs)

main = interact $ unlines . map showSet . solve . map read . words

import Data.List
main = interact ( unlines . map ( unwords . map show ) . af . filter ( /= 0 ) . sort . concat . map ( map read . words ) . tail . lines )
af ( x:y:[] ) = [[1,x],[1,y],[1,0]]
af ( x:y:z:t ) | y < 0 && z < 0 = [[1,x],[2,y,z],( length t )+1:0:t]
               | otherwise      = [[1,x],[1,z],( length t )+2:0:y:t]

import Data.List

main = interact ( conv . af . f . sort . r . tail . lines )
r (x:[]) = map read ( words x )
f = filter ( \x -> x /= 0 )
af :: [Int] -> [[Int]]
af ( x:y:[] ) = [[1,x],[1,y],[1,0]]
af ( x:y:z:t ) | y < 0 && z < 0 = [[1,x],[2,y,z],( length t )+1:0:t]
               | otherwise      = [[1,x],[1,z],( length t )+2:0:y:t]
conv :: [[Int]] -> String
conv [x,y,z] = ( g . show $ x ) ++ "\n" ++ ( g.show $ y ) ++ "\n" ++ ( g . show $ z )
g l = map ( \x -> if x == ',' then ' ' else x ) ( filter ( \x -> x /= '[' && x /= ']' ) l )

main = interact $ unlines . go . (map read) . concat . (map words) . lines
go (n:as) = (f bz):(f az):(f ez):[]
          where f z = (show $ length z) ++ " " ++ (unwords $ map show z)
                ng  = filter (<0) as
                bz  = [head ng]
                az  = (if length (tail ng) < 2 then [] else take 2 $ tail ng) ++ (filter (>0) as)
                ez  = [0] ++ (if length (tail ng) < 2 then tail ng else drop 3 ng)

solve x
    | gz /= [] = [head lz] : [head gz] : (z ++ tail gz ++ tail lz) : []
    | otherwise = [lz !! 2] : take 2 lz : (z ++ drop 3 lz): []
    where lz = filter (<0) x
          gz = filter (>0) x
          z  = filter (==0) x

l x = length x : x

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

import Control.Monad (liftM)
import Data.List (intercalate)
import Prelude hiding (reads)

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

solve :: [Int] -> [[Int]]
solve xs
  | even (length ms)  =  [as, bsEven, csEven]
  | otherwise  =  [as, bsOdd, csOdd]
  where
    as  =  [head ms]
    bsEven  =  tail $ tail ms ++ ps
    bsOdd  =  tail ms ++ ps
    csEven  =  [head $ tail ms] ++ zs
    csOdd  =  zs
    ps  =  filter (> 0) xs
    zs  =  filter (== 0) xs
    ms  =  filter (< 0) xs

print' ::  [Int] -> IO ()
print' xs  =  putStrLn $ intercalate " " $ map show $ (length xs : xs)

main :: IO ()
main  =  getLine >> reads >>= mapM_ print' . solve

solve :: [Int] -> [[Int]]
solve xs = [take 1 negative,
            (if positive == []
             then (take 2 (drop 1 negative))
             else positive),
            (if positive == []
             then (zero ++ drop 3 negative)
             else (zero ++ drop 1 negative))]
  where negative = filter (<0) xs
        positive = filter (>0) xs
        zero = filter (==0) xs

showSet :: [Int] -> String
showSet xs = unwords $ map show (length xs:xs)

showSolution :: [[Int]] -> String
showSolution xs = unlines $ map showSet xs

main = interact $ showSolution . solve . map read . tail . words

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

main = do
  _ <- getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let x1 = filter (\x -> x < 0) xs
      x2 = filter (\x -> x > 0) xs
      x3 = filter (\x -> x == 0) xs
      n1 = [head x1]
      tx1 = tail x1
      n2 = x2 ++ (if (length (tx1) >= 2) then take 2 tx1 else [])
      n3 = x3 ++ (if (length (tx1) >= 2) then drop 2 (tail x1) else take 2 tx1)

  putStr $ show (length(n1)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n1
  putStrLn ""

  putStr $ show (length(n2)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n2
  putStrLn ""

  putStr $ show (length(n3)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n3
  putStrLn ""

import Data.List ((\\), sort)

main :: IO ()
main = getContents >>= mapM_ (\xs -> putStrLn $ unwords $ map show $ length xs : xs) . solve . map read . tail . words

solve :: [Int] -> [[Int]]
solve as = [ n1, n2, (as \\ n1) \\ n2 ]
  where n1 = [ minimum as ]
        n2 = if maximum as > 0 then [ maximum as ] else take 2 (tail (sort as))

main=interact$unlines.map(unwords.map show).f.map read.tail.words
f xs
  | odd $ length (x:xs1) = [[1,x],length(xs1++xs2):(xs1++xs2),length xs3:xs3]
  | otherwise = [[1,x],length(tail xs1++xs2):(tail xs1++xs2),(length xs3+1):head xs1:xs3]
   where
     (x:xs1)=filter(<0)xs
     xs2=filter(>0)xs
     xs3=filter(0==)xs

import Data.List

gao::([Int],[Int])->([Int],[Int])
gao (a,b) = if (b!!0)>0 then (a,b) else (b,a)

main::IO()
main = do
	input<-getContents
	let
		(n:olda)=map read (words input) :: [Int]
		(x:a)=sort olda
		len = length $ takeWhile (<=0) a
		(b,c)=gao $ if len <2 then splitAt len a else splitAt 2 a
		out a = ( show $ length a ) ++ " " ++ ( foldr (\a t -> t++a) [] (map ((++" ").show) a) )
	putStrLn $ out [x]
	putStrLn $ out c
	putStrLn $ out b

module Main where

printSolution :: ([Int], [Int], [Int]) -> IO ()
printSolution (a, b, c) = do
  putStrLn ((show $ length a) ++ " " ++ (unwords $ map show a))
  putStrLn ((show $ length b) ++ " " ++ (unwords $ map show b))
  putStrLn ((show $ length c) ++ " " ++ (unwords $ map show c))

classify :: ([Int], [Int], [Int]) -> Int -> ([Int], [Int], [Int])
classify (a, b, c) n
  | n  < 0 = (n:a,   b,   c)
  | n  > 0 = (  a, n:b,   c)
  | n == 0 = (  a,   b, n:c)

fixPositive :: ([Int], [Int], [Int]) -> ([Int], [Int], [Int])
fixPositive (a1:a2:as, [], c) = (as, [a1, a2], c)
fixPositive t = t

fixNegative :: ([Int], [Int], [Int]) -> ([Int], [Int], [Int])
fixNegative t@(a,b,c) = if (length a) `rem` 2 == 0 then (tail a, b, (head a) : c) else t

solve :: [Int] -> ([Int], [Int], [Int])
solve = fixNegative . fixPositive . foldl classify ([], [], [])

main = getLine >> getLine >>= (printSolution . solve . map read . words)

import Control.Applicative
import Data.List

del x (a:as) 	| x==a = as
		| otherwise = a: (del x as)

main= do
	 getLine
	 a<- map read. words <$> getLine::IO [Int]
	 let b1 = head $ filter (<0) a
	 let a1 = del b1 a
	 let b21 =  filter (>0) a1
	 let b2 =if b21 ==[] then  take 2 $ filter (<0) a1 else  take 1 b21
	 let b31 =   (del (head b2) a1)
         let b3 = if length b2 >1 then (del (last b2) b31) else b31
	 putStrLn $ "1 " ++ show b1
	 putStrLn $  (show (length b2)) ++ " " ++(unwords (map show b2))
	 putStrLn $ (show (length b3)) ++ " " ++(unwords (map show b3))

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

main :: IO ()
main = do
	_ <- getLine
	line <- getLine
	let
		arr = map read. words $ line
		pos = filter (> 0) arr
		neg = filter (<0) arr
		zero = filter (==0) arr
		[arr1, arr2, arr3] = if length neg >= 3 then  [[neg!!0], [neg!!1, neg!!2], (drop 3 neg) ++ (pos) ++ zero]  else [[neg!!0], [pos!!0], (drop 1 pos) ++ (drop 1 neg) ++ zero]
	putStr $ (show (length arr1)) ++ " "
	mapM_ (\x -> putStr $ (show x) ++ " ") arr1
	putStrLn ""
	putStr $ (show (length arr2)) ++ " "
	mapM_ (\x -> putStr $ (show x) ++ " ") arr2
	putStrLn ""
	putStr $ (show (length arr3)) ++ " "
	mapM_ (\x -> putStr $ (show x) ++ " ") arr3

main :: IO()
main = interact work

work :: String -> String
work input = unlines . map showList . solve $ numbers
    where numbers = map parseInt . words . last . lines $ input
          parseInt str = read str :: Int
          showList lst = (show . length $ lst) ++ " " ++ (unwords . map show $ lst)

solve :: [Int] -> [[Int]]
solve numbers = if null ps
                then [[head ns], tail . take 3 $ ns, drop 3 ns ++ zs]
                else [[head ns], [head ps], tail ns ++ tail ps ++ zs]
    where ps = filter (\x -> x > 0) numbers
          ns = filter (\x -> x < 0) numbers
          zs = filter (\x -> x == 0) numbers

import Data.List

recombine [] _  _    = error "never mind"
recombine ns [] zs   = [drop 2 ns, take 2 ns, zs]
recombine ns ps zs
  | even (length ns) = [tail ns, ps, head ns : zs]
  | otherwise        = [ns, ps, zs]

solve (n:xs) = recombine negatives positives zeroes
  where
    negatives = filter (< 0) xs
    positives = filter (> 0) xs
    zeroes = filter (== 0) xs

showSet xs = unwords $ map show (length xs : xs)

main = interact $ unlines . map showSet . solve . map read . words

main = interact $ unlines . go . (map read) . concat . (map words) . lines
go (n:as) = (f bz):(f az):(f ez):[]
          where f z = (show $ length z) ++ " " ++ (unwords $ map show z)
                ng  = filter (<0) as
                bz  = [head ng]
                az  = (take 2 $ tail ng) ++ (filter (>0) as)
                ez  = [0]

main = interact $ show . unlines . go . (map read) . concat . (map words) . lines
go (n:as) = (f bz):(f az):(f ez):[]
          where f z = (show $ length z) ++ (foldl (\s x -> " " ++ (show x) ++ s) [] z)
                ng  = filter (<0) as
                bz  = [head ng]
                az  = (take 2 $ tail ng) ++ (filter (>0) as)
                ez  = [0]

import Control.Monad (liftM)
import Data.List (intercalate)
import Prelude hiding (reads)

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

solve :: [Int] -> [[Int]]
solve xs  =  [as, bs, cs]
  where
    as  =  [head $ filter (< 0) xs]
    bs  =  tail $ filter (< 0) xs ++ filter (> 0) xs
    cs  =  filter (== 0) xs

print' ::  [Int] -> IO ()
print' xs  =  putStrLn $ intercalate " " $ map show $ (length xs : xs)

main :: IO ()
main  =  getLine >> reads >>= mapM_ print' . solve

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

main = do
  _ <- getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let x1 = filter (\x -> x < 0) xs
      x2 = filter (\x -> x > 0) xs
      x3 = filter (\x -> x == 0) xs
      n1 = [head x1]
      n2 = take 2 (tail x1) ++ x2
      n3 = drop 3 x1 ++ x3

  putStr $ show (length(n1)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n1
  putStrLn ""

  putStr $ show (length(n2)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n2
  putStrLn ""

  putStr $ show (length(n3)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n3
  putStrLn ""

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

main = do
  _ <- getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let x1 = filter (\x -> x < 0) xs
      x2 = filter (\x -> x > 0) xs
      x3 = filter (\x -> x == 0) xs
      n1 = [head x1]
      n2 = if length(x2) == 0 then take 2 x1 else x2
      n3 = if length(x2) == 0 then drop 2 x1 ++ x3 else x3

  putStr $ show (length(n1)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n1
  putStrLn ""

  putStr $ show (length(n2)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n2
  putStrLn ""

  putStr $ show (length(n3)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n3
  putStrLn ""

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

main = do
  _ <- getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let x1 = filter (\x -> x < 0) xs
      x2 = filter (\x -> x > 0) xs
      x3 = filter (\x -> x == 0) xs
      n1 = [head x1]
      n2 = x2 ++ take 2 (tail x1)
      n3 = x3 ++ drop 2 (tail x1)

  putStr $ show (length(n1)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n1
  putStrLn ""

  putStr $ show (length(n2)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n2
  putStrLn ""

  putStr $ show (length(n3)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n3
  putStrLn ""

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

main = do
  _ <- getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let x1 = filter (\x -> x < 0) xs
      x2 = filter (\x -> x > 0) xs
      x3 = filter (\x -> x == 0) xs
      n1 = [head x1]
      n2 = if length(x2) == 0 then tail x1 ++ x2 else x2
      n3 = if length(x2) /= 0 then tail x1 ++ x3 else x3

  putStr $ show (length(n1)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n1
  putStrLn ""

  putStr $ show (length(n2)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n2
  putStrLn ""

  putStr $ show (length(n3)) ++ " "
  mapM_ (\x -> putStr $ show(x) ++ " ") n3
  putStrLn ""

module Main where

printSolution :: ([Int], [Int], [Int]) -> IO ()
printSolution (a, b, c) = do
  putStrLn ((show $ length a) ++ " " ++ (unwords $ map show a))
  putStrLn ((show $ length b) ++ " " ++ (unwords $ map show b))
  putStrLn ((show $ length c) ++ " " ++ (unwords $ map show c))

classify :: ([Int], [Int], [Int]) -> Int -> ([Int], [Int], [Int])
classify (a, b, c) n
  | n  < 0 = (n:a,   b,   c)
  | n  > 0 = (  a, n:b,   c)
  | n == 0 = (  a,   b, n:c)

fixSolution :: ([Int], [Int], [Int]) -> ([Int], [Int], [Int])
fixSolution (a1:a2:as, [], c) = (as, [a1, a2], c)
fixSolution t = t

solve :: [Int] -> ([Int], [Int], [Int])
solve = foldl classify ([], [], [])

main = getLine >> getLine >>= (printSolution . fixSolution . solve . map read . words)


Since Sonya is interested in robotics too, she decided to construct robots that will read and recognize numbers.Sonya has drawn $$$n$$$ numbers in a row, $$$a_i$$$ is located in the $$$i$$$-th position. She also has put a robot at each end of the row (to the left of the first number and to the right of the last number). Sonya will give a number to each robot (they can be either same or different) and run them. When a robot is running, it is moving toward to another robot, reading numbers in the row. When a robot is reading a number that is equal to the number that was given to that robot, it will turn off and stay in the same position.Sonya does not want robots to break, so she will give such numbers that robots will stop before they meet. That is, the girl wants them to stop at different positions so that the first robot is to the left of the second one.For example, if the numbers $$$[1, 5, 4, 1, 3]$$$ are written, and Sonya gives the number $$$1$$$ to the first robot and the number $$$4$$$ to the second one, the first robot will stop in the $$$1$$$-st position while the second one in the $$$3$$$-rd position. In that case, robots will not meet each other. As a result, robots will not be broken. But if Sonya gives the number $$$4$$$ to the first robot and the number $$$5$$$ to the second one, they will meet since the first robot will stop in the $$$3$$$-rd position while the second one is in the $$$2$$$-nd position.Sonya understands that it does not make sense to give a number that is not written in the row because a robot will not find this number and will meet the other robot.Sonya is now interested in finding the number of different pairs that she can give to robots so that they will not meet. In other words, she wants to know the number of pairs ($$$p$$$, $$$q$$$), where she will give $$$p$$$ to the first robot and $$$q$$$ to the second one. Pairs ($$$p_i$$$, $$$q_i$$$) and ($$$p_j$$$, $$$q_j$$$) are different if $$$p_i\neq p_j$$$ or $$$q_i\neq q_j$$$.Unfortunately, Sonya is busy fixing robots that broke after a failed launch. That is why she is asking you to find the number of pairs that she can give to robots so that they will not meet.

The first line contains a single integer $$$n$$$ ($$$1\leq n\leq 10^5$$$) — the number of numbers in a row. The second line contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1\leq a_i\leq 10^5$$$) — the numbers in a row.

Print one number — the number of possible pairs that Sonya can give to robots so that they will not meet.

import Data.List.Split as Split
import Data.Bits
import Data.List
import Data.Set as Set
import Data.IntMap as Map
-- import Data.HashMap as Map
import Data.Array as A

stringToInt s = read s :: Int

int_arr = Prelude.map stringToInt . words

main = do
  ns <- getLine
  let n = stringToInt ns
  as <- getLine
  let an = int_arr as
  print (no_meet n an)
  -- putStrLn (foldl (\acc s -> acc ++ s) [] num_arr)

-- no_meet an =
--   let len = length $ Set.toList $ Set.fromList an
--   in sum [i | i <- [1..(len-1)]]

no_meet :: Int -> [Int] -> Integer
no_meet n an = nm an (Map.empty) (prepare_aux_arr n an) 1

nm [_] _ _ _ = 0
nm (a:as) m aux n =
  case Map.lookup a m of
    Just _ -> nm as m aux (n+1)
    Nothing ->
      let m1 = Map.insert a True m
      in (toInteger (aux A.! n)) + nm as m1 aux (n+1)

-- calc [] an = 0
-- calc (b:bs) an =
--   let (h, t) = splitBy b an
--   in (length $ uniq t) + (calc bs an)

prepare_aux_arr :: Int -> [Int] -> Array Int Int
prepare_aux_arr n an =
  let (l, _) = aux an Map.empty
  in A.listArray (0, n-1) l

-- aux [] m = ([], M.empty)
aux (x:[]) m = ([1], (Map.insert x True m))
aux (x:xs) m =
  let ((a:as), m1) = aux xs m
  in case Map.lookup x m1 of
    Just _ -> ((a:a:as), m1)
    Nothing -> (((a + 1):a:as), (Map.insert x True m1))

splitBy :: (Eq t) => t -> [t] -> ([t], [t])
splitBy _n [] = ([], [])
splitBy n (x:xs)
  | n == x = ([n], xs)
  | otherwise =
    let (h, t) = splitBy n xs
    in ((x:h), t)

-- no_meet :: [Int] -> Int
-- no_meet an =
--   let len = cn an Map.empty Map.empty
--   in sum [1..(len-1)]

-- cn [] m1 m2 = (length (Map.keys m1)) + (length (Map.keys m2))
-- cn (x:xs) m1 m2 =
--   case Map.lookup x m1 of
--     Just _ ->
--       let m21 = Map.insert x True m2
--       in cn xs m1 m21
--     Nothing ->
--       let m11 = Map.insert x True m1
--       in cn xs m11 m2

-- uniq = Set.toList . Set.fromList

drop_last [_] = []
drop_last l = fst $ splitAt ((length l) - 1) l

-- no_meet :: [Int] -> Int
-- no_meet an =
--   let begin = drop_last an
--       begin_uniq = uniq begin
--   in calc begin_uniq an

-- calc [] an = 0
-- calc (b:bs) an =
--   let (h, t) = splitBy b an
--   in (length $ uniq t) + (calc bs an)

import Data.List.Split as Split
import Data.Bits
import Data.List
import Data.Set as Set
import Data.IntMap as Map
-- import Data.HashMap as Map
import Data.Array as A

stringToInt s = read s :: Int

int_arr = Prelude.map stringToInt . words

main = do
  ns <- getLine
  let n = stringToInt ns
  as <- getLine
  let an = int_arr as
  print (no_meet n an)
  -- putStrLn (foldl (\acc s -> acc ++ s) [] num_arr)

-- no_meet an =
--   let len = length $ Set.toList $ Set.fromList an
--   in sum [i | i <- [1..(len-1)]]

no_meet :: Int -> [Int] -> Int
no_meet n an = nm an (Map.empty) (prepare_aux_arr n an) 1

nm [_] _ _ _ = 0
nm (a:as) m aux n =
  case Map.lookup a m of
    Just _ -> nm as m aux (n+1)
    Nothing ->
      let m1 = Map.insert a True m
      in (aux A.! n) + nm as m1 aux (n+1)

-- calc [] an = 0
-- calc (b:bs) an =
--   let (h, t) = splitBy b an
--   in (length $ uniq t) + (calc bs an)

prepare_aux_arr :: Int -> [Int] -> Array Int Int
prepare_aux_arr n an =
  let (l, _) = aux an Map.empty
  in A.listArray (0, n-1) l

-- aux [] m = ([], M.empty)
aux (x:[]) m = ([1], (Map.insert x True m))
aux (x:xs) m =
  let ((a:as), m1) = aux xs m
  in case Map.lookup x m1 of
    Just _ -> ((a:a:as), m1)
    Nothing -> (((a + 1):a:as), (Map.insert x True m1))

splitBy :: (Eq t) => t -> [t] -> ([t], [t])
splitBy _n [] = ([], [])
splitBy n (x:xs)
  | n == x = ([n], xs)
  | otherwise =
    let (h, t) = splitBy n xs
    in ((x:h), t)

-- no_meet :: [Int] -> Int
-- no_meet an =
--   let len = cn an Map.empty Map.empty
--   in sum [1..(len-1)]

-- cn [] m1 m2 = (length (Map.keys m1)) + (length (Map.keys m2))
-- cn (x:xs) m1 m2 =
--   case Map.lookup x m1 of
--     Just _ ->
--       let m21 = Map.insert x True m2
--       in cn xs m1 m21
--     Nothing ->
--       let m11 = Map.insert x True m1
--       in cn xs m11 m2

-- uniq = Set.toList . Set.fromList

drop_last [_] = []
drop_last l = fst $ splitAt ((length l) - 1) l

-- no_meet :: [Int] -> Int
-- no_meet an =
--   let begin = drop_last an
--       begin_uniq = uniq begin
--   in calc begin_uniq an

-- calc [] an = 0
-- calc (b:bs) an =
--   let (h, t) = splitBy b an
--   in (length $ uniq t) + (calc bs an)

import Data.List.Split as Split
import Data.Bits
import Data.List
import Data.Set as Set

stringToInt s = read s :: Int

int_arr = Prelude.map stringToInt . words

main = do
  ns <- getLine
  let n = stringToInt ns
  as <- getLine
  let an = int_arr as
  print (no_meet an)
  -- putStrLn (foldl (\acc s -> acc ++ s) [] num_arr)

no_meet an =
  let len = length $ Set.toList $ Set.fromList an
  in sum [i | i <- [1..(len-1)]]


Squirrel Liss loves nuts. There are n trees (numbered 1 to n from west to east) along a street and there is a delicious nut on the top of each tree. The height of the tree i is hi. Liss wants to eat all nuts.Now Liss is on the root of the tree with the number 1. In one second Liss can perform one of the following actions:  Walk up or down one unit on a tree.  Eat a nut on the top of the current tree.  Jump to the next tree. In this action the height of Liss doesn't change. More formally, when Liss is at height h of the tree i (1 ≤ i ≤ n - 1), she jumps to height h of the tree i + 1. This action can't be performed if h > hi + 1. Compute the minimal time (in seconds) required to eat all nuts.

The first line contains an integer n (1  ≤  n ≤ 105) — the number of trees. Next n lines contains the height of trees: i-th line contains an integer hi (1 ≤ hi ≤ 104) — the height of the tree with the number i.

Print a single integer — the minimal time required to eat all nuts in seconds.

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

main = do
	n <- read <$> getLine
	hs <- replicateM n $ read <$> getLine
	print $ solve hs 0 0

solve :: [Int] -> Int -> Int -> Int
solve [] _ res = res - 1
solve (c:hs) h res = solve hs c ( res + abs ( c - h ) + 2 )

import Control.Monad;

main :: IO ()
main = do
  n <- fmap read getLine
  h1:hRest <- replicateM n $ fmap read getLine
  let time curH leftHs =
        case leftHs of
          []     ->  0
          h:rest ->  (abs (curH - h) + 2) + time h rest
  print $ h1 + 1 + time h1 hRest

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

solve (h:hs) = fst $
    foldl' (\(j,y) x -> (j + 2 + (if y == x then 0 else abs $ x - y ),x)) (h + 1,h) (hs)

main = do
    let int = fst .fromJust . B.readInt
    n <- readLn :: IO Int
    hs <- replicateM n (int <$> B.getLine)
    print $ solve hs

solve :: [Int] -> Int
solve xs  =  solve' 0 xs - 1
  where
    solve' h []  =  0
    solve' h (x:xs)
      | h <= x  =  1 + (x - h) + 1 + solve' x xs
      | otherwise  =  (h - x) + 1 + 1 + solve' x xs

main :: IO ()
main  =  do
    n   <-  readLn
    xs  <-  sequence $ replicate n readLn
    print $ solve xs

import Control.Applicative

main = do
  getLine
  trees <- map read . lines <$> getContents
  print $ (length trees)*2 - 1 + slv trees 0 0

slv [] n _ = n
slv (x:xs) n prevLvl = slv xs (abs (prevLvl-x)+n) x


There are n people and k keys on a straight line. Every person wants to get to the office which is located on the line as well. To do that, he needs to reach some point with a key, take the key and then go to the office. Once a key is taken by somebody, it couldn't be taken by anybody else.You are to determine the minimum time needed for all n people to get to the office with keys. Assume that people move a unit distance per 1 second. If two people reach a key at the same time, only one of them can take the key. A person can pass through a point with a key without taking it.

The first line contains three integers n, k and p (1 ≤ n ≤ 1 000, n ≤ k ≤ 2 000, 1 ≤ p ≤ 109) — the number of people, the number of keys and the office location. The second line contains n distinct integers a1, a2, ..., an (1 ≤ ai ≤ 109) — positions in which people are located initially. The positions are given in arbitrary order. The third line contains k distinct integers b1, b2, ..., bk (1 ≤ bj ≤ 109) — positions of the keys. The positions are given in arbitrary order. Note that there can't be more than one person or more than one key in the same point. A person and a key can be located in the same point.

Print the minimum time (in seconds) needed for all n to reach the office with keys.

NoteIn the first example the person located at point 20 should take the key located at point 40 and go with it to the office located at point 50. He spends 30 seconds. The person located at point 100 can take the key located at point 80 and go to the office with it. He spends 50 seconds. Thus, after 50 seconds everybody is in office with keys.

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Data.Array.Unboxed
import Data.List

main = do
  [np, nk, o] <- fmap readInts B.getLine
  ps <- fmap readInts B.getLine
  ks <- fmap readInts B.getLine
  print $ solve np nk o ps ks

solve np nk o ps' ks' = tbl!(np, nk)
  where
    ps = listArray (1, np) $ sort ps' :: UArray Int Int
    ks = listArray (1, nk) $ sort ks' :: UArray Int Int
    tbl = listArray bnd $ map go $ range bnd :: Array (Int, Int) Int
      where
        bnd = ((0, 0), (np, nk))
        go (ip, ik)
          | ip > ik = maxBound
          | ip == 0 = 0
          | otherwise = max (tbl!(ip - 1, ik - 1)) $ min (tbl!(ip, ik - 1)) $ abs (ps!ip - ks!ik) + abs(ks!ik - o)

readInt = maybe undefined fst . B.readInt
readInts = fmap readInt . B.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
module Main where
import qualified Data.ByteString.Char8 as B
import Data.Array.Unboxed
import Data.List

main = do
  [np, nk, o] <- fmap readInts B.getLine
  ps <- fmap readInts B.getLine
  ks <- fmap readInts B.getLine
  print $ solve np nk o ps ks

solve np nk o ps' ks' = tbl!(np, nk)
  where
    ps = listArray (1, np) $ sort ps' :: UArray Int Int
    ks = listArray (1, nk) $ sort ks' :: UArray Int Int
    tbl = listArray bnd $ map go $ range bnd :: Array (Int, Int) Int
      where
        bnd = ((0, 0), (np, nk))
        go (ip, ik)
          | ip > ik = 1000000
          | ip == 0 = 0
          | otherwise = max (tbl!(ip - 1, ik - 1)) $ min (tbl!(ip, ik - 1)) $ abs (ps!ip - ks!ik) + abs(ks!ik - o)

readInt = maybe undefined fst . B.readInt
readInts = fmap readInt . B.words


A sequence of $$$n$$$ numbers is called permutation if it contains all numbers from $$$1$$$ to $$$n$$$ exactly once. For example, the sequences $$$[3, 1, 4, 2]$$$, [$$$1$$$] and $$$[2,1]$$$ are permutations, but $$$[1,2,1]$$$, $$$[0,1]$$$ and $$$[1,3,4]$$$ are not.For a given number $$$n$$$ you need to make a permutation $$$p$$$ such that two requirements are satisfied at the same time:  For each element $$$p_i$$$, at least one of its neighbors has a value that differs from the value of $$$p_i$$$ by one. That is, for each element $$$p_i$$$ ($$$1 \le i \le n$$$), at least one of its neighboring elements (standing to the left or right of $$$p_i$$$) must be $$$p_i + 1$$$, or $$$p_i - 1$$$.  the permutation must have no fixed points. That is, for every $$$i$$$ ($$$1 \le i \le n$$$), $$$p_i \neq i$$$ must be satisfied. Let's call the permutation that satisfies these requirements funny.For example, let $$$n = 4$$$. Then [$$$4, 3, 1, 2$$$] is a funny permutation, since:   to the right of $$$p_1=4$$$ is $$$p_2=p_1-1=4-1=3$$$;  to the left of $$$p_2=3$$$ is $$$p_1=p_2+1=3+1=4$$$;  to the right of $$$p_3=1$$$ is $$$p_4=p_3+1=1+1=2$$$;  to the left of $$$p_4=2$$$ is $$$p_3=p_4-1=2-1=1$$$.  for all $$$i$$$ is $$$p_i \ne i$$$. For a given positive integer $$$n$$$, output any funny permutation of length $$$n$$$, or output -1 if funny permutation of length $$$n$$$ does not exist.

The first line of input data contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. The description of the test cases follows. Each test case consists of f single line containing one integer $$$n$$$ ($$$2 \le n \le 2 \cdot 10^5$$$). It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, print on a separate line:    any funny permutation $$$p$$$ of length $$$n$$$;  or the number -1 if the permutation you are looking for does not exist.

NoteThe first test case is explained in the problem statement.In the second test case, it is not possible to make the required permutation: permutations $$$[1, 2, 3]$$$, $$$[1, 3, 2]$$$, $$$[2, 1, 3]$$$, $$$[3, 2, 1]$$$ have fixed points, and in $$$[2, 3, 1]$$$ and $$$[3, 1, 2]$$$ the first condition is met not for all positions.

module Main where

import Data.Function
import Control.Monad
--import Data.Text (split)

toInt :: String -> Int
toInt str = core * (length xs + 1)
  where
    (s : xs) = reverse str
    core = case s of
      'S' -> -1
      'M' -> 0
      'L' -> 1

compareTShirts :: String -> String -> String
compareTShirts a b = toAns $ (compare `on` toInt) a b
  where
    toAns LT = "<"
    toAns EQ = "="
    toAns GT = ">"

funnyPermute :: Int -> [Int]
funnyPermute 2 = [2, 1]
funnyPermute 3 = []
funnyPermute x = x : x - 1 : [1..x-2]

main :: IO ()
main = do
  n <- getLine
  replicateM_ (read n) test
  where
    test = do
      input <- getLine
      let x = read input
      let ans = unwords $ map show $ funnyPermute x
      putStrLn (if ans == "" then "-1" else ans)