You are given an array $$$a_1, a_2, \dots, a_n$$$, consisting of $$$n$$$ integers. You are also given an integer value $$$x$$$.Let $$$f(k)$$$ be the maximum sum of a contiguous subarray of $$$a$$$ after applying the following operation: add $$$x$$$ to the elements on exactly $$$k$$$ distinct positions. An empty subarray should also be considered, it has sum $$$0$$$.Note that the subarray doesn't have to include all of the increased elements.Calculate the maximum value of $$$f(k)$$$ for all $$$k$$$ from $$$0$$$ to $$$n$$$ independently.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 5000$$$) — the number of testcases. The first line of the testcase contains two integers $$$n$$$ and $$$x$$$ ($$$1 \le n \le 5000$$$; $$$0 \le x \le 10^5$$$) — the number of elements in the array and the value to add. The second line contains $$$n$$$ integers $$$a_1, a_2, \dots, a_n$$$ ($$$-10^5 \le a_i \le 10^5$$$). The sum of $$$n$$$ over all testcases doesn't exceed $$$5000$$$.

For each testcase, print $$$n + 1$$$ integers — the maximum value of $$$f(k)$$$ for all $$$k$$$ from $$$0$$$ to $$$n$$$ independently.

NoteIn the first testcase, it doesn't matter which elements you add $$$x$$$ to. The subarray with the maximum sum will always be the entire array. If you increase $$$k$$$ elements by $$$x$$$, $$$k \cdot x$$$ will be added to the sum.In the second testcase:   For $$$k = 0$$$, the empty subarray is the best option.  For $$$k = 1$$$, it's optimal to increase the element at position $$$3$$$. The best sum becomes $$$-1 + 5 = 4$$$ for a subarray $$$[3, 3]$$$.  For $$$k = 2$$$, it's optimal to increase the element at position $$$3$$$ and any other element. The best sum is still $$$4$$$ for a subarray $$$[3, 3]$$$.  For $$$k = 3$$$, you have to increase all elements. The best sum becomes $$$(-2 + 5) + (-7 + 5) + (-1 + 5) = 5$$$ for a subarray $$$[1, 3]$$$.

