A tree is a connected graph without cycles. A rooted tree has a special vertex called the root. The parent of a vertex $$$v$$$ (different from root) is the previous to $$$v$$$ vertex on the shortest path from the root to the vertex $$$v$$$. Children of the vertex $$$v$$$ are all vertices for which $$$v$$$ is the parent.A vertex is a leaf if it has no children. We call a vertex a bud, if the following three conditions are satisfied:   it is not a root,  it has at least one child, and  all its children are leaves. You are given a rooted tree with $$$n$$$ vertices. The vertex $$$1$$$ is the root. In one operation you can choose any bud with all its children (they are leaves) and re-hang them to any other vertex of the tree. By doing that you delete the edge connecting the bud and its parent and add an edge between the bud and the chosen vertex of the tree. The chosen vertex cannot be the bud itself or any of its children. All children of the bud stay connected to the bud.What is the minimum number of leaves it is possible to get if you can make any number of the above-mentioned operations (possibly zero)?

The input consists of multiple test cases. The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ ($$$2 \le n \le 2 \cdot 10^5$$$) — the number of the vertices in the given tree. 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 vertices $$$u$$$ and $$$v$$$ in the tree. It is guaranteed that the given graph is a tree. It is guaranteed that the sum of $$$n$$$ over all test cases doesn't exceed $$$2 \cdot 10^5$$$.

For each test case print a single integer — the minimal number of leaves that is possible to get after some operations.

NoteIn the first test case the tree looks as follows:  Firstly you can choose a bud vertex $$$4$$$ and re-hang it to vertex $$$3$$$. After that you can choose a bud vertex $$$2$$$ and re-hang it to vertex $$$7$$$. As a result, you will have the following tree with $$$2$$$ leaves:  It can be proved that it is the minimal number of leaves possible to get.In the second test case the tree looks as follows:  You can choose a bud vertex $$$3$$$ and re-hang it to vertex $$$5$$$. As a result, you will have the following tree with $$$2$$$ leaves:  It can be proved that it is the minimal number of leaves possible to get.

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.Bool (bool)
import Data.Maybe
import Data.Bifunctor (bimap)

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

data NodeType = BUD | LEAVE deriving (Eq, Show)
type NodeId = Int
type Parent = NodeId
type BudCount = Int
type LeaveCount = Int

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- fmap concat $ replicateM (n - 1) $ do
      ~[u, v] <- getInts 2
      pure $! [(u, v), (v, u)]
    let
      esArr :: Array NodeId [NodeId]
      esArr = accumArray (flip (:)) [] (1, n) es
      countNode :: Parent -> NodeId -> (NodeType, (BudCount, LeaveCount))
      countNode p i = (nodeType, (bc + (fromEnum $ nodeType == BUD), lc + (fromEnum $ nodeType == LEAVE)))
        where
          children =  map (countNode i) $ filter (/=p) $ esArr!i
          nodeType = bool LEAVE BUD $ any ((==LEAVE) . fst) children
          (bc, lc) = bimap sum sum $ unzip $ fmap snd $ children
      (rootType, (budCount, leaveCount)) = countNode 1 1
    pure $! putInts [leaveCount - budCount + (fromEnum $ rootType == BUD)]

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map readInt <$> getNext k

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

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

data NodeType = BUD | LEAVE deriving (Eq, Show)
type NodeId = Int
type Parent = NodeId
type BudCount = Int
type LeaveCount = Int
type LonelyRoot = Bool
data NodeCount = NC !BudCount !LeaveCount deriving (Eq, Show)

instance Semigroup NodeCount where
  (NC bc lc) <> (NC bc' lc') = NC (bc + bc') (lc + lc')

instance Monoid NodeCount where
  mempty = NC 0 0

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- fmap concat $ replicateM (n - 1) $ do
      ~[u, v] <- getInts 2
      pure $! [(u, v), (v, u)]
    let
      esArr :: Array NodeId [NodeId]
      esArr = accumArray (flip (:)) [] (1, n) es
      countNode :: Parent -> NodeId -> (NodeType, NodeCount)
      countNode p i = (nodeType, nodeCount)
        where
          children = filter (/=p) $ esArr!i
          childCounts = map (countNode i) children
          nodeType = if any ((==LEAVE) . fst) childCounts then BUD else LEAVE
          nodeCount = foldMap snd childCounts <> (
            NC (fromEnum $ nodeType == BUD) (fromEnum $ nodeType == LEAVE))
      (rootType, NC budCount leaveCount) = countNode 1 1
    pure $! putInts [leaveCount - budCount + (fromEnum $ rootType == BUD)]

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map readInt <$> getNext k

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

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

data NodeType = BUD | LEAVE deriving (Eq, Show)
type NodeId = Int
type Parent = NodeId
type BudCount = Int
type LeaveCount = Int
type LonelyRoot = Bool
data NodeCount = NC !BudCount !LeaveCount deriving (Eq, Show)

instance Semigroup NodeCount where
  (NC bc lc) <> (NC bc' lc') = NC (bc + bc') (lc + lc')

instance Monoid NodeCount where
  mempty = NC 0 0

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- replicateM (n - 1) $ getInts 2
    let
      esArr :: Array NodeId [NodeId]
      esArr = accumArray (flip (:)) [] (1, n) $ do
        [u, v] <- es
        [(u, v), (v, u)]
      countNode :: Parent -> NodeId -> (NodeType, NodeCount)
      countNode p i = (nodeType, nodeCount)
        where
          children = filter (/=p) $ esArr!i
          childCounts = map (countNode i) children
          nodeType = if any ((==LEAVE) . fst) childCounts then BUD else LEAVE
          nodeCount = foldMap snd childCounts <> (
            NC (fromEnum $ nodeType == BUD) (fromEnum $ nodeType == LEAVE))
      (rootType, NC budCount leaveCount) = countNode 1 1
    pure $! putInts [leaveCount - budCount + (fromEnum $ rootType == BUD)]

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map readInt <$> getNext k

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

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

data NodeType = BUD | LEAVE deriving (Eq, Show)
type NodeId = Int
type Parent = Maybe NodeId
type BudCount = Int
type LeaveCount = Int
type LonelyRoot = Bool
data NodeCount = NC !BudCount !LeaveCount deriving (Eq, Show)

instance Semigroup NodeCount where
  (NC bc lc) <> (NC bc' lc') = NC (bc + bc') (lc + lc')

instance Monoid NodeCount where
  mempty = NC 0 0

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- replicateM (n - 1) $ getInts 2
    let
      esArr :: Array NodeId [NodeId]
      esArr = accumArray (flip (:)) [] (1, n) $ do
        [u, v] <- es
        [(u, v), (v, u)]
      countNode :: Parent -> NodeId -> (NodeType, NodeCount)
      countNode p i = (nodeType, nodeCount)
        where
          children = maybe id (filter . (/=)) p $ esArr!i
          childCounts = map (countNode (Just i)) children
          nodeType
            | null children = LEAVE
            | any ((==LEAVE) . fst) childCounts = BUD
            | otherwise = LEAVE
          nodeCount = foldMap snd childCounts <> (case nodeType of
            LEAVE -> NC 0 1
            BUD -> NC 1 0)
      (rootType, NC budCount leaveCount) = countNode Nothing 1
    pure $! putInts [leaveCount - budCount + (if rootType == LEAVE then 0 else 1)]

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map readInt <$> getNext k

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

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

data NodeType = BUD | LEAVE deriving (Eq, Show)
type NodeId = Int
type Parent = Maybe NodeId
type BudCount = Int
type LeaveCount = Int
type LonelyRoot = Bool
data NodeCount = NC !BudCount !LeaveCount deriving (Eq, Show)

instance Semigroup NodeCount where
  (NC bc lc) <> (NC bc' lc') = NC (bc + bc') (lc + lc')

instance Monoid NodeCount where
  mempty = NC 0 0

mainFun :: SP Builder
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- replicateM (n - 1) $ getInts 2
    let
      esArr :: Array NodeId [NodeId]
      esArr = accumArray (flip (:)) [] (1, n) $ do
        [u, v] <- es
        [(u, v), (v, u)]
      countNode :: Parent -> NodeId -> (NodeType, NodeCount, LonelyRoot)
      countNode p i = (nodeType, nodeCount, lonelyRoot)
        where
          children = maybe id (filter . (/=)) p $ esArr!i
          childCounts = map (countNode (Just i)) children
          nodeType
            | null children = LEAVE
            | any ((==LEAVE) . (\(t, _, _) -> t)) childCounts = BUD
            | otherwise = LEAVE
          nodeCount = foldMap (\(_, c, _) -> c) childCounts <> (case nodeType of
            LEAVE -> NC 0 1
            BUD -> NC 1 0)
          lonelyRoot = isNothing p && nodeType == LEAVE
      (_, NC budCount leaveCount, lonelyRoot) = countNode Nothing 1
    pure $! putInts [leaveCount - budCount + (if lonelyRoot then 0 else 1)]

type SP = State [P.ByteString]

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

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

getInts :: Int -> SP [Int]
getInts k = map readInt <$> getNext k

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

import Control.Monad
import Data.Array
import Data.Graph
import Data.Maybe
import Data.Tree
import qualified Data.ByteString.Char8 as C

data Typ = Leaf | Bud deriving Eq

