There is a binary string $$$a$$$ of length $$$n$$$. In one operation, you can select any prefix of $$$a$$$ with an equal number of $$$0$$$ and $$$1$$$ symbols. Then all symbols in the prefix are inverted: each $$$0$$$ becomes $$$1$$$ and each $$$1$$$ becomes $$$0$$$.For example, suppose $$$a=0111010000$$$.   In the first operation, we can select the prefix of length $$$8$$$ since it has four $$$0$$$'s and four $$$1$$$'s: $$$[01110100]00\to [10001011]00$$$.  In the second operation, we can select the prefix of length $$$2$$$ since it has one $$$0$$$ and one $$$1$$$: $$$[10]00101100\to [01]00101100$$$.  It is illegal to select the prefix of length $$$4$$$ for the third operation, because it has three $$$0$$$'s and one $$$1$$$. Can you transform the string $$$a$$$ into the string $$$b$$$ using some finite number of operations (possibly, none)?

The first line contains a single integer $$$t$$$ ($$$1\le t\le 10^4$$$) — the number of test cases. The first line of each test case contains a single integer $$$n$$$ ($$$1\le n\le 3\cdot 10^5$$$) — the length of the strings $$$a$$$ and $$$b$$$. The following two lines contain strings $$$a$$$ and $$$b$$$ of length $$$n$$$, consisting of symbols $$$0$$$ and $$$1$$$. The sum of $$$n$$$ across all test cases does not exceed $$$3\cdot 10^5$$$.

For each test case, output "YES" if it is possible to transform $$$a$$$ into $$$b$$$, or "NO" if it is impossible. You can print each letter in any case (upper or lower).

NoteThe first test case is shown in the statement.In the second test case, we transform $$$a$$$ into $$$b$$$ by using zero operations.In the third test case, there is no legal operation, so it is impossible to transform $$$a$$$ into $$$b$$$.In the fourth test case, here is one such transformation:   Select the length $$$2$$$ prefix to get $$$100101010101$$$.  Select the length $$$12$$$ prefix to get $$$011010101010$$$.  Select the length $$$8$$$ prefix to get $$$100101011010$$$.  Select the length $$$4$$$ prefix to get $$$011001011010$$$.  Select the length $$$6$$$ prefix to get $$$100110011010$$$. In the fifth test case, the only legal operation is to transform $$$a$$$ into $$$111000$$$. From there, the only legal operation is to return to the string we started with, so we cannot transform $$$a$$$ into $$$b$$$.

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import Data.Bool (bool)
import Data.List (find)
import Data.Maybe (fromMaybe)

main :: IO ()
main =
  interact $
  words >>>
  drop 1 >>> chunksOf 3 >>> map (solve >>> bool "NO" "YES") >>> unlines

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

type CC = (Char, Char) -- pair of chars

type PString = [CC] -- string of pair of chars

solve :: [String] -> Bool
solve [_, a, b] =
  let (g:gs) = decomp $ zip a b
   in all ok gs && uncurry (==) (unzip g)

ok :: PString -> Bool
ok = liftA2 (||) (all (uncurry (==))) (not . any (uncurry (==)))

decomp :: PString -> [PString]
decomp = (\(_, e, es) -> e : es) . foldl extend (0, [], [])
  where
    extend :: (Int, PString, [PString]) -> CC -> (Int, PString, [PString])
    extend (s, g, gs) (ai, bi) =
      let s' =
            s +
            if ai == '0'
              then 1
              else (-1)
          g' = (ai, bi) : g
       in if s' == 0
            then (0, [], g' : gs)
            else (s', g', gs)

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

import qualified Data.Array as A

import qualified Control.Monad.State.Strict as State
import Control.Monad.ST

import Data.Bits(xor, (.&.), (.|.))

import Data.Array((!))
import Control.Monad(replicateM)
import Data.Maybe

type Set = S.Set Integer

solve :: String -> String -> Bool
solve a b = aux (n-1) False

	where
		n = length a
		aA = A.listArray (0, n-1) a
		bA = A.listArray (0, n-1) b
		aux i inv
			| i == -1 = True
			| test /= inv = aux (i-1) inv
			| test == inv && S.member i set = aux (i-1) (not inv)
			| otherwise = False
			where
				test = aA ! i == bA ! i

		num0_1 [] _ _ = []
		num0_1 ('0':xs) i j = (i+1, j):num0_1 xs (i+1) j
		num0_1 ('1':xs) i j = (i, j+1):num0_1 xs i (j+1)
		set = S.fromList [i | (i, (x, y))<-zip [0..] (num0_1 a 0 0), x==y]

showR :: Bool -> IO ()
showR False = putStrLn "NO"
showR True = putStrLn "YES"

main = do
	t <- getLine >>= return . read :: IO Integer
	replicateM (fromInteger t) $ do
		[n] <- getLine >>= return . (fmap read) . words :: IO [Integer]
		a <- getLine
		b <- getLine
		showR $ solve a b

import Control.Applicative (liftA2)
import Control.Arrow ((>>>))
import Data.Bool (bool)
import Data.List (find)
import Data.Maybe (fromMaybe)

main :: IO ()
main =
  interact $
  words >>>
  drop 1 >>> chunksOf 3 >>> map (solve >>> bool "NO" "YES") >>> unlines

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

type CC = (Char, Char) -- pair of chars

type PString = [CC] -- string of pair of chars

solve :: [String] -> Bool
solve [_, a, b] = all ok $ decomp $ zip a b

ok :: PString -> Bool
ok = liftA2 (||) (all (uncurry (==))) (not . any (uncurry (==)))

decomp :: PString -> [PString]
decomp = (\(_, _, e) -> e) . foldr extend (0, [], [])
  where
    extend :: CC -> (Int, PString, [PString]) -> (Int, PString, [PString])
    extend (ai, bi) (s, g, gs) =
      let s' =
            s +
            if ai == '0'
              then 1
              else (-1)
          g' = (ai, bi) : g
       in if s' == 0
            then (0, [], g' : gs)
            else (s', g', gs)

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

import qualified Data.Array as A

import qualified Control.Monad.State.Strict as State
import Control.Monad.ST

import Data.Bits(xor, (.&.), (.|.))

import Data.Array((!))
import Control.Monad(replicateM)
import Data.Maybe

type Set = S.Set Integer

solve :: String -> String -> Bool
solve a b = aux (n-1) True || aux (n-1) False

	where
		n = length a
		aA = A.listArray (0, n-1) a
		bA = A.listArray (0, n-1) b
		aux i inv
			| i == -1 = True
			| aA ! i /= bA ! i && inv = aux (i-1) inv
			| aA ! i == bA ! i && not inv = aux (i-1) inv
			| aA ! i == bA ! i && inv && S.member i set = aux (i-1) (not inv)
			| aA ! i /= bA ! i && not inv && S.member i set = aux (i-1) (not inv)
			| otherwise = False

		num0_1 [] _ _ = []
		num0_1 ('0':xs) i j = (i+1, j):num0_1 xs (i+1) j
		num0_1 ('1':xs) i j = (i, j+1):num0_1 xs i (j+1)
		set = S.fromList [i | (i, (x, y))<-zip [0..] (num0_1 a 0 0), x==y]

showR :: Bool -> IO ()
showR False = putStrLn "NO"
showR True = putStrLn "YES"

main = do
	t <- getLine >>= return . read :: IO Integer
	replicateM (fromInteger t) $ do
		[n] <- getLine >>= return . (fmap read) . words :: IO [Integer]
		a <- getLine
		b <- getLine
		showR $ solve a b


Ashish has a string $$$s$$$ of length $$$n$$$ containing only characters 'a', 'b' and 'c'.He wants to find the length of the smallest substring, which satisfies the following conditions:   Length of the substring is at least $$$2$$$  'a' occurs strictly more times in this substring than 'b'  'a' occurs strictly more times in this substring than 'c'  Ashish is busy planning his next Codeforces round. Help him solve the problem.A string $$$a$$$ is a substring of a string $$$b$$$ if $$$a$$$ can be obtained from $$$b$$$ by deletion of several (possibly, zero or all) characters from the beginning and several (possibly, zero or all) characters from the end.

The first line contains a single integer $$$t$$$ $$$(1 \le t \le 10^{5})$$$  — the number of test cases. The description of test cases follows. The first line of each test case contains a single integer $$$n$$$ $$$(2 \le n \le 10^{6})$$$  — the length of the string $$$s$$$. The second line of each test case contains a string $$$s$$$ consisting only of characters 'a', 'b' and 'c'. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^{6}$$$.

For each test case, output the length of the smallest substring which satisfies the given conditions or print $$$-1$$$ if there is no such substring.

NoteConsider the first test case. In the substring "aa", 'a' occurs twice, while 'b' and 'c' occur zero times. Since 'a' occurs strictly more times than 'b' and 'c', the substring "aa" satisfies the condition and the answer is $$$2$$$. The substring "a" also satisfies this condition, however its length is not at least $$$2$$$.In the second test case, it can be shown that in none of the substrings of "cbabb" does 'a' occur strictly more times than 'b' and 'c' each.In the third test case, "cacabccc", the length of the smallest substring that satisfies the conditions is $$$3$$$.

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

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

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

data TC = TC {n :: Int, s :: String}

input :: Scanner TC
input = do
  n <- int
  s <- str
  return TC {..}

type Output = Int

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

solve :: TC -> Output
solve TC {..} = if null cands then -1 else minimum cands
  where
    cands = [length w | w <- ["aa", "aba", "aca", "abca", "acba", "abbacca", "accabba"], w `substring` s]

substring _ [] = False
substring w s = w == take (length w) s || substring w (tail s)

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

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

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

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

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

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

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

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

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

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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

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

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

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

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

(><) = times

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

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

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

import Control.Monad
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n] <- readInts
    s <- takeWhile (not . isSpace) . C.unpack <$> C.getLine
    let f t = if t `isInfixOf` s then Just (length t) else Nothing
    print $ fromMaybe (-1) $ asum $ map f ss

ss :: [String]
ss =
    [ "aa"
    , "aba"
    , "aca"
    , "abca"
    , "acba"
    , "abbacca"
    , "accabba"
    ]

readInts :: IO [Int]
readInts = map (fst . fromJust . C.readInt) . C.words <$> C.getLine

main :: IO ()
main = flip replicateM_ solve . head =<< readInts

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

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

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

data TC = TC {n :: Int, s :: String}

input :: Scanner TC
input = do
  n <- int
  s <- str
  return TC {..}

type Output = Int

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

solve :: TC -> Output
solve TC {..}
  | "aa" `elem` g = 2
  | "b" `elem` g || "c" `elem` g = 3
  | "bc" `elem` g || "cb" `elem` g = 4
  | otherwise = -1
  where
    g =
      debug
        . groupOn (== 'a')
        . dropWhile (/= 'a')
        . reverse
        . dropWhile (/= 'a')
        $ s

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

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

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

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

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

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

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

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

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

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

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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

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

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

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

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

(><) = times

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

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

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

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

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

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

data TC = TC {n :: Int, s :: String}

input :: Scanner TC
input = do
  n <- int
  s <- str
  return TC {..}

type Output = Int

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

solve :: TC -> Output
solve TC {..}
  | ('a', 'a') `elem` adjacents s = 2
  | "b" `elem` g || "c" `elem` g = 3
  | "bc" `elem` g || "cb" `elem` g = 4
  | otherwise = -1
  where
    g =
      filter ((/= 'a') . head)
        . groupOn (== 'a')
        . dropWhile (/= 'a')
        . reverse
        . dropWhile (/= 'a')
        $ s

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

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

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

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

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

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

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

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

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

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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

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

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

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

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

(><) = times

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

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

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


Vasya has an array a consisting of positive integer numbers. Vasya wants to divide this array into two non-empty consecutive parts (the prefix and the suffix) so that the sum of all elements in the first part equals to the sum of elements in the second part. It is not always possible, so Vasya will move some element before dividing the array (Vasya will erase some element and insert it into an arbitrary position).Inserting an element in the same position he was erased from is also considered moving.Can Vasya divide the array after choosing the right element to move and its new position?

The first line contains single integer n (1 ≤ n ≤ 100000) — the size of the array. The second line contains n integers a1, a2... an (1 ≤ ai ≤ 109) — the elements of the array.

Print YES if Vasya can divide the array after moving one element. Otherwise print NO.

NoteIn the first example Vasya can move the second element to the end of the array.In the second example no move can make the division possible.In the third example Vasya can move the fourth element by one position to the left.

import qualified Data.ByteString.Char8 as B
import           Data.Functor
import           Data.List
import           Data.Maybe
import qualified Data.Set              as S

getInts :: IO [Int]
getInts = map (fst . fromJust . B.readInt) <$> B.words <$> B.getContents
getIntegers :: IO [Integer]
getIntegers = map (fst . fromJust . B.readInteger) <$> B.words <$> B.getContents
pair []       = []
pair (x:y:rs) = (x, y) : pair rs
clamp u v w = max u $ min v $ w

main = do
    _:xs <- getIntegers
    putStrLn $ if solve xs then "YES" else "NO"

solve xs = mod s 2 == 0 && (res1 || res2) where
    s = sum xs
    want = - div s 2
    res1 = go xs want S.empty
    res2 = go (reverse xs) want S.empty
    go [] want s     = S.member want s
    go (x:xs) want s = S.member want s || go xs (want+x) (S.insert x s)

--- 20:36 - 20:40
import qualified Data.ByteString.Char8 as B
import           Data.Functor
import           Data.List
import           Data.Maybe
import qualified Data.Set              as S

getInts :: IO [Int]
getInts = map (fst . fromJust . B.readInt) <$> B.words <$> B.getContents
getIntegers :: IO [Integer]
getIntegers = map (fst . fromJust . B.readInteger) <$> B.words <$> B.getContents
pair []       = []
pair (x:y:rs) = (x, y) : pair rs
clamp u v w = max u $ min v $ w

main = do
    _:xs <- getIntegers
    s <- return $ sum xs
    if mod s 2 == 0 && (solve xs (-div s 2) S.empty
                         || solve (reverse xs) (-div s 2) S.empty)
        then putStrLn "YES"
        else putStrLn "NO"

solve [] want s     = S.member want s
solve (x:xs) want s = S.member want s || solve xs (want+x) (S.insert x s)

{-# LANGUAGE FlexibleContexts #-}
import Data.Int
import Data.List
import Data.Array
import qualified Data.ByteString.Char8 as BS
readInt s = let Just (a,_) = BS.readInt s in a

main = BS.interact $ BS.pack . out . solve . map (fromIntegral . readInt) . tail . BS.words

out True = "YES"
out _ = "NO"

solve :: [Int64] -> Bool
solve ns = (solveleft ns) || (solveleft $ reverse ns)

solveleft ns = or $ map (\(a, i) -> checkl a i psum) $ ns `zip` [1..]
    where len = length ns
          psum = listArray (1, len) $
            head ns : [ psum ! (i - 1) + a | (a, i) <- (tail ns) `zip` [2..]]

checkl balance i psum = diff (check_ i $ ir + 1) == 0
  where (il, ir) = bounds psum
        check_ l r
          | r - l <= 1 = l
          | diff mid >= 0 = check_ mid r
          | otherwise = check_ l mid
          where mid = (l + r) `div` 2
        diff mid = (psum ! ir) - 2 * (psum ! mid) + 2 * balance

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

import qualified Data.ByteString as B (ByteString, getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.Int as I (Int64)
import qualified Data.Map.Strict as MP (fromList, Map, alter, member, empty)

readInt :: B.ByteString -> I.Int64
readInt = fromIntegral . fst . M.fromJust . C.readInt

data MultiSet a = MS (MP.Map a Int)
empty = MS (MP.empty)
fromList xs | xs == [] = empty | otherwise = let x:xr = xs in insert x (fromList xr)
member x (MS m) = MP.member x m
insert x (MS m) = MS (MP.alter msucc x m) where
    msucc Nothing = Just 1
    msucc (Just x) = Just (x + 1)
delete x (MS m) = MS (MP.alter mpred x m) where
    mpred (Just 1) = Nothing
    mpred (Just x) = Just (x - 1)

run _ _ _ _ [] = "NO"
run sl sr tl tr (r:rs) | sl == sr = "YES"
    | sl > sr && even (sl - sr) && ((sl - sr) `div` 2) `member` tl = "YES"
    | sl < sr && even (sr - sl) && ((sr - sl) `div` 2) `member` tr = "YES"
    | otherwise = run (sl + r) (sr - r) (r `insert` tl) (r `delete` tr) rs
runx xs = run 0 (sum xs) empty (fromList xs) xs

main = B.getLine >> B.getLine >>= putStrLn . runx . map readInt . C.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M
import Data.Int

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> s == hs || maybe False (> i) (M.lookup (hs - s) m)) $ zip [1..] $ scanl1 (+) xs')
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) mr) $ zip [n + 2, n + 1..] $ scanl1 (+) $ reverse xs')
  where
    xs' = 0:xs ++ [0]
    m = M.fromListWith max $ zip xs' [(1 :: Int64)..]
    mr = M.fromListWith min $ zip xs' [(1 :: Int64)..]
    (hs, r) = sum xs `quotRem` 2 :: (Int64, Int64)

