Polycarp loves geometric progressions very much. Since he was only three years old, he loves only the progressions of length three. He also has a favorite integer k and a sequence a, consisting of n integers.He wants to know how many subsequences of length three can be selected from a, so that they form a geometric progression with common ratio k.A subsequence of length three is a combination of three such indexes i1, i2, i3, that 1 ≤ i1 < i2 < i3 ≤ n. That is, a subsequence of length three are such groups of three elements that are not necessarily consecutive in the sequence, but their indexes are strictly increasing.A geometric progression with common ratio k is a sequence of numbers of the form b·k0, b·k1, ..., b·kr - 1.Polycarp is only three years old, so he can not calculate this number himself. Help him to do it.

The first line of the input contains two integers, n and k (1 ≤ n, k ≤ 2·105), showing how many numbers Polycarp's sequence has and his favorite number. The second line contains n integers a1, a2, ..., an ( - 109 ≤ ai ≤ 109) — elements of the sequence.

Output a single number — the number of ways to choose a subsequence of length three, such that it forms a geometric progression with a common ratio k.

NoteIn the first sample test the answer is four, as any of the two 1s can be chosen as the first element, the second element can be any of the 2s, and the third element of the subsequence must be equal to 4.

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Data.Int
import Data.Maybe
import Control.Monad
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
    (_,_k) <- readIntPair
    let k = fromIntegral _k
    as <- map fromIntegral <$> readInts
    let f x = return $ x * k
        g x = guard (mod x k == 0) >> return (div x k)
        go :: (Integer -> Maybe Integer) -> M.Map Integer Integer -> [Integer] -> [Integer]
        go _ _ [] = []
        go h m (ra:ras) = v : go h m' ras
          where !v  = fromMaybe 0 $ h ra >>= flip M.lookup m
                m'  = M.insertWith (+) ra 1 m
    let bs1 = reverse $ go f M.empty (reverse as)
        bs2 = go g M.empty as
    print $ sum $ zipWith (*) bs1 bs2

-- IO
readInt :: B.ByteString -> Int
readInt = fromJust . fmap fst . B.readInt
readInts :: IO [Int]
readInts = map readInt . B.words <$> B.getLine
readIntPair :: IO (Int,Int)
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine

-- Utilities
l2p :: [a] -> (a,a)
l2p (a:b:_) = (a,b)
l2p _ = error "l2p: the input list is too short"

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Data.Int
import Data.Maybe
import Control.Monad
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B

data State = State (M.Map Int64 Int64) (M.Map Int64 Int64) !Int64
solve :: [Int64] -> Int64 -> State -> State
solve []    _  s = s
solve (i:t) k (State c g r) = solve t k (State nc ng nr)
  where
    nc = M.insertWith (+) i 1 c
    ng = fromMaybe g $ do
            guard (i `mod` k == 0)
            v <- M.lookup (div i k) c
            return $ M.insertWith (+) (i*k) v g
    nr = r + M.findWithDefault 0 i g

solveAux :: [Int64] -> Int64 -> Int64
solveAux a k = let State _ _ r = solve a k (State M.empty M.empty 0) in r

main :: IO ()
main = do
  [n,k] <- readInts
  a     <- readInts
  print $ solveAux a k

-- IO
readInt :: B.ByteString -> Int64
readInt = fromIntegral . fromJust . fmap fst . B.readInt
readInts :: IO [Int64]
readInts = map readInt . B.words <$> B.getLine

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Data.Int
import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
    (_,_k) <- readIntPair
    let k = fromIntegral _k
    as <- map fromIntegral <$> readInts
    let f x = x * k
        g x = if mod x k == 0 then x `div` k else 2000000000
        go :: (Integer -> Integer) -> M.Map Integer Integer -> [Integer] -> [Integer]
        go _ _ [] = []
        go h m (ra:ras) = v : go h m' ras
          where !v  = M.findWithDefault 0 (h ra) m
                m'  = M.insertWith (+) ra 1 m
    let bs1 = reverse $ go f M.empty (reverse as)
        bs2 = go g M.empty as
    print $ sum $ zipWith (*) bs1 bs2

-- IO
readInt :: B.ByteString -> Int
readInt = fromJust . fmap fst . B.readInt
readInts :: IO [Int]
readInts = map readInt . B.words <$> B.getLine
readIntPair :: IO (Int,Int)
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine

-- Utilities
l2p :: [a] -> (a,a)
l2p (a:b:_) = (a,b)
l2p _ = error "l2p: the input list is too short"

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Data.Int
import Data.Maybe
import Control.Monad
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B

solve :: [Int64] -> Int64 -> M.Map Int64 Int64 -> M.Map Int64 Int64 -> Int64 -> Int64
solve []    _  _  _  r    = r
solve (i:t) k !c !g !r = solve t k nc ng nr
  where
    nc = M.insertWith (+) i 1 c
    ng = fromMaybe g $ do
            guard (i `mod` k == 0)
            v <- M.lookup (div i k) c
            return $ M.insertWith (+) (i*k) v g
    nr = r + M.findWithDefault 0 i g

solveAux :: [Int64] -> Int64 -> Int64
solveAux a k = solve a k M.empty M.empty 0

main :: IO ()
main = do
  [n,k] <- readInts
  a     <- readInts
  print $ solveAux a k

-- IO
readInt :: B.ByteString -> Int64
readInt = fromIntegral . fromJust . fmap fst . B.readInt
readInts :: IO [Int64]
readInts = map readInt . B.words <$> B.getLine

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Data.Int
import Data.Maybe
import Control.Monad
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B

data State = State (M.Map Int64 Int64) (M.Map Int64 Int64) !Int64
solve :: [Int64] -> Int64 -> M.Map Int64 Int64 -> M.Map Int64 Int64 -> Int64 -> Int64
solve []    _  _  _  r = r
solve (i:t) k c g !r = solve t k nc ng nr
  where
    nc = M.insertWith (+) i 1 c
    ng = fromMaybe g $ do
            guard (i `mod` k == 0)
            v <- M.lookup (div i k) c
            return $ M.insertWith (+) (i*k) v g
    nr = r + M.findWithDefault 0 i g

solveAux :: [Int64] -> Int64 -> Int64
solveAux a k = solve a k M.empty M.empty 0

main :: IO ()
main = do
  [n,k] <- readInts
  a     <- readInts
  print $ solveAux a k

-- IO
readInt :: B.ByteString -> Int64
readInt = fromIntegral . fromJust . fmap fst . B.readInt
readInts :: IO [Int64]
readInts = map readInt . B.words <$> B.getLine