solve :: IO ()
solve = do
    [n] <- readInts
    es <- replicateM (n - 1) readInts
    let [t] = dfs (buildG (1, n) $ concatMap (\[u, v] -> [(u, v), (v, u)]) es) [1]
        ta = array (1, n) $ go t [] where
            go (Node u ts) acc = (u, typ) : foldr go acc ts where
                typ | any ((==Leaf) . (ta!) . rootLabel) ts = Bud
                    | otherwise                             = Leaf
    print $ n - 2 * length (filter (==Bud) $ elems ta) + fromEnum (ta!1 == Bud)

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

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

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

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

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

data TC = TC { n :: Int, edges :: [(Int, Int)] }

input :: Scanner TC
input = do
  n <- int
  edges <- (n - 1) >< pair int int
  return TC{..}

output = showB

solve :: TC -> Int
solve TC{..} = n - 2 * b + bool 1 0 rb
  where
    adj :: Array Int [Int]
    adj = accumArray (flip (:)) [] (1, n) $ edges ++ map swap edges

    (b, rb) = dfs 1 1

    dfs :: Int -> Int -> (Int, Bool)
    dfs p u = (sum buds + bool 1 0 leaf, leaf)
      where
        leaf = not $ or leaves
        (buds, leaves) = unzip . map (dfs u) . filter (/= p) $ adj ! u

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

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

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

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

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

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

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

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

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

peek :: Scanner C.ByteString
peek = gets head

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

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

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

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

integer :: Scanner Integer
integer = readStr

int64 :: Scanner Int64
int64 = readStr

double :: Scanner Double
double = readStr

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

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

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

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

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

(><) = times

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

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

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

import 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.ByteString.Builder.Extra (flush) -- for interactive problems
import Control.Monad
import Data.List
import Data.Array.Unboxed

type Graph = Array Int [Int]

dfs :: Graph -> Int -> Int -> [(Int, Int)] -> (Int, [(Int, Int)])
dfs adj par curr later = let
  children = filter (/= par) $ adj ! curr
  res = scanr (\child (_, cont) -> dfs adj curr child cont) (1, later) children
  nleaves = foldl' (\acc (x, _) -> acc + if  x == 0  then  1  else  0) 0 res
  in  case  res  of
  (_, cont) : _ -> (,) nleaves $ if  nleaves > 0
    then  (curr, nleaves) : cont
    else  cont
  _ -> error "scanr cannot result in []"

mainFun :: SO
mainFun = do
  ~[t] <- getInts 1
  fmap mconcat $ replicateM t $ do
    ~[n] <- getInts 1
    es <- fmap concat $ replicateM (n - 1) $ do
      ~[u, v] <- getInts 2
      pure [(u, v), (v, u)]
    let
      adj = accumArray (flip (:)) [] (1, n) es
      (_special, almostBuds) = dfs adj 1 1 []
      ans = foldl' (\x (_, y) -> x + y - 1) 1 almostBuds
    pure $ {- string7 (show almostBuds ++ "\n") <> -} putInts [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 sequence of $$$n$$$ digits $$$d_1d_2 \dots d_{n}$$$. You need to paint all the digits in two colors so that:  each digit is painted either in the color $$$1$$$ or in the color $$$2$$$;  if you write in a row from left to right all the digits painted in the color $$$1$$$, and then after them all the digits painted in the color $$$2$$$, then the resulting sequence of $$$n$$$ digits will be non-decreasing (that is, each next digit will be greater than or equal to the previous digit). For example, for the sequence $$$d=914$$$ the only valid coloring is $$$211$$$ (paint in the color $$$1$$$ two last digits, paint in the color $$$2$$$ the first digit). But $$$122$$$ is not a valid coloring ($$$9$$$ concatenated with $$$14$$$ is not a non-decreasing sequence).It is allowed that either of the two colors is not used at all. Digits painted in the same color are not required to have consecutive positions.Find any of the valid ways to paint the given sequence of digits or determine that it is impossible to do.

The first line contains a single integer $$$t$$$ ($$$1 \le t \le 10000$$$) — the number of test cases in the input. The first line of each test case contains an integer $$$n$$$ ($$$1 \le n \le 2\cdot10^5$$$) — the length of a given sequence of digits. The next line contains a sequence of $$$n$$$ digits $$$d_1d_2 \dots d_{n}$$$ ($$$0 \le d_i \le 9$$$). The digits are written in a row without spaces or any other separators. The sequence can start with 0. It is guaranteed that the sum of the values of $$$n$$$ for all test cases in the input does not exceed $$$2\cdot10^5$$$.

Print $$$t$$$ lines — the answers to each of the test cases in the input. If there is a solution for a test case, the corresponding output line should contain any of the valid colorings written as a string of $$$n$$$ digits $$$t_1t_2 \dots t_n$$$ ($$$1 \le t_i \le 2$$$), where $$$t_i$$$ is the color the $$$i$$$-th digit is painted in. If there are several feasible solutions, print any of them. If there is no solution, then the corresponding output line should contain a single character '-' (the minus sign).

NoteIn the first test case, $$$d=040425524644$$$. The output $$$t=121212211211$$$ is correct because $$$0022444$$$ (painted in $$$1$$$) concatenated with $$$44556$$$ (painted in $$$2$$$) is $$$002244444556$$$ which is a sorted sequence of $$$n$$$ given digits.

import Data.List
--import Data.Ord
import Control.Monad
import Data.Maybe

isSorted []       = True
isSorted [_]      = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)

pinf = 10 :: Int
minf = -10 :: Int

testWith :: Int -> [Int] -> Maybe String
testWith number array = if isSorted p1 && isSorted p2 && good then Just r else Nothing
  where
    ind = fromMaybe maxBound $ findIndex (>number) array
    r = zipWith (curry mapper) array [(0 :: Int)..]
    mapper (e, i)
      | e == number && i < ind = '2'
      | e == number && i > ind = '1'
      | e < number = '1'
      | e > number = '2'
    good = count number array <= (count number p1 + count number p2)
    (a1, a2) = (filter (<=number) array, filter(>=number) array)
    p1 = cutPInfBegin a1 number
    p2 = cutMInfEnd   a2 number
    count x =  length . filter (==x)

cutPInfBegin [] _ = []
cutPInfBegin x n = filter (/= n) x ++ takeWhile (== n) (reverse x)
cutMInfEnd [] _ = []
cutMInfEnd x n = takeWhile (== n) x ++ filter (/= n) x

solve a 0 = "-"
solve a n
  | Just s <- testWith n a = s
  | otherwise = solve a (n - 1)

main = do
  a <- fmap read getLine :: IO Int
  forM_ [1..a] $ \_ -> do
     _ <- getLine
     arr <- fmap (map $ \x -> read [x]) getLine
     putStrLn $ solve arr 9

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

isSorted []       = True
isSorted [_]      = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)

testWith :: Int -> [Int] -> Maybe String
testWith number array = if isSorted p1 && isSorted p2 && good then Just r else Nothing
  where
    ind = fromMaybe maxBound $ findIndex (>number) array
    r = zipWith (curry mapper) array [(0 :: Int)..]
    mapper (e, i)
      | e == number && i < ind = '2'
      | e == number && i > ind = '1'
      | e < number = '1'
      | e > number = '2'
    good = count number array <= (count number p1 + count number p2)
    (a1, a2) = (filter (<=number) array, filter(>=number) array)
    p1 = cutPInfBegin a1 number
    p2 = cutMInfEnd   a2 number
    count x =  length . filter (==x)

cutPInfBegin [] _ = []
cutPInfBegin x n = filter (/= n) x ++ takeWhile (== n) (reverse x)
cutMInfEnd [] _ = []
cutMInfEnd x n = takeWhile (== n) x ++ filter (/= n) x

solve a 0 = "-"
solve a n
  | Just s <- testWith n a = s
  | otherwise = solve a (n - 1)

main = do
  Just (a, _) <- fmap B.readInt B.getLine
  replicateM_ a $ do
     _ <- B.getLine
     arr <- fmap (map digitToInt . filter isDigit . B.unpack) B.getLine
     B.putStrLn $ B.pack $ solve arr 9

{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Char
import Control.Monad
import Data.Maybe
import Data.Int
import qualified Data.ByteString.Char8 as B

isSorted []       = True
isSorted [_]      = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)

testWith :: Int8 -> [Int8] -> Maybe String
testWith number array = if isSorted p1 && isSorted p2 && good then Just r else Nothing
  where
    ind = fromMaybe maxBound $ findIndex (>number) array
    r = zipWith (curry mapper) array [(0 :: Int)..]
    mapper (e, i)
      | e == number && i < ind = '2'
      | e == number && i > ind = '1'
      | e < number = '1'
      | e > number = '2'
    good = count number array <= (count number p1 + count number p2)
    (a1, a2) = (filter (<=number) array, filter(>=number) array)
    p1 = cutPInfBegin a1 number
    p2 = cutMInfEnd   a2 number
    count x =  length . filter (==x)

cutPInfBegin [] _ = []
cutPInfBegin x n = filter (/= n) x ++ takeWhile (== n) (reverse x)
cutMInfEnd [] _ = []
cutMInfEnd x n = takeWhile (== n) x ++ filter (/= n) x

solve a 0 = "-"
solve a n
  | Just s <- testWith n a = s
  | otherwise = solve a (n - 1)

d2i8 x = case x of
  '0' -> 0
  '1' -> 1
  '2' -> 2
  '3' -> 3
  '4' -> 4
  '5' -> 5
  '6' -> 6
  '7' -> 7
  '8' -> 8
  '9' -> 9

