Recently n students from city S moved to city P to attend a programming camp.They moved there by train. In the evening, all students in the train decided that they want to drink some tea. Of course, no two people can use the same teapot simultaneously, so the students had to form a queue to get their tea.i-th student comes to the end of the queue at the beginning of li-th second. If there are multiple students coming to the queue in the same moment, then the student with greater index comes after the student with lesser index. Students in the queue behave as follows: if there is nobody in the queue before the student, then he uses the teapot for exactly one second and leaves the queue with his tea; otherwise the student waits for the people before him to get their tea. If at the beginning of ri-th second student i still cannot get his tea (there is someone before him in the queue), then he leaves the queue without getting any tea. For each student determine the second he will use the teapot and get his tea (if he actually gets it).

The first line contains one integer t — the number of test cases to solve (1 ≤ t ≤ 1000). Then t test cases follow. The first line of each test case contains one integer n (1 ≤ n ≤ 1000) — the number of students. Then n lines follow. Each line contains two integer li, ri (1 ≤ li ≤ ri ≤ 5000) — the second i-th student comes to the end of the queue, and the second he leaves the queue if he still cannot get his tea. It is guaranteed that for every  condition li - 1 ≤ li holds. The sum of n over all test cases doesn't exceed 1000. Note that in hacks you have to set t = 1.

For each test case print n integers. i-th of them must be equal to the second when i-th student gets his tea, or 0 if he leaves without tea.

NoteThe example contains 2 tests:  During 1-st second, students 1 and 2 come to the queue, and student 1 gets his tea. Student 2 gets his tea during 2-nd second.  During 1-st second, students 1 and 2 come to the queue, student 1 gets his tea, and student 2 leaves without tea. During 2-nd second, student 3 comes and gets his tea.

{-# 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 Control.Monad
import Control.Monad.Trans.State.Strict

main = B.interact exec
exec = B.pack . evalState app . B.words
app = do
  t <- poi
  fmap (unlines . map (unwords . map show)) $ replicateM t $ do
    n <- poi
    ts <- replicateM n $ liftM2 (,) poi poi
    return $ solve ts
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve ts = foldr (\(l, r) g p -> if p > r then 0:g p else let t = max p l in t:g (t + 1)) (const []) ts 0


Today, Wet Shark is given n bishops on a 1000 by 1000 grid. Both rows and columns of the grid are numbered from 1 to 1000. Rows are numbered from top to bottom, while columns are numbered from left to right.Wet Shark thinks that two bishops attack each other if they share the same diagonal. Note, that this is the only criteria, so two bishops may attack each other (according to Wet Shark) even if there is another bishop located between them. Now Wet Shark wants to count the number of pairs of bishops that attack each other.

The first line of the input contains n (1 ≤ n ≤ 200 000) — the number of bishops. Each of next n lines contains two space separated integers xi and yi (1 ≤ xi, yi ≤ 1000) — the number of row and the number of column where i-th bishop is positioned. It's guaranteed that no two bishops share the same position.

Output one integer — the number of pairs of bishops which attack each other.

NoteIn the first sample following pairs of bishops attack each other: (1, 3), (1, 5), (2, 3), (2, 4), (3, 4) and (3, 5). Pairs (1, 2), (1, 4), (2, 5) and (4, 5) do not attack each other because they do not share the same diagonal.

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

import qualified Data.ByteString.Char8 as C

findRes :: (Int -> Int -> Int) -> [(Int, Int)] -> Int
findRes f = (map (uncurry f)) >>> sort >>> group >>> (map length) >>> filter (>1) >>> (map (\x -> x * (x-1) `div` 2)) >>> sum

main :: IO ()
main = do
    getLine
    a <- map (\(x:y:ys) -> (x,y)) . map (map (fst.fromJust.C.readInt)). map C.words. C.lines <$> C.getContents :: IO [(Int, Int)]
    print $ ((findRes (+) &&& findRes (-)) >>> uncurry (+)) a

import Control.Monad
import Data.List
import Numeric

pairs x = (x*x-x) `div` 2

iRead s = case readDec s of [(n,_)] -> n

main = do
	line  <- getLine
	let n = iRead line
	lines <- replicateM n getLine
	let bishops = [map iRead (words l) :: [Int] | l <- lines]
	let [x,y] = transpose bishops
	let p = sum (map pairs (map length (group (sort (zipWith (+) x y)))))
	let s = sum (map pairs (map length (group (sort (zipWith (-) x y)))))
	putStrLn $ show (p+s)

import Control.Monad
import Data.List
import Numeric

pairs x = (x*x-x) `div` 2
iRead s = case readDec s of [(n,_)] -> n

main = do
	line  <- getLine
	lines <- replicateM (iRead line) getLine
	let [x,y] = transpose [map iRead (words l) :: [Int] | l <- lines]
	let p = sum (map pairs (map length (group (sort (zipWith (+) x y)))))
	let s = sum (map pairs (map length (group (sort (zipWith (-) x y)))))
	putStrLn $ show (p+s)

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

co x = div  (x* (x-1)) 2

main= do
	getLine
	s<- map (map (fst.fromJust.C.readInt)). map C.words. C.lines <$> C.getContents :: IO [[Int]]
	let [t1,t2]= transpose s
	let r1=  sum $ map co $ filter (>1) $ map length $group $ sort $ zipWith (+) t1 t2
	let r2=  sum $ map co $ filter (>1) $ map length $group $ sort $ zipWith (-) t1 t2
	print $ r1+r2

import Control.Monad
import Control.Arrow
import Data.List

getMin :: [Integer] -> Integer
getMin [] = 0
getMin xs = ((minimum &&& (length >>> fromIntegral >>> (`mod` 2))) >>> uncurry (*)) xs

findRes :: (Integer -> Integer -> Integer) -> [(Integer, Integer)] -> Int
findRes f = (map (uncurry f)) >>> sort >>> group >>> (map length) >>> filter (>1) >>> (map (\x -> x * (x-1))) >>> sum

main :: IO ()
main = do
    n <- liftM (read::String -> Integer) getLine
    a <- mapM (\_ -> liftM ((\(x:y:ys) -> (x,y)) . map(read::String->Integer) . words) getLine) [1..n]
    print $ ((findRes (+) &&& findRes (-)) >>> uncurry (+)) a


Once again, Boris needs the help of Anton in creating a task. This time Anton needs to solve the following problem:There are two arrays of integers $$$a$$$ and $$$b$$$ of length $$$n$$$. It turned out that array $$$a$$$ contains only elements from the set $$$\{-1, 0, 1\}$$$.Anton can perform the following sequence of operations any number of times:   Choose any pair of indexes $$$(i, j)$$$ such that $$$1 \le i < j \le n$$$. It is possible to choose the same pair $$$(i, j)$$$ more than once.   Add $$$a_i$$$ to $$$a_j$$$. In other words, $$$j$$$-th element of the array becomes equal to $$$a_i + a_j$$$. For example, if you are given array $$$[1, -1, 0]$$$, you can transform it only to $$$[1, -1, -1]$$$, $$$[1, 0, 0]$$$ and $$$[1, -1, 1]$$$ by one operation.Anton wants to predict if it is possible to apply some number (zero or more) of these operations to the array $$$a$$$ so that it becomes equal to array $$$b$$$. Can you help him?

Each test contains multiple test cases.  The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 10000$$$). 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 length of arrays. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$-1 \le a_i \le 1$$$)  — elements of array $$$a$$$. There can be duplicates among elements. The third line of each test case contains $$$n$$$ integers $$$b_1, b_2, \dots, b_n$$$ ($$$-10^9 \le b_i \le 10^9$$$)  — elements of array $$$b$$$. There can be duplicates among elements. It is guaranteed that the sum of $$$n$$$ over all test cases doesn't exceed $$$10^5$$$.

For each test case, output one line containing "YES" if it's possible to make arrays $$$a$$$ and $$$b$$$ equal by performing the described operations, or "NO" if it's impossible. You can print each letter in any case (upper or lower).

NoteIn the first test-case we can choose $$$(i, j)=(2, 3)$$$ twice and after that choose $$$(i, j)=(1, 2)$$$ twice too. These operations will transform $$$[1, -1, 0] \to [1, -1, -2] \to [1, 1, -2]$$$In the second test case we can't make equal numbers on the second position.In the third test case we can choose $$$(i, j)=(1, 2)$$$ $$$41$$$ times. The same about the fourth test case.In the last lest case, it is impossible to make array $$$a$$$ equal to the array $$$b$$$.

module Main where

import Control.Monad
import Data.List

getStrList :: IO [String]
getStrList = words <$> getLine

getIntList :: IO [Int]
getIntList = map read <$> getStrList

main :: IO ()
main = do
    t <- readLn
    replicateM_ t $ do
        getLine
        a <- getIntList
        b <- getIntList
        putStrLn . g $ f a b

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

f :: [Int] -> [Int] -> Bool
f (x:xs) (y:ys)
    | x /= y = False
    | otherwise = r (False || (x == -1), False || (x == 1)) xs ys

r :: (Bool, Bool) -> [Int] -> [Int] -> Bool
r _ [] [] = True
r (neg, pos) (x:xs) (y:ys)
    | and [x < y, not pos] = False
    | and [x > y, not neg] = False
    | otherwise = r (neg || (x == -1), pos || (x == 1)) xs ys


You are given an array $$$a_1, a_2, \ldots, a_n$$$ of positive integers. A good pair is a pair of indices $$$(i, j)$$$ with $$$1 \leq i, j \leq n$$$ such that, for all $$$1 \leq k \leq n$$$, the following equality holds:$$$$$$ |a_i - a_k| + |a_k - a_j| = |a_i - a_j|, $$$$$$ where $$$|x|$$$ denotes the absolute value of $$$x$$$.Find a good pair. Note that $$$i$$$ can be equal to $$$j$$$.

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 1000$$$) — the number of test cases. Description of the test cases follows. The first line of each test case contains an integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the length of the array. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 10^9$$$) where $$$a_i$$$ is the $$$i$$$-th element of the array. The sum of $$$n$$$ for all test cases is at most $$$2 \cdot 10^5$$$.

For each test case, print a single line with two space-separated indices $$$i$$$ and $$$j$$$ which form a good pair of the array. The case $$$i=j$$$ is allowed. It can be shown that such a pair always exists. If there are multiple good pairs, print any of them.

import Control.Monad (forM_)

solve :: (Ord a1, Num a2) => a1 -> a1 -> a2 -> a2 -> a2 -> [a1] -> (a2, a2)
solve max min maxIdx minIdx i [] = (maxIdx, minIdx)
solve max min maxIdx minIdx i (x : xs)
    | x >= max && x <= min = solve x x i i (i + 1) xs
    | x <= min = solve max x maxIdx i (i + 1) xs
    | x >= max = solve x min i minIdx (i + 1) xs
    | otherwise = solve max min maxIdx minIdx (i + 1) xs

main :: IO ()
main = do
    t <- readLn :: IO Int
    forM_ [1 .. t] $ \i -> do
        n <- readLn :: IO Int
        l <- getLine
        let arr = (map read . words) l :: [Int]
        let (a, b) = if n == 1 then (0,0) else solve (-1) (10^9) (-1) (-1) 0 arr
        putStrLn $ show (a + 1) ++ " " ++ show (b + 1)

import Lib
import Data.List
import Control.Monad

main :: IO ()
main = do
    n <- readLn
    replicateM_ n solvet

solvet :: IO ()
solvet = do
    n <- getLine
    xs <- map read . words <$> getLine :: IO [Int]
    let (Just minPos) = succ <$> minimum xs `elemIndex` xs
    let (Just maxPos) = succ <$> maximum xs `elemIndex` xs
    putStrLn (show minPos ++ " " ++ show maxPos)

import Control.Monad (forM_)

solve :: (Ord a1, Num a2) => a1 -> a1 -> a2 -> a2 -> a2 -> [a1] -> (a2, a2)
solve max min maxIdx minIdx i [] = (maxIdx, minIdx)
solve max min maxIdx minIdx i (x : xs)
    | x >= max = solve x min i minIdx (i + 1) xs
    | x <= min = solve max x maxIdx i (i + 1) xs
    | otherwise = solve max min maxIdx minIdx (i + 1) xs

