One day Vasya was on a physics practical, performing the task on measuring the capacitance. He followed the teacher's advice and did as much as n measurements, and recorded the results in the notebook. After that he was about to show the results to the teacher, but he remembered that at the last lesson, the teacher had made his friend Petya redo the experiment because the largest and the smallest results differed by more than two times. Vasya is lazy, and he does not want to redo the experiment. He wants to do the task and go home play computer games. So he decided to cheat: before Vasya shows the measurements to the teacher, he will erase some of them, so as to make the largest and the smallest results of the remaining measurements differ in no more than two times. In other words, if the remaining measurements have the smallest result x, and the largest result y, then the inequality y ≤ 2·x must fulfill. Of course, to avoid the teacher's suspicion, Vasya wants to remove as few measurement results as possible from his notes.Help Vasya, find what minimum number of measurement results he will have to erase from his notes so that the largest and the smallest of the remaining results of the measurements differed in no more than two times.

The first line contains integer n (2 ≤ n ≤ 105) — the number of measurements Vasya made. The second line contains n integers c1, c2, ..., cn (1 ≤ ci ≤ 5000) — the results of the measurements. The numbers on the second line are separated by single spaces.

Print a single integer — the minimum number of results Vasya will have to remove.

NoteIn the first sample you can remove the fourth and the sixth measurement results (values 8 and 7). Then the maximum of the remaining values will be 5, and the minimum one will be 3. Or else, you can remove the third and fifth results (both equal 3). After that the largest remaining result will be 8, and the smallest one will be 4.

import Data.Array ((!), accumArray, listArray, elems)

solve :: [Int] -> Int
solve cs  =  n - maximum [d ! (2*i) - d ! (i-1) | i <- [1 .. max `div` 2]]
  where
    n  =  length cs
    a  =  accumArray (+) 0 (1, max) $ [(c, 1) | c <- cs]
    d  =  listArray (0, max) $ scanl (+) 0 $ elems a
    max  =  5000

main :: IO ()
main  =  do
    content  <-  readFile "input.txt"
    let cs  =  tail $ map read $ words content
    writeFile "output.txt" $ show $ solve cs

{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import System.IO
import qualified Data.ByteString.Char8 as B
import Data.Array.Base
import Data.List

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

bSearch :: (Int -> Bool) -> Int -> Int -> Int
bSearch p !low !high
  | high<=low = low
  | p mid     = bSearch p mid high
  | otherwise = bSearch p low (mid-1)
   where
     mid = div (low+high+1) 2

main = do

  hin  <- openFile "input.txt"  ReadMode
  hout <- openFile "output.txt" WriteMode

  n <- read <$> hGetLine hin
  xs <- sort.map readInt.B.words <$> B.hGetContents hin
  hPrint hout $ n - solve n (listArray (0,n-1) xs)

  hClose hin
  hClose hout

solve :: Int -> UArray Int Int -> Int
solve n arr = maximum $ map f [0..n-1]
   where
     f i
       | unsafeAt arr (n-1) <= ai2 = n-1-i+1
       | otherwise = bSearch ((<=ai2).unsafeAt arr) i (n-1) - i+1
        where
          !ai2 = 2*unsafeAt arr i

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import Control.Monad
import System.IO
import qualified Data.ByteString.Char8 as B
import Data.Array.Base
import Data.List

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

bSearch :: (Int -> Bool) -> Int -> Int -> Int
bSearch p !low !high
  | high<=low = high
  | p mid     = bSearch p low mid
  | otherwise = bSearch p (mid+1) high
   where
     mid = quot (low+high) 2

main = do

  hin  <- openFile "input.txt"  ReadMode
  hout <- openFile "output.txt" WriteMode

  n <- read <$> hGetLine hin
  xs <- sort.map readInt.B.words <$> B.hGetContents hin
  hPrint hout $ n - solve n (listArray (0,n-1) xs)

  hClose hin
  hClose hout

solve :: Int -> UArray Int Int -> Int
solve n arr = maximum $ map f [0..n-1]
   where
     f i
       | unsafeAt arr (n-1) <= ai2 = n-1-i+1
       | otherwise = bSearch ((<=ai2).unsafeAt arr) i (n-1) - i+1
        where
          !ai2 = 2*unsafeAt arr i


This is the second subtask of problem F. The only differences between this and the first subtask are the constraints on the value of $$$m$$$ and the time limit. It is sufficient to solve this subtask in order to hack it, but you need to solve both subtasks in order to hack the first one.There are $$$n+1$$$ distinct colours in the universe, numbered $$$0$$$ through $$$n$$$. There is a strip of paper $$$m$$$ centimetres long initially painted with colour $$$0$$$. Alice took a brush and painted the strip using the following process. For each $$$i$$$ from $$$1$$$ to $$$n$$$, in this order, she picks two integers $$$0 \leq a_i < b_i \leq m$$$, such that the segment $$$[a_i, b_i]$$$ is currently painted with a single colour, and repaints it with colour $$$i$$$. Alice chose the segments in such a way that each centimetre is now painted in some colour other than $$$0$$$. Formally, the segment $$$[i-1, i]$$$ is painted with colour $$$c_i$$$ ($$$c_i \neq 0$$$). Every colour other than $$$0$$$ is visible on the strip.Count the number of different pairs of sequences $$$\{a_i\}_{i=1}^n$$$, $$$\{b_i\}_{i=1}^n$$$ that result in this configuration. Since this number may be large, output it modulo $$$998244353$$$.

The first line contains a two integers $$$n$$$, $$$m$$$ ($$$1 \leq n \leq 500$$$, $$$n \leq m \leq 10^6$$$) — the number of colours excluding the colour $$$0$$$ and the length of the paper, respectively. The second line contains $$$m$$$ space separated integers $$$c_1, c_2, \ldots, c_m$$$ ($$$1 \leq c_i \leq n$$$) — the colour visible on the segment $$$[i-1, i]$$$ after the process ends. It is guaranteed that for all $$$j$$$ between $$$1$$$ and $$$n$$$ there is an index $$$k$$$ such that $$$c_k = j$$$.

Output a single integer — the number of ways Alice can perform the painting, modulo $$$998244353$$$.

NoteIn the first example, there are $$$5$$$ ways, all depicted in the figure below. Here, $$$0$$$ is white, $$$1$$$ is red, $$$2$$$ is green and $$$3$$$ is blue.Below is an example of a painting process that is not valid, as in the second step the segment 1 3 is not single colour, and thus may not be repainted with colour $$$2$$$.In the second example, Alice must first paint segment 0 3 with colour $$$1$$$ and then segment 1 2 with colour $$$2$$$.

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM_)
import Control.Monad.ST (ST, runST)
import Control.Monad.State.Strict (State, evalState, get, modify, put)
import Data.Array.IArray ((!), listArray)
import Data.Array.MArray.Safe (newArray, readArray, writeArray)
import Data.Array.ST.Safe (STArray, STUArray)
import Data.Array.Unboxed (UArray)
import Data.Bits ((.|.), shiftL)
import Data.Char (ord)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap, (!?), empty, insert)
import Data.List (group)
import Data.Ratio (denominator, numerator)
import Data.Sequence
  ( Seq
  , Seq((:<|))
  , Seq((:|>))
  , Seq(Empty)
  , (><)
  , fromList
  , index
  , spanl
  , spanr
  , update
  )
import qualified Data.Sequence as S (length, replicate, splitAt)
import GHC.TypeNats (KnownNat, Nat, natVal)
import Numeric.Natural (Natural)

parseInt = foldl (\acc c -> acc * 10 + ord c - 48) 0

parseInts = fmap parseInt . words

newtype PrimeField (p :: Nat) =
  PrimeField Natural
  deriving (Eq)

char :: KnownNat p => PrimeField p -> Natural
char = natVal

instance KnownNat p => Show (PrimeField p) where
  show (PrimeField a) = show a

instance KnownNat p => Num (PrimeField p) where
  (+) x@(PrimeField a) (PrimeField b) =
    PrimeField $
    if a + b >= mm
      then a + b - mm
      else a + b
    where
      mm = char x
  (*) x@(PrimeField a) (PrimeField b) = PrimeField $ (a * b) `mod` mm
    where
      mm = char x
  fromInteger a = ret
    where
      mm = toInteger (char ret)
      ret = PrimeField . fromInteger . (`mod` mm) . (+ mm) . (`mod` mm) $ a
  negate x@(PrimeField a) =
    PrimeField $
    if a == 0
      then 0
      else mm - a
    where
      mm = char x
  abs = id
  signum _ = 1

instance KnownNat p => Fractional (PrimeField p) where
  recip x@(PrimeField a)
    | a == 0 = undefined
    | a == 1 = 1
    | otherwise = negate (PrimeField q) * recip (PrimeField r)
    where
      mm = char x
      (q, r) = mm `divMod` a
  fromRational =
    liftA2 (/) (fromInteger . numerator) (fromInteger . denominator)

type MField = PrimeField 998244353

type Hash = IntMap MField

data Node =
  Node
    { getIndex :: !Int
    , getValue :: !Int
    , getExt :: !Int
    }
  deriving (Show, Eq)

hash l r = l `shiftL` 10 .|. r