main = do
  Just (a, _) <- fmap B.readInt B.getLine
  replicateM_ a $ do
     _ <- B.getLine
     arr <- fmap (map d2i8 . filter isDigit . B.unpack) B.getLine
     B.putStrLn $ B.pack $ solve arr 9

{-# LANGUAGE TypeApplications #-}

import Data.List
import Data.Ord
import Control.Monad
import Data.Maybe

lis a = extract1 (maximumBy (comparing $ \(_, (a, _, _)) -> a) (zip [0..] cmp)) cmp
  where cmp = lisHelper (tail a) [(1, head a, -1)]
        extract (_, _, -1) _ = []
        extract (1, _, l) _ = [l]
        extract (_, c, l) a = extract (a !! l) a ++ [l]
        extract1 (i, (_, c, -1)) a = [i]
        extract1 (i, (_, c, l)) a = extract (a !! l) a ++ [l] ++ [i]
        lisHelper []     acc = acc
        lisHelper (x:xs) acc = lisHelper xs $ acc ++ [max acc x]
        max acc x = (\((a, _, _), i) -> (a + 1, x, i)) $ maximumBy (comparing $ \((a, _, _), _) -> a) $ filter (\((_, e, _), _) -> e <= x) (zip ((0, -1, -1):acc) [(-1)..])

takeNot what whre = map snd $ filter (\(i, e) -> not $ i `elem` what) (zip [0..] whre)

isSorted []       = True
isSorted [x]      = True
isSorted (x:y:xs) = x <= y && isSorted (y:xs)

prc x = if s then Just $ map (\e -> if e `elem` l then '1' else '2') [0..(length x - 1)] else Nothing
  where l = lis x
        s = isSorted $ takeNot l x

main = do
  a <- fmap read getLine
  forM_ [1..a] $ \_ -> do
     _ <- getLine
     a <- fmap (map $ \x -> read [x]) getLine
     putStrLn $ fromMaybe "-" (prc a)


You are given an array $$$a$$$ consisting of $$$n$$$ positive integers. Find a non-empty subset of its elements such that their sum is even (i.e. divisible by $$$2$$$) or determine that there is no such subset.Both the given array and required subset may contain equal values.

The first line contains a single integer $$$t$$$ ($$$1 \leq t \leq 100$$$), number of test cases to solve. Descriptions of $$$t$$$ test cases follow. A description of each test case consists of two lines. The first line contains a single integer $$$n$$$ ($$$1 \leq n \leq 100$$$), length of array $$$a$$$. The second line contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 100$$$), elements of $$$a$$$. The given array $$$a$$$ can contain equal values (duplicates).

For each test case output $$$-1$$$ if there is no such subset of elements. Otherwise output positive integer $$$k$$$, number of elements in the required subset. Then output $$$k$$$ distinct integers ($$$1 \leq p_i \leq n$$$), indexes of the chosen elements. If there are multiple solutions output any of them.

NoteThere are three test cases in the example.In the first test case, you can choose the subset consisting of only the second element. Its sum is $$$4$$$ and it is even.In the second test case, there is only one non-empty subset of elements consisting of the first element, however sum in it is odd, so there is no solution.In the third test case, the subset consisting of all array's elements has even sum.

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

main = getLine >>= test.read
test 0 = return ()
test i = do
  getLine
  as <- map read.words <$> getLine
  case () of
    _ | any even as     -> print 1 >> print (fst $ head $ filter (even.snd) $ zip [1..] as)
      | length as >= 2  -> putStrLn "2\n1 2"
      | otherwise       -> putStrLn "-1"
  test (i - 1)

import Data.List

main :: IO ()
main =
  interact
    (unlines .
     concatMap (map (unwords . map show) . solve . map read . words) .
     takeSnd . tail . lines)

takeSnd :: [a] -> [a]
takeSnd [] = []
takeSnd [x] = []
takeSnd (x:y:xs) = y : takeSnd xs

solve :: [Int] -> [[Int]]
solve l =
  maybe [[-1]] (\x -> [[length x], x]) (aux (map fst evens) (map fst odds))
  where
    (evens, odds) = partition (even . snd) (zip [1 ..] l)

aux :: [Int] -> [Int] -> Maybe [Int]
aux (x:xs) _ = Just [x]
aux _ (x:y:xs) = Just [x, y]
aux _ _ = Nothing

import System.IO (getChar, putStr)
import Data.Char

{--
getInt  :: Int -> IO Int

getInt x = do c <- getChar
              if isDigit c then getInt (10 * x + digitToInt c)
                         else return x
--}

getInt :: Int -> [Char] -> Int

getInt num (x : xs) = getInt (10 * num + digitToInt x) xs
getInt num _      = num

getString :: Int -> [Char]

getString x = let
                 q = x `div` 10
                 r = x `mod` 10
                 rem = chr $ ord '0' + r
              in if q > 0 then getString q ++ [rem]
                          else [rem]

findEven (x : xs) n = if x `mod` 2 == 0 then Just n
                                      else findEven xs $ n + 1
findEven _       _  = Nothing

solvet :: IO ()
solvet           = do n <- getLine
                      a <- getLine
                      putStr (let
                             line1 = words n
                             line2 = words a
                             l1    = head $ map (getInt 0) line1
                             l2    = map (getInt 0) line2
                             in  case findEven l2 1 of
                                (Just x) -> "1\n" ++ getString x ++ "\n"
                                _        -> if l1 == 1 then "-1\n"
                                                      else "2\n1 2\n")

solve :: Int -> IO ()

solve t | t > 0 = solve (t - 1) >> solvet
        | otherwise = putStr ""

main :: IO ()

main = do str <- getLine
          let
              q1 = words str
              q  = head $ map (getInt 0) q1
           in solve q

{--
          putStr (let
                 ls = words str
                 lsNum = map (getInt 0) ls
                 lsChar = map getString lsNum
                 in foldl (++) [] lsChar)
--}

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

process1 c s | c==1 && odd (head s) = do
			putStrLn "-1"
	     |c==1  = do
			putStrLn "1"
			putStrLn "1"
	     | e>0  = do
			putStrLn "1"
			putStrLn $ show $ snd $ head $ filter (\z-> even (fst z)) $ zip s [1..]
	     | otherwise = do
			putStrLn "2"
			putStrLn $ intercalate " " $ map show $ map snd $ take 2 $ filter (\z-> odd(fst z)) $ zip s [1..]
	where e = length $ filter even  s

process = do
		c<-read <$> getLine ::IO Int
		s<-map read <$> words <$> getLine ::IO [Int]
		process1 c s

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

import Data.List(findIndex)
import Data.Maybe(isNothing,fromJust)

evenSubset :: [Int] -> Maybe [Int]
evenSubset xs
    | isNothing idx = if length xs == 1 then Nothing else Just [1,2]
    | otherwise = fmap ((:[]) . (+1)) idx
    where idx = findIndex even xs

process :: Int -> IO ()
process 0 = return ()
process t = do
    n' <- getLine
    a' <- getLine
    let a = map read . words $ a'
    let s = evenSubset a
    if isNothing s
        then print (-1)
        else do
            let s' = fromJust s
            print . length $ s'
            putStrLn . unwords . map show $ s'
    process (t-1)

main = do
    t <- fmap read getLine
    process t

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

process1 c s | c==1 = do
			putStrLn "-1"
	     |c==2 && even (sum s ) = do
			putStrLn "2"
			putStrLn "1 2"
	     | c==2 =do
			putStrLn "-1"
	     | o >2= do
			putStrLn "2"
			putStrLn $ intercalate " " $ map show $ map snd $ filter (\z-> odd(fst z)) $ zip s [1..]
	     | otherwise = do
			putStrLn "2"
			putStrLn $ intercalate " " $ map show $ map snd $ filter (\z-> even(fst z)) $ zip s [1..]
	where o = length $ filter odd s

process = do
		c<-read <$> getLine ::IO Int
		s<-map read <$> words <$> getLine ::IO [Int]
		process1 c s

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


Alice is playing with some stones.Now there are three numbered heaps of stones. The first of them contains $$$a$$$ stones, the second of them contains $$$b$$$ stones and the third of them contains $$$c$$$ stones.Each time she can do one of two operations:  take one stone from the first heap and two stones from the second heap (this operation can be done only if the first heap contains at least one stone and the second heap contains at least two stones);  take one stone from the second heap and two stones from the third heap (this operation can be done only if the second heap contains at least one stone and the third heap contains at least two stones). She wants to get the maximum number of stones, but she doesn't know what to do. Initially, she has $$$0$$$ stones. Can you help her?

The first line contains one integer $$$t$$$ ($$$1 \leq t \leq 100$$$)  — the number of test cases. Next $$$t$$$ lines describe test cases in the following format: Line contains three non-negative integers $$$a$$$, $$$b$$$ and $$$c$$$, separated by spaces ($$$0 \leq a,b,c \leq 100$$$) — the number of stones in the first, the second and the third heap, respectively. In hacks it is allowed to use only one test case in the input, so $$$t = 1$$$ should be satisfied.

Print $$$t$$$ lines, the answers to the test cases in the same order as in the input. The answer to the test case is the integer  — the maximum possible number of stones that Alice can take after making some operations.

NoteFor the first test case in the first test, Alice can take two stones from the second heap and four stones from the third heap, making the second operation two times. Then she can take one stone from the first heap and two stones from the second heap, making the first operation one time. The summary number of stones, that Alice will take is $$$9$$$. It is impossible to make some operations to take more than $$$9$$$ stones, so the answer is $$$9$$$.

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

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

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