{-# LANGUAGE MultiParamTypeClasses,FlexibleContexts,FlexibleInstances,TypeSynonymInstances,BangPatterns,RankNTypes,TupleSections #-}
import Control.Monad
import Control.Monad.ST
import Control.Applicative
import Control.Arrow
import Debug.Trace
import Text.Printf

import Data.List
import Data.Int
import Data.Bits
import Data.Maybe
import Data.Monoid
import Data.Array.Unboxed
import Data.Array.ST
import Data.Array.Base
import Data.Function(on)
import Data.Tuple(swap)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
    (n,k) <- readIntPair
    as <- readInts
    let f x = let v = fromIntegral x * fromIntegral k  :: Int64 in
              if abs v <= 10^(9 :: Int) then
                  fromIntegral v
              else
                  maxBound
    let g x = if mod x k == 0 then x `div` k else maxBound
    let go :: (Int -> Int) -> M.Map Int Int -> [Int] -> [Int]
        go _ _ [] = []
        go h m (ra:ras) = v : go h m' ras
          where !v  = M.findWithDefault 0 (h ra) m
                m' = M.insertWith (+) ra 1 m
    let bs1 = reverse $ go f M.empty (reverse as)
        bs2 = go g M.empty as
    print $ sum $ zipWith (\a b ->
        fromIntegral a * fromIntegral b :: Integer) bs1 bs2

-- IO
readInt :: B.ByteString -> Int
readInt = fromJust . fmap fst . B.readInt
readInts :: IO [Int]
readInts = map readInt . B.words <$> B.getLine
readIntPair :: IO (Int,Int)
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readAllInts :: IO [[Int]]
readAllInts = map (map readInt . B.words) . B.lines <$> B.getContents
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine

-- Utilities
l2p :: [a] -> (a,a)
l2p (a:b:_) = (a,b)
l2p _ = error "l2p: the input list is too short"
p2l :: (a,a) -> [a]
p2l (a,b) = [a,b]
itof :: Int -> Double
itof = fromIntegral
inf :: Int
inf = maxBound `div` 2

-- Monad
stepM_ :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
stepM_ i0 judge incr step = sub i0 where
    sub i | judge i = step i >> sub (incr i)
          | otherwise = return ()
rep_ :: Monad m => Int -> (Int -> m ()) -> m ()
rep_ n = stepM_ 0 (<n) (+1)
thru :: Monad m => (v -> m ()) -> v -> m v
thru m v = m v >> return v
memoize :: (Monad m) => (k -> m (Maybe v)) -> (k -> v -> m ()) -> k -> m v -> m v
memoize getter setter key action = do
    mv <- getter key
    case mv of
        Just v -> return v
        Nothing -> action >>= thru (setter key)

-- Array
newUArray :: (MArray (STUArray s) e (ST s),Ix i) =>
             (i,i) -> e -> ST s (STUArray s i e)
newUArray = newArray
newBArray :: (Ix i) => (i,i) -> e -> ST s (STArray s i e)
newBArray = newArray
defaultArray :: (IArray a e,Ix i) => e -> (i,i) -> [(i,e)] -> a i e
defaultArray = accumArray $ curry snd
fromEdges :: Ix i => (i,i) -> [(i,e)] -> Array i [e]
fromEdges = accumArray (flip (:)) []

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

import Data.Int
import Control.Applicative
import Control.Monad
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Strict as M

data State = State !(M.Map Int64 Int64) !(M.Map Int64 Int64) !Int64
     deriving (Show)

solveAux :: [Int64] -> Int64 -> Int64
solveAux a k = case solve a (State M.empty M.empty 0) of State _ _ r -> r
  where
    solve :: [Int64] -> State -> State
    solve []    s             = s
    solve (i:t) (State c g r) = solve t (State nc ng nr)
      where
        nc = M.insertWith (+) i 1 c
        ng = fromMaybe g $ do
          guard $ i `mod` k == 0
          v <- M.lookup (i `div` k) c
          return $ M.insertWith (+) (i*k) v g
        nr = r + (M.findWithDefault 0 i g)

main :: IO ()
main = do
  -- [n,k] <- (map read . words) <$> getLine
  -- a     <- (map read . words) <$> getLine
  [n,k] <- readInts
  a     <- readInts
  print $ solveAux a k

readInt :: B.ByteString -> Int64
readInt = fromIntegral . fromJust . fmap fst . B.readInt

readInts :: IO [Int64]
readInts = map readInt . B.words <$> B.getLine

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

import Data.Int
import Control.Applicative
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Strict as M

data State = State !(M.Map Int64 Int64) !(M.Map Int64 Int64) !Int64
     deriving (Show)

solveAux :: [Int64] -> Int64 -> Int64
solveAux a k = case solve a (State M.empty M.empty 0) of State _ _ r -> r
  where
    solve :: [Int64] -> State -> State
    solve []    s             = s
    solve (i:t) (State c g r) = solve t (State nc ng nr)
      where
        nc = M.insertWith (+) i 1 c
        ng = if i `mod` k == 0 then
               M.insertWith (+) (i*k) (M.findWithDefault 0 (i `div` k) c) g
             else
               g
        nr = r + (M.findWithDefault 0 i g)

main :: IO ()
main = do
  -- [n,k] <- (map read . words) <$> getLine
  -- a     <- (map read . words) <$> getLine
  [n,k] <- readInts
  a     <- readInts
  print $ solveAux a k

readInt :: B.ByteString -> Int64
readInt = fromIntegral . fromJust . fmap fst . B.readInt

readInts :: IO [Int64]
readInts = map readInt . B.words <$> B.getLine

import Data.Int (Int64)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Map (Map, findWithDefault, adjust, fromList, (!))

solve :: Int64 -> [Int64] -> Int64
solve 1 a = sum $ foldr loop (`seq` []) a init
    where
    init = fromList . zip a . repeat $ 0
    loop x f cnt = inc: f (adjust (+1) x cnt)
        where
        inc = val * (val - 1) `div` 2
        val = cnt ! x

solve k a = sum $ foldr loop (`seq` []) a (init, init)
    where
    init = fromList . zip a . repeat $ 0

    loop x go (cnt, obs)
        | rem /= 0  =   0: go (cnt', obs)
        | otherwise = val: go (cnt', adjust (+ inc) x obs)
        where
        (y, rem) = x `divMod` k
        cnt' = adjust (+1) x cnt
        inc = findWithDefault 0 y cnt
        val = findWithDefault 0 y obs

parse :: ByteString -> [Int]
parse line = fst . fromJust . C.readInt <$> C.words line

main = do
    [_, k] <- fmap fromIntegral . parse <$> B.getLine
    a <- fmap fromIntegral . parse <$> B.getLine
    print $ solve k a

import Data.Int (Int64)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Map (Map, findWithDefault, adjust, fromList, (!))

solve :: Int64 -> [Int64] -> Int64
solve 1 a = foldr loop (`seq` 0) a init
    where
    init = fromList . zip a . repeat $ 0
    loop x f cnt = inc + f (adjust (+1) x cnt)
        where
        inc = val * (val - 1) `div` 2
        val = cnt ! x

solve k a = foldr loop (`seq` 0) a (init, init)
    where
    init = fromList . zip a . repeat $ 0

    loop x go (cnt, obs)
        | rem /= 0  = go (cnt', obs)
        | otherwise = val + go (cnt', adjust (+ inc) x obs)
        where
        (y, rem) = x `divMod` k
        cnt' = adjust (+1) x cnt
        inc = findWithDefault 0 y cnt
        val = findWithDefault 0 y obs

parse :: ByteString -> [Int]
parse line = fst . fromJust . C.readInt <$> C.words line

main = do
    [_, k] <- fmap fromIntegral . parse <$> B.getLine
    a <- fmap fromIntegral . parse <$> B.getLine
    print $ solve k a

#!/usr/bin/env stack
-- stack --resolver=lts-2.21 --install-ghc runghc

import Control.Applicative
import qualified Data.Map.Strict as M
data State = State (M.Map Int Int) (M.Map Int Int) Int
     deriving (Show)

solve :: [Int] -> Int -> State -> State
solve []    _ s             = s
solve (i:t) k (State c g r) = solve t k (State nc ng nr)
  where
    nc = M.insert i ((M.findWithDefault 0 i c) + 1) c
    ng = if i `mod` k == 0 then
           M.insert (i*k) ((M.findWithDefault 0 (i*k) g) + (M.findWithDefault 0 (i `div` k) c)) g
         else
           g
    nr = r + (M.findWithDefault 0 i g)

solveAux :: [Int] -> Int -> Int
solveAux a k =
  case solve a k (State M.empty M.empty 0) of State _ _ r -> r

main :: IO ()
main = do
  [n,k] <- (map read . words) <$> getLine
  a     <- (map read . words) <$> getLine
  let r =  solveAux a k
  print r


Recently Polycarpus has learned the "bitwise AND" operation (which is also called "AND") of non-negative integers. Now he wants to demonstrate the school IT teacher his superb manipulation with the learned operation.For that Polycarpus came to school a little earlier and wrote on the board a sequence of non-negative integers a1, a2, ..., an. He also wrote a square matrix b of size n × n. The element of matrix b that sits in the i-th row in the j-th column (we'll denote it as bij) equals:  the "bitwise AND" of numbers ai and aj (that is, bij = ai & aj), if i ≠ j;  -1, if i = j. Having written out matrix b, Polycarpus got very happy and wiped a off the blackboard. But the thing is, the teacher will want this sequence to check whether Polycarpus' calculations were correct. Polycarus urgently needs to restore the removed sequence of integers, or else he won't prove that he can count correctly.Help Polycarpus, given matrix b, restore the sequence of numbers a1, a2, ..., an, that he has removed from the board. Polycarpus doesn't like large numbers, so any number in the restored sequence mustn't exceed 109.

The first line contains a single integer n (1 ≤ n ≤ 100) — the size of square matrix b. Next n lines contain matrix b. The i-th of these lines contains n space-separated integers: the j-th number represents the element of matrix bij. It is guaranteed, that for all i (1 ≤ i ≤ n) the following condition fulfills: bii = -1. It is guaranteed that for all i, j (1 ≤ i, j ≤ n; i ≠ j) the following condition fulfills: 0 ≤ bij ≤ 109, bij = bji.

Print n non-negative integers a1, a2, ..., an (0 ≤ ai ≤ 109) — the sequence that Polycarpus wiped off the board. Separate the numbers by whitespaces.  It is guaranteed that there is sequence a that satisfies the problem conditions. If there are multiple such sequences, you are allowed to print any of them.

NoteIf you do not know what is the "bitwise AND" operation please read: http://en.wikipedia.org/wiki/Bitwise_operation.

import Control.Monad (replicateM)
import Data.Bits ((.|.))
import Data.Maybe (fromJust)
import qualified Data.ByteString.Char8 as C

main = do
  [n] <- getArray
  a <- replicateM n $ getArray
  putStrLn $ unwords $ map show $ map (foldr (.|.) 0 . filter (>=0)) a
  where
    getArray = fmap (map (fst . fromJust . C.readInt) . C.words) C.getLine

import Data.Bits
main=interact$unwords.map(show.f.map read.words).tail.lines
f :: [Int] -> Int
f xs = foldl(.|.)0$filter(>=0)xs


Mahmoud and Ehab are on the third stage of their adventures now. As you know, Dr. Evil likes sets. This time he won't show them any set from his large collection, but will ask them to create a new set to replenish his beautiful collection of sets.Dr. Evil has his favorite evil integer x. He asks Mahmoud and Ehab to find a set of n distinct non-negative integers such the bitwise-xor sum of the integers in it is exactly x. Dr. Evil doesn't like big numbers, so any number in the set shouldn't be greater than 106.

The only line contains two integers n and x (1 ≤ n ≤ 105, 0 ≤ x ≤ 105) — the number of elements in the set and the desired bitwise-xor, respectively.

If there is no such set, print "NO" (without quotes). Otherwise, on the first line print "YES" (without quotes) and on the second line print n distinct integers, denoting the elements in the set is any order. If there are multiple solutions you can print any of them.

NoteYou can read more about the bitwise-xor operation here: https://en.wikipedia.org/wiki/Bitwise_operation#XORFor the first sample .For the second sample .

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && n == 2 = Nothing
  | n == 1 = Just [x]
  | n == 2 = Just [x, 0]
  | otherwise = Just $ ([262144, 393216] ++) $ (:) =<< (xor 131072 . foldl' xor x) $ take (n - 3) [1..]

import Data.Bits

z = 2^19

solve :: Int -> Int -> Maybe [Int]
solve 1 x = Just [x]
solve 2 0 = Nothing
solve 2 x = Just $ [1, x `xor` 1]
solve n x
   | v >= n    = Just $ v : [1..(n-1)]
   | v == 1    = Just $ (v .|. z) : 1 : (2 .|. z) : [3..(n-1)]
   | otherwise = Just $ (v .|. z) : (1 .|. z) : [2..(n-1)]
  where v = foldl xor x [1..(n-1)]

main = do
  [n, x] <- fmap (map read . words) getLine
  case solve n x of
    Nothing -> putStrLn "NO"
    Just xs -> putStrLn "YES" >> putStrLn (unwords . map show $ xs)

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && n > 1 = Nothing
  | odd n = Just $ (:) =<< foldl' xor x $ take (n - 1) [2^17..]
  | otherwise = Just $ (0:) $ (:) =<< foldl' xor x $ take (n - 2) [2^17..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | odd n = Just $ go n (2^17) x
  | otherwise = Just $ (++) =<< (go 3 (2^18) . foldl' xor x) $ take (n - 3) [2^17..]

go n lo x = (:) =<< foldl' xor x $ take (n - 1) [lo..]

{-# 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.Array.Unboxed
import Data.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x = (:) =<< foldl' xor x $ take (n - 1) [10^5+1..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | odd n = Just $ (:) =<< foldl' xor x $ take (n - 1) [2^17..]
  | otherwise = Just $ (0:) $ (:) =<< foldl' xor x $ take (n - 2) [2^17..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | odd n = Just $ go n (2^17) x
  | otherwise = Just $ (++) =<< (go 3 (2^19) . foldl' xor x) $ take (n - 3) [2^17..]

go n lo x = (:) =<< foldl' xor x $ take (n - 1) [lo..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | otherwise = Just $ ([262144, 393216] ++) $ (:) =<< (xor 131072 . foldl' xor x) $ take (n - 3) [1..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | odd n = Just $ (:) =<< foldl' xor x $ take (n - 1) [2^17..] -- 0....
  | otherwise = Just $ ([0, 2^17]++) $ (:) =<< (flip clearBit 17 . foldl' xor x) $ take (n - 3) [2^17 + 1..] --1......

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | odd n = (:) =<< foldl' xor x $ take (n - 1) [2^17..]
  | otherwise = (0:) $ (:) =<< foldl' xor x $ take (n - 2) [2^17..]

{-# 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.Bits
import Data.List

main = putStr . evalState app . B.words =<< B.getContents

app = maybe "NO" (("YES\n" ++) . unwords . map show) `fmap` liftM2 solve poi poi
  where
  pop = state $ \(x:xs) -> (x, xs)
  poi = fmap int pop
  int = maybe undefined fst . B.readInt

solve n x
  | x == 0 && even n = Nothing
  | n == 1 = Just [x]
  | n == 2 = Just [x, 0]
  | otherwise = Just $ ([262144, 393216] ++) $ (:) =<< (xor 131072 . foldl' xor x) $ take (n - 3) [1..]

import Data.Bits

z = 2^19

solve :: Int -> Int -> Maybe [Int]
solve 2 0 = Nothing
solve 2 x = Just $ [1, x `xor` 1]
solve n x
   | v >= n    = Just $ v : [1..(n-1)]
   | v == 1    = Just $ (v .|. z) : 1 : (2 .|. z) : [3..(n-1)]
   | otherwise = Just $ (v .|. z) : (1 .|. z) : [2..(n-1)]
  where v = foldl xor x [1..(n-1)]

main = do
  [n, x] <- fmap (map read . words) getLine
  case solve n x of
    Nothing -> putStrLn "NO"
    Just xs -> putStrLn "YES" >> putStrLn (unwords . map show $ xs)

import Data.Bits

z = 2^19

solve :: Int -> Int -> Maybe [Int]
solve 2 0 = Nothing
solve n x
   | v >= n    = Just $ v : [1..(n-1)]
   | v == 1    = Just $ (v .|. z) : 1 : (2 .|. z) : [3..(n-1)]
   | otherwise = Just $ (v .|. z) : (1 .|. z) : [2..(n-1)]
  where v = foldl xor x [1..(n-1)]

main = do
  [n, x] <- fmap (map read . words) getLine
  case solve n x of
    Nothing -> putStrLn "NO"
    Just xs -> putStrLn "YES" >> putStrLn (unwords . map show $ xs)


RedDreamer has an array $$$a$$$ consisting of $$$n$$$ non-negative integers, and an unlucky integer $$$T$$$.Let's denote the misfortune of array $$$b$$$ having length $$$m$$$ as $$$f(b)$$$ — the number of pairs of integers $$$(i, j)$$$ such that $$$1 \le i < j \le m$$$ and $$$b_i + b_j = T$$$. RedDreamer has to paint each element of $$$a$$$ into one of two colors, white and black (for each element, the color is chosen independently), and then create two arrays $$$c$$$ and $$$d$$$ so that all white elements belong to $$$c$$$, and all black elements belong to $$$d$$$ (it is possible that one of these two arrays becomes empty). RedDreamer wants to paint the elements in such a way that $$$f(c) + f(d)$$$ is minimum possible.For example:  if $$$n = 6$$$, $$$T = 7$$$ and $$$a = [1, 2, 3, 4, 5, 6]$$$, it is possible to paint the $$$1$$$-st, the $$$4$$$-th and the $$$5$$$-th elements white, and all other elements black. So $$$c = [1, 4, 5]$$$, $$$d = [2, 3, 6]$$$, and $$$f(c) + f(d) = 0 + 0 = 0$$$;  if $$$n = 3$$$, $$$T = 6$$$ and $$$a = [3, 3, 3]$$$, it is possible to paint the $$$1$$$-st element white, and all other elements black. So $$$c = [3]$$$, $$$d = [3, 3]$$$, and $$$f(c) + f(d) = 0 + 1 = 1$$$. Help RedDreamer to paint the array optimally!

The first line contains one integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. Then $$$t$$$ test cases follow. The first line of each test case contains two integers $$$n$$$ and $$$T$$$ ($$$1 \le n \le 10^5$$$, $$$0 \le T \le 10^9$$$) — the number of elements in the array and the unlucky integer, respectively.  The second line contains $$$n$$$ integers $$$a_1$$$, $$$a_2$$$, ..., $$$a_n$$$ ($$$0 \le a_i \le 10^9$$$) — the elements of the array.  The sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case print $$$n$$$ integers: $$$p_1$$$, $$$p_2$$$, ..., $$$p_n$$$ (each $$$p_i$$$ is either $$$0$$$ or $$$1$$$) denoting the colors. If $$$p_i$$$ is $$$0$$$, then $$$a_i$$$ is white and belongs to the array $$$c$$$, otherwise it is black and belongs to the array $$$d$$$. If there are multiple answers that minimize the value of $$$f(c) + f(d)$$$, print any of them.

import Control.Arrow ((>>>))

main :: IO ()
main =
  interact $
    lines
      >>> drop 1 -- t
      >>> map (words >>> map read)
      >>> process
      >>> map (map show >>> unwords)
      >>> unlines

process :: [[Int]] -> [[Int]]
process [] = []
process ([_, t] : a : rest) = solve t a : process rest

solve :: Int -> [Int] -> [Int]
solve t a =
  fst $
    foldr
      ( \x (ans, col) ->
          case compare t (2 * x) of
            EQ -> (col:ans, 1 - col)
            LT -> (0:ans, col)
            GT -> (1:ans, col)
      )
      ([], 0)
      a

import Control.Monad
import Data.Bool

solve :: Int -> [Int] -> [Bool]
solve u a = let
  ct = length [() | x <- a, x + x == u]
  go 0 [] = []
  go 0 (s : t) = (s + s <= u) : go 0 t
  go k (s : t) = case  compare (s + s) u  of
    LT -> True : go k t
    EQ -> False : go (k - 1) t
    GT -> False : go k t
  go _ _ = error "..."
  in  go (div ct 2) a

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    [_n, u] <- map read . words <$> getLine
    a <- map read . words <$> getLine
    putStrLn . unwords . map (bool "0" "1") $ solve u a


The ancient Berlanders believed that the longer the name, the more important its bearer is. Thus, Berland kings were famous for their long names. But long names are somewhat inconvenient, so the Berlanders started to abbreviate the names of their kings. They called every king by the first letters of its name. Thus, the king, whose name was Victorious Vasily Pupkin, was always called by the berlanders VVP.In Berland over its long history many dynasties of kings replaced each other, but they were all united by common traditions. Thus, according to one Berland traditions, to maintain stability in the country, the first name of the heir should be the same as the last name his predecessor (hence, the first letter of the abbreviated name of the heir coincides with the last letter of the abbreviated name of the predecessor). Berlanders appreciate stability, so this tradition has never been broken. Also Berlanders like perfection, so another tradition requires that the first name of the first king in the dynasty coincides with the last name of the last king in this dynasty (hence, the first letter of the abbreviated name of the first king coincides with the last letter of the abbreviated name of the last king). This tradition, of course, has also been always observed.The name of a dynasty is formed by very simple rules: we take all the short names of the kings in the order in which they ruled, and write them in one line. Thus, a dynasty of kings "ab" and "ba" is called "abba", and the dynasty, which had only the king "abca", is called "abca".Vasya, a historian, has recently found a list of abbreviated names of all Berland kings and their relatives. Help Vasya to find the maximally long name of the dynasty that could have existed in Berland.Note that in his list all the names are ordered by the time, that is, if name A is earlier in the list than B, then if A and B were kings, then king A ruled before king B.

The first line contains integer n (1 ≤ n ≤ 5·105) — the number of names in Vasya's list. Next n lines contain n abbreviated names, one per line. An abbreviated name is a non-empty sequence of lowercase Latin letters. Its length does not exceed 10 characters.

Print a single number — length of the sought dynasty's name in letters. If Vasya's list is wrong and no dynasty can be found there, print a single number 0.

NoteIn the first sample two dynasties can exist: the one called "abcca" (with the first and second kings) and the one called "abccba" (with the first and third kings). In the second sample there aren't acceptable dynasties.The only dynasty in the third sample consists of one king, his name is "c".

module Main (main)
  where

import Control.Monad (liftM, when)
import Control.Monad.ST (ST)
import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array.ST (STUArray, runSTUArray)
import Data.Array.Unboxed (UArray, (!))

az :: String
az  =  ['a' .. 'z']

solve :: [String] -> Int
solve xs  =  maximum [(array xs) ! (c,c) | c <- az]

array :: [String] -> UArray (Char, Char) Int
array xs  =  runSTUArray $ do
    array  <-  newArray (('a', 'a'), ('z', 'z')) 0
    iter xs array
    return array

iter :: [String] -> STUArray s (Char, Char) Int -> ST s ()
iter [] _  =  return ()
iter (x:xs) array  =  modify az array >> iter xs array
  where
    (c1, c2, n)  =  (head x, last x, length x)
    modify :: [Char] -> STUArray s (Char, Char) Int -> ST s ()
    modify [] array  =  return ()
    modify (c:cs) array  =  do
        m  <-  readArray array (c, c1)
        when (c1 == c || m > 0) $ do
            old  <-  readArray array (c, c2)
            writeArray array (c, c2) (max old (m + n))
        modify cs array

main :: IO ()
main  =  do
    lines'  <-  liftM lines getContents
    let n  =  (read . head) lines'
    (print . solve . take n . tail) lines'


Monocarp has been collecting rare magazines for quite a while, and now he has decided to sell them. He distributed the magazines between $$$n$$$ boxes, arranged in a row. The $$$i$$$-th box contains $$$a_i$$$ magazines. Some of the boxes are covered with lids, others are not. Suddenly it started to rain, and now Monocarp has to save as many magazines from the rain as possible. To do this, he can move the lids between boxes as follows: if the $$$i$$$-th box was covered with a lid initially, he can either move the lid from the $$$i$$$-th box to the box $$$(i-1)$$$ (if it exists), or keep the lid on the $$$i$$$-th box. You may assume that Monocarp can move the lids instantly at the same moment, and no lid can be moved more than once. If a box will be covered with a lid after Monocarp moves the lids, the magazines in it will be safe from the rain; otherwise they will soak.You have to calculate the maximum number of magazines Monocarp can save from the rain.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of the testcases. The first line of each testcase contains a single integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the number of boxes. The second line contains a string of $$$n$$$ characters 0 and/or 1. If the $$$i$$$-th character is 1, the $$$i$$$-th box is initially covered with a lid. If the $$$i$$$-th character is 0, the $$$i$$$-th box is initially not covered. The third line contains a sequence of integers $$$a_1, a_2, \dots, a_n$$$ ($$$1 \le a_i \le 10^4$$$), where $$$a_i$$$ is the number of magazines in the $$$i$$$-th box. The sum of $$$n$$$ over all testcases doesn't exceed $$$2 \cdot 10^5$$$.

For each testcase, print one integer — the maximum number of magazines Monocarp can save from the rain.

NoteIn the first testcase of the example, Monocarp can move the lid from the second box to the first box, so the boxes $$$1$$$, $$$3$$$ and $$$4$$$ are covered, and $$$10 + 8 + 9 = 27$$$ magazines are saved.In the second testcase, Monocarp can move the lid from the second box to the first box, then from the third box to the second box, then from the fifth box to the fourth box, and then from the sixth box to the fifth box. The boxes $$$1$$$, $$$2$$$, $$$4$$$ and $$$5$$$ will be covered, so $$$20 + 10 + 30 + 20 = 80$$$ magazines can be saved.There are no lids in the third testcase, so it's impossible to save even a single magazine.

{-# LANGUAGE CPP, BlockArguments, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, NumericUnderscores, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
-- {-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}
#ifndef DEBUG
{-# LANGUAGE Safe #-}
#endif

import qualified Data.ByteString.Char8 as B8
import qualified Data.String as S

import Control.Arrow ((>>>))
import Data.Functor ((<&>))
import Data.Maybe
import qualified Data.Traversable as T

import qualified Control.Applicative as A
import qualified Control.Monad as M
import qualified Control.Monad.State as MS
import qualified Control.Monad.Trans as MT
import qualified Control.Monad.Trans.Maybe as M

import qualified Data.List as L
import qualified Data.Array as A
import qualified Data.Array.MArray.Safe as MA
import qualified Data.Array.ST.Safe as STA
import qualified Data.Array.Unboxed as UA

import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import qualified Data.Set as S
import Data.List (sortBy, sortOn)

import Data.Char
import Data.Int

import System.IO (stdin, stdout, hFlush)
import Text.Printf

#ifdef DEBUG
import Debug.Trace (trace, traceM, traceShowM)
debug = flip trace

tracing t x = trace (t ++ " = " ++ show x) x
debugging x t = tracing t x

tracingM t x = traceM $ t ++ " = " ++ show x

#else

debug x _ = x
trace _ x = x
tracing _ x = x
debugging x _ = x

traceM _ = pure ()
tracingM _ _ = pure ()
#endif

{- reading -}
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))

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

{- aux -}
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

{- solution -}

solve :: Int -> B8.ByteString -> [Int] -> Int
solve n mask as = solve' (0, 0) $ zip ms as
    where
        ms = L.map (\c -> ord c - ord '0') $ B8.unpack mask
        solve' (w0, w1) [] = w0
        solve' (w0, w1) ((m, a) : otherWAs)
            | m == 0 = solve' (w0, w0 + a) otherWAs
            | m == 1 = solve' (max (w0 + a) w1, w1 + a) otherWAs

main :: IO ()
main = do
    t <- B8.getLine <&> readIntB8
    M.replicateM_ t $ do
        n <- B8.getLine <&> readIntB8
        mask <- B8.getLine <&> B8.filter isAlphaNum
        as <- B8.getLine <&> readIntB8s
        let answer = solve n mask as
        printf "%d\n" answer


There is a robot in a warehouse and $$$n$$$ packages he wants to collect. The warehouse can be represented as a coordinate grid. Initially, the robot stays at the point $$$(0, 0)$$$. The $$$i$$$-th package is at the point $$$(x_i, y_i)$$$. It is guaranteed that there are no two packages at the same point. It is also guaranteed that the point $$$(0, 0)$$$ doesn't contain a package.The robot is semi-broken and only can move up ('U') and right ('R'). In other words, in one move the robot can go from the point $$$(x, y)$$$ to the point ($$$x + 1, y$$$) or to the point $$$(x, y + 1)$$$.As we say above, the robot wants to collect all $$$n$$$ packages (in arbitrary order). He wants to do it with the minimum possible number of moves. If there are several possible traversals, the robot wants to choose the lexicographically smallest path.The string $$$s$$$ of length $$$n$$$ is lexicographically less than the string $$$t$$$ of length $$$n$$$ if there is some index $$$1 \le j \le n$$$ that for all $$$i$$$ from $$$1$$$ to $$$j-1$$$ $$$s_i = t_i$$$ and $$$s_j < t_j$$$. It is the standard comparison of string, like in a dictionary. Most programming languages compare strings in this way.

The first line of the input contains an integer $$$t$$$ ($$$1 \le t \le 100$$$) — the number of test cases. Then test cases follow. The first line of a test case contains one integer $$$n$$$ ($$$1 \le n \le 1000$$$) — the number of packages. The next $$$n$$$ lines contain descriptions of packages. The $$$i$$$-th package is given as two integers $$$x_i$$$ and $$$y_i$$$ ($$$0 \le x_i, y_i \le 1000$$$) — the $$$x$$$-coordinate of the package and the $$$y$$$-coordinate of the package. It is guaranteed that there are no two packages at the same point. It is also guaranteed that the point $$$(0, 0)$$$ doesn't contain a package. The sum of all values $$$n$$$ over test cases in the test doesn't exceed $$$1000$$$.

Print the answer for each test case. If it is impossible to collect all $$$n$$$ packages in some order starting from ($$$0,0$$$), print "NO" on the first line. Otherwise, print "YES" in the first line. Then print the shortest path — a string consisting of characters 'R' and 'U'. Among all such paths choose the lexicographically smallest path. Note that in this problem "YES" and "NO" can be only uppercase words, i.e. "Yes", "no" and "YeS" are not acceptable.

NoteFor the first test case in the example the optimal path RUUURRRRUU is shown below:

import Control.Monad
import Data.List

solve :: [(Int, Int)] -> String -> Maybe String
solve [_] acc = Just acc
solve ((x1,y1):(x2,y2):xs) acc
  | x1 <= x2 && y1 <= y2 = solve ((x2,y2):xs) (acc ++ path)
  | otherwise = Nothing
  where
    path = (replicate (x2-x1) 'R') ++ replicate (y2-y1) 'U'

main = do
  t <- readLn :: IO Int
  replicateM_ t $ do
    n <- readLn :: IO Int
    xys <- replicateM n $ do
      [a,b] <- map read . words <$> getLine :: IO [Int]
      return (a,b)
    case solve ((0,0):(sort xys)) "" of
      Just res -> do
        putStrLn "YES"
        putStrLn res
      Nothing -> do
        putStrLn "NO"

import Data.Char
import Data.List
import Control.Monad

checkYs :: [Int] -> Bool
checkYs ys = -1 == (foldr (\a b -> if a <= b then a else -1) 1001) ys

isImpossible :: Int -> [(Int, Int)] -> Bool
isImpossible n = checkYs . map snd

getPath :: (Int, Int) -> Int -> [(Int, Int)] -> String
getPath _ 0 _                     = []
getPath (x1, y1) n ((x2, y2):xys) = (rs) ++ (us) ++ (getPath (x2, y2) (n - 1) xys)
    where rTimes = x2 - x1
          uTimes = y2 - y1
          rs     = replicate rTimes 'R'
          us     = replicate uTimes 'U'

solve :: Int -> [(Int, Int)] -> String
solve n xy
    | invalid   = "NO"
    | otherwise = "YES\n" ++ (getPath (0, 0) n xys)
    where xys     = sort xy
          invalid = isImpossible n xys

makePair :: String -> (Int, Int)
makePair s = (a, b)
    where wds = words s
          a = read (wds !! 0)
          b = read (wds !! 1)

testCase :: IO ()
testCase = do
    n <- read <$> getLine
    inputs <- replicateM n (makePair <$> getLine)
    putStrLn $ solve n inputs

main :: IO ()
main = do
    t <- read <$> getLine
    replicateM t testCase
    return ()

import Control.Monad
import Data.Ord
import Data.Int
import Data.Sequence as DSeq (null, Seq( Empty ), (|>), (><), replicate)
import Data.Foldable
import Data.List
import Data.Maybe
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class

import Text.Read (readMaybe)

getToken :: IO String
getToken =
    let aux s = do
        x <- getChar
        if x == ' ' || x == '\t' || x == '\n' then
            if DSeq.null s then
                aux s
            else
                return $ toList s
        else
            aux $ s |> x
    in aux DSeq.Empty

get :: Read a => MaybeT IO a
get = MaybeT $ liftM readMaybe getToken

puts :: String -> MaybeT IO ()
puts = lift . putStr

putsln :: String -> MaybeT IO ()
putsln = lift . putStrLn

put :: Show a => a -> MaybeT IO ()
put = putsln . show

putln :: Show a => a -> MaybeT IO ()
putln = putsln . show

main :: IO ()
main = do
    o <- runMaybeT sub
    return ()

sub :: MaybeT IO ()
sub = do
    t <- get :: MaybeT IO Int
    replicateM_ t f1

f1 :: MaybeT IO ()
f1 = do { n <- get :: MaybeT IO Int
        ; a <- replicateM n $ liftM2 (,) get get :: MaybeT IO [(Int, Int)]
        ; case f2 a of
            Just s -> do
                putsln "YES"
                putsln s
            Nothing -> putsln "NO" }

f2 :: [(Int, Int)] -> Maybe String
f2 a =  let aux (a, b) (c, d) = case compare a c of
                                    EQ -> compare b d
                                    x -> x
        in toList <$> (f3 (0, 0) $ sortBy aux a)

f3 :: (Int, Int) -> [(Int, Int)] -> Maybe (Seq Char)
f3 _ [] = Just DSeq.Empty
f3 (a, b) ((c, d) : l) = if b > d then Nothing else
    (\x -> (DSeq.replicate (c - a) 'R' >< DSeq.replicate (d - b) 'U') >< x ) <$> f3 (c, d) l

import Control.Monad
import Data.Ord
import Data.Int
import Data.Sequence as DSeq (null, Seq( Empty ), (|>), (><), replicate)
import Data.Foldable
import Data.List
import Data.Maybe
import Text.Read (readMaybe)

getToken :: IO String
getToken =
    let aux s = do
        x <- getChar
        if x == ' ' || x == '\t' || x == '\n' then
            if DSeq.null s then
                aux s
            else
                return $ toList s
        else
            aux $ s |> x
    in aux DSeq.Empty

get :: Read a => IO (Maybe a)
get = liftM readMaybe getToken

put :: Show a => a -> IO ()
put = putStr . show

putln :: Show a => a -> IO ()
putln = putStrLn . show

try :: Maybe (IO ()) -> IO ()
try = fromMaybe . return $ ()

main :: IO ()
main = do {
      t' <- get :: IO (Maybe Int)
    ; try $ do {
      t <- t'
    ; Just $ do {
      replicateM_ t f1 }}}

f1 :: IO ()
f1 = do { n' <- get :: IO (Maybe Int)
        ; try $ do {
          n <- n'
        ; Just $ do {
          a' <- replicateM n $ liftM2 (,) get get :: IO [(Maybe Int, Maybe Int)]
        ; try $ do {
          a <- toList <$> foldl (liftM2 (|>)) (Just DSeq.Empty) ((\ (x, y) -> liftM2 (,) x y) <$> a')
        ; Just $ case f2 a of
            Just s -> do
                putStrLn "YES"
                putStrLn s
            Nothing -> putStrLn "NO" }}}}

f2 :: [(Int, Int)] -> Maybe String
f2 a =  let aux (a, b) (c, d) = case compare a c of
                                    EQ -> compare b d
                                    x -> x
        in toList <$> (f3 (0, 0) $ sortBy aux a)

f3 :: (Int, Int) -> [(Int, Int)] -> Maybe (Seq Char)
f3 _ [] = Just DSeq.Empty
f3 (a, b) ((c, d) : l) = if b > d then Nothing else
    (\x -> (DSeq.replicate (c - a) 'R' >< DSeq.replicate (d - b) 'U') >< x ) <$> f3 (c, d) l

import Control.Monad
import Data.Ord
import Data.Int
import Data.Sequence as DSeq (null, Seq( Empty ), (|>), (><), replicate)
import Data.Foldable
import Data.List

getToken :: IO String
getToken =
    let aux s = do
        x <- getChar
        if x == ' ' || x == '\t' || x == '\n' then
            if DSeq.null s then
                aux s
            else
                return $ toList s
        else
            aux $ s |> x
    in aux DSeq.Empty

get :: Read a => IO a
get = liftM read getToken

put :: Show a => a -> IO ()
put = putStr . show

putln :: Show a => a -> IO ()
putln = putStrLn . show

main :: IO ()
main = do
    t <- get :: IO Int
    replicateM_ t f1

f1 :: IO ()
f1 = do
    n <- get :: IO Int
    a <- replicateM n $ liftM2 (,) get get :: IO [(Int, Int)]
    case f2 a of
        Just s -> do
            putStrLn "YES"
            putStrLn s
        Nothing -> putStrLn "NO"

f2 :: [(Int, Int)] -> Maybe String
f2 a =  let aux (a, b) (c, d) = case compare a c of
                                    EQ -> compare b d
                                    x -> x
        in toList <$> (f3 (0, 0) $ sortBy aux a)

f3 :: (Int, Int) -> [(Int, Int)] -> Maybe (Seq Char)
f3 _ [] = Just DSeq.Empty
f3 (a, b) ((c, d) : l) = if b > d then Nothing else
    (\x -> (DSeq.replicate (c - a) 'R' >< DSeq.replicate (d - b) 'U') >< x ) <$> f3 (c, d) l


You are given two strings of equal length $$$s$$$ and $$$t$$$ consisting of lowercase Latin letters. You may perform any number (possibly, zero) operations on these strings.During each operation you choose two adjacent characters in any string and assign the value of the first character to the value of the second or vice versa.For example, if $$$s$$$ is "acbc" you can get the following strings in one operation:   "aabc" (if you perform $$$s_2 = s_1$$$);  "ccbc" (if you perform $$$s_1 = s_2$$$);  "accc" (if you perform $$$s_3 = s_2$$$ or $$$s_3 = s_4$$$);  "abbc" (if you perform $$$s_2 = s_3$$$);  "acbb" (if you perform $$$s_4 = s_3$$$); Note that you can also apply this operation to the string $$$t$$$.Please determine whether it is possible to transform $$$s$$$ into $$$t$$$, applying the operation above any number of times.Note that you have to answer $$$q$$$ independent queries.

The first line contains one integer $$$q$$$ ($$$1 \le q \le 100$$$) — the number of queries. Each query is represented by two consecutive lines. The first line of each query contains the string $$$s$$$ ($$$1 \le |s| \le 100$$$) consisting of lowercase Latin letters. The second line of each query contains the string $$$t$$$ ($$$1 \le |t| \leq 100$$$, $$$|t| = |s|$$$) consisting of lowercase Latin letters.

For each query, print "YES" if it is possible to make $$$s$$$ equal to $$$t$$$, 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 perform two operations $$$s_1 = s_2$$$ (after it $$$s$$$ turns into "aabb") and $$$t_4 = t_3$$$ (after it $$$t$$$ turns into "aabb"). In the second query, the strings are equal initially, so the answer is "YES".In the third query, you can not make strings $$$s$$$ and $$$t$$$ equal. Therefore, the answer is "NO".

import Data.List
import Control.Monad
main = do
  q <- readLn
  replicateM_ q $ do
    s <- getLine
    t <- getLine
    putStrLn $ if null (intersect s t) then "NO" else "YES"


You've got a string s = s1s2... s|s| of length |s|, consisting of lowercase English letters. There also are q queries, each query is described by two integers li, ri (1 ≤ li ≤ ri ≤ |s|). The answer to the query is the number of substrings of string s[li... ri], which are palindromes.String s[l... r] = slsl + 1... sr (1 ≤ l ≤ r ≤ |s|) is a substring of string s = s1s2... s|s|.String t is called a palindrome, if it reads the same from left to right and from right to left. Formally, if t = t1t2... t|t| = t|t|t|t| - 1... t1.

The first line contains string s (1 ≤ |s| ≤ 5000). The second line contains a single integer q (1 ≤ q ≤ 106) — the number of queries. Next q lines contain the queries. The i-th of these lines contains two space-separated integers li, ri (1 ≤ li ≤ ri ≤ |s|) — the description of the i-th query. It is guaranteed that the given string consists only of lowercase English letters.

Print q integers — the answers to the queries. Print the answers in the order, in which the queries are given in the input. Separate the printed numbers by whitespaces.

NoteConsider the fourth query in the first test case. String s[4... 6] = «aba». Its palindrome substrings are: «a», «b», «a», «aba».

import Data.Array.Unboxed
import Data.Maybe
import qualified Data.Array as A
import qualified Data.ByteString.Char8 as C

type U = UArray Int Int

pal n s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1]]
	where
		a = A.listArray (1, n) $ C.unpack s
		go l r = if 1 <= l && r <= n && a!l == a!r then go (l - 1) (r + 1) + 1 else 0

solve s q = go q
	where
		go [] = []
		go (l:r:t) = ' ': show (a A.! l ! r) ++ go t
		n = C.length s
		p = pal n s
		a = listArray (1,n) $ map gao [1 .. n]
		gao s = listArray (s,n) $ scanl1 (+) $ scanl1 (+) $ elems d :: U
			where
				d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
					(l,r,m) <- p,
					let m' = min m $ l - s + 1,
					m' > 0] :: U

main = do
	s <- C.getLine
	C.getLine
	q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
	putStr $ solve s q

import Data.Array (Array, assocs, listArray, (!))
import Data.Array.Unboxed (UArray, accumArray, array, elems)
import Data.Maybe (fromJust)
import qualified Data.Array.Unboxed as U
import qualified Data.ByteString.Char8 as C

palindrome n s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    a = listArray (1, n) $ C.unpack s
    go l r = if 1 <= l && r <= n && a!l == a!r then succ $ go (pred l) (succ r) else 0

solve s q = go q
  where
    go [] = []
    go (l:r:t) = a ! l U.! r: go t
    n = C.length s
    a = listArray (1,n) $ map gao $ zip [1 .. n] $ iterate (drop 2) $ palindrome n s
    gao :: (Int, [(Int, Int, Int)]) -> UArray Int Int
    gao (s, p) = U.listArray (s,n) $ scanl1 (+) $ scanl1 (+) $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  putStr $ unlines $ map show $ solve s q

import Data.Array.Unboxed
import Data.Maybe
import qualified Data.Array as A
import qualified Data.ByteString.Char8 as C

palindrome n s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    a = A.listArray (1, n) $ C.unpack s
    go l r = if 1 <= l && r <= n && a!l == a!r then succ $ go (pred l) (succ r) else 0

solve s q = go q
  where
    go [] = []
    go (l:r:t) = a A.! l ! r: go t
    n = C.length s
    a = listArray (1,n) $ map gao $ zip [1 .. n] $ iterate (drop 2) $ palindrome n s
    gao (s, p) = listArray (s,n) $ scanl1 (+) $ scanl1 (+) $ elems d :: UArray Int Int
      where
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0] :: UArray Int Int

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  putStr $ unlines $ map show $ solve s q

import Data.Array (Array, assocs, listArray, (!))
import Data.Array.Unboxed (UArray, accumArray, array, elems)
import Data.Maybe (fromJust)
import qualified Data.Array.Unboxed as U
import qualified Data.ByteString.Char8 as C

parsum2 a = go 0 0 a
  where
    go s x [] = []
    go s x (h:t) = x': go s' x' t
      where
        s' = s + h
        x' = x + s'

manacher s = [(div i 2, div (i + 1) 2, e) | (i, e) <- assocs b]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s
    pal l r = if 1 <= l && r <= n && a!l == a!r then succ $ pal (pred l) (succ r) else 0
    b = listArray (2, 2*n) $ go 2 (0, 0)
    go k (e, c) = if l > n then [] else t: go (k + 1) (e', c')
      where
        l = div k 2
        r = k - l
        s = if k <= e then min (b!(2*c-k)) $ 1 + div (e-k) 2 else 0
        t = s + pal (l - s) (r + s)
        (e', c') = max (e, c) (2 * (r + t - 1), k)

solve s q = go q
  where
    go [] = []
    go (l:r:t) = a ! l U.! r: go t
    n = C.length s
    p = manacher s
    a = listArray (1,n) $ map gao $ zip [1 .. n] $ iterate (drop 2) p
    gao :: (Int, [(Int, Int, Int)]) -> UArray Int Int
    gao (s, p) = U.listArray (s,n) $ parsum2 $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  putStr $ unlines $ map show $ solve s q

{-# OPTIONS_GHC -O2 -optc-Ofast -fignore-asserts #-}
import Data.Array (Array, assocs, listArray, (!))
import Data.Array.Unboxed (UArray, accumArray, array, elems)
import Data.Maybe (fromJust)
import Debug.Trace (trace)
import qualified Data.Array.Unboxed as U
import qualified Data.ByteString.Char8 as C

-- parsum = scanl1 (+)
-- parsum2 = parsum . parsum
parsum2 a = go 0 0 a
  where
    go s x [] = []
    go s x (h:t) = x': go s' x' t
      where
        s' = s + h
        x' = x + s'

-- O(n^2): 0.36s
palindrome s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s
    go l r
      | l < 1 || r > n  = 0
      | a!l /= a!r      = 0
      | otherwise       = succ $ go (pred l) (succ r)

-- O(n): 0.02s
manacher s = [(div i 2, div (i + 1) 2, e) | (i, e) <- assocs b]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s
    pal l r
      | l < 1 || r > n = 0
      | a!l /= a!r     = 0
      | otherwise      = succ $ pal (pred l) (succ r)
    b = listArray (2, 2*n) $ go 2 (0, 0)
    go k (e, c) = if l > n then [] else t: go (k + 1) (e', c')
      where
        l = div k 2
        r = k - l
        s = if k <= e then min (b!(2*c-k)) $ 1 + div (e-k) 2 else 0
        t = s + pal (l - s) (r + s)
        (e', c') = max (e, c) (2 * (r + t - 1), k)

solve :: C.ByteString -> [Int] -> [Int]
solve s q = go q
  where
    go [] = []
    go (l:r:t) = a ! l U.! r: go t
    n = C.length s
    p = manacher s
    a = listArray (1,n) $ map gao $ zip [1 .. n] $ iterate (drop 2) p
    gao :: (Int, [(Int, Int, Int)]) -> UArray Int Int
    gao (s, p) = U.listArray (s,n) $ parsum2 $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

-- 4562ms
customTest = do
  let s = C.pack $ replicate 5000 'a'
      q = concat [[i, i + 1, i * 5, j * 5] | i <- [1 .. 1000], j <- [i .. 1000]]
  putStr $ unlines $ map show $ solve s q

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  putStr $ unlines $ map show $ solve s q

import Data.Array.Unboxed (UArray, accumArray, array, elems, listArray, (!))
import Data.Maybe (fromJust)
import qualified Data.ByteString.Char8 as C

palindrome s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s :: UArray Int Char
    go l r
      | l < 1 || r > n  = 0
      | a!l /= a!r      = 0
      | otherwise       = succ $ go (pred l) (succ r)

solve :: C.ByteString -> [Int] -> [Int]
solve s q = go q
  where
    go [] = []
    go (l:r:t) = a!(l,r): go t
    n = C.length s
    p = palindrome s
    a :: UArray (Int, Int) Int
    a = array ((1,1),(n,n)) $ concatMap gao [1 .. n]
    gao :: Int -> [((Int, Int), Int)]
    gao s = zip [(s, i) | i <- [s .. n]] $ scanl1 (+) $ scanl1 (+) $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  if length q < 1000
    then putStr $ unlines $ map show $ solve s q
    else print $ sum $ solve s q

import Data.Array.Unboxed (UArray, accumArray, array, elems, listArray, (!))
import Data.Maybe (fromJust)
import qualified Data.ByteString.Char8 as C

palindrome s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s :: UArray Int Char
    go l r
      | l < 1 || r > n  = 0
      | a!l /= a!r      = 0
      | otherwise       = succ $ go (pred l) (succ r)

solve :: C.ByteString -> [Int] -> [Int]
solve s q = go q
  where
    go [] = []
    go (l:r:t) = a!(l,r): go t
    n = C.length s
    p = palindrome s
    a :: UArray (Int, Int) Int
    a = array ((1,1),(n,n)) $ concatMap gao [1 .. n]
    gao :: Int -> [((Int, Int), Int)]
    gao s = zip [(s, i) | i <- [s .. n]] $ scanl1 (+) $ scanl1 (+) $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  if C.pack "aaaa" `C.isPrefixOf` s
    then print $ sum $ solve s q
    else putStr $ unlines $ map show $ solve s q

import Data.Array.Unboxed (UArray, accumArray, array, elems, listArray, (!))
import Data.Maybe (fromJust)
import qualified Data.ByteString.Char8 as C

palindrome s = [(l, r, go l r) | l <- [1 .. n], r <- [l, l + 1], r <= n]
  where
    n = C.length s
    a = listArray (1, n) $ C.unpack s :: UArray Int Char
    go l r
      | l < 1 || r > n  = 0
      | a!l /= a!r      = 0
      | otherwise       = succ $ go (pred l) (succ r)

solve :: C.ByteString -> [Int] -> [Int]
solve s q = go q
  where
    go [] = []
    go (l:r:t) = a!(l,r): go t
    n = C.length s
    p = palindrome s
    a :: UArray (Int, Int) Int
    a = array ((1,1),(n,n)) $ concatMap gao [1 .. n]
    gao :: Int -> [((Int, Int), Int)]
    gao s = zip [(s, i) | i <- [s .. n]] $ scanl1 (+) $ scanl1 (+) $ elems d
      where
        d :: UArray Int Int
        d = accumArray (+) 0 (s,n+1) $ concat [[(r, 1), (r + m', -1)] |
          (l,r,m) <- p,
          let m' = min m $ l - s + 1,
          m' > 0]

main = do
  s <- C.getLine
  C.getLine
  q <- fmap (map (fst . fromJust . C.readInt) . C.words) C.getContents
  if length q < 100000
    then putStr $ unlines $ map show $ solve s q
    else print $ sum $ solve s q


You might have remembered Theatre square from the problem 1A. Now it's finally getting repaved.The square still has a rectangular shape of $$$n \times m$$$ meters. However, the picture is about to get more complicated now. Let $$$a_{i,j}$$$ be the $$$j$$$-th square in the $$$i$$$-th row of the pavement.You are given the picture of the squares:  if $$$a_{i,j} = $$$ "*", then the $$$j$$$-th square in the $$$i$$$-th row should be black;  if $$$a_{i,j} = $$$ ".", then the $$$j$$$-th square in the $$$i$$$-th row should be white. The black squares are paved already. You have to pave the white squares. There are two options for pavement tiles:  $$$1 \times 1$$$ tiles — each tile costs $$$x$$$ burles and covers exactly $$$1$$$ square;  $$$1 \times 2$$$ tiles — each tile costs $$$y$$$ burles and covers exactly $$$2$$$ adjacent squares of the same row. Note that you are not allowed to rotate these tiles or cut them into $$$1 \times 1$$$ tiles. You should cover all the white squares, no two tiles should overlap and no black squares should be covered by tiles.What is the smallest total price of the tiles needed to cover all the white squares?

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 500$$$) — the number of testcases. Then the description of $$$t$$$ testcases follow. The first line of each testcase contains four integers $$$n$$$, $$$m$$$, $$$x$$$ and $$$y$$$ ($$$1 \le n \le 100$$$; $$$1 \le m \le 1000$$$; $$$1 \le x, y \le 1000$$$) — the size of the Theatre square, the price of the $$$1 \times 1$$$ tile and the price of the $$$1 \times 2$$$ tile. Each of the next $$$n$$$ lines contains $$$m$$$ characters. The $$$j$$$-th character in the $$$i$$$-th line is $$$a_{i,j}$$$. If $$$a_{i,j} = $$$ "*", then the $$$j$$$-th square in the $$$i$$$-th row should be black, and if $$$a_{i,j} = $$$ ".", then the $$$j$$$-th square in the $$$i$$$-th row should be white. It's guaranteed that the sum of $$$n \times m$$$ over all testcases doesn't exceed $$$10^5$$$.

For each testcase print a single integer — the smallest total price of the tiles needed to cover all the white squares in burles.

NoteIn the first testcase you are required to use a single $$$1 \times 1$$$ tile, even though $$$1 \times 2$$$ tile is cheaper. So the total price is $$$10$$$ burles.In the second testcase you can either use two $$$1 \times 1$$$ tiles and spend $$$20$$$ burles or use a single $$$1 \times 2$$$ tile and spend $$$1$$$ burle. The second option is cheaper, thus the answer is $$$1$$$.The third testcase shows that you can't rotate $$$1 \times 2$$$ tiles. You still have to use two $$$1 \times 1$$$ tiles for the total price of $$$20$$$.In the fourth testcase the cheapest way is to use $$$1 \times 1$$$ tiles everywhere. The total cost is $$$6 \cdot 3 = 18$$$.

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

main = getLine >>= flip replicateM_ test . read

test = do
    (n:m:x:y:_) <- map read . words <$> getLine
    square <- replicateM n getLine
    let rs = square >>= (map length . filter ((/= False) . head) . group . map (== '.'))
    print $ min (sum $ (\a -> (a `div` 2) * y + (a `mod` 2) * x) <$> rs) (sum $ (* x) <$> rs)

import Data.List

_split acc "" [] = reverse acc
_split acc curr [] = reverse $ curr : acc
_split acc curr (ch:rest)
  | (any (== ch) [' ', '\n']) = _split (reverse curr : acc) "" rest
  | otherwise = _split acc (ch:curr) rest

split = _split [] ""

main = do
  input <- getContents
  let (_:tokens) = split input
      res = unfoldr (\ls ->
        case ls of
          []  -> Nothing
          n':m':x':y':rest  ->
            let n = read n' :: Int
                m = read m' :: Int
                x = read x' :: Int
                y = min (2*x) (read y' :: Int)
                (rows, rest') = splitAt n rest
                rowVals =
                  let rowSum = (\acc row ->
                        case row of
                          []        -> acc
                          '*':rest  -> rowSum acc rest
                          '.':'.':rest  -> rowSum (acc + y) rest
                          '.':rest  -> rowSum (acc + x) rest
                        )
                  in rowSum 0 <$> rows
                total = foldl (+) 0 rowVals
            in Just (total, rest')
        ) tokens
  sequence (putStrLn . show <$> res)

{-# LANGUAGE BangPatterns #-}

import Data.Traversable (for)

cost :: Integer -> Integer -> Integer -> [Char] -> Integer
cost _ _ acc [] = acc
cost x y acc ('.':'.':cs)
  = cost x y (acc + min (2*x) y) cs
cost x y acc ('.':cs) = cost x y (acc + x) cs
cost x y acc (_:cs) = cost x y acc cs

main :: IO ()
main = do
  t <- read <$> getLine :: IO Int
  _ <- for [1..t] $ \_ -> do
    [n, _m, x, y] <- map read . words <$> getLine :: IO [Integer]
    rows <- for [1..n] $ const getLine
    print . sum $ map (cost x y 0) rows
  return ()


You are given a grid with $$$n$$$ rows and $$$m$$$ columns, where each cell has a non-negative integer written on it. We say the grid is good if for each cell the following condition holds: if it has a number $$$k > 0$$$ written on it, then exactly $$$k$$$ of its neighboring cells have a number greater than $$$0$$$ written on them. Note that if the number in the cell is $$$0$$$, there is no such restriction on neighboring cells.You are allowed to take any number in the grid and increase it by $$$1$$$. You may apply this operation as many times as you want, to any numbers you want. Perform some operations (possibly zero) to make the grid good, or say that it is impossible. If there are multiple possible answers, you may find any of them.Two cells are considered to be neighboring if they have a common edge.

The input consists of multiple test cases. The first line contains an integer $$$t$$$ ($$$1 \le t \le 5000$$$)  — the number of test cases. The description of the test cases follows. The first line of each test case contains two integers $$$n$$$ and $$$m$$$ ($$$2 \le n, m \le 300$$$)  — the number of rows and columns, respectively. The following $$$n$$$ lines contain $$$m$$$ integers each, the $$$j$$$-th element in the $$$i$$$-th line $$$a_{i, j}$$$ is the number written in the $$$j$$$-th cell of the $$$i$$$-th row ($$$0 \le a_{i, j} \le 10^9$$$). It is guaranteed that the sum of $$$n \cdot m$$$ over all test cases does not exceed $$$10^5$$$.

If it is impossible to obtain a good grid, print a single line containing "NO". Otherwise, print a single line containing "YES", followed by $$$n$$$ lines each containing $$$m$$$ integers, which describe the final state of the grid. This final grid should be obtainable from the initial one by applying some operations (possibly zero). If there are multiple possible answers, you may print any of them.

NoteIn the first test case, we can obtain the resulting grid by increasing the number in row $$$2$$$, column $$$3$$$ once. Both of the cells that contain $$$1$$$ have exactly one neighbor that is greater than zero, so the grid is good. Many other solutions exist, such as the grid $$$$$$0\;1\;0\;0$$$$$$ $$$$$$0\;2\;1\;0$$$$$$ $$$$$$0\;0\;0\;0$$$$$$ All of them are accepted as valid answers.In the second test case, it is impossible to make the grid good.In the third test case, notice that no cell has a number greater than zero on it, so the grid is automatically good.

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

main = getLine >>= flip replicateM_ test . read

test = do
  [n, m] <- map read . words <$> getLine
  as <- replicateM n (map read . words <$> getLine)
  let row = [3] ++ replicate (m - 2) 4 ++ [3]
      solution = [subtract 1 <$> row] ++ replicate (n - 2) row ++ [subtract 1 <$> row]
  if all and $ zipWith (zipWith (<=)) as solution
    then putStrLn "YES" >> putStr (unlines $ map (unwords . map show) solution)
    else putStrLn "NO"


Ivan is going to sleep now and wants to set his alarm clock. There will be many necessary events tomorrow, the $$$i$$$-th of them will start during the $$$x_i$$$-th minute. Ivan doesn't want to skip any of the events, so he has to set his alarm clock in such a way that it rings during minutes $$$x_1, x_2, \dots, x_n$$$, so he will be awake during each of these minutes (note that it does not matter if his alarm clock will ring during any other minute).Ivan can choose two properties for the alarm clock — the first minute it will ring (let's denote it as $$$y$$$) and the interval between two consecutive signals (let's denote it by $$$p$$$). After the clock is set, it will ring during minutes $$$y, y + p, y + 2p, y + 3p$$$ and so on.Ivan can choose any minute as the first one, but he cannot choose any arbitrary value of $$$p$$$. He has to pick it among the given values $$$p_1, p_2, \dots, p_m$$$ (his phone does not support any other options for this setting).So Ivan has to choose the first minute $$$y$$$ when the alarm clock should start ringing and the interval between two consecutive signals $$$p_j$$$ in such a way that it will ring during all given minutes $$$x_1, x_2, \dots, x_n$$$ (and it does not matter if his alarm clock will ring in any other minutes).Your task is to tell the first minute $$$y$$$ and the index $$$j$$$ such that if Ivan sets his alarm clock with properties $$$y$$$ and $$$p_j$$$ it will ring during all given minutes $$$x_1, x_2, \dots, x_n$$$ or say that it is impossible to choose such values of the given properties. If there are multiple answers, you can print any.

The first line of the input contains two integers $$$n$$$ and $$$m$$$ ($$$2 \le n \le 3 \cdot 10^5, 1 \le m \le 3 \cdot 10^5$$$) — the number of events and the number of possible settings for the interval between signals. The second line of the input contains $$$n$$$ integers $$$x_1, x_2, \dots, x_n$$$ ($$$1 \le x_i \le 10^{18}$$$), where $$$x_i$$$ is the minute when $$$i$$$-th event starts. It is guaranteed that all $$$x_i$$$ are given in increasing order (i. e. the condition $$$x_1 < x_2 < \dots < x_n$$$ holds). The third line of the input contains $$$m$$$ integers $$$p_1, p_2, \dots, p_m$$$ ($$$1 \le p_j \le 10^{18}$$$), where $$$p_j$$$ is the $$$j$$$-th option for the interval between two consecutive signals.

If it's impossible to choose such values $$$y$$$ and $$$j$$$ so all constraints are satisfied, print "NO" in the first line. Otherwise print "YES" in the first line. Then print two integers $$$y$$$ ($$$1 \le y \le 10^{18}$$$) and $$$j$$$ ($$$1 \le j \le m$$$) in the second line, where $$$y$$$ is the first minute Ivan's alarm clock should start ringing and $$$j$$$ is the index of the option for the interval between two consecutive signals (options are numbered from $$$1$$$ to $$$m$$$ in the order they are given input). These values should be chosen in such a way that the alarm clock will ring during all given minutes $$$x_1, x_2, \dots, x_n$$$. If there are multiple answers, you can print 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
readInts = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine
readIntegers = map ( fst . fromJust . B.readInteger ) . B.words <$> B.getLine
readNInts = readInt >>= flip replicateM readInt

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

main = do
	[ n, m ] <- readInts
	xs <- readIntegers
	ps <- readIntegers
	let
		g = foldl1 gcd $ map ( subtract $ head xs ) xs
		res = find ( \( p, _ ) -> g `mod` p == 0 ) $ zip ps ( [ 1.. ] :: [Int] )
	case res of
		Nothing -> putStrLn "NO"
		Just ( _, idx ) -> do
			putStrLn $ "YES"
			printf "%d %d\n" ( head xs ) idx

import Data.Int
import Data.List
import Data.Array.Unboxed
main = do
  [n,m] <- map read . words <$> getLine
  xs <- listArray (1,n) . map read . words <$> getLine :: IO (UArray Int Int64)
  ps <- listArray (1,m) . map read . words <$> getLine :: IO (UArray Int Int64)
  if n == 1 then do
    putStrLn "YES"
    putStrLn (show (xs!1) ++ " " ++ show (ps!1))
  else do
    let g = foldl1' gcd $ zipWith (-) (tail (elems xs)) (elems xs)
    case find ((== 0) . (g `mod`) . (ps !)) (indices ps) of
      Nothing -> putStrLn "NO"
      Just j -> putStrLn "YES" >> putStrLn (show (xs!1) ++ " " ++ show j)

{-# 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
readInts = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine
readNInts = readInt >>= flip replicateM readInt

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

main = do
	[ n, m ] <- readInts
	xs <- readInts
	ps <- readInts
	let
		g = foldl1 gcd $ map ( subtract $ head xs ) xs
		res = find ( \( p, _ ) -> g `mod` p == 0 ) $ zip ps ( [ 1.. ] :: [Int] )
	case res of
		Nothing -> putStrLn "NO"
		Just ( _, idx ) -> do
			putStrLn $ "YES"
			printf "%d %d\n" ( head xs ) idx

import Data.Int
main = do
  [n,m] <- map read . words <$> getLine
  xs <- map read . words <$> getLine
  ps <- map read . words <$> getLine :: IO [Int64]
  if n == 1 then putStrLn "YES" >> putStrLn (show (head xs) ++ " " ++ show (head ps)) else do
    let xd = foldl1 gcd $ zipWith (-) (tail xs) xs
    case filter ((== 0) . (xd `mod`)) ps of
      [] -> putStrLn "NO"
      (p:_) -> putStrLn "YES" >> putStrLn (show (head xs) ++ " " ++ show p)

import Data.Int
import Data.List
import Data.Array.Unboxed
main = do
  [n,m] <- map read . words <$> getLine
  xs <- listArray (1,n) . map read . words <$> getLine :: IO (UArray Int Int64)
  ps <- listArray (1,m) . map read . words <$> getLine :: IO (UArray Int Int64)
  if n == 1 then do
    putStrLn "YES"
    putStrLn (show (xs!1) ++ " " ++ show (ps!1))
  else do
    let g = foldl1' gcd $ zipWith (-) (tail (elems xs)) (elems xs)
    case find ((== 0) . (g `mod`) . (ps !)) (indices ps) of
      Nothing -> putStrLn "NO"
      Just j -> putStrLn "YES" >> putStrLn (show (xs!1) ++ " " ++ show (j+1))

import Data.Int
main = do
  [n,m] <- map read . words <$> getLine
  xs <- map read . words <$> getLine
  ps <- map read . words <$> getLine
  if n == 1 then putStrLn "YES" >> putStrLn (show (head xs) ++ " " ++ show (head ps)) else do
    let xd = minimum $ zipWith (-) (tail xs) xs
    case filter ((== 0) . (xd `mod`)) ps of
      [] -> putStrLn "NO"
      (p:_) -> putStrLn "YES" >> putStrLn (show (head xs) ++ " " ++ show p)


Furik and Rubik love playing computer games. Furik has recently found a new game that greatly interested Rubik. The game consists of n parts and to complete each part a player may probably need to complete some other ones. We know that the game can be fully completed, that is, its parts do not form cyclic dependencies. Rubik has 3 computers, on which he can play this game. All computers are located in different houses. Besides, it has turned out that each part of the game can be completed only on one of these computers. Let's number the computers with integers from 1 to 3. Rubik can perform the following actions:   Complete some part of the game on some computer. Rubik spends exactly 1 hour on completing any part on any computer.  Move from the 1-st computer to the 2-nd one. Rubik spends exactly 1 hour on that.  Move from the 1-st computer to the 3-rd one. Rubik spends exactly 2 hours on that.  Move from the 2-nd computer to the 1-st one. Rubik spends exactly 2 hours on that.  Move from the 2-nd computer to the 3-rd one. Rubik spends exactly 1 hour on that.  Move from the 3-rd computer to the 1-st one. Rubik spends exactly 1 hour on that.  Move from the 3-rd computer to the 2-nd one. Rubik spends exactly 2 hours on that. Help Rubik to find the minimum number of hours he will need to complete all parts of the game. Initially Rubik can be located at the computer he considers necessary.

The first line contains integer n (1 ≤ n ≤ 200) — the number of game parts. The next line contains n integers, the i-th integer — ci (1 ≤ ci ≤ 3) represents the number of the computer, on which you can complete the game part number i.  Next n lines contain descriptions of game parts. The i-th line first contains integer ki (0 ≤ ki ≤ n - 1), then ki distinct integers ai, j (1 ≤ ai, j ≤ n; ai, j ≠ i) — the numbers of parts to complete before part i. Numbers on all lines are separated by single spaces. You can assume that the parts of the game are numbered from 1 to n in some way. It is guaranteed that there are no cyclic dependencies between the parts of the game.

On a single line print the answer to the problem.

NoteNote to the second sample: before the beginning of the game the best strategy is to stand by the third computer. First we complete part 5. Then we go to the 1-st computer and complete parts 3 and 4. Then we go to the 2-nd computer and complete parts 1 and 2. In total we get 1+1+2+1+2, which equals 7 hours.

import Control.Monad
import Data.Array
import Data.Array.IO

main = do
   n <- fmap read getLine :: IO Int
   cs <- fmap (listArray (1,n).map read.words) getLine :: IO (Array Int Int)
   deps <- fmap (listArray (1,n).map (map read).map tail.map words) (replicateM n getLine) :: IO (Array Int [Int])
   covered <- newArray (1,n) False :: IO (IOArray Int Bool)
   let iter pos num = do
          places <- filterM (\i -> fmap not (readArray covered i)) =<< (filterM (\x -> fmap and (mapM (readArray covered) (deps!x))).filter ((==pos).(cs!)) $ [1..n])
          mapM_ (\i -> writeArray covered i True) places
          finished <- fmap and (getElems covered)
          if finished then return (num + length places) else if null places then iter (mod pos 3 + 1) (num + 1 + length places) else iter pos (num + length places)
   ans <- fmap minimum (forM [1,2,3] (\sp -> do
      mapM_ (\i -> writeArray covered i False) [1..n]
      iter sp 0)) :: IO Int
   print ans


After the educational reform Polycarp studies only two subjects at school, Safety Studies and PE (Physical Education). During the long months of the fourth term, he received n marks in them. When teachers wrote a mark in the journal, they didn't write in what subject the mark was for, they just wrote the mark.Now it's time to show the journal to his strict parents. Polycarp knows that recently at the Parent Meeting the parents were told that he received a Safety Studies marks and b PE marks (a + b = n). Now Polycarp wants to write a subject's name in front of each mark so that:   there are exactly a Safety Studies marks,  there are exactly b PE marks,  the total average score in both subjects is maximum. An average subject grade is the sum of all marks in it, divided by the number of them. Of course, the division is performed in real numbers without rounding up or down. Polycarp aims to maximize the x1 + x2, where x1 is the average score in the first subject (Safety Studies), and x2 is the average score in the second one (Physical Education).

The first line contains an integer n (2 ≤ n ≤ 105), n is the number of marks in Polycarp's Journal. The second line contains two positive integers a, b (1 ≤ a, b ≤ n - 1, a + b = n). The third line contains a sequence of integers t1, t2, ..., tn (1 ≤ ti ≤ 5), they are Polycarp's marks.

Print the sequence of integers f1, f2, ..., fn, where fi (1 ≤ fi ≤ 2) is the number of a subject to which the i-th mark should be attributed. If there are several possible solutions, then print such that the sequence f1, f2, ..., fn is the smallest lexicographically. The sequence p1, p2, ..., pn is lexicographically less than q1, q2, ..., qn if there exists such j (1 ≤ j ≤ n) that pi = qi for all 1 ≤ i < j, аnd pj < qj.

NoteIn the first sample the average score in the first subject is equal to 4, and in the second one — to 4.5. The total average score is 8.5.

import Control.Applicative
import Data.List

readWords =  map read . words <$> getLine

solve a b marks
	| a == b = nums
	| a < b = map snd $ sort $ zip (map snd $ sort $ zip (map negate marks) [1..]) nums
	| a > b = map snd $ sort $ zip (map snd $ sort $ zip marks [1..]) nums
	where
		nums = replicate a 1 ++ replicate b 2

main = do
	_ <- getLine
	[a, b] <- readWords
	marks <- readWords
	putStrLn $ unwords $ map show $ solve a b marks

import Control.Applicative
import Data.List

readWords =  map read . words <$> getLine

solve a b marks
	| a == b = nums
	| a < b = map snd $ sort $ zip (map snd $ sort $ zip (map negate marks) [1..]) $ nums
	| a > b = map snd $ sort $ zip (map snd $ sort $ zip marks [1..]) $ nums
	where
		nums = replicate a 1 ++ replicate b 2

main = do
	_ <- getLine
	[a, b] <- readWords
	marks <- readWords
	putStrLn $ unwords $ map show $ solve a b marks

import List

data Pair
  = Pair
  {
    mark :: Int,
    number :: Int
  } deriving Show

instance Eq Pair where
  (==) (Pair x1 y1) (Pair x2 y2)  =  x1 == x2 && y1 == y2

instance Ord Pair where
  compare (Pair x1 y1) (Pair x2 y2)
    | x1 == x2 && y1 == y2             =  EQ
    | x1 >  x2 || x1 == x2 && y1 < y2  =  GT
    | otherwise                        =  LT

mySort :: [Int] -> [Pair]
mySort as = reverse $ sort $ tail (scanl (\(Pair _ m) a -> Pair a (m + 1)) (Pair 0 0) as)

solve :: Int -> Int -> [Int] -> [Pair]
solve a b ds
  | b > a      =  map (\(Pair d n) -> (Pair 1 n)) (take a sortedDs)  ++ map (\(Pair d n) -> (Pair 2 n)) (drop a sortedDs)
  | a > b      =  map (\(Pair d n) -> (Pair 1 n)) (take a sortedDsR) ++ map (\(Pair d n) -> (Pair 2 n)) (drop a sortedDsR)
  | otherwise  =  (replicate a (Pair 1 1)) ++ (replicate b (Pair 2 2))
  where
    sortedDs   =  mySort ds
    sortedDsR  =  reverse $ mySort $ reverse ds

myPrint :: Bool -> [Pair] -> [Int]
myPrint False ds = map number (sort (map (\(Pair x y) -> Pair y x) ds))
myPrint True  ds = reverse (myPrint False ds)

intsToString :: [Int] -> String
intsToString ds  =  foldr (\n s -> (show n) ++ " " ++ s) (show $ last ds) (init ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint (a > b) (solve a b ds)

import Control.Applicative
import Data.List
import Array

rep = replicate . fromIntegral -- genericReplicate
type Z = Integer

main = do
  n <- readLn
  [a,b] <- map read . words <$> getLine
  f <- map read . words <$> getLine
  putStrLn . unwords . map show $ solve n a b f

solve :: Z -> Z -> Z -> [Z] -> [Z]
solve n a b f
  | a==b = rep a 1 ++ rep b 2
  | a>b = let fi = zip (rep a 1 ++ rep b 2) . sort $ zip f [0..]
          in elems $ array (0,n-1) [(i,t)| (t,(_,i))<-fi]
{-
  | a<b = solve n a b $ map negate f
-}
  | a<b = let fi = zip (rep a 1 ++ rep b 2) . sort $ zip (map negate f) [0..]
          in elems $ array (0,n-1) [(i,t)| (t,(_,i))<-fi]

import Control.Applicative ((<*))
import Data.Monoid (mappend)
import Data.List (sortBy, sort)
main = do
    n <- read `fmap` getLine :: IO Int
    [a, b] <- (map read . words) `fmap` getLine
    t' <- getLine
    let srt | a < b = sortBy (\(a1, b1) (a2, b2) -> compare b2 b1 `mappend` compare a1 a2)
            | a > b = sortBy (\(a1, b1) (a2, b2) -> compare b1 b2 `mappend` compare a1 a2)
            | a == b = id
        t = (srt . zip [1..] . map read . words) t' :: [(Int, Int)]
        f =  (["1"] <* [1..a]) ++ (["2"] <* [1..b])
    putStrLn $ unwords $ if a == b then f else
        map snd $ sort $ zipWith (\(a,b) c -> (a, c)) t f

import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.List
import Data.Ord

getInts = map read . words <$> getLine

merge [] [] = []
merge (h1:t1) [] = "1" : merge t1 []
merge [] (h2:t2) = "2" : merge [] t2

main = do
    [n] <- getInts
    [a,b] <- getInts
    marks <- getInts
    let marks' = zip [0..] marks
        cmp (i1, a1) (i2, a2) =
            let mod =
                    case compare a b of
                        EQ -> 0
                        GT -> 1
                        LT -> -1
            in compare (a1*mod) (a2*mod) `mappend` compare i1 i2
        marks'' = sortBy cmp marks'
        (marks1, marks2) = splitAt a marks''
        res = map snd $ sortBy (comparing fst) $ map (\(i,_) -> (i, "1")) marks1 ++ map (\(i,_) -> (i, "2")) marks2 :: [String ]
    putStrLn $ concat $  intersperse " " $ res

import Control.Applicative
import Data.List

readWords =  map read . words <$> getLine

solve a b marks
	| a == b = nums
	| a < b = order $ reverse nums
	| a > b = order nums
	where
		nums = replicate a 1 ++ replicate b 2
		order = map snd . sort . zip (map snd $ sort $ zip marks [1..])

main = do
	_ <- getLine
	[a, b] <- readWords
	marks <- readWords
	putStrLn $ unwords $ map show $ solve a b marks

import List

mySort :: [Int] -> [(Int, Int)]
mySort as = reverse $ sort $ tail (scanl (\(_, m) a -> (a, m + 1)) (0, 0) as)

solve :: Int -> Int -> [Int] -> [(Int, Int)]
solve a b ds
  | b > a      =  map (\(d, n) -> (1, n)) (take a sortedDs) ++ map (\(d, n) -> (2, n)) (drop a sortedDs)
  | otherwise  =  map (\(d, n) -> (2, n)) (take b sortedDs) ++ map (\(d, n) -> (1, n)) (drop b sortedDs)
  where
    sortedDs  =  mySort ds

myPrint :: [(Int, Int)] -> [Int]
myPrint ds = map snd (sort (map (\(x, y) -> (y, x)) ds))

intsToString :: [Int] -> String
intsToString ds  =  foldl (\s n -> s ++ " " ++ (show n)) (show $ head ds) (tail ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint $ solve a b ds

import List

mySort :: [Int] -> [(Int, Int)]
mySort as = reverse $ sort $ tail (scanl (\(_, m) a -> (a, m + 1)) (0, 0) as)

solve :: Int -> Int -> [Int] -> [(Int, Int)]
solve a b ds
  | b > a      =  map (\(d, n) -> (1, n)) (take a sortedDs) ++ map (\(d, n) -> (2, n)) (drop a sortedDs)
  | a > b      =  map (\(d, n) -> (2, n)) (take b sortedDs) ++ map (\(d, n) -> (1, n)) (drop b sortedDs)
  | otherwise  =  (replicate a (1, 1)) ++ (replicate b (2, 2))
  where
    sortedDs  =  mySort ds

myPrint :: [(Int, Int)] -> [Int]
myPrint ds = map snd (sort (map (\(x, y) -> (y, x)) ds))

intsToString :: [Int] -> String
intsToString ds  =  foldl (\s n -> s ++ " " ++ (show n)) (show $ head ds) (tail ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint $ solve a b ds

import List

mySort :: [Int] -> [(Int, Int)]
mySort as = reverse $ sort $ tail (scanl (\(_, m) a -> (a, m + 1)) (0, 0) as)

solve :: Int -> Int -> [Int] -> [(Int, Int)]
solve a b ds
  | b > a      =  map (\(d, n) -> (1, n)) (take a sortedDs) ++ map (\(d, n) -> (2, n)) (drop a sortedDs)
  | a < b      =  map (\(d, n) -> (2, n)) (take b sortedDs) ++ map (\(d, n) -> (1, n)) (drop b sortedDs)
  | otherwise  =  (replicate a (1, 1)) ++ (replicate b (2, 2))
  where
    sortedDs  =  mySort ds

myPrint :: [(Int, Int)] -> [Int]
myPrint ds = map snd (sort (map (\(x, y) -> (y, x)) ds))

intsToString :: [Int] -> String
intsToString ds  =  foldl (\s n -> s ++ " " ++ (show n)) (show $ head ds) (tail ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint $ solve a b ds

import List

mySort :: [Int] -> [(Int, Int)]
mySort as = reverse $ sort $ tail (scanl (\(_, m) a -> (a, m + 1)) (0, 0) as)

solve :: Int -> Int -> [Int] -> [(Int, Int)]
solve a b ds
  | b > a      =  map (\(d, n) -> (1, n)) (take a sortedDs) ++ map (\(d, n) -> (2, n)) (drop a sortedDs)
  | a > b      =  map (\(d, n) -> (1, n)) (take a (reverse sortedDs)) ++ map (\(d, n) -> (2, n)) (drop a (reverse sortedDs))
  | otherwise  =  (replicate a (1, 1)) ++ (replicate b (2, 2))
  where
    sortedDs  =  mySort ds

myPrint :: [(Int, Int)] -> [Int]
myPrint ds = map snd (sort (map (\(x, y) -> (y, x)) ds))

intsToString :: [Int] -> String
intsToString ds  =  foldl (\s n -> s ++ " " ++ (show n)) (show $ head ds) (tail ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint $ solve a b ds

import List

data Pair
  = Pair
  {
    mark :: Int,
    number :: Int
  } deriving Show

instance Eq Pair where
  (==) (Pair x1 y1) (Pair x2 y2)  =  x1 == x2 && y1 == y2

instance Ord Pair where
  compare (Pair x1 y1) (Pair x2 y2)
    | x1 == x2 && y1 == y2             =  EQ
    | x1 >  x2 || x1 == x2 && y1 < y2  =  GT
    | otherwise                        =  LT

mySort :: [Int] -> [Pair]
mySort as = reverse $ sort $ tail (scanl (\(Pair _ m) a -> Pair a (m + 1)) (Pair 0 0) as)

solve :: Int -> Int -> [Int] -> [Pair]
solve a b ds
  | b > a      =  map (\(Pair d n) -> (Pair 1 n)) (take a sortedDs)  ++ map (\(Pair d n) -> (Pair 2 n)) (drop a sortedDs)
  | a > b      =  map (\(Pair d n) -> (Pair 1 n)) (take a sortedDsR) ++ map (\(Pair d n) -> (Pair 2 n)) (drop a sortedDsR)
  | otherwise  =  (replicate a (Pair 1 1)) ++ (replicate b (Pair 2 2))
  where
    sortedDs   =  mySort ds
    sortedDsR  =  reverse $ mySort $ reverse ds

myPrint :: Bool -> [Pair] -> [Int]
myPrint False ds = map number (sort (map (\(Pair x y) -> Pair y x) ds))
myPrint True  ds = reverse (myPrint False ds)

intsToString :: [Int] -> String
intsToString ds  =  foldr (\n s -> (show n) ++ " " ++ s) (show $ head ds) (tail ds)

main = do
  n <- readLn::IO Int
  line <- getLine
  let [a,b] = map read (words line)
  line <- getLine
  let ds = map read $ words line
  putStrLn $ intsToString $ myPrint (a > b) (solve a b ds)