readInt = maybe undefined (fromIntegral . fst) . B.readInteger
readInts = fmap readInt . B.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Strict as M
import Data.Int

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> maybe False (> i) $ M.lookup (hs - s) m) $ zip [1..] $ scanl1 (+) xs')
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) mr) $ zip [n + 2, n + 1..] $ scanl1 (+) $ reverse xs')
  where
    xs' = 0:xs ++ [0]
    m = M.fromListWith max $ zip xs' [(1 :: Int64)..]
    mr = M.fromListWith min $ zip xs' [(1 :: Int64)..]
    (hs, r) = sum xs `quotRem` 2 :: (Int64, Int64)

readInt = maybe undefined (fromIntegral . fst) . B.readInteger
readInts = fmap readInt . B.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Strict as M
import Data.Int

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> s == hs || maybe False (> i) (M.lookup (hs - s) m)) $ zip [1..] $ scanl1 (+) xs')
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) mr) $ zip [n + 2, n + 1..] $ scanl1 (+) $ reverse xs')
  where
    xs' = 0:xs ++ [0]
    m = M.fromListWith max $ zip xs' [(1 :: Int64)..]
    mr = M.fromListWith min $ zip xs' [(1 :: Int64)..]
    (hs, r) = sum xs `quotRem` 2 :: (Int64, Int64)

readInt = maybe undefined (fromIntegral . fst) . B.readInteger
readInts = fmap readInt . B.words

{-# LANGUAGE FlexibleContexts #-}
import Data.List
import Data.Array
import qualified Data.ByteString.Char8 as BS
readInt s = let Just (a,_) = BS.readInt s in a

main = BS.interact $ BS.pack . out . solve . map readInt . tail . BS.words

out True = "YES"
out _ = "NO"

solve ns = (solveleft ns) || (solveleft $ reverse ns)

solveleft ns = or $ map (\(a, i) -> checkl a i psum) $ ns `zip` [1..]
    where len = length ns
          psum = listArray (1, len) $
            head ns : [ psum ! (i - 1) + a | (a, i) <- (tail ns) `zip` [2..]]

checkl balance i psum = diff (check_ i $ ir + 1) == 0
  where (il, ir) = bounds psum
        check_ l r
          | r - l <= 1 = l
          | diff mid >= 0 = check_ mid r
          | otherwise = check_ l mid
          where mid = (l + r) `div` 2
        diff mid = (psum ! ir) - 2 * (psum ! mid) + 2 * balance

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

import qualified Data.ByteString as B (ByteString, getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.Int as I (Int64)
import qualified Data.Set as S (fromList, member, insert, delete, empty)

readInt :: B.ByteString -> I.Int64
readInt = fromIntegral . fst . M.fromJust . C.readInt

run _ _ _ _ [] = "NO"
run sl sr tl tr (r:rs) | sl == sr = "YES"
    | sl > sr && even (sl - sr) && ((sl - sr) `div` 2) `S.member` tl = "YES"
    | sl < sr && even (sr - sl) && ((sr - sl) `div` 2) `S.member` tr = "YES"
    | otherwise = run (sl + r) (sr - r) (r `S.insert` tl) (r `S.delete` tr) rs
runx xs = run 0 (sum xs) S.empty (S.fromList xs) xs

main = B.getLine >> B.getLine >>= putStrLn . runx . map readInt . C.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = any (\(i, s) -> maybe False (> i) $ M.lookup (hs - s) m) $ zip [1..] $ scanl1 (+) xs
  where
    m = M.fromList $ zip xs [1..]
    (hs, r) = sum xs `quotRem` 2

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

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M
import Data.Int

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> s == hs || maybe False (> i) (M.lookup (hs - s) m)) $ zip [1..] $ scanl1 (+) xs')
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) m) $ zip [n, n - 1..] $ scanl1 (+) $ reverse xs')
  where
    xs' = 0:xs ++ [0]
    m = M.fromList $ zip xs' [(1 :: Int64)..]
    (hs, r) = sum xs `quotRem` 2 :: (Int64, Int64)