import qualified Data.ByteString.Char8 as B

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

-- import Debug.Trace
import Text.Printf

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

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

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

main = readInt >>= flip replicateM solve >>= mapM_ print

solve = do
	[ a, b, c ] <- readInts
	return $ maximum $ do
		i <- [ 0 .. min a ( b `div` 2 ) ]
		let
			j = min ( b - 2 * i ) ( c `div` 2 )
		return $ i + 2 * i + j + 2 * j

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}
#ifndef DEBUG
{-# LANGUAGE Safe              #-}
#endif

import           Control.Applicative
import           Control.Exception
import           Control.Monad
import           Control.Monad.State.Strict
import qualified Data.Array                 as A
import qualified Data.Array.Unboxed         as UA
import qualified Data.Array.ST.Safe         as MA
import           Data.Bool
import qualified Data.ByteString.Builder    as B
import qualified Data.ByteString.Char8      as C
import           Data.Char
import           Data.Function
import qualified Data.IntMap.Strict         as IM
import qualified Data.IntSet                as IS
import qualified Data.List                  as L
import qualified Data.List.NonEmpty         as NL
import           Data.Monoid
import qualified Data.Map.Strict            as M
import           Data.Monoid
import           Data.Ord
import           Data.Semigroup
import qualified Data.Set                   as S
import           Data.Tuple
import           Foreign
import qualified System.IO                  as IO
#ifdef DEBUG
import           Debug.Trace
#endif

main :: IO ()
main = do
  t <- readLn
  replicateM_ t $ do
      [a,b,c] <- map read.words <$> getLine
      print $ maximum $ do
          x <- [0..min a (div b 2)]
          let b' = b - 2 * x
          y <- [0..min b' (div c 2)]
          return $ (x + y) * 3

import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Array
import qualified Data.Map as M

process  = do
		[a,b,c] <- map read <$> words <$> getLine ::IO [Int]
		let m1= min b (div c 2)
		let m2 = min a (div (b-m1) 2)
		print $ 3*(m1+m2)

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

process :: Int -> Int -> Int -> Int
process a b c
    | 2*b <= c = 3*b
    | 2*a <= b' = 3*c2 + 3*a
    | otherwise = 3*c2 + 3*b2
    where
        c2 = c `div` 2
        b' = b-c2
        b2 = b' `div` 2

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    t <- fmap readInt getLine
    ts <- fmap (map (map readInt.words).lines) getContents
    mapM_ print $ map (\[a,b,c] -> process a b c) ts


A number is called 2050-number if it is $$$2050$$$, $$$20500$$$, ..., ($$$2050 \cdot 10^k$$$ for integer $$$k \ge 0$$$).Given a number $$$n$$$, you are asked to represent $$$n$$$ as the sum of some (not necessarily distinct) 2050-numbers. Compute the minimum number of 2050-numbers required for that.

The first line contains a single integer $$$T$$$ ($$$1\le T\leq 1\,000$$$) denoting the number of test cases. The only line of each test case contains a single integer $$$n$$$ ($$$1\le n\le 10^{18}$$$) denoting the number to be represented.

For each test case, output the minimum number of 2050-numbers in one line.  If $$$n$$$ cannot be represented as the sum of 2050-numbers, output $$$-1$$$ instead.

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.ST

import qualified Data.Array as A

import Data.Bits(xor)

import Data.Array((!))

n2050 :: Integer -> Integer
n2050 n = aux 2050 where
	aux i
		| n < i = div i 10
		| otherwise = aux $ 10*i

solve :: Integer -> Maybe Integer
solve n = aux n where
	aux 0 = Just 0
	aux n | n < 2050 = Nothing
	aux n = do
		i <- aux (n - n2050 n)
		return $ i + 1

showR :: Maybe Integer -> Integer
showR Nothing = -1
showR (Just i) = i

main = do
	t <- getLine >>= return . read :: IO Integer
	let loop t = if t == 0 then return () else do
		n <- getLine >>= return . read :: IO Integer
		--a <- getLine >>= return . (fmap read) . words :: IO [Integer]
		print $ showR $ solve n
		loop $ t - 1
	loop t

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.State.Strict

import qualified Data.Array as A

import Data.Bits(xor)

import Data.Array((!))

n2050 :: Integer -> Integer
n2050 n = aux 2050 where
	aux i
		| n < i = div i 10
		| otherwise = aux $ 10*i

solve :: Integer -> Maybe Integer
solve n = aux n where
	aux 0 = Just 0
	aux n | n < 2050 = Nothing
	aux n = do
		i <- aux (n - n2050 n)
		return $ i + 1

showR :: Maybe Integer -> Integer
showR Nothing = -1
showR (Just i) = i

main = do
	t <- getLine >>= return . read :: IO Integer
	let loop t = if t == 0 then return () else do
		n <- getLine >>= return . read :: IO Integer
		--a <- getLine >>= return . (fmap read) . words :: IO [Integer]
		print $ showR $ solve n
		loop $ t - 1
	loop t

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

import qualified Data.Array as A

import Data.Bits(xor)

import Data.Array((!))

n2050 :: Integer -> Integer
n2050 n = aux 2050 where
	aux i
		| n < i = div i 10
		| otherwise = aux $ 10*i

solve :: Integer -> Maybe Integer
solve n = aux n where
	aux 0 = Just 0
	aux n | n < 2050 = Nothing
	aux n = do
		i <- aux (n - n2050 n)
		return $ i + 1

showR :: Maybe Integer -> Integer
showR Nothing = -1
showR (Just i) = i

main = do
	t <- getLine >>= return . read :: IO Integer
	let loop t = if t == 0 then return () else do
		n <- getLine >>= return . read :: IO Integer
		--a <- getLine >>= return . (fmap read) . words :: IO [Integer]
		print $ showR $ solve n
		loop $ t - 1
	loop t

digitSum :: Integer -> Integer
digitSum v
  | v /= 0 = m + d
  | otherwise = 0
  where
    m = mod v 10
    d = digitSum $ div v 10

solve :: Integer -> Integer
solve val
  | m == 0 = digitSum d
  | otherwise = -1
  where
    m = mod val 2050
    d = div val 2050

operate :: IO()
operate = do
  line <- getLine
  let n = read line
  print $ solve n

solveAll :: Int -> IO()
solveAll n
  | n /= 0 = operate >> solveAll (n - 1)
  | otherwise = return ()

main :: IO ()
main = do
  line <- getLine
  let n = read line
  solveAll n

digitSum :: Integer -> Integer
digitSum v
  | v /= 0 = m + d
  | otherwise = 0
  where
    m = mod v 10
    d = digitSum $ div v 10

solve :: Integer -> Integer
solve val
  | m == 0 = digitSum d
  | otherwise = -1
  where
    m = mod val 2050
    d = div val 2050

solveAll :: [String] -> [String]
solveAll = map $ show . solve . read

main :: IO ()
main =
  interact $ unlines . solveAll . to_list
  where
    to_list = tail . words

digitSum :: Integer -> Integer
digitSum v
  | v /= 0 = m + d
  | otherwise = 0
  where
    m = mod v 10
    d = digitSum $ div v 10

solve :: [Integer] -> [Integer]
solve (val : xs)
  | m == 0 = digitSum d : next
  | otherwise = -1 : next
  where
    m = mod val 2050
    d = div val 2050
    next = solve xs
solve [] = []

main :: IO ()
main =
  interact $ to_string . solve . to_list
  where
    to_list = map read . tail . words
    to_string = unlines . map show

ns = takeWhile (<10^18) $ iterate (*10) 2050
solve n = case foldr (\x (r,ds) -> let (q,s) = r `divMod` x in (s,q:ds)) (n,[]) ns  of
    (a,_)  | a > 0 -> -1
    (_, b)         -> sum b

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

solve n = case foldr (\x (r,ds) -> let (q,s) = r `divMod` x in (s,q:ds)) (n,[]) $ takeWhile (<10^18) $ iterate (*10) 2050  of
    (a,_)  | a > 0 -> -1
    (_, b)         -> sum b

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

import Control.Monad
import Data.Char
import Data.Int

solve :: Int64 -> Int
solve n
  | n `mod` 2050 /= 0 = -1
  | otherwise = bitsSum $ quot n 2050
  where
    bitsSum i = sum $ (\c -> ord c - ord '0') <$> show i

solveIO :: IO ()
solveIO = do
  l <- getLine
  let t = read l :: Int64
  putStr $ show (solve t) ++ "\n"

main :: IO ()
main = do
  l <- getLine
  let t = read l :: Int
  replicateM_ t solveIO

import Control.Monad
import Data.Int

solve :: Int64 -> Int64
solve n
  | n `mod` 2050 /= 0 = -1
  | otherwise = bitsSum $ quot n 2050
  where
    bitsSum i = sum $ read <$> (\c -> [c]) <$> show i

solveIO :: IO ()
solveIO = do
  l <- getLine
  let t = read l :: Int64
  putStr $ show (solve t) ++ "\n"

main :: IO ()
main = do
  l <- getLine
  let t = read l :: Int
  replicateM_ t solveIO

solve x ans
  | x > 0 = solve (x `div` 10) (ans + (x `mod` 10))
  | otherwise = ans

helper x =
  show $
    if y `mod` 2050 == 0
    then solve (y `div` 2050) 0
    else -1
    where
      y = read x

main = do
  getLine
  interact $ unlines . map helper . lines

solve x ans
  | x > 0 = solve (x `div` 10) (ans + (x `mod` 10))
  | otherwise = ans

helper x = show $
                if (read x :: Integer) `mod` 2050 == 0
                then solve ((read x :: Integer) `div` 2050) 0
                else -1

main = do
  getLine
  interact $ unlines . map helper . lines

module Main where

    import Control.Monad ( replicateM )

    main :: IO ()
    main = do
        input <- getLine
        let n = (read input :: Int)
        inputs <- replicateM n getLine
        let numbers = map (read::String->Int) inputs
        let ret = map getAnswer numbers
        mapM_ print ret

    getDigits:: Int -> Int
    getDigits 0 = 0
    getDigits x = xd + getDigits ((x - xd) `div` 10)
        where xd = x `mod` 10

    getAnswer:: Int -> Int
    getAnswer x
        | x `mod` 2050 == 0 = getDigits (x `div` 2050)
        | otherwise = -1

import Control.Monad
import Data.Maybe
import qualified Data.ByteString.Char8 as C
import Data.ByteString.Builder
import System.IO

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

parseInteger :: C.ByteString -> Integer
parseInteger = fst . fromJust . C.readInteger

getInts :: IO [Int]
getInts = map parseInt . C.words <$> C.getLine

main :: IO ()
main = do
  [t] <- getInts
  output <- fmap mconcat $ replicateM t $ do
    n <- fmap parseInteger C.getLine
    let result = if n `mod` 2050 == 0 then solve (n `div` 2050) else (-1)
        solve 0 = 0
        solve x = x `mod` 10 + solve (x `div` 10)
    return $ integerDec result `mappend` charUtf8 '\n'
  hPutBuilder stdout output

import Control.Monad
import Data.Int
import Data.List

char2s :: Char -> [Char]
char2s c = [c]

calc :: Int64 -> Int
calc n | n `mod` 2050 == 0 =
         let k = n `div` 2050
             s = map read $ map char2s $ show k :: [Int] in
           sum s
calc _ = -1

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

import Control.Monad ( forM )

digits :: Integer -> [Integer]
digits x
    | x == 0 = [0]
    | otherwise = (x `mod` 10):digits (x `div` 10)

solve :: Integer -> Integer
solve x
    | x `mod` 2050 /= 0 = -1
    | otherwise = sum $ digits $ x `div` 2050

main :: IO ()
main = do
    a <- getLine
    let t = read a :: Int
    s <- forM [1..t] $ \_ -> do
        b <- getLine
        let n = read b :: Integer
        return (solve n) :: IO Integer
    mapM_ print s

digitSum :: Int -> Int
digitSum v
  | v /= 0 = m + d
  | otherwise = 0
  where
    m = mod v 10
    d = digitSum $ div v 10

solve :: [Int] -> [Int]
solve (val : xs)
  | m == 0 = digitSum d : next
  | otherwise = -1 : next
  where
    m = mod val 2050
    d = div val 2050
    next = solve xs
solve [] = []

main :: IO ()
main =
  interact $ to_string . solve . to_list
  where
    to_list = map read . tail . words
    to_string = unlines . map show

solve n = case foldr (\x (r,ds) -> let (q,s) = r `divMod` x in (s,q:ds)) (n,[]) $ takeWhile (<10^18) $ iterate (*10) 2050  of
    (a,_)  | a > 0 -> -1
    (_, b)         -> sum b

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

import Control.Monad

solve :: Int -> Int
solve n
  | n `mod` 2050 /= 0 = -1
  | otherwise = bitsSum $ quot n 2050
  where
    bitsSum i = sum $ read <$> (\c -> [c]) <$> show i

solveIO :: IO ()
solveIO = do
  l <- getLine
  let t = read l :: Int
  putStr $ show (solve t) ++ "\n"

main :: IO ()
main = do
  l <- getLine
  let t = read l :: Int
  replicateM_ t solveIO


This task is very simple. Given a string S of length n and q queries each query is on the format i j k which means sort the substring consisting of the characters from i to j in non-decreasing order if k = 1 or in non-increasing order if k = 0.Output the final string after applying the queries.

The first line will contain two integers n, q (1 ≤ n ≤ 105, 0 ≤ q ≤ 50 000), the length of the string and the number of queries respectively.  Next line contains a string S itself. It contains only lowercase English letters. Next q lines will contain three integers each i, j, k (1 ≤ i ≤ j ≤ n, ).

Output one line, the string S after applying the queries.

module Main where

import Data.List
import Data.Maybe
import Data.Function
import Control.Arrow

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: [(Char,Int)], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = [(c, 1)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = [], l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node | null $ content node = [l,r] >>= \f -> pnt $ f node
         | otherwise           = content node >>= \(c,n) -> replicate n c

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq cnt $ solve s' t'
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | null $ content node           = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = map ((head *** sum) . unzip)
            $ groupBy ((==) `on` fst)
            $ m (k==0) reverse id
            $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = [],
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=cnt'', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid   = div (l_end+r_end) 2
        cnt'  = mask cnt l_end r_end
        cnt'' = map (second $ \(l,r)->r-l+1) cnt'

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (second $ max l_end *** min r_end) cnt, l<=r]

module Main where

import Data.List
import Data.Maybe
import Data.Function
import Control.Arrow

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

data Tree = Nil | Node { content :: [(Char,Int)], l, r :: Tree, rng :: (Int, Int) }

makeTree [c] rng = Node { content = [(c, 1)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = [], l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node | null $ content node = [l,r] >>= \f -> pnt $ f node
         | otherwise           = content node >>= \(c,n) -> replicate n c

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (snd $ snd $ last cnt) $ solve s' t'
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | null $ content node           = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = map ((head *** sum) . unzip)
            $ groupBy ((==) `on` fst)
            $ (if k==0 then reverse else id)
            $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt l_end r_end
  | otherwise                     = node {
      content = [],
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=cnt'', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid   = div (l_end+r_end) 2
        cnt'  = mask cnt l_end r_end
        cnt'' = map (second $ \(l,r)->r-l+1) cnt'

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (second $ max l_end *** min r_end) cnt, l<=r]

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (length cnt) (solve s' t')
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | content node == Nothing       = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = fromJust $ content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=Just cnt', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid = div (l_end+r_end) 2
        cnt' = mask cnt l_end r_end

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (length cnt) (solve s' t')
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t []
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)}) res
  | q_r < l_end || r_end < q_l    = res
  | content node == Nothing       = extract q_l q_r (l node) (extract q_l q_r (r node) res)
  | q_l <= l_end && r_end <= q_r  = (fromJust $ content node) ++ res
  | otherwise                     = extract q_l q_r (l node) (extract q_l q_r (r node) res)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=Just cnt', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid = div (l_end+r_end) 2
        cnt' = mask cnt l_end r_end

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | content node == Nothing       = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = fromJust $ content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=Just cnt', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid = div (l_end+r_end) 2
        cnt' = mask cnt l_end r_end

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

import Data.List
import Data.Maybe
import Data.Function
import Control.Arrow

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: [(Char,Int)], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = [(c, 1)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = [], l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node | null $ content node = [l,r] >>= \f -> pnt $ f node
         | otherwise           = content node >>= \(c,n) -> replicate n c

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq cnt $ solve s' t'
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | null $ content node           = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = map ((head *** sum) . unzip)
            $ groupBy ((==) `on` fst)
            $ m (k==0) reverse id
            $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = [],
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=cnt'', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid   = div (l_end+r_end) 2
        cnt'  = mask cnt l_end r_end
        cnt'' = map (second $ \(l,r)->r-l+1) cnt'

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq cnt $ solve s' t'
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | content node == Nothing       = [l,r] >>= \f -> extract q_l q_r (f node)
  | q_l <= l_end && r_end <= q_r  = fromJust $ content node
  | otherwise                     = [l,r] >>= \f -> extract q_l q_r (f node)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=Just cnt', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid = div (l_end+r_end) 2
        cnt' = mask cnt l_end r_end

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  solve lines (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (length cnt) (solve s' t')
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)})
  | q_r < l_end || r_end < q_l    = []
  | content node == Nothing       = extract q_l q_r (l node) ++ extract q_l q_r (r node)
  | q_l <= l_end && r_end <= q_r  = fromJust $ content node
  | otherwise                     = extract q_l q_r (l node) ++ extract q_l q_r (r node)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = genNode cnt' l_end r_end
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = mask cnt l_end r_end

