When little Petya grew up and entered the university, he started to take part in АСМ contests. Later he realized that he doesn't like how the АСМ contests are organised: the team could only have three members (and he couldn't take all his friends to the competitions and distribute the tasks between the team members efficiently), so he decided to organize his own contests PFAST Inc. — Petr and Friends Are Solving Tasks Corporation. PFAST Inc. rules allow a team to have unlimited number of members.To make this format of contests popular he organised his own tournament. To create the team he will prepare for the contest organised by the PFAST Inc. rules, he chose several volunteers (up to 16 people) and decided to compile a team from them. Petya understands perfectly that if a team has two people that don't get on well, then the team will perform poorly. Put together a team with as many players as possible given that all players should get on well with each other.

The first line contains two integer numbers n (1 ≤ n ≤ 16) — the number of volunteers, and m () — the number of pairs that do not get on. Next n lines contain the volunteers' names (each name is a non-empty string consisting of no more than 10 uppercase and/or lowercase Latin letters). Next m lines contain two names — the names of the volunteers who do not get on. The names in pair are separated with a single space. Each pair of volunteers who do not get on occurs exactly once. The strings are case-sensitive. All n names are distinct.

The first output line should contain the single number k — the number of people in the sought team. Next k lines should contain the names of the sought team's participants in the lexicographical order. If there are several variants to solve the problem, print any of them. Petya might not be a member of the sought team.

module Main where

import Control.Monad
import Data.Bits
import Data.List
import qualified Data.Map as Map

bitCount 0 = 0
bitCount n = ( n .&. 1 ) + bitCount ( n `shiftR` 1 )

chooseToNames 0 _ = []
chooseToNames n (name:names) =
    let others = chooseToNames (n `shiftR` 1) names in
    if n .&. 1 == 0
        then others
        else name : others

main = do
    [n, m] <- ( map read . words ) `liftM` getLine
    volunteers <- replicateM n getLine

    let volunteerIndexMap = Map.fromList (zip volunteers [0..])

    constraints <- replicateM m $ do
        [a, b] <- ( map ( bit . ( volunteerIndexMap Map.! ) ) . words ) `liftM` getLine
        return ( a .|. b )

    let candidates :: [Int]
        candidates = filter (\t ->
                all (\c -> t .&. c /= c) constraints
            ) [1..( 1 `shift` n )]
        (choose, chooseLen) = foldl' (\(best, bestLen) c ->
                let currLen = bitCount c in
                if currLen > bestLen
                    then (c, currLen)
                    else (best, bestLen)
            ) (0,0) candidates
        chooseName = sort $ chooseToNames choose volunteers

    --putStrLn $ show constraints
    --putStrLn $ show candidates
    --putStrLn $ show choose
    putStrLn $ show chooseLen
    putStr $ unlines chooseName

import Data.List
import Control.Monad
combinations k ns = filter ((k==).length) (subsequences ns)
solution::[String]->[(String,String)]->Int->[String]
solution ns cs 1 = [ns !! 0]
solution ns cs n | or $ map isClique combs = (filter isClique combs) !! 0
                 | otherwise = solution ns cs (n-1)
                      where combs = combinations n ns
                            isClique q = all (flip notElem cs) [(a,b) | a<- q, b <-q]
printsol xs = (putStrLn $ show.length $ xs) >> (forM_ xs (\x -> putStrLn x))
main = do
       [n,m] <- getLine >>= return.(map read).words
       team <- forM [1..n]  (\_ -> getLine)
       collisions <-fmap concat $ forM [1..m] (\_ -> do
                                          [n1,n2] <- getLine >>= return . words
                                          return [(n1,n2), (n2,n1)])
       printsol $ sort $ solution team collisions n

import qualified Data.ByteString.Lazy.Char8 as C
import Data.List
import Data.Array
import Data.Maybe
import IO
import Debug.Trace

mytrace x = traceShow x x

powSet :: [a] -> [[a]]
powSet [] = [[]]
powSet (x:xs) = concat [[x:y, y] | y <- powSet xs]