readInt = maybe undefined (fromIntegral . fst) . B.readInteger
readInts = fmap readInt . B.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> s == hs || maybe False (> i) (M.lookup (hs - s) m)) $ zip [1..] $ scanl1 (+) xs)
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) m) $ zip [n, n - 1..] $ scanl1 (+) $ reverse xs)
  where
    m = M.fromList $ zip xs [1..]
    (hs, r) = sum xs `quotRem` 2

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

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M
import Data.Int

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> s == hs || maybe False (> i) (M.lookup (hs - s) m)) $ zip [1..] $ scanl1 (+) xs)
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) m) $ zip [n, n - 1..] $ scanl1 (+) $ reverse xs)
  where
    m = M.fromList $ zip xs [(1 :: Int64)..]
    (hs, r) = sum xs `quotRem` 2 :: (Int64, Int64)

readInt = maybe undefined (fromIntegral . fst) . B.readInteger
readInts = fmap readInt . B.words

{-# OPTIONS_GHC -O2 -optc-O3 -optc-ffast-math -funfolding-use-threshold=16 -fexcess-precision -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
module Main where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Lazy as M

main = do
  n <- fmap readInt B.getLine
  xs <- fmap readInts B.getLine
  putStrLn $ if solve n xs then "YES" else "NO"

solve n xs
  | r /= 0 = False
  | otherwise = (any (\(i, s) -> maybe False (> i) $ M.lookup (hs - s) m) $ zip [1..] $ scanl1 (+) xs)
             || (any (\(i, s) -> maybe False (< i) $ M.lookup (hs - s) m) $ zip [n, n - 1..] $ scanl1 (+) $ reverse xs)
  where
    m = M.fromList $ zip xs [1..]
    (hs, r) = sum xs `quotRem` 2

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


On some square in the lowest row of a chessboard a stands a pawn. It has only two variants of moving: upwards and leftwards or upwards and rightwards. The pawn can choose from which square of the lowest row it can start its journey. On each square lay from 0 to 9 peas. The pawn wants to reach the uppermost row having collected as many peas as possible. As there it will have to divide the peas between itself and its k brothers, the number of peas must be divisible by k + 1. Find the maximal number of peas it will be able to collect and which moves it should make to do it.The pawn cannot throw peas away or leave the board. When a pawn appears in some square of the board (including the first and last square of the way), it necessarily takes all the peas.

The first line contains three integers n, m, k (2 ≤ n, m ≤ 100, 0 ≤ k ≤ 10) — the number of rows and columns on the chessboard, the number of the pawn's brothers. Then follow n lines containing each m numbers from 0 to 9 without spaces — the chessboard's description. Each square is described by one number — the number of peas in it. The first line corresponds to the uppermost row and the last line — to the lowest row.

If it is impossible to reach the highest row having collected the number of peas divisible by k + 1, print -1.  Otherwise, the first line must contain a single number — the maximal number of peas the pawn can collect given that the number must be divisible by k + 1. The second line must contain a single number — the number of the square's column in the lowest row, from which the pawn must start its journey. The columns are numbered from the left to the right with integral numbers starting from 1. The third line must contain a line consisting of n - 1 symbols — the description of the pawn's moves. If the pawn must move upwards and leftwards, print L, if it must move upwards and rightwards, print R. If there are several solutions to that problem, print any of them.

import Array
import Char
main = interact solve
solve input = output where
  input0 = lines input
  [n,m,k] = map (read::String->Int) $ words $ head input0
  peas = map (map (\x -> ord x - ord '0')) $ tail input0
  output = if x == -1 then "-1\n" else unlines [show x,show y,z] where
    (x,y,z) = foldl1 max [answer peas!(i,0)|i<-[1..m]]
  answer [x] = array ((1,0),(m,k)) [((i,j),f i j)|i<-[1..m],j<-[0..k]] where
    f i j = (u,v,w) where
      u = if mod y (k+1) == j then y else -1
      v = i
      w = ""
      y = x!!(i-1)
  answer (x:xs) = array ((1,0),(m,k)) [((i,j),f i j)|i<-[1..m],j<-[0..k]] where
    ys = answer xs
    f i j
      | a== -1 && p== -1 = (-1,0,"")
      | a>p              = (a+y,b,c++"R")
      | otherwise        = (p+y,q,r++"L")
      where
        (a,b,c) = if i==1 then (-1,0,"") else ys!(i-1,mod (j-y+k+1) (k+1))
        (p,q,r) = if i==m then (-1,0,"") else ys!(i+1,mod (j-y+k+1) (k+1))
        y = x!!(i-1)


You are playing a variation of game 2048. Initially you have a multiset $$$s$$$ of $$$n$$$ integers. Every integer in this multiset is a power of two. You may perform any number (possibly, zero) operations with this multiset.During each operation you choose two equal integers from $$$s$$$, remove them from $$$s$$$ and insert the number equal to their sum into $$$s$$$.For example, if $$$s = \{1, 2, 1, 1, 4, 2, 2\}$$$ and you choose integers $$$2$$$ and $$$2$$$, then the multiset becomes $$$\{1, 1, 1, 4, 4, 2\}$$$.You win if the number $$$2048$$$ belongs to your multiset. For example, if $$$s = \{1024, 512, 512, 4\}$$$ you can win as follows: choose $$$512$$$ and $$$512$$$, your multiset turns into $$$\{1024, 1024, 4\}$$$. Then choose $$$1024$$$ and $$$1024$$$, your multiset turns into $$$\{2048, 4\}$$$ and you win.You have to determine if you can win this game.You have to answer $$$q$$$ independent queries.

The first line contains one integer $$$q$$$ ($$$1 \le q \le 100$$$) – the number of queries. The first line of each query contains one integer $$$n$$$ ($$$1 \le n \le 100$$$) — the number of elements in multiset. The second line of each query contains $$$n$$$ integers $$$s_1, s_2, \dots, s_n$$$ ($$$1 \le s_i \le 2^{29}$$$) — the description of the multiset. It is guaranteed that all elements of the multiset are powers of two.

For each query print YES if it is possible to obtain the number $$$2048$$$ in your multiset, and NO otherwise. You may print every letter in any case you want (so, for example, the strings yEs, yes, Yes and YES will all be recognized as positive answer).

NoteIn the first query you can win as follows: choose $$$512$$$ and $$$512$$$, and $$$s$$$ turns into $$$\{1024, 64, 1024\}$$$. Then choose $$$1024$$$ and $$$1024$$$, and $$$s$$$ turns into $$$\{2048, 64\}$$$ and you win.In the second query $$$s$$$ contains $$$2048$$$ initially.

import           Control.Monad (replicateM_)

main = do
  q <- read <$> getLine :: IO Int
  replicateM_ q (readQuery >>= ((putStrLn . (\x -> if x then "YES" else "No")) . solve))

readQuery :: IO [Int]
readQuery = do
  n <- read <$> getLine :: IO Int
  map read . words <$> getLine :: IO [Int]

solve :: [Int] -> Bool
solve = findAmount 2048 1
  where
    findAmount required amount xs
      | length (filter (== required) xs) >= amount = True
      | required == 1 = False
      | otherwise = findAmount (required `div` 2) ((amount - length (filter (== required) xs)) * 2) xs

import Data.List
import Data.Int
import qualified Data.Array as A
import qualified Data.Map.Strict as MS
import Data.Array((!))
import Numeric

fastRead :: String -> Int64
fastRead ('-':s) = case readDec s of [(n, "")] -> -n
fastRead s = case readDec s of [(n, "")] -> n

main = interact solve

solve input =
  let asnums :: [Int]
      asnums = map read $ words input
      (n:xs) = asnums
      testcases :: [[Int]]
      testcases = parseTestCases xs
      answers = map (boolToString.solve') testcases
      boolToString True = "YES"
      boolToString False = "NO"
  in intercalate "\n" answers

parseTestCases :: [Int] -> [[Int]]
parseTestCases [] = []
parseTestCases (n:xs) =
  let (here,next) = splitAt n xs
  in (here:parseTestCases next)

solve' :: [Int] -> Bool
solve' [] = False
solve' inp =
  let baseSet :: MS.Map Int Int
      baseSet = foldl addToMap (MS.empty) inp
      reducedSet = reduceSet baseSet
      addToMap :: MS.Map Int Int -> Int -> MS.Map Int Int
      addToMap map num = MS.insertWith (+) num 1 map
      answer = case (MS.keys reducedSet) of (2048:_) -> True
                                            _ -> False
  in answer

reduceSet :: MS.Map Int Int -> MS.Map Int Int
reduceSet inp
  | isEmpty = MS.empty
  | lowestKey == 2048 = inp
  | lowestCount == 1 = reduceSet $ MS.delete lowestKey inp
  | otherwise = reduceSet $ MS.delete lowestKey $ MS.insertWith (+) (lowestKey*2) (div lowestCount 2) inp
  where
    isEmpty = (MS.size inp) == 0
    lowestKey :: Int
    (lowestKey:_) = MS.keys inp
    lowestCount :: Int
    Just lowestCount = MS.lookup lowestKey inp

{-# OPTIONS_GHC -O3 #-}

import Control.Monad ( replicateM_ )

main = do
  n <- fmap read getLine
  replicateM_ n $ do
    getLine
    s <- fmap (filter (<= 2048) . fmap read . words) getLine
    putStrLn $ if sum s >= 2048 then "yes" else "no"

import           Control.Monad (replicateM_)

main = do
  q <- read <$> getLine :: IO Int
  replicateM_ q (readQuery >>= ((print . (\x -> if x then "YES" else "No")) . solve))

readQuery :: IO [Int]
readQuery = do
  n <- read <$> getLine :: IO Int
  map read . words <$> getLine :: IO [Int]

solve :: [Int] -> Bool
solve = findAmount 2048 1
  where
    findAmount required amount xs
      | length (filter (== required) xs) >= amount = True
      | required == 1 = False
      | otherwise = findAmount (required `div` 2) ((amount - length (filter (== required) xs)) * 2) xs


Leha like all kinds of strange things. Recently he liked the function F(n, k). Consider all possible k-element subsets of the set [1, 2, ..., n]. For subset find minimal element in it. F(n, k) — mathematical expectation of the minimal element among all k-element subsets.But only function does not interest him. He wants to do interesting things with it. Mom brought him two arrays A and B, each consists of m integers. For all i, j such that 1 ≤ i, j ≤ m the condition Ai ≥ Bj holds. Help Leha rearrange the numbers in the array A so that the sum  is maximally possible, where A' is already rearranged array.

First line of input data contains single integer m (1 ≤ m ≤ 2·105) — length of arrays A and B. Next line contains m integers a1, a2, ..., am (1 ≤ ai ≤ 109) — array A. Next line contains m integers b1, b2, ..., bm (1 ≤ bi ≤ 109) — array B.

Output m integers a'1, a'2, ..., a'm — array A' which is permutation of the array A.

-- 840A

import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Binary.Builder as BU
import Data.Maybe (fromJust)
import Control.Monad (forM_)
import Data.List (sortBy)
import Data.Array.ST.Safe
import Data.Array.IArray

main = B.getContents >>= output . program . input
    where input = (map . map) (fst . fromJust . B.readInt)
                . map B.words
                . B.lines
          output = putStrLn . unwords . map show

program :: [[Int]] -> [Int]
program ([n]:a:b:_) = buildArray n $ zip bIndices aSorted
    where aSorted = sortBy (flip compare) a
          bIndices = map fst $
            sortBy (\x y -> compare (snd x) (snd y)) $
              zip ([1..] :: [Int]) b

buildArray :: Int -> [(Int, Int)] -> [Int]
buildArray n pairs = elems $ runSTUArray $ do
  arr <- newArray (1, n) 0
  forM_ pairs $ \(i, v) ->
    writeArray arr i v
  return arr

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

main = B.getContents >>= putStr . unwords . map show . evalState app . B.words

app = do
  n <- poi
  as <- replicateM n poi
  bs <- replicateM n poi
  return $ solve n as bs
  where
    pop = state $ \(x:xs) -> (x, xs)
    poi = fmap int pop
    int = maybe undefined fst . B.readInt

solve n as bs = (elems :: UArray Int Int -> [Int]) $ array (1, n) $ flip zip (sortBy (flip compare) as) $ map fst $ sortBy (compare `on` snd) $ zip [1..] bs

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

main = B.getContents >>= B.putStr . B.unwords . map (B.pack . show) . evalState app . B.words

app = do
  n <- poi
  as <- replicateM n poi
  bs <- replicateM n poi
  return $ solve n as bs
  where
    pop = state $ \(x:xs) -> (x, xs)
    poi = fmap int pop
    int = maybe undefined fst . B.readInt

solve n as bs = (elems :: UArray Int Int -> [Int]) $ array (1, n) $ flip zip (sortBy (flip compare) as) $ map fst $ sortBy (compare `on` snd) $ zip [1..] bs

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

import qualified Data.ByteString as B (getLine)
import qualified Data.ByteString.Char8 as C (readInt, words)
import qualified Data.Maybe as M (fromJust)
import qualified Data.List as L (sort, sortBy, intercalate)

readInt = fst . M.fromJust . C.readInt

main = do
    (readInt -> n) <- B.getLine
    (map readInt . C.words -> as) <- B.getLine
    (map readInt . C.words -> bs) <- B.getLine
    let bss = L.sortBy (\a b -> compare (snd a) (snd b)) (zip [1..] bs)
        ass = reverse $ L.sort as
        css = map (\(a, (b, c)) -> (a, b)) (zip ass bss)
        dss = map fst $ L.sortBy (\a b -> compare (snd a) (snd b)) css
    putStrLn $ L.intercalate " " $ map show dss

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

main = B.getContents >>= mapM_ print . evalState app . B.words

app = do
  n <- poi
  as <- replicateM n poi
  bs <- replicateM n poi
  return $ solve n as bs
  where
    pop = state $ \(x:xs) -> (x, xs)
    poi = fmap int pop
    int = maybe undefined fst . B.readInt

solve n as bs = (elems :: UArray Int Int -> [Int]) $ array (1, n) $ flip zip (sortBy (flip compare) as) $ map fst $ sortBy (compare `on` snd) $ zip [1..] bs


Your friend Salem is Warawreh's brother and only loves math and geometry problems. He has solved plenty of such problems, but according to Warawreh, in order to graduate from university he has to solve more graph problems. Since Salem is not good with graphs he asked your help with the following problem.  You are given a complete directed graph with $$$n$$$ vertices without self-loops. In other words, you have $$$n$$$ vertices and each pair of vertices $$$u$$$ and $$$v$$$ ($$$u \neq v$$$) has both directed edges $$$(u, v)$$$ and $$$(v, u)$$$.Every directed edge of the graph is labeled with a single character: either 'a' or 'b' (edges $$$(u, v)$$$ and $$$(v, u)$$$ may have different labels).You are also given an integer $$$m > 0$$$. You should find a path of length $$$m$$$ such that the string obtained by writing out edges' labels when going along the path is a palindrome. The length of the path is the number of edges in it.You can visit the same vertex and the same directed edge any number of times.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 500$$$) — the number of test cases. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$2 \leq n \leq 1000$$$; $$$1 \leq m \leq 10^{5}$$$) — the number of vertices in the graph and desirable length of the palindrome. Each of the next $$$n$$$ lines contains $$$n$$$ characters. The $$$j$$$-th character of the $$$i$$$-th line describes the character on the edge that is going from node $$$i$$$ to node $$$j$$$. Every character is either 'a' or 'b' if $$$i \neq j$$$, or '*' if $$$i = j$$$, since the graph doesn't contain self-loops. It's guaranteed that the sum of $$$n$$$ over test cases doesn't exceed $$$1000$$$ and the sum of $$$m$$$ doesn't exceed $$$10^5$$$.

For each test case, if it is possible to find such path, print "YES" and the path itself as a sequence of $$$m + 1$$$ integers: indices of vertices in the path in the appropriate order. If there are several valid paths, print any of them. Otherwise, (if there is no answer) print "NO".

5
3 1
*ba
b*b
ab*
3 3
*ba
b*b
ab*
3 4
*ba
b*b
ab*
4 6
*aaa
b*ba
ab*a
bba*
2 6
*a
b*

NoteThe graph from the first three test cases is shown below:  In the first test case, the answer sequence is $$$[1,2]$$$ which means that the path is:$$$$$$1 \xrightarrow{\text{b}} 2$$$$$$So the string that is obtained by the given path is b.In the second test case, the answer sequence is $$$[2,1,3,2]$$$ which means that the path is:$$$$$$2 \xrightarrow{\text{b}} 1 \xrightarrow{\text{a}} 3 \xrightarrow{\text{b}} 2$$$$$$So the string that is obtained by the given path is bab.In the third test case, the answer sequence is $$$[1,3,1,3,1]$$$ which means that the path is:$$$$$$1 \xrightarrow{\text{a}} 3 \xrightarrow{\text{a}} 1 \xrightarrow{\text{a}} 3 \xrightarrow{\text{a}} 1$$$$$$So the string that is obtained by the given path is aaaa.The string obtained in the fourth test case is abaaba.

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

import qualified Data.ByteString.Lazy.Char8 as L
-- Using lazy only would probably be OK.
import qualified Data.ByteString.Char8 as S

import Data.Array.IArray

type SIO = StateT L.ByteString IO

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

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

insertionTopoSort :: (t -> t -> Ordering) -> [t] -> Either [t] [t]
-- returns (Left cycle) or (Right sortedVersion)
insertionTopoSort cmp = let
  go pref [] = Right pref
  go pref (x:xs) = let
    (le, ri) = span (\y -> cmp y x == LT) pref
    in  case  span (\y -> cmp x y == LT) ri  of
    (_, []) -> go (le ++ [x] ++ ri) xs
    (ys, z:_) -> case  cmp z x  of
      LT -> Left $ z : x : ys
      EQ -> Left [z, x]
      GT -> error "ordering function given is not antisymmetric"
  in  go []

main :: IO ()
main = (L.getContents >>=) . evalStateT $ do
  [t] <- readInts
  replicateM_ t $ do
    [n, m] <- readInts
    qLi <- replicateM n (L.toStrict <$> readLine)
    let
      q :: Array Int S.ByteString
      q = listArray (0, n-1) qLi
      comparator i j = compare (S.index (q ! i) j) (S.index (q ! j) i)
      ans = case  insertionTopoSort comparator [0 .. n-1]  of
        Left li -> Just . take (m+1) $ cycle li
        Right order -> if  odd m
          then  Just . take (m+1) . cycle $ take 2 order
          else  if  n == 2
          then  Nothing
          else  let
          x : y : z : _ = order
          segLen = div m 2
          rStart = take segLen $ cycle [x, y]
          end    = take segLen $ cycle [z, y]
          in  Just $ reverse rStart ++ [y] ++ end
    lift $ case  ans  of
      Nothing -> L.putStrLn $ L.pack "NO"
      Just li -> do
        L.putStrLn $ L.pack "YES"
        L.putStrLn . L.pack . unwords $ map (show . (+1)) li


A permutation of length $$$n$$$ is an array consisting of $$$n$$$ distinct integers from $$$1$$$ to $$$n$$$ in arbitrary order. For example, $$$[2,3,1,5,4]$$$ is a permutation, but $$$[1,2,2]$$$ is not a permutation ($$$2$$$ appears twice in the array) and $$$[1,3,4]$$$ is also not a permutation ($$$n=3$$$ but there is $$$4$$$ in the array).Let $$$p$$$ be any permutation of length $$$n$$$. We define the fingerprint $$$F(p)$$$ of $$$p$$$ as the sorted array of sums of adjacent elements in $$$p$$$. More formally,$$$$$$F(p)=\mathrm{sort}([p_1+p_2,p_2+p_3,\ldots,p_{n-1}+p_n]).$$$$$$For example, if $$$n=4$$$ and $$$p=[1,4,2,3],$$$ then the fingerprint is given by $$$F(p)=\mathrm{sort}([1+4,4+2,2+3])=\mathrm{sort}([5,6,5])=[5,5,6]$$$.You are given a permutation $$$p$$$ of length $$$n$$$. Your task is to find a different permutation $$$p'$$$ with the same fingerprint. Two permutations $$$p$$$ and $$$p'$$$ are considered different if there is some index $$$i$$$ such that $$$p_i \ne p'_i$$$.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 668$$$). Description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$2\le n\le 100$$$)  — the length of the permutation. The second line of each test case contains $$$n$$$ integers $$$p_1,\ldots,p_n$$$ ($$$1\le p_i\le n$$$). It is guaranteed that $$$p$$$ is a permutation.

For each test case, output $$$n$$$ integers $$$p'_1,\ldots, p'_n$$$ — a permutation such that $$$p'\ne p$$$ and $$$F(p')=F(p)$$$. We can prove that for every permutation satisfying the input constraints, a solution exists. If there are multiple solutions, you may output any.

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

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

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