genNode cnt l_end r_end
  = Node { content=Just cnt', rng=(l_end,r_end), l=genNode cnt' l_end mid, r=genNode cnt' (mid+1) r_end }
  where mid = div (l_end+r_end) 2
        cnt' = mask cnt l_end r_end

mask cnt l_end r_end = [c | c@(_,(l,r)) <- map (mask' (l_end, r_end)) cnt, l<=r]
  where mask' (l, r) (c, (l_end, r_end)) = (c, (max l_end l, min r_end r))

module Main where

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (drop 40000 lines) (makeTree s (1,n))

data Tree = Nil | Node [Int] Tree Tree (Int, Int) deriving Show

makeTree [c] r = Node [if c'==c then 1 else 0 | c' <- ['a'..'z']] Nil Nil r

makeTree s r@(l_end, r_end)
  = Node (zipWith (+) left_l right_l) left right r
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left@(Node left_l _ _ _) = makeTree left_s (l_end, mid)
	right@(Node right_l _ _ _) = makeTree right_s (mid + 1, r_end)

pnt Nil
  = ""

pnt (Node cnt l r (l_end, r_end))
  | l_end == r_end
  = [c | (1,c) <- zip cnt ['a'..'z']]
  | otherwise
  = pnt l ++ pnt r

solve :: [String] -> Tree -> IO ()
solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = extract i j t
	t' = replace i j k cnt t

extract l r (Node cnt l_ch r_ch (l_end, r_end))
  | l <= l_end && r_end <= r
  = cnt
  | r < l_end || r_end < l
  = [0,0..]
  | otherwise
  = zipWith (+) (extract l r l_ch) (extract l r r_ch)

replace l r k cnt node@(Node _ _ _ (l_end, r_end))
  | r < l_end || r_end < l
  = node
  | l == l_end && r == r_end
  = sp cnt k (l_end, r_end)
  | otherwise
  = replace' l r k cnt node

replace' l r k cnt node@(Node _ l_ch r_ch (l_end, r_end))
  | mid < l
  = makeNode l_ch (replace l r k cnt r_ch) (l_end, r_end)
  | r <= mid
  = makeNode (replace l r k cnt l_ch) r_ch (l_end, r_end)
  | otherwise
  = makeNode (replace l mid k l_cnt l_ch) (replace (mid+1) r k r_cnt r_ch) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        (l_cnt, r_cnt) = sp'' k cnt (mid - l + 1)

makeNode l@(Node l_cnt _ _ _) r@(Node r_cnt _ _ _) rng
  = Node (zipWith (+) l_cnt r_cnt) l r rng

sp cnt k (l_end, r_end)
  = Node cnt (sp l_cnt k (l_end, mid)) (sp r_cnt k (mid+1, r_end)) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        l_len = mid - l_end + 1
	(l_cnt, r_cnt) = sp'' k cnt l_len

sp' [] _ = ([],[])
sp' (cnt:cnt') l_len
  | cnt <= l_len
  = (cnt:l, 0:r)
  | otherwise
  = (l_len:l,cnt-l_len:r)
  where l_len' = max (l_len - cnt) 0
        (l, r) = sp' cnt' l_len'

sp'' 1 cnt l_len = sp' cnt l_len
sp'' 0 cnt l_len = (l, r)
  where l_len' = sum cnt - l_len
        (r, l) = sp' cnt l_len'

module Main where

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (take 25000 lines) (makeTree s (1,n))

data Tree = Nil | Node [Int] Tree Tree (Int, Int) deriving Show

makeTree [c] r = Node [if c'==c then 1 else 0 | c' <- ['a'..'z']] Nil Nil r

makeTree s r@(l_end, r_end)
  = Node (zipWith (+) left_l right_l) left right r
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left@(Node left_l _ _ _) = makeTree left_s (l_end, mid)
	right@(Node right_l _ _ _) = makeTree right_s (mid + 1, r_end)

pnt Nil
  = ""

pnt (Node cnt l r (l_end, r_end))
  | l_end == r_end
  = [c | (1,c) <- zip cnt ['a'..'z']]
  | otherwise
  = pnt l ++ pnt r

solve :: [String] -> Tree -> IO ()
solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = extract i j t
	t' = replace i j k cnt t

extract l r (Node cnt l_ch r_ch (l_end, r_end))
  | l <= l_end && r_end <= r
  = cnt
  | r < l_end || r_end < l
  = [0,0..]
  | otherwise
  = zipWith (+) (extract l r l_ch) (extract l r r_ch)

replace l r k cnt node@(Node _ _ _ (l_end, r_end))
  | r < l_end || r_end < l
  = node
  | l == l_end && r == r_end
  = sp cnt k (l_end, r_end)
  | otherwise
  = replace' l r k cnt node

replace' l r k cnt node@(Node _ l_ch r_ch (l_end, r_end))
  | mid < l
  = makeNode l_ch (replace l r k cnt r_ch) (l_end, r_end)
  | r <= mid
  = makeNode (replace l r k cnt l_ch) r_ch (l_end, r_end)
  | otherwise
  = makeNode (replace l mid k l_cnt l_ch) (replace (mid+1) r k r_cnt r_ch) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        (l_cnt, r_cnt) = sp'' k cnt (mid - l + 1)

makeNode l@(Node l_cnt _ _ _) r@(Node r_cnt _ _ _) rng
  = Node (zipWith (+) l_cnt r_cnt) l r rng

sp cnt k (l_end, r_end)
  = Node cnt (sp l_cnt k (l_end, mid)) (sp r_cnt k (mid+1, r_end)) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        l_len = mid - l_end + 1
	(l_cnt, r_cnt) = sp'' k cnt l_len

sp' [] _ = ([],[])
sp' (cnt:cnt') l_len
  | cnt <= l_len
  = (cnt:l, 0:r)
  | otherwise
  = (l_len:l,cnt-l_len:r)
  where l_len' = max (l_len - cnt) 0
        (l, r) = sp' cnt' l_len'

sp'' 1 cnt l_len = sp' cnt l_len
sp'' 0 cnt l_len = (l, r)
  where l_len' = sum cnt - l_len
        (r, l) = sp' cnt l_len'

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (take 1000 lines) (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (length cnt) (solve s' t')
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t []
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)}) res
  | q_r < l_end || r_end < q_l    = res
  | content node == Nothing       = extract q_l q_r (l node) (extract q_l q_r (r node) res)
  | q_l <= l_end && r_end <= q_r  = (fromJust $ content node) ++ res
  | otherwise                     = extract q_l q_r (l node) (extract q_l q_r (r node) res)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = node {
      content = Just cnt',
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = [c | Just c <- map (mask (l_end, r_end)) cnt]

mask (l, r) item@(c, (l_end, r_end))
  | r < l_end || r_end < l = Nothing
  | otherwise              = Just (c, (max l_end l, min r_end r))

module Main where

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (take 5000 lines) (makeTree s (1,n))

data Tree = Nil | Node [Int] Tree Tree (Int, Int) deriving Show

makeTree [c] r = Node [if c'==c then 1 else 0 | c' <- ['a'..'z']] Nil Nil r

makeTree s r@(l_end, r_end)
  = Node (zipWith (+) left_l right_l) left right r
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left@(Node left_l _ _ _) = makeTree left_s (l_end, mid)
	right@(Node right_l _ _ _) = makeTree right_s (mid + 1, r_end)

pnt Nil
  = ""

pnt (Node cnt l r (l_end, r_end))
  | l_end == r_end
  = [c | (1,c) <- zip cnt ['a'..'z']]
  | otherwise
  = pnt l ++ pnt r

solve :: [String] -> Tree -> IO ()
solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = extract i j t
	t' = replace i j k cnt t

extract l r (Node cnt l_ch r_ch (l_end, r_end))
  | l <= l_end && r_end <= r
  = cnt
  | r < l_end || r_end < l
  = [0,0..]
  | otherwise
  = zipWith (+) (extract l r l_ch) (extract l r r_ch)

replace l r k cnt node@(Node _ _ _ (l_end, r_end))
  | r < l_end || r_end < l
  = node
  | l == l_end && r == r_end
  = sp cnt k (l_end, r_end)
  | otherwise
  = replace' l r k cnt node

replace' l r k cnt node@(Node _ l_ch r_ch (l_end, r_end))
  | mid < l
  = makeNode l_ch (replace l r k cnt r_ch) (l_end, r_end)
  | r <= mid
  = makeNode (replace l r k cnt l_ch) r_ch (l_end, r_end)
  | otherwise
  = makeNode (replace l mid k l_cnt l_ch) (replace (mid+1) r k r_cnt r_ch) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        (l_cnt, r_cnt) = sp'' k cnt (mid - l + 1)

makeNode l@(Node l_cnt _ _ _) r@(Node r_cnt _ _ _) rng
  = Node (zipWith (+) l_cnt r_cnt) l r rng

sp cnt k (l_end, r_end)
  = Node cnt (sp l_cnt k (l_end, mid)) (sp r_cnt k (mid+1, r_end)) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        l_len = mid - l_end + 1
	(l_cnt, r_cnt) = sp'' k cnt l_len

sp' [] _ = ([],[])
sp' (cnt:cnt') l_len
  | cnt <= l_len
  = (cnt:l, 0:r)
  | otherwise
  = (l_len:l,cnt-l_len:r)
  where l_len' = max (l_len - cnt) 0
        (l, r) = sp' cnt' l_len'