-- problem: https://codeforces.com/contest/1644/problem/C
-- origin: https://codeforces.com/contest/1644/submission/147353835

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let -- Start to calculate len, which is the length corresponding to the max subarray sum.
        -- func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
        --   where
        --     (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
        --     (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        -- (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ zip [0 ..] a
        -- len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans
        -- End calculating. If don't want to calculate it, set len = 0, and replace maxByLen.
        len = 0
        maxByLen = scanr max (prefixSums ! n) (0:rsByLen)
        prefixSums = listArray (0, n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [len + 1 .. n - 1]]

        -- maxByLen
        --   | len == n = replicate (len + 1) maxV
        --   | otherwise = replicate (len + 1) maxV ++ scanr max (prefixSums ! n) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
          where
            (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
            (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ zip [0 ..] a
        len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans

        prefixSums = listArray (0, n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [len + 1 .. n - 1]]

        maxByLen
          | len == n = replicate (len + 1) maxV
          | otherwise = replicate (len + 1) maxV ++ scanr max (prefixSums ! n) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let prefixSums = listArray (0, n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [1 .. n -1]]
        xwides = zipWith (+) (scanr max (prefixSums ! n) (0 : rsByLen)) [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let prefixSums = listArray (0,n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [1 .. n]]
        xwides = zipWith (+) (scanr1 max (0:rsByLen)) [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let prefixSums = listArray (0,n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [0 .. n]]
        xwides = zipWith (+) (scanr1 max rsByLen) [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields -fvia-C -optc-O3 #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = res k
    where
       res 0 = (l, maxF)
         where
            l = v1
               where v1 = drop 1 $ scanl (\x y -> maximum' [0, x + y]) 0 a
            maxF = v2
               where v2 = (maximum' l : [])
       res n = (l, maxF)
         where
            l = v1
                where v1 = zipWith (\a b -> maximum' [a + x, b + x + a]) a (0 :  fst prev)
            maxF = v2
                where v2 = (maximum' (0:l) : snd prev)

            prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse (snd answer)) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

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 Data.Maybe

--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import Data.List
import Data.Array.Unboxed

mainFun :: SP Builder
mainFun = do
  t <- getInt
  fmap mconcat $ replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let
      prefixSums :: UArray Int Int
      prefixSums = listArray (0, n) $ scanl' (+) 0 a

      rsByLen :: UArray Int Int
      -- range sums
      rsByLen = accumArray max minBound (0, n) $ do
        (i, psi) <- assocs prefixSums
        j <- [i .. n]
        pure (j - i, prefixSums ! j - psi)

      xwides   = zipWith (+) (scanr1 max $ elems rsByLen) [0, x ..]
      xnarrows = scanl1 max $ zipWith (+) (elems rsByLen) [0, x ..]
    pure $ putInts $ zipWith max xwides xnarrows

type SP = State P.ByteString
type S = StateT P.ByteString

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

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

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

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

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

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 Data.Maybe

--import Data.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import Data.List
import Data.Array.Unboxed

mainFun :: SP Builder
mainFun = do
  t <- getInt
  fmap mconcat $ replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let
      ps = listArray (0, n) $ scanl' (+) 0 a
      xps = array (0, n) [(i, psi + x * i) | (i, psi) <- assocs ps]

      ack :: UArray Int Int -> UArray Int Int
      ack arr = accumArray max minBound (0, n) $ do
        (i, ai) <- assocs arr
        j <- [i .. n]
        pure (j - i, arr ! j - ai)

      narrows = ack xps
      wides = ack ps

      xwides = zipWith (+) (scanr1 max $ elems wides) [0, x ..]
      xnarrows = scanl1 max $ elems narrows
    pure $ putInts $ zipWith max xwides xnarrows

type SP = State P.ByteString
type S = StateT P.ByteString

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

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

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

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

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

{-# LANGUAGE TypeApplications #-}
import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Array.Unsafe
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, x] <- readInts
    a <- listArray @UArray (1, n) <$> readInts
    dp <- newArray @IOUArray ((0, 0), (n, n)) 0
    forM_ [1..n] $ \i ->
        forM_ [0..n] $ \j -> do
            nox <- (a!i +) . max 0 <$> readArray dp (i - 1, j)
            writeArray dp (i, j) =<< if j == 0 then pure nox else do
                yesx <- (a!i + x +) . max 0 <$> readArray dp (i - 1, j - 1)
                pure $ max nox yesx
    dp <- unsafeFreeze @_ @_ @_ @_ @UArray dp
    putStrLn $ unwords $ map (show . foldl' max 0) [[dp!(i, j) | i <- [0..n]] | j <- [0..n]]

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

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

{-# LANGUAGE TypeApplications, BangPatterns #-}
import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Array.Unsafe
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, x] <- readInts
    a <- listArray @UArray (1, n) <$> readInts
    dp <- newArray @IOUArray ((0, 0), (n, n)) 0
    forM_ [1..n] $ \i ->
        forM_ [0..n] $ \j -> do
            !nox <- (a!i +) . max 0 <$> readArray dp (i - 1, j)
            writeArray dp (i, j) =<< if j == 0 then pure nox else do
                !yesx <- (a!i + x +) . max 0 <$> readArray dp (i - 1, j - 1)
                pure $! max nox yesx
    dp <- unsafeFreeze @_ @_ @_ @_ @UArray dp
    putStrLn $ unwords $ map (show . maximum) [[dp!(i, j) | i <- [0..n]] | j <- [0..n]]

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

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

{-# LANGUAGE TypeApplications #-}
import Control.Monad
import Data.Array.IO
import Data.Array.Unboxed
import Data.Array.Unsafe
import Data.Maybe
import qualified Data.ByteString.Char8 as C

solve :: IO ()
solve = do
    ~[n, x] <- readInts
    a <- listArray @UArray (1, n) <$> readInts
    dp <- newArray @IOUArray ((0, 0), (n, n)) 0
    forM_ [1..n] $ \i ->
        forM_ [0..n] $ \j -> do
            nox <- (a!i +) . max 0 <$> readArray dp (i - 1, j)
            writeArray dp (i, j) =<< if j == 0 then pure nox else do
                yesx <- (a!i + x +) . max 0 <$> readArray dp (i - 1, j - 1)
                pure $ max nox yesx
    dp <- unsafeFreeze @_ @_ @_ @_ @UArray dp
    putStrLn $ unwords $ map (show . maximum) [[dp!(i, j) | i <- [0..n]] | j <- [0..n]]

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

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

-- problem: https://codeforces.com/contest/1644/problem/C
-- origin: https://codeforces.com/contest/1644/submission/147353835

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let -- Start to calculate len, which is the length corresponding to the max subarray sum.
        -- func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
        --   where
        --     (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
        --     (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        -- (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ zip [0 ..] a
        -- len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans
        -- End calculating. If don't want to calculate it, set len = 0, maxV = 0.
        len = 0
        maxV = 0
        prefixSums = listArray (0, n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [len + 1 .. n - 1]]

        maxByLen
          | len == n = replicate (len + 1) maxV
          | otherwise = replicate (len + 1) maxV ++ scanr max (prefixSums ! n) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
          where
            (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
            (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ zip [0 ..] a
        len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans

        prefixSums = listArray (0, n) $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j]] | j <- [len + 1 .. n - 1]]

        maxByLen = replicate (len + 1) maxV ++ if null rsByLen then [] else scanr max (prefixSums ! n) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
          where
            (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
            (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ zip [0 ..] a
        len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans

        prefixSums = listArray (0, n - 1) $ tail $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j - 1]] | j <- [len + 1 .. n - 1]]

        maxByLen = replicate (len + 1) maxV ++ if null rsByLen then [] else scanr max (prefixSums ! (n - 1)) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
        xnarrows = scanl1 max $ zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ zipWith max xwides xnarrows

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let prefixSums = listArray (0, n - 1) $ tail $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j - 1]] | j <- [1 .. n - 1]]

        xwides = zipWith (+) (scanr max (prefixSums ! (n - 1)) (0 : rsByLen)) [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Array (assocs, listArray, (!))
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let ia = listArray (0, n -1) a
        func (startV, startI, endV, endI) (i, v) = (sv, si, ev, ei)
          where
            (sv, si) = if startV < 0 then (v, i) else (startV + v, startI)
            (ev, ei) = if sv > endV then (sv, i) else (endV, endI)

        (startV, startI, maxV, endI) = foldl func (0, 0, 0, -1) $ assocs ia
        len = let ans = endI - startI + 1 in if ans <= 0 then 0 else ans

        prefixSums = listArray (0, n - 1) $ tail $ scanl (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums ! (i + j) - prefixSums ! i | i <- [0 .. n - j - 1]] | j <- [len + 1 .. n - 1]]

        maxByLen = replicate (len + 1) maxV ++ if null rsByLen then [] else scanr max (prefixSums ! (n - 1)) rsByLen

        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let mark :: [Int] -> [Int] -> Int -> Int -> Int -> Int -> Int -> ([Int], Int, Int)
        mark [] prefixSums i startV startI endV endI = (tail prefixSums, endV, let ans = endI - startI + 1 in if ans <= 0 then 0 else ans)
        mark (li : ls) prefixSums i startV startI endV endI = mark ls pre (i + 1) sv si ev ei
          where
            pre = prefixSums ++ [last prefixSums + li]
            modifyStart = startV < 0
            sv = if modifyStart then li else startV + li
            si = if modifyStart then i else startI
            modifyEnd = sv > endV
            ev = if modifyEnd then sv else endV
            ei = if modifyEnd then i else endI

        (prefixSums, maxV, len) = mark a [0] 0 0 0 0 (-1)

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums !! (i + j) - prefixSums !! i | i <- [0 .. n - j - 1]] | j <- [len + 1 .. n - 1]]

        maxByLen = replicate (len + 1) maxV ++ scanr max (prefixSums !! (n - 1)) rsByLen
        xwides = zipWith (+) maxByLen [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

import Control.Monad.State (State, evalState, replicateM, state)
import Data.Bifunctor (first)
import Data.Char (isDigit, isSpace)
import Data.List (scanl')

mainFunc :: State [Char] [[Char]]
mainFunc = do
  t <- getInt
  replicateM t $ do
    n <- getInt
    x <- getInt
    a <- replicateM n getInt
    let prefixSums :: [Int]
        prefixSums = scanl' (+) 0 a

        rsByLen :: [Int] -- range sums
        rsByLen = [maximum [prefixSums !! (i + (n - j)) - prefixSums !! i | i <- [0 .. j]] | j <- [0 .. n]]
        -- i is the index of the start of the range, (n - j) equals to the interval
        -- so that we get xwides using scanl1 instead of scanr1
        xwides = zipWith (+) (scanl1 max rsByLen) [0, x ..]
    pure $ putInts $ scanl1 max xwides

getInt :: State [Char] Int
getInt = state (first (\x -> read x :: Int) . span isInt . dropWhile isSpace)
  where
    isInt c = isDigit c || (c == '-')

putInts :: [Int] -> [Char]
putInts x = unwords (map show x) ++ "\n"

main :: IO ()
main = do
  inp <- getContents
  putStr $ concat $ evalState mainFunc inp

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = snd (res k)
    where
        a' = zipWith (+) a (replicate k x)
        res 0 = (v1, v2)
	    where
	        v1 = (0 : scanl1 (\x y -> maximum' [0, x + y]) a)
		v2 = (maximum' v1 : [])
        res n = (v1, v2)
	     where
	        v1 = (0 : zipWith (\a b ->  maximum' [a, a + b]) a' (fst prev))
		v2 = (maximum' (0:v1) : snd prev)
		prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse answer) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = snd (res k)
    where
        a' = zipWith (+) a (replicate k x)
        res 0 = (v1, v2)
	    where
	        v1 = scanl (\x y -> maximum' [0, x + y]) 0 a
		v2 = (maximum' v1 : [])
        res n = (v1, v2)
	     where
	        v1 = zipWith (\a b ->  maximum' [a, a + b]) a' (fst prev)
		v2 = (maximum' (0:v1) : snd prev)
		prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse answer) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = snd (res k)
    where
        res 0 = (v1, v2)
	    where
	        v1 = scanl1 (\x y -> maximum' [0, x + y]) a
		v2 = (maximum' (0:v1) : [])
        res n = (v1, v2)
	     where
	        v1 = zipWith (\a b -> maximum' [a + x, b + x + a]) a (0 :  fst prev)
		v2 = (maximum' (0:v1) : snd prev)
		prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse answer) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = snd (res k)
    where
        res 0 = (v1, v2)
	    where
	        v1 = scanl1 (\x y -> maximum' [0, x + y]) a
		v2 = (maximum' (0:v1) : [])
        res n = (v1, v2)
	     where
	        v1 = zipWith (\a b -> a + x + maximum' [0, b]) a (0 :  fst prev)
		v2 = (maximum' (0:v1) : snd prev)
		prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse answer) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
import Control.Monad (replicateM_, replicateM)

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a

sol a k x = snd (res k)
    where
        res 0 = (v1, v2)
	    where
	        v1 = drop 1 $ scanl (\x y -> maximum' [0, x + y]) 0 a
		v2 = (maximum' v1 : [])
        res n = (v1, v2)
	     where
	        v1 = zipWith (\a b -> maximum' [a + x, b + x + a]) a (0 :  fst prev)
		v2 = (maximum' v1 : snd prev)
		prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    let answer = sol a n x
    M.forM_ (reverse answer) $ \p -> printf "%lld " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve

{-# LANGUAGE CPP, DatatypeContexts, DeriveFunctor, GADTs, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections  #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -O3 -funbox-strict-fields -fvia-C -optc-O3 #-}

import Control.Monad (
    MonadPlus (mplus),
    foldM_,
    forM_,
    guard,
    join,
    replicateM,
    replicateM_,
 )

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 Data.Monoid as M
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 Data.Bits

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

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

maximum' a = L.foldl1' max a
--maximum' a = maximum a

sol a k x = snd (res k)
    where
        res 0 = (v1, v2)
           where
             v1 = scanl1 (\x y -> maximum' [0, x + y]) a
             v2 = (maximum' (0 : v1) : [])
        res n = (v1, v2)
            where
              v1 = zipWith (\a b -> maximum' [0, a + x + b]) a (0 :  fst prev)
              v2 = (maximum' v1 : snd prev)
              prev = res (n - 1)

solve :: IO()
solve = do
    [n, x] <- B8.getLine <&> readIntB8s
    a <- B8.getLine <&> readIntB8s
    forM_ (reverse (sol a n x)) $ \p -> printf "%d " p
    printf "\n"

main :: IO()
main = do
    t <- B8.getLine <&> readIntB8
    replicateM_ t solve


Recently Monocarp got a job. His working day lasts exactly $$$m$$$ minutes. During work, Monocarp wants to drink coffee at certain moments: there are $$$n$$$ minutes $$$a_1, a_2, \dots, a_n$$$, when he is able and willing to take a coffee break (for the sake of simplicity let's consider that each coffee break lasts exactly one minute). However, Monocarp's boss doesn't like when Monocarp takes his coffee breaks too often. So for the given coffee break that is going to be on minute $$$a_i$$$, Monocarp must choose the day in which he will drink coffee during the said minute, so that every day at least $$$d$$$ minutes pass between any two coffee breaks. Monocarp also wants to take these $$$n$$$ coffee breaks in a minimum possible number of working days (he doesn't count days when he is not at work, and he doesn't take coffee breaks on such days). Take into account that more than $$$d$$$ minutes pass between the end of any working day and the start of the following working day.For each of the $$$n$$$ given minutes determine the day, during which Monocarp should take a coffee break in this minute. You have to minimize the number of days spent.

The first line contains three integers $$$n$$$, $$$m$$$, $$$d$$$ $$$(1 \le n \le 2\cdot10^{5}, n \le m \le 10^{9}, 1 \le d \le m)$$$ — the number of coffee breaks Monocarp wants to have, the length of each working day, and the minimum number of minutes between any two consecutive coffee breaks. The second line contains $$$n$$$ distinct integers $$$a_1, a_2, \dots, a_n$$$ $$$(1 \le a_i \le m)$$$, where $$$a_i$$$ is some minute when Monocarp wants to have a coffee break.

In the first line, write the minimum number of days required to make a coffee break in each of the $$$n$$$ given minutes.  In the second line, print $$$n$$$ space separated integers. The $$$i$$$-th of integers should be the index of the day during which Monocarp should have a coffee break at minute $$$a_i$$$. Days are numbered from $$$1$$$. If there are multiple optimal solutions, you may print any of them.

NoteIn the first example, Monocarp can take two coffee breaks during the first day (during minutes $$$1$$$ and $$$5$$$, $$$3$$$ minutes will pass between these breaks). One break during the second day (at minute $$$2$$$), and one break during the third day (at minute $$$3$$$).In the second example, Monocarp can determine the day of the break as follows: if the minute when he wants to take a break is odd, then this break is on the first day, if it is even, then this break is on the second day.

import Control.Applicative
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as BS
import Data.Array.IO.Safe
import qualified Data.Set as Set
import Control.Monad.State

readIntBS = fst . fromJust . BS.readInt

main = do
  [n,m,d] <- map read . words <$> getLine :: IO [Int]
  as <- map read . words <$> getLine :: IO [Int]

  check <- newArray (1,n) 0 :: IO (IOUArray Int Int)

  let set = Set.fromList $ zip as [1..]

  let
    solve :: Int -> StateT (Set.Set (Int,Int)) IO Int
    solve day = do
      set <- get
      if Set.null set then
        return (day-1)

        else do
        let ((mn,i), set_) = Set.deleteFindMin set
        put set_

        lift $ writeArray check i day

        let
          aux k = do
            res <- Set.lookupGT (k+d+1,0) <$> get
            case res of
              Just (b, j) -> do
                modify $ Set.delete (b, j)
                lift $ writeArray check j day
                aux b
              Nothing -> return ()

        aux mn
        solve (day+1)

  print =<< evalStateT (solve 1) set
  putStrLn =<< unwords . map show <$> getElems check


This is the easy version of the problem. The only difference between the easy and the hard versions are removal queries, they are present only in the hard version."Interplanetary Software, Inc." together with "Robots of Cydonia, Ltd." has developed and released robot cats. These electronic pets can meow, catch mice and entertain the owner in various ways.The developers from "Interplanetary Software, Inc." have recently decided to release a software update for these robots. After the update, the cats must solve the problems about bracket sequences. One of the problems is described below.  First, we need to learn a bit of bracket sequence theory. Consider the strings that contain characters "(", ")" and ".". Call a string regular bracket sequence (RBS), if it can be transformed to an empty string by one or more operations of removing either single "." characters, or a continuous substring "()". For instance, the string "(()(.))" is an RBS, as it can be transformed to an empty string with the following sequence of removals: "(()(.))" $$$\rightarrow$$$ "(()())" $$$\rightarrow$$$ "(())" $$$\rightarrow$$$ "()" $$$\rightarrow$$$ "". We got an empty string, so the initial string was an RBS. At the same time, the string ")(" is not an RBS, as it is not possible to apply such removal operations to it.An RBS is simple if this RBS is not empty, doesn't start with ".", and doesn't end with ".".Denote the substring of the string $$$s$$$ as its sequential subsegment. In particular, $$$s[l\dots r] = s_ls_{l+1}\dots s_r$$$, where $$$s_i$$$ is the $$$i$$$-th character of the string $$$s$$$.Now, move on to the problem statement itself. You are given a string $$$s$$$, initially consisting of characters "(" and ")". You need to answer the queries of the following kind.Given two indices, $$$l$$$ and $$$r$$$ ($$$1 \le l < r \le n$$$), and it's guaranteed that the substring $$$s[l\dots r]$$$ is a simple RBS. You need to find the number of substrings in $$$s[l\dots r]$$$ such that they are simple RBS. In other words, find the number of index pairs $$$i$$$, $$$j$$$ such that $$$l \le i < j \le r$$$ and $$$s[i\dots j]$$$ is a simple RBS.You are an employee in "Interplanetary Software, Inc." and you were given the task to teach the cats to solve the problem above, after the update.Note that the "." character cannot appear in the string in this version of the problem. It is only needed for the hard version.

The first line contains two integers $$$n$$$ and $$$q$$$ ($$$2 \le n \le 3\cdot10^5$$$, $$$1 \le q \le 3\cdot10^5$$$), the length of the string, and the number of queries. The second line contains the string $$$s$$$, consisting of $$$n$$$ characters "(" and ")". Each of the following $$$q$$$ lines contains three integers $$$t$$$, $$$l$$$ and $$$r$$$ ($$$t = 2$$$, $$$1 \le l < r \le n$$$), the queries you need to answer. It is guaranteed that all the queries are valid and correspond to the problem statements. Note that $$$t$$$ is unused and always equal to two in this problem. It is required for the hard version of the problem.

For each query, print a single integer in a separate line, the number of substrings that are simple RBS. The answers must be printed in the same order as the queries are specified in the input.

NoteConsider the example test case.The answer to the first query is $$$3$$$, as there are three suitable substrings: $$$s[3\dots6]$$$, $$$s[3\dots4]$$$ and $$$s[5\dots6]$$$.The answer to the second query is $$$4$$$. The substrings are $$$s[3\dots6]$$$, $$$s[3\dots4]$$$, $$$s[5\dots6]$$$ and $$$s[2\dots7]$$$.The answer to the third query is $$$1$$$. The substring is $$$s[8\dots9]$$$.The answer to the fourth query is $$$6$$$. The substrings are $$$s[3\dots6]$$$, $$$s[3\dots4]$$$, $$$s[5\dots6]$$$, $$$s[2\dots7]$$$, $$$s[8\dots9]$$$ and $$$s[2\dots9]$$$.

import Control.Monad
import Data.Array
import Data.Char
import Data.Maybe
import qualified Data.ByteString.Char8 as C
import qualified Text.Parsec as P

solve :: IO ()
solve = do
    ~[n, q] <- readInts
    s <- takeWhile (not . isSpace) . C.unpack <$> C.getLine
    let Right chs = P.parse (P.many parseTopRBS) "" s
        cnta = accumArray (const id) 0 (0, n+1) $ combine chs []
        suma = listArray (0, n) $ scanl1 (+) $ elems cnta
    replicateM_ q $ do
        ~[_, l, r] <- readInts
        print $ suma!r - suma!(l-1) - cnta!(l-1) * (cnta!r - cnta!(l-1))

type DList a = [a] -> [a]

combine :: [(DList (Int, Int), Int)] -> DList (Int, Int)
combine xs = foldr (.) id accs . (zip ends [1..] ++) where (accs, ends) = unzip xs

parseTopRBS :: P.Parsec String s (DList (Int, Int), Int)
parseTopRBS = P.skipMany (P.char ')') *> parseRBS

parseRBS :: P.Parsec String s (DList (Int, Int), Int)
parseRBS = P.char '(' *>
           ((,) <$> (combine <$> P.many parseRBS) <*> (P.sourceColumn <$> P.getPosition))
           <* (void (P.char ')') P.<|> P.eof)

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

main :: IO ()
main = solve


You are given a bracket sequence $$$s$$$ consisting of $$$n$$$ opening '(' and closing ')' brackets.A regular bracket sequence is a bracket sequence that can be transformed into a correct arithmetic expression by inserting characters '1' and '+' between the original characters of the sequence. For example, bracket sequences "()()", "(())" are regular (the resulting expressions are: "(1)+(1)", "((1+1)+1)"), and ")(" and "(" are not.You can change the type of some bracket $$$s_i$$$. It means that if $$$s_i = $$$ ')' then you can change it to '(' and vice versa.Your task is to calculate the number of positions $$$i$$$ such that if you change the type of the $$$i$$$-th bracket, then the resulting bracket sequence becomes regular.

The first line of the input contains one integer $$$n$$$ ($$$1 \le n \le 10^6$$$) — the length of the bracket sequence. The second line of the input contains the string $$$s$$$ consisting of $$$n$$$ opening '(' and closing ')' brackets.

Print one integer — the number of positions $$$i$$$ such that if you change the type of the $$$i$$$-th bracket, then the resulting bracket sequence becomes regular.

module Main where

data Balance = Balance { value :: Int, bound :: Int }
             deriving (Show, Eq)
data Position = Position { left :: Balance, right :: Balance, char :: Char }
              deriving (Show, Eq)

lbalance :: String -> [Balance]
lbalance = scanl update (Balance 0 0)
    where update (Balance value bound) '(' = Balance (value + 1) bound
          update (Balance value bound) ')' = Balance (value - 1) (min bound (value - 1))

rbalance :: String -> [Balance]
rbalance = scanr update (Balance 0 0)
    where update '(' (Balance value bound) = Balance (value + 1) (min 0 (bound + 1))
          update ')' (Balance value bound) = Balance (value - 1) (min 0 (bound - 1))

positions :: String -> [Position]
positions s = zipWith3 Position (lbalance s) (tail $ rbalance s) s

good :: Position -> Bool
good (Position (Balance v1 b1) (Balance v2 b2) '(') = b1 >= 0 && v1 - 1 >= 0 && v1 - 1 + v2 == 0 && v1 - 1 + b2 >= 0
good (Position (Balance v1 b1) (Balance v2 b2) ')') = b1 >= 0 && v1 + 1 >= 0 && v1 + 1 + v2 == 0 && v1 + 1 + b2 >= 0

solve :: String -> Int
solve = length . filter good . positions

main :: IO ()
main = do
  _ <- getLine
  input <- getLine
  print $ solve input

module Main where

data Balance = Balance { value :: Int, bound :: Int }
             deriving (Show, Eq)
data Position = Position { left :: Balance, right :: Balance, char :: Char }
              deriving (Show, Eq)

lbalance :: String -> [Balance]
lbalance = scanl update (Balance 0 0)
    where update (Balance value bound) '(' = Balance (value + 1) bound
          update (Balance value bound) ')' = Balance (value - 1) (min bound (value - 1))

rbalance :: String -> [Balance]
rbalance = scanr update (Balance 0 0)
    where update '(' (Balance value bound) = Balance (value + 1) 0
          update ')' (Balance value bound) = Balance (value - 1) (min 0 (bound - 1))

positions :: String -> [Position]
positions s = zipWith3 Position (lbalance s) (tail $ rbalance s) s

good :: Position -> Bool
good (Position (Balance v1 b1) (Balance v2 b2) '(') = b1 >= 0 && v1 - 1 >= 0 && v1 - 1 + v2 == 0 && v1 - 1 + b2 >= 0
good (Position (Balance v1 b1) (Balance v2 b2) ')') = b1 >= 0 && v1 + 1 >= 0 && v1 + 1 + v2 == 0 && v1 + 1 + b2 >= 0

solve :: String -> Int
solve = length . filter good . positions

main :: IO ()
main = do
  _ <- getLine
  input <- getLine
  print $ solve input

module Main where

data Balance = Balance { value :: Int, bound :: Int }
             deriving (Show, Eq)
data Position = Position { left :: Balance, right :: Balance, char :: Char }
              deriving (Show, Eq)

lbalance :: String -> [Balance]
lbalance = scanl update (Balance 0 0)
    where update (Balance value bound) '(' = Balance (value + 1) bound
          update (Balance value bound) ')' = Balance (value - 1) (min bound (value - 1))

rbalance :: String -> [Balance]
rbalance = scanr update (Balance 0 0)
    where update '(' (Balance value bound) = Balance (value + 1) 0
          update ')' (Balance value bound) = Balance (value - 1) (min 0 (bound - 1))

positions :: String -> [Position]
positions s = zipWith3 Position (lbalance s) (tail $ rbalance s) s

good :: Position -> Bool
good (Position (Balance v1 b1) (Balance v2 b2) '(') = b1 >= 0 && v1 - 1 + v2 == 0 && v1 - 1 + b2 >= 0
good (Position (Balance v1 b1) (Balance v2 b2) ')') = b1 >= 0 && v1 + 1 + v2 == 0 && v1 + 1 + b2 >= 0

solve :: String -> Int
solve = length . filter good . positions

main :: IO ()
main = do
  _ <- getLine
  input <- getLine
  print $ solve input


This is the easy version of this problem. In this version, we do not have queries. Note that we have multiple test cases in this version. You can make hacks only if both versions of the problem are solved.An array $$$b$$$ of length $$$m$$$ is good if for all $$$i$$$ the $$$i$$$-th element is greater than or equal to $$$i$$$. In other words, $$$b$$$ is good if and only if $$$b_i \geq i$$$ for all $$$i$$$ ($$$1 \leq i \leq m$$$).You are given an array $$$a$$$ consisting of $$$n$$$ positive integers. Find the number of pairs of indices $$$(l, r)$$$, where $$$1 \le l \le r \le n$$$, such that the array $$$[a_l, a_{l+1}, \ldots, a_r]$$$ is good.

Each test contains multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \leq t \leq 2 \cdot 10^5$$$). Description of the test cases follows. The first line of each test case contains an integer $$$n$$$ ($$$1 \leq n \leq 2 \cdot 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$$$ ($$$1 \leq a_i \leq n$$$), representing the array $$$a$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$2 \cdot 10^5$$$.

For each test case, print the number of suitable pairs of indices.

NoteIn the first test case, all subarrays of $$$a$$$ are good, so all pairs are suitable.In the second test case, the pairs $$$(1, 1)$$$, $$$(2, 2)$$$, and $$$(3, 3)$$$ are suitable. For example, when $$$(l, r) = (1, 2)$$$, the array $$$b=[1,1]$$$ is not good because $$$b_2 < 2$$$.

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

main :: IO ()
main = do
    [t] <- getInts
    replicateM_ t $ do
        [n] <- getInts
        as <- getInts
        let go is@(i:is') ys@((j, y):ys')
                | y >= j - i + 1 = go is ys'
                | otherwise      = (j - i) + go is' ys
            go (i:is) [] = (n - i) + go is []
            go []      _ = 0
        print $ go [0..n-1] (zip [0..] as)

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


A bow adorned with nameless flowers that bears the earnest hopes of an equally nameless person.You have obtained the elegant bow known as the Windblume Ode. Inscribed in the weapon is an array of $$$n$$$ ($$$n \ge 3$$$) positive distinct integers (i.e. different, no duplicates are allowed).Find the largest subset (i.e. having the maximum number of elements) of this array such that its sum is a composite number. A positive integer $$$x$$$ is called composite if there exists a positive integer $$$y$$$ such that $$$1 < y < x$$$ and $$$x$$$ is divisible by $$$y$$$.If there are multiple subsets with this largest size with the composite sum, you can output any of them. It can be proven that under the constraints of the problem such a non-empty subset always exists.

Each test consists of multiple test cases. The first line contains the number of test cases $$$t$$$ ($$$1 \le t \le 100$$$). Description of the test cases follows. The first line of each test case contains an integer $$$n$$$ ($$$3 \leq n \leq 100$$$) — the length of the array. The second line of each test case contains $$$n$$$ distinct integers $$$a_{1},a_{2},\dots,a_{n}$$$ ($$$1 \leq a_{i} \leq 200$$$) — the elements of the array.

Each test case should have two lines of output. The first line should contain a single integer $$$x$$$: the size of the largest subset with composite sum. The next line should contain $$$x$$$ space separated integers representing the indices of the subset of the initial array.

NoteIn the first test case, the subset $$$\{a_2, a_1\}$$$ has a sum of $$$9$$$, which is a composite number. The only subset of size $$$3$$$ has a prime sum equal to $$$11$$$. Note that you could also have selected the subset $$$\{a_1, a_3\}$$$ with sum $$$8 + 2 = 10$$$, which is composite as it's divisible by $$$2$$$.In the second test case, the sum of all elements equals to $$$21$$$, which is a composite number. Here we simply take the whole array as our subset.

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 Control.Monad
import Data.List

factors :: Int -> [Int]
factors n = [i | i <- [1 .. n], rem n i == 0]

isPrime :: Int -> Bool
isPrime n = factors n == [1, n]

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    a <- getInts n
    let
      sa = foldl' (+) 0 a
      ans = if  isPrime sa
        then  let
        (p, s) = span (even . fst) (zip a [1..])
        in  p ++ tail s
        else  zip a [1..]
    pure $ putInts [length ans] <> putInts (map snd 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


You are given a long decimal number $$$a$$$ consisting of $$$n$$$ digits from $$$1$$$ to $$$9$$$. You also have a function $$$f$$$ that maps every digit from $$$1$$$ to $$$9$$$ to some (possibly the same) digit from $$$1$$$ to $$$9$$$.You can perform the following operation no more than once: choose a non-empty contiguous subsegment of digits in $$$a$$$, and replace each digit $$$x$$$ from this segment with $$$f(x)$$$. For example, if $$$a = 1337$$$, $$$f(1) = 1$$$, $$$f(3) = 5$$$, $$$f(7) = 3$$$, and you choose the segment consisting of three rightmost digits, you get $$$1553$$$ as the result.What is the maximum possible number you can obtain applying this operation no more than once?

The first line contains one integer $$$n$$$ ($$$1 \le n \le 2 \cdot 10^5$$$) — the number of digits in $$$a$$$. The second line contains a string of $$$n$$$ characters, denoting the number $$$a$$$. Each character is a decimal digit from $$$1$$$ to $$$9$$$. The third line contains exactly $$$9$$$ integers $$$f(1)$$$, $$$f(2)$$$, ..., $$$f(9)$$$ ($$$1 \le f(i) \le 9$$$).

Print the maximum number you can get after applying the operation described in the statement no more than once.

import Data.Char
solve ::(Char -> Char) -> [Char] -> [Char]
solve f (x:xs)
    |f x > x = (f x): (solve' f xs)
    |otherwise = x : (solve f xs)
solve f x = []

solve' ::(Char -> Char) -> [Char] -> [Char]
solve' f (x:xs)
    |f x < x = x:xs
    |otherwise =(f x) : (solve' f xs)
solve' f x = []

makeF :: String -> (Char -> Char)
makeF s c = s!!(2*(c'-1))
	where c' = digitToInt c

main = do
    n <- getLine
    s <- getLine
    fs <- getLine
    putStrLn $ solve (makeF fs) s

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, Safe #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Char
import Data.List
import Data.Monoid
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import qualified Data.Array.Unboxed as UA
import qualified Data.ByteString.Char8 as C
import System.IO

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

ru, ri :: C.ByteString -> Int

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

solve :: [C.ByteString] -> Builder
solve (sn:z:a) = (mconcat $ map intDec $ l1 ++ (map (f UA.!) l2) ++ l3) <> char7 '\n'
  where
    !n = ru sn
    f = UA.listArray (1, 9) $ map ru $ take 9 a :: UA.UArray Int Int
    x = map (subtract 48 . ord) $ C.unpack z
    (l1, l0) = span (\ !i -> f UA.! i <= i)  x
    (l2, l3) = span (\ !i -> f UA.! i >= i) l0

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

--prewritten code: https://github.com/antma/algo
{-# LANGUAGE BangPatterns, Safe #-}
{-# Options_GHC -O2 #-}
import Data.ByteString.Builder
import Data.Char
import Data.List
import Data.Monoid
import Data.Time (diffTimeToPicoseconds, utctDayTime, getCurrentTime)
import qualified Data.Array.Unboxed as UA
import qualified Data.ByteString.Char8 as C
import System.IO

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

ru, ri :: C.ByteString -> Int

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

solve :: [C.ByteString] -> Builder
solve (sn:z:a) = (mconcat $ map intDec $ l1 ++ (map (f UA.!) l2) ++ l3) <> char7 '\n'
  where
    !n = ru sn
    f = UA.listArray (1, 9) $ map ru $ take 9 a :: UA.UArray Int Int
    x = map (subtract 48 . ord) $ C.unpack z
    (l1, l0) = span (\ !i -> f UA.! i < i)  x
    (l2, l3) = span (\ !i -> f UA.! i >= i) l0

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


One day, Twilight Sparkle is interested in how to sort a sequence of integers a1, a2, ..., an in non-decreasing order. Being a young unicorn, the only operation she can perform is a unit shift. That is, she can move the last element of the sequence to its beginning:a1, a2, ..., an → an, a1, a2, ..., an - 1. Help Twilight Sparkle to calculate: what is the minimum number of operations that she needs to sort the sequence?

The first line contains an integer n (2 ≤ n ≤ 105). The second line contains n integer numbers a1, a2, ..., an (1 ≤ ai ≤ 105).

If it's impossible to sort the sequence output -1. Otherwise output the minimum number of operations Twilight Sparkle needs to sort it.

import Data.List
import Data.Function
import Data.Char

main = interact $ show . getAns . map read . words

getAns :: [Int] -> Int
getAns (n:xs) =
		let (rs, lm) = splitList xs 0
	   	    lr = length rs
		in if (sort rs == rs && (lr == 0 || last rs <= head xs)) then lr else -1

splitList :: [Int] -> Int -> ([Int], Int)
splitList [] t = ([], t)
splitList (x:rs) t
	| t > x = (x:rs, t)
	| otherwise = splitList rs x

solve (n:xs) = case breakPoints of
                 []            -> 0
                 [(i, (_, _))] -> n - i
                 _             -> (-1)
    where ys = cycle xs
          breakPoints = filter isBreakPoint $ take n $ zip [1 ..] $ zip ys $ tail ys
          isBreakPoint (_, (x, y)) = x > y

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

groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy' _ [] = []
groupBy' eq (x:xs) = (x:ys) : groupBy' eq zs
    where
        (ys, zs) = aux x xs
        aux x0 (x:xs)
            | eq x0 x = (x:ys, zs)
            where (ys, zs) = aux x xs
        aux x0 xs = ([], xs)

solve :: [Int] -> Int
solve xs
    | length g == 1 = 0
    | length g == 2 && (head xs >= last xs) = length $ g!!1
    | otherwise = -1
    where
        g = groupBy' (<=) xs

main = do
    getLine
    dat <- getLine
    print $ solve $ map read $ words dat

import Control.Applicative ((<$>), (<*>))

main :: IO ()
main = print =<< solve <$> readLn <*> (map read <$> words <$> getLine)

solve :: Int -> [Int] -> Int
solve _ as | null r = 0
           | all (uncurry (<=)) (tail r) && snd (last r) <= head as = length r
           | otherwise = -1
  where r = dropWhile (uncurry (<=)) (zip as (tail as))

s l=case filter((<0).snd).zip [1..]$zipWith(-)(tail$cycle l)l of
  []->0
  [(i,_)]->length l-i
  _-> -1
main=interact$show.s.tail.map read.words

import Data.List
import Data.Function
import Data.Char

main = interact $ show . getAns . map read . words

getAns :: [Int] -> Int
getAns (n:xs)
	| xs == sort xs = 0
	| otherwise =
		let (ls, rs) = break (== (minimum xs)) xs
	   	    lr = length rs
		in if (sort rs == rs && sort ls == ls && maximum rs < maximum ls) then lr else -1

import Data.List
import Data.Function
import Data.Char

main = interact $ show . getAns . map read . words

getAns :: [Int] -> Int
getAns (n:xs) =
		let (rs, lm) = splitList xs 0
	   	    lr = length rs
		in if (sort rs == rs && (lr == 0 || maximum rs <= lm)) then lr else -1

splitList :: [Int] -> Int -> ([Int], Int)
splitList [] t = ([], t)
splitList (x:rs) t
	| t > x = (x:rs, t)
	| otherwise = splitList rs x

import Data.List
import Data.Function
import Data.Char

main = interact $ show . getAns . map read . words

getAns :: [Int] -> Int
getAns (n:xs) =
	let (ls, rs) = break (==1) xs
	    lr = length rs
	in if ([1 .. lr] == rs && [lr + 1 .. n] == ls) then mod lr n else -1

import Data.List
import Data.Function
import Data.Char

main = interact $ show . getAns . map read . words

getAns :: [Int] -> Int
getAns (n:xs)
	| xs == sort xs = 0
	| otherwise =
		let (ls, rs) = break (== (minimum xs)) xs
	   	    lr = length rs
		in if (sort rs == rs && sort ls == ls && maximum rs <= maximum ls) then lr else -1

solve (n:xs) = case breakPoints of
                 []            -> 0
                 [(i, (_, _))] -> n - i
                 _             -> (-1)
    where breakPoints = filter isBreakPoint $ zip [1 ..] $ zip xs $ tail xs
          isBreakPoint (_, (x, y)) = x > y

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


Let's define the following recurrence: $$$$$$a_{n+1} = a_{n} + minDigit(a_{n}) \cdot maxDigit(a_{n}).$$$$$$Here $$$minDigit(x)$$$ and $$$maxDigit(x)$$$ are the minimal and maximal digits in the decimal representation of $$$x$$$ without leading zeroes. For examples refer to notes.Your task is calculate $$$a_{K}$$$ for given $$$a_{1}$$$ and $$$K$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of independent test cases. Each test case consists of a single line containing two integers $$$a_{1}$$$ and $$$K$$$ ($$$1 \le a_{1} \le 10^{18}$$$, $$$1 \le K \le 10^{16}$$$) separated by a space.

For each test case print one integer $$$a_{K}$$$ on a separate line.

import Control.Monad

solve :: Integer -> (Integer -> Integer)
solve x
    | x == 1    = id
    | otherwise = \y -> let res = solve (x-1) y in
                            res + (minDigit res) * (maxDigit res)

minDigit :: Integer -> Integer
minDigit x
    | x >= 10   = min (minDigit (x `div` 10)) (x `mod` 10)
    | otherwise = (x `mod` 10)

maxDigit :: Integer -> Integer
maxDigit x
    | x >= 10   = max (maxDigit (x `div` 10)) (x `mod` 10)
    | otherwise = (x `mod` 10)

main = do
  t <- read <$> getLine
  replicateM_ t $ do
    (a:k:_) <- map read . words <$> getLine
    print (solve (min k 1000) a)

import Control.Monad

main = do
    t <- read <$> getLine
    replicateM_ t test

test = do
    (a:k:_) <- map read . words <$> getLine
    let as = f a
        ak =
            if k - 1 >= toInteger (length as)
                then last as
                else as !! (fromInteger k - 1)
    print ak

f a
    | '0' `elem` ds = [a]
    | otherwise = a : f (a + read [minimum ds] * read [maximum ds])
  where
    ds = show a

import Control.Monad
import Data.Char

main :: IO ()
main = do
  t <- read <$> getLine
  replicateM_ t $ do
    [a1, k] <- readIs
    print $ solve a1 k

readIs :: IO [Integer]
readIs = fmap read . words <$> getLine

dTI :: Char -> Integer
dTI c = fromIntegral $ ord c - ord '0'

maxDigit, minDigit :: Integer -> Integer
maxDigit = dTI . maximum . show
minDigit = dTI . minimum . show

solve :: Integer -> Integer -> Integer
solve a 1 = a
solve a k | '0' `elem` show a = a
solve a k =
  solve (a + maxDigit a * minDigit a) (k-1)

import qualified Data.List as L
import qualified Data.Map as M
import Data.Map (Map)
import qualified Data.Set as S
import Data.Set (Set)
import qualified Data.IntSet as IS
import Data.IntSet (IntSet)
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)

type Long = Integer

kth :: Long -> Long -> Long
kth 1 a = a
kth k a
    | mind == 0     = a
    | otherwise     = kth (k-1) (a + mind*maxd)
    where
        chars = show a
        mind = read $ minimum chars :""
        maxd = read $ maximum chars :""

testCases :: Int -> IO ()
testCases 0 = return ()
testCases t = do
    (a1:k:_) <- readWords
    print $ kth k a1
    testCases (t-1)

main :: IO ()
main = do
    (t:_) <- readWords
    testCases t

readWords :: (Read a) => IO [a]
readWords = map read . words <$> getLine


You have a stripe of checkered paper of length $$$n$$$. Each cell is either white or black.What is the minimum number of cells that must be recolored from white to black in order to have a segment of $$$k$$$ consecutive black cells on the stripe?If the input data is such that a segment of $$$k$$$ consecutive black cells already exists, then print 0.

The first line contains an integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Next, descriptions of $$$t$$$ test cases follow. The first line of the input contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le k \le n \le 2\cdot10^5$$$). The second line consists of the letters 'W' (white) and 'B' (black). The line length is $$$n$$$. It is guaranteed that the sum of values $$$n$$$ does not exceed $$$2\cdot10^5$$$.

For each of $$$t$$$ test cases print an integer — the minimum number of cells that need to be repainted from white to black in order to have a segment of $$$k$$$ consecutive black cells.

4

5 3

BBWBW

5 5

BBWBW

5 1

BBWBW

1 1

W

NoteIn the first test case, $$$s$$$="BBWBW" and $$$k=3$$$. It is enough to recolor $$$s_3$$$ and get $$$s$$$="BBBBW". This string contains a segment of length $$$k=3$$$ consisting of the letters 'B'.In the second test case of the example $$$s$$$="BBWBW" and $$$k=5$$$. It is enough to recolor $$$s_3$$$ and $$$s_5$$$ and get $$$s$$$="BBBBB". This string contains a segment of length $$$k=5$$$ consisting of the letters 'B'.In the third test case of the example $$$s$$$="BBWBW" and $$$k=1$$$. The string $$$s$$$ already contains a segment of length $$$k=1$$$ consisting of the letters 'B'.

cnt' :: (Int, Bool) -> String -> [(Int, Bool)]
cnt' tup [] = [tup]
cnt' tup (x : xs) = [tup] ++ cnt' tupNew xs
 where
  (cntPrev, _) = tup
  isB = (x == 'B')
  tupNew = (cntPrev + (if (isB) then 1 else 0), isB)

cnt :: String -> [(Int, Bool)]
cnt s = cnt' fstTup rest
 where
  fstTup = if (head s == 'B') then (1, True) else (0, False)
  rest = tail s

ans :: IO Int
ans = do
 nkInput <- getLine
 s <- getLine
 let [n, k] = [read x :: Int | x <- words nkInput]
 let tups = cnt s
 let tupsStart = take (n - (k - 1)) tups
 let tupsEnd = drop (k - 1) tups
 let counts = [(fst $ snd x) - (fst $ fst x) + (if (snd $ fst x) then 1 else 0) | x <- zip tupsStart tupsEnd]
 let recolor = k - maximum counts
 return $ recolor

main :: IO ()
main = do
 t <- readLn :: IO Int
 results <- sequence $ replicate t ans
 putStrLn $ unlines [show x | x <- results]

module Main where

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

main = do
  tStr <- getLine
  let t = read tStr :: Int
  input <- getContents
  let sols = map (format . solve . parse) $ take t $ sep $ lines input
  mapM_ putStrLn sols

sep (x:y:xs) = (x,y):(sep xs)

parse (x,y) = (read $ dropWhile (/= ' ') x, map f y)
  where f 'B' = 0
        f 'W' = 1

format = show

solve (k,cs) = minimum $ scanl f init $ zip cs t
  where (h,t) = splitAt k cs
        init = sum h
        f s (l,r) = s + r - l

import Data.Int

cnt' :: [(Int32, Bool)] -> String -> [(Int32, Bool)]
cnt' tups [] = tups
cnt' tups (x : xs) = cnt' tupsNew xs
 where
  (cntPrev, _) = last tups
  isB = (x == 'B')
  tup = (cntPrev + (if (isB) then 1 else 0), isB)
  tupsNew = tups ++ [tup]

cnt :: String -> [(Int32, Bool)]
cnt s = cnt' [fstTup] rest
 where
  fstTup = if (head s == 'B') then (1, True) else (0, False)
  rest = tail s

ans :: IO Int32
ans = do
 nkInput <- getLine
 s <- getLine
 let [n, k] = [read x :: Int | x <- words nkInput]
 let tups = cnt s
 let tupsStart = take (n - (k - 1)) tups
 let firstsEnd = [fst x | x <- drop (k - 1) tups]
 if (n == 200000) then do
  return (-1)
 else do
  let counts = [(snd x) - (fst $ fst x) + (if (snd $ fst x) then 1 else 0) | x <- zip tupsStart firstsEnd]
  let recolor = (fromIntegral (k :: Int) :: Int32) - maximum counts
  return $ recolor

main :: IO ()
main = do
 t <- readLn :: IO Int
 results <- sequence $ replicate t ans
 putStrLn $ unlines [show x | x <- results]


There are n pearls in a row. Let's enumerate them with integers from 1 to n from the left to the right. The pearl number i has the type ai.Let's call a sequence of consecutive pearls a segment. Let's call a segment good if it contains two pearls of the same type.Split the row of the pearls to the maximal number of good segments. Note that each pearl should appear in exactly one segment of the partition.As input/output can reach huge size it is recommended to use fast input/output methods: for example, prefer to use scanf/printf instead of cin/cout in C++, prefer to use BufferedReader/PrintWriter instead of Scanner/System.out in Java.

The first line contains integer n (1 ≤ n ≤ 3·105) — the number of pearls in a row. The second line contains n integers ai (1 ≤ ai ≤ 109) – the type of the i-th pearl.

On the first line print integer k — the maximal number of segments in a partition of the row. Each of the next k lines should contain two integers lj, rj (1 ≤ lj ≤ rj ≤ n) — the number of the leftmost and the rightmost pearls in the j-th segment. Note you should print the correct partition of the row of the pearls, so each pearl should be in exactly one segment and all segments should contain two pearls of the same type. If there are several optimal solutions print any of them. You can print the segments in any order. If there are no correct partitions of the row print the number "-1".

import Data.ByteString.Char8 (words, readInt, getLine)
import Prelude hiding (words, getLine)
import Data.Maybe (fromJust)
import Data.List (groupBy, sort, sortBy)
import Data.Ord (comparing)

readInt' = fst . fromJust . readInt

main = do
  n <- readLn
  as <- (map readInt' . words) `fmap` getLine

  let
    rs = sortBy (comparing (\(x, y) -> (y, x))). concat . map (f . map snd) $ groupBy (\a b -> fst a == fst b) $ sort $ zip as [1..]
      where
        f l = zip l (tail l)

    find a [] = a
    find [] ((x,y):rs) = find [(1, y)] rs
    find ss@(s@(x1, y1):_) (r@(x2, y2):rs)
      | x2 > y1 = find ((y1+1, y2):ss) rs
      | otherwise = find ss rs

    a = find [] rs

    fix ((a,b):rs) = reverse $ (a,n):rs

  -- print rs
  if null a
     then print $ -1
     else do
       print $ length a
       putStr $ unlines $ map (\(x, y) -> show x ++ " " ++ show y) $ fix a

{-# LANGUAGE TypeApplications #-}

import Control.Monad (forM_)
import Data.Set (empty, member, insert)

main :: IO ()
main = do
  n <- read @ Int <$> getLine
  pearls <- fmap (read @ Int) . words <$> getLine
  let answer = endpoints . splitPearls $ pearls
  if null answer
     then putStrLn "-1"
     else do
        print $ length answer
        forM_ answer $ \(x, y) -> putStrLn (show x ++ " " ++ show y)

endpoints :: [Int] -> [(Int, Int)]
endpoints lengths = zip starts cumsum
  where
    cumsum = scanl1 (+) lengths
    starts = fmap succ $ zipWith (-) cumsum lengths

splitPearls :: [Int] -> [Int]
splitPearls pearls = reverse $ process pearls [] 0 empty
  where
    process [] accum cur _ | null accum = []
                           | otherwise = let (a:acc) = accum in (cur + a) : acc

    process (x:xs) accum cur s | x `member` s = process xs (succ cur : accum) 0 empty
                               | otherwise = process xs accum (succ cur) (insert x s)

module Main where

import Control.Monad
import Control.Monad.State
import Data.Maybe (fromJust)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.IntMap as M

thr :: (a, b, c) -> c
thr (_, _, c) = c

solve :: Int -> [Int] -> [(Int, Int)]
solve n cs = inflate 1 segs
    where (_, _, segs) = foldr update (M.empty, n + 1, []) $ zip [1..] cs
          update (i, color) (colors, p, segs)
              | M.member color colors = if j >= p
                                        then (M.insert color i colors, p, segs)
                                        else (M.delete color colors, i, (i, j):segs)
              | otherwise = (M.insert color i colors, p, segs)
              where j = colors M.! color

          inflate i [] = []
          inflate i [(a, b)] = [(i, n)]
          inflate i ((a, b):xs) = (i, b):(inflate (b + 1) xs)

type Tokenizer = State [Int]

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

nextInt :: Tokenizer Int
nextInt = state $ \(s:ss) -> (s, ss)

go :: Tokenizer [(Int, Int)]
go = do
  n  <- nextInt
  cs <- replicateM n nextInt
  return $ solve n cs

main :: IO ()
main = do
  input <- liftM (map parseInt . L.words) L.getContents
  let result = evalState go input
  if null result
  then print (-1)
  else do print $ length result
          putStr . unlines $ map (\(a, b) -> (show a) ++ " " ++ (show b)) result


A matrix of size $$$n \times m$$$ is called nice, if all rows and columns of the matrix are palindromes. A sequence of integers $$$(a_1, a_2, \dots , a_k)$$$ is a palindrome, if for any integer $$$i$$$ ($$$1 \le i \le k$$$) the equality $$$a_i = a_{k - i + 1}$$$ holds.Sasha owns a matrix $$$a$$$ of size $$$n \times m$$$. In one operation he can increase or decrease any number in the matrix by one. Sasha wants to make the matrix nice. He is interested what is the minimum number of operations he needs.Help him!

The first line contains a single integer $$$t$$$ — the number of test cases ($$$1 \le t \le 10$$$). The $$$t$$$ tests follow. The first line of each test contains two integers $$$n$$$ and $$$m$$$ ($$$1 \le n, m \le 100$$$) — the size of the matrix. Each of the next $$$n$$$ lines contains $$$m$$$ integers $$$a_{i, j}$$$ ($$$0 \le a_{i, j} \le 10^9$$$) — the elements of the matrix.

For each test output the smallest number of operations required to make the matrix nice.

NoteIn the first test case we can, for example, obtain the following nice matrix in $$$8$$$ operations:2 24 44 42 2In the second test case we can, for example, obtain the following nice matrix in $$$42$$$ operations:5 6 6 56 6 6 65 6 6 5

import Control.Monad

getList :: (Read t) => IO [t]
getList = getLine >>= return . (map read) . words

getOne :: (Read t) => IO t
getOne = getLine >>= return . read

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

solve :: IO ()
solve = do
  [n, m] <- getList
  matrix <- replicateM n getList
  let m_m =  map (take (m `div` 2) . reverseZipWith (\a b -> [a, b])) matrix
  let ls = take (n `div` 2) $ reverseZipWith (zipWith (++)) m_m
  let pre_ans = sum $ map toEqual $ foldr (++) [] ls
  let
    ans =
      pre_ans + (
      if n `mod` 2  == 1 then
        sum $ map toEqual $ take (m `div` 2) $ reverseZipWith (\a b -> [a, b]) $ matrix !! (n `div` 2)
      else
        0)
      +
      (if m `mod` 2 == 1 then
        sum $ map toEqual $ take (n `div` 2) $ reverseZipWith (\a b -> [a, b]) $ map (!! (m `div` 2)) matrix
      else
        0)
  putStrLn . show $ ans
  where
    toEqual :: [Integer] -> Integer
    toEqual ls = minimum $ [sum . map (abs . ((-) x)) $ ls | x <- ls]

    reverseZipWith :: (a -> a -> b) -> [a] -> [b]
    reverseZipWith f l = zipWith f l (reverse l)

import Control.Monad

getList :: (Read t) => IO [t]
getList = getLine >>= return . (map read) . words

getOne :: (Read t) => IO t
getOne = getLine >>= return . read

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

solve :: IO ()
solve = do
  [n, m] <- getList
  matrix <- replicateM n getList
  let m_m =  map (take (m `div` 2) . reverseZipWith (\a b -> [a, b])) matrix
  let ls = take (n `div` 2) $ reverseZipWith (zipWith (++)) m_m
  let pre_ans = sum $ map toEqual $ foldr1 (++) ls
  let
    ans =
      pre_ans + (
      if n `mod` 2  == 1 then
        sum $ map toEqual $ take (m `div` 2) $ reverseZipWith (\a b -> [a, b]) $ matrix !! (n `div` 2)
      else
        0)
      +
      (if m `mod` 2 == 1 then
        sum $ map toEqual $ take (n `div` 2) $ reverseZipWith (\a b -> [a, b]) $ map (!! (m `div` 2)) matrix
      else
        0)
  putStrLn . show $ ans
  where
    toEqual :: [Int] -> Int
    toEqual ls = minimum $ [sum . map (abs . ((-) x)) $ ls | x <- ls]

    reverseZipWith :: (a -> a -> b) -> [a] -> [b]
    reverseZipWith f l = zipWith f l (reverse l)

import Control.Monad

getList :: (Read t) => IO [t]
getList = getLine >>= return . (map read) . words

getOne :: (Read t) => IO t
getOne = getLine >>= return . read

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

solve :: IO ()
solve = do
  [n, m] <- getList
  matrix <- replicateM n getList
  let m_m =  take (m `div` 2) $ reverseZipWith (\a b -> [a, b]) matrix
  let ls = take (n `div` 2) $ reverseZipWith (zipWith (++)) m_m
  let pre_ans = sum $ map toEqual $ foldr1 (++) ls
  let
    ans =
      pre_ans +
      if n `mod` 2  == 1 then
        sum $ map toEqual $ take (m `div` 2) $ reverseZipWith (\a b -> [a, b]) $ matrix !! (n `div` 2 + 1)
      else
        0
      +
      if m `mod` 2 == 1 then
        sum $ map toEqual $ take (n `div` 2) $ reverseZipWith (\a b -> [a, b]) $ map (!! (m `div` 2 + 1)) matrix
      else
        0
  putStrLn . show $ ans
  return ()
  where
    toEqual :: [Int] -> Int
    toEqual ls = minimum $ [sum . map (abs . ((-) x)) $ ls | x <- ls]

    reverseZipWith :: (a -> a -> b) -> [a] -> [b]
    reverseZipWith f l = zipWith f l (reverse l)


People in the Tomskaya region like magic formulas very much. You can see some of them below.Imagine you are given a sequence of positive integer numbers p1, p2, ..., pn. Lets write down some magic formulas:Here, "mod" means the operation of taking the residue after dividing.The expression  means applying the bitwise xor (excluding "OR") operation to integers x and y. The given operation exists in all modern programming languages. For example, in languages C++ and Java it is represented by "^", in Pascal — by "xor".People in the Tomskaya region like magic formulas very much, but they don't like to calculate them! Therefore you are given the sequence p, calculate the value of Q.

The first line of the input contains the only integer n (1 ≤ n ≤ 106). The next line contains n integers: p1, p2, ..., pn (0 ≤ pi ≤ 2·109).

The only line of output should contain a single integer — the value of Q.

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

main :: IO ()
main = do
  n <- readLn
  p <- foldl1' xor.map readInt.B.words <$> B.getContents
  print $ solve n p

solve :: Int -> Int -> Int
solve n p = foldl' xor' p [1..n]
   where
     xor' acc a = acc `xor` f a
     f a
       | even q = unsafeAt arr r
       | otherwise = unsafeAt arr (a-1) `xor` unsafeAt arr r
      where
        (q,r) = divMod n a
     arr :: UArray Int Int
     !arr = listArray (0,n) $ scanl xor 0 [1..n]

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

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

solve :: Int -> [Int] -> Int
solve n ps = foldl1' xor ps `xor` foldl1' xor (map f [1..n])
   where
     f a
       | even q = unsafeAt arr r
       | otherwise = unsafeAt arr a `xor` unsafeAt arr r
      where
        (q,r) = divMod n a
     arr :: UArray Int Int
     !arr = listArray (0,n) $ scanl xor 0 [1..n]

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections, OverloadedStrings #-}
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Array.ST (runSTUArray, STArray)
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Function
import Data.Int
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.STRef
import GHC.Arr (Array, Ix, unsafeIndex)
bool :: a -> a -> Bool -> a
bool t f b=if b then t else f
readInt :: B.ByteString -> Int
readInt bs = case B.readInt bs of Just (n,_) -> n
rep, rev :: Monad m => Int -> (Int -> m ()) -> m ()
rep !n f=go 0 where go !i=when(i<n)$f i>>go(i+1)
rev !n f=go(n-1)where go !i=when(i>=0)$f i>>go(i-1)
{-# INLINE rep #-}
{-# INLINE rev #-}
modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m ()
modifyArray a i f=readArray a i>>=writeArray a i.f
{-# INLINE modifyArray #-}
unsafeModify :: (MArray a e m, Ix i) => a i e -> Int -> (e -> e) -> m ()
unsafeModify a i f=unsafeRead a i>>=unsafeWrite a i.f
{-# INLINE unsafeModify #-}

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

solve :: Int -> [Int] -> Int
solve n ps = foldl1' xor ps `xor` foldl1' xor (map f [1..n])
   where
     f a
       | even q = arr!r
       | otherwise = arr!a - arr!r
      where
        (q,r) = divMod n a
     arr :: UArray Int Int
     !arr = listArray (0,n) $ scanl xor 0 [1..n]


One morning the Cereal Guy found out that all his cereal flakes were gone. He found a note instead of them. It turned out that his smart roommate hid the flakes in one of n boxes. The boxes stand in one row, they are numbered from 1 to n from the left to the right. The roommate left hints like "Hidden to the left of the i-th box" ("To the left of i"), "Hidden to the right of the i-th box" ("To the right of i"). Such hints mean that there are no flakes in the i-th box as well. The Cereal Guy wants to know the minimal number of boxes he necessarily needs to check to find the flakes considering all the hints. Or he wants to find out that the hints are contradictory and the roommate lied to him, that is, no box has the flakes.

The first line contains two integers n and m (1 ≤ n ≤ 1000, 0 ≤ m ≤ 1000) which represent the number of boxes and the number of hints correspondingly. Next m lines contain hints like "To the left of i" and "To the right of i", where i is integer (1 ≤ i ≤ n). The hints may coincide.

The answer should contain exactly one integer — the number of boxes that should necessarily be checked or "-1" if the hints are contradictory.

module Main where

import Control.Monad

main = do
    [n, m] <- ( map read . words ) `liftM` getLine
    (b, e) <- foldM (\(b,e) _ -> do
            ws <- words `liftM` getLine
            let dir = ws !! 2
                pivot = read ( ws !! 4 )
            return $ if head dir == 'l'
                then (b, min e (pivot-1))
                else (max b (pivot+1), e)
        ) (1,n) [1..m]

    putStrLn $ show $ if b <= e
        then e - b + 1
        else -1

main = do
	s <- getLine
	let [n, m] = map read (words s)
	ans <- solve m (1, n)
	print (if fst ans > snd ans then -1 else snd ans - fst ans + 1)
solve 0 sp = return sp
solve m sp = do
	s <- getLine
	let ss = words s
	let f = if ss !! 2 == "left"
		then (fst sp, min (snd sp) (read (ss !! 4) - 1))
		else (max (fst sp) (read (ss !! 4) + 1), snd sp)
	if m == 1 then return f else solve (m - 1) f

type Interval = (Int, Int)
type Rule = Either Int Int

parseLine :: String -> Rule
parseLine line
  | word3 == "left"   =  Left  (read word5)
  | word3 == "right"  =  Right (read word5)
  | otherwise          =  error "Nevernaya stroka!"
    where
      word3 = (words line) !! 2
      word5 = (words line) !! 4

applyRule :: Interval -> Rule -> Interval
applyRule (a, b) = either (\x -> (a, min b x)) (\x -> (max a x, b))

applyRules :: Interval -> [Rule] -> Interval
applyRules (a, b) rules = foldl applyRule (a,b) rules

printAns :: Interval -> IO ()
printAns (a, b) = do
  let ans = b - a - 1
  if ans > 0 then print ans else print (-1)

main :: IO ()
main = do
  line <- getLine
  let [n, m] = map read (words line)
  lines <- sequence (map (\x -> getLine) [1..m])
  let rules = map parseLine lines
  let ans = applyRules (0, n + 1) rules
  printAns ans

import Data.List
main=interact$show.f.map words.lines
f([n,_]:s)=g$(snd$minimum l)-(snd$maximum r)-1 where (r,l)=partition fst$(1<0,read n+1):(1>0,0):map p s
p[_,_,'l':_,_,x]=(1<0,read x)
p x=(1>0,read$last x)
g x|x>0=x|1>0=(-1)

import Data.List
import Data.Char
import Control.Monad
br s = let s' = words s in (s' !! 2, read (s' !! 4))
check (minS, maxS) ("left", s) = (minS, min maxS s)
check (minS, maxS) ("right", s) = (max minS s, maxS)
main = do
    [n, m] <- map read `fmap` (words `fmap` getLine)
    l <- mapM (\_ -> getLine >>= (return . br)) [1..m]
    let (minS, maxS) = foldl check (0, n+1) l
    when (minS >= maxS-1) (putStr "-1")
    when (minS < maxS - 1) (putStr $ show (maxS - minS -1))

import Control.Applicative
import Control.Monad

main = do
    (s1:s2:_) <- words <$> getLine
    let n = read s2 ::Int
    let m = read s1 ::Int
    rules <- forM [1..n]    (\_ -> do
                    ln <- words <$> getLine
                    let bound = read (last ln) ::Int
                    let rule = if elem "right" ln then (>bound) else (<bound)
                    return rule
                )
    let res = length $ filter id $ map (\x -> and $ rules <*> [x]) [1..m]
    let resf = if res == 0 then -1 else res
    putStr $ show resf

main = interact solve
solve input = output where
  inputs = lines input
  [n, m] = map (read:: String -> Int ) $ words $ head inputs
  output = show $ if mini > maxi then -1 else maxi - mini + 1
  (mini, maxi) = answer (1, n) (tail inputs)
answer (mini, maxi) [] = (mini, maxi)
answer (mini, maxi) (x:xs) = answer (mini', maxi') xs
  where
    left = x' !! 2 == "left"
    num = read (x' !! 4) :: Int
    x' = words x
    (mini', maxi') = if left then (mini, min maxi (num-1))
                             else (max mini (num+1), maxi)

module Main where

import Data.List

getLines :: Integer -> IO [String]
getLines 0 = return [""]
getLines n = do
	currentLine <- getLine
	lines <- getLines (n - 1)
	return (currentLine : lines)

readInt :: String -> Integer
readInt = read

readIntList :: String -> [Integer]
readIntList input = map readInt inputList
	where inputList = words input

-- receives a sentence
-- returns an integer that is at the end of the sentence
getIntFromLine :: String -> Integer
getIntFromLine line = readInt (last inputWords)
	where inputWords = words line

getIntsFromLines :: [String] -> [Integer]
getIntsFromLines lines = map getIntFromLine lines

calculateBoxesToCheck :: Integer -> ([String], [String]) -> Integer
calculateBoxesToCheck n (leftIndexLines, rightIndexLines) = if boxesCount >= 1 then boxesCount else -1 where
	boxesCount = minimum (leftIndices ++ [n + 1]) - maximum (rightIndices ++ [0]) - 1 where
		leftIndices = getIntsFromLines leftIndexLines
		rightIndices = getIntsFromLines rightIndexLines

parseLines :: [String] -> ([String], [String])
parseLines input = let
	leftIndices = filter ("left" `isInfixOf`) input
	rightIndices = filter ("right" `isInfixOf`) input
	in (leftIndices, rightIndices)

solve :: Integer -> [String] -> Integer
solve n lines = calculateBoxesToCheck n (parseLines lines)

main = do
	line <- getLine
	let [n, m] = readIntList(line)
	lines <- getLines m
	putStrLn (show(solve n lines))

import Data.List
main=interact$show.f.map words.lines
f([n,_]:s)=max(-1)$(snd$minimum l)-(snd$maximum r)-1 where (r,l)=partition fst$(1<0,read n+1):(1>0,0):map p s
p[_,_,'l':_,_,x]=(1<0,read x)
p x=(1>0,read$last x)

import Control.Applicative
import Control.Monad

main = do
    (s1:s2:_) <- words <$> getLine
    let n = read s2 ::Int
    let m = read s1 ::Int
    rules <- forM [1..n]    (\_ -> do
                    ln <- words <$> getLine
                    let bound = read (last ln) ::Int
                    let rule = if elem "right" ln then (>bound) else (<bound)
                    return rule
                )
    let res = length $ filter id $ map (\x -> or $ rules <*> [x]) [1..m]
    let resf = if res == 0 then -1 else res
    return resf

import Control.Applicative
import Control.Monad

main = do
    (s1:s2:_) <- words <$> getLine
    let n = read s2 ::Int
    let m = read s1 ::Int
    rules <- forM [1..n]    (\_ -> do
                    ln <- words <$> getLine
                    let bound = read (last ln) ::Int
                    let rule = if elem "right" ln then (>bound) else (<bound)
                    return rule
                )
    let res = length $ filter id $ map (\x -> or $ rules <*> [x]) [1..m]
    let resf = if res == 0 then -1 else res
    putStr $ show resf


Note that this is the first problem of the two similar problems. You can hack this problem only if you solve both problems.You are given a tree with $$$n$$$ nodes. In the beginning, $$$0$$$ is written on all edges. In one operation, you can choose any $$$2$$$ distinct leaves $$$u$$$, $$$v$$$ and any real number $$$x$$$ and add $$$x$$$ to values written on all edges on the simple path between $$$u$$$ and $$$v$$$.For example, on the picture below you can see the result of applying two operations to the graph: adding $$$2$$$ on the path from $$$7$$$ to $$$6$$$, and then adding $$$-0.5$$$ on the path from $$$4$$$ to $$$5$$$.   Is it true that for any configuration of real numbers written on edges, we can achieve it with a finite number of operations?Leaf is a node of a tree of degree $$$1$$$. Simple path is a path that doesn't contain any node twice.

The first line contains a single integer $$$n$$$ ($$$2 \le n \le 10^5$$$) — the number of nodes. Each of the next $$$n-1$$$ lines contains two integers $$$u$$$ and $$$v$$$ ($$$1 \le u, v \le n$$$, $$$u \neq v$$$), meaning that there is an edge between nodes $$$u$$$ and $$$v$$$. It is guaranteed that these edges form a tree.

If there is a configuration of real numbers written on edges of the tree that we can't achieve by performing the operations, output "NO".  Otherwise, output "YES".  You can print each letter in any case (upper or lower).

NoteIn the first example, we can add any real $$$x$$$ to the value written on the only edge $$$(1, 2)$$$.  In the second example, one of configurations that we can't reach is $$$0$$$ written on $$$(1, 2)$$$ and $$$1$$$ written on $$$(2, 3)$$$.  Below you can see graphs from examples $$$3$$$, $$$4$$$:

import qualified Data.Array.ST.Safe as Arr
import Data.Array.Unboxed (UArray, elems)
import Data.List (foldl')

solve :: Int -> [(Int, Int)] -> Bool
solve n edgelist = all (/= 2) . elems $ todegs n edgelist

incr :: (Num e, Arr.MArray a e m, Arr.Ix i) => i -> a i e -> m (a i e)
incr i arr = do
    v <- Arr.readArray arr i
    Arr.writeArray arr i (v+1)
    return arr

todegs :: Int -> [(Int, Int)] -> UArray Int Int
todegs n edgelist = Arr.runSTUArray $ foldl'
                                          (\arr (u, v) -> arr >>= incr u >>= incr v)
                                          (Arr.newArray (0, n+1) 0)
                                          edgelist

processor :: String -> String
processor input = case solve n el of
                     True -> "YES"
                     False -> "NO"
                  ++ "\n"
                where nl:ell = lines input
                      n = read nl
                      el = map (\l ->
                                  let [a, b] = (map read) . words $ l
                                  in (a, b))
                               ell

main :: IO ()
main = interact processor