main :: IO ()
main = do
    t <- readLn :: IO Int
    forM_ [1 .. t] $ \i -> do
        n <- readLn :: IO Int
        l <- getLine
        let arr = (map read . words) l :: [Int]
        let (a, b) = if n == 1 then (0,0) else solve (-1) (10^9) (-1) (-1) 0 arr
        putStrLn $ show (a + 1) ++ " " ++ show (b + 1)

import Control.Monad (forM_)

solve :: (Ord a1, Num a2) => a1 -> a1 -> a2 -> a2 -> a2 -> [a1] -> (a2, a2)
solve max min maxIdx minIdx i [] = (maxIdx, minIdx)
solve max min maxIdx minIdx i (x : xs)
    | x <= min = solve max x maxIdx i (i + 1) xs
    | x >= max = solve x min i minIdx (i + 1) xs
    | otherwise = solve max min maxIdx minIdx (i + 1) xs

main :: IO ()
main = do
    t <- readLn :: IO Int
    forM_ [1 .. t] $ \i -> do
        n <- readLn :: IO Int
        l <- getLine
        let arr = (map read . words) l :: [Int]
        let (a, b) = if n == 1 then (0,0) else solve (-1) (10^9) (-1) (-1) 0 arr
        putStrLn $ show (a + 1) ++ " " ++ show (b + 1)

import Control.Monad (forM_)

solve :: (Ord a1, Num a2) => a1 -> a1 -> a2 -> a2 -> a2 -> [a1] -> (a2, a2)
solve max min maxIdx minIdx i [] = (maxIdx, minIdx)
solve max min maxIdx minIdx i (x : xs)
    | x < min = solve max x maxIdx i (i + 1) xs
    | x > max = solve x min i minIdx (i + 1) xs
    | otherwise = solve max min maxIdx minIdx (i + 1) xs

main :: IO ()
main = do
    t <- readLn :: IO Int
    forM_ [1 .. t] $ \i -> do
        n <- readLn :: IO Int
        l <- getLine
        let arr = (map read . words) l :: [Int]
        let (a, b) = if n == 1 then (0,0) else solve (-1) (10^9) (-1) (-1) 0 arr
        putStrLn $ show (a + 1) ++ " " ++ show (b + 1)

import Lib
import Data.List
import Control.Monad

main :: IO ()
main = do
    n <- readLn
    replicateM_ n solvet

solvet :: IO ()
solvet = do
    n <- getLine
    xs <- map read . words <$> getLine :: IO [Int]
    let (Just minPos) = succ <$> minimum xs `elemIndex` xs
    let (Just maxPos) = succ <$> maximum xs `elemIndex` xs
    print (show minPos ++ " " ++ show maxPos)


Bob is a competitive programmer. He wants to become red, and for that he needs a strict training regime. He went to the annual meeting of grandmasters and asked $$$n$$$ of them how much effort they needed to reach red."Oh, I just spent $$$x_i$$$ hours solving problems", said the $$$i$$$-th of them. Bob wants to train his math skills, so for each answer he wrote down the number of minutes ($$$60 \cdot x_i$$$), thanked the grandmasters and went home. Bob could write numbers with leading zeroes — for example, if some grandmaster answered that he had spent $$$2$$$ hours, Bob could write $$$000120$$$ instead of $$$120$$$.Alice wanted to tease Bob and so she took the numbers Bob wrote down, and for each of them she did one of the following independently:   rearranged its digits, or  wrote a random number. This way, Alice generated $$$n$$$ numbers, denoted $$$y_1$$$, ..., $$$y_n$$$.For each of the numbers, help Bob determine whether $$$y_i$$$ can be a permutation of a number divisible by $$$60$$$ (possibly with leading zeroes).

The first line contains a single integer $$$n$$$ ($$$1 \leq n \leq 418$$$) — the number of grandmasters Bob asked. Then $$$n$$$ lines follow, the $$$i$$$-th of which contains a single integer $$$y_i$$$ — the number that Alice wrote down. Each of these numbers has between $$$2$$$ and $$$100$$$ digits '0' through '9'. They can contain leading zeroes.

Output $$$n$$$ lines. For each $$$i$$$, output the following. If it is possible to rearrange the digits of $$$y_i$$$ such that the resulting number is divisible by $$$60$$$, output "red" (quotes for clarity). Otherwise, output "cyan".

NoteIn the first example, there is one rearrangement that yields a number divisible by $$$60$$$, and that is $$$360$$$.In the second example, there are two solutions. One is $$$060$$$ and the second is $$$600$$$.In the third example, there are $$$6$$$ possible rearrangments: $$$025$$$, $$$052$$$, $$$205$$$, $$$250$$$, $$$502$$$, $$$520$$$. None of these numbers is divisible by $$$60$$$.In the fourth example, there are $$$3$$$ rearrangements: $$$228$$$, $$$282$$$, $$$822$$$.In the fifth example, none of the $$$24$$$ rearrangements result in a number divisible by $$$60$$$.In the sixth example, note that $$$000\dots0$$$ is a valid solution.

{- This code was written by
Russell Emerine - linguist,
mathematician, coder,
musician, and metalhead. -}
main=interact$unlines.map(p.w).tail.words
p b|b="red"|1>0="cyan"
w l=elem '0'l&&sum[read[d]|d<-l]`rem`3<1&&(1<0)#l
False#('0':t)=True#t
b#(c:t)|elem c['0','2'..'8']=1>0|1>0=b#t
_#_=1<0

{- This code was written by
Russell Emerine - linguist,
mathematician, coder,
musician, and metalhead. -}
main=interact$unlines.map(p.w).tail.words
p b|b="red"|1>0="cyan"
w l=elem '0'l&&x(filter('0'<)l)
x[]=1>0
x l=sum[read[d]|d<-l]`rem`3<1&&any(`elem`['0','2'..'8'])l


You are given n × m table. Each cell of the table is colored white or black. Find the number of non-empty sets of cells such that:  All cells in a set have the same color.  Every two cells in a set share row or column.

The first line of input contains integers n and m (1 ≤ n, m ≤ 50) — the number of rows and the number of columns correspondingly. The next n lines of input contain descriptions of rows. There are m integers, separated by spaces, in each line. The number equals 0 if the corresponding cell is colored white and equals 1 if the corresponding cell is colored black.

Output single integer  — the number of non-empty sets from the problem description.

NoteIn the second example, there are six one-element sets. Additionally, there are two two-element sets, the first one consists of the first and the third cells of the first row, the second one consists of the first and the third cells of the second row. To sum up, there are 8 sets.

-- 844B

import Data.List (transpose, partition)
import Control.Arrow ((***))
import Control.Monad (join)

main = do
  [n,m] <- fmap (map read . words) getLine
  interact $ show . program (n*m) . input
  where input = map (map head . words) . lines

program :: Integer -> [[Char]] -> Integer
program elems mat = accum mat + accum (transpose mat) - elems
  where accum = foldr1 (+) . map count

count :: [Char] -> Integer
count line = 2^w + 2^b - 2
  where (w, b) = join (***) length $ partition (=='0') line


Let's define $$$S(x)$$$ to be the sum of digits of number $$$x$$$ written in decimal system. For example, $$$S(5) = 5$$$, $$$S(10) = 1$$$, $$$S(322) = 7$$$.We will call an integer $$$x$$$ interesting if $$$S(x + 1) < S(x)$$$. In each test you will be given one integer $$$n$$$. Your task is to calculate the number of integers $$$x$$$ such that $$$1 \le x \le n$$$ and $$$x$$$ is interesting.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 1000$$$)  — number of test cases. Then $$$t$$$ lines follow, the $$$i$$$-th line contains one integer $$$n$$$ ($$$1 \le n \le 10^9$$$) for the $$$i$$$-th test case.

Print $$$t$$$ integers, the $$$i$$$-th should be the answer for the $$$i$$$-th test case.

NoteThe first interesting number is equal to $$$9$$$.

import Control.Monad

calc :: Int -> Int
calc n = (n+1) `div` 10

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

module Main where
import Data.Char (ord)
main = interact solve

solve inp =
    let
        linp = lines inp
        t = read $ head linp :: Int
        inps = take t . tail $ linp
        logic n | length n == 1 = if n == "9" then 1 else 0
                | otherwise = if last n == '9' then read (init n) + 1 else read (init n) :: Int
    in
        unlines . map (show . logic) $ inps

testcase :: Int -> IO ()
testcase 0 = return ()
testcase i = (readLn :: IO Int) >>= (print . (`div` 10) . (+1)) >> testcase (i - 1)

main :: IO ()
main = (readLn :: IO Int) >>= testcase

import Control.Monad

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

solve :: IO ()
solve = do
  n <- readLn :: IO Int
  print $ ans n

ans x
  | x `mod` 10 == 9 = myAns+1
  | otherwise = myAns
  where myAns = x `div` 10

main = interact $ unlines . map show . map(\x -> x `div` 10) . map (+1) . map read . tail . words

import Control.Monad (replicateM_)

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
    n <- readLn
    print $ (n + 1) `div` 10

module Main where

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

getStrList :: IO [String]
getStrList = words <$> getLine

getIntList :: IO [Int]
getIntList = map read <$> getStrList

printList :: (Show a) => [a] -> IO ()
printList = putStrLn . list2Str

list2Str :: (Show a) => [a] -> String
list2Str = concat . intersperse " " . fmap show

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

tCase :: IO () -> IO ()
tCase x = do
    t <- readLn
    replicateM_ t $ x

main :: IO ()
main = tCase process

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

process :: IO ()
process = do
    n <- readLn
    print $ (n + 1) `div` 10

import Control.Monad

printResult = do
    n <- readLn :: IO Int
    print $ div (n+1) 10

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

import Control.Arrow ((>>>))

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

solve :: Int -> Int
solve n = (n + 1) `div` 10

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n] <- readInts
    putInts [div (n + 1) 10]

type SIO = StateT P.ByteString IO

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

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

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder


You are given a positive integer $$$x$$$. Check whether the number $$$x$$$ is representable as the sum of the cubes of two positive integers.Formally, you need to check if there are two integers $$$a$$$ and $$$b$$$ ($$$1 \le a, b$$$) such that $$$a^3+b^3=x$$$.For example, if $$$x = 35$$$, then the numbers $$$a=2$$$ and $$$b=3$$$ are suitable ($$$2^3+3^3=8+27=35$$$). If $$$x=4$$$, then no pair of numbers $$$a$$$ and $$$b$$$ is suitable.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. Then $$$t$$$ test cases follow. Each test case contains one integer $$$x$$$ ($$$1 \le x \le 10^{12}$$$). Please note, that the input for some test cases won't fit into $$$32$$$-bit integer type, so you should use at least $$$64$$$-bit integer type in your programming language.

For each test case, output on a separate line:    "YES" if $$$x$$$ is representable as the sum of the cubes of two positive integers.  "NO" otherwise.  You can output "YES" and "NO" in any case (for example, the strings yEs, yes, Yes and YES will be recognized as positive).

NoteThe number $$$1$$$ is not representable as the sum of two cubes.The number $$$2$$$ is represented as $$$1^3+1^3$$$.The number $$$4$$$ is not representable as the sum of two cubes.The number $$$34$$$ is not representable as the sum of two cubes.The number $$$35$$$ is represented as $$$2^3+3^3$$$.The number $$$16$$$ is represented as $$$2^3+2^3$$$.The number $$$703657519796$$$ is represented as $$$5779^3+7993^3$$$.

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

cbrt :: Int64 -> Int64
cbrt x = let
  cr :: Double
  cr = fromIntegral x ** (1 / 3)
  cr32 :: Int
  cr32 = floor cr -- may be too small by 1 if perfect cube, but that's OK
  in  fromIntegral cr32

solve :: Int64 -> Bool
solve n = let
  incrs = map (\i -> i*i*i) [1..]
  decrs = map (\i -> i*i*i) $ takeWhile (> 0) $ iterate (subtract 1) $ cbrt n
  go _ [] = False
  go xs@(x:txs) ys@(y:tys) = case  compare (x + y) n  of
    LT -> go txs ys
    EQ -> True
    GT -> go xs tys
  go [] _ = error "solve.go: overflow?"
  in  go incrs decrs

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [x] <- readInts
    lift $ P.putStr $ case  solve x  of
      True  -> P.pack "YES\n"
      False -> P.pack "NO\n"

type SIO = StateT P.ByteString IO

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

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

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Builder as B
import System.IO

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let
  cr :: Int
  -- Seriously?  (floor :: Double -> Int64)?
  -- THAT's where the majority of my runtime was spent?
  cr = floor $ 0.5 + fromIntegral x ** (1 / 3.0 :: Double)
  cr64 = fromIntegral cr
  in  cr64 * cr64 * cr64 == x