sp'' 1 cnt l_len = sp' cnt l_len
sp'' 0 cnt l_len = (l, r)
  where l_len' = sum cnt - l_len
        (r, l) = sp' cnt l_len'

module Main where

import Data.List
import Data.Maybe

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve [last lines] (makeTree s (1,n))

m True  x _ = x
m False _ y = y

data Tree = Nil | Node { content :: Maybe [(Char,(Int,Int))], l, r :: Tree, rng :: (Int, Int) }
  deriving Show

makeTree [c] rng = Node { content = Just [(c, rng)], l = Nil, r = Nil, rng = rng }

makeTree s rng@(l_end, r_end)
  = Node { content = Nothing, l = left, r = right, rng = rng }
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left = makeTree left_s (l_end, mid)
        right = makeTree right_s (mid + 1, r_end)

pnt node@(Node{content = Nothing})  = pnt (l node) ++ pnt (r node)
pnt node@(Node{content = Just cnt}) = concat $ map (\(c,(l,r))->replicate (r-l+1) c) cnt

solve [] t = putStrLn $ pnt t
solve (s:s') t = seq (length cnt) (solve s' t')
  where [i,j,k] = map read $ words s
        cnt = integrate i j k $ extract i j t []
        t' = replace i j cnt t

extract q_l q_r node@(Node{rng=(l_end,r_end)}) res
  | q_r < l_end || r_end < q_l    = res
  | content node == Nothing       = extract q_l q_r (l node) (extract q_l q_r (r node) res)
  | q_l <= l_end && r_end <= q_r  = (fromJust $ content node) ++ res
  | otherwise                     = extract q_l q_r (l node) (extract q_l q_r (r node) res)

integrate :: Int -> Int -> Int -> [(Char,(Int,Int))] -> [(Char,(Int,Int))]
integrate l_end r_end k ls
  = integrate' ls' l_end
  where ls' = init
            $ foldr (\(c,n) ((c',n'):etc)->m (c==c') ((c,n+n'):etc) ((c,n):(c',n'):etc)) [('?',0)]
            $ m (k==0) reverse id
            $ map (\(c,(l_end,r_end))->(c,r_end-l_end + 1)) $ sort ls