{-# INLINE hash #-}
mm = 998244353 :: Int64

madd :: Int64 -> Int64 -> Int64
madd a b
  | a + b < mm = a + b
  | otherwise = (a + b) - mm

{-# INLINE madd #-}
mmul :: Int64 -> Int64 -> Int64
mmul a b = a * b `mod` mm

{-# INLINE mmul #-}
search ::
     forall s.
     (UArray Int Int, UArray Int Int)
  -> STUArray s Int Int64
  -> (Int, Int)
  -> ST s ()
search (value, ext) mem (left, right) = do
  let hc = hash left right
      mlo =
        foldl
          (\mm i ->
             mm >>= \m ->
               if ext ! i >= right
                 then Nothing
                 else Just (min m (value ! i)))
          (Just (value ! left))
          [left .. right - 1]
  ret <-
    case mlo of
      Nothing -> return 0
      Just lo ->
        let loop f s i
              | f i = loop f s (s i)
              | otherwise = i
            findNext = loop ((/=) lo . (value !))
            !lp = findNext succ left
            !rp = findNext pred (right - 1)
            lov = single (lp, rp)
            access l r = readArray mem (hash l r)
            single (l, r)
              | l == r = return 1
              | value ! l == lo = single (l + 1, r)
              | otherwise = liftA2 mmul (access l l') (single (l', r))
              where
                l' = findNext succ l
            lv = match (left, lp)
            rv = match (rp + 1, right)
            match (l, r) =
              foldr
                (liftA2 madd)
                (return 0)
                [liftA2 mmul (access l m) (access m r) | m <- [l .. r]]
         in liftA2 mmul lov (liftA2 mmul lv rv)
  writeArray mem hc ret

solve :: Int -> [Int] -> Int64
solve n a = runST recur
  where
    a' = reverse (zip a [0 ..])
    es = evalState (mapM findNext a') (S.replicate (n + 1) (-1))
    findNext :: (Int, Int) -> State (Seq Int) Int
    findNext (v, i) = do
      next <- get
      let p = index next v
      put (update v i next)
      if p == -1
        then return i
        else return p
    m = length a
    value = listArray (0, m - 1) a :: UArray Int Int
    ext = listArray (0, m - 1) (reverse es) :: UArray Int Int
    recur :: forall s. ST s Int64
    recur = do
      mem <- newArray (0, 1 `shiftL` 20) 1 :: ST s (STUArray s Int Int64)
      sequence_
        [ search (value, ext) mem (left, left + len)
        | len <- [1 .. m]
        , left <- [0 .. m - len]
        ]
      readArray mem (hash 0 m)

main = do
  [n, m] <- fmap parseInts getLine
  a <- fmap parseInts getLine
  let a' = group a
  if length a' > 2 * n
    then print 0
    else print . solve n . fmap head $ a'

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM_)
import Control.Monad.State.Strict (State, evalState, get, modify, put)
import Data.Bits ((.|.), shiftL)
import Data.Char (ord)
import Data.IntMap.Strict (IntMap, (!?), empty, insert)
import Data.List (group)
import Data.Ratio (denominator, numerator)
import Data.Sequence
  ( Seq
  , Seq((:<|))
  , Seq((:|>))
  , Seq(Empty)
  , (><)
  , fromList
  , index
  , spanl
  , spanr
  , update
  )
import qualified Data.Sequence as S (length, replicate, splitAt)
import Data.Array.Unboxed (UArray)
import Data.Array.IArray (listArray, (!))
import GHC.TypeNats (KnownNat, Nat, natVal)
import Numeric.Natural (Natural)

parseInt = foldl (\acc c -> acc * 10 + ord c - 48) 0

parseInts = fmap parseInt . words

newtype PrimeField (p :: Nat) =
  PrimeField Natural
  deriving (Eq)

char :: KnownNat p => PrimeField p -> Natural
char = natVal

instance KnownNat p => Show (PrimeField p) where
  show (PrimeField a) = show a

instance KnownNat p => Num (PrimeField p) where
  (+) x@(PrimeField a) (PrimeField b) =
    PrimeField $
    if a + b >= mm
      then a + b - mm
      else a + b
    where
      mm = char x
  (*) x@(PrimeField a) (PrimeField b) = PrimeField $ (a * b) `mod` mm
    where
      mm = char x
  fromInteger a = ret
    where
      mm = toInteger (char ret)
      ret = PrimeField . fromInteger . (`mod` mm) . (+ mm) . (`mod` mm) $ a
  negate x@(PrimeField a) =
    PrimeField $
    if a == 0
      then 0
      else mm - a
    where
      mm = char x
  abs = id
  signum _ = 1

instance KnownNat p => Fractional (PrimeField p) where
  recip x@(PrimeField a)
    | a == 0 = undefined
    | a == 1 = 1
    | otherwise = negate (PrimeField q) * recip (PrimeField r)
    where
      mm = char x
      (q, r) = mm `divMod` a
  fromRational =
    liftA2 (/) (fromInteger . numerator) (fromInteger . denominator)

type MField = PrimeField 998244353

type Hash = IntMap MField

data Node =
  Node
    { getIndex :: !Int
    , getValue :: !Int
    , getExt :: !Int
    }
  deriving (Show, Eq)

hash l r = l `shiftL` 10 .|. r

{-# INLINE hash #-}
search :: (UArray Int Int, UArray Int Int) -> (Int, Int) -> State Hash MField
search (value, ext) (left, right) = search' (left, right)
  where
    search' :: (Int, Int) -> State Hash MField
    search' (!left, !right)
      | left == right = return 1
      | otherwise = do
      let hc = hash left right
      table <- get
      case table !? hc of
        Just v -> return v
        Nothing -> do
          let mlo =
                foldl
                  (\mm i ->
                     mm >>= \m ->
                       if ext ! i >= right
                         then Nothing
                         else Just (min m (value ! i)))
                  (Just (value ! left))
                  [left .. right - 1]
          ret <-
            case mlo of
              Nothing -> return 0
              Just lo ->
                let loop f s i
                      | f i = loop f s (s i)
                      | otherwise = i
                    findNext = loop ((/=) lo . (value !))
                    lp = findNext succ left
                    rp = findNext pred (right - 1)
                    lov = fmap product . mapM search' . seqGroup $ (lp, rp)
                    seqGroup (l, r)
                      | l == r = []
                      | value ! l == lo = seqGroup (l + 1, r)
                      | otherwise = (l, l') : seqGroup (l', r)
                      where
                        l' = findNext succ l
                    lv = match (left, left, lp)
                    rv = match (rp + 1, rp + 1, right)
                    match (l, m, r)
                      | m > r = return 0
                      | m == r = search' (l, m)
                      | otherwise =
                            let m' = (ext ! m) + 1
                             in liftA2
                                  (+)
                                  (liftA2 (*) (search' (l, m)) (search' (m, r)))
                                  (match (l, m', r))
                 in fmap product (sequence [lov, lv, rv])
          ret `seq` modify (insert hc ret)
          return ret

solve :: Int -> [Int] -> MField
solve n a = evalState (search (value, ext) (0, m)) empty
  where
    a' = reverse (zip a [0 ..])
    es = evalState (mapM findNext a') (S.replicate (n + 1) (-1))
    findNext :: (Int, Int) -> State (Seq Int) Int
    findNext (v, i) = do
      next <- get
      let p = index next v
      put (update v i next)
      if p == -1
        then return i
        else return p
    m = length a
    value = listArray (0, m - 1) a :: UArray Int Int
    ext = listArray (0, m - 1) (reverse es) :: UArray Int Int

main = do
  [n, m] <- fmap parseInts getLine
  a <- fmap parseInts getLine
  let a' = group a
  if length a' > 2 * n
    then print 0
    else print . solve n . fmap head $ a'

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM_)
import Control.Monad.ST (ST, runST)
import Control.Monad.State.Strict (State, evalState, get, modify, put)
import Data.Array.IArray ((!), listArray)
import Data.Array.MArray.Safe (newArray, readArray, writeArray)
import Data.Array.ST.Safe (STArray, STUArray)
import Data.Array.Unboxed (UArray)
import Data.Bits ((.|.), shiftL, shiftR)
import Data.Char (ord, isSpace)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap, (!?), empty, insert)
import Data.List (group)
import Data.Ratio (denominator, numerator)
import Data.Sequence
  ( Seq
  , Seq((:<|))
  , Seq((:|>))
  , Seq(Empty)
  , (><)
  , fromList
  , index
  , spanl
  , spanr
  , update
  )
import qualified Data.Sequence as S (length, replicate, splitAt)
import GHC.TypeNats (KnownNat, Nat, natVal)
import Numeric.Natural (Natural)
import qualified Data.ByteString.Char8 as BS (readInt, getContents, getLine, dropWhile)

parseInts s = parse id s []
  where
    parse r s = case BS.readInt (BS.dropWhile isSpace s) of
                  Nothing -> r
                  Just (i, s') -> parse (r . (i :)) s'

newtype PrimeField (p :: Nat) =
  PrimeField Natural
  deriving (Eq)

char :: KnownNat p => PrimeField p -> Natural
char = natVal

instance KnownNat p => Show (PrimeField p) where
  show (PrimeField a) = show a

instance KnownNat p => Num (PrimeField p) where
  (+) x@(PrimeField a) (PrimeField b) =
    PrimeField $
    if a + b >= mm
      then a + b - mm
      else a + b
    where
      mm = char x
  (*) x@(PrimeField a) (PrimeField b) = PrimeField $ (a * b) `mod` mm
    where
      mm = char x
  fromInteger a = ret
    where
      mm = toInteger (char ret)
      ret = PrimeField . fromInteger . (`mod` mm) . (+ mm) . (`mod` mm) $ a
  negate x@(PrimeField a) =
    PrimeField $
    if a == 0
      then 0
      else mm - a
    where
      mm = char x
  abs = id
  signum _ = 1

instance KnownNat p => Fractional (PrimeField p) where
  recip x@(PrimeField a)
    | a == 0 = undefined
    | a == 1 = 1
    | otherwise = negate (PrimeField q) * recip (PrimeField r)
    where
      mm = char x
      (q, r) = mm `divMod` a
  fromRational =
    liftA2 (/) (fromInteger . numerator) (fromInteger . denominator)

type MField = PrimeField 998244353

type Hash = IntMap MField

data Node =
  Node
    { getIndex :: !Int
    , getValue :: !Int
    , getExt :: !Int
    }
  deriving (Show, Eq)

hash l r = l `shiftL` 10 .|. r

{-# INLINE hash #-}
mm = 998244353 :: Int64

madd :: Int64 -> Int64 -> Int64
madd a b
  | a + b < mm = a + b
  | otherwise = (a + b) - mm

{-# INLINE madd #-}
mmul :: Int64 -> Int64 -> Int64
mmul a b = a * b `mod` mm

{-# INLINE mmul #-}
search ::
     forall s.
     (UArray Int Int, UArray Int Int)
  -> STUArray s Int Int64
  -> (Int, Int)
  -> ST s ()
search (value, ext) mem (left, right) = do
  let hc = hash left right
      mlo =
        foldl
          (\mm i ->
             mm >>= \m ->
               if ext ! i >= right
                 then Nothing
                 else Just (min m (value ! i)))
          (Just (value ! left))
          [left .. right - 1]
  ret <-
    case mlo of
      Nothing -> return 0
      Just lo ->
        let loop f s i
              | f i = loop f s (s i)
              | otherwise = i
            findNext = loop ((/=) lo . (value !))
            !lp = findNext succ left
            !rp = findNext pred (right - 1)
            lov = single (lp, rp)
            access l r = readArray mem (hash l r)
            single (l, r)
              | l == r = return 1
              | value ! l == lo = single (l + 1, r)
              | otherwise = liftA2 mmul (access l l') (single (l', r))
              where
                l' = findNext succ l
            lv = match (left, lp)
            rv = match (rp + 1, right)
            match (l, r) =
              foldr
                (liftA2 madd)
                (return 0)
                [liftA2 mmul (access l m) (access m r) | m <- [l .. r]]
         in liftA2 mmul lov (liftA2 mmul lv rv)
  writeArray mem hc ret

solve :: Int -> [Int] -> Int64
solve n a = runST recur
  where
    a' = reverse (zip a [0 ..])
    es = evalState (mapM findNext a') (S.replicate (n + 1) (-1))
    findNext :: (Int, Int) -> State (Seq Int) Int
    findNext (v, i) = do
      next <- get
      let p = index next v
      put (update v i next)
      if p == -1
        then return i
        else return p
    m = length a
    value = listArray (0, m - 1) a :: UArray Int Int
    ext = listArray (0, m - 1) (reverse es) :: UArray Int Int
    recur :: forall s. ST s Int64
    recur = do
      mem <- newArray (0, 1 `shiftL` 20) 1 :: ST s (STUArray s Int Int64)
      sequence_
        [ search (value, ext) mem (left, left + len)
        | len <- [1 .. m]
        , left <- [0 .. m - len]
        ]
      readArray mem (hash 0 m)

main = do
  [n, m] <- fmap parseInts BS.getLine
  a <- fmap parseInts BS.getLine
  let a' = group a
  if length a' > 2 * n
    then print 0
    else print . solve n . fmap head $ a'

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM_)
import Control.Monad.ST (ST, runST)
import Control.Monad.State.Strict (State, evalState, get, modify, put)
import Data.Array.IArray ((!), listArray)
import Data.Array.MArray.Safe (newArray, readArray, writeArray)
import Data.Array.ST.Safe (STArray, STUArray)
import Data.Array.Unboxed (UArray)
import Data.Bits ((.|.), shiftL)
import Data.Char (ord, isSpace)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap, (!?), empty, insert)
import Data.List (group)
import Data.Ratio (denominator, numerator)
import Data.Sequence
  ( Seq
  , Seq((:<|))
  , Seq((:|>))
  , Seq(Empty)
  , (><)
  , fromList
  , index
  , spanl
  , spanr
  , update
  )
import qualified Data.Sequence as S (length, replicate, splitAt)
import GHC.TypeNats (KnownNat, Nat, natVal)
import Numeric.Natural (Natural)
import qualified Data.ByteString.Char8 as BS (readInt, getContents, getLine, dropWhile)

parseInts s = parse id s []
  where
    parse r s = case BS.readInt (BS.dropWhile isSpace s) of
                  Nothing -> r
                  Just (i, s') -> parse (r . (i :)) s'

newtype PrimeField (p :: Nat) =
  PrimeField Natural
  deriving (Eq)

char :: KnownNat p => PrimeField p -> Natural
char = natVal

instance KnownNat p => Show (PrimeField p) where
  show (PrimeField a) = show a

instance KnownNat p => Num (PrimeField p) where
  (+) x@(PrimeField a) (PrimeField b) =
    PrimeField $
    if a + b >= mm
      then a + b - mm
      else a + b
    where
      mm = char x
  (*) x@(PrimeField a) (PrimeField b) = PrimeField $ (a * b) `mod` mm
    where
      mm = char x
  fromInteger a = ret
    where
      mm = toInteger (char ret)
      ret = PrimeField . fromInteger . (`mod` mm) . (+ mm) . (`mod` mm) $ a
  negate x@(PrimeField a) =
    PrimeField $
    if a == 0
      then 0
      else mm - a
    where
      mm = char x
  abs = id
  signum _ = 1

instance KnownNat p => Fractional (PrimeField p) where
  recip x@(PrimeField a)
    | a == 0 = undefined
    | a == 1 = 1
    | otherwise = negate (PrimeField q) * recip (PrimeField r)
    where
      mm = char x
      (q, r) = mm `divMod` a
  fromRational =
    liftA2 (/) (fromInteger . numerator) (fromInteger . denominator)

type MField = PrimeField 998244353

type Hash = IntMap MField

data Node =
  Node
    { getIndex :: !Int
    , getValue :: !Int
    , getExt :: !Int
    }
  deriving (Show, Eq)

hash l r = l `shiftL` 10 .|. r

{-# INLINE hash #-}
mm = 998244353 :: Int64

madd :: Int64 -> Int64 -> Int64
madd a b
  | a + b < mm = a + b
  | otherwise = (a + b) - mm

{-# INLINE madd #-}
mmul :: Int64 -> Int64 -> Int64
mmul a b = a * b `mod` mm

{-# INLINE mmul #-}
search ::
     forall s.
     (UArray Int Int, UArray Int Int)
  -> STUArray s Int Int64
  -> (Int, Int)
  -> ST s ()
search (value, ext) mem (left, right) = do
  let hc = hash left right
      mlo =
        foldl
          (\mm i ->
             mm >>= \m ->
               if ext ! i >= right
                 then Nothing
                 else Just (min m (value ! i)))
          (Just (value ! left))
          [left .. right - 1]
  ret <-
    case mlo of
      Nothing -> return 0
      Just lo ->
        let loop f s i
              | f i = loop f s (s i)
              | otherwise = i
            findNext = loop ((/=) lo . (value !))
            !lp = findNext succ left
            !rp = findNext pred (right - 1)
            lov = single (lp, rp)
            access l r = readArray mem (hash l r)
            single (l, r)
              | l == r = return 1
              | value ! l == lo = single (l + 1, r)
              | otherwise = liftA2 mmul (access l l') (single (l', r))
              where
                l' = findNext succ l
            lv = match (left, lp)
            rv = match (rp + 1, right)
            match (l, r) =
              foldr
                (liftA2 madd)
                (return 0)
                [liftA2 mmul (access l m) (access m r) | m <- [l .. r]]
         in liftA2 mmul lov (liftA2 mmul lv rv)
  writeArray mem hc ret

solve :: Int -> [Int] -> Int64
solve n a = runST recur
  where
    a' = reverse (zip a [0 ..])
    es = evalState (mapM findNext a') (S.replicate (n + 1) (-1))
    findNext :: (Int, Int) -> State (Seq Int) Int
    findNext (v, i) = do
      next <- get
      let p = index next v
      put (update v i next)
      if p == -1
        then return i
        else return p
    m = length a
    value = listArray (0, m - 1) a :: UArray Int Int
    ext = listArray (0, m - 1) (reverse es) :: UArray Int Int
    recur :: forall s. ST s Int64
    recur = do
      mem <- newArray (0, 1 `shiftL` 20) 1 :: ST s (STUArray s Int Int64)
      sequence_
        [ search (value, ext) mem (left, left + len)
        | len <- [1 .. m]
        , left <- [0 .. m - len]
        ]
      readArray mem (hash 0 m)

main = do
  [n, m] <- fmap parseInts BS.getLine
  a <- fmap parseInts BS.getContents
  let a' = group a
  if length a' > 2 * n
    then print 0
    else print . solve n . fmap head $ a'

{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Applicative (liftA2)
import Control.Monad (replicateM_)
import Control.Monad.ST (ST, runST)
import Control.Monad.State.Strict (State, evalState, get, modify, put)
import Data.Array.IArray ((!), listArray)
import Data.Array.MArray.Safe (newArray, readArray, writeArray)
import Data.Array.ST.Safe (STArray, STUArray)
import Data.Array.Unboxed (UArray)
import Data.Bits ((.|.), shiftL)
import Data.Char (ord)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap, (!?), empty, insert)
import Data.List (group)
import Data.Ratio (denominator, numerator)
import Data.Sequence
  ( Seq
  , Seq((:<|))
  , Seq((:|>))
  , Seq(Empty)
  , (><)
  , fromList
  , index
  , spanl
  , spanr
  , update
  )
import qualified Data.Sequence as S (length, replicate, splitAt)
import GHC.TypeNats (KnownNat, Nat, natVal)
import Numeric.Natural (Natural)

parseInt = foldl (\acc c -> acc * 10 + ord c - 48) 0

parseInts = fmap parseInt . words

newtype PrimeField (p :: Nat) =
  PrimeField Natural
  deriving (Eq)

char :: KnownNat p => PrimeField p -> Natural
char = natVal

instance KnownNat p => Show (PrimeField p) where
  show (PrimeField a) = show a

instance KnownNat p => Num (PrimeField p) where
  (+) x@(PrimeField a) (PrimeField b) =
    PrimeField $
    if a + b >= mm
      then a + b - mm
      else a + b
    where
      mm = char x
  (*) x@(PrimeField a) (PrimeField b) = PrimeField $ (a * b) `mod` mm
    where
      mm = char x
  fromInteger a = ret
    where
      mm = toInteger (char ret)
      ret = PrimeField . fromInteger . (`mod` mm) . (+ mm) . (`mod` mm) $ a
  negate x@(PrimeField a) =
    PrimeField $
    if a == 0
      then 0
      else mm - a
    where
      mm = char x
  abs = id
  signum _ = 1

instance KnownNat p => Fractional (PrimeField p) where
  recip x@(PrimeField a)
    | a == 0 = undefined
    | a == 1 = 1
    | otherwise = negate (PrimeField q) * recip (PrimeField r)
    where
      mm = char x
      (q, r) = mm `divMod` a
  fromRational =
    liftA2 (/) (fromInteger . numerator) (fromInteger . denominator)

type MField = PrimeField 998244353

type Hash = IntMap MField

data Node =
  Node
    { getIndex :: !Int
    , getValue :: !Int
    , getExt :: !Int
    }
  deriving (Show, Eq)

hash l r = l `shiftL` 10 .|. r

{-# INLINE hash #-}
mm = 998244353 :: Int64

madd :: Int64 -> Int64 -> Int64
madd a b
  | a + b < mm = a + b
  | otherwise = (a + b) - mm

{-# INLINE madd #-}
mmul :: Int64 -> Int64 -> Int64
mmul a b = a * b `mod` mm

{-# INLINE mmul #-}
search ::
     forall s.
     (UArray Int Int, UArray Int Int)
  -> STUArray s Int Int64
  -> (Int, Int)
  -> ST s ()
search (value, ext) mem (left, right)
  | left == right = return ()
  | otherwise = do
    let hc = hash left right
        mlo =
          foldl
            (\mm i ->
               mm >>= \m ->
                 if ext ! i >= right
                   then Nothing
                   else Just (min m (value ! i)))
            (Just (value ! left))
            [left .. right - 1]
    ret <-
      case mlo of
        Nothing -> return 0
        Just lo ->
          let loop f s i
                | f i = loop f s (s i)
                | otherwise = i
              findNext = loop ((/=) lo . (value !))
              !lp = findNext succ left
              !rp = findNext pred (right - 1)
              lov = single (lp, rp)
              single (l, r)
                | l == r = return 1
                | value ! l == lo = single (l + 1, r)
                | otherwise =
                  liftA2 mmul (readArray mem (hash l l')) (single (l', r))
                where
                  l' = findNext succ l
              lv = match (left, left, lp)
              rv = match (rp + 1, rp + 1, right)
              match (l, m, r)
                | m > r = return 0
                | m == r = readArray mem (hash l m)
                | otherwise =
                  let m' = (ext ! m) + 1
                   in liftA2
                        madd
                        (liftA2
                           mmul
                           (readArray mem (hash l m))
                           (readArray mem (hash m r)))
                        (match (l, m', r))
           in liftA2 mmul lov (liftA2 mmul lv rv)
    writeArray mem hc ret

solve :: Int -> [Int] -> Int64
solve n a = runST recur
  where
    a' = reverse (zip a [0 ..])
    es = evalState (mapM findNext a') (S.replicate (n + 1) (-1))
    findNext :: (Int, Int) -> State (Seq Int) Int
    findNext (v, i) = do
      next <- get
      let p = index next v
      put (update v i next)
      if p == -1
        then return i
        else return p
    m = length a
    value = listArray (0, m - 1) a :: UArray Int Int
    ext = listArray (0, m - 1) (reverse es) :: UArray Int Int
    recur :: forall s. ST s Int64
    recur = do
      mem <- newArray (0, 1 `shiftL` 20) 1 :: ST s (STUArray s Int Int64)
      sequence_
        [ search (value, ext) mem (left, left + len)
        | len <- [1 .. m]
        , left <- [0 .. m - len]
        ]
      readArray mem (hash 0 m)

main = do
  [n, m] <- fmap parseInts getLine
  a <- fmap parseInts getLine
  let a' = group a
  if length a' > 2 * n
    then print 0
    else print . solve n . fmap head $ a'


There are one cat, $$$k$$$ mice, and one hole on a coordinate line. The cat is located at the point $$$0$$$, the hole is located at the point $$$n$$$. All mice are located between the cat and the hole: the $$$i$$$-th mouse is located at the point $$$x_i$$$ ($$$0 < x_i < n$$$). At each point, many mice can be located.In one second, the following happens. First, exactly one mouse moves to the right by $$$1$$$. If the mouse reaches the hole, it hides (i.e. the mouse will not any more move to any point and will not be eaten by the cat). Then (after that the mouse has finished its move) the cat moves to the right by $$$1$$$. If at the new cat's position, some mice are located, the cat eats them (they will not be able to move after that). The actions are performed until any mouse hasn't been hidden or isn't eaten.In other words, the first move is made by a mouse. If the mouse has reached the hole, it's saved. Then the cat makes a move. The cat eats the mice located at the pointed the cat has reached (if the cat has reached the hole, it eats nobody).Each second, you can select a mouse that will make a move. What is the maximum number of mice that can reach the hole without being eaten?

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Then $$$t$$$ test cases follow. Each test case consists of two lines. The first line contains two integers $$$n$$$ and $$$k$$$ ($$$2 \le n \le 10^9$$$, $$$1 \le k \le 4 \cdot 10^5$$$). The second line contains $$$k$$$ integers $$$x_1, x_2, \dots x_k$$$ ($$$1 \le x_i < n$$$) — the initial coordinates of the mice. It is guaranteed that the sum of all $$$k$$$ given in the input doesn't exceed $$$4 \cdot 10^5$$$.

For each test case output on a separate line an integer $$$m$$$ ($$$m \ge 0$$$) — the maximum number of mice that can reach the hole without being eaten.

--
-- Michael V. Antosha
-- 2021
-- Michael.Antosha@gmail.com
--

{-# language NoMonomorphismRestriction #-}

{-# options_ghc -Weverything                     #-}

{-# options_ghc -Wno-safe                        #-}     -- no warning if inferred as safe
{-# options_ghc -Wno-all-missed-specialisations  #-}     -- "Could not specialise..." when -O1
{-# options_ghc -Wno-missing-import-lists        #-}
{-# options_ghc -Wno-missing-local-signatures    #-}

-- (ghc -Werror -O1 -rtsopts -o a.out *.hs  &&  set -o pipefail  &&  cat -- input.txt | ./a.out > temp.txt  &&  diff -sdu -- output.txt temp.txt)  &&  echo OKAY  ||  echo ERROR

import Prelude
import Control.Monad
import Data.List

main :: IO ()
main = do
    t <- readLn
    tcs <- replicateM t readTC

    (putStr . unlines . map solve) tcs

readTC = do
    [n, _k]    <- readListLn
    miceCoords <- readListLn
    return (n, miceCoords)

readListLn = map read <$> words <$> getLine  :: IO [Integer]

solve (n, xs) = show . length . takeWhile (<n) . scanl1 (+) . sort . map (n-) $ xs

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

getInput :: IO (Int, [Int])
getInput = do
    first_line <- getLine
    second_line <- getLine
    let n = (map read (words first_line)) !! 0
        ms = map read (words second_line)
    return (n, sort ms)

maxNoOfMice :: (Int, [Int]) -> Int
maxNoOfMice (n, ms) =
    let costs = sort $ map (n -) ms
        (c, _) = foldl countSteps (0, 0) costs
     in c
        where countSteps (count, total) x =
                if total + x < n then (count + 1, total + x) else (count, total)

main :: IO ()
main = do
    num_of_inputs <- getLine
    list_of_inputs <- replicateM (read num_of_inputs) getInput
    let ans = map maxNoOfMice list_of_inputs
    traverse_ (putStrLn . show) ans

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

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

data TC = TC {n :: Int, xs :: [Int]}

input :: Scanner TC
input = do
  n <- int
  xs <- numberOf int
  return TC {..}

output = showB

solve :: TC -> Int
solve TC {..} = length . takeWhile (< n) . scanl1 (+) . sort . map (n - ) $ xs

-------------------------- 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 Data.Function (on)
import Data.List

-- code --

data Task = Task { n      :: Int
                 , k      :: Int
                 , points :: [Int]
                 } deriving (Show)

data Answer = Answer {num :: Int}

biteTask :: String -> (Task, String)
biteTask str = let line1:line2:_ = lines str
                   [n,k] = map read $ words line1
                   points = map read $ words line2
                   in (Task {n=n, k=k, points=points}, dropLines 2 str)

showAns :: Answer -> String
showAns Answer {num = ans} = show ans

solve_task :: Task -> Answer
solve_task Task { n=n
                , points = points
                } = let dist_list = sort $ map (n-) points
                        runaway = 0 : scanl1 (+) dist_list
                        saved = takeWhile (\(acc,x) -> n - acc > x) $ zip runaway dist_list
                        in Answer { num = length saved }

-- //// --

yesNo False = "NO"
yesNo True = "YES"

readInt :: String -> Int
readInt = read

readBigInt :: String -> Integer
readBigInt = read

dropLines _ ""        = ""
dropLines 0 text      = text
dropLines n ('\n':xs) = dropLines (n-1) xs
dropLines n (x:xs)    = dropLines n xs

type Tasks = [Task]
type Answers = [Answer]

readTasks :: String -> Tasks
readTasks ""    = []
readTasks input = let (task, input') = biteTask input
                      in task : readTasks input'

showAnswers :: Answers -> String
showAnswers [] = ""
showAnswers (ans : anss) = showAns ans ++ "\n" ++ showAnswers anss

solve :: String -> String
solve = showAnswers . map solve_task . readTasks . dropLines 1

main = interact solve

import Control.Monad (replicateM_, forM_, forM)
import Data.List (sort)

nextList :: IO [Int]
nextList = map read.words <$> getLine

go :: [Int] -> Int -> Int
go [] _ = 0
go (a : as) x = if a > x then 0 else go as (x - a) + 1

solve = do
    [n, k] <- nextList
    a <- nextList
    print $ go (sort $ map (n -) a) (n - 1)

main = do
    [t] <- nextList
    replicateM_ t solve


The Looksery company, consisting of n staff members, is planning another big party. Every employee has his phone number and the phone numbers of his friends in the phone book. Everyone who comes to the party, sends messages to his contacts about how cool it is. At the same time everyone is trying to spend as much time on the fun as possible, so they send messages to everyone without special thinking, moreover, each person even sends a message to himself or herself.Igor and Max, Looksery developers, started a dispute on how many messages each person gets. Igor indicates n numbers, the i-th of which indicates how many messages, in his view, the i-th employee is going to take. If Igor guesses correctly at least one of these numbers, he wins, otherwise Max wins.You support Max in this debate, so you need, given the contact lists of the employees, to determine whether there is a situation where Igor loses. Specifically, you need to determine which employees should come to the party, and which should not, so after all the visitors send messages to their contacts, each employee received a number of messages that is different from what Igor stated.

The first line contains a single integer n (1 ≤ n ≤ 100) — the number of employees of company Looksery. Next n lines contain the description of the contact lists of the employees. The i-th of these lines contains a string of length n, consisting of digits zero and one, specifying the contact list of the i-th employee. If the j-th character of the i-th string equals 1, then the j-th employee is in the i-th employee's contact list, otherwise he isn't. It is guaranteed that the i-th character of the i-th line is always equal to 1. The last line contains n space-separated integers: a1, a2, ..., an (0 ≤ ai ≤ n), where ai represents the number of messages that the i-th employee should get according to Igor.

In the first line print a single integer m — the number of employees who should come to the party so that Igor loses the dispute. In the second line print m space-separated integers — the numbers of these employees in an arbitrary order. If Igor wins the dispute in any case, print -1. If there are multiple possible solutions, print any of them.

NoteIn the first sample Igor supposes that the first employee will receive 0 messages. Since he isn't contained in any other contact list he must come to the party in order to receive one message from himself. If he is the only who come to the party then he will receive 1 message, the second employee will receive 0 messages and the third will also receive 1 message. Thereby Igor won't guess any number.In the second sample if the single employee comes to the party he receives 1 message and Igor wins, so he shouldn't do it.In the third sample the first employee will receive 2 messages, the second — 3, the third — 2, the fourth — 3.

{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Char
import Data.List

type Input  = ([[Int]], [Int])
type Output = [Int]

parse :: [String] -> Input
parse = evalState $ do
        n <- read   <$> readLine
        g <- parseG <$> replicateM n readLine
        d <- parseD <$> readLine
        return (g, d)
        where readLine = state (head &&& tail)
              parseG   = map (map (\c -> ord c - 48))
              parseD   = map read . words

solve :: Input -> Output
solve (g, d) = sort (foo d)
               where foo a = case elemIndex 0 a of
                                 Nothing -> []
                                 Just i  -> i : foo (zipWith (-) a (g !! i))

pprint :: Output -> IO ()
pprint a = putStr (unlines ls)
           where ls = [show (length a), unwords (map (show . (+1)) a)]

main :: IO ()
main = pprint . solve . parse . lines =<< getContents

-- {{{ A minimal State Monad
class (Monad m) => MonadState s m | m -> s where
    get :: m s
    put :: s -> m ()

-- modify :: (MonadState s m) => (s -> s) -> m ()
-- modify f = do
--  s <- get
--  put (f s)
--
-- gets :: (MonadState s m) => (s -> a) -> m a
-- gets f = do
--  s <- get
--  return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
    fmap f m = State $ \s -> let
        (a, s') = runState m s
        in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

instance Monad (State s) where
    return a = State $ \s -> (a, s)
    m >>= k  = State $ \s -> let
        (a, s') = runState m s
        in runState (k a) s'

instance MonadState s (State s) where
    get   = State $ \s -> (s, s)
    put s = State $ const ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

-- execState :: State s a -> s -> s
-- execState m s = snd (runState m s)
--
-- mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
-- mapState f m = State $ f . runState m
--
-- withState :: (s -> s) -> State s a -> State s a
-- withState f m = State $ runState m . f

state :: (s -> (a, s)) -> State s a
state = State
-- }}}

{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Char
import Data.List

type Input  = ([[Int]], [Int])
type Output = [Int]

parse :: [String] -> Input
parse = evalState $ do
        n <- read   <$> readLine
        g <- parseG <$> replicateM n readLine
        d <- parseD <$> readLine
        return (g, d)
        where readLine = state (head &&& tail)
              parseG   = map (map (\c -> ord c - 48))
              parseD   = map read . words

solve :: Input -> Output
solve (g, d) = sort (foo d)
               where foo a = case findIndex (== 0) a of
                                 Nothing -> []
                                 Just i  -> i : foo (zipWith (-) a (g !! i))

pprint :: Output -> IO ()
pprint a = putStr (unlines ls)
           where ls = [show (length a), unwords (map (show . (+1)) a)]

main :: IO ()
main = pprint . solve . parse . lines =<< getContents

-- {{{ A minimal State Monad
class (Monad m) => MonadState s m | m -> s where
    get :: m s
    put :: s -> m ()

-- modify :: (MonadState s m) => (s -> s) -> m ()
-- modify f = do
--  s <- get
--  put (f s)
--
-- gets :: (MonadState s m) => (s -> a) -> m a
-- gets f = do
--  s <- get
--  return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
    fmap f m = State $ \s -> let
        (a, s') = runState m s
        in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

instance Monad (State s) where
    return a = State $ \s -> (a, s)
    m >>= k  = State $ \s -> let
        (a, s') = runState m s
        in runState (k a) s'

instance MonadState s (State s) where
    get   = State $ \s -> (s, s)
    put s = State $ const ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

-- execState :: State s a -> s -> s
-- execState m s = snd (runState m s)
--
-- mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
-- mapState f m = State $ f . runState m
--
-- withState :: (s -> s) -> State s a -> State s a
-- withState f m = State $ runState m . f

state :: (s -> (a, s)) -> State s a
state = State
-- }}}

{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}

import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Debug.Trace

type Input  = ([[Int]], [Int])
type Output = [Int]

parse :: [String] -> Input
parse = evalState $ do
        n <- read   <$> readLine
        g <- parseG <$> replicateM n readLine
        d <- parseD <$> readLine
        return (g, d)
        where readLine = state (head &&& tail)
              parseG   = map (map (\c -> ord c - 48))
              parseD   = map read . words

solve :: Input -> Output
solve (g, d) = sort (foo d)
               where foo a = case find (== 0) a of
                                 Nothing -> []
                                 Just i  -> i : foo (zipWith (-) a (g !! i))

pprint :: Output -> IO ()
pprint a = putStr (unlines ls)
           where ls = [show (length a), unwords (map (show . (+1)) a)]

main :: IO ()
main = pprint . solve . parse . lines =<< getContents

-- {{{ A minimal State Monad
class (Monad m) => MonadState s m | m -> s where
    get :: m s
    put :: s -> m ()

-- modify :: (MonadState s m) => (s -> s) -> m ()
-- modify f = do
--  s <- get
--  put (f s)
--
-- gets :: (MonadState s m) => (s -> a) -> m a
-- gets f = do
--  s <- get
--  return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
    fmap f m = State $ \s -> let
        (a, s') = runState m s
        in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

instance Monad (State s) where
    return a = State $ \s -> (a, s)
    m >>= k  = State $ \s -> let
        (a, s') = runState m s
        in runState (k a) s'

instance MonadState s (State s) where
    get   = State $ \s -> (s, s)
    put s = State $ const ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

-- execState :: State s a -> s -> s
-- execState m s = snd (runState m s)
--
-- mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
-- mapState f m = State $ f . runState m
--
-- withState :: (s -> s) -> State s a -> State s a
-- withState f m = State $ runState m . f

state :: (s -> (a, s)) -> State s a
state = State
-- }}}


Print the word "YES" if the body is in equilibrium, or the word "NO" if it is not.

import Control.Monad

data Answer = YES | NO deriving (Show)

zeroVector :: [Integer]
zeroVector = [0, 0, 0]

isBalanced :: [[Integer]] -> [Integer]
isBalanced [] = [0, 0, 0]
isBalanced (first:rest) = add first (isBalanced rest)

add :: [Integer] -> [Integer] -> [Integer]
add [a, b, c] [x, y, z] = [a+x, b+y, c+z]
add list anotherList = [0, 0, 0]

getLines :: Int -> IO [String]
getLines t = replicateM t getLine

toNumbers :: [String] -> [[Integer]]
toNumbers [] = []
toNumbers (first:rest) = [(map read (words first))] ++ (toNumbers rest)

getAnswer :: [String] -> Answer
getAnswer list = if isBalanced (toNumbers list) == zeroVector
                 then YES
                 else NO

main :: IO ()
main = do
  n <- getLine
  list <- getLines (read n)
  print (getAnswer list)

import Control.Monad
import Control.Applicative

main = do
  n <- readLn :: IO Int
  points <- map (map read . words) <$>  replicateM n getLine :: IO [[Int]]
  let ans = foldr (\p1 p2 -> zipWith (+) p1 p2) [0,0,0] points
  putStrLn $ if all (==0) ans then "YES" else "NO"

module Main (main)
    where

import Data.List (foldl1')
import Control.Monad (replicateM)

readInts :: String -> [Int]
readInts = map read . words

main :: IO ()
main = putStrLn . check . map readInts =<< flip replicateM getLine =<< readLn
    where check = toYesNo . all (==0) . foldl1' (zipWith (+))
          toYesNo True  = "YES"
          toYesNo False = "NO"

module Main where

import Control.Monad
import Data.List

main = do
    n <- read `liftM` getLine
    final <- foldl' (\acc' _ -> do
            acc <- acc'
            v <- ( map read . words ) `liftM` getLine
            return $ zipWith (+) acc v
        ) (return [0, 0, 0]) [1..n]

    putStrLn $ if final == [0, 0, 0]
        then "YES"
        else "NO"

main = do
	n<-getLine
	rest<-getContents
	let v =map (map read)  $ map words $ lines rest
	if solve v 0 0 0 == [0,0,0] then putStrLn "YES" else putStrLn "NO"

solve [] xc yc zc = [xc,yc,zc]
solve ([x,y,z]:rest) xc yc zc = solve rest (xc+x) (yc+y) (zc+z)

module Main where

solve :: [[Int]] -> String
solve l = if x == 0 && y == 0 && z == 0 then "YES" else "NO" where
    x = sum $ map (!! 0) l
    y = sum $ map (!! 1) l
    z = sum $ map (!! 2) l

main = do
    n <- getLine
    forces <- getContents
    putStrLn $ solve $ map ((map read).words) $ lines forces

getLines :: Int -> IO [String]
getLines 0 = return []
getLines n = do
	x <- getLine
	xs <- getLines $ n-1
	return (x:xs)

main = do
	n <- getLine >>= return.read :: IO Int
	xyzs <- getLines n >>= return . (map $ map read . words) :: IO [[Int]]
	putStrLn $ if foldl (\[x,y,z] [xx,yy,zz] -> [x+xx, y+yy, z+zz]) [0,0,0] xyzs == [0,0,0] then "YES" else "NO"

sumelems ff a b c
  | (null ff) = if a == 0 && b == 0 && c == 0
                then True
                else False
  | otherwise = sumelems (tail ff)
    (a + (read (head (words (head ff))))::Int)
    (b + (read (head (drop 1 (words (head ff)))))::Int)
    (c + (read (head (drop 2 (words (head ff)))))::Int)

main = do
  ww <- getLine
  let yy = replicate ((read ww)::Int) getLine

  aa <- sequence yy
  let bb = sumelems aa 0 0 0
  if bb
    then putStrLn "YES"
    else putStrLn "NO"

import Control.Monad
import Data.List

-- Snippet: readItems
readItems = do
    line <- getLine
    return $ map read $ words line

main = do
    n <- readLn
    a <- replicateM n $ readItems
    putStrLn $ if all (== 0) $ map sum $ transpose a then "YES" else "NO"

import Data.List
main = interact $ (\x -> if x == True then "YES" else "NO") . all (== 0) . foldl1 (zipWith (+)) . map (map read . words) . tail . lines

import Data.List
import Control.Monad

parseVector :: String -> [Int]
parseVector s = map (read :: String -> Int) . words $ s

main = do
    nl <- getLine
    let n = (read :: String -> Int) nl
    vectorStrings <- replicateM n getLine
    let vectors = map parseVector vectorStrings

    putStrLn (if (all (== 0) . map sum . transpose $ vectors) then "YES" else "NO")

main = interact $f.tail.words

f inp = (fadd (unzip3 (parse (map read inp :: [Integer]))))
parse [] = []
parse (x:y:z:xs) = (x, y, z):parse xs

fadd (a, b, c)
  | 0 == sum a && 0 == sum a && 0 == sum a = "YES"
  | otherwise = "NO"

main = do
    getLine
    ts <- fmap (map (map read . words) . lines) getContents

    let s = foldl1 (\[a, b, c] [d, e, f] -> [a+d, b+e, c+f]) ts
    putStrLn $ if s == [0, 0, 0] then "YES" else "NO"

import Control.Monad (replicateM)
import Data.List (foldl')

(-->) = flip fmap

addTriple :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)
addTriple (a,b,c) (x,y,z) = (a+x,b+y,c+z)

sumTriples :: Num a => [(a,a,a)] -> (a,a,a)
sumTriples = foldl' addTriple (0,0,0)

readTriple :: (Num a, Read a) => IO (a,a,a)
readTriple = do
  (a:b:c:_) <- getLine --> words --> map read
  return (a,b,c)

main = do
  n <- getLine --> read
  (a,b,c) <- (replicateM n readTriple) --> sumTriples
  let _ = a :: Int
  if (a == 0 && b == 0 && c == 0)
    then putStrLn "YES"
    else putStrLn "NO"

import Control.Monad

(|>) x f = f x

main = do
    l1 <- getLine
    vecs <- replicateM (read l1) getLine
    let vectors = vecs |> map words |> map (map read) :: [[Int]]
    if solve vectors then
        putStrLn "YES"
    else
        putStrLn "NO"

solve vectors = sumNth vectors 0 == 0
    && sumNth vectors 1 == 0
    && sumNth vectors 2 == 0

sumNth vectors n = vectors |> map (\x -> x !! n) |> sum

import List
main = interact (s.lines)
s (sn:xs) = if (foldl1 (zipWith (+)) $ map ((map read).words) xs)==[0,0,0] then "YES" else "NO"

main :: IO ()
main = do cs <- getContents
          let nums = map read $ words cs
              n    = head nums
              mat  = tail nums
              zmat = zip [0..] mat
              sums = map (sumup zmat) [0..2]
              oks  = map (== 0) sums
              ans  = and oks
          putStrLn $ if ans then "YES" else "NO"
    where sumup xs i = sum $ map snd $ filter ((\x -> x `mod` 3 == i) . fst) xs

main = do
			n <- getLine
			l <- getContents
			putStr $ func $ sumV (trans  l)

trans  = map (ctoc.line) . lines
		where
			line = map read . words
			ctoc [x,y,z] = (x,y,z)
sumV l = foldr (sumcort) (0,0,0) l
		where
				sumcort (x,y,z) (x',y',z') = (x+x',y+y', z+z')
func a = if a == (0,0,0) then "YES" else "NO"

import Data.List
import Data.Maybe
main=   readsolveprint
readsolveprint::IO()
readsolveprint =  getLine>>= \x -> interact $ solve . map (map read .words).take (read x) . lines
solve :: [[Int]]->String
solve xss  =if foldr (\[a,b,c] [a1,b1,c1] -> [a+a1,b+b1,c+c1]) [0,0,0] xss ==[0,0,0] then "YES" else "NO"

type Vec3 = (Integer, Integer, Integer)

split :: Eq a => a -> [a] -> [[a]]
split _    [] = []
split cond xs = x : split cond (drop 1 y) where (x, y) = span (/= cond) xs

read_inputs :: Integer -> IO [Vec3]
read_inputs k = if k > 0
  then do
    input <- getLine
    let xs = map (read :: String -> Integer) (split ' ' input)
    let a  = (xs !! 0, xs !! 1, xs !! 2)
    b <- read_inputs (k - 1)
    return (a : b)
  else return []

add_vector :: Vec3 -> Vec3 -> Vec3
add_vector (a, b, c) (x, y, z) = (a + x, b + y, c + z)

process :: [Vec3] -> Bool
process xs =
  let res = foldl1 (\x y -> add_vector x y) xs
  in  if res == (0, 0, 0) then True else False

main :: IO ()
main = do
  k <- getLine
  let (x', _) = span (\x -> elem x ['0' .. '9']) k
  xs <- read_inputs (read x')
  let result = process xs
  if result then putStrLn "YES" else putStrLn "NO"

main = do
    n <- readLn
    v <- readlist n
    putStrLn $ if (solve v) then "YES" else "NO"
solve :: [(Int, Int, Int)] -> Bool
solve x = (0, 0, 0) == foldr (\(a, b, c) -> \(d, e, f) -> (a + d, b + e, c + f)) (0, 0, 0) x
readlist :: Int -> IO [(Int, Int, Int)]
readlist 0 = return []
readlist n = do
    s <- getLine
    let [a, b, c] = map read (words s)
    d <- readlist (n - 1)
    return $ (a, b, c) : d

import Control.Monad
int x = read x ::Int

vectoradd (x:xs) = foldr (\x acc -> zipWith (+) x acc) x xs

main = do
   n <- liftM int getLine
   vs <- liftM (map (map int. words)) $ replicateM n getLine
   let v = vectoradd vs
   putStrLn $ if v == [0,0,0] then "YES" else "NO"

{-#LANGUAGE OverloadedStrings#-}
module Main where

import qualified Data.Text as T
import Data.List

main :: IO ()
main = do
    ns <- getLine
    let n = read ns :: Integer
    res <- getL n []
    let res2 = (transpose . reverse) res
        allz = foldr (\x acc -> sum x == 0 && acc) True res2
    if allz then putStrLn "YES"
    else putStrLn "NO"
    pure ()

getL :: Integer -> [[Integer]] -> IO [[Integer]]
getL 0 acc = pure acc
getL n acc = do
    str <- getLine
    let l = map ((read :: String -> Integer) . T.unpack)
                (T.splitOn " " . T.pack $ str)
    getL (n-1) (l : acc)

readLine :: Integer -> IO String
readLine _ = getLine

parseLine :: String -> (Int, Int, Int)
parseLine s = (p1, p2, p3)
    where
        ss = words s
        p1 = read (ss !! 0)
        p2 = read (ss !! 1)
        p3 = read (ss !! 2)

myAdd :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
myAdd (a1, b1, c1) (a2, b2, c2) = (a1 + a2, b1 + b2, c1 + c2)

solve :: (Int, Int, Int) -> String
solve (0, 0, 0) = "YES"
solve _ = "NO"

main = do
    s <- getLine
    n <- return (read s)
    lines <- sequence (map readLine [1..n])
    powers <- return (map parseLine lines)
    ans <- return (foldl myAdd (0, 0, 0) powers)
    putStr (solve ans)

import Control.Monad
import Control.Applicative

data Vec = V Int Int Int

plus (V x1 y1 z1) (V x2 y2 z2) = V (x1+x2) (y1+y2) (z1+z2)
nul (V a b c) = all (==0) [a,b,c]

cr [a,b,c] = V a b c

parse = map (cr . map read . words)

main = do
  n <- read <$> getLine
  xs <- parse <$> replicateM n getLine
  let res = foldl1 plus xs
  putStrLn $
    if nul res then "YES" else "NO"

solve input = if (xx == 0 && yy == 0 && zz == 0) then
                "YES"
              else
                "NO"
  where (xx, yy, zz) = foldl (\(x1, y1, z1) (x2, y2, z2) -> (x1 + x2, y1 + y2, z1 + z2)) (0, 0, 0) coords
        coords = map f (tail $ lines input)
        f s =
          case map (read :: String -> Integer) (words s) of
            [x, y, z] -> (x, y, z)
            _ -> undefined

main = interact solve

import Control.Monad

main = readInt
  >>= readVectors
  >>= (putStrLn . decide . sumVectors . parseVectors)

readInt::IO Int
readInt = readLn

readVectors::Int -> IO [String]
readVectors n = mapM (\_ -> getLine) [1..n]

parseVectors::[String] -> [[Int]]
parseVectors strs = map (toVector . words) strs
  where toVector strs' = map read strs'

sumVectors::[[Int]] -> [Int]
sumVectors vectors = foldr sumVectors' [0, 0, 0] vectors
  where sumVectors' a b = sumPairs $ zip a b
        sumPairs pairs = map sumPair pairs
        sumPair pair = (+) (fst pair) (snd pair)

decide::[Int] -> String
decide [0, 0, 0] = "YES"
decide _ = "NO"

import Control.Monad
import Data.Array
import Data.Char
import Data.Int
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as B
getList :: Read a => IO [a]
getList = fmap (map (read . B.unpack) . B.words) B.getLine
getIntList :: IO [Int]
getIntList = fmap (unfoldr (B.readInt . B.dropWhile isSpace)) B.getLine

solve :: [[Int]] -> Bool
solve = (==[0,0,0]) . foldl1 (zipWith (+))

main :: IO ()
main = do
        n <- fmap read getLine
        a <- replicateM n getIntList
        putStrLn $ if solve a then "YES" else "NO"

import Data.List
main=interact$f.map sum.transpose.map(map read.words).tail.lines
f x|all(==0)x="YES"|1>0="NO"

import Control.Applicative
import Data.List

main=do
    getLine
    a<- map sum <$> transpose <$> map (map read) <$> map words <$> lines<$>getContents
    putStrLn $ if a==[0,0,0] then "YES" else "NO"

module Main where

import Control.Arrow
import Data.List

main = interact $ lines >>> tail >>> map (words >>> map read) >>>
  foldl1 (zipWith (+)) >>> all (==0) >>> fromEnum >>> (["NO","YES"]!!)

module Main where

import Control.Arrow
import Data.List

main = interact $ lines >>> tail >>>
  map (words >>> map read) >>>
  transpose >>> find (sum >>> (/=0)) >>> maybe "YES" (const "NO")

import Data.List (foldl')

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map (map read . words) . tail . lines

solve :: [[Int]] -> Bool
solve = all (==0) . foldl' (zipWith (+)) [0, 0, 0]

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

data Force = Force Int Int Int deriving (Show)

makeForce :: String -> Force
makeForce s = Force x y z
  where x = read $ w !! 0
        y = read $ w !! 1
        z = read $ w !! 2
        w = words s

add :: Force -> Force -> Force
add (Force a b c) (Force d e f) = Force (a + d) (b + e) (c + f)

equilAcc :: [String] -> Force -> String
equilAcc [] (Force x y z)
  | x == 0 && y == 0 && z == 0 = "YES"
  | otherwise = "NO"
equilAcc (l:ls) f = equilAcc ls (add f (makeForce l))

equil :: String -> String
equil s = equilAcc ls (Force 0 0 0)
  where ls = lines s

main = do
  getLine
  interact equil

import Control.Monad
import Control.Applicative
main = do
  n <- readLn
  cs <- replicateM n $ fmap (ZipList . map read . words) getLine
  putStrLn $ if all (==0) (getZipList (foldr1 (liftA2 (+)) cs)) then "YES" else "NO"

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Monad

main :: IO ()
main = do
  [n] :: [Int] <- map read <$> words <$> getLine
  as :: [[Int]] <- replicateM n (map read <$> words <$> getLine)
  putStrLn $ if all (== 0) $ foldl1 (zipWith (+)) as then "YES" else "NO"

import Control.Monad
main = do
    n <- getLine
    vectors <- forM [1..read n] (\_ -> do
        v_i <- getLine
        let [a,b,c] = map read . words $ v_i
        return (a,b,c))
    let vectorsSum = foldl1 (\(a,b,c) (d,e,f) -> (a+d,b+e,c+f)) vectors
    putStrLn $ if vectorsSum == (0,0,0) then "YES" else "NO"

-- Vicfred
-- https://codeforces.com/problemset/problem/69/A

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

solve :: [[Int]] -> Bool
solve = (==[0,0,0]) . foldl1 (zipWith (+))

main = do
    n <- fmap read getLine
    a <- replicateM n getIntList
    putStrLn $ if solve a then "YES" else "NO"

getIntList :: IO [Int]
getIntList = fmap (unfoldr (B.readInt . B.dropWhile isSpace)) B.getLine

p [0,0,0] = "YES"
p _       = "NO"
main = interact $ p . foldr1 (zipWith (+)) . map (map read . words) . tail . lines

main = interact $ test . foldl addTuples (0,0,0) . cps . map read . tail . words

cps (x:y:z:xs) = (x,y,z):cps(xs)
cps _ = []

addTuples (a1,b1,c1) (a2,b2,c2) = (a1+a2,b1+b2,c1+c2)

test (a,b,c) = if a == 0 && b == 0 && c == 0 then "YES" else "NO"

import Data.List
main = do
    n <- read `fmap` getLine
    l <- mapM (\_-> (map read . words) `fmap` getLine) [1..n]
    let s = foldl (\s x -> s + abs x) 0 $ foldl (zipWith (+)) [0, 0, 0] l
    putStrLn (if s == 0 then "YES" else "NO")

import Data.List
import Control.Monad

check num = if all (\x -> sum x == 0) num then "YES" else "NO"

main = do
    n <- readLn
    num <- replicateM n f
    putStrLn $ check (transpose num)
    where f :: IO [Int]
          f = fmap (map read . words) getLine

--In matrix rows values should be space separated
inputNumMatrix :: Int -> IO [[Int]]
inputNumMatrix nRows =
  sequence $ replicate nRows (map read . words <$> getLine)

sumRows :: [[Int]] -> [Int]
sumRows matrix = foldr (zipWith (+)) initAcc matrix
  where
    nColumns = length $ head matrix
    initAcc = replicate nColumns 0

--mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]

main :: IO ()
main = (read <$> getLine) >>= inputNumMatrix >>=
  (\ matrix ->
    if all (==0) (sumRows matrix)
      then putStrLn "YES"
      else putStrLn "NO")

import Control.Monad

isEquilibrium :: [Int] -> Bool
isEquilibrium [0, 0, 0] = True
isEquilibrium [a, b, c] = False

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

sumOfVectors :: [Int] -> [Int] -> [Int]
sumOfVectors [x, y, z] [] = [x, y, z]
sumOfVectors [] [x, y, z] = [x, y, z]
sumOfVectors [x1, y1, z1] [x2, y2, z2] = [x1 + x2, y1 + y2, z1 + z2]

sumOfAllVectors :: [[Int]] -> [Int]
sumOfAllVectors a = foldr sumOfVectors [0, 0, 0] a

toVec :: [String] -> [Int]
toVec a = map read a

main :: IO ()
main = do
    k <- getLine

    v <- replicateM (read k) (fmap (toVec . words) getLine)

    putStrLn $ getAnswer $ isEquilibrium
        $ sumOfAllVectors v

import Control.Monad

main :: IO ()
main = do
    k <- getLine
    v <- replicateM (read k) $ fmap ((map read) . words) getLine
    putStrLn $ getAnswer $ sumOfAllVectors v
        where getAnswer xs
                | all (==0) xs = "YES"
                | otherwise = "NO"
              sumOfAllVectors xs = foldr (zipWith (+)) (replicate 3 0) xs

import Control.Applicative
import Data.List
import Data.Maybe

main= do
	getLine
	x<- transpose. map  (map read). map words.lines <$> getContents ::IO [[Int]]
	putStrLn $ if (map sum x) == [0,0,0] then "YES" else "NO"

{-
A. Young Physicist
===================
time limit per test: 2 seconds
memory limit per test: 256 megabytes
input: standard input
output: standard output

A guy named Vasya attends the final grade of a high school. One day Vasya decided to watch a match of his favorite hockey team. And, as the boy loves hockey very much, even more than physics, he forgot to do the homework. Specifically, he forgot to complete his physics tasks. Next day the teacher got very angry at Vasya and decided to teach him a lesson. He gave the lazy student a seemingly easy task: You are given an idle body in space and the forces that affect it. The body can be considered as a material point with coordinates (0; 0; 0). Vasya had only to answer whether it is in equilibrium. "Piece of cake" — thought Vasya, we need only to check if the sum of all vectors is equal to 0. So, Vasya began to solve the problem. But later it turned out that there can be lots and lots of these forces, and Vasya can not cope without your help. Help him. Write a program that determines whether a body is idle or is moving by the given vectors of forces.

Input
------
The first line contains a positive integer n (1 ≤ n ≤ 100), then follow n lines containing three integers each: the xi coordinate, the yi coordinate and the zi coordinate of the force vector, applied to the body ( - 100 ≤ xi, yi, zi ≤ 100).

Output
------
Print the word "YES" if the body is in equilibrium, or the word "NO" if it is not.

Sample test(s)
---------------
input
3
4 1 7
-2 4 -1
1 -5 -3
output
NO

input
3
3 -1 7
-5 2 -4
2 -1 -3
output
YES

-}

import Data.List (transpose)

isEquilibrium :: [[Int]] -> Bool
isEquilibrium forces = all (\xs -> sum xs == 0) (transpose forces)

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

reader :: String -> [[Int]]
reader s = [map read (words line) | line <- tail (lines s)]

main = do
  input <- getContents
  let forces = reader input
  (putStrLn . boolToStr . isEquilibrium) forces

main = do
  n <- readLn
  m <- sequence $ replicate n getLine
  let m2 = map (map read . words) m
  if (equil m2) then putStrLn "YES" else putStrLn "NO"
equil :: [[Int]] -> Bool
equil x = (foldl (\[y1, y2, y3] [z1, z2, z3] -> [y1+z1, y2+z2, y3+z3]) [0, 0, 0] x) == [0, 0, 0]

solve l n
  | all (0==) [sum [l !! i !! j | i <- [0 .. n - 1]] | j <- [0 .. 2]] = "YES"
  | otherwise                                    = "NO"
main = do
  n <- readLn :: IO Int
  l <- getContents >>= return.map (map read. words).lines:: IO [[Integer]]
  putStrLn.solve l $ n

import           Control.Monad
import           Data.List
main :: IO ()
main = do
    n <- (read :: String -> Int) <$> getLine
    vectors <- map (map (read :: String -> Int) . words) <$> replicateM n getLine
    let sums = map sum $ transpose vectors
    putStrLn $ if sums == [0, 0, 0] then "YES" else "NO"

import Control.Monad.State
import Data.List

countVerdict :: StateT [Integer] IO ()
countVerdict = do
  a <- lift getLine
  forM_ [1 .. read a] $ \_ -> do
    input <- lift getLine
    modify $ zipWith (+) $ read <$> words input

someFunc :: IO ()
someFunc = execStateT countVerdict [0, 0, 0] >>= (\s -> putStrLn $ if all (== 0) s then "YES" else "NO")

main :: IO ()
main = someFunc

import Data.List
import Control.Monad
main = getLine >>= flip replicateM getLine.read
   >>= answer.succ.sum.map (abs.sum.map read).transpose.map words
answer = putStrLn.last.flip take ("YES":repeat "NO")

import Data.List (transpose)

process :: [[Int]] -> Bool
process = all (==0).map sum.transpose

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    n <- fmap readInt getLine
    xss <- fmap (map (map readInt.words).lines) getContents
    putStrLn $ ["NO","YES"] !! fromEnum (process xss)

module Main where

import           Data.List

main :: IO ()
main = interact $ f . map sum . transpose . map (map read.words) . tail . lines

f :: (Num a, Eq a, Foldable t) => t a -> String
f x | all (==0) x = "YES"
    | otherwise = "NO"

getLines :: Int -> IO [String]
getLines n
		| n==0 = return []
		| otherwise = do
			str <- getLine
			others <- getLines (n-1)
			return (str:others)

getVector :: String -> [Int]
getVector str = map (read :: String -> Int) $ words str

sumElems :: [[Int]] -> [Int]
sumElems vectors = foldl (\ (x:y:z:[]) (x':y':z':xs) -> ( (x+x'):(y+y'):(z+z'):[] ) ) [0,0,0] vectors

main = do
	countStr <- getLine
	let count = read countStr
	vectorStrs <- getLines count
	let vectors = map getVector vectorStrs
	let mainVector = sumElems vectors
	if all (==0) mainVector then putStrLn "YES" else putStrLn "NO"

equilibrium :: [[Int]] -> Bool
equilibrium = all (== 0) . foldl (zipWith (+)) [0,0,0]

solve :: String -> String
solve s
    | equilibrium xs = "YES"
    | otherwise = "NO"
        where _:ls = lines s
              xs = fmap (fmap read . words) $ ls

main :: IO ()
main = interact solve

f = (\x->if x then"YES"else"NO").all (==0).foldl1 (zipWith (+))
main = interact $ f.map (map read.words).tail.lines

import qualified Data.List as List
import qualified Data.Maybe as Maybe

readAsInt :: String -> Int
readAsInt str = read str :: Int

foldCoordinate :: Int -> [[Int]] -> Int
foldCoordinate index vectorList = foldl (\acc elem -> let coord = elem !! index in acc + coord) 0 vectorList

isEquilibrium :: [[Int]] -> String
isEquilibrium vectorList =
	if xTotal == 0 && (yTotal == 0 && zTotal == 0)
	then "YES"
	else "NO"
	where xTotal = foldCoordinate 0 vectorList; yTotal = foldCoordinate 1 vectorList; zTotal = foldCoordinate 2 vectorList

solveCase :: Int -> [[Int]] -> IO ()
solveCase remainCase initial
	| remainCase > 0 = do
		line <- getLine
		let vector = map readAsInt $ words line
		solveCase (remainCase - 1) (vector : initial)
	| remainCase == 0 = putStrLn $ isEquilibrium initial

main = do
	line <- getLine
	let vectorNum = readAsInt line
	solveCase vectorNum []

main = do
    getLine
    ts <- fmap (map (map read . words) . lines) getLine

    let s = foldl1 (\[a, b, c] [d, e, f] -> [a+d, b+e, c+f]) ts
    putStrLn $ if s == [0, 0, 0] then "YES" else "NO"

main :: IO ()
main = do cs <- getContents
          let nums = map read $ words cs
              n    = head nums
              mat  = tail nums
              zmat = zip [0..] mat
              sums = map (sumup zmat n) [0..2]
              oks  = map (== 0) sums
              ans  = and oks
          putStrLn $ if ans then "YES" else "NO"
    where sumup xs n i = sum $ map snd $ filter ((\x -> x `mod` n == i) . fst) xs

main :: IO ()
main = do cs <- getContents
          let nums = map read $ words cs
              n    = head nums
              mat  = tail nums
              zmat = zip [0..] mat
              sums = map (sumup zmat n) [0..n-1]
              oks  = map (== 0) sums
              ans  = and oks
          putStrLn $ if ans then "YES" else "NO"
    where sumup xs n i = sum $ map snd $ filter ((\x -> x `mod` n == i) . fst) xs

type Vec3 = (Integer, Integer, Integer)

split :: Eq a => a -> [a] -> [[a]]
split _    [] = []
split cond xs = x : split cond (drop 1 y) where (x, y) = span (/= cond) xs

read_inputs :: Integer -> IO [Vec3]
read_inputs k = if k > 0
  then do
    input <- getLine
    let xs = map (read :: String -> Integer) (split ' ' input)
    let a  = (xs !! 0, xs !! 1, xs !! 2)
    b <- read_inputs (k - 1)
    return (a : b)
  else return []

add_vector :: Vec3 -> Vec3 -> Vec3
add_vector (a, b, c) (x, y, z) = (a + x, b + y, c + z)

process :: [Vec3] -> Bool
process xs =
  let res = foldl1 (\x y -> add_vector x y) xs
  in  if res == (0, 0, 0) then True else False

main :: IO ()
main = do
  k <- getLine
  let (x', _) = span (\x -> elem x ['0' .. '9']) k
  xs <- read_inputs (read x')
  let result = process xs
  if result then putStrLn "Yes" else putStrLn "No"

import Data.List (foldl')

main :: IO ()
main = getContents >>= putStrLn . yesno . solve . map (map read . words) . tail . lines

solve :: [[Int]] -> Bool
solve = allsame . foldl' (zipWith (+)) [0, 0, 0]

allsame :: Eq a => [a] -> Bool
allsame xs = all (==head xs) xs

yesno :: Bool -> String
yesno True = "YES"
yesno _ = "NO"

{-
A. Young Physicist
===================
time limit per test: 2 seconds
memory limit per test: 256 megabytes
input: standard input
output: standard output

A guy named Vasya attends the final grade of a high school. One day Vasya decided to watch a match of his favorite hockey team. And, as the boy loves hockey very much, even more than physics, he forgot to do the homework. Specifically, he forgot to complete his physics tasks. Next day the teacher got very angry at Vasya and decided to teach him a lesson. He gave the lazy student a seemingly easy task: You are given an idle body in space and the forces that affect it. The body can be considered as a material point with coordinates (0; 0; 0). Vasya had only to answer whether it is in equilibrium. "Piece of cake" — thought Vasya, we need only to check if the sum of all vectors is equal to 0. So, Vasya began to solve the problem. But later it turned out that there can be lots and lots of these forces, and Vasya can not cope without your help. Help him. Write a program that determines whether a body is idle or is moving by the given vectors of forces.

Input
------
The first line contains a positive integer n (1 ≤ n ≤ 100), then follow n lines containing three integers each: the xi coordinate, the yi coordinate and the zi coordinate of the force vector, applied to the body ( - 100 ≤ xi, yi, zi ≤ 100).

Output
------
Print the word "YES" if the body is in equilibrium, or the word "NO" if it is not.

Sample test(s)
---------------
input
3
4 1 7
-2 4 -1
1 -5 -3
output
NO

input
3
3 -1 7
-5 2 -4
2 -1 -3
output
YES

-}

import Data.List (transpose)

isEquilibrium :: [[Int]] -> Bool
isEquilibrium forces = all (\xs -> sum xs == 0) (transpose forces)

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

reader :: String -> [[Int]]
reader s = [map read (words line) | line <- lines xss]
  where _:xss = s

main = do
  input <- getContents
  let forces = reader input
  (putStrLn . boolToStr . isEquilibrium) forces

import Data.List
import Control.Monad
main = getLine >>= flip replicateM getLine.read
   >>= answer.succ.abs.sum.map (sum.map read).transpose.map words
answer = putStrLn.last.flip take ("YES":repeat "NO")

getLines :: Int -> IO [String]
getLines n
		| n==0 = return []
		| otherwise = do
			str <- getLine
			others <- getLines (n-1)
			return (str:others)

getVector :: String -> [Int]
getVector str = map (read :: String -> Int) $ words str

sumElems :: [[Int]] -> [Int]
sumElems vectors = foldl (\ (x:y:z:[]) (x':y':z':xs) -> ( (x+x'):(y+y'):(z+z'):[] ) ) [0,0,0] vectors

main = do
	countStr <- getLine
	let count = read countStr
	vectorStrs <- getLines count
	let vectors = map getVector vectorStrs
	let mainVector = sumElems vectors
	if all (==0) mainVector then print "YES" else print "NO"


A sequence a0, a1, ..., at - 1 is called increasing if ai - 1 < ai for each i: 0 < i < t.You are given a sequence b0, b1, ..., bn - 1 and a positive integer d. In each move you may choose one element of the given sequence and add d to it. What is the least number of moves required to make the given sequence increasing?

The first line of the input contains two integer numbers n and d (2 ≤ n ≤ 2000, 1 ≤ d ≤ 106). The second line contains space separated sequence b0, b1, ..., bn - 1 (1 ≤ bi ≤ 106).

Output the minimal number of moves needed to make the sequence increasing.

solve :: Int -> [Int] -> Int
solve _ [] = 0
solve _ [_] = 0
solve d (x:y:zs) = cnt + solve d ((y+cnt*d):zs)
	where cnt = max 0 $ (x - y + d) `div` d

main = do
	n:d:_ <- getLine >>= return . (map read) . words :: IO [Int]
	b <- getLine >>= return . (map read) . words :: IO [Int]
	putStrLn $ show $ solve d b

extract (x:y:_)=(a,b,dat) where
	(a:b:_)=map (\x->read x::Int) (words x)
	dat=map (\x->read x::Int) (words y)
solve (a,delta,(x:xs)) = solve1 xs x delta

solve1 [] lst delta = 0
solve1 (x:xs) lst delta
	|x>lst = solve1 xs x delta
	|otherwise = cnt + solve1 xs (x+cnt*delta) delta
	where
		cnt = (div (lst-x) delta)+1

main=interact$show.solve.extract.lines

extract (x:y:_)=(a,b,dat) where
	(a:b:_)=map (\x->read x::Int) (words x)
	dat=map (\x->read x::Int) (words y)
solve (a,delta,(x:xs)) = solve1 xs x delta 0

solve1 [] lst delta counter = counter
solve1 (x:xs) lst delta counter
	|x>lst = solve1 xs x delta counter
	|otherwise = solve1 xs (x+cnt*delta) delta (counter+cnt)
	where
		cnt = (div (lst-x) delta)+1

main=interact$show.solve.extract.lines

module Main where
import Data.List
main = do
    [n,d] <- map (read :: String -> Int) . words <$> getLine
    bs <- map (read :: String -> Int) . words <$> getLine
    print $ fst $ foldl' (\(a,b) x ->
        if x > b
            then (a,x)
            else
                let c = b-x+1
                    e = c `div` d + if c `mod` d /= 0 then 1 else 0
                in  (a+e,x+e*d)
        ) (0,head bs) $ tail bs

solve :: Int -> [Int] -> Int
solve d (x:xs)  =  solve' x xs
  where
    solve' _ []  =  0
    solve' x (y:ys)
      | y > x  =  solve' y ys
      | otherwise  =  n + solve' (y + n*d) ys
      where
        n  =  div (x - y) d + 1

main :: IO ()
main  =  do
    [n, d]  <-  getLine >>= return . map read . words
    xs  <-  getLine >>= return . map read . words
    print $ solve d xs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# OPTIONS_GHC -O2 #-}

import Data.List
import Data.Maybe
import Data.Char
import Data.Array.IArray
import Data.Array.Unboxed (UArray)
import Data.Int
import Data.Ratio
import Data.Bits
import Data.Function
import Data.Ord
--import Control.Monad.State
import Control.Monad
import Control.Applicative
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Sequence (Seq, (<|), (|>), (><), ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Graph

parseInput = do
    n <- readInt
    d <- readInt
    a <- replicateM n readInt
    return (d, a)
  where
    readInt = state $ fromJust . BS.readInt . BS.dropWhile isSpace
    readInteger = state $ fromJust . BS.readInteger . BS.dropWhile isSpace
    readString = state $ BS.span (not . isSpace) . BS.dropWhile isSpace
    readLine = state $ BS.span (not . isEoln) . BS.dropWhile isEoln
    isEoln ch = ch == '\r' || ch == '\n'

main = print =<< solve . evalState parseInput <$> BS.getContents

solve :: (Int, [Int]) -> Int
solve (d, x:y:zs) = delta + solve (d, (y + delta * d):zs)
  where
    delta = if x >= y then (x - y) `div` d + 1 else 0
solve _ = 0

----------------------------------------------------------------------
----------------------------------------------------------------------
----------------------------------------------------------------------

class (Monad m) => MonadState s m | m -> s where
	get :: m s
	put :: s -> m ()

modify :: (MonadState s m) => (s -> s) -> m ()
modify f = do
	s <- get
	put (f s)

gets :: (MonadState s m) => (s -> a) -> m a
gets f = do
	s <- get
	return (f s)

newtype State s a = State { runState :: s -> (a, s) }

instance Functor (State s) where
	fmap f m = State $ \s -> let
		(a, s') = runState m s
		in (f a, s')

instance Applicative (State s) where
    pure = return
    (<*>) = ap

instance Monad (State s) where
	return a = State $ \s -> (a, s)
	m >>= k  = State $ \s -> let
		(a, s') = runState m s
		in runState (k a) s'

instance MonadState s (State s) where
	get   = State $ \s -> (s, s)
	put s = State $ \_ -> ((), s)

evalState :: State s a -> s -> a
evalState m s = fst (runState m s)

execState :: State s a -> s -> s
execState m s = snd (runState m s)

mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
mapState f m = State $ f . runState m

withState :: (s -> s) -> State s a -> State s a
withState f m = State $ runState m . f

state = State

{-# LANGUAGE BangPatterns #-}

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

solve :: [String] -> [String]
solve = fmap return $ do
  let readInts = map read . words . head
  d <- head . drop 1 . readInts
  bs <- readInts . drop 1
  let count (!prev, !moves) b
        | prev >= b = count (prev, moves + n) (b + d * n)
        | otherwise = (b, moves)
        where n = (prev - b) `quot` d + 1
  return . show . snd $ foldl' count (0, 0) bs

main :: IO ()
main = interact $ unlines . solve . lines

{-# LANGUAGE BangPatterns #-}

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

solve :: [String] -> [String]
solve = fmap return $ do
  let readInts = map read . words . head
  d <- head . drop 1 . readInts
  bs <- readInts . drop 1
  let count (!prev, !moves) !b
        | prev >= b = count (prev, moves + n) (b + d * n)
        | otherwise = (b, moves)
        where n = (prev - b) `quot` d + 1
  return . show . snd $ foldl' count (0, 0) bs

main :: IO ()
main = interact $ unlines . solve . lines

{-# LANGUAGE BangPatterns #-}

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

solve :: [String] -> [String]
solve = fmap return $ do
  let readInts = map read . words . head
  d <- head . drop 1 . readInts
  bs <- readInts . drop 1
  let count (prev, !moves) !b
        | prev >= b = count (prev, moves + n) (b + d * n)
        | otherwise = (b, moves)
        where n = (prev - b) `quot` d + 1
  return . show . snd $ foldl' count (0, 0) bs

main :: IO ()
main = interact $ unlines . solve . lines

main = do
 [_,d] <- (read <$>) <$> words <$> getLine
 arr <- (read <$>) <$> words <$> getLine
 let red a b | a >= b = (a - b) `div` d + 1
             | otherwise = 0
     sol (x1:x2:xs) = let add = red x1 x2 in add + sol (add * d + x2:xs)
     sol _ = 0
 print $ sol arr

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

process n d [x] = n
process n d (a:b:cs) | a<b = process n d (b:cs)
                     | otherwise = process (n+x) d ((b+x*d):cs)

	where x = div (a-b) d +1
main = do
		[n,d]<-map read <$> words <$> getLine ::IO [Int]
		s<-map read <$> words <$> getLine ::IO [Int]
		print $ process 0 d s

extract (x:y:_)=(a,b,dat) where
	(a:b:_)=map (\x->read x::Int) (words x)
	dat=map (\x->read x::Int) (words y)
solve (a,delta,(x:xs)) = solve1 xs x delta 0

solve1 [] lst delta counter = counter
solve1 (x:xs) lst delta counter
	|x>lst = solve1 xs x delta counter
	|otherwise = solve1 xs (lst+cnt*delta) delta (counter+cnt)
	where
		cnt = (div (lst-x) delta)+1

main=interact$show.solve.extract.lines

main = do
 getLine
 arr <- (read <$>) <$> words <$> getLine
 let
  sol acc _ [] = acc
  sol acc cnt (x:xs) = sol (acc + abs (x - cnt)) (succ cnt) xs
 print $ sol 0 1 arr