solve :: Int64 -> Bool
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt
  answers <- replicateM t $ solve <$> readInt
  putBools answers

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

putBools :: [Bool] -> SIO ()
putBools = let
  res True = B.byteString $ S.pack "YES\n"
  res False = B.byteString $ S.pack "NO\n"
  in  lift . B.hPutBuilder stdout . mconcat . map res

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Builder as B
import System.IO

import Data.Int
import Data.Char

isCube :: Int64 -> Bool
isCube x = let
  cr = floor $ 0.5 + exp (log (fromIntegral x) / (3.0 :: Double))
  in  cr*cr*cr == x

solve :: Int64 -> Bool -- these should get inlined anyway, right?
solve v = any (\(_, y) -> isCube y) $ takeWhile (\(x, y) -> x <= y) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

zeroVal :: Int64
zeroVal = fromIntegral $ ord '0' -- 48

-- Is this THAT much faster than P.readInteger?
parseUInt64 :: P.ByteString -> Int64
parseUInt64 = L.foldl' (\x y -> x * 10 + fromIntegral y - zeroVal) 0

main :: IO ()
main = do
  inp <- P.getContents
  let  vals = tail $ map parseUInt64 $ P.words inp
  putBools $ map solve vals

putBools :: [Bool] -> IO ()
putBools = let
  res True = B.byteString $ S.pack "YES\n"
  res False = B.byteString $ S.pack "NO\n"
  in  B.hPutBuilder stdout . mconcat . map res

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString as SR
import qualified Data.ByteString.Builder as B
import System.IO

import Data.Int
import Data.Char

isCube :: Int64 -> Bool
isCube x = let
  cr = floor $ 0.5 + exp (log (fromIntegral x) / (3.0 :: Double))
  in  cr*cr*cr == x

solve :: Int64 -> Bool
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

zeroVal :: Int64
zeroVal = fromIntegral $ ord '0' -- 48

-- Is this THAT much faster than P.readInteger?
parseUInt64 :: S.ByteString -> Int64
parseUInt64 = SR.foldl' (\x y -> x * 10 + fromIntegral y - zeroVal) 0

main :: IO ()
main = do
  inp <- S.getContents
  let  vals = tail $ map parseUInt64 $ S.words inp
  putBools $ map solve vals

putBools :: [Bool] -> IO ()
putBools = let
  res True = B.byteString $ S.pack "YES\n"
  res False = B.byteString $ S.pack "NO\n"
  in  B.hPutBuilder stdout . mconcat . map res

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Builder as B
import System.IO

import Data.Int
import Data.Char

isCube :: Int64 -> Bool
isCube x = let
  cr = floor $ 0.5 + exp (log (fromIntegral x) / (3.0 :: Double))
  in  cr*cr*cr == x

solve :: Int64 -> Bool
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

zeroVal :: Int64
zeroVal = fromIntegral $ ord '0' -- 48

-- Is this THAT much faster than P.readInteger?
parseUInt64 :: P.ByteString -> Int64
parseUInt64 = L.foldl' (\x y -> x * 10 + fromIntegral y - zeroVal) 0

main :: IO ()
main = do
  inp <- P.getContents
  let  vals = tail $ map parseUInt64 $ P.words inp
  putBools $ map solve vals

putBools :: [Bool] -> IO ()
putBools = let
  res True = B.byteString $ S.pack "YES\n"
  res False = B.byteString $ S.pack "NO\n"
  in  B.hPutBuilder stdout . mconcat . map res

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Builder as B
import System.IO

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = floor $ 0.5 + exp (log (fromIntegral x) / (3.0 :: Double)) -- is (**) slow?
  in  cr*cr*cr == x

solve :: Int64 -> Bool
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  answers <- replicateM t $ solve <$> readInt
  putBools answers -- try faster output?

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

putBools :: [Bool] -> SIO ()
putBools = let
  res True = B.byteString $ S.pack "YES\n"
  res False = B.byteString $ S.pack "NO\n"
  in  lift . B.hPutBuilder stdout . mconcat . map res

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = floor $ 0.5 + exp (log (fromIntegral x) / (3.0 :: Double)) -- is (**) slow?
  in  cr*cr*cr == x

solve :: Int64 -> Bool
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  replicateM_ t $ do
    x <- readInt
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = floor $ 0.5 + fromIntegral x ** (1 / 3 :: Double)
  in  cr*cr*cr == x -- is it (^3) that is slow?

solve :: Int64 -> Bool -- I doubt this is more than 30% faster...
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  replicateM_ t $ do
    x <- readInt
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = round $ fromIntegral x ** (1 / 3 :: Double)
  in  cr*cr*cr == x -- is it (^3) that is slow?

solve :: Int64 -> Bool -- I doubt this is more than 30% faster...
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  replicateM_ t $ do
    x <- readInt
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = fromIntegral x ** (1 / 3 :: Double)
  in  round cr ^ (3 :: Int) == x

solve :: Int64 -> Bool -- I doubt this is more than 30% faster...
solve v = any (isCube . snd) $ takeWhile (uncurry (<=)) $ do
  [(x, y) | i <- [1..], let { x = i*i*i; y = v - x }]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  replicateM_ t $ do
    x <- readInt
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

import qualified Data.ByteString.Lazy.Char8 as P

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

import Data.Int

isCube :: Int64 -> Bool
isCube x = let -- OK, it's very stable.
  cr = fromIntegral x ** (1 / 3 :: Double)
  in  round cr ^ (3 :: Int) == x

solve :: Int64 -> Bool
solve x = any isCube $ [v | i <- [1..10000], let v = x - i*i*i, v > 0]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  t <- readInt -- overflow in input reading, silly me
  replicateM_ t $ do
    x <- readInt
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

readInt :: Num t => SIO t
readInt = do
  currLine <- readLine
  let  [Just (x, _)] = map P.readInteger $ P.words currLine
  pure $ fromInteger x

-- import Debug.Trace

type InType  = Integer
type OutType = Bool

bruteLim = 10 ^ 4 + 10
cube x = x * x * x

binSearch l r x
    | l >= r     = cube l == x
    | cube m>= x = binSearch l       m x
    | otherwise  = binSearch (m + 1) r x
    where m = (l + r) `div` 2

isCube = binSearch 1 bruteLim

solve n = any (\x -> isCube (n - cube x)) [1 .. bruteLim]

receive [s] = read s

main = interact (unlines . map (showBool . solve . receive . pure) . tail . lines)
    where showBool True = "YES"
          showBool False = "NO"

-- import Debug.Trace

type InType  = Integer
type OutType = Bool

inpLines = 1

bruteLim = 10 ^ 4 + 10

chunksOf _ [] = []
chunksOf x l  = take x l : chunksOf x (drop x l)

cube x = x * x * x

binSearch l r x
    | l >= r     = cube l == x
    | cube m>= x = binSearch l       m x
    | otherwise  = binSearch (m + 1) r x
    where m = (l + r) `div` 2

isCube = binSearch 1 bruteLim

solve n = any (\x -> isCube (n - cube x)) [1 .. bruteLim]

receive [s] = read s

main = interact (unlines . map (showBool . solve . receive) . chunksOf inpLines . tail . lines)
    where showBool True = "YES"
          showBool False = "NO"

-- import Debug.Trace

type InType  = Integer
type OutType = Bool

inpLines :: Int
inpLines = 1

bruteLim = 10 ^ 4 + 10

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

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

cube :: Integer -> Integer
cube x = x * x * x

binSearch :: Integer -> Integer -> Integer -> Bool
binSearch l r x
    | l >= r     = cube l == x
    | cube m>= x = binSearch l       m x
    | otherwise  = binSearch (m + 1) r x
    where m = (l + r) `div` 2

isCube :: Integer -> Bool
isCube = binSearch 1 bruteLim

solve :: InType -> OutType
solve n = any (\x -> isCube (n - cube x)) [1 .. bruteLim]

receive :: [String] -> InType
receive [s] = read s

main :: IO ()
main = interact (unlines . map (showBool . solve . receive) . chunksOf inpLines . tail . lines)
    where showBool True = "YES"
          showBool False = "NO"

cubes :: [Integer]
cubes = [r^3 | r <- [1..10^4]]

isCube :: Integer -> Bool
isCube x = any isRoot [candidate - 1, candidate, candidate + 1]
    where isRoot r = r^3 == x
          candidate = round $ fromIntegral x ** (1/3)

isSumOfCubes :: Integer -> Bool
isSumOfCubes x = any isHalf possibleHalves
    where possibleHalves = takeWhile (<x) cubes
          isHalf cube = isCube (x - cube)

solveTest :: Integer -> String
solveTest x = if isSumOfCubes x then "YES" else "NO"

solve :: String -> String
solve = unlines . map (solveTest . read) . drop 1 . lines

main :: IO ()
main = interact solve

module Main where

import Control.Monad

import Data.Int
import Data.Ratio

main :: IO ()
main = do
    n <- ((read :: String -> Int) <$> getLine)
    replicateM_ n action

action = getLine >>= putStrLn . answer . guess . read

guess :: Int64 -> Bool
guess x = any (\a -> let r = x - a^3 in r > 0 && (round $ (fromIntegral r)**(1/3))^3 == r) [1..9999]

answer True = "yes"
answer False = "no"