integrate' [] _ = []
integrate' ((c,n):etc) l_end = (c,(l_end,l_end+n-1)) : integrate' etc (l_end+n)

replace q_l q_r cnt node@(Node{rng=(l_end, r_end)})
  | q_r < l_end || r_end < q_l    = node
  | q_l <= l_end && r_end <= q_r  = node {
      content = Just cnt',
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  | otherwise                     = node {
      content = Nothing,
      l       = replace q_l q_r cnt' (l node),
      r       = replace q_l q_r cnt' (r node)
    }
  where cnt' = [c | Just c <- map (mask (l_end, r_end)) cnt]

mask (l, r) item@(c, (l_end, r_end))
  | r < l_end || r_end < l = Nothing
  | otherwise              = Just (c, (max l_end l, min r_end r))

module Main where

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (take 10 lines) (makeTree s (1,n))

data Tree = Nil | Node [Int] Tree Tree (Int, Int) deriving Show

makeTree [c] r = Node [if c'==c then 1 else 0 | c' <- ['a'..'z']] Nil Nil r

makeTree s r@(l_end, r_end)
  = Node (zipWith (+) left_l right_l) left right r
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left@(Node left_l _ _ _) = makeTree left_s (l_end, mid)
	right@(Node right_l _ _ _) = makeTree right_s (mid + 1, r_end)

pnt Nil
  = ""

pnt (Node cnt l r (l_end, r_end))
  | l_end == r_end
  = [c | (1,c) <- zip cnt ['a'..'z']]
  | otherwise
  = pnt l ++ pnt r

solve :: [String] -> Tree -> IO ()
solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = extract i j t
	t' = replace i j k cnt t

extract l r (Node cnt l_ch r_ch (l_end, r_end))
  | l <= l_end && r_end <= r
  = cnt
  | r < l_end || r_end < l
  = [0,0..]
  | otherwise
  = zipWith (+) (extract l r l_ch) (extract l r r_ch)

replace l r k cnt node@(Node _ _ _ (l_end, r_end))
  | r < l_end || r_end < l
  = node
  | l == l_end && r == r_end
  = sp cnt k (l_end, r_end)
  | otherwise
  = replace' l r k cnt node

replace' l r k cnt node@(Node _ l_ch r_ch (l_end, r_end))
  | mid < l
  = makeNode l_ch (replace l r k cnt r_ch) (l_end, r_end)
  | r <= mid
  = makeNode (replace l r k cnt l_ch) r_ch (l_end, r_end)
  | otherwise
  = makeNode (replace l mid k l_cnt l_ch) (replace (mid+1) r k r_cnt r_ch) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        (l_cnt, r_cnt) = sp'' k cnt (mid - l + 1)

makeNode l@(Node l_cnt _ _ _) r@(Node r_cnt _ _ _) rng
  = Node (zipWith (+) l_cnt r_cnt) l r rng

sp cnt k (l_end, r_end)
  = Node cnt (sp l_cnt k (l_end, mid)) (sp r_cnt k (mid+1, r_end)) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        l_len = mid - l_end + 1
	(l_cnt, r_cnt) = sp'' k cnt l_len

sp' [] _ = ([],[])
sp' (cnt:cnt') l_len
  | cnt <= l_len
  = (cnt:l, 0:r)
  | otherwise
  = (l_len:l,cnt-l_len:r)
  where l_len' = max (l_len - cnt) 0
        (l, r) = sp' cnt' l_len'

sp'' 1 cnt l_len = sp' cnt l_len
sp'' 0 cnt l_len = (l, r)
  where l_len' = sum cnt - l_len
        (r, l) = sp' cnt l_len'

module Main where

main = do
  line1 <- getLine
  let [n, q] = map read $ words line1
  s <- getLine
  lines <- sequence [getLine | _ <- [1..q]]
  if n < 1000 then solve lines (makeTree s (1,n))
              else solve (take 1000 lines) (makeTree s (1,n))

data Tree = Nil | Node [Int] Tree Tree (Int, Int) deriving Show

makeTree [c] r = Node [if c'==c then 1 else 0 | c' <- ['a'..'z']] Nil Nil r

makeTree s r@(l_end, r_end)
  = Node (zipWith (+) left_l right_l) left right r
  where mid = (l_end + r_end) `div` 2
        (left_s, right_s) = splitAt (mid - l_end + 1) s
        left@(Node left_l _ _ _) = makeTree left_s (l_end, mid)
	right@(Node right_l _ _ _) = makeTree right_s (mid + 1, r_end)

pnt Nil
  = ""

pnt (Node cnt l r (l_end, r_end))
  | l_end == r_end
  = [c | (1,c) <- zip cnt ['a'..'z']]
  | otherwise
  = pnt l ++ pnt r

solve :: [String] -> Tree -> IO ()
solve [] t = putStrLn $ pnt t
solve (s:s') t = solve s' t'
  where [i,j,k] = map read $ words s
        cnt = extract i j t
	t' = replace i j k cnt t

extract l r (Node cnt l_ch r_ch (l_end, r_end))
  | l <= l_end && r_end <= r
  = cnt
  | r < l_end || r_end < l
  = [0,0..]
  | otherwise
  = zipWith (+) (extract l r l_ch) (extract l r r_ch)

replace l r k cnt node@(Node _ _ _ (l_end, r_end))
  | r < l_end || r_end < l
  = node
  | l == l_end && r == r_end
  = sp cnt k (l_end, r_end)
  | otherwise
  = replace' l r k cnt node

replace' l r k cnt node@(Node _ l_ch r_ch (l_end, r_end))
  | mid < l
  = makeNode l_ch (replace l r k cnt r_ch) (l_end, r_end)
  | r <= mid
  = makeNode (replace l r k cnt l_ch) r_ch (l_end, r_end)
  | otherwise
  = makeNode (replace l mid k l_cnt l_ch) (replace (mid+1) r k r_cnt r_ch) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        (l_cnt, r_cnt) = sp'' k cnt (mid - l + 1)

makeNode l@(Node l_cnt _ _ _) r@(Node r_cnt _ _ _) rng
  = Node (zipWith (+) l_cnt r_cnt) l r rng

sp cnt k (l_end, r_end)
  = Node cnt (sp l_cnt k (l_end, mid)) (sp r_cnt k (mid+1, r_end)) (l_end, r_end)
  where mid = (l_end + r_end) `div` 2
        l_len = mid - l_end + 1
	(l_cnt, r_cnt) = sp'' k cnt l_len

sp' [] _ = ([],[])
sp' (cnt:cnt') l_len
  | cnt <= l_len
  = (cnt:l, 0:r)
  | otherwise
  = (l_len:l,cnt-l_len:r)
  where l_len' = max (l_len - cnt) 0
        (l, r) = sp' cnt' l_len'

sp'' 1 cnt l_len = sp' cnt l_len
sp'' 0 cnt l_len = (l, r)
  where l_len' = sum cnt - l_len
        (r, l) = sp' cnt l_len'


George is a cat, so he really likes to play. Most of all he likes to play with his array of positive integers b. During the game, George modifies the array by using special changes. Let's mark George's current array as b1, b2, ..., b|b| (record |b| denotes the current length of the array). Then one change is a sequence of actions:   Choose two distinct indexes i and j (1 ≤ i, j ≤ |b|; i ≠ j), such that bi ≥ bj.  Get number v = concat(bi, bj), where concat(x, y) is a number obtained by adding number y to the end of the decimal record of number x. For example, concat(500, 10) = 50010, concat(2, 2) = 22.  Add number v to the end of the array. The length of the array will increase by one.  Remove from the array numbers with indexes i and j. The length of the array will decrease by two, and elements of the array will become re-numbered from 1 to current length of the array. George played for a long time with his array b and received from array b an array consisting of exactly one number p. Now George wants to know: what is the maximum number of elements array b could contain originally? Help him find this number. Note that originally the array could contain only positive integers.

The first line of the input contains a single integer p (1 ≤ p < 10100000). It is guaranteed that number p doesn't contain any leading zeroes.

Print an integer — the maximum number of elements array b could contain originally.