import qualified Data.ByteString.Char8 as B

import Data.Array.ST.Safe
import Data.STRef

-- import Debug.Trace
import Text.Printf

readInt = readLn :: IO Int
readInteger = readLn :: IO Integer
readInts = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine
readIntegers = map ( fst . fromJust . B.readInteger ) . B.words <$> B.getLine

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

modifyArray a i f = writeArray a i =<< f <$> readArray a i

printList [a] = print a
printList (a:as) = putStr ( show a ) >> putChar ' ' >> printList as

main = readInt >>= flip replicateM solve

solve = getLine >> readInts >>= printList . reverse

import Control.Monad

main = do
  t <- read <$> getLine
  replicateM_ t $ do
    n <- getLine
    as <- words <$> getLine
    putStrLn $ unwords $ reverse $ as

{-# LANGUAGE OverloadedStrings #-}
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.Functor
import Data.Array.Unboxed as UA
import qualified Data.ByteString.Char8 as B8
import Text.Printf

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

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    forM_ [1..t] $ \_ -> do
        n <- B8.getLine <&> readIntB8
        ps <- B8.getLine <&> B8.words <&> map readIntB8
        let answer = reverse ps
        forM_ answer $ printf "%d "
        printf "\n"


Vasya bought the collected works of a well-known Berland poet Petya in n volumes. The volumes are numbered from 1 to n. He thinks that it does not do to arrange the book simply according to their order. Vasya wants to minimize the number of the disposition’s divisors — the positive integers i such that for at least one j (1 ≤ j ≤ n) is true both: j mod i = 0 and at the same time p(j) mod i = 0, where p(j) is the number of the tome that stands on the j-th place and mod is the operation of taking the division remainder. Naturally, one volume can occupy exactly one place and in one place can stand exactly one volume.Help Vasya — find the volume disposition with the minimum number of divisors.

The first line contains number n (1 ≤ n ≤ 100000) which represents the number of volumes and free places.

Print n numbers — the sought disposition with the minimum divisor number. The j-th number (1 ≤ j ≤ n) should be equal to p(j) — the number of tome that stands on the j-th place. If there are several solutions, print any of them.

import Control.Applicative

solve n | even n = concatMap (\x->[x+1, x]) [1,3..]
        | otherwise = 1 : (concatMap (\x->[x, x-1])) [3, 5..]

main = do
  n <- read <$> getLine
  putStrLn $ unwords $ map show $ take n $ solve n

import Control.Monad
main = do
n<-getLine>>=return.read
if odd n then do{putStr"1 ";m[2,4..n-1]} else m[1,3..n-1] where m = mapM (\x->putStr(show(x+1)++" "++show x++" "))

import Prelude
import List
import Char

main = interact q

q = func.(read::String->Int)

func::Int->String
func a = solve [1..a]

fileInteract func inf ouf = do file <- readFile inf
                               writeFile ouf (func file)

toInt::String->Int
toInt = read

asInteger::String->Integer
asInteger = read

toString::Int->String
toString = show

maximum' [] = 0
maximum' a  = maximum a

solve::[Int]->String
solve a = showStr ((tail a) ++ [b])
    where
      b = head a

showStr::[Int]->String
showStr = init. foldr (\a b->(show a)++(' ':b)) ""

main = do getLine >>= putStr . unwords . map show . (\n -> n:[1..n-1]) . read

isp n = and $ map ((/=0) . (mod n)) $ takeWhile ((<=n) . (^2)) [2 ..]

gao 0 = []
gao n = gao (p - 1) ++ [n + p - i | i <- [p .. n]] where
	p = until (isp . (+n)) succ 1

main = do getLine >>= putStr . unwords . map show . gao . read

import Monad
import List

main = readLn >>= putStrLn.unwords.map show.solve

solve n = [2..n] ++ [1]

main :: IO ()
main = do
    n <- read <$> getLine
    putStrLn . unwords . map show $ n:[1..n-1]

main = do
  n <- readLn
  putStrLn $ unwords $ map show [1..n]


Farmer John has a farm that consists of $$$n$$$ pastures connected by one-directional roads. Each road has a weight, representing the time it takes to go from the start to the end of the road. The roads could have negative weight, where the cows go so fast that they go back in time! However, Farmer John guarantees that it is impossible for the cows to get stuck in a time loop, where they can infinitely go back in time by traveling across a sequence of roads. Also, each pair of pastures is connected by at most one road in each direction.Unfortunately, Farmer John lost the map of the farm. All he remembers is an array $$$d$$$, where $$$d_i$$$ is the smallest amount of time it took the cows to reach the $$$i$$$-th pasture from pasture $$$1$$$ using a sequence of roads. The cost of his farm is the sum of the weights of each of the roads, and Farmer John needs to know the minimal cost of a farm that is consistent with his memory.

The first line contains one integer $$$t$$$ ($$$1 \leq t \leq 10^4$$$) — the number of test cases. Then $$$t$$$ cases follow. The first line of each test case contains a single integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the number of pastures. The second line of each test case contains $$$n$$$ space separated integers $$$d_1, d_2, \ldots, d_n$$$ ($$$0 \leq d_i \leq 10^9$$$) — the array $$$d$$$. It is guaranteed that $$$d_1 = 0$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, output the minimum possible cost of a farm that is consistent with Farmer John's memory.

NoteIn the first test case, you can add roads   from pasture $$$1$$$ to pasture $$$2$$$ with a time of $$$2$$$,  from pasture $$$2$$$ to pasture $$$3$$$ with a time of $$$1$$$,  from pasture $$$3$$$ to pasture $$$1$$$ with a time of $$$-3$$$,  from pasture $$$3$$$ to pasture $$$2$$$ with a time of $$$-1$$$,  from pasture $$$2$$$ to pasture $$$1$$$ with a time of $$$-2$$$.  The total cost is $$$2 + 1 + -3 + -1 + -2 = -3$$$.In the second test case, you can add a road from pasture $$$1$$$ to pasture $$$2$$$ with cost $$$1000000000$$$ and a road from pasture $$$2$$$ to pasture $$$1$$$ with cost $$$-1000000000$$$. The total cost is $$$1000000000 + -1000000000 = 0$$$.In the third test case, you can't add any roads. The total cost is $$$0$$$.

--
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> [Int64] -> Int64
solve n ds = solve' 1 0 0 . tail . sort $ ds
    where
        solve' :: Int64 -> Int64 -> Int64 -> [Int64] -> Int64
        solve' _ _ _ [] = 0
        solve' kDs sDs lDs ds@(d:pDs) = (d - lDs) - kDs * d + sDs + solve' (succ kDs) (sDs + d) d pDs

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        ds :: [Int64] <- B8.getLine <&> readIntegerB8s <&> map fromInteger
        let answer = solve n ds
        printf "%lld\n" answer

import Control.Monad ( replicateM_ )
import Data.Int ( Int64 )
import Data.List ( sort, tails, zipWith4 )

solve :: IO()
solve = do
    n <- readInt <$> getLine
    as <- sort . map readInt64 . words <$> getLine
    let calc i ai alast slast = slast + (ai - alast) * fromIntegral i
        dp = 0 : zipWith4 calc [1..] (tail as) as dp
    print $ as !! (n - 1) - sum dp

readInt :: String -> Int
readInt = read

readInt64 :: String -> Int64
readInt64 = read

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

{-# OPTIONS_GHC -XStrict -XStrictData #-}
{-# LANGUAGE FlexibleContexts #-}
import qualified Data.ByteString.Char8 as BS
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST
import Data.Array.Unboxed
import Data.Bifunctor
import Data.Bits
import Data.Bool
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Tuple
import qualified Data.IntSet as IS
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import Data.STRef.Strict
import System.IO
import System.IO.Unsafe

(><) a b = a Seq.>< b

deb name s e = seq s unsafePerformIO $! do
    hPutStrLn stderr $ " " ++ name ++ " = " ++ show s
    return e

parseInt = fst . fromJust . BS.readInt
parseInteger = fst . fromJust . BS.readInteger

modifyArray f a i = readArray a i >>= \v -> writeArray a i (f v)

solve :: Int64 -> [Int64] -> Int64
solve n xs =
    let ws = [i*(n-i) | i <- [1..n-1]]
        ys = zipWith (-) xs (drop 1 xs)
    in
        sum $ zipWith (\w y -> (w-1)*y) ws ys

main = do
    tn <- parseInt <$> BS.getLine
    replicateM_ tn $ do
        n <- fromIntegral . parseInt <$> BS.getLine
        xs <- map (fromIntegral . parseInt) . BS.words <$> BS.getLine
        print $ solve n (sort xs)

--
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DatatypeContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TupleSections #-}

import Control.Arrow ((>>>))
import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )
import qualified Control.Monad.ST.Strict as ST
import qualified Control.Monad.State.Strict as S

import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.IO.Safe as IOA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import Data.Bits
import qualified Data.ByteString.Char8 as B8
import Data.Char
import Data.Int

import Data.Function (on)
import Data.Functor ((<&>))
import Data.Bifunctor (bimap)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Maybe as MB

import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.List   as L
import Data.List (
    elemIndices,
    find,
    findIndices,
    intersect,
    isPrefixOf,
    nub,
    sort,
    sortOn,
 )
import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad.Cont (MonadIO (liftIO))
import Data.IORef (modifyIORef, newIORef, readIORef)
import GHC.IO.Handle (hDuplicateTo)
import System.IO (
    IOMode (ReadMode, WriteMode),
    openFile,
    stdin,
    stdout,
    hFlush
 )
import System.Posix.Internals (puts)
import Text.Printf (printf)
import qualified Data.Array.IO.Safe as UOA

-- import Debug.Trace (trace, traceM, traceShowM)
-- debug = flip trace

readIntB8 :: B8.ByteString -> Int
readIntB8 = B8.readInt >>> (fst . fromJust)

readIntB8s :: B8.ByteString -> [Int]
readIntB8s = B8.words >>> map (B8.readInt >>> (fst . fromJust))

readIntegerB8 :: B8.ByteString -> Integer
readIntegerB8 = B8.readInteger >>> (fst . fromJust)

readIntegerB8s :: B8.ByteString -> [Integer]
readIntegerB8s = B8.words >>> map (B8.readInteger >>> (fst . fromJust))

modifyArray :: (MA.MArray a e m, MA.Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray arr ix f = do
    value <- MA.readArray arr ix
    MA.writeArray arr ix $ f value

putsYesNo :: Bool -> IO ()
putsYesNo value = do
    let result :: String =
            if value
                then "YES"
                else "NO"
    printf "%s\n" result

{- END OF GENERAL -}

solve :: Int -> [Int64] -> Int64
solve n ds = solve' 1 0 0 $ tail ds
    where
        solve' :: Int64 -> Int64 -> Int64 -> [Int64] -> Int64
        solve' _ _ _ [] = 0
        solve' kDs sDs lDs ds@(d:pDs) = (d - lDs) - kDs * d + sDs + solve' (succ kDs) (sDs + d) d pDs

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        ds :: [Int64] <- B8.getLine <&> readIntegerB8s <&> map fromInteger
        let answer = solve n ds
        printf "%lld\n" answer


You are given an integer $$$n$$$.You can perform any of the following operations with this number an arbitrary (possibly, zero) number of times:   Replace $$$n$$$ with $$$\frac{n}{2}$$$ if $$$n$$$ is divisible by $$$2$$$;  Replace $$$n$$$ with $$$\frac{2n}{3}$$$ if $$$n$$$ is divisible by $$$3$$$;  Replace $$$n$$$ with $$$\frac{4n}{5}$$$ if $$$n$$$ is divisible by $$$5$$$. For example, you can replace $$$30$$$ with $$$15$$$ using the first operation, with $$$20$$$ using the second operation or with $$$24$$$ using the third operation.Your task is to find the minimum number of moves required to obtain $$$1$$$ from $$$n$$$ or say that it is impossible to do it.You have to answer $$$q$$$ independent queries.

The first line of the input contains one integer $$$q$$$ ($$$1 \le q \le 1000$$$) — the number of queries. The next $$$q$$$ lines contain the queries. For each query you are given the integer number $$$n$$$ ($$$1 \le n \le 10^{18}$$$).

Print the answer for each query on a new line. If it is impossible to obtain $$$1$$$ from $$$n$$$, print -1. Otherwise, print the minimum number of moves required to do it.

{-# LANGUAGE TypeApplications #-}
main = interact $ unlines . map (show . solve . read @Integer) . tail . lines
solve n = go n 0 where
  go 1 a = a
  go n a | (q,0) <- n `divMod` 5 = go q $! a+3
         | (q,0) <- n `divMod` 3 = go q $! a+2
         | (q,0) <- n `divMod` 2 = go q $! a+1
         | otherwise = -1

-- https://github.com/minoki/my-atcoder-solutions
{-# LANGUAGE BangPatterns #-}
import Data.Int
import Control.Monad

solve :: Int64 -> Int
solve 0 = error "invalid input"
solve n = let (e2, n') = factorMultiplicity 2 n
              (e3, n'') = factorMultiplicity 3 n'
              (e5, n''') = factorMultiplicity 5 n''
          in if n''' == 1
             then e2 + 2 * e3 + 3 * e5
             else -1
  where
    factorMultiplicity :: Int64 -> Int64 -> (Int, Int64)
    factorMultiplicity !p = loop 0
      where loop !k !n = case n `quotRem` p of
                           (q,0) -> loop (k + 1) q
                           _ -> (k, n)

main = do
  q <- readLn
  replicateM_ q (solve <$> readLn >>= print)

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

process n a | a==1 = n
            | mod a 5 ==0 = process (n+1) (div (a*4) 5)
	    | mod a 3 ==0 = process (n+1) (div (a*2) 3)
	    | mod a 2 ==0 = process (n+1) (div a 2)
	    | otherwise = -1

process1 = do
		a<- read <$> getLine ::IO Integer
		print $ process 0 a

main = do
		n<-read <$> getLine ::IO Int
		replicateM_ n process1

countFactor :: Integer -> Integer -> (Integer, Integer)
countFactor d n = (fromIntegral (length c),n')
    where (c,n':_) = span ((==0).(`mod` d)) $ iterate (`div` d) n

--process :: Integer -> Integer
process n
    | n' == 1 = sum $ zipWith (*) [1,2,3] $ fst $ unzip xs
    | otherwise = -1
    where
        xs@((_,n'):_) = scanr f (0,n) [2,3,5]
        f = \x (_,t) -> countFactor x t

readInt :: String -> Integer
readInt = read

main :: IO ()
main = do
    q <- fmap readInt getLine
    ns <- fmap (map readInt.words) getContents
    mapM_ print $ map process ns

subN' :: Integer -> Int -> Int
subN' x c
    | x == 1 = c
    | mod x 5 == 0 = subN' (div (x*4) 5) (c+1)
    | mod x 3 == 0 = subN' (div (x*2) 3) (c+1)
    | mod x 2 == 0 = subN' (div x 2) (c+1)
    | otherwise = -1

subN :: Integer -> Int
subN x = subN' x 0

solve :: [Integer] -> [Int]
solve xs = map subN xs

main = interact $ unlines . map show . solve . map (read::String->Integer) . tail . words

subN' :: Integer -> Int -> Int
subN' x c
    | x == 1 = c
    | mod x 5 == 0 = subN' (div (x*4) 5) (c+1)
    | mod x 3 == 0 = subN' (div (x*2) 3) (c+1)
    | mod x 2 == 0 = subN' (div x 2) (c+1)
    | otherwise = -1

subN :: Integer -> Int
subN x = subN' x 0

solve :: [Integer] -> [Int]
solve xs = map subN xs

main = interact $ unlines . map show . solve . map (read::String->Integer) . words


You are given an integer array $$$a$$$ of length $$$n$$$. Does there exist an array $$$b$$$ consisting of $$$n+1$$$ positive integers such that $$$a_i=\gcd (b_i,b_{i+1})$$$ for all $$$i$$$ ($$$1 \leq i \leq n$$$)? Note that $$$\gcd(x, y)$$$ denotes the greatest common divisor (GCD) of integers $$$x$$$ and $$$y$$$.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \leq t \leq 10^5$$$). Description of the test cases follows. The first line of each test case contains an integer $$$n$$$ ($$$1 \leq n \leq 10^5$$$) — the length of the array $$$a$$$. The second line of each test case contains $$$n$$$ space-separated integers $$$a_1,a_2,\ldots,a_n$$$ representing the array $$$a$$$ ($$$1 \leq a_i \leq 10^4$$$). It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case, output "YES" if such $$$b$$$ exists, otherwise output "NO". You can print each letter in any case (upper or lower).

NoteIn the first test case, we can take $$$b=[343,343]$$$.In the second test case, one possibility for $$$b$$$ is $$$b=[12,8,6]$$$.In the third test case, it can be proved that there does not exist any array $$$b$$$ that fulfills all the conditions.

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

main :: IO ()
main = do
    [t] <- getInts
    replicateM_ t $ do
        _ <- getInts
        as <- getInts
        let bs = zipWith lcm as (tail as)
            cs = zipWith gcd bs (drop 1 bs)
            ok = and $ zipWith (==) cs (tail as)
        putStrLn $ if ok then "YES" else "NO"

getInts :: IO [Int]
getInts = map (fst . fromJust . C.readInt) . C.words <$> C.getLine


Alice and Bob play a game. Initially they have a string $$$s_1, s_2, \dots, s_n$$$, consisting of only characters . and X. They take alternating turns, and Alice is moving first. During each turn, the player has to select a contiguous substring consisting only of characters . and replaces each of them with X. Alice must select a substing of length $$$a$$$, and Bob must select a substring of length $$$b$$$. It is guaranteed that $$$a > b$$$.For example, if $$$s =$$$ ...X.. and $$$a = 3$$$, $$$b = 2$$$, then after Alice's move string can turn only into XXXX... And if it's Bob's turn and the string $$$s =$$$ ...X.., then after Bob's move the string can turn into XX.X.., .XXX.. or ...XXX.Whoever is unable to make a move, loses. You have to determine who wins if they both play optimally.You have to answer $$$q$$$ independent queries.

The first line contains one integer $$$q$$$ ($$$1 \le q \le 3 \cdot 10^5$$$) — the number of queries. The first line of each query contains two integers $$$a$$$ and $$$b$$$ ($$$1 \le b < a \le 3 \cdot 10^5$$$). The second line of each query contains the string $$$s$$$ ($$$1 \le |s| \le 3 \cdot 10^5$$$), consisting of only characters . and X. It is guaranteed that sum of all $$$|s|$$$ over all queries not exceed $$$3 \cdot 10^5$$$.

For each test case print YES if Alice can win and NO otherwise. You may print every letter in any case you want (so, for example, the strings yEs, yes, Yes and YES will all be recognized as positive answer).

NoteIn the first query Alice can select substring $$$s_3 \dots s_5$$$. After that $$$s$$$ turns into XXXXX...XX...X. After that, no matter what move Bob makes, Alice can make the move (this will be her second move), but Bob can't make his second move.In the second query Alice can not win because she cannot even make one move.In the third query Alice can choose substring $$$s_2 \dots s_6$$$. After that $$$s$$$ turns into .XXXXX.X..X, and Bob can't make a move after that.

import qualified Data.ByteString.Char8 as C8
import Control.Monad

main :: IO ()
main = do
  n <- read <$> getLine
  replicateM_ n $ do
    [a, b] <- (map read . words) <$> getLine
    l <- (filter (>=b) . map C8.length . filter ((=='.') . C8.head) . C8.group) <$> C8.getLine
    putStrLn $ if solve a b l then "Yes" else "No"

solve :: Int -> Int -> [Int] -> Bool
solve a b l
  | midCount > 1 = False
  | any (< a) l = False
  | midCount == 1 = midSolve (maximum l)
  | otherwise = odd $ length l
  where midCount = (length $ filter (>= 2 * b) l)
        midSolve q = (canSplitInto0 q && (odd  . length) l) ||
                     (canSplitInto1 q && (even . length) l) ||
                     (canSplitInto2 q && (odd  . length) l)
        canSplitInto0 q = any (\x -> q - a - x < b && x < b) [0..q-a]
        canSplitInto1 q = any (\x -> q - a - x < b && x >= a && x < (b+b)) [0..q-a]
        canSplitInto2 q = any (\x -> (q-a-x) >= a && (q-a-x) < (b+b) && x >= a && x < (b+b)) [0..q-a]

import qualified Data.ByteString.Char8 as C8
import Control.Monad

main :: IO ()
main = do
  n <- read <$> getLine
  replicateM_ n $ do
    [a, b] <- (map read . words) <$> getLine
    l <- (filter (>=b) . map C8.length . filter ((=='.') . C8.head) . C8.group) <$> C8.getLine
    putStrLn $ if solve a b l then "Yes" else "No"

solve :: Int -> Int -> [Int] -> Bool
solve a b l
  | midCount > 1 = False
  | any (< a) l = False
  | midCount == 1 = midSolve (maximum l)
  | otherwise = odd $ length l
  where midCount = (length $ filter (>= 2 * b) l)
        midSolve q = (canSplitInto0 q && (odd  . length) l) ||
                     (canSplitInto1 q && (even . length) l) ||
                     (canSplitInto2 q && (odd  . length) l)
        canSplitInto0 q = any (\x -> q - a - x < b && x < b) [0..q-a]
        canSplitInto1 q = any (\x -> q - a - x < b && x >= b && x < (b+b)) [0..q-a]
        canSplitInto2 q = any (\x -> (q-a-x) >= b && (q-a-x) < (b+b) && x >= b && x < (b+b)) [0..q-a]

import qualified Data.ByteString.Char8 as C8
import Control.Monad

main :: IO ()
main = do
  n <- read <$> getLine
  replicateM_ n $ do
    [a, b] <- (map read . words) <$> getLine
    l <- (filter (>=b) . map C8.length . filter ((=='.') . C8.head) . C8.group) <$> C8.getLine
    putStrLn $ if solve a b l then "Yes" else "No"

solve :: Int -> Int -> [Int] -> Bool
solve a b l
  | midCount > 1 = False
  | any (< a) l = False
  | midCount == 1 = midSolve (maximum l)
  | otherwise = odd $ length l
  where midCount = (length $ filter (>= 2 * b) l)
        midSolve q = (canSplitInto0 q && (odd  . length) l) ||
                     (canSplitInto1 q && (even . length) l) ||
                     (canSplitInto2 q && (odd  . length) l)
        canSplitInto0 q = any (\x -> q - a - x < b && x < b) [0..q-a]
        canSplitInto1 q = any (\x -> q - a - x < b && x >= b && x < (a+b)) [0..q-a]
        canSplitInto2 q = any (\x -> (q-a-x) >= b && (q-a-x) < (a+b) && x >= b && x < (a+b)) [0..q-a]


Прошло много лет, и на вечеринке снова встретились n друзей. С момента последней встречи техника шагнула далеко вперёд, появились фотоаппараты с автоспуском, и теперь не требуется, чтобы один из друзей стоял с фотоаппаратом, и, тем самым, оказывался не запечатлённым на снимке.Упрощенно процесс фотографирования можно описать следующим образом. На фотографии каждый из друзей занимает прямоугольник из пикселей: в стоячем положении i-й из них занимает прямоугольник ширины wi пикселей и высоты hi пикселей. Но также, при фотографировании каждый человек может лечь, и тогда он будет занимать прямоугольник ширины hi пикселей и высоты wi пикселей.Общая фотография будет иметь размеры W × H, где W — суммарная ширина всех прямоугольников-людей, а H — максимальная из высот. Друзья хотят определить, какую минимальную площадь может иметь общая фотография. Помогите им в этом.

В первой строке следует целое число n (1 ≤ n ≤ 1000) — количество друзей. В последующих n строках следуют по два целых числа wi, hi (1 ≤ wi, hi ≤ 1000), обозначающие размеры прямоугольника, соответствующего i-му из друзей.

Выведите единственное целое число, равное минимальной возможной площади фотографии, вмещающей всех друзей.

import Data.List (sortBy)
import Control.Monad (replicateM)
import Data.Tuple (swap)

type Man = (Integer, Integer) -- w, h

minDim :: Man -> Integer
minDim (a, b) = min a b

maxDim (a, b) = max a b

minDimRes :: Integer -> Man -> Integer
minDimRes h m@(a, b) = if (max a b) > h then max a b else minDim m

go f (ls, m, []) = [f ls m []]
go f (ls, m, r:rs) = f ls m (r:rs) : go f (m:ls, r, rs)

solution :: [Man] -> Integer
solution ms = let mh = maximum $ map minDim ms
                  f ls m rs = if snd m < mh then 10^13
                                            else (snd m)*(fst m + (sum $ map (minDimRes (snd m)) (ls ++ rs)))
                  f' ls m rs = min (f ls m rs) (f ls (swap m) rs)
              in minimum $ go f' ([], head ms, tail ms)

readPair :: IO (Integer, Integer)
readPair = fmap (f . map read . words) getLine
         where f [a, b] = (a, b)

main = do
    n <- read `fmap` getLine
    men <- replicateM n readPair
    print $ solution men


There are two rival donut shops.The first shop sells donuts at retail: each donut costs $$$a$$$ dollars.The second shop sells donuts only in bulk: box of $$$b$$$ donuts costs $$$c$$$ dollars. So if you want to buy $$$x$$$ donuts from this shop, then you have to buy the smallest number of boxes such that the total number of donuts in them is greater or equal to $$$x$$$.You want to determine two positive integer values:   how many donuts can you buy so that they are strictly cheaper in the first shop than in the second shop?  how many donuts can you buy so that they are strictly cheaper in the second shop than in the first shop? If any of these values doesn't exist then that value should be equal to $$$-1$$$. If there are multiple possible answers, then print any of them.The printed values should be less or equal to $$$10^9$$$. It can be shown that under the given constraints such values always exist if any values exist at all.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of testcases. Each of the next $$$t$$$ lines contains three integers $$$a$$$, $$$b$$$ and $$$c$$$ ($$$1 \le a \le 10^9$$$, $$$2 \le b \le 10^9$$$, $$$1 \le c \le 10^9$$$).

For each testcase print two positive integers. For both shops print such $$$x$$$ that buying $$$x$$$ donuts in this shop is strictly cheaper than buying $$$x$$$ donuts in the other shop. $$$x$$$ should be greater than $$$0$$$ and less or equal to $$$10^9$$$. If there is no such $$$x$$$, then print $$$-1$$$. If there are multiple answers, then print any of them.

NoteIn the first testcase buying any number of donuts will be cheaper in the second shop. For example, for $$$3$$$ or $$$5$$$ donuts you'll have to buy a box of $$$10$$$ donuts for $$$4$$$ dollars. $$$3$$$ or $$$5$$$ donuts in the first shop would cost you $$$15$$$ or $$$25$$$ dollars, respectively, however. For $$$20$$$ donuts you'll have to buy two boxes for $$$8$$$ dollars total. Note that $$$3$$$ and $$$5$$$ are also valid answers for the second shop, along with many other answers.In the second testcase buying any number of donuts will be either cheaper in the first shop or the same price. $$$8$$$ donuts cost $$$32$$$ dollars in the first shop and $$$40$$$ dollars in the second shop (because you have to buy two boxes). $$$10$$$ donuts will cost $$$40$$$ dollars in both shops, so $$$10$$$ is not a valid answer for any of the shops.In the third testcase $$$1$$$ donut costs $$$2$$$ and $$$3$$$ dollars, respectively. $$$2$$$ donuts cost $$$4$$$ and $$$3$$$ dollars. Thus, $$$1$$$ is a valid answer for the first shop and $$$2$$$ is a valid answer for the second shop.In the fourth testcase $$$10^9$$$ donuts cost $$$10^{18}$$$ dollars in the first shop and $$$10^9$$$ dollars in the second shop.

import Data.List
dec :: (Int) -> (Int)
dec x = x - 1

solve :: [Int] -> [Int]
solve (x:1:z:_)
    | x < z = [1 , -1]
    | x == z = [-1 , -1]
    | x > z = [-1 , 1]
solve (x:y:z:_)
    | x >= z = [-1 , y]
    | x <= (div z y) = [1 , -1]
    | x > (div z y) = [1 , y]

test :: (Int) -> IO()
test 0 = return()
test x = do
    t <- getLine
    let arr = map (\a -> read a :: Int ) $ words t
    let ans = solve arr
    let out = unwords $ map (\a -> show a ) ans
    putStrLn out
    test (x - 1)

main = do
    t <- getLine
    let x = read t :: Int

    test x


Sergei B., the young coach of Pokemons, has found the big house which consists of n flats ordered in a row from left to right. It is possible to enter each flat from the street. It is possible to go out from each flat. Also, each flat is connected with the flat to the left and the flat to the right. Flat number 1 is only connected with the flat number 2 and the flat number n is only connected with the flat number n - 1.There is exactly one Pokemon of some type in each of these flats. Sergei B. asked residents of the house to let him enter their flats in order to catch Pokemons. After consulting the residents of the house decided to let Sergei B. enter one flat from the street, visit several flats and then go out from some flat. But they won't let him visit the same flat more than once. Sergei B. was very pleased, and now he wants to visit as few flats as possible in order to collect Pokemons of all types that appear in this house. Your task is to help him and determine this minimum number of flats he has to visit.

The first line contains the integer n (1 ≤ n ≤ 100 000) — the number of flats in the house. The second line contains the row s with the length n, it consists of uppercase and lowercase letters of English alphabet, the i-th letter equals the type of Pokemon, which is in the flat number i.

Print the minimum number of flats which Sergei B. should visit in order to catch Pokemons of all types which there are in the house.

NoteIn the first test Sergei B. can begin, for example, from the flat number 1 and end in the flat number 2.In the second test Sergei B. can begin, for example, from the flat number 4 and end in the flat number 6. In the third test Sergei B. must begin from the flat number 2 and end in the flat number 6.

import Data.List
import Data.Array
import Data.Maybe
import qualified Data.Map.Strict as M

main = do
    n <- read `fmap` getLine :: IO Int
    flats <- getLine
    let flatAry = listArray (1, length flats) flats
    let numPoke = (length . group . sort) flats
    print $ solve numPoke flatAry

type Book = M.Map Char Int
type Solution = (Book, Int, Int) -- (currSet, beginIx, endIx)

solve numPoke flats = f (M.empty, 1, 1) 100000 where
    f :: Solution -> Int -> Int
    f curr best = case walk numPoke flats curr of
        Nothing -> best
        Just next -> f (removeHead next flats) (min best (cost next))
    cost (_, b, e) = e - b

removeHead (book, b, e) flats = (book', b+1, e) where
    x = flats ! b
    book' = if book M.! x == 1 then M.delete x book else M.adjust (\y->y-1) x book

walk :: Int -> Array Int Char -> Solution -> Maybe Solution
walk num flats (book, b, e) = f book e where
    (ary1, aryN) = bounds flats
    len = aryN - ary1 + 1
    f book e
        | e > len && M.size book >= num = Just (book, b, e)
        | e > len && M.size book < num = Nothing
        | M.size book == num = Just (book, b, e)
        | otherwise = f (M.insertWith (+) (flats ! e) 1 book) (e + 1)

{-# 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 qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
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
  getLine
  s <- getLine

  let m = length $ filter (/= 0) $ elems $ accumArray (+) 0 (chr 0, chr 127) $ zip s (repeat 1)

  cs :: IOUArray Char Int <- newArray (chr 0, chr 127) 0

  let
    scan0 :: String -> Int -> Int -> IO (String, Int)
    scan0 s d k
      | k == m = return (s, d)
      | otherwise = do
        v <- readArray cs c
        writeArray cs c (v+1)
        scan0 (tail s) (d+1) (if v == 0 then k + 1 else k)
      where c = head s

  (r0, d0) <- scan0 s 0 0

  let
    scan :: String -> String -> Int -> Int -> IO Int
    scan l r d m = do
        cnt <- readArray cs c
        writeArray cs c (cnt-1)

        if cnt == 1
          then
            if null r2
               then return m
               else do
                 mapM (\c -> readArray cs c >>= \v -> writeArray cs c (v+1)) $ c:r1
                 scan l' r' d' $ min d' m
          else scan l' r (d-1) $ min (d-1) m
      where
        (c, l') = (head l, tail l)
        (r1, r2) = span (/= c) r
        r' = tail r2
        d' = d + length r1

  m <- scan s r0 d0 d0

  print m

import Data.List

main = do
    n <- read `fmap` getLine :: IO Int
    str <- getLine
    let numPoke = (length . group . sort) str
    print $ minimum [minStep n numPoke (drop i str) | i <- [0..n-numPoke+1]]

minStep n nPoke ps = f ps [] 0 where
    f [] qs step = n
    f (p:ps) qs step
        | length qs == nPoke = step
        | otherwise = f ps qs' (step+1)
        where qs' = if p `elem` qs then qs else (p:qs)

import Data.List

main = do
    n <- read `fmap` getLine :: IO Int
    str <- getLine
    let numPoke = (length . group . sort) str
    print $ minimum [minStep numPoke (drop i str) | i <- [0..n-numPoke]]

minStep nPoke ps = f ps [] 0 where
    f [] qs step = step
    f (p:ps) qs step
        | length qs == nPoke = step
        | otherwise = f ps qs' (step+1)
        where qs' = if p `elem` qs then qs else (p:qs)

import Data.List

main = do
    n <- read `fmap` getLine :: IO Int
    str <- getLine
    let numPoke = (length . group . sort) str
    print $ minimum [minStep numPoke (drop i str) | i <- [0..n-numPoke+1]]

minStep n ps = f ps [] 0 where
    f [] qs step = n + 1
    f (p:ps) qs step
        | length qs == n = step
        | otherwise = f ps qs' (step+1)
        where qs' = if p `elem` qs then qs else (p:qs)

import Data.List

main = do
    n <- read `fmap` getLine :: IO Int
    str <- getLine
    let numPoke = (length . group . sort) str
    print $ minimum [minStep numPoke (drop i str) | i <- [0..n-numPoke+1]]

minStep n ps = f ps [] 0 where
    f [] qs step = n
    f (p:ps) qs step
        | length qs == n = step
        | otherwise = f ps qs' (step+1)
        where qs' = if p `elem` qs then qs else (p:qs)

{-# 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 qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
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
  getLine
  s <- getLine

  let m = length $ filter (/= 0) $ elems $ accumArray (+) 0 (chr 0, chr 127) $ zip s (repeat 1)

  cs :: IOUArray Char Int <- newArray (chr 0, chr 127) 0

  let
    scan0 :: String -> Int -> Int -> IO (String, Int)
    scan0 s d k
      | k == m = return (s, d)
      | otherwise = do
        v <- readArray cs c
        writeArray cs c (v+1)
        scan0 (tail s) (d+1) (if v == 0 then k + 1 else k)
      where c = head s

  (r0, d0) <- scan0 s 0 0

  let
    scan :: String -> String -> Int -> Int -> IO Int
    scan _ [] _ m = return m
    scan l r d m = do
        cnt <- readArray cs c
        writeArray cs c (cnt-1)

        if cnt == 1
          then
            if null r2
               then return m
               else scan l' r' d' $ min d' m
          else scan l' r (d-1) $ min (d-1) m
      where
        (c, l') = (head l, tail l)
        (r1, r2) = span (/= c) r
        r' = tail r2
        d' = d + length r1

  m <- scan s r0 d0 d0

  print m

{-# 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 qualified Data.Foldable as F
import Data.Function
-- import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
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
  getLine
  s <- getLine

  let m = length $ filter (/= 0) $ elems $ accumArray (+) 0 (chr 0, chr 127) $ zip s (repeat 1)

  cs :: IOUArray Char Int <- newArray (chr 0, chr 127) 0

  let
    scan0 :: String -> Int -> Int -> IO (String, Int)
    scan0 s d k
      | k == m = return (s, d)
      | otherwise = do
        v <- readArray cs c
        writeArray cs c (v+1)
        scan0 (tail s) (d+1) (if v == 0 then k + 1 else k)
      where c = head s

  (r0, d0) <- scan0 s 0 0
  print (r0, d0)

  let
    scan :: String -> String -> Int -> Int -> IO Int
    scan _ [] _ m = return m
    scan l r d m = do
        cnt <- readArray cs c
        writeArray cs c (cnt-1)

        if cnt == 1
          then
            if null r2
               then return m
               else scan l' r' d' $ min d' m
          else scan l' r (d-1) $ min (d-1) m
      where
        (c, l') = (head l, tail l)
        (r1, r2) = span (/= c) r
        r' = tail r2
        d' = d + length r1

  m <- scan s r0 d0 d0

  print m


Andi and Budi were given an assignment to tidy up their bookshelf of $$$n$$$ books. Each book is represented by the book title — a string $$$s_i$$$ numbered from $$$1$$$ to $$$n$$$, each with length $$$m$$$. Andi really wants to sort the book lexicographically ascending, while Budi wants to sort it lexicographically descending.Settling their fight, they decided to combine their idea and sort it asc-desc-endingly, where the odd-indexed characters will be compared ascendingly, and the even-indexed characters will be compared descendingly.A string $$$a$$$ occurs before a string $$$b$$$ in asc-desc-ending order if and only if in the first position where $$$a$$$ and $$$b$$$ differ, the following holds:  if it is an odd position, the string $$$a$$$ has a letter that appears earlier in the alphabet than the corresponding letter in $$$b$$$;  if it is an even position, the string $$$a$$$ has a letter that appears later in the alphabet than the corresponding letter in $$$b$$$.

The first line contains two integers $$$n$$$ and $$$m$$$ ($$$1 \leq n \cdot m \leq 10^6$$$). The $$$i$$$-th of the next $$$n$$$ lines contains a string $$$s_i$$$ consisting of $$$m$$$ uppercase Latin letters — the book title. The strings are pairwise distinct.

Output $$$n$$$ integers — the indices of the strings after they are sorted asc-desc-endingly.

NoteThe following illustrates the first example.

import Control.Monad
import Data.List

comparator' :: Int -> String -> String -> Ordering
comparator' _ [] [] = EQ
comparator' 0 (a:as) (b:bs)
  | a<b = LT
  | a==b = comparator' 1 as bs
  | a>b = GT
comparator' 1 (a:as) (b:bs)
  | a<b = GT
  | a==b = comparator' 0 as bs
  | a>b = LT

comparator :: (String,Int) -> (String,Int) -> Ordering
comparator (s1,_) (s2,_) =
  comparator' 0 s1 s2

main = do
  line <- getLine
  let [n,m] = map read $ words line :: [Int]
  lines <- mapM (\_ -> do
           line <- getLine
           return line
           ) [1..n]
  let ans = map (\(_,i) -> i) $ sortBy comparator $ zip lines [1..]
  putStrLn $ intercalate " " $ map show ans

import qualified Data.ByteString.Lazy.Char8 as P
import Data.ByteString.Builder
import qualified Data.ByteString.Builder.Prim as Prim
import System.IO
import Control.Monad.Trans.State

import qualified Data.ByteString.Char8 as S
import Data.Array.Unboxed

stableBucketSortOn :: (Int -> Int) -> (Int, Int) -> [Int] -> [[Int]]
stableBucketSortOn fun = \bnds li -> let
  arr :: Array Int ([Int] -> [Int])
  arr = accumArray (\x y -> x . (y :)) id bnds [(fun x, x) | x <- li]
  in  filter (not . null) $ map ($ []) $ elems arr
{-# INLINE stableBucketSortOn #-}

mainFun :: SO
mainFun = do
  ~[n, m] <- getInts 2
  sLi <- getNext n
  let
    s :: Array Int S.ByteString
    s = listArray (1, n) $ map P.toStrict sLi
    compareAtPos x = \y -> if  even x
      then  fromEnum (S.index (s ! y) x)
      else  fromEnum 'A' + fromEnum 'Z' - fromEnum (S.index (s ! y) x)
    step :: [[Int]] -> Int -> [[Int]]
    step lis pos = do
      li <- lis
      stableBucketSortOn (compareAtPos pos) (fromEnum 'A', fromEnum 'Z') li
    ans = foldl step [[1..n]] [0 .. m-1]
  pure $ putInts $ concat ans

type SP = State [P.ByteString]
type SO = SP Builder

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

getInts :: Int -> SP [Int]
getInts k = do
  vs <- getNext k
  pure [v | Just (v, _) <- map P.readInt vs]

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

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