{-# LANGUAGE OverloadedStrings, FunctionalDependencies, FlexibleContexts,
    ConstraintKinds, BangPatterns #-}

import Control.Applicative
import Control.Exception (assert)
import Control.Monad
import Control.Monad.State
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Bits
import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
import Data.Int
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable
import System.IO

------

type Hopper r = State [r]

type HopperT r = StateT [r]

runHopper :: Hopper r a -> [r] -> (a, [r])
runHopper = runState

evalHopper :: Hopper r a -> [r] -> a
evalHopper = evalState

runHopperT :: HopperT r m a -> [r] -> m (a, [r])
runHopperT = runStateT

evalHopperT :: Monad m => HopperT r m a -> [r] -> m a
evalHopperT = evalStateT

type MonadHopper r m = MonadState [r] m

pop :: MonadHopper r m => m (Maybe r)
pop = state f
  where
    f :: [r] -> (Maybe r, [r])
    f [] = (Nothing, [])
    f (q:qs) = (Just q, qs)

popJust :: MonadHopper r m => m r
popJust = fromJust <$> pop

------

popInt :: MonadHopper B.ByteString m => m Int
popInt = fst . fromJust . B.readInt <$> popJust

popInts :: MonadHopper B.ByteString m => m [Int]
popInts = map (fst . fromJust . B.readInt) . B.words <$> popJust

popInteger :: MonadHopper B.ByteString m => m Integer
popInteger = fst . fromJust . B.readInteger <$> popJust

popIntegers :: MonadHopper B.ByteString m => m [Integer]
popIntegers = map (fst . fromJust . B.readInteger) . B.words <$> popJust

------

dropCR :: B.ByteString -> B.ByteString
dropCR s | not (B.null s) && B.last s == '\r' = B.init s
         | otherwise = s

bshow :: Show a => a -> B.ByteString
bshow = B.pack . show

main = B.interact go
  where
    go :: B.ByteString -> B.ByteString
    go = evalHopper run . map dropCR . B.lines

------

run :: Hopper B.ByteString B.ByteString
run = do
  t <- popInt
  B.unlines <$> replicateM t run1

run1 = bool "NO" "YES" . solve <$> popInteger

solve x = any test $ takeWhile (\a -> 2 * a ^ 3 <= x) [1..]
  where
    test a = Set.member (x - a ^ 3) cubes

    cubes = Set.fromList $ takeWhile (<= x) $ map (^ 3) [1..]

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

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

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

p3 :: Int64 -> Int64
p3 x = x * x * x

f :: Int64 -> Int64 -> Bool
f x y
  | xxx < y = f (succ x) y
  | xxx == y = True
  | otherwise = False
  where xxx = p3 x

cube :: Int64 -> Bool
cube x = f xxx x
  where
    xxx :: Int64
    xxx = fromIntegral $ floor $ exp $ ((log $ fromIntegral x) / 3.0)

yes = byteString $ C.pack "YES\n"
no = byteString $ C.pack "NO\n"

test :: Int64 -> Builder
test n = if x then yes else no
  where x = any (\(_, bbb) -> cube bbb) $ takeWhile (\(u, v) -> u <= v) $ [(aaa, bbb) | a <- [1 ..], let aaa = p3 a, let bbb = n - aaa]

solve :: [Int64] -> Builder
solve (n:l) = mconcat $ map test l'
  where
    l' = take (fromIntegral n) l

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

import qualified Data.ByteString.Lazy.Char8 as P
import qualified Data.ByteString.Builder as B
import System.IO

import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List
import Data.Semigroup

import Data.Int

isCube :: Int64 -> Bool
isCube x = let
  cr = fromIntegral x ** (1 / 3 :: Double)
  in  round cr ^ (3 :: Int) == x

solve :: Int64 -> Bool
solve x = any isCube $ [v | i <- [1..10000], let v = x - i*i*i, v > 0]

main :: IO ()
main = (P.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [x] <- map fromIntegral <$> readInts
    lift $ P.putStrLn $ case  solve x  of
      True  -> P.pack "YES"
      False -> P.pack "NO"

type SIO = StateT P.ByteString IO

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

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

putInts :: [Int] -> SIO ()
putInts li = let
  outBuilder = foldr (<>) (B.char7 '\n')
    $ intersperse (B.char7 ' ') (map B.intDec li)
  in  lift $ B.hPutBuilder stdout outBuilder

-- import Debug.Trace

type InType  = Int
type OutType = Bool

inpLines :: Int
inpLines = 1

bruteLim = 10 ^ 4 + 10

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

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

cube :: Int -> Int
cube x = x * x * x

binSearch :: Int -> Int -> Int -> Bool
binSearch l r x
    | l >= r     = cube l == x
    | cube m>= x = binSearch l       m x
    | otherwise  = binSearch (m + 1) r x
    where m = (l + r) `div` 2

isCube :: Int -> Bool
isCube = binSearch 1 bruteLim

solve :: InType -> OutType
solve n = any (\x -> isCube (n - cube x)) [1 .. bruteLim]

receive :: [String] -> InType
receive [s] = read s

main :: IO ()
main = interact (unlines . map (showBool . solve . receive) . chunksOf inpLines . tail . lines)
    where showBool True = "YES"
          showBool False = "NO"


Ilya is a very good-natured lion. He likes maths. Of all mathematical objects, his favourite one is matrices. Now he's faced a complicated matrix problem he needs to solve.He's got a square 2n × 2n-sized matrix and 4n integers. You need to arrange all these numbers in the matrix (put each number in a single individual cell) so that the beauty of the resulting matrix with numbers is maximum.The beauty of a 2n × 2n-sized matrix is an integer, obtained by the following algorithm:  Find the maximum element in the matrix. Let's denote it as m.  If n = 0, then the beauty of the matrix equals m. Otherwise, a matrix can be split into 4 non-intersecting 2n - 1 × 2n - 1-sized submatrices, then the beauty of the matrix equals the sum of number m and other four beauties of the described submatrices. As you can see, the algorithm is recursive.Help Ilya, solve the problem and print the resulting maximum beauty of the matrix.

The first line contains integer 4n (1 ≤ 4n ≤ 2·106). The next line contains 4n integers ai (1 ≤ ai ≤ 109) — the numbers you need to arrange in the 2n × 2n-sized matrix.

On a single line print the maximum value of the beauty of the described matrix. Please, do not use the %lld specifier to read or write 64-bit integers in С++. It is preferred to use the cin, cout streams or the %I64d specifier.

NoteConsider the second sample. You need to arrange the numbers in the matrix as follows:1 23 4Then the beauty of the matrix will equal: 4 + 1 + 2 + 3 + 4 = 14.

-- For benchmark. Based on not my solution but cojna's

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import qualified Data.ByteString.Char8 as B
import Data.Int
import Data.Array.Base
import Data.Array.ST
import Data.Bits
import Data.Ix

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

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

solve :: Int -> UArray Int Int -> Int64
solve n arr0 = sum . map (unsafeAt arr.(n-)).takeWhile (<=n) $ iterate (4*) 1
   where
     !arr = runSTUArray $ do
       a <- newArray (0,n-1) 0 :: ST s (STUArray s Int Int64)
       let go !i !acc = do
             when (i>=0) $ do
               let acc' = (acc+).fromIntegral $ unsafeAt arr0 i
               unsafeWrite a i acc'
               go (i-1) acc'
       go (n-1) 0
       return a

unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

rep :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
{-# INLINE rep #-}

rev :: Monad m => Int -> (Int -> m ()) -> m ()
rev !n f= go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rev #-}

mask :: Int
mask = 0xffff
{-# INLINE mask #-}

radixSort :: Int -> [Int] -> UArray Int Int
radixSort n xs = runSTUArray $ do
  arr   <- newListArray (0,n-1) xs :: ST s (STUArray s Int Int)
  tmp   <- newArray (0,n-1) 0      :: ST s (STUArray s Int Int)
  count <- newArray (0,mask) 0     :: ST s (STUArray s Int Int)

  rep n $ \i-> do
    xi <- unsafeRead arr i
    unsafeModify count (xi.&.mask) (1+)
  rep mask $ \i-> do
    x <- unsafeRead count i
    unsafeModify count (i+1) (x+)
  rev n $ \i-> do
    xi <- unsafeRead arr i
    let !mi = xi.&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite tmp j xi

  rep (mask+1) $ \i-> do
    unsafeWrite count i 0

  rep n $ \i-> do
    xi <- unsafeRead arr i
    unsafeModify count ((xi`unsafeShiftR`16).&.mask) (1+)
  rep mask $ \i-> do
    x <- unsafeRead count i
    unsafeModify count (i+1) (x+)
  rev n $ \i-> do
    xi <- unsafeRead tmp i
    let !mi = (xi`unsafeShiftR`16).&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite arr j xi

  return arr

{-# OPTIONS_GHC -O2 #-}

import Control.Monad
import Control.Applicative
import Control.Arrow

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

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0 >>> negate

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

solve :: [Int] -> Integer
solve [-1,x] = -fromIntegral x
solve (n:l) = - sum [sum $ take (4^i) l'| i <- takeWhile (\i -> 4^i < -n)[0..]] - x
    where
        l' = map fromIntegral $ sort $ removeSome n l
        x  = sum $ map fromIntegral l

removeSome n l = if length l1*4 >= n then l1 else l
    where
        a = minimum l
        b = maximum l
        c = (a+b)`div`2
        l1 = filter (<= c) l

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import qualified Data.ByteString.Char8 as B
import Data.Int
import Data.Array.Base
import Data.Array.ST
import Data.Bits

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

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

solve :: Int -> UArray Int Int -> Int64
solve n arr0 = sum . map (unsafeAt arr.(n-)).takeWhile (<=n) $ iterate (4*) 1
   where
     !arr = runSTUArray $ do
       a <- newArray (0,n-1) 0 :: ST s (STUArray s Int Int64)
       let go !i !acc = do
             when (i>=0) $ do
               let acc' = (acc+).fromIntegral $ unsafeAt arr0 i
               unsafeWrite a i acc'
               go (i-1) acc'
       go (n-1) 0
       return a

mask :: Int
mask = 0xffff

radixSort :: Int -> [Int] -> UArray Int Int
radixSort n xs = runSTUArray $ do
  arr <- newListArray (0,n-1) xs :: ST s (STUArray s Int Int)
  tmp <- newArray (0,n-1) 0      :: ST s (STUArray s Int Int)
  count <- newArray (0,mask) 0   :: ST s (STUArray s Int Int)

  forM_ xs $ \x-> do
    let !mx = x.&.mask
    unsafeRead count mx >>= unsafeWrite count mx.(1+)
  forM_ [1..mask] $ \i-> do
    x <- unsafeRead count $ i-1
    unsafeRead count i >>= unsafeWrite count i.(x+)
  forM_ [n-1,n-2..0] $ \i-> do
    xi <- unsafeRead arr i
    let !mi = xi.&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite tmp j xi

  forM_ [0..mask] $ \i-> do
    unsafeWrite count i 0

  forM_ xs $ \x-> do
    let !mx = (x`unsafeShiftR`16).&.mask
    unsafeRead count mx >>= unsafeWrite count mx.(1+)
  forM_ [1..mask] $ \i-> do
    x <- unsafeRead count $ i-1
    unsafeRead count i >>= unsafeWrite count i.(x+)
  forM_ [n-1,n-2..0] $ \i-> do
    xi <- unsafeRead tmp i
    let !mi = (xi`unsafeShiftR`16).&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite arr j xi

  return arr

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}

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

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

stoi :: B.ByteString -> Int64
stoi = toEnum . negate . maybe 0 fst . B.readInt

solve :: [Int64] -> Int64
solve (_ : a : as) = negate $ sum $ scanl (+) a $ slice [0..] as
  where
  slice _ [] = []
  slice (i : is) xs = sum ys : slice is zs
    where
    (ys, zs) = splitAt (3 * 4 ^ i) xs

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

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

solve :: [Int] -> Int
solve (_ : as') = f 0 a as
  where
  (a : as) = map negate $ sort $ map negate as'
  f _ s [] = s
  f n s xs = seq s $ s + f (n + 1) (s + sum ys) zs
    where
    (ys, zs) = splitAt (3 * 4 ^ n) xs

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}

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

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

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

solve :: [Int] -> Int64
solve (n : as') = sum $ scanl (+) (toEnum a) $ slice (n - 1) 3 as
  where
  (a : as) = sortBy (compare `on` negate) as'

slice :: Int -> Int -> [Int] -> [Int64]
slice s i xs
  | s <= i = [sum' xs]
  | otherwise = sum' ys : slice (s - i) (i * 4) zs
  where
  sum' = foldl' (\x y -> x + toEnum y) 0
  (ys, zs) = splitAt i xs

import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.ByteString.Char8 as B
import qualified Data.Array as A
import Data.Maybe
import Debug.Trace

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

type Point = (Int,Int)
type Memo = A.Array Point Int
data Tree = Node Tree Tree Tree Tree
          | Leaf Int
          deriving(Show)

solve :: [Int] -> Integer
solve (n:l) = fst $ beauty tree
    where
        s = round $ sqrt $ fromIntegral n
        memo = A.listArray ((0,0),(s-1,s-1)) l
        tree = makeTree memo (0,0) (s,s)

makeTree :: Memo -> Point -> Point -> Tree
makeTree memo = sub
    where
        sub (x1,y1) (x2,y2)
            | x2 - x1 == 1 = Leaf (memo A.! (x1,y1))
            | otherwise =  Node t1 t2 t3 t4
            where
                mx = (x1+x2) `div`2
                my = (y1+y2) `div`2
                t1 = sub (x1,y1) (mx,my)
                t2 = sub (mx,y1) (x2,my)
                t3 = sub (x1,my) (mx,y2)
                t4 = sub (mx,my) (x2,y2)

beauty :: Tree -> (Integer,Int)
beauty (Leaf i) = (fromIntegral i,i)
beauty (Node t1 t2 t3 t4) = f $ sum *** maximum $ unzip $ map beauty [t1,t2,t3,t4]
    where
        f (x,y) = (fromIntegral y+x,y)

import Control.Monad
import Control.Applicative
import Control.Arrow

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

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0 >>> negate

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

solve :: [Int] -> Integer
solve (n:l) = - sum [sum $ take (4^i) l'| i <- takeWhile (\i -> 4^i <= -n)[0..]] - x
    where
        l' = map fromIntegral $ sort $ removeSome n l
        x  = sum $ map fromIntegral l

removeSome n l = if length l1*4 >= n then l1 else l
    where
        a = minimum l
        b = maximum l
        c = (a+b)`div`4
        l1 = filter (<= c) l

import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.ByteString.Char8 as B
import qualified Data.Array as A
import Data.Maybe

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

type Point = (Int,Int)
type Memo = A.Array Point Int
data Tree = Node Tree Tree Tree Tree
          | Leaf Int
          deriving(Show)

solve :: [Int] -> Integer
solve (n:l) = fst $ beauty tree
    where
        s = floor $ sqrt $ fromIntegral n
        memo = A.listArray ((0,0),(s-1,s-1)) l
        tree = makeTree memo (0,0) (s-1,s-1)

makeTree :: Memo -> Point -> Point -> Tree
makeTree memo = sub
    where
        sub (x1,y1) (x2,y2)
            | x1 == x2  = Leaf (memo A.! (x1,y1))
            | otherwise = Node t1 t2 t3 t4
            where
                mx = (x1+x2) `div`2
                my = (y1+y2) `div`2
                t1 = sub (x1,y1) (mx,my)
                t2 = sub (mx+1,y1) (x2,my)
                t3 = sub (x1,my+1) (mx,y2)
                t4 = sub (mx+1,my+1) (x2,y2)

beauty :: Tree -> (Integer,Int)
beauty (Leaf i) = (fromIntegral i,i)
beauty (Node t1 t2 t3 t4) = f $ sum *** maximum $ unzip $ map beauty [t1,t2,t3,t4]
    where
        f (x,y) = (fromIntegral y+x,y)

import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.ByteString.Char8 as B
import qualified Data.Array as A
import Data.Maybe

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

type Point = (Int,Int)
type Memo = A.Array Point Int
data Tree = Node Tree Tree Tree Tree
          | Leaf Int
          deriving(Show)

solve :: [Int] -> Integer
solve (n:l) = fst $ beauty tree
    where
        s = floor $ sqrt $ fromIntegral n
        memo = A.listArray ((0,0),(s-1,s-1)) l
        tree = makeTree memo (0,0) (s-1,s-1)

makeTree :: Memo -> Point -> Point -> Tree
makeTree memo = sub
    where
        sub (x1,y1) (x2,y2)
            | x1 == x2  = Leaf (memo A.! (x1,y1))
            | otherwise = Node t1 t2 t3 t4
            where
                mx = (x1+x2+1) `div`2
                my = (y1+y2+1) `div`2
                t1 = sub (x1,y1) (mx-1,my-1)
                t2 = sub (mx,y1) (x2,my-1)
                t3 = sub (x1,my) (mx-1,y2)
                t4 = sub (mx,my) (x2,y2)

beauty :: Tree -> (Integer,Int)
beauty (Leaf i) = (fromIntegral i,i)
beauty (Node t1 t2 t3 t4) = f $ sum *** maximum $ unzip $ map beauty [t1,t2,t3,t4]
    where
        f (x,y) = (fromIntegral y+x,y)

import Control.Monad
import Control.Applicative
import Control.Arrow

import Control.Monad.ST
import Data.Array.ST
import Data.Array
import Debug.Trace

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

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0 >>> negate

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

solve :: [Int] -> Integer
solve [-1,x] = -fromIntegral x
solve (n:l) = - sum [sum $ take (4^i) l'| i <- takeWhile (\i -> 4^i < -n)[0..]] - x
    where
        l' = map fromIntegral $ qsort $l
        x  = sum $ map fromIntegral l

removeSome n l = if length l1*4 >= n then l1 else l
    where
        a = minimum l
        b = maximum l
        c = (a+b)`div`2
        l1 = filter (<= c) l

qsort :: [Int] -> [Int]
qsort l = elems $ runSTArray $ do
    ary <- newListArray (0,n-1) l :: ST s (STArray s Int Int)
    qsortST (0,n-1) ary
    return ary
    where
        n = length l

median3 x y z | x <= y && y <= z = y
              | x <= y           = max x z
              | z <= y           = y
              | otherwise        = min x z

qsortST :: (Int,Int) -> (STArray s Int Int) -> ST s ()
qsortST (i,j) ary
    | j == i = return ()
    | otherwise = do
    s <- readArray ary i
    e <- readArray ary j
    m <- readArray ary ((i+j)`div`2)
    let pivot = median3 s e m
    k <- partitionST (i,j) ary pivot (s,e)
    qsortST (i,k) ary
    qsortST (k+1,j) ary

partitionST (i,j) ary p (a,b)
    | j - i < 1 = return i
    | a >= p && b <= p = do
        writeArray ary i b
        writeArray ary j a
        a' <- readArray ary (i+1)
        b' <- readArray ary (j-1)
        partitionST (i+1,j-1) ary p (a',b')
    | a >= p = do
        b' <- readArray ary (j-1)
        partitionST (i,j-1) ary p (a,b')
    | otherwise = do
        a' <- readArray ary (i+1)
        partitionST (i+1,j) ary p (a',b)

import Control.Monad
import Control.Applicative
import Control.Arrow

import qualified Data.ByteString.Char8 as B
import qualified Data.Array as A
import Data.Maybe

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

type Point = (Int,Int)
type Memo = A.Array Point Int
data Tree = Node Tree Tree Tree Tree
          | Leaf Int
          deriving(Show)

solve :: [Int] -> Integer
solve (n:l) = fst $ beauty tree
    where
        s = round $ sqrt $ fromIntegral n
        memo = A.listArray ((0,0),(s-1,s-1)) l
        tree = makeTree memo (0,0) (s-1,s-1)

makeTree :: Memo -> Point -> Point -> Tree
makeTree memo = sub
    where
        sub (x1,y1) (x2,y2)
            | x1 == x2  = Leaf (memo A.! (x1,y1))
            | otherwise = Node t1 t2 t3 t4
            where
                mx = (x1+x2+1) `div`2
                my = (y1+y2+1) `div`2
                t1 = sub (x1,y1) (mx-1,my-1)
                t2 = sub (mx,y1) (x2,my-1)
                t3 = sub (x1,my) (mx-1,y2)
                t4 = sub (mx,my) (x2,y2)

beauty :: Tree -> (Integer,Int)
beauty (Leaf i) = (fromIntegral i,i)
beauty (Node t1 t2 t3 t4) = f $ sum *** maximum $ unzip $ map beauty [t1,t2,t3,t4]
    where
        f (x,y) = (fromIntegral y+x,y)

import Control.Monad
import Control.Applicative
import Control.Arrow

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

stoi :: B.ByteString -> Int
stoi = B.readInt >>> fmap fst >>> fromMaybe 0 >>> negate

main = do
    l <- map stoi . B.words <$> B.getContents
    print $ solve l

solve :: [Int] -> Integer
solve [-1,x] = -fromIntegral x
solve (n:l) = - sum [sum $ take (4^i) l'| i <- takeWhile (\i -> 4^i <= -n)[0..]] - x
    where
        l' = map fromIntegral $ sort $ removeSome n l
        x  = sum $ map fromIntegral l

removeSome n l = if length l1*4 >= n then l1 else l
    where
        a = minimum l
        b = maximum l
        c = (a+b)`div`4
        l1 = filter (<= c) l

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import qualified Data.ByteString.Char8 as B
import Data.Int
import Data.Array.Base
import Data.Array.ST
import Data.Bits

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

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

solve :: Int -> UArray Int Int -> Int64
solve n arr0 = sum . map (unsafeAt arr.subtract 1).takeWhile (<=n) $ iterate (4*) 1
   where
     !arr = runSTUArray $ do
       a <- newArray (0,n-1) 0 :: ST s (STUArray s Int Int64)
       let go !i !acc = do
             when (i>=0) $ do
               let acc' = (acc+).fromIntegral $ unsafeAt arr0 i
               unsafeWrite a i acc'
               go (i-1) acc'
       go (n-1) 0
       return a

mask :: Int
mask = 0xffff

radixSort :: Int -> [Int] -> UArray Int Int
radixSort n xs = runSTUArray $ do
  arr <- newListArray (0,n-1) xs :: ST s (STUArray s Int Int)
  tmp <- newArray (0,n-1) 0      :: ST s (STUArray s Int Int)
  count <- newArray (0,mask) 0   :: ST s (STUArray s Int Int)

  forM_ xs $ \x-> do
    let !mx = x.&.mask
    unsafeRead count mx >>= unsafeWrite count mx.(1+)
  forM_ [1..mask] $ \i-> do
    x <- unsafeRead count $ i-1
    unsafeRead count i >>= unsafeWrite count i.(x+)
  forM_ [n-1,n-2..0] $ \i-> do
    xi <- unsafeRead arr i
    let !mi = xi.&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite tmp j xi

  forM_ [0..mask] $ \i-> do
    unsafeWrite count i 0

  forM_ xs $ \x-> do
    let !mx = (x`unsafeShiftR`16).&.mask
    unsafeRead count mx >>= unsafeWrite count mx.(1+)
  forM_ [1..mask] $ \i-> do
    x <- unsafeRead count $ i-1
    unsafeRead count i >>= unsafeWrite count i.(x+)
  forM_ [n-1,n-2..0] $ \i-> do
    xi <- unsafeRead tmp i
    let !mi = (xi`unsafeShiftR`16).&.mask
    j <- subtract 1 <$> unsafeRead count mi
    unsafeWrite count mi j
    unsafeWrite arr j xi

  return arr


Petya has a rectangular Board of size $$$n \times m$$$. Initially, $$$k$$$ chips are placed on the board, $$$i$$$-th chip is located in the cell at the intersection of $$$sx_i$$$-th row and $$$sy_i$$$-th column.In one action, Petya can move all the chips to the left, right, down or up by $$$1$$$ cell.If the chip was in the $$$(x, y)$$$ cell, then after the operation:   left, its coordinates will be $$$(x, y - 1)$$$;  right, its coordinates will be $$$(x, y + 1)$$$;  down, its coordinates will be $$$(x + 1, y)$$$;  up, its coordinates will be $$$(x - 1, y)$$$. If the chip is located by the wall of the board, and the action chosen by Petya moves it towards the wall, then the chip remains in its current position.Note that several chips can be located in the same cell.For each chip, Petya chose the position which it should visit. Note that it's not necessary for a chip to end up in this position.Since Petya does not have a lot of free time, he is ready to do no more than $$$2nm$$$ actions.You have to find out what actions Petya should do so that each chip visits the position that Petya selected for it at least once. Or determine that it is not possible to do this in $$$2nm$$$ actions.

The first line contains three integers $$$n, m, k$$$ ($$$1 \le n, m, k \le 200$$$) — the number of rows and columns of the board and the number of chips, respectively. The next $$$k$$$ lines contains two integers each $$$sx_i, sy_i$$$ ($$$ 1 \le sx_i \le n, 1 \le sy_i \le m$$$) — the starting position of the $$$i$$$-th chip. The next $$$k$$$ lines contains two integers each $$$fx_i, fy_i$$$ ($$$ 1 \le fx_i \le n, 1 \le fy_i \le m$$$) — the position that the $$$i$$$-chip should visit at least once.

In the first line print the number of operations so that each chip visits the position that Petya selected for it at least once. In the second line output the sequence of operations. To indicate operations left, right, down, and up, use the characters $$$L, R, D, U$$$ respectively. If the required sequence does not exist, print -1 in the single line.

import Control.Arrow

main = interact $
  lines >>> map (words >>> map read) >>>
  solve >>> (\ans -> [show $ length ans, ans]) >>> unlines

solve :: [[Int]] -> String
solve ([n,m,k]:_) = take (2 * n * m) $
  (take (n - 1) $ repeat 'U') ++
  (take (m - 1) $ repeat 'L') ++
  (foldr (++) "" $ take n $ repeat
    (take (m - 1) (repeat 'R') ++ "D" ++
    take (m - 1) (repeat 'L') ++ "D"))

import Control.Arrow ((>>>))

main :: IO ()
main =
  interact $
    lines >>> map (words >>> map read)
      >>> solve
      >>> (\ans -> [show (length ans), ans])
      >>> unlines

solve :: [[Int]] -> String
solve ([n, m, _] : _) =
  take (2 * n * m) $
    replicate (n - 1) 'U' ++ replicate (m - 1) 'L'
      ++ concat
        ( replicate
            n
            (replicate (m - 1) 'R' ++ "D" ++ replicate (m - 1) 'L' ++ "D")
        )

import Control.Monad
main :: IO ()
main = do
  [n,m,k] <- (map read.words) <$> getLine
  replicateM_ (2*k) getLine
  print (n*m+n+m-3)
  putStrLn $ solve n m

solve :: Int -> Int -> String
solve m n = replicate (n-1) 'L' ++ replicate (m-1) 'D' ++ take (n*m-1) frst
  where
    frst = replicate (n-1) 'R' ++ "U" ++ replicate (n-1) 'L' ++ "U" ++ frst
--n lr m ud

import Control.Monad
main :: IO ()
main = do
  [n,m,k] <- (map read.words) <$> getLine
  replicateM_ (2*k) getLine
  putStrLn $ solve n m

solve :: Int -> Int -> String
solve n m = replicate (n-1) 'L' ++ replicate (m-1) 'D' ++ take (n*m-1) frst
  where
    frst = replicate (n-1) 'R' ++ "U" ++ replicate (n-1) 'L' ++ "U" ++ frst
--n lr m ud

import Control.Monad
main :: IO ()
main = do
  [n,m,k] <- (map read.words) <$> getLine
  replicateM_ (2*k) getLine
  print (n*m+n+m-3)
  putStrLn $ solve n m

solve :: Int -> Int -> String
solve n m = replicate (n-1) 'L' ++ replicate (m-1) 'D' ++ take (n*m-1) frst
  where
    frst = replicate (n-1) 'R' ++ "U" ++ replicate (n-1) 'L' ++ "U" ++ frst
--n lr m ud


Fox Ciel wants to write a task for a programming contest. The task is: "You are given a simple undirected graph with n vertexes. Each its edge has unit length. You should calculate the number of shortest paths between vertex 1 and vertex 2."Same with some writers, she wants to make an example with some certain output: for example, her birthday or the number of her boyfriend. Can you help her to make a test case with answer equal exactly to k?

The first line contains a single integer k (1 ≤ k ≤ 109).

You should output a graph G with n vertexes (2 ≤ n ≤ 1000). There must be exactly k shortest paths between vertex 1 and vertex 2 of the graph. The first line must contain an integer n. Then adjacency matrix G with n rows and n columns must follow. Each element of the matrix must be 'N' or 'Y'. If Gij is 'Y', then graph G has a edge connecting vertex i and vertex j. Consider the graph vertexes are numbered from 1 to n. The graph must be undirected and simple: Gii = 'N' and Gij = Gji must hold. And there must be at least one path between vertex 1 and vertex 2. It's guaranteed that the answer exists. If there multiple correct answers, you can output any of them.

8
NNYYYNNN
NNNNNYYY
YNNNNYYY
YNNNNYYY
YNNNNYYY
NYYYYNNN
NYYYYNNN
NYYYYNNN

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Control.Monad (mapM_)
import Data.Int (Int64)

type Block = (Int, Int)   -- (start, length)

cY = 'Y'
cN = 'N'

row :: Int -> Block -> Block -> ByteString
row end (pstart, plen) (nstart, nlen) =
  BS.pack $ col1 ++ col2 ++ pre ++ blk1 ++ mid ++ blk2 ++ post
  where
    col1 = if plen == 0 then [cY] else [cN]
    col2 = if nlen == 0 then [cY] else [cN]
    pend = pstart+plen
    nend = nstart+nlen
    pre  = replicate (pstart-3)    cN
    blk1 = replicate plen          cY
    mid  = replicate (nstart-pend) cN
    blk2 = replicate nlen          cY
    post = replicate (end-nend)    cN

triples :: [a] -> [(a,a,a)]
triples [] = []
triples [_,_] = []
triples xs@(a:b:c:_) =  (a,b,c) : triples (tail xs)

rows :: Int -> [ Block ] -> [ByteString]
rows end blks =
    [ r' | (a,(bstart,blen),c) <- blks', let r = row end a c, r' <- replicate blen r ]
  where blks' = triples $ [(3,0)] ++ blks ++ [(end,0)]

-- return a string with Ys in the positions indicated and N's elsewhere
pattern :: Int -> [Block] -> ByteString
pattern end blks = BS.pack $ go 1 blks
  where
    go k [] = replicate (end-k) cN
    go k ((start,len):rest) = replicate (start-k) cN ++ replicate len cY ++ go (start+len) rest

row1 :: Int -> [ [Block] ] -> ByteString
row1 end blks = pattern end (map head blks)

row2 :: Int -> [ [Block] ] -> ByteString
row2 end blks = pattern end (map last blks)

test1 = do let blks = [(3,3),(6,2)]
           mapM_ BS.putStrLn $ [row1 8 [blks], row2 8 [blks]] ++ rows 8 blks

assign' :: Int -> [Int] -> (Int,[Block])
assign' k [] = (k,[])
assign' k xs = (m, blks)
  where
    blks = go k xs
    m = let (k,a) = last blks in a+k
    go k [] = []
    go k (a:as) = (k,a) : go (k+a) as

-- assume all lists have the same length
assign :: [[Int]] -> (Int, [[Block]])
assign [] = (3, [])
assign xs = (m,blkss)
  where
    blkss = go 3 xs
    m = let (k,a) = (last (last blkss))
        in a+k
    go k []     = []
    go k (x:xs) = let (k',bs) = assign' k x
                  in bs : go k' xs

-- | make all the lengths the same by extending short lists with 1
normalize :: [[Int]] -> [[Int]]
normalize xss =
  let m = maximum (map length xss)
  in map (\xs -> replicate (m - length xs) 1 ++ xs) xss

graph :: Int -> [[Block]] -> [ByteString]
graph end blkss =
  [row1 end blkss, row2 end blkss] ++ concatMap (rows end) blkss

bAdd :: [[Int]] -> [[Int]] -> [[Int]]
bAdd as bs = as ++ bs

bMul :: Int -> [[Int]] -> [[Int]]
bMul n bss = map (n:) bss

toInts :: Int -> Int64 -> [[Int]]
toInts base 0 = []
toInts base n =
  case n `divMod` (fromIntegral base) of
    (q,0) -> base `bMul` (toInts base q)
    (q,r) -> (base `bMul` (toInts base q)) `bAdd` [[fromIntegral r]]

nodeCount :: [[Int]] -> Int
nodeCount = sum . concat

toBlocks :: Int -> Int64 -> (Int,[[Block]])
toBlocks base = assign . normalize . toInts base

solve :: Int -> Int64 -> (Int,[ByteString])
solve base n =
  let (end,blkss) = toBlocks base n
  in (end, graph end blkss)

main = do
  n <- read `fmap` getLine
  let (end,lines) = solve 4 n
  print (end-1)
  mapM_ BS.putStrLn lines

import qualified Data.IntMap as IM
import Data.List (foldl')
import qualified Data.IntSet as IS

decomp :: Integer -> [Bool]
decomp x = decomp' x []
  where
    decomp' 0 l = l
    decomp' k l
      | k `mod` 2 == 1 = decomp' (k `div` 2) (True:l)
      | otherwise = decomp' (k `div` 2) (False:l)

main :: IO ()
main = do
  i <- fmap read getLine
  let bits = decomp i
  --print $ rush bits
  putStr $ pp $ rush bits

pp :: Graph -> String
pp (g,m) = unlines $ show m : pg
  where pg = foldr (\i l -> let Just es = IM.lookup i g
                            in  map (\j -> if IS.member j es then 'Y' else 'N') [1..m] : l) [] [1..m]

type Graph = (IM.IntMap IS.IntSet, Int)

emptyGraph :: Graph
emptyGraph = (IM.fromList [(1, IS.empty), (2, IS.empty)], 2)

insert2 :: (Int, Int) -> Graph -> Graph
insert2 (a,b) (g, m) = (g', m + 2)
  where
    prev = IS.fromList [a, b]
    g' = f (m + 1) $ f (m + 2) g
    f x gg = IM.update (Just . (IS.insert x)) a $ IM.update (Just . (IS.insert x)) b $ IM.insert x prev gg

insert2' :: Graph -> Graph
insert2' g@(_,m) = insert2 (m, m - 1) g

insert2'' ::  (IM.IntMap IS.IntSet, Int) -> Graph
insert2'' g@(_,m) = insert2 (m,m) g

insert1 :: Int -> Graph -> Graph
insert1 a (g, m) = (g', m + 1)
  where
    prev = IS.singleton a
    g' =  IM.update (Just . (IS.insert (m + 1))) a $ IM.insert (m + 1) prev g

insert1' :: Graph -> Graph
insert1' g@(_,m) = insert1 m g

connect :: (Int, Int) -> Graph -> Graph
connect (a,b) (g,m) = (IM.update (Just . (IS.insert a)) b $ IM.update (Just . (IS.insert b)) a g, m)

connect' :: Int -> Graph -> Graph
connect' a g@(_,m) = connect (a,m) g

close1 :: Graph -> Graph
close1 g@(_,m) = connect (2,m) g

close2 :: Graph -> Graph
close2 g@(_,m) = connect (2,m) . connect (2, m - 1) $ g

rush :: [Bool] -> Graph
rush [True] = connect (1,2) emptyGraph
rush l = let len = length l
             z = zip l [0..]
             build 0 = insert2 (1,1) : replicate (len - 2) insert2' ++ [close2]
             build x
              | x == len - 1 =  insert1 1 : replicate (len - 2) insert1' ++ [close1]
              | otherwise = insert1 1 : replicate (x - 1) insert1' ++ [connect' (2*x+3), connect' (2*x+4)]
             apply = foldl' (\g f -> f g)
         in
          foldl' (\g (t,non2) -> if t then apply  g (build non2) else g) emptyGraph z

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Control.Monad (mapM_)
import Data.Int (Int64)

type Block = (Int, Int)   -- (start, length)

cY = 'Y'
cN = 'N'

row :: Int -> Block -> Block -> ByteString
row end (pstart, plen) (nstart, nlen) =
  BS.pack $ col1 ++ col2 ++ pre ++ blk1 ++ mid ++ blk2 ++ post
  where
    col1 = if plen == 0 then [cY] else [cN]
    col2 = if nlen == 0 then [cY] else [cN]
    pend = pstart+plen
    nend = nstart+nlen
    pre  = replicate (pstart-3)    cN
    blk1 = replicate plen          cY
    mid  = replicate (nstart-pend) cN
    blk2 = replicate nlen          cY
    post = replicate (end-nend)    cN

triples :: [a] -> [(a,a,a)]
triples [] = []
triples [_,_] = []
triples xs@(a:b:c:_) =  (a,b,c) : triples (tail xs)

rows :: Int -> [ Block ] -> [ByteString]
rows end blks =
    [ r' | (a,(bstart,blen),c) <- blks', let r = row end a c, r' <- replicate blen r ]
  where blks' = triples $ [(3,0)] ++ blks ++ [(end,0)]

-- return a string with Ys in the positions indicated and N's elsewhere
pattern :: Int -> [Block] -> ByteString
pattern end blks = BS.pack $ go 1 blks
  where
    go k [] = replicate (end-k) cN
    go k ((start,len):rest) = replicate (start-k) cN ++ replicate len cY ++ go (start+len) rest

row1 :: Int -> [ [Block] ] -> ByteString
row1 end blks = pattern end (map head blks)

row2 :: Int -> [ [Block] ] -> ByteString
row2 end blks = pattern end (map last blks)

test1 = do let blks = [(3,3),(6,2)]
           mapM_ BS.putStrLn $ [row1 8 [blks], row2 8 [blks]] ++ rows 8 blks

assign' :: Int -> [Int] -> (Int,[Block])
assign' k [] = (k,[])
assign' k xs = (m, blks)
  where
    blks = go k xs
    m = let (k,a) = last blks in a+k
    go k [] = []
    go k (a:as) = (k,a) : go (k+a) as

-- assume all lists have the same length
assign :: [[Int]] -> (Int, [[Block]])
assign [] = (3, [])
assign xs = (m,blkss)
  where
    blkss = go 3 xs
    m = let (k,a) = (last (last blkss))
        in a+k
    go k []     = []
    go k (x:xs) = let (k',bs) = assign' k x
                  in bs : go k' xs

-- | make all the lengths the same by extending short lists with 1
normalize :: [[Int]] -> [[Int]]
normalize xss =
  let m = maximum (map length xss)
  in map (\xs -> replicate (m - length xs) 1 ++ xs) xss

graph :: Int -> [[Block]] -> [ByteString]
graph end blkss =
  [row1 end blkss, row2 end blkss] ++ concatMap (rows end) blkss

bAdd :: [[Int]] -> [[Int]] -> [[Int]]
bAdd as bs = as ++ bs

bMul :: Int -> [[Int]] -> [[Int]]
bMul n bss = map (n:) bss

toInts :: Int -> Int64 -> [[Int]]
toInts base 0 = []
toInts base n =
  case n `divMod` (fromIntegral base) of
    (q,0) -> base `bMul` (toInts base q)
    (q,r) -> (base `bMul` (toInts base q)) `bAdd` [[fromIntegral r]]

nodeCount :: [[Int]] -> Int
nodeCount = sum . concat

toBlocks :: Int -> Int64 -> (Int,[[Block]])
toBlocks base = assign . normalize . toInts base

solve :: Int64 -> (Int,[ByteString])
solve n =
  let (end,blkss) = toBlocks 2 n
  in (end, graph end blkss)

main = do
  n <- read `fmap` getLine
  let (end,lines) = solve n
  print (end-1)
  mapM_ BS.putStrLn lines

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Control.Monad (mapM_)

type Block = (Int, Int)   -- (start, length)

cY = 'Y'
cN = 'N'

row :: Int -> Block -> Block -> ByteString
row end (pstart, plen) (nstart, nlen) =
  BS.pack $ col1 ++ col2 ++ pre ++ blk1 ++ mid ++ blk2 ++ post
  where
    col1 = if plen == 0 then [cY] else [cN]
    col2 = if nlen == 0 then [cY] else [cN]
    pend = pstart+plen
    nend = nstart+nlen
    pre  = replicate (pstart-3)    cN
    blk1 = replicate plen          cY
    mid  = replicate (nstart-pend) cN
    blk2 = replicate nlen          cY
    post = replicate (end-nend)    cN

triples :: [a] -> [(a,a,a)]
triples [] = []
triples [_,_] = []
triples xs@(a:b:c:_) =  (a,b,c) : triples (tail xs)

rows :: Int -> [ Block ] -> [ByteString]
rows end blks =
    [ r' | (a,(bstart,blen),c) <- blks', let r = row end a c, r' <- replicate blen r ]
  where blks' = triples $ [(3,0)] ++ blks ++ [(end,0)]

-- return a string with Ys in the positions indicated and N's elsewhere
pattern :: Int -> [Block] -> ByteString
pattern end blks = BS.pack $ go 1 blks
  where
    go k [] = replicate (end-k) cN
    go k ((start,len):rest) = replicate (start-k) cN ++ replicate len cY ++ go (start+len) rest

row1 :: Int -> [ [Block] ] -> ByteString
row1 end blks = pattern end (map head blks)

row2 :: Int -> [ [Block] ] -> ByteString
row2 end blks = pattern end (map last blks)

test1 = do let blks = [(3,3),(6,2)]
           mapM_ BS.putStrLn $ [row1 8 [blks], row2 8 [blks]] ++ rows 8 blks

assign' :: Int -> [Int] -> (Int,[Block])
assign' k [] = (k,[])
assign' k xs = (m, blks)
  where
    blks = go k xs
    m = let (k,a) = last blks in a+k
    go k [] = []
    go k (a:as) = (k,a) : go (k+a) as

-- assume all lists have the same length
assign :: [[Int]] -> (Int, [[Block]])
assign [] = (3, [])
assign xs = (m,blkss)
  where
    blkss = go 3 xs
    m = let (k,a) = (last (last blkss))
        in a+k
    go k []     = []
    go k (x:xs) = let (k',bs) = assign' k x
                  in bs : go k' xs

-- | make all the lengths the same by extending short lists with 1
normalize :: [[Int]] -> [[Int]]
normalize xss =
  let m = maximum (map length xss)
  in map (\xs -> replicate (m - length xs) 1 ++ xs) xss

graph :: Int -> [[Block]] -> [ByteString]
graph end blkss =
  [row1 end blkss, row2 end blkss] ++ concatMap (rows end) blkss

bAdd :: [[Int]] -> [[Int]] -> [[Int]]
bAdd as bs = as ++ bs

bMul :: Int -> [[Int]] -> [[Int]]
bMul n bss = map (n:) bss

toInts :: Int -> Int -> [[Int]]
toInts base 0 = []
toInts base n =
  case n `divMod` base of
    (q,0) -> base `bMul` (toInts base q)
    (q,r) -> (base `bMul` (toInts base q)) `bAdd` [[r]]

nodeCount :: [[Int]] -> Int
nodeCount = sum . concat

toBlocks :: Int -> Int -> (Int,[[Block]])
toBlocks base = assign . normalize . toInts base

solve :: Int -> (Int,[ByteString])
solve n =
  let (end,blkss) = toBlocks 2 n
  in (end, graph end blkss)

main = do
  n <- read `fmap` getLine
  let (end,lines) = solve n
  print (end-1)
  mapM_ BS.putStrLn lines

import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Control.Monad (mapM_)

type Block = (Int, Int)   -- (start, length)

cY = 'Y'
cN = 'N'

row :: Int -> Block -> Block -> ByteString
row end (pstart, plen) (nstart, nlen) =
  BS.pack $ col1 ++ col2 ++ pre ++ blk1 ++ mid ++ blk2 ++ post
  where
    col1 = if plen == 0 then [cY] else [cN]
    col2 = if nlen == 0 then [cY] else [cN]
    pend = pstart+plen
    nend = nstart+nlen
    pre  = replicate (pstart-3)    cN
    blk1 = replicate plen          cY
    mid  = replicate (nstart-pend) cN
    blk2 = replicate nlen          cY
    post = replicate (end-nend)    cY

triples :: [a] -> [(a,a,a)]
triples [] = []
triples [_,_] = []
triples xs@(a:b:c:_) =  (a,b,c) : triples (tail xs)

rows :: Int -> [ Block ] -> [ByteString]
rows end blks =
    [ r' | (a,(bstart,blen),c) <- blks', let r = row end a c, r' <- replicate blen r ]
  where blks' = triples $ [(3,0)] ++ blks ++ [(end,0)]

-- return a string with Ys in the positions indicated and N's elsewhere
pattern :: Int -> [Block] -> ByteString
pattern end blks = BS.pack $ go 1 blks
  where
    go k [] = replicate (end-k) cN
    go k ((start,len):rest) = replicate (start-k) cN ++ replicate len cY ++ go (start+len) rest

row1 :: Int -> [ [Block] ] -> ByteString
row1 end blks = pattern end (map head blks)

row2 :: Int -> [ [Block] ] -> ByteString
row2 end blks = pattern end (map last blks)

test1 = do let blks = [(3,3),(6,2)]
           mapM_ BS.putStrLn $ [row1 8 [blks], row2 8 [blks]] ++ rows 8 blks

assign' :: Int -> [Int] -> (Int,[Block])
assign' k [] = (k,[])
assign' k xs = (fst (last blks), blks)
  where
    blks = go k xs
    go k [] = []
    go k (a:as) = (k,a) : go (k+a) as

-- assume all lists have the same length
assign :: [[Int]] -> (Int, [[Block]])
assign [] = (3, [])
assign xs = (m,blkss)
  where
    blkss = go 3 xs
    m = let (k,a) = (last (last blkss))
        in a+k
    go k []     = []
    go k (x:xs) = let (k',bs) = assign' k x
                  in bs : go k' xs

-- | make all the lengths the same by extending short lists with 1
normalize :: [[Int]] -> [[Int]]
normalize xss =
  let m = maximum (map length xss)
  in map (\xs -> replicate (m - length xs) 1 ++ xs) xss

graph :: Int -> [[Block]] -> [ByteString]
graph end blkss =
  [row1 end blkss, row2 end blkss] ++ concatMap (rows end) blkss

bAdd :: [[Int]] -> [[Int]] -> [[Int]]
bAdd as bs = as ++ bs

bMul :: Int -> [[Int]] -> [[Int]]
bMul n bss = map (n:) bss

toInts :: Int -> Int -> [[Int]]
toInts base 0 = []
toInts base n =
  case n `divMod` base of
    (q,0) -> base `bMul` (toInts base q)
    (q,r) -> (base `bMul` (toInts base q)) `bAdd` [[r]]

nodeCount :: [[Int]] -> Int
nodeCount = sum . concat

toBlocks :: Int -> Int -> (Int,[[Block]])
toBlocks base = assign . normalize . toInts base

solve :: Int -> (Int,[ByteString])
solve n =
  let (end,blkss) = toBlocks 2 n
  in (end, graph end blkss)

main = do
  n <- read `fmap` getLine
  let (end,lines) = solve n
  print (end-1)
  mapM_ BS.putStrLn lines

import qualified Data.IntMap as IM
import Data.List (foldl')
import qualified Data.IntSet as IS

decomp :: Integer -> [Bool]
decomp x = decomp' x []
  where
    decomp' 0 l = l
    decomp' k l
      | k `mod` 2 == 1 = decomp' (k `div` 2) (True:l)
      | otherwise = decomp' (k `div` 2) (False:l)

main :: IO ()
main = do
  i <- fmap read getLine
  let bits = decomp i
  print bits
  --print $ rush bits
  putStr $ pp $ rush bits

pp :: Graph -> String
pp (g,m) = unlines $ show m : pg
  where pg = foldr (\i l -> let Just es = IM.lookup i g
                            in  map (\j -> if IS.member j es then 'Y' else 'N') [1..m] : l) [] [1..m]

type Graph = (IM.IntMap IS.IntSet, Int)

emptyGraph :: Graph
emptyGraph = (IM.fromList [(1, IS.empty), (2, IS.empty)], 2)

insert2 :: (Int, Int) -> Graph -> Graph
insert2 (a,b) (g, m) = (g', m + 2)
  where
    prev = IS.fromList [a, b]
    g' = f (m + 1) $ f (m + 2) g
    f x gg = IM.update (Just . (IS.insert x)) a $ IM.update (Just . (IS.insert x)) b $ IM.insert x prev gg

insert2' :: Graph -> Graph
insert2' g@(_,m) = insert2 (m, m - 1) g

insert2'' ::  (IM.IntMap IS.IntSet, Int) -> Graph
insert2'' g@(_,m) = insert2 (m,m) g

insert1 :: Int -> Graph -> Graph
insert1 a (g, m) = (g', m + 1)
  where
    prev = IS.singleton a
    g' =  IM.update (Just . (IS.insert (m + 1))) a $ IM.insert (m + 1) prev g

insert1' :: Graph -> Graph
insert1' g@(_,m) = insert1 m g

connect :: (Int, Int) -> Graph -> Graph
connect (a,b) (g,m) = (IM.update (Just . (IS.insert a)) b $ IM.update (Just . (IS.insert b)) a g, m)

connect' :: Int -> Graph -> Graph
connect' a g@(_,m) = connect (a,m) g

close1 :: Graph -> Graph
close1 g@(_,m) = connect (2,m) g

close2 :: Graph -> Graph
close2 g@(_,m) = connect (2,m) . connect (2, m - 1) $ g

rush :: [Bool] -> Graph
rush [True] = connect (1,2) emptyGraph
rush l = let len = length l
             z = zip l [0..]
             build 0 = insert2 (1,1) : replicate (len - 2) insert2' ++ [close2]
             build x
              | x == len - 1 =  insert1 1 : replicate (len - 2) insert1' ++ [close1]
              | otherwise = insert1 1 : replicate (x - 1) insert1' ++ [connect' (2*x+3), connect' (2*x+4)]
             apply = foldl' (\g f -> f g)
         in
          foldl' (\g (t,non2) -> if t then apply  g (build non2) else g) emptyGraph z

import qualified Data.IntMap as IM
import Data.List (foldl')
import qualified Data.IntSet as IS

decomp :: Integer -> [Bool]
decomp x = decomp' x []
  where
    decomp' 0 l = l
    decomp' k l
      | k `mod` 2 == 1 = decomp' (k `div` 2) (True:l)
      | otherwise = decomp' (k `div` 2) (False:l)

main :: IO ()
main = do
  i <- fmap read getLine
  let bits = decomp i
  --print $ rush bits
  putStr $ pp $ rush bits

pp :: Graph -> String
pp (g,m) = unlines $ show m : pg
  where pg = foldr (\i l -> let Just es = IM.lookup i g
                            in  map (\j -> if IS.member j es then 'Y' else 'N') [1..m] : l) [] [1..m]

type Graph = (IM.IntMap IS.IntSet, Int)

emptyGraph :: Graph
emptyGraph = (IM.fromList [(1, IS.empty), (2, IS.empty)], 2)

insert2 :: (Int, Int) -> Graph -> Graph
insert2 (a,b) (g, m) = (g', m + 2)
  where
    prev = IS.fromList [a, b]
    g' = f (m + 1) $ f (m + 2) g
    f x gg = IM.update (Just . (IS.insert x)) a $ IM.update (Just . (IS.insert x)) b $ IM.insert x prev gg

insert2' :: Graph -> Graph
insert2' g@(_,m) = insert2 (m, m - 1) g

insert2'' ::  (IM.IntMap IS.IntSet, Int) -> Graph
insert2'' g@(_,m) = insert2 (m,m) g

insert1 :: Int -> Graph -> Graph
insert1 a (g, m) = (g', m + 1)
  where
    prev = IS.singleton a
    g' =  IM.update (Just . (IS.insert (m + 1))) a $ IM.insert (m + 1) prev g

insert1' :: Graph -> Graph
insert1' g@(_,m) = insert1 m g

connect :: (Int, Int) -> Graph -> Graph
connect (a,b) (g,m) = (IM.update (Just . (IS.insert a)) b $ IM.update (Just . (IS.insert b)) a g, m)

close1 :: Graph -> Graph
close1 g@(_,m) = connect (2,m) g

close2 :: Graph -> Graph
close2 g@(_,m) = connect (2,m) . connect (2, m - 1) $ g

rush :: [Bool] -> Graph
rush [True] = connect (1,2) emptyGraph
rush l = let len = length l
             z = zip l [0..]
             build 0 = insert2 (1,1) : replicate (len - 2) insert2' ++ [close2]
             build x
              | x == len - 1 =  insert1 1 : replicate (len - 2) insert1' ++ [close1]
              | otherwise = insert1 1 : replicate (x - 1) insert1' ++ [insert2''] ++ replicate (len - 2 - x) insert2' ++ [close2]
             apply = foldl' (\g f -> f g)
         in
          foldr (\(t,non2) g -> if t then apply  g (build non2) else g) emptyGraph z


Xenia the horse breeder has n (n > 1) horses that stand in a row. Each horse has its own unique number. Initially, the i-th left horse has number i. That is, the sequence of numbers of horses in a row looks as follows (from left to right): 1, 2, 3, ..., n.Xenia trains horses before the performance. During the practice sessions, she consistently gives them commands. Each command is a pair of numbers l, r (1 ≤ l < r ≤ n). The command l, r means that the horses that are on the l-th, (l + 1)-th, (l + 2)-th, ..., r-th places from the left must be rearranged. The horses that initially stand on the l-th and r-th places will swap. The horses on the (l + 1)-th and (r - 1)-th places will swap. The horses on the (l + 2)-th and (r - 2)-th places will swap and so on. In other words, the horses that were on the segment [l, r] change their order to the reverse one.For example, if Xenia commanded l = 2, r = 5, and the sequence of numbers of horses before the command looked as (2, 1, 3, 4, 5, 6), then after the command the sequence will be (2, 5, 4, 3, 1, 6).We know that during the practice Xenia gave at most three commands of the described form. You have got the final sequence of numbers of horses by the end of the practice. Find what commands Xenia gave during the practice. Note that you do not need to minimize the number of commands in the solution, find any valid sequence of at most three commands.

The first line contains an integer n (2 ≤ n ≤ 1000) — the number of horses in the row. The second line contains n distinct integers a1, a2, ..., an (1 ≤ ai ≤ n), where ai is the number of the i-th left horse in the row after the practice.

The first line should contain integer k (0 ≤ k ≤ 3) — the number of commads Xenia gave during the practice. In each of the next k lines print two integers. In the i-th line print numbers li, ri (1 ≤ li < ri ≤ n) — Xenia's i-th command during the practice. It is guaranteed that a solution exists. If there are several solutions, you are allowed to print any of them.

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, Int)]
solve (x:xs)  =  head' $ solve' [] $ group (x, x) xs
  where
    head' []  =  [(1, 2)]
    head' (x:xs)  =  x
    m  =  length $ group (x, x) xs
    group :: (Int, Int) -> [Int] -> [(Int, Int)]
    group (a, b) []
      | abs (a - b) == 1  =  [(a, a), (b, b)]
      | otherwise  =  [(a, b)]
    group (a, b) (x:xs)
      | a <= b && b + 1 == x  =  group (a, x) xs
      | a >= b && b - 1 == x  =  group (a, x) xs
      | abs (a - b) == 1  =  (a, a) : (b, b) : group (x, x) xs
      | otherwise  =  (a, b) : group (x, x) xs
    solve' :: [(Int, Int)] -> [(Int, Int)] -> [[(Int, Int)]]
    solve' ans group
      | sorted group  =  [ans]
      | length ans >= 3  =  []
      | otherwise  =  concat [solve' (numbers i j : ans) (replace group (i, j)) | i <- [1..m], j <- [1..m], i < j || i == j && notNull (group !! (i-1))]
      where
        sum' s (a, b)  =  s + (abs (b - a) + 1)
        numbers i j  =  (foldl sum' 1 $ take (i - 1) group, foldl sum' 0 $ take j group)
        notNull (a, b)  =  a /= b

    sorted :: [(Int, Int)] -> Bool
    sorted []  =  True
    sorted [(x, y)]  =  x <= y
    sorted ((x1, y1) : (x2, y2) : xs)
      | x1 <= y1 && y1 + 1 == x2  =  sorted ((x2, y2) : xs)
      | otherwise  =  False
replace :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
replace group (i, j)  =  take (i-1) group  ++ (map swap $ reverse $ drop (i-1) $ take j group)  ++ drop j group
  where
    swap (i, j)  =  (j, i)

print' :: [(Int, Int)] -> IO ()
print' ans  =  do
    print $ length ans
    mapM_ print'' ans
  where
    print'' (x, y)  =  putStrLn $ concat [show x, " ", show y]

main :: IO ()
main  =
  getLine >> reads >>= print' . solve
  --print $ solve [10, 5, 4, 9, 8, 7, 6, 3, 2, 1]
  --print $ solve [1,2,3,7,8,9,6,5,4,10]
  --print $ solve [1,2,3,4,8,7,5,6,9,10]
  --print $ solve [1,2,4,3,5,6,8,7,9,10,12,11,13,14]
  --print $ solve [1,2,3,7,8,4,5,6,9,10]
  --print $ solve [1,3,4,2,5,6]
  --print $ solve [3, 4, 1, 2, 5, 6, 7, 10, 9, 8, 11]

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, Int)]
solve (x:xs)  =  head' $ solve' [] $ group (x, x) xs
  where
    head' []  =  [(1, 2)]
    head' (x:xs)  =  x
    m  =  length $ group (x, x) xs
    group :: (Int, Int) -> [Int] -> [(Int, Int)]
    group (a, b) []
      | a - b == 1  =  [(a, a), (b, b)]
      | otherwise  =  [(a, b)]
    group (a, b) (x:xs)
      | a <= b && b + 1 == x  =  group (a, x) xs
      | a >= b && b - 1 == x  =  group (a, x) xs
      | a - b == 1  =  (a, a) : (b, b) : group (x, x) xs
      | otherwise  =  (a, b) : group (x, x) xs
    solve' :: [(Int, Int)] -> [(Int, Int)] -> [[(Int, Int)]]
    solve' ans group
      | sorted group  =  [ans]
      | length ans >= 3  =  []
      | otherwise  =  concat [solve' (numbers i j : ans) (replace group (i, j)) | i <- [1..m], j <- [1..m], i < j || i == j && notNull (group !! (i-1))]
      where
        sum' s (a, b)  =  s + (abs (b - a) + 1)
        numbers i j  =  (foldl sum' 1 $ take (i - 1) group, foldl sum' 0 $ take j group)
        notNull (a, b)  =  a /= b

    sorted :: [(Int, Int)] -> Bool
    sorted []  =  True
    sorted [(x, y)]  =  x <= y
    sorted ((x1, y1) : (x2, y2) : xs)
      | x1 <= y1 && y1 + 1 == x2  =  sorted ((x2, y2) : xs)
      | otherwise  =  False
replace :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
replace group (i, j)  =  take (i-1) group  ++ (map swap $ reverse $ drop (i-1) $ take j group)  ++ drop j group
  where
    swap (i, j)  =  (j, i)

print' :: [(Int, Int)] -> IO ()
print' ans  =  do
    print $ length ans
    mapM_ print'' ans
  where
    print'' (x, y)  =  putStrLn $ concat [show x, " ", show y]

main :: IO ()
main  =
  getLine >> reads >>= print' . solve
  --print $ solve [10, 5, 4, 9, 8, 7, 6, 3, 2, 1]
  --print $ solve [1,2,3,7,8,9,6,5,4,10]
  --print $ solve [1,2,3,4,8,7,5,6,9,10]
  --print $ solve [1,2,4,3,5,6,8,7,9,10,12,11,13,14]
  --print $ solve [1,2,3,7,8,4,5,6,9,10]
  --print $ solve [1,3,4,2,5,6]

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, Int)]
solve (x:xs)  =  head' $ solve' [] $ group (x, x) xs
  where
    head' []  =  [(1, 2)]
    head' (x:xs)  =  x
    m  =  length $ group (x, x) xs
    group :: (Int, Int) -> [Int] -> [(Int, Int)]
    group (a, b) []  =  [(a, b)]
    group (a, b) (x:xs)
      | a <= b && b + 1 == x  =  group (a, x) xs
      | a >= b && b - 1 == x  =  group (a, x) xs
      | otherwise  =  (a, b) : group (x, x) xs
    solve' :: [(Int, Int)] -> [(Int, Int)] -> [[(Int, Int)]]
    solve' ans group
      | sorted group  =  [ans]
      | length ans >= 3  =  []
      | otherwise  =  concat [solve' (numbers i j : ans) (replace group (i, j)) | i <- [1..m], j <- [1..m], i < j || i == j && notNull (group !! (i-1))]
      where
        sum' s (a, b)  =  s + (abs (b - a) + 1)
        numbers i j  =  (foldl sum' 1 $ take (i - 1) group, foldl sum' 0 $ take j group)
        notNull (a, b)  =  a /= b

    sorted :: [(Int, Int)] -> Bool
    sorted []  =  True
    sorted [(x, y)]  =  x <= y
    sorted ((x1, y1) : (x2, y2) : xs)
      | x1 <= y1 && y1 + 1 == x2  =  sorted ((x2, y2) : xs)
      | otherwise  =  False
replace :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
replace group (i, j)  =  take (i-1) group  ++ (map swap $ reverse $ drop (i-1) $ take j group)  ++ drop j group
  where
    swap (i, j)  =  (j, i)

print' :: [(Int, Int)] -> IO ()
print' ans  =  do
    print $ length ans
    mapM_ print'' ans
  where
    print'' (x, y)  =  putStrLn $ concat [show x, " ", show y]

main :: IO ()
main  =
  --getLine >> reads >>= print' . solve
  print $ solve [10, 5, 4, 9, 8, 7, 6, 3, 2, 1]

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, Int)]
solve (x:xs)  =  head' $ solve' [] $ group (x, x) xs
  where
    head' []  =  [(1, 2)]
    head' (x:xs)  =  x
    m  =  length $ group (x, x) xs
    group :: (Int, Int) -> [Int] -> [(Int, Int)]
    group (a, b) []  =  [(a, b)]
    group (a, b) (x:xs)
      | a <= b && b + 1 == x  =  group (a, x) xs
      | a >= b && b - 1 == x  =  group (a, x) xs
      | otherwise  =  (a, b) : group (x, x) xs
    solve' :: [(Int, Int)] -> [(Int, Int)] -> [[(Int, Int)]]
    solve' ans group
      | sorted group  =  [ans]
      | length ans >= 3  =  []
      | otherwise  =  concat [solve' (numbers i j : ans) (replace group (i, j)) | i <- [1..m], j <- [1..m], i < j || i == j && notNull (group !! (i-1))]
      where
        sum' s (a, b)  =  s + (abs (b - a) + 1)
        numbers i j  =  (foldl sum' 1 $ take (i - 1) group, foldl sum' 0 $ take j group)
        notNull (a, b)  =  a /= b

    sorted :: [(Int, Int)] -> Bool
    sorted []  =  True
    sorted [(x, y)]  =  x <= y
    sorted ((x1, y1) : (x2, y2) : xs)
      | x1 <= y1 && y1 + 1 == x2  =  sorted ((x2, y2) : xs)
      | otherwise  =  False
replace :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
replace group (i, j)  =  take (i-1) group  ++ (map swap $ reverse $ drop (i-1) $ take j group)  ++ drop j group
  where
    swap (i, j)  =  (j, i)

print' :: [(Int, Int)] -> IO ()
print' ans  =  do
    print $ length ans
    mapM_ print'' ans
  where
    print'' (x, y)  =  putStrLn $ concat [show x, " ", show y]

main :: IO ()
main  =
  getLine >> reads >>= print' . solve
  --print $ solve [10, 5, 4, 9, 8, 7, 6, 3, 2, 1]