NoteLet's consider the test examples:   Originally array b can be equal to {5, 9, 5, 5}. The sequence of George's changes could have been: {5, 9, 5, 5} → {5, 5, 95} → {95, 55} → {9555}.  Originally array b could be equal to {1000000000, 5}. Please note that the array b cannot contain zeros.  Originally array b could be equal to {800, 10, 1}.  Originally array b could be equal to {45}. It cannot be equal to {4, 5}, because George can get only array {54} from this array in one operation. Note that the numbers can be very large.

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}

import Data.Char
import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Data.Array.IArray
import Debug.Trace
import Data.List (maximumBy)
import Data.Ord (comparing)
import Control.Monad (forM_)
import Text.Printf (printf)

debug :: Show a => String -> a -> a
debug label a = trace msg a
  where msg = "=== " ++ label ++ ": " ++ show a

debug2 :: Show a => String -> a -> b -> b
debug2 label a b = debug label a `seq` b

-- compare two substrings of a bytestring
cmpbs :: ByteString -> (Int,Int) -> (Int,Int) -> Ordering
-- cmpbs bs (alo,ahi) (blo,bhi) | debug2 "cmpbs" ((alo,ahi),(blo,bhi)) False = undefined
cmpbs bs (alo,ahi) (blo,bhi) =
  case (ahi-alo) `compare` (bhi-blo) of
    GT -> GT
    LT -> LT
    EQ -> cmpbs' bs alo ahi blo

-- compare two substrings of equal length
cmpbs' :: ByteString -> Int -> Int -> Int -> Ordering
cmpbs' bs ai ahi bi | ai > ahi = EQ
cmpbs' bs ai ahi bi =
  case (bs `BS.index` ai) `compare` (bs `BS.index` bi) of
    GT -> GT
    LT -> LT
    EQ -> cmpbs' bs (ai+1) ahi (bi+1)

bestSol :: ByteString -> Int -> Int -> [(Int,Int)]
bestSol bs lo hi | lo > hi = []
bestSol bs lo hi = [(k,hi)] ++ bestSol bs lo (k-1)
  where
    k' = head [ i | i <- [hi,hi-1..lo], BS.index bs i /= '0' ]
    k = if cmpbs bs (lo,k'-1) (k',hi) >= EQ then k' else lo

best :: ByteString -> Int -> Int -> Int
best bs lo hi = go hi 0
  where
    go hi a | hi < lo = a
    go hi a = go (k-1) (a+1)
      where
        k' = head [ i | i <- [hi,hi-1..lo], BS.index bs i /= '0' ]
        k = if cmpbs bs (lo,k'-1) (k',hi) >= EQ then k' else lo

(-->) = flip fmap

showBSSolution :: ByteString -> [(Int,Int)] -> IO ()
showBSSolution bs sols = do
  forM_ sols $ \(a,b) -> do
    putStrLn $ printf "%3d - %3d : %s" a b [ BS.index bs i | i <- [a..b] ]
  putStrLn $ printf "length: %d" (length sols)

main = do
  digits <- BS.getLine --> BS.filter isDigit
  let n = BS.length digits
  print $ best digits 0 (n-1)

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

solve :: ByteString -> Int
solve line = foldl loop 0 $ zip tok len
    where
    tok = C.groupBy (\_ i -> i == '0') line :: [ByteString]
    len = scanl (+) 0 $ map C.length tok :: [Int]

    loop :: Int -> (ByteString, Int) -> Int
    loop acc (a, k) = case k `compare` C.length a of
        GT -> 1 + acc
        LT -> 1
        EQ -> if C.take k line < a then 1 else 1 + acc

main = B.getLine >>= print . solve . C.init


Polycarpus has n markers and m marker caps. Each marker is described by two numbers: xi is the color and yi is the diameter. Correspondingly, each cap is described by two numbers: aj is the color and bj is the diameter. Cap (aj, bj) can close marker (xi, yi) only if their diameters match, that is, bj = yi. Besides, a marker is considered to be beautifully closed, if the cap color and the marker color match, that is, aj = xi.Find the way to close the maximum number of markers. If there are several such ways, then choose the one that has the maximum number of beautifully closed markers.

The first input line contains two space-separated integers n and m (1 ≤ n, m ≤ 105) — the number of markers and the number of caps, correspondingly.  Next n lines describe the markers. The i-th line contains two space-separated integers xi, yi (1 ≤ xi, yi ≤ 1000) — the i-th marker's color and diameter, correspondingly. Next m lines describe the caps. The j-th line contains two space-separated integers aj, bj (1 ≤ aj, bj ≤ 1000) — the color and diameter of the j-th cap, correspondingly.

Print two space-separated integers u, v, where u is the number of closed markers and v is the number of beautifully closed markers in the sought optimal way. Remember that you have to find the way to close the maximum number of markers, and if there are several such ways, you should choose the one where the number of beautifully closed markers is maximum.

NoteIn the first test sample the first marker should be closed by the fourth cap, the second marker should be closed by the first cap and the third marker should be closed by the second cap. Thus, three markers will be closed, and two of them will be beautifully closed — the first and the third markers.

import Array ((!), accumArray)
import Control.Monad (liftM)
import Data.IntMap (IntMap, intersectionWith, fold, fromListWith)

--------------------------------------------------------------------------------
{-
import HUnit

testInput :: Test
testInput  =  TestList "TestInput"
  [
    Test "1" $ assertEq (3,2) $ solve [(1,2), (3,4), (2,4)] [(5,4), (2,4), (1,1), (1,2)],
    Test "2" $ assertEq (1,0) $ solve [(1,2), (2,1)] [(3,4), (5,1)]
  ]

testManyEquals :: Test
testManyEquals  =  Test "TestManyEquals" $
    assertEq (n, n) $ solve
        [(1 + mod i maxN, 1 + mod i maxN) | i <- [1..n]]
        [(1 + mod i maxN, 1 + mod i maxN) | i <- [1..n]]
  where
    n  =  10^5

testManyEqualsDiametr :: Test
testManyEqualsDiametr  =  Test "TestManyEqualsDiametr" $
    assertEq (n, 0) $ solve
        [(1 + mod i maxN, 1 + mod i maxN) | i <- [1..n]]
        [(1 + mod (i+1) maxN, 1 + mod i maxN) | i <- [1..n]]
  where
    n  =  10^5

testMany :: Test
testMany  =  Test "TestMany" $
    assertEq (0, 0) $ solve
        [(1, 1 + mod (2*i + 1) maxN) | i <- [1..n]]
        [(1, 1 + mod (2*i) maxN) | i <- [1..n]]
  where
    n  =  10^5

test :: IO ()
test  =  mapM_ run
  [
    testInput,
    testManyEquals,
    testManyEqualsDiametr,
    testMany
  ]
-}
--------------------------------------------------------------------------------

maxN :: Int
maxN  =  1000

solve :: [(Int, Int)] -> [(Int, Int)] -> (Int, Int)
solve as bs  =  (countOneDiameter, countOneColor)
  where
    mapDCA  =  fromListWith (+) $ map (\(c, d) -> (c * maxN + d, 1)) as
    mapDCB  =  fromListWith (+) $ map (\(c, d) -> (c * maxN + d, 1)) bs
    mapDCAB  =  intersectionWith min mapDCA mapDCB
    countOneColor  =  fold (+) 0 mapDCAB
    asArray'  =  accumArray (+) 0 (1, maxN) [(b, 1) | (a,b) <- as]
    bsArray'  =  accumArray (+) 0 (1, maxN) [(b, 1) | (a,b) <- bs]
    countOneDiameter  =  sum [min (asArray' ! i) (bsArray' ! i) | i <- [1..maxN]]

readPair :: String -> (Int, Int)
readPair line  =  case map read (words line) of
    [a, b]  ->  (a, b)
    _  ->  undefined

main :: IO ()
main  =  do
    lines'  <-  liftM lines getContents
    let (n, m)  =  readPair $ head lines'
    let (as, bs)  =  splitAt n $ map readPair $ tail lines'
    let (c, d)  =  solve as bs
    putStrLn $ concat [show c, " ", show d]

import Data.List
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char
pairs (x:y:zs) = (y,x) : pairs zs
pairs _ = []
main = do
  (n:m:ns) <- liftM (unfoldr (B.readInt . B.dropWhile (not . isDigit))) B.getContents
  let (ms,cs) = splitAt (2*n) ns
      ms' = sort (pairs ms)
      cs' = sort (pairs cs)
  putStrLn $ show (commonBy fst ms' cs' 0) ++ " " ++
             show (commonBy id ms' cs' 0)
commonBy f (a:as) (b:bs) c | f a < f b = commonBy f as (b:bs) c
                           | f a > f b = commonBy f (a:as) bs c
                           | otherwise = commonBy f as bs $! c+1
commonBy _ _ _ c = c

import Data.List

minus as [] = as
minus [] _ = []
minus (a : as) (b : bs) = case compare a b of
  LT -> a : minus as (b : bs)
  EQ -> minus as bs
  GT -> minus (a : as) bs

f a b = (length a - length a', (a', b `minus` a)) where
  a' = a `minus` b

g(a,b)=case f a b of
  (n1, (a', b')) -> case f (map head a') (map head b') of
    (n2, _) -> [n1 + n2, n1]
j(a,b)=g(sort a,sort b)
s([_,n]:l)=j$splitAt n l
main=interact$unwords.map show.s.map(reverse.map(foldl(\a c->a*10+fromEnum c-fromEnum '0')0).words).lines