ok :: [(Int, Int)] -> Int -> Int -> Bool
ok x y z = d!(y,z)
	where
		ok' (i,j) = (elemIndex (i,j) x == Nothing) && (elemIndex (j,i) x == Nothing)
		d = array ((1,1),(16,16)) [((i,j), ok' (i,j)) | i <- [1..16], j <- [1..16]]

-- nameToId :: [C.ByteString] -> C.ByteString -> Int
nameToId a s = (fromJust . elemIndex s) a + 1

-- idToName :: [C.ByteString] -> Int -> C.ByteString
idToName a i = a !! (i - 1)

ord :: [a] -> [a] -> Ordering
ord x y
	| length x < length y = LT
	| length x > length y = GT
	| otherwise = EQ

getLines 0 = return []
getLines n = do
	x <- getLine
	xs <- getLines (n-1)
	return (x:xs)

getLines2 0 = return []
getLines2 n = do
	x <- getLine >>= return . words
	xs <- getLines2 (n-1)
	return (x:xs)

main = do
	-- stream <- fmap C.lines $ C.hGetContents stdin
	-- let [n, m] = mytrace $ (map (fst . fromJust . C.readInt) . C.words . head) stream
	-- let names = mytrace $ (take n . tail) stream
	-- let bad_pairs = mytrace $ (map ((\x -> (head x, last x)) . map (nameToId names) . C.words) . take m . drop (n+1)) stream
	[n, m] <- getLine >>= return . map read . words :: IO [Int]
	names <- getLines n
	bad_pairs <- getLines2 m >>= return . map ((\x -> (head x, last x)) . map (nameToId names))
	let ans = (last . sortBy ord) [ c | c <- powSet [1..n], all (\(a, b) -> ok bad_pairs a b) [(a, b) | a <- c, b <- c]]
	putStr $ (show . length) ans ++ "\n" ++ (unlines . sort . map (idToName names)) ans

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

powSet :: [a] -> [[a]]
powSet [] = [[]]
powSet (x:xs) = concat [[x:y, y] | y <- powSet xs]

ok :: [(Int, Int)] -> Int -> Int -> Bool
ok x y z = d!(y,z)
	where
		ok' (i,j) = (elemIndex (i,j) x == Nothing) && (elemIndex (j,i) x == Nothing)
		d = array ((1,1),(16,16)) [((i,j), ok' (i,j)) | i <- [1..16], j <- [1..16]]

nameToId :: [String] -> String -> Int
nameToId a s = (fromJust . elemIndex s) a + 1

idToName :: [String] -> Int -> String
idToName a i = a !! (i - 1)

ord :: [a] -> [a] -> Ordering
ord x y
	| length x < length y = LT
	| length x > length y = GT
	| otherwise = EQ

getLines 0 = return []
getLines n = do
	x <- getLine
	xs <- getLines (n-1)
	return (x:xs)

getLines2 0 = return []
getLines2 n = do
	x <- getLine >>= return . words
	xs <- getLines2 (n-1)
	return (x:xs)

main = do
	[n, m] <- getLine >>= return . map read . words :: IO [Int]
	names <- getLines n
	bad_pairs <- getLines2 m >>= return . map ((\x -> (head x, last x)) . map (nameToId names))
	let ans = (last . sortBy ord) [ c | c <- powSet [1..n], all (\(a, b) -> ok bad_pairs a b) [(a, b) | a <- c, b <- c]]
	putStr $ (show . length) ans ++ "\n" ++ (unlines . sort . map (idToName names)) ans

{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -O2 #-}
import Debug.Trace
import Data.List
import Data.Array
import Data.Char
import Data.Map

class Scan a where scan' :: String -> a
instance Scan Int where scan' = read
instance Scan Char where scan' (x:_) = x
instance Scan Float where scan' = read
instance Scan Double where scan' = read
instance Scan Integer where scan' = read
instance Scan String where scan' x = x
instance (Scan a,Scan b) => Scan (a,b) where scan' x = (\(x:y:_) -> (scan' x,scan' y)) (words x)
instance (Scan a,Scan b,Scan c) => Scan (a,b,c) where scan' x = (\(x:y:z:_) -> (scan' x,scan' y,scan' z)) (words x)
instance (Scan a,Scan b,Scan c,Scan d) => Scan (a,b,c,d) where scan' x = (\(w:x:y:z:_) -> (scan' w,scan' x,scan' y,scan' z)) (words x)
instance (Scan a,Scan b,Scan c,Scan d,Scan e) => Scan (a,b,c,d,e) where scan' x = (\(v:w:x:y:z:_) -> (scan' v,scan' w,scan' x,scan' y,scan' z)) (words x)
class Ans a where showans :: a -> String
instance Ans Int where showans x = show x
instance Ans Char where showans x = [x]
instance Ans Float where showans x = show x
instance Ans Double where showans x = show x
instance Ans Integer where showans x = show x
instance Ans String where showans x = x
instance (Ans a, Ans b) => Ans (a,b) where showans (x,y) = showans x ++ " " ++ showans y
instance (Ans a, Ans b,Ans c) => Ans (a,b,c) where showans (x,y,z) = showans x ++ " " ++ showans y ++ " " ++ showans z
scan :: (Scan a) => IO a
scan = getLine>>=(return.scan')
scans :: (Scan a) => Int -> IO [a]
scans n = if n==0 then return [] else scan>>=(\x->scans (n-1)>>=return.(x:))
scanlist :: (Scan a) => IO [a]
scanlist = getLine>>=return.(Data.List.map scan').words
scanlists :: (Scan a) => Int -> IO [[a]]
scanlists n = if n==0 then return [] else scanlist>>=(\x->scanlists (n-1)>>=return.(x:))
putAnsLn :: (Ans a) => a -> IO ()
putAnsLn = putStrLn.showans
putAnsLns :: (Ans a) => [a] -> IO ()
putAnsLns = mapM_ putAnsLn

rec _ [] l = (length l,l)
rec antis (x:xs) l = let (a1,team1) = rec antis xs l in
                     let diff' = (Data.Map.lookup x antis) in
                     let diff = case diff' of
                                  Nothing -> []
                                  Just l -> l
                     in
                       let (a2,team2) = rec antis (xs Data.List.\\ diff) (x:l) in
                       if a1>a2 then
                           (a1,team1)
                       else
                           (a2,team2)

solve members n anti = let antis = foldl (\mp -> \(na,an) -> insertWith (++) an [na] (insertWith (++) na [an] mp)) empty anti in
                       let (ans,team) = rec antis members [] in
                       if ans==0 then
                           ["0"]
                       else
                           (show ans):(sort team)

main = do (n,m) <- scan :: IO (Int,Int)
          members <- scans n :: IO [String]
          anti <- scans m :: IO [(String,String)]
          putAnsLns (solve members n anti)

import Data.List
import Debug.Trace (trace)
import GHC.Exts(sortWith)

main3 = print $ getResult [1,2,3] [(1,2)]
mains = print $ getResult [1,2,3] []
main =
	do
		[n,m] <- getNums
		l <- getLines n
		lines <- getLines m
		let n = lines |> map (\x ->
			let [a,b] = (splitBy x)
			in (a,b))
		let r = getResult (l) n |> sort
		putStrLn $ (show (length r)) ++ "\n" ++ (intercalate "\n" r)

getResult l n = result
	where
		result = subsequences l |> sortWith (\x -> length x) |> reverse |>
			filter (\x -> n |> all (\(y,z) -> (notElem y x) || (notElem z x))) |> head
------------------usefule-----------------------
tr x y = trace ((show x) ++ (show y)) y
tr1 x y = trace ((show x)) y
tr2 y = trace ((show y)) y

(|>) x f = f x

parseInt x = (read x) :: Int

getLines n = repeat getLine |> take n |> sequence

getNums =
	do
		line <- getLine
		return $ getNumbers line

getNumbers line =
	case index of
		Nothing -> [parseInt line]
		Just i ->
			let (l,r) = splitAt (i + 1) line in
				(parseInt l) : (getNumbers r)
	where
		index = elemIndex ' ' line

splitBy k =
	case index of
		Nothing -> [k]
		Just i ->
			let (l,r) = splitAt (i) k in
				l : splitBy (drop 1 r)
	where
		index = elemIndex ' ' k


You are given an integer m, and a list of n distinct integers between 0 and m - 1.You would like to construct a sequence satisfying the properties:  Each element is an integer between 0 and m - 1, inclusive.  All prefix products of the sequence modulo m are distinct.  No prefix product modulo m appears as an element of the input list.  The length of the sequence is maximized. Construct any sequence satisfying the properties above.

The first line of input contains two integers n and m (0 ≤ n < m ≤ 200 000) — the number of forbidden prefix products and the modulus. If n is non-zero, the next line of input contains n distinct integers between 0 and m - 1, the forbidden prefix products. If n is zero, this line doesn't exist.

On the first line, print the number k, denoting the length of your sequence. On the second line, print k space separated integers, denoting your sequence.

NoteFor the first case, the prefix products of this sequence modulo m are [1, 2, 3, 4, 0].For the second case, the prefix products of this sequence modulo m are [3, 7, 4, 6, 8, 0].

{-# OPTIONS_GHC -O3 #-}
{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}

import qualified Data.ByteString as B (getLine, empty)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.List as L (sort, intercalate)
import qualified Data.Set as S (fromList, difference)
import qualified Data.Foldable as F (toList)
import qualified Data.Map.Strict as MP (empty, alter, (!))
import qualified Data.Int as I (Int64)

readInt = fst. M.fromJust . C.readInt

exgcd :: I.Int64 -> I.Int64 -> (I.Int64, I.Int64, I.Int64)
exgcd a 0 = (a, 1, 0)
exgcd a b = (ret, y, x - a `div` b * y) where
    (ret, x, y) = exgcd b (a `mod` b)

pmod x y = ((x `mod` y) + y) `mod` y
modeq a b n | b `mod` d == 0 = pmod (x * (b `div` d)) n | otherwise = -1 where
    (d, x, y) = exgcd a n

modeqx (fromIntegral -> n) (fromIntegral -> a) (fromIntegral -> b) = fromIntegral (modeq a b n)

data Node = Empty | Node Int Int Node deriving Eq
instance Ord (Node) where
    compare (Node _ ci _) (Node _ cj _) = compare ci cj

cnt (x:xs) res | null res || fst (head res) /= x = cnt xs ((x, 1):res)
cnt (x:xs) ((_, cr):res) = cnt xs ((x, succ cr):res)
cnt [] res = reverse res

cmp ((x, xp):xs) mp = cmp xs (MP.alter mpf x mp) where
    mpf Nothing = Just [xp]
    mpf (Just ps) = Just (xp:ps)
cmp [] mp = mp

accu pre ((x, cx):xs) = accu (tf:pre) xs where
    pf = filter (\(Node i _ _) -> x `mod` i == 0) pre
    mx@(Node _ cm _) = maximum pf
    tf = if null pf then (Node x cx Empty) else (Node x (cx + cm) mx)
accu pre [] = maximum pre

acnd Empty mp ans = ans
acnd (Node i _ ct) mp ans = acnd ct mp (reverse (mp MP.! i) ++ ans)

main = do
    (map readInt . C.words -> [n, m]) <- B.getLine
    (map readInt . C.words -> xs) <- if n == 0 then return B.empty else B.getLine
    let rs = L.sort [ (gcd m i, i) | i <- F.toList ((S.fromList [0..m - 1]) `S.difference` (S.fromList xs)) ]
        as = acnd (accu [] (cnt (map fst rs) [])) (cmp rs MP.empty) []
    putStrLn $ show (length as)
    putStrLn $ L.intercalate " " $ map show (zipWith (modeqx m) (1:as) as)


One fine October day a mathematics teacher Vasily Petrov went to a class and saw there n pupils who sat at the  desks, two people at each desk. Vasily quickly realized that number n is even. Like all true mathematicians, Vasily has all students numbered from 1 to n.But Vasily Petrov did not like the way the children were seated at the desks. According to him, the students whose numbers differ by 1, can not sit together, as they talk to each other all the time, distract others and misbehave.On the other hand, if a righthanded student sits at the left end of the desk and a lefthanded student sits at the right end of the desk, they hit elbows all the time and distract each other. In other cases, the students who sit at the same desk, do not interfere with each other.Vasily knows very well which students are lefthanders and which ones are righthanders, and he asks you to come up with any order that meets these two uncomplicated conditions (students do not talk to each other and do not bump their elbows). It is guaranteed that the input is such that at least one way to seat the students always exists.

The first input line contains a single even integer n (4 ≤ n ≤ 100) — the number of students in the class. The second line contains exactly n capital English letters "L" and "R". If the i-th letter at the second line equals "L", then the student number i is a lefthander, otherwise he is a righthander.

Print  integer pairs, one pair per line. In the i-th line print the numbers of students that will sit at the i-th desk. The first number in the pair stands for the student who is sitting to the left, and the second number stands for the student who is sitting to the right. Separate the numbers in the pairs by spaces. If there are multiple solutions, print any of them.

import Array
import Monad
import IO

solve :: Int -> Array Int Char -> [(Int, Int)]
solve n xs  =  [f i | i <- [1..div n 2]]
  where
    f i
      | xs ! i == 'R' && xs ! (i + div n 2) == 'L'  =  (i + div n 2, i)
      | otherwise  =  (i, i + div n 2)

prints :: Show a => Handle -> (a, a) -> IO ()
prints hOutput (a, b)  =  hPutStrLn hOutput (show a ++ " " ++ show b)

main :: IO ()
main  =  do
    hInput  <-  openFile "input.txt" ReadMode
    hOutput  <-  openFile "output.txt" WriteMode
    n   <-  liftM read (hGetLine hInput)
    xs  <-  liftM (listArray (1,n)) (hGetLine hInput)
    mapM_ (prints hOutput) $ solve n xs
    hClose hInput
    hClose hOutput

solve n orient = map swapInter $ zip left right
  where left = [1 .. halfN]
        right = [halfN + 1 .. n]
        halfN = n `div` 2
        swapInter (x, y)
          | l == 'R' && r == 'L' = (y, x)
          | otherwise = (x, y)
          where l = orient !! (x - 1)
                r = orient !! (y - 1)

showPair (x, y) = show x ++ " " ++ show y

main = do [n, orient] <- fmap words $ readFile "input.txt"
          writeFile "output.txt" $ unlines $ map showPair $ solve (read n) orient

import Data.Either

main=readFile"input.txt">>=writeFile"output.txt".parseOutput.solve.map f.zip[1..].(!!1).lines
f(i,'L')=Left i
f(i,'R')=Right i

parseOutput (l:r:lrs) = shows l" "++shows r"\n"++parseOutput lrs
parseOutput _ = []

solve lrs = merge (lefts lrs) (rights lrs)

merge [l] [r1,r2,r3]
  | l < r1 = [l,r2,r1,r3]
  | l < r2 = [l,r3,r1,r2]
  | l < r3 = [l,r1,r2,r3]
  | otherwise = [l,r2,r1,r3]

merge [l1,l2,l3] [r]
  | r < l1 = [l2,r,l1,l3]
  | r < l2 = [l3,r,l1,l2]
  | r < l3 = [l1,r,l2,l3]
  | otherwise = [l2,r,l1,l3]

merge [l1,l2] [r1,r2]
  | l2 < r1  || r2 < l1 = [l1,r1,l2,r2]
  | r2-r1==1 || l2-l1==1 = [l1,r2,l2,r1]
  | otherwise = [l1,l2,r1,r2]

merge [l1,l2,l3,l4] [] = [l1,l3,l2,l4]

merge [] [r1,r2,r3,r4] = [r1,r3,r2,r4]

merge (l1:l2:ls) (r1:r2:rs)
  | l2 < r1  || r2 < l1  = l1:r1: merge (l2:ls) (r2:rs)
  | r2-r1==1 || l2-l1==1 = l1:r2: merge (l2:ls) (r1:rs)
  | otherwise            = r1:r2: merge (l1:l2:ls) rs

merge [l] (r1:r2:r3:rs) = r1:r3:merge [l] (r2:rs)
merge (l1:l2:l3:ls) [r] = l1:l3:merge (l2:ls) [r]
merge [] (r1:r2:r3:r4:rs) = r1:r3:merge [] (r2:r4:rs)
merge (l1:l2:l3:l4:ls) [] = l1:l3:merge (l2:l4:ls) []


You work in the quality control department of technical support for a large company. Your job is to make sure all client issues have been resolved.Today you need to check a copy of a dialog between a client and a technical support manager. According to the rules of work, each message of the client must be followed by one or several messages, which are the answer of a support manager. However, sometimes clients ask questions so quickly that some of the manager's answers to old questions appear after the client has asked some new questions.Due to the privacy policy, the full text of messages is not available to you, only the order of messages is visible, as well as the type of each message: a customer question or a response from the technical support manager. It is guaranteed that the dialog begins with the question of the client.You have to determine, if this dialog may correspond to the rules of work described above, or the rules are certainly breached.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 500$$$). Description of the test cases follows. The first line of each test case contains one integer $$$n$$$ ($$$1 \le n \le 100$$$) — the total number of messages in the dialog. The second line of each test case consists of $$$n$$$ characters "Q" and "A", describing types of messages in the dialog in chronological order. Character "Q" denotes the message with client question, and character "A" — the message with technical support manager answer. It is guaranteed that the first character in the line equals to "Q".

For each test case print "Yes" (without quotes) if dialog may correspond to the rules of work, or "No" (without quotes) otherwise.

5

4

QQAA

4

QQAQ

3

QAA

1

Q

14

QAQQAQAAQQQAAA

NoteIn the first test case the two questions from the client are followed with two specialist's answers. So this dialog may correspond to the rules of work.In the second test case one of the first two questions was not answered.In the third test case the technical support manager sent two messaged as the answer to the only message of the client.

module Main where

import Control.Monad
import Data.Foldable

processCase _ = do
  getLine
  s <- getLine
  let r = foldl' (\r -> (r +) . (\b -> if b then 1 else -fromEnum (r /= 0)) . (== 'Q')) 0 s :: Int
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad
import Data.Foldable

processCase _ = do
  getLine
  s <- getLine
  let r = foldl' (\r -> (r +) . (\b -> if b then 1 else if r /= 0 then -1 else 0) . (== 'Q')) 0 s :: Int
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad

processCase _ = do
  getLine
  s <- getLine
  let r = foldl (\r -> (r +) . (\b -> if b then 1 else if r /= 0 then -1 else 0) . (== 'Q')) 0 s :: Int
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad

processCase _ = do
  getLine
  s <- getLine
  let r = foldl (\r -> (r +) . (\b -> if b then 1 else -fromEnum (r /= 0)) . (== 'Q')) 0 s
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad

processCase _ = do
  getLine
  s <- getLine
  let r = foldl (\r -> (r +) . (\b -> if b then 1 else -1) . (== 'Q')) 0 s
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad

processCase _ = do
  l <- readLn :: IO Int
  s <- getLine
  let r = foldl (\r -> (r +) . (\b -> if b then 1 else -1) . (== 'Q')) 0 s
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase

module Main where

import Control.Monad

processCase _ = do
  l <- readLn :: IO Int
  s <- getLine
  let r = foldl (\r -> fromEnum . (== 'Q')) 0 s
  putStrLn $ if r > 0 then "No" else "Yes"

main :: IO ()
main = do
  n <- readLn :: IO Int
  forM_ [1..n] processCase


We call a string good, if after merging all the consecutive equal characters, the resulting string is palindrome. For example, "aabba" is good, because after the merging step it will become "aba".Given a string, you have to find two values:  the number of good substrings of even length;  the number of good substrings of odd length.

The first line of the input contains a single string of length n (1 ≤ n ≤ 105). Each character of the string will be either 'a' or 'b'.

Print two space-separated integers: the number of good substrings of even length and the number of good substrings of odd length.

NoteIn example 1, there are three good substrings ("b", "b", and "bb"). One of them has even length and two of them have odd length.In example 2, there are six good substrings (i.e. "b", "a", "a", "b", "aa", "baab"). Two of them have even length and four of them have odd length.In example 3, there are seven good substrings (i.e. "b", "a", "b", "b", "bb", "bab", "babb"). Two of them have even length and five of them have odd length.DefinitionsA substring s[l, r] (1 ≤ l ≤ r ≤ n) of string s = s1s2... sn is string slsl + 1... sr.A string s = s1s2... sn is a palindrome if it is equal to string snsn - 1... s1.

f _ [] = 0
f c (x:xs) = g c xs + (if c == x then 1 else 0)

g _ [] = 0
g c (x:xs) = f c xs

h0 c s = (f c s) * (g c s)
h1 c s = (f c s * (f c s + 1) + g c s * (g c s + 1)) `div` 2

main = do
  s <- getLine
  putStrLn $ show (h0 'a' s + h0 'b' s) ++ " " ++ show (h1 'a' s + h1 'b' s)

{-# OPTIONS_GHC -O2 #-}
import Data.Maybe
import Data.Char
import Data.List
import Data.Int
import Data.Bits
import Data.IORef
import Data.Array.IO
import Control.Monad
import Control.Applicative
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map              as Map
import qualified Data.Set              as Set
import Text.Printf

pairsum (a,b) (c,d) = (a+c, b+d)

solve :: String -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> (Int64, Int64)
solve [] _ _ _ _ _ = (0, 0)
solve (s:str) aEven aOdd bEven bOdd cpos
  | s == 'a' = pairsum resA (solve str aEven1 aOdd1 bEven1 bOdd1 (1 - cpos))
  | s == 'b' = pairsum resB (solve str aEven1 aOdd1 bEven1 bOdd1 (1 - cpos))
  where resA
          | cpos == 0 = (aOdd1, aEven1)
          | cpos == 1 = (aEven1, aOdd1)
        resB
          | cpos == 0 = (bOdd1, bEven1)
          | cpos == 1 = (bEven1, bOdd1)
        aEven1 = if s == 'a' && cpos == 0 then aEven + 1 else aEven
        aOdd1  = if s == 'a' && cpos == 1 then aOdd  + 1 else aOdd
        bEven1 = if s == 'b' && cpos == 0 then bEven + 1 else bEven
        bOdd1  = if s == 'b' && cpos == 1 then bOdd  + 1 else bOdd

main = do
  str <- getLine
  let res = solve str 0 0 0 0 0
  putStr (show (fst res))
  putStrLn $ " " ++ (show (snd res))


You are given $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$. Is it possible to arrange them on a circle so that each number is strictly greater than both its neighbors or strictly smaller than both its neighbors?In other words, check if there exists a rearrangement $$$b_1, b_2, \ldots, b_n$$$ of the integers $$$a_1, a_2, \ldots, a_n$$$ such that for each $$$i$$$ from $$$1$$$ to $$$n$$$ at least one of the following conditions holds: $$$b_{i-1} < b_i > b_{i+1}$$$ $$$b_{i-1} > b_i < b_{i+1}$$$To make sense of the previous formulas for $$$i=1$$$ and $$$i=n$$$, one shall define $$$b_0=b_n$$$ and $$$b_{n+1}=b_1$$$.

The first line of the input contains a single integer $$$t$$$ ($$$1 \le t \le 3\cdot 10^4$$$)  — the number of test cases. The description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$3 \le n \le 10^5$$$)  — the number of integers. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$0 \le a_i \le 10^9$$$). The sum of $$$n$$$ over all test cases doesn't exceed $$$2\cdot 10^5$$$.

For each test case, if it is not possible to arrange the numbers on the circle satisfying the conditions from the statement, output $$$\texttt{NO}$$$. You can output each letter in any case. Otherwise, output $$$\texttt{YES}$$$. In the second line, output $$$n$$$ integers $$$b_1, b_2, \ldots, b_n$$$, which are a rearrangement of $$$a_1, a_2, \ldots, a_n$$$ and satisfy the conditions from the statement. If there are multiple valid ways to arrange the numbers, you can output any of them.

NoteIt can be shown that there are no valid arrangements for the first and the third test cases.In the second test case, the arrangement $$$[1, 8, 4, 9]$$$ works. In this arrangement, $$$1$$$ and $$$4$$$ are both smaller than their neighbors, and $$$8, 9$$$ are larger.In the fourth test case, the arrangement $$$[1, 11, 1, 111, 1, 1111]$$$ works. In this arrangement, the three elements equal to $$$1$$$ are smaller than their neighbors, while all other elements are larger than their neighbors.

{-# LANGUAGE Strict #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -funbox-strict-fields -O3 #-}

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if checkAns cs then cs else []
-- solveEven n as = if check b1s b2s && checkAns cs then cs else []
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

checkAns :: [Int] -> Bool
checkAns (a1:a2:a3:as) = (a1-a2)*(a3-a2) > 0 && checkAns (a2:a3:as)
checkAns _ = True

check :: [Int] -> [Int] -> Bool
check =  (and .) . zipWith (/=)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

{-# LANGUAGE Strict #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if checkAns cs then cs else []
-- solveEven n as = if check b1s b2s && checkAns cs then cs else []
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

checkAns :: [Int] -> Bool
checkAns (a1:a2:a3:as) = (a1-a2)*(a3-a2) > 0 && checkAns (a2:a3:as)
checkAns _ = True

check :: [Int] -> [Int] -> Bool
check =  (and .) . zipWith (/=)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if checkAns cs then cs else []
-- solveEven n as = if check b1s b2s && checkAns cs then cs else []
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

checkAns :: [Int] -> Bool
checkAns (a1:a2:a3:as) = (a1-a2)*(a3-a2) > 0 && checkAns (a2:a3:as)
checkAns _ = True

check :: [Int] -> [Int] -> Bool
check =  (and .) . zipWith (/=)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s && checkAns cs then cs else []
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

checkAns :: [Int] -> Bool
checkAns (a1:a2:a3:as) = (a1-a2)*(a3-a2) > 0 && checkAns (a2:a3:as)
checkAns _ = True

check :: [Int] -> [Int] -> Bool
check =  (and .) . zipWith (/=)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

{-# LANGUAGE Strict #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))
import Data.Int (Int32)

readInt :: B8.ByteString -> Int32
readInt =  fromIntegral . fst . fromJust . B8.readInt

readInts :: B8.ByteString -> [Int32]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int32
  as <- readInts <$> B8.getLine :: IO [Int32]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int32] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int32 -> [Int32] -> [Int32]
solveEven n as = if checkAns cs then cs else []
-- solveEven n as = if check b1s b2s && checkAns cs then cs else []
  where
    m = fromIntegral n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

checkAns :: [Int32] -> Bool
checkAns (a1:a2:a3:as) = (a1-a2)*(a3-a2) > 0 && checkAns (a2:a3:as)
checkAns _ = True

check :: [Int] -> [Int] -> Bool
check =  (and .) . zipWith (/=)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if True then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check as bs =  or $ zipWith (==) as bs

-- check :: [Int] -> [Int] -> Bool
-- check =  (or .) . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
-- output [] = noLit
output [] = B8.unwords $ yesLit : map (B8.pack . show) [1,2]
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check as bs =  or $ zipWith (==) as bs

-- check :: [Int] -> [Int] -> Bool
-- check =  (or .) . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = yesLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check as bs =  or $ zipWith (==) as bs

-- check :: [Int] -> [Int] -> Bool
-- check =  (or .) . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords $ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check as bs =  or $ zipWith (==) as bs

-- check :: [Int] -> [Int] -> Bool
-- check =  (or .) . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

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

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)
import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  t <- readLn :: IO Int
  replicateM_ t run

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  B8.putStrLn . output $ if even n then solveEven n as else []

noLit :: B8.ByteString
yesLit :: B8.ByteString
noLit  = B8.pack "NO"
yesLit = B8.pack "YES\n"

output :: [Int] -> B8.ByteString
output [] = noLit
output as = B8.unwords$ yesLit : map (B8.pack . show) as

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m bs
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check =  (.) or . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as

{-# LANGUAGE Strict  #-}

import Control.Monad (replicateM_)
import Data.List (sort)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (fromJust)

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

readInts :: B8.ByteString -> [Int]
readInts = map readInt . B8.words

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

run :: IO ()
run = do
  n <- readInt <$> B8.getLine :: IO Int
  as <- readInts <$> B8.getLine :: IO [Int]
  -- n <- readLn :: IO Int
  -- as <- map read . words <$> getLine :: IO [Int]
  putStrLn . output $ if even n then solveEven n as else []

output :: [Int] -> String
output [] = "NO"
output as = "YES\n" ++ unwords (map show as)

solveEven :: Int -> [Int] -> [Int]
solveEven n as = if check b1s b2s then [] else cs
  where
    m = n `div` 2
    bs = sort as
    (b1s, b2s) = splitAt m as
    cs = interleave b1s b2s

check :: [Int] -> [Int] -> Bool
check =  (.) or . zipWith (==)

interleave :: [a] -> [a] -> [a]
interleave (a:as) (b:bs) = a : b : interleave as bs
interleave [] bs = bs
interleave as [] = as


You are given an array $$$a_1, a_2, \dots, a_n$$$ where all $$$a_i$$$ are integers and greater than $$$0$$$. In one operation, you can choose two different indices $$$i$$$ and $$$j$$$ ($$$1 \le i, j \le n$$$). If $$$gcd(a_i, a_j)$$$ is equal to the minimum element of the whole array $$$a$$$, you can swap $$$a_i$$$ and $$$a_j$$$. $$$gcd(x, y)$$$ denotes the greatest common divisor (GCD) of integers $$$x$$$ and $$$y$$$. Now you'd like to make $$$a$$$ non-decreasing using the operation any number of times (possibly zero). Determine if you can do this. An array $$$a$$$ is non-decreasing if and only if $$$a_1 \le a_2 \le \ldots \le a_n$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases.  The first line of each test case contains one integer $$$n$$$ ($$$1 \le n \le 10^5$$$) — the length of array $$$a$$$.  The second line of each test case contains $$$n$$$ positive integers $$$a_1, a_2, \ldots a_n$$$ ($$$1 \le a_i \le 10^9$$$) — the array itself.  It is guaranteed that the sum of $$$n$$$ over all test cases doesn't exceed $$$10^5$$$.

For each test case, output "YES" if it is possible to make the array $$$a$$$ non-decreasing using the described operation, or "NO" if it is impossible to do so.

Note In the first and third sample, the array is already non-decreasing. In the second sample, we can swap $$$a_1$$$ and $$$a_3$$$ first, and swap $$$a_1$$$ and $$$a_5$$$ second to make the array non-decreasing. In the forth sample, we cannot the array non-decreasing using the operation.

import Control.Monad -- for replicateM_
import Data.List -- for sort

solve :: [Int] -> String
solve xs = if error == 0 then "YES" else "NO"
    where
        sorted = sort xs
        error = length $ filter (\(x, y) -> x /= y && mod x min_element /= 0) (zip xs sorted)
        min_element = minimum xs

deal :: IO()
deal = do
    getLine
    a <- map read . words <$> getLine
    putStrLn $ solve a

main :: IO()
main = getLine >>= flip replicateM_ deal . read

import Control.Monad
import Control.Monad.ST
import Data.Array
import qualified Data.Array.ST.Safe as S
import qualified Data.Array.Unboxed as U
import Data.Foldable
import Data.List

testCase :: IO a -> IO ()
testCase f = do
  t <- read <$> getLine
  replicateM_ t f

main = testCase $ do
  _ <- getLine
  v <- map read . words <$> getLine
  let m = minimum v
  let t = sort v
  if t == v || (foldl (\flag (a, b) -> flag && (a == b || b `mod` m == 0)) True $ zip t v)
    then putStrLn "Yes"
    else putStrLn "No"

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

solve :: [Int] -> String
solve a = let
  asor = sort a
  q = head asor
  fun x y = x == y || rem x q == 0
  in  if  and $ zipWith fun a asor  then  "YES"  else  "NO"

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    _nStr <- getLine
    getLine >>= putStrLn . solve . map read . words

module Main where

import Control.Monad
import Data.List

readWords :: Read a => IO [a]
readWords =
  fmap read . words <$> getLine

isSorted :: Ord a => [a] -> Bool
isSorted xs =
  GT `notElem` zipWith compare xs (tail xs)

taskSort :: [Int] -> [Int]
taskSort xs =
  let m = minimum xs
      indexed = zip [0..] xs
      isDivisable (_, x) = x `mod` m == 0
      (divisable, notDivisable) = partition isDivisable indexed
      (divIndices, divValues) = unzip divisable
      sortedDivisable = zip (sort divIndices) (sort divValues)
      -- sortedDivisable = uncurry zip . fmap sort . unzip $ divisable
      sortedAll = sort $ notDivisable ++ sortedDivisable
      (_, result) = unzip sortedAll
   in result

solve :: [Int] -> String
solve = asYesNo . isSorted . taskSort

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

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
    getLine
    xs <- readWords
    putStrLn $ solve xs

import Control.Monad -- for replicateM_
import Data.List -- for sort

solve :: [Int] -> String
solve xs = if error == 0 then "YES" else "NO"
    where
        sorted = sort xs
        error = length $ filter (\(x, y) -> x /= y && gcd x min_element == 1) (zip xs sorted)
        min_element = minimum xs

deal :: IO()
deal = do
    getLine
    a <- map read . words <$> getLine
    putStrLn $ solve a

main :: IO()
main = getLine >>= flip replicateM_ deal . read

module Main where

import Control.Monad
import Data.List

readWords :: Read a => IO [a]
readWords =
  fmap read . words <$> getLine

isSorted :: Ord a => [a] -> Bool
isSorted xs =
  GT `notElem` zipWith compare xs (tail xs)

taskSort :: [Int] -> [Int]
taskSort xs =
  let m = minimum xs
      indexed = zip [0..] xs
      isDivisable (_, x) = x `mod` m == 0
      (divisable, notDivisable) = partition isDivisable indexed
      (divIndices, divValues) = unzip divisable
      sortedDivisable = zip (sort divIndices) (sort divValues)
      -- sortedDivisable = uncurry zip . fmap sort . unzip $ divisable
      sortedAll = sort $ notDivisable ++ sortedDivisable
      (_, result) = unzip sortedAll
   in result

solve :: [Int] -> String
solve = asYesNo . isSorted . taskSort

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

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
    getLine
    xs <- readWords
    print $ solve xs


According to rules of the Berland fashion, a jacket should be fastened by all the buttons except only one, but not necessarily it should be the last one. Also if the jacket has only one button, it should be fastened, so the jacket will not swinging open.You are given a jacket with n buttons. Determine if it is fastened in a right way.

The first line contains integer n (1 ≤ n ≤ 1000) — the number of buttons on the jacket. The second line contains n integers ai (0 ≤ ai ≤ 1). The number ai = 0 if the i-th button is not fastened. Otherwise ai = 1.

In the only line print the word "YES" if the jacket is fastened in a right way. Otherwise print the word "NO".

getInt = read `fmap` getLine :: IO Int
getInts = (map read . words) `fmap` getLine :: IO [Int]

main = do
    n <- getInt
    xs <- getInts
    if n == 1
    then if xs == [1] then putStrLn "YES" else putStrLn "NO"
    else if (filter (==0) xs) == [0] then putStrLn "YES" else putStrLn "NO"

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

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

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

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

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

msg = putStrLn . which "YES" "NO"

main = do
	getLine
	a <- getList
	if length a == 1
		then msg $ head a == 1
		else msg $ ( == length a - 1 ) $ length $ filter ( == 1 ) a

import Data.Functor

main :: IO()
main = do
  n <- readLn :: IO Int
  s <- map read . words <$> getLine
  putStrLn $ solve n s

solve :: Int -> [Int] -> String
solve n r
  | n == 1 && s == 1 = "YES"
  | n > 1 && n == s + 1 = "YES"
  | otherwise = "NO"
  where s = sum r

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    putStrLn (if sum m == n - fromEnum (n > 1) then "YES" else "NO")

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    putStrLn (
      if (n == 1 && head m == 1) || (n /= 1 && sum m == n - 1)
        then "YES" else "NO"
      )

main :: IO ()
main = do
    _ <- getLine
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    putStrLn (if sum m == length m - fromEnum (length m > 1) then "YES" else "NO")

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.State
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.IO
-- import Debug.Trace

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

main = do
  n <- readLn
  xs <- getInts

  let f = if n == 1 then xs == [1] else length (filter (== 0) xs) == 1

  putStrLn $ if f then "YES" else "NO"

main = interact $ f . map read . words
f (a:b) = if max 1 (a - 1) == sum b then "YES\n" else "NO\n"

main = getContents >>= putStrLn . solve . map read . tail . words

solve [0] = "NO"
solve [1] = "YES"
solve ls = if sum ls == length ls - 1 then "YES" else "NO"

module Main where
  import Data.List
  import Control.Monad
  import Data.Array
  import qualified Data.Set as S

  toArray :: [a] -> Array Int a
  toArray xs =
    let ls = length xs - 1
        in array (0, ls) $ zip [0..ls] xs

  readInt :: String -> Int
  readInt s = read s :: Int

  readMultilineInput :: Int -> (String -> IO a) -> IO [a]
  readMultilineInput n transformer = replicateM n (getLine >>= transformer)

  elemSet :: (Ord a) => a -> S.Set a -> Bool
  elemSet elem sets =
    let found = elem `S.lookupIndex` sets
        in toBool found
        where
          toBool :: Maybe Int -> Bool
          toBool (Just _) = True
          toBool Nothing = False

  -- converting list to Set
  -- let mySet = S.fromList myList
  solve :: [Int] -> String
  solve [1] = "YES"
  solve [0] = "NO"
  solve xs =
    case (==1) $ length $ filter (==0) xs of
      True -> "YES"
      False -> "NO"

  main :: IO()
  main = do
    n <- getLine >>= return . readInt
    xs <- getLine >>= return . (map readInt) . words
    putStrLn $ solve xs

main = getContents >>= putStrLn . (\(n:l) -> if (n - 1) == (sum $ take n l) && n > 1 || n == 1 && head l == 1 then "YES" else "NO") . map read . words

main = interact $ solve . map read . words
solve (n:r)
 | n == 1 && s == 1 = "YES"
 | n > 1 && n == s + 1 = "YES"
 | otherwise = "NO"
 where s = sum . take n $ r

check jacket = if length jacket == 1 then jacket !! 0 == 1 else sum [1 | x <- jacket, x == 0] == 1

output jacket = putStrLn ( if check jacket then "YES" else "NO" )

main = do
	n <- getLine
	raw_jacket <- getLine
	let jacket = [ read x :: Int | x <- ( words raw_jacket ) ]
	output jacket

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

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

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

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

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

main = getLine >> getList >>= putStrLn . which "YES" "NO" . ( == 1 ) . length . filter ( == 0 )

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

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

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

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

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

main = do
	getLine
	a <- getList
	putStrLn $ which "YES" "NO" $ ( == length a - 1 ) $ length $ filter ( == 1 ) a

a :: Int ->[Int] -> Bool
a r [] = r == 1
a r (x:xs) = a (r + 1 - x) xs

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    if n == 1 then
      if head m == 0 then
        print "NO"
        else
          print "YES"
      else
        if a 0 m then
          print "YES"
          else
            print "NO"

a :: Int -> [Int] -> Bool
a r [] = r == 1
a r (x:xs) = a (r + 1 - x) xs

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    let s = sum m
    if n == 1 then
      if head m == 0 then
        print "NO"
        else
          print "YES"
      else
        if sum m == n - 1 then
            putStrLn "YES"
        else
            putStrLn "NO"

a :: Int -> [Int] -> Bool
a r [] = r == 1
a r (x:xs) = a (r + 1 - x) xs

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    if n == 1 then
      if head m == 0 then
        print "NO"
        else
          print "YES"
      else
        if a 0 m then
          print "YES"
          else
            print "NO"

a :: Int -> [Int] -> Bool
a r [] = r == 1
a r (x:xs) = a (r + 1 - x) xs

main :: IO ()
main = do
    n_str <- getLine
    let n = read n_str :: Int
    m_str <- getLine
    let m = map read $ words m_str :: [Int]
    let s = sum m
    if n == 1 then
      if head m == 0 then
        print "NO"
        else
          print "YES"
      else
        if sum m == n - 1 then
            print "YES"
        else
            print "NO"

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.State
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.IO
-- import Debug.Trace

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

main = do
  n <- readLn
  xs <- getInts

  let f = n == 1 && xs == [1] || length (filter (== 0) xs) == 1

  putStrLn $ if f then "YES" else "NO"

main = getContents >>= putStrLn . show . (\(n:l) -> if (n - 1) == (sum $ take n l) then "YES" else "NO") . map read . words

main = getContents >>= putStrLn . (\(n:l) -> if 1 == n || (n - 1) == (sum $ take n l) then "YES" else "NO") . map read . words

main = getContents >>= putStrLn . (\(n:l) -> if (n - 1) == (sum $ take n l) then "YES" else "NO") . map read . words


You know that the Martians use a number system with base k. Digit b (0 ≤ b < k) is considered lucky, as the first contact between the Martians and the Earthlings occurred in year b (by Martian chronology).A digital root d(x) of number x is a number that consists of a single digit, resulting after cascading summing of all digits of number x. Word "cascading" means that if the first summing gives us a number that consists of several digits, then we sum up all digits again, and again, until we get a one digit number.For example, d(35047) = d((3 + 5 + 0 + 4)7) = d(157) = d((1 + 5)7) = d(67) = 67. In this sample the calculations are performed in the 7-base notation.If a number's digital root equals b, the Martians also call this number lucky.You have string s, which consists of n digits in the k-base notation system. Your task is to find, how many distinct substrings of the given string are lucky numbers. Leading zeroes are permitted in the numbers.Note that substring s[i... j] of the string s = a1a2... an (1 ≤ i ≤ j ≤ n) is the string aiai + 1... aj. Two substrings s[i1... j1] and s[i2... j2] of the string s are different if either i1 ≠ i2 or j1 ≠ j2.

The first line contains three integers k, b and n (2 ≤ k ≤ 109, 0 ≤ b < k, 1 ≤ n ≤ 105). The second line contains string s as a sequence of n integers, representing digits in the k-base notation: the i-th integer equals ai (0 ≤ ai < k) — the i-th digit of string s. The numbers in the lines are space-separated.

Print a single integer — the number of substrings that are lucky numbers. 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.

NoteIn the first sample the following substrings have the sought digital root: s[1... 2] = "3 2", s[1... 3] = "3 2 0", s[3... 4] = "0 5", s[4... 4] = "5" and s[2... 6] = "2 0 5 6 1".

import Data.List
import Data.Maybe
import qualified Data.IntMap as M
import qualified Data.ByteString.Char8 as C

gao b 0 a = sum [i * (i + 1) `div` 2| i <- map toInteger c]
  where
    c = map length $ filter ((==0) . head) $ group a

gao b d a = c - if d == b - 1 then gao b 0 a else 0
  where
    (c, _, _) = foldl' go (0, 0, M.singleton 0 1) a
    go (x, s, m) t = (x', s', m')
      where
        t' = (s' - d) `mod` (b - 1)
        x' = x + toInteger (M.findWithDefault 0 t' m)
        s' = (s + t) `mod` (b - 1)
        m' = M.insertWith (+) s' 1 m

main = do
  [k, b, n] <- getArray
  a <- getArray
  print $ gao k b a
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

import Data.List
import Data.Maybe
import qualified Data.IntMap as M
import qualified Data.ByteString.Char8 as C

gao b 0 a = sum [i * (i + 1) `div` 2| i <- map toInteger c]
  where
    c = map length $ filter ((==0) . head) $ group a

gao b d a = c - if d == b - 1 then z else 0
  where
    z = toInteger $ length $ filter (==0) a
    (c, _, _) = foldl' go (0, 0, M.singleton 0 1) a
    go (x, s, m) t = (x', s', m')
      where
        t' = (s' - d) `mod` (b - 1)
        x' = x + toInteger (M.findWithDefault 0 t' m)
        s' = (s + t) `mod` (b - 1)
        m' = M.insertWith (+) s' 1 m

main = do
  [k, b, n] <- getArray
  a <- getArray
  print $ gao k b a
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine


People do many crazy things to stand out in a crowd. Some of them dance, some learn by heart rules of Russian language, some try to become an outstanding competitive programmers, while others collect funny math objects.Alis is among these collectors. Right now she wants to get one of k-special tables. In case you forget, the table n × n is called k-special if the following three conditions are satisfied:  every integer from 1 to n2 appears in the table exactly once;  in each row numbers are situated in increasing order;  the sum of numbers in the k-th column is maximum possible. Your goal is to help Alice and find at least one k-special table of size n × n. Both rows and columns are numbered from 1 to n, with rows numbered from top to bottom and columns numbered from left to right.

The first line of the input contains two integers n and k (1 ≤ n ≤ 500, 1 ≤ k ≤ n) — the size of the table Alice is looking for and the column that should have maximum possible sum.

First print the sum of the integers in the k-th column of the required table. Next n lines should contain the description of the table itself: first line should contains n elements of the first row, second line should contain n elements of the second row and so on. If there are multiple suitable table, you are allowed to print any.

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

import Control.Applicative
import Control.Monad
import Control.Monad.ST.Safe
import Control.Monad.State
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.IO
-- import Debug.Trace

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

main = do
  [n, k] <- getInts

  let
    (ls, rs) = splitAt (n*(k-1)) [1..n*n]
    ls' = if k == 1 then replicate n [] else ch (k-1) ls
    rs' = ch (n-k+1) rs
    r = zipWith (++) ls' rs'

    ch k = unfoldr (\s -> if null s then Nothing else Just $ splitAt k s)

  print $ sum $ transpose r !! (k-1)
  putStr $ unlines $ map (unwords . map show) r

{-# LANGUAGE TupleSections, MultiParamTypeClasses, ExistentialQuantification,
             RankNTypes, FlexibleContexts, DeriveFunctor #-}

import Control.Monad
import Control.Applicative
--import Control.Lens
--import Control.Zipper
import Control.Arrow
import qualified Data.Map as M
--import qualified Data.Vector as V
import qualified Data.Set as S
import Data.List
--import Debug.Trace
--import Control.Comonad
import Data.Monoid
--import Data.Functor.Foldable
--import Test.QuickCheck
import Data.Tree
--import Data.Machine
--import Data.Traversable
--import Data.Distributive
--import Linear
import Control.Monad.Cont

main = do
  [n, k] <- fmap (map read . words) getLine
  pprint $ solve n (k-1)

pprint :: ([[Int]], Int) -> IO ()
pprint (l, x) = print x >> mapM_ putStrLn rest
    where
      rest = map g l
      g x = x >>= \a -> show a ++ " "

solve :: Int -> Int -> ([[Int]], Int)
solve n k = (take n $ zipWith (++) pref suff, sumKs)
    where
      sumKs = sum $ map head (take n suff)
      pref = chunks k l
      suff = chunks (n-k) l'
      (l, l') = splitAt (k*n) [1..n*n]

chunks _ [] = (repeat [])
chunks x l = b : chunks x a
    where
      (b, a) = splitAt x l

{-
instructions go here...
-}

module Main where

solve :: Int -> Int -> [[Int]]
solve n k = take n $ solve' [1 ..] [n*n, n*n-1 ..]
  where solve' :: [Int] -> [Int] -> [[Int]]
        solve' lower upper = row : solve' lower' upper'
          where lower' = drop (k - 1) lower
                upper' = drop (n - k + 1) upper
                row = take (k - 1) lower ++ (reverse $ take (n - k + 1) upper)
{-
solve :: Int -> Int -> [[Int]]
solve n k = take n $ solve' 1 (n*n)
  where solve' :: Int -> Int -> [[Int]]
        solve' lower upper = row : solve' lower' upper'
          where lower' = lower + (k - 1)
                upper' = upper - (n - k - 1)
                row = [lower .. (lower' - 1)] ++ [(upper' + 1) .. upper]
-}

kTableSum :: [[Int]] -> Int -> Int
kTableSum kTable k = sum $ map (!! (k - 1)) kTable

kTableToStr :: [[Int]] -> String
kTableToStr rows = unlines $ map (unwords . numsToStrings) rows
  where numsToStrings = map show :: [Int] -> [String]

main :: IO ()
main = do
  line <- getLine
  let [n, k] = map read (words line) :: [Int]
      ktable = solve n k
  putStrLn $ show $ kTableSum ktable k
  putStrLn $ kTableToStr ktable


You are given two integers $$$a$$$ and $$$b$$$, and $$$q$$$ queries. The $$$i$$$-th query consists of two numbers $$$l_i$$$ and $$$r_i$$$, and the answer to it is the number of integers $$$x$$$ such that $$$l_i \le x \le r_i$$$, and $$$((x \bmod a) \bmod b) \ne ((x \bmod b) \bmod a)$$$. Calculate the answer for each query.Recall that $$$y \bmod z$$$ is the remainder of the division of $$$y$$$ by $$$z$$$. For example, $$$5 \bmod 3 = 2$$$, $$$7 \bmod 8 = 7$$$, $$$9 \bmod 4 = 1$$$, $$$9 \bmod 9 = 0$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. Then the test cases follow. The first line of each test case contains three integers $$$a$$$, $$$b$$$ and $$$q$$$ ($$$1 \le a, b \le 200$$$; $$$1 \le q \le 500$$$). Then $$$q$$$ lines follow, each containing two integers $$$l_i$$$ and $$$r_i$$$ ($$$1 \le l_i \le r_i \le 10^{18}$$$) for the corresponding query.

For each test case, print $$$q$$$ integers — the answers to the queries of this test case in the order they appear.

import qualified Data.List as L
import qualified Data.Array as A

f a b x = (x `mod` a) `mod` b

solve_one cycle acc xx = q*(acc A.! (cycle)) + (acc A.! r)
  where x = xx+0
        q = x `div` cycle
        r = x `mod` cycle

solve_query :: Integer -> A.Array Integer Integer -> [Integer] -> Integer
solve_query cycle acc [ll,rr] = (solve_one cycle acc (rr+1)) - (solve_one cycle acc ll)

solve :: (Integer,Integer,Integer,[[Integer]]) -> [Integer]
solve (a,b,q,queries) = map (solve_query cycle (A.listArray (0,cycle) acc)) queries
   where cycle = a*b
         numbers = init [0..cycle]
         mods_a = map (f a b) numbers
         mods_b = map (f b a) numbers
         is_diff = zipWith (\q w -> if q == w then 0 else 1) mods_a mods_b
         acc = scanl (+) 0 is_diff

parse_other :: [[Integer]] -> [(Integer,Integer,Integer,[[Integer]])]
parse_other ([a,b,q]:ss) = (a,b,q,take (fromInteger q) ss):(parse_other $ drop (fromInteger q) ss)
parse_other [] = []
parse_input ([t]:other) = parse_other other

main = interact $ unlines . map (unwords . map show) . map solve . parse_input . map (map read) . map words . lines

import Control.Monad

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

routine :: IO ()
routine = do
  [a1,b1,q] <- (map read.words) <$> getLine
  queries <- replicateM q $ (map read.words) <$> getLine
  let (a,b) = (fromIntegral $ min a1 b1, fromIntegral $ max a1 b1)
    in putStrLn.unwords.map show $ map (solveQuery (a,b)) queries

upToN :: (Integer,Integer) -> Integer -> Integer
upToN (a,b) n = d*b + min m b
    where
      period = lcm a b
      (d,m) = divMod (n+1) period

solveQuery :: (Integer,Integer) -> [Integer] -> Integer
solveQuery (a,b) [l,r] = (r - f r) - ((l-1) - f (l-1))
  where
    f = upToN (a,b)

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

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

getIntegers :: IO [Integer]
getIntegers = map (fst . fromJust . C.readInteger) . C.words <$> C.getLine

main :: IO ()
main = do
  tt <- parseInt <$> C.getLine
  replicateM_ tt $ do
    [a, b, q] <- getIntegers
    let c = a * b `div` gcd a b
        d = max a b
        f n = (n `div` c) * (c - d) + max 0 (n `mod` c - d + 1)
    as <- replicateM (fromIntegral q) $ do
      [l, r] <- getIntegers
      return $ f r - f (l - 1)
    putStrLn $ unwords $ map show as

import qualified Data.List as L
import qualified Data.Array as V

f a b x = (x `mod` a) `mod` b

solve_query :: Integer -> Integer -> Integer -> V.Array Integer Integer -> [Integer] -> Integer
solve_query a b cycle acc [l,rr] = (q_r-q_l) * (acc V.! (cycle-1)) + (acc V.! (fromInteger (r `mod` cycle))) - (acc V.! (fromInteger (l`mod` cycle)))
  where r = rr+1
        q_l = l `div` cycle
        q_r = r `div` cycle

solve :: (Integer,Integer,Integer,[[Integer]]) -> [Integer]
solve (a,b,q,queries) = map (solve_query a b cycle (V.listArray (0,cycle-1) acc)) queries
   where cycle = a*b
         numbers = init [0..cycle]
         mods_a = map (f a b) numbers
         mods_b = map (f b a) numbers
         is_diff = zipWith (\q w -> if q == w then 0 else 1) mods_a mods_b
         acc = scanl (+) 0 is_diff

parse_other :: [[Integer]] -> [(Integer,Integer,Integer,[[Integer]])]
parse_other ([a,b,q]:ss) = (a,b,q,take (fromInteger q) ss):(parse_other $ drop (fromInteger q) ss)
parse_other [] = []
parse_input ([t]:other) = parse_other other

main = interact $ unlines . map (unwords . map show) . map solve . parse_input . map (map read) . map words . lines

import qualified Data.List as L
import qualified Data.Array as A

f a b x = (x `mod` a) `mod` b

solve_one cycle acc xx = q*(acc A.! (cycle)) + (acc A.! r)
  where x = xx+1
        q = x `div` cycle
        r = x `mod` cycle

solve_query :: Integer -> A.Array Integer Integer -> [Integer] -> Integer
solve_query cycle acc [ll,rr] = (solve_one cycle acc (rr+1)) - (solve_one cycle acc ll)

solve :: (Integer,Integer,Integer,[[Integer]]) -> [Integer]
solve (a,b,q,queries) = map (solve_query cycle (A.listArray (0,cycle) acc)) queries
   where cycle = a*b
         numbers = init [0..cycle]
         mods_a = map (f a b) numbers
         mods_b = map (f b a) numbers
         is_diff = zipWith (\q w -> if q == w then 0 else 1) mods_a mods_b
         acc = scanl (+) 0 is_diff

parse_other :: [[Integer]] -> [(Integer,Integer,Integer,[[Integer]])]
parse_other ([a,b,q]:ss) = (a,b,q,take (fromInteger q) ss):(parse_other $ drop (fromInteger q) ss)
parse_other [] = []
parse_input ([t]:other) = parse_other other

main = interact $ unlines . map (unwords . map show) . map solve . parse_input . map (map read) . map words . lines


In this problem your goal is to sort an array consisting of n integers in at most n swaps. For the given array find the sequence of swaps that makes the array sorted in the non-descending order. Swaps are performed consecutively, one after another.Note that in this problem you do not have to minimize the number of swaps — your task is to find any sequence that is no longer than n.

The first line of the input contains integer n (1 ≤ n ≤ 3000) — the number of array elements. The second line contains elements of array: a0, a1, ..., an - 1 ( - 109 ≤ ai ≤ 109), where ai is the i-th element of the array. The elements are numerated from 0 to n - 1 from left to right. Some integers may appear in the array more than once.

In the first line print k (0 ≤ k ≤ n) — the number of swaps. Next k lines must contain the descriptions of the k swaps, one per line. Each swap should be printed as a pair of integers i, j (0 ≤ i, j ≤ n - 1), representing the swap of elements ai and aj. You can print indices in the pairs in any order. The swaps are performed in the order they appear in the output, from the first to the last. It is allowed to print i = j and swap the same pair of elements multiple times. If there are multiple answers, print any of them. It is guaranteed that at least one answer exists.

import Data.List (elemIndex)
import Data.Maybe (fromJust)

main :: IO ()
main = getContents >>= printSolution . solve 0 . map read . tail . words
  where printSolution xs = print (length xs) >> mapM_ (putStrLn . unwords . map show) xs

solve :: Int -> [Int] -> [[Int]]
solve _ [] = []
solve i aas@(a:as) = (if j > 0 then ([i, i + j]:) else id) (solve (i + 1) [ if j == k then a else b | (k, b) <- zip [1..] as ])
  where j = fromJust $ elemIndex (minimum aas) aas

import Data.List (elemIndex)
import Data.Maybe (fromJust)

main :: IO ()
main = getContents >>= printSolution . solve 0 . map read . tail . words
  where printSolution xs = print (length xs) >> mapM_ (putStrLn . unwords . map show) xs

solve :: Int -> [Int] -> [[Int]]
solve _ [] = []
solve i as = (if j > Just 0 then ([i, i + fromJust j]:) else id) (solve (i + 1) [ if j == Just k then head as else a | (k, a) <- zip [1..] (tail as) ])
  where j = elemIndex (minimum as) as

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

process [x] = putStrLn "0 0"
process t = do
		let z = fromJust(elemIndex (maximum t) t)
		let lt = length t - 1
		putStrLn $ show z ++ " "++ show lt
		let nt = init (take z t ++ [t!!lt] ++ (drop (z+1) t))
		process nt

main=do
	s<- getLine
	t<- map (fst.fromJust.C.readInt). C.words <$> C.getLine ::IO [Int]
	print $ length t
	process t

import qualified Data.List as List

argMin :: [Int] -> (Int, Int)
argMin [v] = (v, 0)
argMin (x : xs) = (v', p')
    where (v, p) = argMin xs
          p' = if v < x then p + 1 else 0
          v' = min x v

replace :: [Int] -> Int -> Int -> [Int]
replace (x : xs) 0 v = v : xs
replace (x : xs) p v = x : replace xs (p - 1) v

solve :: [Int] -> [Int]
solve [] = []
solve all@(x : xs) = let (_, p) = argMin all
                         rs = if (p == 0) then xs else replace xs (p - 1) x
                      in p : solve rs

main = do
    getLine
    input <- getLine
    let swap = solve $ map read $ words input
        n = length swap
    print n
    mapM putStrLn $ map unwords $ zipWith (\x y -> [show x, show (x + y)]) [0 .. ] swap

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

process [x] = putStrLn "0 0"
process t = do
		let z = fromJust(elemIndex (maximum t) t)
		let lt = length t - 1
		putStrLn $ show z ++ " "++ show lt
		let nt = init (take (z-1) t ++ [t!!lt] ++ (drop (z+1) t))
		process nt

main=do
	s<- getLine
	t<- map (fst.fromJust.C.readInt). C.words <$> C.getLine ::IO [Int]
	print $ length t
	process t


By the age of three Smart Beaver mastered all arithmetic operations and got this summer homework from the amazed teacher:You are given a sequence of integers a1, a2, ..., an. Your task is to perform on it m consecutive operations of the following type:  For given numbers xi and vi assign value vi to element axi.  For given numbers li and ri you've got to calculate sum , where f0 = f1 = 1 and at i ≥ 2: fi = fi - 1 + fi - 2.  For a group of three numbers li ri di you should increase value ax by di for all x (li ≤ x ≤ ri). Smart Beaver planned a tour around great Canadian lakes, so he asked you to help him solve the given problem.

The first line contains two integers n and m (1 ≤ n, m ≤ 2·105) — the number of integers in the sequence and the number of operations, correspondingly. The second line contains n integers a1, a2, ..., an (0 ≤ ai ≤ 105). Then follow m lines, each describes an operation. Each line starts with an integer ti (1 ≤ ti ≤ 3) — the operation type:    if ti = 1, then next follow two integers xi vi (1 ≤ xi ≤ n, 0 ≤ vi ≤ 105);  if ti = 2, then next follow two integers li ri (1 ≤ li ≤ ri ≤ n);  if ti = 3, then next follow three integers li ri di (1 ≤ li ≤ ri ≤ n, 0 ≤ di ≤ 105).  The input limits for scoring 30 points are (subproblem E1):    It is guaranteed that n does not exceed 100, m does not exceed 10000 and there will be no queries of the 3-rd type.  The input limits for scoring 70 points are (subproblems E1+E2):    It is guaranteed that there will be queries of the 1-st and 2-nd type only.  The input limits for scoring 100 points are (subproblems E1+E2+E3):    No extra limitations.

For each query print the calculated sum modulo 1000000000 (109).

{-# 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.List
import Data.Array.Base
import Data.Array.IO
import Data.Int

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

main :: IO ()
main = do
  [n,m] <- map read.words <$> getLine
  xs <- (0:).map(fromIntegral.readInt).B.words <$> B.getLine :: IO [Int64]
  arr <- newListArray(0,n) xs :: IO (IOUArray Int Int64)
  let task1 :: Int -> Int -> IO ()
      task1 x v = unsafeWrite arr x $ fromIntegral v
      task2 :: Int -> Int -> IO Int64
      task2 l r = foldl'(+%)0.zipWith (*%) fibs <$> mapM (unsafeRead arr) [l..r]
      solve (1:x:v:rest) = task1 x v >> solve rest
      solve (2:l:r:rest) = task2 l r >>= print >> solve rest
      solve _ = return ()
  tasks <- map readInt.B.words <$> B.getContents
  solve tasks

x +% y = (x+y)`rem`1000000000
{-# INLINE (+%) #-}
x *% y = (x*y)`rem`1000000000
{-# INLINE (*%) #-}

fibs :: [Int64]
fibs = 1:1:zipWith(+%)fibs(tail fibs)
   where
     x +% y = (x+y)`rem`1000000000


The only difference between problems C1 and C2 is that all values in input of problem C1 are distinct (this condition may be false for problem C2).You are given a sequence $$$a$$$ consisting of $$$n$$$ integers.You are making a sequence of moves. During each move you must take either the leftmost element of the sequence or the rightmost element of the sequence, write it down and remove it from the sequence. Your task is to write down a strictly increasing sequence, and among all such sequences you should take the longest (the length of the sequence is the number of elements in it).For example, for the sequence $$$[1, 2, 4, 3, 2]$$$ the answer is $$$4$$$ (you take $$$1$$$ and the sequence becomes $$$[2, 4, 3, 2]$$$, then you take the rightmost element $$$2$$$ and the sequence becomes $$$[2, 4, 3]$$$, then you take $$$3$$$ and the sequence becomes $$$[2, 4]$$$ and then you take $$$4$$$ and the sequence becomes $$$[2]$$$, the obtained increasing sequence is $$$[1, 2, 3, 4]$$$).

The first line of the input contains one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the number of elements in $$$a$$$. The second line of the input contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 2 \cdot 10^5$$$), where $$$a_i$$$ is the $$$i$$$-th element of $$$a$$$.

In the first line of the output print $$$k$$$ — the maximum number of elements in a strictly increasing sequence you can obtain. In the second line print a string $$$s$$$ of length $$$k$$$, where the $$$j$$$-th character of this string $$$s_j$$$ should be 'L' if you take the leftmost element during the $$$j$$$-th move and 'R' otherwise. If there are multiple answers, you can print any.

NoteThe first example is described in the problem statement.

--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 qualified Data.Array.Unboxed as UA

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

ru, ri :: C.ByteString -> Int

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

solve :: [Int] -> Builder
solve (n:a) = intDec (C.length ans) <> char7 '\n' <>  byteString ans <> char7 '\n'
  where
    b = take n a
    x = UA.listArray (1, n) b :: UA.UArray Int Int
    loopi !i !last r
      | xi <= last = r
      | True = loopi (succ i) xi ('L':r)
      where
        xi = x UA.! i
    loopj !j !last r
      | xj <= last = r
      | True = loopj (pred j) xj ('R':r)
      where
        xj = x UA.! j

    loop i j last r
      | i > j = r
      | i == j = if last < xi then 'L' : r else r
      | xi == xj && xi <= last = r
      | xi == xj = let r1 = loopi i last [] in
                   let r2 = loopj j last [] in
                   if length r1 > length r2 then r1 ++ r else r2 ++ r
      | null l = r
      | d == 'L' = loop (succ i) j v (d : r)
      | d == 'R' = loop i (pred j) v (d : r)
      where
        xi = x UA.! i
        xj = x UA.! j
        l = filter ( (last <  ) . fst) [(xi, 'L'), (xj, 'R')]
        (v, d) = minimum l
    ans = C.reverse $ C.pack $ loop 1 n minBound []

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


Finally, you have defeated Razor and now, you are the Most Wanted street racer. Sergeant Cross has sent the full police force after you in a deadly pursuit. Fortunately, you have found a hiding spot but you fear that Cross and his force will eventually find you. To increase your chances of survival, you want to tune and repaint your BMW M3 GTR.The car can be imagined as a permuted $$$n$$$-dimensional hypercube. A simple $$$n$$$-dimensional hypercube is an undirected unweighted graph built recursively as follows:   Take two simple $$$(n-1)$$$-dimensional hypercubes one having vertices numbered from $$$0$$$ to $$$2^{n-1}-1$$$ and the other having vertices numbered from $$$2^{n-1}$$$ to $$$2^{n}-1$$$. A simple $$$0$$$-dimensional Hypercube is just a single vertex.  Add an edge between the vertices $$$i$$$ and $$$i+2^{n-1}$$$ for each $$$0\leq i < 2^{n-1}$$$. A permuted $$$n$$$-dimensional hypercube is formed by permuting the vertex numbers of a simple $$$n$$$-dimensional hypercube in any arbitrary manner.Examples of a simple and permuted $$$3$$$-dimensional hypercubes are given below:  Note that a permuted $$$n$$$-dimensional hypercube has the following properties:   There are exactly $$$2^n$$$ vertices.  There are exactly $$$n\cdot 2^{n-1}$$$ edges.  Each vertex is connected to exactly $$$n$$$ other vertices.  There are no self-loops or duplicate edges. Let's denote the permutation used to generate the permuted $$$n$$$-dimensional hypercube, representing your car, from a simple $$$n$$$-dimensional hypercube by $$$P$$$. Before messing up the functionalities of the car, you want to find this permutation so that you can restore the car if anything goes wrong. But the job isn't done yet.You have $$$n$$$ different colours numbered from $$$0$$$ to $$$n-1$$$. You want to colour the vertices of this permuted $$$n$$$-dimensional hypercube in such a way that for each and every vertex $$$u$$$ satisfying $$$0\leq u < 2^n$$$ and for each and every colour $$$c$$$ satisfying $$$0\leq c < n$$$, there is at least one vertex $$$v$$$ adjacent to $$$u$$$ having a colour $$$c$$$. In other words, from each and every vertex, it must be possible to reach a vertex of any colour by just moving to an adjacent vertex. Given the permuted $$$n$$$-dimensional hypercube, find any valid permutation $$$P$$$ and colouring.

The first line of input contains a single integer $$$t$$$ ($$$1\leq t\leq 4096$$$) — the number of test cases. For each test case, the first line contains a single integer $$$n$$$ ($$$1\leq n\leq 16$$$). Each of the next $$$n\cdot 2^{n-1}$$$ lines contain two integers $$$u$$$ and $$$v$$$ ($$$0\leq u, v < 2^n$$$) denoting that there is an edge between the vertices numbered $$$u$$$ and $$$v$$$. It is guaranteed that the graph described in the input is a permuted $$$n$$$-dimensional hypercube. Additionally, it is guaranteed that the sum of $$$2^n$$$ over all test cases does not exceed $$$2^{16}=65\,536$$$.

For each test case, print two lines. In the first line, output any permutation $$$P$$$ of length $$$2^n$$$ that can be used to transform a simple $$$n$$$-dimensional hypercube to the permuted $$$n$$$-dimensional hypercube given in the input. Two permuted hypercubes are considered the same if they have the same set of edges. If there are multiple answers, output any of them. In the second line, print the colouring. If there is no way to colour the vertices satisfying the conditions, output $$$-1$$$. Otherwise, output a single line containing $$$2^n$$$ space separated integers. The $$$i$$$-th integer must be the colour of the vertex numbered $$$(i-1)$$$ in the permuted $$$n$$$-dimensional hypercube. If there are multiple answers, output any of them.

NoteThe colouring and the permuted hypercube for the first test case is shown below:   The colouring and the permuted hypercube for the second test case is shown below:   The permuted hypercube for the third test case is given in the problem statement. However, it can be shown that there exists no way to colour that cube satifying all the conditions. Note that some other permutations like $$$[0, 5, 7, 3, 1, 2, 4, 6]$$$ and $$$[0, 1, 5, 2, 7, 4, 3, 6]$$$ will also give the same permuted hypercube.

import Control.Monad ( replicateM, replicateM_ )
import Data.Array ( (!) )
import Data.Bits ( Bits(testBit, (.&.), xor) )
import Data.Graph ( buildG )
import Data.List ( sort )
import Data.Tuple ( swap )
import qualified Data.ByteString.Char8 as C
import qualified Data.IntSet as S

data Queue a = Queue [a] [a] deriving Show

empty :: Queue a -> Bool
empty (Queue [] []) = True
empty _             = False

push :: a -> Queue a -> Queue a
push x (Queue a b) = Queue (x:a) b

pop :: Queue a -> (a, Queue a)
pop (Queue [] [])    = error "empty"
pop (Queue a (x:xs)) = (x, Queue a xs)
pop (Queue a [])     = pop $ Queue [] (reverse a)

solve :: IO ()
solve = do
    n <- readInt
    e <- replicateM (n * 2^(n - 1)) $ do
        [u, v] <- readInts
        return (u, v)
    let g = buildG (0, 2^n - 1) (e ++ map swap e)
        go :: S.IntSet -> Int -> Int -> [Int]
        go un u v | S.size un == 2 = [u, v]
        go un u v =
            let (r0, u0, v0, r1, u1, v1) = bfs un (Queue [] [u]) (S.singleton u) (Queue [] [v]) (S.singleton v)
                r0' = go r0 u0 v0
                r1' = match un r0' r1
            in r0' ++ r1'
        bfs :: S.IntSet -> Queue Int -> S.IntSet -> Queue Int -> S.IntSet -> (S.IntSet, Int, Int, S.IntSet, Int, Int)
        bfs un q0 a0 q1 a1
            | empty q0 = (a0, -1, -1, a1, -1, -1)
            | otherwise =
                let (u, q0') = pop q0
                    ok v = v `S.notMember` a0 && v `S.notMember` a1 && v `S.member` un
                    nbs = filter ok (g!u)
                    a0' = foldr S.insert a0 nbs
                    q0'' = foldr push q0' nbs
                    (r1, u1, v1, r0, _, _) = bfs un q1 a1 q0'' a0'
                in (r0, u, head nbs, r1, u1, v1)
        match :: S.IntSet -> [Int] -> S.IntSet -> [Int]
        match un r0 r1 =
            let ok v = v `S.member` r1 && v `S.member` un
            in map (head . filter ok . (g!)) r0
        canColor = n .&. (n - 1) == 0
        color :: Int -> Int
        color u = foldr xor 0 $ filter (testBit u) [0..n - 1]
    let (u, v) = head e
        p = go (S.fromList [0..2^n - 1]) u v
        invP = map snd $ sort $ zip p [0..]
        pStr = unwords $ map show p
        cStr = unwords $ map (show . color) invP
    putStrLn pStr
    putStrLn $ if canColor then cStr else "-1"

parseInt = getInt . C.readInt where getInt (Just (i, _)) = i
readInt = parseInt <$> C.getLine
readInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = do
    t <- readInt
    replicateM_ t solve

import Control.Monad ( replicateM, replicateM_ )
import Data.Array ( (!) )
import Data.Bits ( Bits(testBit, (.&.), xor) )
import Data.Graph ( buildG )
import Data.List ( sort )
import Data.Tuple ( swap )
import qualified Data.ByteString.Char8 as C
import qualified Data.IntSet as S

data Queue a = Queue [a] [a] deriving Show

empty :: Queue a -> Bool
empty (Queue [] []) = True
empty _             = False

push :: a -> Queue a -> Queue a
push x (Queue a b) = Queue (x:a) b

pop :: Queue a -> (a, Queue a)
pop (Queue [] [])    = error "empty"
pop (Queue a (x:xs)) = (x, Queue a xs)
pop (Queue a [])     = pop $ Queue [] (reverse a)

solve :: IO ()
solve = do
    n <- readInt
    e <- replicateM (n * 2^(n - 1)) $ do
        [u, v] <- readInts
        return (u, v)
    let g = buildG (0, 2^n - 1) (e ++ map swap e)
        go :: S.IntSet -> Int -> Int -> [Int]
        go un u v | S.size un == 2 = [u, v]
        go un u v =
            let (r0, u0, v0, r1, u1, v1) = bfs un (Queue [] [u]) (S.singleton u) (Queue [] [v]) (S.singleton v)
                r0' = go r0 u0 v0
                r1' = match un r0' r1
            in r0' ++ r1'
        bfs :: S.IntSet -> Queue Int -> S.IntSet -> Queue Int -> S.IntSet -> (S.IntSet, Int, Int, S.IntSet, Int, Int)
        bfs un q0 a0 q1 a1
            | empty q0 = (a0, -1, -1, a1, -1, -1)
            | otherwise =
                let (u, q0') = pop q0
                    ok v = v `S.notMember` a0 && v `S.notMember` a1 && v `S.member` un
                    nbs = filter ok (g!u)
                    a0' = foldr S.insert a0 nbs
                    q0'' = foldr push q0' nbs
                    (r1, u1, v1, r0, _, _) = bfs un q1 a1 q0'' a0'
                in (r0, u, head nbs, r1, u1, v1)
        match :: S.IntSet -> [Int] -> S.IntSet -> [Int]
        match un r0 r1 =
            let ok v = v `S.member` r1 && v `S.member` un
            in map (head . filter ok . (g!)) r0
        canColor = n .&. (n - 1) == 0
        color u = foldr xor 0 [i | i <- [0..n - 1], u `testBit` i]
    let (u, v) = head e
        p = go (S.fromList [0..2^n - 1]) u v
        invP = map snd $ sort $ zip p [0..]
        pStr = unwords $ map show p
        cStr = unwords $ map show $ [color (i :: Int) | i <- invP]
    putStrLn pStr
    putStrLn $ if canColor then cStr else "-1"

parseInt = getInt . C.readInt where getInt (Just (i, _)) = i
readInt = parseInt <$> C.getLine
readInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = do
    t <- readInt
    replicateM_ t solve

import Control.Monad ( replicateM, replicateM_ )
import Data.Array ( (!) )
import Data.Bits ( Bits(testBit, (.&.), xor) )
import Data.Graph ( buildG )
import Data.List ( sort )
import Data.Tuple ( swap )
import qualified Data.IntSet as S

data Queue a = Queue [a] [a] deriving Show

empty :: Queue a -> Bool
empty (Queue [] []) = True
empty _             = False

push :: a -> Queue a -> Queue a
push x (Queue a b) = Queue (x:a) b

pop :: Queue a -> (a, Queue a)
pop (Queue [] [])    = error "empty"
pop (Queue a (x:xs)) = (x, Queue a xs)
pop (Queue a [])     = pop $ Queue [] (reverse a)

solve :: IO ()
solve = do
    n <- readLn :: IO Int
    e <- replicateM (n * 2^(n - 1)) $ do
        [u, v] <- readMany :: IO [Int]
        return (u, v)
    let g = buildG (0, 2^n - 1) (e ++ map swap e)
        go :: S.IntSet -> Int -> Int -> [Int]
        go un u v | S.size un == 2 = [u, v]
        go un u v =
            let (r0, u0, v0, r1, u1, v1) = bfs un (Queue [] [u]) (S.singleton u) (Queue [] [v]) (S.singleton v)
            in go r0 u0 v0 ++ go r1 u1 v1
        bfs :: S.IntSet -> Queue Int -> S.IntSet -> Queue Int -> S.IntSet -> (S.IntSet, Int, Int, S.IntSet, Int, Int)
        bfs un q0 a0 q1 a1
            | empty q0 = (a0, -1, -1, a1, -1, -1)
            | otherwise =
                let (u, q0') = pop q0
                    ok v = v `S.notMember` a0 && v `S.notMember` a1 && v `S.member` un
                    nxt = filter ok (g!u)
                    a0' = foldr S.insert a0 nxt
                    q0'' = foldr push q0' nxt
                    (r1, u1, v1, r0, u0, v0) = bfs un q1 a1 q0'' a0'
                    (u0', v0') = if null nxt then (u0, v0) else (u, head nxt)
                in (r0, u0', v0', r1, u1, v1)
        canColor = n .&. (n - 1) == 0
        color u = foldr xor 0 [i | i <- [0..n - 1], u `testBit` i]
    let (u, v) = head e
        p = go (S.fromList [0..2^n - 1]) u v
        invP = map snd $ sort $ zip p [0..]
        pStr = unwords $ map show p
        cStr = unwords $ map show $ [color (i :: Int) | i <- invP]
    putStrLn pStr
    putStrLn $ if canColor then cStr else "-1"

readMany :: Read a => IO [a]
readMany = map read . words <$> getLine

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

import Control.Monad ( replicateM, replicateM_ )
import Data.Array ( (!) )
import Data.Bits ( Bits(testBit, (.&.), xor) )
import Data.Graph ( buildG )
import Data.List ( sort )
import Data.Tuple ( swap )
import qualified Data.IntSet as S

data Queue a = Queue [a] [a] deriving Show

empty :: Queue a -> Bool
empty (Queue [] []) = True
empty _             = False

push :: a -> Queue a -> Queue a
push x (Queue a b) = Queue (x:a) b

pop :: Queue a -> (a, Queue a)
pop (Queue [] [])    = error "empty"
pop (Queue a (x:xs)) = (x, Queue a xs)
pop (Queue a [])     = pop $ Queue [] (reverse a)

solve :: IO ()
solve = do
    n <- readLn :: IO Int
    e <- replicateM (n * 2^(n - 1)) $ do
        [u, v] <- readMany :: IO [Int]
        return (u, v)
    let g = buildG (0, 2^n - 1) (e ++ map swap e)
        go :: S.IntSet -> Int -> Int -> [Int]
        go un u v =
            let (r0, u0, v0, r1, u1, v1) = bfs un (Queue [] [u]) (S.singleton u) (Queue [] [v]) (S.singleton v)
            in if u0 == -1 then [S.findMin r0, S.findMin r1] else go r0 u0 v0 ++ go r1 u1 v1
        bfs :: S.IntSet -> Queue Int -> S.IntSet -> Queue Int -> S.IntSet -> (S.IntSet, Int, Int, S.IntSet, Int, Int)
        bfs un q0 a0 q1 a1
            | empty q0 = (a0, -1, -1, a1, -1, -1)
            | otherwise =
                let (u, q0') = pop q0
                    ok v = v `S.notMember` a0 && v `S.notMember` a1 && v `S.member` un
                    nxt = filter ok (g!u)
                    a0' = foldr S.insert a0 nxt
                    q0'' = foldr push q0' nxt
                    (r1, u1, v1, r0, u0, v0) = bfs un q1 a1 q0'' a0'
                    (u0', v0') = if null nxt then (u0, v0) else (u, head nxt)
                in (r0, u0', v0', r1, u1, v1)
        canColor = n .&. (n - 1) == 0
        color u = foldr xor 0 [i | i <- [0..n - 1], u `testBit` i]
    let (u, v) = head e
        p = go (S.fromList [0..2^n - 1]) u v
        pStr = unwords $ map show p
        invP = map snd $ sort $ zip p [0..]
        cStr = unwords $ map show $ [color (i :: Int) | i <- invP]
    putStrLn pStr
    putStrLn $ if canColor then cStr else "-1"

readMany :: Read a => IO [a]
readMany = map read . words <$> getLine

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