Author has gone out of the stories about Vasiliy, so here is just a formal task description.You are given q queries and a multiset A, initially containing only integer 0. There are three types of queries:  "+ x" — add integer x to multiset A. "- x" — erase one occurrence of integer x from multiset A. It's guaranteed that at least one x is present in the multiset A before this query. "? x" — you are given integer x and need to compute the value , i.e. the maximum value of bitwise exclusive OR (also know as XOR) of integer x and some integer y from the multiset A.Multiset is a set, where equal elements are allowed.

The first line of the input contains a single integer q (1 ≤ q ≤ 200 000) — the number of queries Vasiliy has to perform. Each of the following q lines of the input contains one of three characters '+', '-' or '?' and an integer xi (1 ≤ xi ≤ 109). It's guaranteed that there is at least one query of the third type. Note, that the integer 0 will always be present in the set A.

For each query of the type '?' print one integer — the maximum value of bitwise exclusive OR (XOR) of integer xi and some integer from the multiset A.

NoteAfter first five operations multiset A contains integers 0, 8, 9, 11, 6 and 1.The answer for the sixth query is integer  — maximum among integers , , ,  and .

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import Data.Bits

data Tree = Leaf | Node Tree Tree Int deriving (Eq, Show)

insert :: Tree -> [Bool] -> Tree
insert (Node Leaf Leaf c) [] = Node Leaf Leaf (c+1)
insert Leaf [] = Node Leaf Leaf 1
insert Leaf (b:bs) =
  if b then Node Leaf (insert Leaf bs) 1 else Node (insert Leaf bs) Leaf 1

insert (Node l r c) (b:bs) = Node l' r' (c+1)
  where
    l' = if b then l else insert l bs
    r' = if b then insert r bs else r

remove :: Tree -> [Bool] -> Tree
remove (Node Leaf Leaf c) [] = if c == 1 then Leaf else Node Leaf Leaf (c-1)
remove (Node l r c) (b:bs) =
    if c == 1 then Leaf else Node l' r' (c-1)
  where
    l' = if b then l else remove l bs
    r' = if b then remove r bs else r

query :: Tree -> [Bool] -> [Bool]
query _ [] = []
query (Node l r c) (b:bs)
  | b && (l /= Leaf) = True:(query l bs)
  | not b && (r /= Leaf) = True:(query r bs)
  | l /= Leaf = b:(query l bs)
  | r /= Leaf = (not b):(query r bs)

bools :: Int -> [Bool]
bools x = map (x `testBit`) [31,30..0]

int :: [Bool] -> Int
int bs = sum $ zipWith (\i b -> if b then bit i else 0)  [31,30..0] bs

main = do
  q <- readLn
  qs <- replicateM q ((\[a, b] -> (a, read b)) . words <$> getLine)

  let
    handle :: Tree -> [(String, Int)] -> [Int]
    handle t [] = []
    handle t (("+", x):qs) = handle t' qs
      where t' = insert t (bools x)
    handle t (("-", x):qs) = handle t' qs
      where t' = remove t (bools x)

    handle t (("?", x):qs) = (int $ query t (bools x)):(handle t qs)

    t = insert Leaf (bools 0)

  putStr $ unlines $ map show $ handle t qs

{-# LANGUAGE OverloadedStrings #-}

import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import Data.Either (either)
import Data.Bits (xor)
import Control.Monad (replicateM, foldM, foldM_)
import Data.List (foldl')

parseInt :: Text -> Int
parseInt = either (error "wtf") fst . T.decimal . T.stripStart

data Query =
    Add {-# UNPACK #-} !Int
  | Erase {-# UNPACK #-} !Int
  | MXor {-# UNPACK #-} !Int deriving (Eq, Ord, Read, Show)

qGetInt :: Query -> Int
qGetInt q =
  case q of
    Add i -> i
    Erase i -> i
    MXor i -> i

parseQ :: Text -> Query
parseQ t =
  let n = parseInt (T.tail t)
  in case T.head t of
       '+' -> Add n
       '-' -> Erase n
       _ -> MXor n

runQ :: IntMap Int -> Query -> (IntMap Int, Maybe Int)
runQ m q =
  case q of
    Add n -> (M.insertWith (+) n 1 m, Nothing)
    Erase n -> (M.update (\i -> if i > 1 then Just (i-1) else Nothing) n m, Nothing)
    MXor n -> (m, Just (M.foldlWithKey' (\a k _-> max a (xor n k)) 0 m))

main0 :: IO ()
main0 = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  ms <- foldM (\m q -> (\(m', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return m') (runQ m q)) M.empty qs
  return ()

data Trie =
    Empty
  | Leaf {-# UNPACK #-} !Int
  | Node {-# UNPACK #-} !Trie {-# UNPACK #-} !Trie
  deriving (Show, Eq, Ord)

isEmpty :: Trie -> Bool
isEmpty t =
  case t of
    Empty -> True
    Leaf n -> False
    Node l r -> isEmpty l && isEmpty r

digits :: Int -> Int -> [Int]
digits base n0 = go n0 []
  where
    go n acc
      | n < base = n:acc
      | otherwise = let (q, r) = quotRem n base
                    in go q (r:acc)

undigits :: Int -> [Int] -> Int
undigits base ds = go (reverse ds) 1 0
  where
    go ds p n =
      case ds of
        [] -> n
        d:ds' -> go ds' (p*base) (n + d*p)

digitsPad :: Int -> Int -> Int -> [Int]
digitsPad sz base n = replicate (sz - length ds) 0 ++ ds
  where
    ds = digits base n

add :: Int -> Trie -> Trie
add i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Empty) -> Leaf 1
        ([], Leaf n) -> Leaf (n+1)
        (0:ds', Empty) -> Node (go ds' Empty) Empty
        (1:ds', Empty) -> Node Empty (go ds' Empty)
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie add invariant failed"

erase :: Int -> Trie -> Trie
erase i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Leaf n) | n > 1 -> Leaf (n-1)
                     | otherwise -> Empty
        (_, Empty) -> Empty
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie erase invariant failed"

maxXor :: Int -> Trie -> Maybe Int
maxXor i = go [] (digitsPad 32 2 i)
  where
    go o ds t =
      case (ds, t) of
        (_, Leaf n) -> Just (xor i . undigits 2 . reverse $ o)
        (d:ds', Node l r) | isEmpty l -> go (1:o) ds' r
                          | isEmpty r -> go (0:o) ds' l
                          | d == 0 -> go (1:o) ds' r
                          | d == 1 -> go (0:o) ds' l
        _ -> error "Trie invariant failed"

runQuery :: Query -> Trie -> (Trie, Maybe Int)
runQuery q t =
  case q of
    Add i -> (add i t, Nothing)
    Erase i -> (erase i t, Nothing)
    MXor i -> (t, maxXor i t)

testT :: Bool
testT = isEmpty (foldl' (flip erase) (foldl' (flip add) Empty [1..1000]) [1..1000])

main :: IO ()
main = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  foldM_ (\t q -> (\(t', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return t') (runQuery q t)) (add 0 Empty) qs

{-# LANGUAGE OverloadedStrings #-}

import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import Data.Either (either)
import Data.Bits (xor)
import Control.Monad (replicateM, foldM, foldM_)

parseInt :: Text -> Int
parseInt = either (error "wtf") fst . T.decimal . T.stripStart

data Query =
    Add {-# UNPACK #-} !Int
  | Erase {-# UNPACK #-} !Int
  | MXor {-# UNPACK #-} !Int deriving (Eq, Ord, Read, Show)

parseQ :: Text -> Query
parseQ t =
  let n = parseInt (T.tail t)
  in case T.head t of
       '+' -> Add n
       '-' -> Erase n
       _ -> MXor n

runQ :: IntMap Int -> Query -> (IntMap Int, Maybe Int)
runQ m q =
  case q of
    Add n -> (M.insertWith (+) n 1 m, Nothing)
    Erase n -> (M.update (\i -> if i > 1 then Just (i-1) else Nothing) n m, Nothing)
    MXor n -> (m, Just (M.foldlWithKey' (\a k _-> max a (xor n k)) 0 m))

main0 :: IO ()
main0 = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  ms <- foldM (\m q -> (\(m', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return m') (runQ m q)) M.empty qs
  return ()

data Trie =
    Empty
  | Leaf {-# UNPACK #-} !Int
  | Node {-# UNPACK #-} !Trie {-# UNPACK #-} !Trie
  deriving (Show, Eq, Ord)

isEmpty :: Trie -> Bool
isEmpty Empty = True
isEmpty _ = False

digits :: Int -> Int -> [Int]
digits base n0 = go n0 []
  where
    go n acc
      | n < base = n:acc
      | otherwise = let (q, r) = quotRem n base
                    in go q (r:acc)

undigits :: Int -> [Int] -> Int
undigits base ds = go (reverse ds) 1 0
  where
    go ds p n =
      case ds of
        [] -> n
        d:ds' -> go ds' (p*base) (n + d*p)

digitsPad :: Int -> Int -> Int -> [Int]
digitsPad sz base n = replicate (sz - length ds) 0 ++ ds
  where
    ds = digits base n

add :: Int -> Trie -> Trie
add i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Empty) -> Leaf 1
        ([], Leaf n) -> Leaf (n+1)
        (0:ds', Empty) -> Node (go ds' Empty) Empty
        (1:ds', Empty) -> Node Empty (go ds' Empty)
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie add invariant failed"

erase :: Int -> Trie -> Trie
erase i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Leaf n) | n > 1 -> Leaf (n-1)
                     | otherwise -> Empty
        (_, Empty) -> Empty
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie erase invariant failed"

maxXor :: Int -> Trie -> Maybe Int
maxXor i = go [] (digitsPad 32 2 i)
  where
    go o ds t =
      case (ds, t) of
        (_, Empty) -> Just i
        (_, Leaf n) -> Just (xor i . undigits 2 . reverse $ o)
        (d:ds', Node l r) | isEmpty l -> go (1:o) ds' r
                          | isEmpty r -> go (0:o) ds' l
                          | d == 0 -> go (1:o) ds' r
                          | d == 1 -> go (0:o) ds' l
        _ -> error "Trie invariant failed"

runQuery :: Query -> Trie -> (Trie, Maybe Int)
runQuery q t =
  case q of
    Add i -> (add i t, Nothing)
    Erase i -> (erase i t, Nothing)
    MXor i -> (t, maxXor i t)

main :: IO ()
main = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  foldM_ (\t q -> (\(t', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return t') (runQuery q t)) Empty qs

{-# LANGUAGE OverloadedStrings #-}

import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import Data.Either (either)
import Data.Bits (xor)
import Control.Monad (replicateM, foldM, foldM_)

parseInt :: Text -> Int
parseInt = either (error "wtf") fst . T.decimal . T.stripStart

data Query =
    Add {-# UNPACK #-} !Int
  | Erase {-# UNPACK #-} !Int
  | MXor {-# UNPACK #-} !Int deriving (Eq, Ord, Read, Show)

parseQ :: Text -> Query
parseQ t =
  let n = parseInt (T.tail t)
  in case T.head t of
       '+' -> Add n
       '-' -> Erase n
       _ -> MXor n

runQ :: IntMap Int -> Query -> (IntMap Int, Maybe Int)
runQ m q =
  case q of
    Add n -> (M.insertWith (+) n 1 m, Nothing)
    Erase n -> (M.update (\i -> if i > 1 then Just (i-1) else Nothing) n m, Nothing)
    MXor n -> (m, Just (M.foldlWithKey' (\a k _-> max a (xor n k)) 0 m))

main0 :: IO ()
main0 = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  ms <- foldM (\m q -> (\(m', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return m') (runQ m q)) M.empty qs
  return ()

data Trie =
    Empty
  | Leaf {-# UNPACK #-} !Int
  | Node {-# UNPACK #-} !Trie {-# UNPACK #-} !Trie
  deriving (Show, Eq, Ord)

isEmpty :: Trie -> Bool
isEmpty Empty = True
isEmpty _ = False

digits :: Int -> Int -> [Int]
digits base n0 = go n0 []
  where
    go n acc
      | n < base = n:acc
      | otherwise = let (q, r) = quotRem n base
                    in go q (r:acc)

undigits :: Int -> [Int] -> Int
undigits base ds = go (reverse ds) 1 0
  where
    go ds p n =
      case ds of
        [] -> n
        d:ds' -> go ds' (p*base) (n + d*p)

digitsPad :: Int -> Int -> Int -> [Int]
digitsPad sz base n = replicate (sz - length ds) 0 ++ ds
  where
    ds = digits base n

add :: Int -> Trie -> Trie
add i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Empty) -> Leaf 1
        ([], Leaf n) -> Leaf (n+1)
        (0:ds', Empty) -> Node (go ds' Empty) Empty
        (1:ds', Empty) -> Node Empty (go ds' Empty)
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie add invariant failed"

erase :: Int -> Trie -> Trie
erase i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Leaf n) | n > 1 -> Leaf (n-1)
                     | otherwise -> Empty
        (_, Empty) -> Empty
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie erase invariant failed"

maxXor :: Int -> Trie -> Maybe Int
maxXor i = go [] (digitsPad 32 2 i)
  where
    go o ds t =
      case (ds, t) of
        (_, Empty) -> Nothing
        (_, Leaf n) -> Just (xor i . undigits 2 . reverse $ o)
        (d:ds', Node l r) | isEmpty l -> go (1:o) ds' r
                          | isEmpty r -> go (0:o) ds' l
                          | d == 0 -> go (1:o) ds' r
                          | d == 1 -> go (0:o) ds' l
        _ -> error "Trie invariant failed"

runQuery :: Query -> Trie -> (Trie, Maybe Int)
runQuery q t =
  case q of
    Add i -> (add i t, Nothing)
    Erase i -> (erase i t, Nothing)
    MXor i -> (t, maxXor i t)

main :: IO ()
main = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  foldM_ (\t q -> (\(t', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return t') (runQuery q t)) Empty qs

{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad
import Data.Bits

data Tree = Leaf | Node Tree Tree Int deriving (Eq, Show)

insert :: Tree -> [Bool] -> Tree
insert _ [] = Node Leaf Leaf 1
insert Leaf (b:bs) =
  if b then Node Leaf (insert Leaf bs) 1 else Node (insert Leaf bs) Leaf 1

insert (Node l r c) (b:bs) = Node l' r' (c+1)
  where
    l' = if b then l else insert l bs
    r' = if b then insert r bs else r

remove :: Tree -> [Bool] -> Tree
remove _ [] = Leaf
remove (Node l r c) (b:bs) =
    if c == 1 then Leaf else Node l' r' (c-1)
  where
    l' = if b then l else remove l bs
    r' = if b then remove r bs else r

query :: Tree -> [Bool] -> [Bool]
query _ [] = []
query (Node l r c) (b:bs)
  | b && (l /= Leaf) = True:(query l bs)
  | not b && (r /= Leaf) = True:(query r bs)
  | l /= Leaf = b:(query l bs)
  | r /= Leaf = (not b):(query r bs)

bools :: Int -> [Bool]
bools x = map (x `testBit`) [31,30..0]

int :: [Bool] -> Int
int bs = sum $ zipWith (\i b -> if b then bit i else 0)  [31,30..0] bs

main = do
  q <- readLn
  qs <- replicateM q ((\[a, b] -> (a, read b)) . words <$> getLine)

  let
    handle :: Tree -> [(String, Int)] -> [Int]
    handle t [] = []
    handle t (("+", x):qs) = handle t' qs
      where t' = insert t (bools x)
    handle t (("-", x):qs) = handle t' qs
      where t' = remove t (bools x)

    handle t (("?", x):qs) = (int $ query t (bools x)):(handle t qs)

    t = insert Leaf (bools 0)

  putStr $ unlines $ map show $ handle t qs

{-# LANGUAGE OverloadedStrings #-}

import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import Data.Either (either)
import Data.Bits (xor)
import Control.Monad (replicateM, foldM, foldM_)

parseInt :: Text -> Int
parseInt = either (error "wtf") fst . T.decimal . T.stripStart

data Query =
    Add {-# UNPACK #-} !Int
  | Erase {-# UNPACK #-} !Int
  | MXor {-# UNPACK #-} !Int deriving (Eq, Ord, Read, Show)

qGetInt :: Query -> Int
qGetInt q =
  case q of
    Add i -> i
    Erase i -> i
    MXor i -> i

parseQ :: Text -> Query
parseQ t =
  let n = parseInt (T.tail t)
  in case T.head t of
       '+' -> Add n
       '-' -> Erase n
       _ -> MXor n

runQ :: IntMap Int -> Query -> (IntMap Int, Maybe Int)
runQ m q =
  case q of
    Add n -> (M.insertWith (+) n 1 m, Nothing)
    Erase n -> (M.update (\i -> if i > 1 then Just (i-1) else Nothing) n m, Nothing)
    MXor n -> (m, Just (M.foldlWithKey' (\a k _-> max a (xor n k)) 0 m))

main0 :: IO ()
main0 = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  ms <- foldM (\m q -> (\(m', mi) -> maybe (return ()) (T.putStrLn . T.pack . show) mi >> return m') (runQ m q)) M.empty qs
  return ()

data Trie =
    Empty
  | Leaf {-# UNPACK #-} !Int
  | Node {-# UNPACK #-} !Trie {-# UNPACK #-} !Trie
  deriving (Show, Eq, Ord)

isEmpty :: Trie -> Bool
isEmpty Empty = True
isEmpty _ = False

digits :: Int -> Int -> [Int]
digits base n0 = go n0 []
  where
    go n acc
      | n < base = n:acc
      | otherwise = let (q, r) = quotRem n base
                    in go q (r:acc)

undigits :: Int -> [Int] -> Int
undigits base ds = go (reverse ds) 1 0
  where
    go ds p n =
      case ds of
        [] -> n
        d:ds' -> go ds' (p*base) (n + d*p)

digitsPad :: Int -> Int -> Int -> [Int]
digitsPad sz base n = replicate (sz - length ds) 0 ++ ds
  where
    ds = digits base n

add :: Int -> Trie -> Trie
add i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Empty) -> Leaf 1
        ([], Leaf n) -> Leaf (n+1)
        (0:ds', Empty) -> Node (go ds' Empty) Empty
        (1:ds', Empty) -> Node Empty (go ds' Empty)
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie add invariant failed"

erase :: Int -> Trie -> Trie
erase i = go (digitsPad 32 2 i)
  where
    go ds t =
      case (ds, t) of
        ([], Leaf n) | n > 1 -> Leaf (n-1)
                     | otherwise -> Empty
        (_, Empty) -> Empty
        (0:ds', Node l r) -> Node (go ds' l) r
        (1:ds', Node l r) -> Node l (go ds' r)
        _ -> error "Trie erase invariant failed"

maxXor :: Int -> Trie -> Maybe Int
maxXor i = go [] (digitsPad 32 2 i)
  where
    go o ds t =
      case (ds, t) of
        (_, Empty) -> Just i
        (_, Leaf n) -> Just (xor i . undigits 2 . reverse $ o)
        (d:ds', Node l r) | isEmpty l -> go (1:o) ds' r
                          | isEmpty r -> go (0:o) ds' l
                          | d == 0 -> go (1:o) ds' r
                          | d == 1 -> go (0:o) ds' l
        _ -> error "Trie invariant failed"

runQuery :: Query -> Trie -> (Trie, Maybe Int)
runQuery q t =
  case q of
    Add i -> (add i t, Nothing)
    Erase i -> (erase i t, Nothing)
    MXor i -> (t, maxXor i t)

main :: IO ()
main = do
  qn <- fmap parseInt T.getLine
  qs <- replicateM qn (fmap parseQ T.getLine)
  foldM_ (\t q -> (\(t', mi) -> maybe (return ()) (T.putStrLn . T.pack . show . max (qGetInt q)) mi >> return t') (runQuery q t)) Empty qs


Let's define the sum of two permutations p and q of numbers 0, 1, ..., (n - 1) as permutation , where Perm(x) is the x-th lexicographically permutation of numbers 0, 1, ..., (n - 1) (counting from zero), and Ord(p) is the number of permutation p in the lexicographical order.For example, Perm(0) = (0, 1, ..., n - 2, n - 1), Perm(n! - 1) = (n - 1, n - 2, ..., 1, 0)Misha has two permutations, p and q. Your task is to find their sum.Permutation a = (a0, a1, ..., an - 1) is called to be lexicographically smaller than permutation b = (b0, b1, ..., bn - 1), if for some k following conditions hold: a0 = b0, a1 = b1, ..., ak - 1 = bk - 1, ak < bk.

The first line contains an integer n (1 ≤ n ≤ 200 000). The second line contains n distinct integers from 0 to n - 1, separated by a space, forming permutation p. The third line contains n distinct integers from 0 to n - 1, separated by spaces, forming permutation q.

Print n distinct integers from 0 to n - 1, forming the sum of the given permutations. Separate the numbers by spaces.

NotePermutations of numbers from 0 to 1 in the lexicographical order: (0, 1), (1, 0).In the first sample Ord(p) = 0 and Ord(q) = 0, so the answer is .In the second sample Ord(p) = 0 and Ord(q) = 1, so the answer is .Permutations of numbers from 0 to 2 in the lexicographical order: (0, 1, 2), (0, 2, 1), (1, 0, 2), (1, 2, 0), (2, 0, 1), (2, 1, 0).In the third sample Ord(p) = 3 and Ord(q) = 5, so the answer is .

{-# OPTIONS_GHC -O2 -optc-O2 #-}
{-# LANGUAGE BangPatterns #-}
import Prelude hiding (getLine)
import Data.List (unfoldr)
import Control.Applicative ((<$>), (<*>))
import Data.ByteString (ByteString, getLine)
import qualified Data.ByteString.Char8 as B

import Data.Set (empty, insert, delete, elemAt, fromDistinctAscList, findIndex)

solve :: Int -> [Int] -> [Int] -> [Int]
solve n a b = foldr run (const []) ys $ fromDistinctAscList [0..n - 1]
    where
    xs = zipWith (+) (ord a) (ord b)
    ys = reverse $ foldr go (\_ _ -> []) xs 1 0
        where
        go x f k c = r: f (k + 1) i
            where (!i, !r) = (x + c) `divMod` k

    run x f s = i: f (delete i s)
        where !i = elemAt x s

    ord = ($ empty) . foldr go (const []) . reverse
        where
        go x f s = i: f t
            where
            !t = insert x s
            !i = findIndex x t

parse :: ByteString -> [Int]
parse = unfoldr $ B.readInt . B.dropWhile (== ' ')

main :: IO ()
main = do
    n:_ <- parse <$> getLine
    a <- parse <$> getLine
    getLine >>= putStr . unwords . map show . solve n a . parse


Valera considers a number beautiful, if it equals 2k or -2k for some integer k (k ≥ 0). Recently, the math teacher asked Valera to represent number n as the sum of beautiful numbers. As Valera is really greedy, he wants to complete the task using as few beautiful numbers as possible. Help Valera and find, how many numbers he is going to need. In other words, if you look at all decompositions of the number n into beautiful summands, you need to find the size of the decomposition which has the fewest summands.

The first line contains string s (1 ≤ |s| ≤ 106), that is the binary representation of number n without leading zeroes (n > 0).

Print a single integer — the minimum amount of beautiful numbers that give a total of n.

NoteIn the first sample n = 2 is a beautiful number.In the second sample n = 7 and Valera can decompose it into sum 23 + ( - 20).In the third sample n = 109 can be decomposed into the sum of four summands as follows: 27 + ( - 24) + ( - 22) + 20.

calc :: String -> Int
calc str = go 0 str
    where
    go acc [] = acc
    go acc (d:ds) | d == '0' = go acc $ dropWhile (== '0') ds
                  | d == '1' = case ds of
                                [] -> acc+1
                                ('0':ds') -> go (acc+1) ds'
                                ('1':ds') -> go (acc+1) $ roundup ds
    roundup ds = case dropWhile (== '1') ds of
                    [] -> "1"
                    (d:ds') -> '1' : ds'
main :: IO ()
main = do
    line <- getLine
    putStrLn $ show $ calc $ reverse line

f []           = 0
f ['1']        = 1
f ('0':xs)     = f xs
f ('1':'0':xs) = 1 + f xs
f ('1':xs)     = 1 + f ('1':(drop (ones+1) xs))
        where ones = length $ takeWhile (=='1') xs

main = do
  line <- getLine
  print . f $ reverse line


Lee just became Master in Codeforces, and so, he went out to buy some gifts for his friends. He bought $$$n$$$ integers, now it's time to distribute them between his friends rationally...Lee has $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ in his backpack and he has $$$k$$$ friends. Lee would like to distribute all integers in his backpack between his friends, such that the $$$i$$$-th friend will get exactly $$$w_i$$$ integers and each integer will be handed over to exactly one friend.Let's define the happiness of a friend as the sum of the maximum and the minimum integer he'll get.Lee would like to make his friends as happy as possible, in other words, he'd like to maximize the sum of friends' happiness. Now he asks you to calculate the maximum sum of friends' happiness.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 10^4$$$) — the number of test cases. Next $$$3t$$$ lines contain test cases — one per three lines. The first line of each test case contains two integers $$$n$$$ and $$$k$$$ ($$$1 \le n \le 2 \cdot 10^5$$$; $$$1 \le k \le n$$$) — the number of integers Lee has and the number of Lee's friends. The second line of each test case contains $$$n$$$ integers $$$a_1, a_2, \ldots, a_n$$$ ($$$-10^9 \le a_i \le 10^9$$$) — the integers Lee has. The third line contains $$$k$$$ integers $$$w_1, w_2, \ldots, w_k$$$ ($$$1 \le w_i \le n$$$; $$$w_1 + w_2 + \ldots + w_k = n$$$) — the number of integers Lee wants to give to each friend.  It's guaranteed that the sum of $$$n$$$ over test cases is less than or equal to $$$2 \cdot 10^5$$$.

For each test case, print a single integer — the maximum sum of happiness Lee can achieve.

NoteIn the first test case, Lee should give the greatest integer to the first friend (his happiness will be $$$17 + 17$$$) and remaining integers to the second friend (his happiness will be $$$13 + 1$$$).In the second test case, Lee should give $$$\{10, 10, 11\}$$$ to the first friend and to the second friend, so the total happiness will be equal to $$$(11 + 10) + (11 + 10)$$$In the third test case, Lee has four friends and four integers, it doesn't matter how he distributes the integers between his friends.

import Data.List
main = interact $ unlines . map show . process . map (sort . map read . words) . tail . lines
process :: [[Integer]] -> [Integer]
process [] = []
process (_:x:y:xs) = process' 0 (reverse x) (map fromIntegral y) : process xs
process' :: Integer -> [Integer] -> [Int] -> Integer
process' s [] _ = s
process' s _ [] = s
process' s xx@(x:xs) yy@(y:ys)
    | y == 1 = process' (s + 2 * x) xs ys
    | otherwise = process'' (s + sum (take k xx)) (drop k xx) yy
    where k = length yy
process'' :: Integer -> [Integer] -> [Int] -> Integer
process'' s _ [] = s
process'' s [] _ = s
process'' s xx (y:ys) = process'' (s + (xx !! (y-2))) (drop (y-1) xx) ys

import Data.List
main = interact $ unlines . map show . process . map (sort . map read . words) . tail . lines
process :: [[Int]] -> [Int]
process [] = []
process (_:x:y:xs) = process' 0 (reverse x) y : process xs
process' s [] _ = s
process' s _ [] = s
process' s xx@(x:xs) yy@(y:ys)
    | y == 1 = process' (s + 2 * x) xs ys
    | otherwise = process'' (s + sum (take k xx)) (drop k xx) yy
    where k = length yy
process'' s [] _ = s
process'' s _ [] = s
process'' s xx (y:ys) = process'' (s + (xx !! (y-2))) (drop (y-1) xx) ys


You are given an array $$$a_1, a_2, \dots , a_n$$$ consisting of integers from $$$0$$$ to $$$9$$$. A subarray $$$a_l, a_{l+1}, a_{l+2}, \dots , a_{r-1}, a_r$$$ is good if the sum of elements of this subarray is equal to the length of this subarray ($$$\sum\limits_{i=l}^{r} a_i = r - l + 1$$$).For example, if $$$a = [1, 2, 0]$$$, then there are $$$3$$$ good subarrays: $$$a_{1 \dots 1} = [1], a_{2 \dots 3} = [2, 0]$$$ and $$$a_{1 \dots 3} = [1, 2, 0]$$$.Calculate the number of good subarrays of the array $$$a$$$.

The first line contains one integer $$$t$$$ ($$$1 \le t \le 1000$$$) — the number of test cases. The first line of each test case contains one integer $$$n$$$ ($$$1 \le n \le 10^5$$$) — the length of the array $$$a$$$. The second line of each test case contains a string consisting of $$$n$$$ decimal digits, where the $$$i$$$-th digit is equal to the value of $$$a_i$$$. It is guaranteed that the sum of $$$n$$$ over all test cases does not exceed $$$10^5$$$.

For each test case print one integer — the number of good subarrays of the array $$$a$$$.

NoteThe first test case is considered in the statement.In the second test case, there are $$$6$$$ good subarrays: $$$a_{1 \dots 1}$$$, $$$a_{2 \dots 2}$$$, $$$a_{1 \dots 2}$$$, $$$a_{4 \dots 4}$$$, $$$a_{5 \dots 5}$$$ and $$$a_{4 \dots 5}$$$. In the third test case there is only one good subarray: $$$a_{2 \dots 6}$$$.

import Control.Monad
import Data.List

main :: IO ()
main = do
  t <- readLn
  replicateM_ t routine

routine :: IO ()
routine = do
  _ <- getLine
  as <- map (\c -> read [c]) <$> getLine
  print $ solve as

solve :: [Integer] -> Integer
solve as = sum as''
  where
    as' = map (\x -> x-1) as
    pref = scanl (+) 0 as'
    as'' =map ((\ l -> (l * (l - 1)) `div` 2) . fromIntegral . length) ((group.sort) pref)

import Data.List
import Data.Char
import Data.Int
getBlocks :: Eq a => [a] -> [Int64]
getBlocks [] = []
getBlocks [_] = [1]
getBlocks (x : y : t) = let ret = getBlocks (y : t) in
                        if x /= y
                        then (1 : ret)
                        else (head ret + 1 : tail ret)
solve :: [Int64] -> Int64
solve a = let prefixSum = scanl (+) 0 $ map pred a in
          let sortedPrefixSums = sort prefixSum in
          let blocks = getBlocks sortedPrefixSums in
          let countPairs x = (x * (x - 1)) `div` 2 in
          let pairsPerBlock = map countPairs blocks in
          sum pairsPerBlock
doCaseIO :: Int64 -> IO ()
doCaseIO 0 = return ()
doCaseIO t = do
             _ <- getLine -- ignore string length
             s <- getLine
             (putStrLn . show . solve . map (fromIntegral . digitToInt)) s
             doCaseIO (t - 1)
main :: IO ()
main = do
       t <- readLn :: IO Int64
       doCaseIO t

{-# LANGUAGE OverloadedStrings #-}

import Prelude
import Control.Monad
import Data.Functor
import Data.List
import Data.Maybe
import Data.Int
import Data.Char
import qualified Data.ByteString.Char8 as B8
import Text.Printf

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

solve :: String -> Int64
solve digitsString = pairsCount
    where
        pairsCount = sum $ map (\cnt -> (cnt * (cnt - 1)) `div` (2 :: Int64)) countGroups
        countGroups = map (\group -> (fromIntegral $ length group) :: Int64) . group $ sort digitSums
        digitSums = scanl' (+) 0 digits
        digits = map (\c -> (fromIntegral ((ord c) - (ord '0') - 1)) :: Int64) digitsString

main :: IO ()
main = do
    t <- readIntB8 <$> B8.getLine
    forM_ [1..t] $ \_ -> do
        n <- readIntB8 <$> B8.getLine
        digits <- (head . B8.words) <$> B8.getLine
        let answer = solve $ B8.unpack digits
        printf "%s\n" $ show answer

import Data.List
import Data.Int
import qualified Data.Array as A
import Data.Array((!))
import qualified Data.Map as M
import Numeric
import Data.Char

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

main = interact solve

type Input = [Int64]
type Output = Int64

solve :: String -> String
solve input = intercalate "\n" formattedOutputs
    where
        _:xs = words input
        inputs = inputParser xs
        outputs = map solver inputs
        formattedOutputs = map outputFormatter outputs

inputParser :: [String] -> [Input]
inputParser [] = []
inputParser (_:x:xs) = (readStr x):(inputParser xs)

readStr :: [Char] -> [Int64]
readStr = map (fromIntegral . Data.Char.digitToInt)

outputFormatter :: Output -> String
outputFormatter x = show x

type FoldState = (M.Map Int64 Int64, Int64)

solver :: Input -> Output
solver x =
    let
        sutr = map (\x -> x - 1) x
        sutr :: [Int64]
        cumul = scanl (+) 0 sutr
        cumul :: [Int64]
        (_, answer) = foldl' folder (M.empty, 0) cumul
    in answer

folder :: FoldState -> Int64 -> FoldState
folder (mm, cur) x
    | M.null mm = (M.insert x 1 mm, cur)
    | otherwise = (M.insertWith (+) x 1 mm, cur + (M.findWithDefault 0 x mm) )

import Control.Monad
import Data.List

main :: IO ()
main = do
  t <- readLn
  replicateM_ t routine

routine :: IO ()
routine = do
  _ <- getLine
  as <- map (\c -> read [c]) <$> getLine
  print $ solve as

solve :: [Int] -> Int
solve as = sum as''
  where
    as' = map (\x -> x-1) as
    pref = scanl (+) 0 as'
    as'' =map ((\ l -> (l * (l - 1)) `div` 2) . length) ((group.sort) pref)

import Data.List
import Data.Char
getBlocks :: Eq a => [a] -> [Int]
getBlocks [] = []
getBlocks [_] = [1]
getBlocks (x : y : t) = let ret = getBlocks (y : t) in
                        if x /= y
                        then (1 : ret)
                        else (head ret + 1 : tail ret)
solve :: [Int] -> Int
solve a = let prefixSum = scanl (+) 0 $ map pred a in
          let sortedPrefixSums = sort prefixSum in
          let blocks = getBlocks sortedPrefixSums in
          let countPairs x = (x * (x - 1)) `div` 2 in
          let pairsPerBlock = map countPairs blocks in
          sum pairsPerBlock
doCaseIO :: Int -> IO ()
doCaseIO 0 = return ()
doCaseIO t = do
             _ <- getLine -- ignore string length
             s <- getLine
             (putStrLn . show . solve . map digitToInt) s
             doCaseIO (t - 1)
main :: IO ()
main = do
       t <- readLn :: IO Int
       doCaseIO t

{-# LANGUAGE OverloadedStrings #-}

import Prelude
import Control.Monad
import Data.Functor
import Data.List
import Data.Maybe
import Data.Int
import Data.Char
import qualified Data.ByteString.Char8 as B8
import Text.Printf

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

solve :: String -> Int64
solve digitsString = pairsCount
    where
        pairsCount = sum $ map (\cnt -> (cnt * (cnt - 1)) `div` 2) countGroups
        countGroups = map (\group -> (fromIntegral $ length group) :: Int64) . group $ sort digitSums
        digitSums = (scanl' (\x y -> x + y - 1) 0 digits)
        digits = map (\c -> (ord c) - (ord '0')) digitsString

main :: IO ()
main = do
    t <- readIntB8 <$> B8.getLine
    forM_ [1..t] $ \_ -> do
        n <- readIntB8 <$> B8.getLine
        digits <- B8.getLine
        let answer = solve $ B8.unpack digits
        printf "%lld\n" answer

{-# LANGUAGE OverloadedStrings #-}

import Prelude
import Control.Monad
import Data.Functor
import Data.List
import Data.Maybe
import Data.Int
import Data.Char
import qualified Data.ByteString.Char8 as B8
import Text.Printf

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

solve :: String -> Int64
solve digitsString = pairsCount
    where
        pairsCount = sum $ map (\cnt -> (cnt * (cnt - 1)) `div` (2 :: Int64)) countGroups
        countGroups = map (\group -> (fromIntegral $ length group) :: Int64) . group $ sort digitSums
        digitSums = scanl' (+) 0 digits
        digits = map (\c -> (ord c) - (ord '0') - 1) digitsString

main :: IO ()
main = do
    t <- readIntB8 <$> B8.getLine
    forM_ [1..t] $ \_ -> do
        n <- readIntB8 <$> B8.getLine
        digits <- B8.getLine
        let answer = solve $ B8.unpack digits
        printf "%s\n" $ show answer

import Data.List
import Data.Int
import qualified Data.Array as A
import Data.Array((!))
import qualified Data.Map as M
import Numeric
import Data.Char

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

main = interact solve

type Input = [Int]
type Output = Int

solve :: String -> String
solve input = intercalate "\n" formattedOutputs
    where
        _:xs = words input
        inputs = inputParser xs
        outputs = map solver inputs
        formattedOutputs = map outputFormatter outputs

inputParser :: [String] -> [Input]
inputParser [] = []
inputParser (_:x:xs) = (readStr x):(inputParser xs)

readStr :: [Char] -> [Int]
readStr = map (Data.Char.digitToInt)

outputFormatter :: Output -> String
outputFormatter x = show x

type FoldState = (M.Map Int Int, Int)

solver :: Input -> Output
solver x =
    let
        sutr = map (\x -> x - 1) x
        sutr :: [Int]
        cumul = scanl (+) 0 sutr
        cumul :: [Int]
        (_, answer) = foldl' folder (M.empty, 0) cumul
    in answer

folder :: FoldState -> Int -> FoldState
folder (mm, cur) x
    | M.null mm = (M.insert x 1 mm, cur)
    | otherwise = (M.insertWith (+) x 1 mm, cur + (M.findWithDefault 0 x mm) )


Now it's time of Olympiads. Vanya and Egor decided to make his own team to take part in a programming Olympiad. They've been best friends ever since primary school and hopefully, that can somehow help them in teamwork.For each team Olympiad, Vanya takes his play cards with numbers. He takes only the cards containing numbers 1 and 0. The boys are very superstitious. They think that they can do well at the Olympiad if they begin with laying all the cards in a row so that:  there wouldn't be a pair of any side-adjacent cards with zeroes in a row;  there wouldn't be a group of three consecutive cards containing numbers one. Today Vanya brought n cards with zeroes and m cards with numbers one. The number of cards was so much that the friends do not know how to put all those cards in the described way. Help them find the required arrangement of the cards or else tell the guys that it is impossible to arrange cards in such a way.

The first line contains two integers: n (1 ≤ n ≤ 106) — the number of cards containing number 0; m (1 ≤ m ≤ 106) — the number of cards containing number 1.

In a single line print the required sequence of zeroes and ones without any spaces. If such sequence is impossible to obtain, print -1.

main = interact $ g.map read .words.head.lines

g (x:y:[])
  | a == "-1" && b == "-1" = a
  | a == "-1" = b
  | otherwise = a
  where a = f x y [] 0
        b = f x y [] 1
f 0 0 ans st = ans
f x y ans st
  | x < 0 || y < 0 = "-1"
  | x - y  >= -1 && st == 1 = f x (y-1) ('1':ans) 0
  | st == 1 = f x (y-2) ('1':'1':ans) 0
  | otherwise = f (x - 1) y ('0':ans) 1

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

import Data.List
import Data.Int
import Data.Bits
import Data.Maybe
import Data.Array.Unboxed
import Data.Array.ST
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b
swap (a,b) = (b,a)
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]
itof :: Int -> Double
itof = fromIntegral
defaultArray :: (IArray a e,Ix i) => e -> (i,i) -> [(i,e)] -> a i e
defaultArray = accumArray $ curry snd
flatten :: [(a,[(b,c)])] -> [((a,b),c)]
flatten = (=<<) $ uncurry $ fmap . first . (,)
stepM_ :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
stepM_ i judge incr step = sub i
    where
    sub i | judge i = step i >> sub (incr i) | otherwise = return ()
inf = maxBound `div` 2 :: Int

main = do
    (n,m) <- readIntPair
    if n > m + 1 || m > 2*(n+1) then
        print $ -1
    else if n == m + 1 then
        putStrLn $ take (n+m) $ cycle "01"
    else if m > 2 * n then
        putStrLn $ take (n+m) $ cycle "110"
    else do
        let k = m - n
        putStrLn $ take (3*k) (cycle "110") ++ take (m+n - 3*k) (cycle "10")

import qualified Data.ByteString.Char8 as B
main = B.putStrLn . B.concat . solve . map read . words =<< getLine
solve [n,m] | n > m+1 || m > 2*n+2 = [B.pack "-1"]
            | m == 2*n+2 = B.pack "11" : go n (m-2)
            | m == 2*n+1 = B.pack "1" : go n (m-1)
            | n == m+1 = go (n-1) m ++ [B.pack "0"]
            | otherwise = go n m
go n m = replicate (m-n) (B.pack "011") ++ replicate (2*n-m) (B.pack "01")

import Data.List

main=interact$f.map read.words
f[m,n]
  | n < m-1 || 2*(m+1) < n = "-1"
  | n+1 == m = take (n+m) $ '0':cycle"10"
  | n == m = take (n+m) $ cycle "10"
  | 2*(m+1) == n = take (n+m) $ cycle "110"
  | r <- n `mod`(m+1) = intercalate "0" $ replicate r "11" ++ replicate (m+1-r) "1"

main = interact $ g.map read .words.head.lines

g (x:y:[])
  | x >= y = f x y [] 0
  | otherwise = f x y [] 1

f 0 0 ans st = ans
f x y ans st
  | x < 0 || y < 0 = "-1"
  | x >= y && st == 1 = f x (y-1) ('1':ans) 0
  | st == 1 = f x (y-2) ('1':'1':ans) 0
  | otherwise = f (x - 1) y ('0':ans) 1

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

import Data.List
import Data.Int
import Data.Bits
import Data.Maybe
import Data.Array.Unboxed
import Data.Array.ST
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

readInt = fromJust . fmap fst . B.readInt
readInts = map readInt . B.words <$> B.getLine
readIntPair = l2p . map readInt . take 2 . B.words <$> B.getLine
readLns :: Read a => IO [a]
readLns = map read . words <$> getLine
cmpFst (a,_) (b,_) = compare a b
cmpSnd (_,a) (_,b) = compare a b
cmpLen a b = length a `compare` length b
swap (a,b) = (b,a)
l2p (a:b:_) = (a,b)
p2l (a,b) = [a,b]
itof :: Int -> Double
itof = fromIntegral
defaultArray :: (IArray a e,Ix i) => e -> (i,i) -> [(i,e)] -> a i e
defaultArray = accumArray $ curry snd
flatten :: [(a,[(b,c)])] -> [((a,b),c)]
flatten = (=<<) $ uncurry $ fmap . first . (,)
stepM_ :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
stepM_ i judge incr step = sub i
    where
    sub i | judge i = step i >> sub (incr i) | otherwise = return ()
inf = maxBound `div` 2 :: Int

main = do
    (n,m) <- readIntPair
    if n > m + 1 || m > 2*(n+1) then
        print $ -1
    else if n == m + 1 then
        putStrLn $ take (n+m) $ cycle "01"
    else if m == 2 * (n+1) then
        putStrLn $ take (n+m) $ cycle "110"
    else do
        let k = m - n
        putStrLn $ take (3*k) (cycle "110") ++ take (m+n - 3*k) (cycle "10")

import qualified Data.ByteString.Char8 as B
main = B.putStrLn . B.concat . solve . map read . words =<< getLine
solve [n,m] | n > m+1 || m > 2*n+2 = [B.pack "-1"]
            | m == 2*n+2 = B.pack "11" : go n (m-2)
            | n == m+1 = go (n-1) m ++ [B.pack "0"]
            | otherwise = go n m
go n m = replicate (m-n) (B.pack "011") ++ replicate (2*n-m) (B.pack "01")


ZS the Coder and Chris the Baboon are travelling to Udayland! To get there, they have to get on the special IOI bus. The IOI bus has n rows of seats. There are 4 seats in each row, and the seats are separated into pairs by a walkway. When ZS and Chris came, some places in the bus was already occupied.ZS and Chris are good friends. They insist to get a pair of neighbouring empty seats. Two seats are considered neighbouring if they are in the same row and in the same pair. Given the configuration of the bus, can you help ZS and Chris determine where they should sit?

The first line of the input contains a single integer n (1 ≤ n ≤ 1000) — the number of rows of seats in the bus. Then, n lines follow. Each line contains exactly 5 characters, the first two of them denote the first pair of seats in the row, the third character denotes the walkway (it always equals '|') and the last two of them denote the second pair of seats in the row.  Each character, except the walkway, equals to 'O' or to 'X'. 'O' denotes an empty seat, 'X' denotes an occupied seat. See the sample cases for more details.

If it is possible for Chris and ZS to sit at neighbouring empty seats, print "YES" (without quotes) in the first line. In the next n lines print the bus configuration, where the characters in the pair of seats for Chris and ZS is changed with characters '+'. Thus the configuration should differ from the input one by exactly two charaters (they should be equal to 'O' in the input and to '+' in the output). If there is no pair of seats for Chris and ZS, print "NO" (without quotes) in a single line. If there are multiple solutions, you may print any of them.

NoteNote that the following is an incorrect configuration for the first sample case because the seats must be in the same pair.O+|+XXO|XXOX|OOXX|OXOO|OOOO|XX

import Control.Monad

-- plain string for output
newtype PlainString = PlainString String
instance Show PlainString where
  show (PlainString s) = s

main :: IO()
main = do
	input <- getLine
	let rows = read input :: Int
	bus <- replicateM (rows) getLine
	let found = findPlace bus 0

	if found >= 0
		then do
			printPlain "YES"
			printPlace bus 0 found
		else printPlain "NO"

printPlain :: [Char] -> IO()
printPlain str = print (PlainString str)

printSit :: [Char] -> IO()
printSit curRow
	| curRow !! 0 == 'O' && curRow !! 1 == 'O' = printPlain ("++" ++ (drop 2 curRow))
	| curRow !! 3 == 'O' && curRow !! 4 == 'O' = printPlain ((take 3 curRow) ++ "++")

printPlace :: [[Char]] -> Int -> Int -> IO()
printPlace [] _ _ = return ()
printPlace (curRow:rest) curRowNum sitNum
	| curRowNum == sitNum = do
				printSit curRow
				printPlace rest (curRowNum + 1) sitNum
	| otherwise = do 	printPlain curRow
				printPlace rest (curRowNum + 1) sitNum

findPlace :: [[Char]] -> Int -> Int
findPlace [] _ = -1
findPlace (curRow:rest) curRowNum
	| curRow !! 0 == 'O' && curRow !! 1 == 'O' = curRowNum
	| curRow !! 3 == 'O' && curRow !! 4 == 'O' = curRowNum
	| otherwise = findPlace rest (curRowNum + 1)

import Control.Monad
import Data.List (isInfixOf)

rep_f :: [Char] -> [Char]
rep_f ('O':'O':x) = ['+', '+']++x
rep_f (c:x) = c:rep_f x
rep_f [] = []

print_f :: [[Char]] -> [Bool] -> Bool -> IO ()
print_f (h:t) (True:t2) True = do
  putStrLn (rep_f h)
  print_f t t2 False
print_f (h:t) (_:t2) is_f = do
  putStrLn h
  print_f t t2 is_f
print_f _ _ _ = return ()

main :: IO ()
main = do
  n_s <- getLine
  seats <- replicateM (read n_s) getLine
  let free = (map (\x -> isInfixOf "OO" x) seats)
  if foldr (||) False free
    then do
      putStrLn "YES"
      print_f seats free True
    else putStrLn "NO"

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.List
import Data.Maybe
import Data.Char
import qualified Data.ByteString.Char8 as B
import Text.Printf

readInt = ( readLn :: IO Int )
readInts = map ( read :: String -> Int ) . words <$> getLine

getList = map ( fst . fromJust . B.readInt ) . B.words <$> B.getLine

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

main = do
	getLine
	seats <- getContents
	let
		res = solve seats
		ok = isJust res
	putStrLn $ which "YES" "NO" ok
	when ok $ do
		putStrLn $ fromJust res

solve [c] = Nothing
solve ( c1 : c2 : s )
	| c1 == 'O' && c2 == 'O' = Just $ "++" ++ s
	| otherwise = ( c1 : ) <$> solve ( c2 : s )

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -O2 #-}

import Control.Applicative
import Control.Monad hiding ((<$!>))
import Control.Monad.ST.Safe
import Control.Monad.State hiding ((<$!>))
import Data.Array
-- import Data.Array.IArray
import Data.Array.IO.Safe
import Data.Array.MArray.Safe
import Data.Array.ST.Safe
-- import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Builder as BB
import Data.Char
import qualified Data.Foldable as F
import Data.Function
import Data.Graph
import Data.Int
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- import Data.Tree
import Data.Tuple
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-- import Debug.Trace
import System.IO

-- getInts = fmap (map read . words) getLine
getInts = unfoldr (B.readInt . B.dropWhile isSpace) <$> B.getLine

replace a b t = f t []
  where
    f t r =
      case stripPrefix a t of
        Nothing -> f (tail t) $ (head t):r
        Just t' -> (reverse r) ++ b ++ t'

main = do
  getLine
  s <- getContents

  if "OO" `isInfixOf` s
    then do
      putStrLn "YES"
      putStr $ replace "OO" "++" s
    else
      putStrLn "NO"

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Data.Functor
import Control.Monad
import Control.Monad.ST.Safe
import Control.Arrow
import Data.Array
import Data.Array.ST.Safe
import Data.STRef
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as C
main=   readsolveprint
readsolveprint::IO()
readsolveprint =  getLine >>= \n -> solve =<< (forM [1..read n] $ \i-> C.splitWith (=='|') <$> C.getLine)
solve xs = mapM_  (\as->C.putStrLn $ C.intercalate (C.singleton '|') as) $ filter (/=[]) $ slv1 $ break (\a-> a==C.pack "OO" || a==C.pack "OO\r") $ concat xs
slv1 (xs,[]) =[[C.pack "NO"]]
slv1 (xs,ys)= let zs = xs++[C.pack "++"]++tail ys in [[C.pack "YES"]]++zipWith (\a b -> if a `mod` 2 /=0 then b else [] ) [1..] (zipWith (\a b -> a:b:[]) zs (tail zs))

import Control.Monad

main = getLine >>= getLines . read >>= putStrLn . decide . parse

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

parse :: [String] -> ([String], Bool)
parse rows = foldr parse' ([], False) rows
  where parse' row (rows, True) = (row:rows, True)
        parse' ('O':'O':xs) (rows, _) = (('+':'+':xs):rows, True)
        parse' (a:b:_:"OO") (rows, _) = ((a:b:"|++"):rows, True)
        parse' row (rows, _) = (row:rows, False)

decide :: ([String], Bool) -> String
decide (_, False) = "NO"
decide (rows, _) = unlines $ "YES":rows

import Text.Printf
import Data.List
import Data.Functor
import Control.Applicative
import Prelude
import Control.Monad
import Data.Maybe
import Data.Function
import Data.Array
import qualified Data.ByteString.Char8 as B8
import Data.Foldable (foldr')

readInt :: String -> Int
readInt = Prelude.read

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

solve :: [String] -> Maybe [String]
solve [] = Nothing
solve bus @ (f : other)
    | "OO" `isSuffixOf` f = Just ((take 3 f ++ "++") : other)
    | "OO" `isInfixOf` f = Just (("++" ++ drop 2 f) : other)
    | otherwise = (f :) <$> solve other

main :: IO ()
main = do
    n <- readInt <$> getLine
    bus <- replicateM n getLine
    let answer = unlines . ("YES" :) <$> solve bus
    printf "%s" $ fromMaybe "NO" answer

import Control.Monad(replicateM)
import Data.Functor ((<$>))

solve :: [String] -> Maybe [String]
solve [] = Nothing
solve (s:t)
    | take 2 s == "OO" = Just (("++" ++ drop 2 s) : t)
    | drop 3 s == "OO" = Just ((take 3 s ++ "++") : t)
    | otherwise = (s :) <$> solve t

main :: IO()
main = do
    n <- readLn :: IO Int
    s <- replicateM n getLine
    case solve s of
        Just s' -> do
            putStrLn "YES"
            putStr (unlines s')
        Nothing ->
            putStrLn "NO"

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

process2::String->(String,Int)
process2 s | take 2 s =="OO" = ("++" ++ drop 2 s,1)
           | drop 3 s =="OO" = (take 3 s ++ "++" ,1)
           | otherwise = (s,0)

process1::[String]->[String]
process1 s = s3
  where s1 =  map process2 s
        s2 = length $ takeWhile (\z-> snd z <1) s1
        s3 = (take (s2+1)  (map fst s1)) ++ (drop (s2+1) s)

process::[String]->[String]
process s | x==[] && y==[] = ["NO"]
          | otherwise = ["YES"] ++ ( process1 s)
  where x = take 1 $ filter (\z-> take 2 z =="OO" ) s
        y = take 1 $ filter (\z-> drop 3 z =="OO" ) s

main = do
  getLine
  s<- lines <$> getContents
  mapM_ putStrLn $  process s

module Main where

checkRow :: (Bool, [String]) -> String -> (Bool, [String])
checkRow (False, ys) ('O':'O':'|':a:b:"") = (True, ys ++ ['+':'+':'|':a:b:""])
checkRow (False, ys) (a:b:'|':'O':'O':"") = (True, ys ++ [a:b:'|':'+':'+':""])
checkRow (b, ys) s                        = (b, ys ++ [s])

render :: (Bool, [String]) -> String
render (True, ys) = "YES\n" ++ unlines ys
render (False, _) = "NO"

solve :: String -> String
solve input = let
    (header:body) = lines input
    n = read header
    ys = take n body
    in render $ foldl checkRow (False, []) ys

main :: IO ()
main = interact solve

{-# LANGUAGE FlexibleInstances #-}

module Main where

import           Control.Monad
import           Data.List     (intercalate)

checkRow :: (Bool, [String]) -> String -> (Bool, [String])
checkRow (False, ys) ('O':'O':'|':a:b:"") = (True, ys ++ ['+':'+':'|':a:b:""])
checkRow (False, ys) (a:b:'|':'O':'O':"") = (True, ys ++ [a:b:'|':'+':'+':""])
checkRow (b, ys) s                        = (b, ys ++ [s])

render :: (Bool, [String]) -> String
render (False, _) = "NO"
render (True, ys) = "YES\n" ++ intercalate "\n" ys

solve :: [String] -> String
solve ys = render $ foldl checkRow (False, []) ys

main :: IO ()
main = do
    n <- readLn
    xs <- replicateM n getLine
    putStrLn $ solve xs

module Main where
  import Data.List
  import Control.Monad
  import Data.Array
  import qualified Data.Set as S

  toArray :: [a] -> Array Int a
  toArray xs =
    let ls = length xs - 1
        in array (0, ls) $ zip [0..ls] xs

  readInt :: String -> Int
  readInt s = read s :: Int

  readMultilineInput :: Int -> (String -> IO a) -> IO [a]
  readMultilineInput n transformer = replicateM n (getLine >>= transformer)

  elemSet :: (Ord a) => a -> S.Set a -> Bool
  elemSet elem sets =
    let found = elem `S.lookupIndex` sets
        in toBool found
        where
          toBool :: Maybe Int -> Bool
          toBool (Just _) = True
          toBool Nothing = False

  considerSeats :: String -> (Bool, Bool)
  considerSeats ('O':'O':_) = (True, False)
  considerSeats (_:_:'|':'O':'O':_) = (False, True)
  considerSeats _ = (False, False)

  transform :: (Bool, Bool) -> String -> String
  transform (True, False) (a:b:s) = '+':'+':s
  transform (False, True) (a:b:s) =  a:b:"|++"

  reshow :: Bool -> [((Bool, Bool), String)] -> [String] -> [String]
  reshow _ [] accumulator = accumulator
  reshow True ((_, s):xs) accumulator                   = reshow True xs (s:accumulator)
  reshow False ((pred@(True, False), s):xs) accumulator = reshow True xs ((transform pred s):accumulator)
  reshow False ((pred@(False, True), s):xs) accumulator = reshow True xs ((transform pred s):accumulator)
  reshow False ((pred@(False, False), s):xs) accumulator  = reshow False xs (s:accumulator)

  hasTrue :: (Bool, Bool) -> Bool
  hasTrue (False, False) = False
  hasTrue _ = True

  main :: IO()
  main = do
    n <- getLine >>= return . readInt
    seats <- readMultilineInput n return
    let consideredSeats = considerSeats `map` seats
        hasAns = any hasTrue consideredSeats
        ans = consideredSeats `zip` seats
        action = case hasAns of
          False -> putStrLn "NO"
          True -> do
            putStrLn "YES"
            mapM_ putStrLn $ reverse $ reshow False ans []
    -- putStrLn $ show ans
    action

import Control.Monad( replicateM)
import Data.List( intercalate, elemIndex)
import Data.Maybe( fromJust)
main = do
    nmRows <- readLn
    let rowseat = getLine >>= return . (read::String->Rowseat)
	rowseat::IO Rowseat
    rowseatS <- replicateM nmRows rowseat
    let tryshit::Pairseat->Pairseat
	tryshit ps = case ps of
		    Empty   -> OK
		    ps	    -> ps
	tryrow (Rowseat (lp,rp)) = Rowseat (tryshit lp, tryshit rp)
	result = map tryrow rowseatS
	resultBusStr = intercalate "\n" $ map show result
	cleanse str =
	  let
	    point = fromJust $ elemIndex '+' str
	    (selectedPart, normalPart) = splitAt (point+2) str
	    cleansed = map (\c->if c=='+' then 'O' else c) normalPart
	  in
	    selectedPart++cleansed
    if elem '+' resultBusStr
	then putStrLn "YES" >> putStr (cleanse resultBusStr)
	else putStr "NO"

data Pairseat = Empty | Full | LEmpty | REmpty | OK
instance Read Pairseat where
    readsPrec _ str =
	tryParse [("OO",Empty), ("OX",LEmpty),
		    ("XO",REmpty), ("XX",Full)]
      where
	tryParse [] = []
	tryParse ((attempt, result):xs) =
	    if str == attempt
		then [(result, [])]
		else tryParse xs

instance Show Pairseat where
    show Empty = "OO"
    show LEmpty = "OX"
    show REmpty = "XO"
    show Full = "XX"
    show OK = "++"

data Rowseat = Rowseat (Pairseat,Pairseat)
instance Read Rowseat where
    readsPrec _ str =
	[(Rowseat (read [str!!0,str!!1], read [str!!3,str!!4]), [])]
instance Show Rowseat where
    show (Rowseat (lp,rp)) = show lp ++ "|" ++ show rp

import System.IO (interact)
import Data.List (find, isInfixOf)
import Control.Applicative ((<$>), (<*>))

g :: [String] -> Maybe [String]
g [] = Nothing
g (x:xs) = case x of
                'O':'O':ys -> Just $ ("++" ++ ys):xs
                a:b:c:"OO" -> Just $ (a:b:c:"++"):xs
                _ -> (:) <$> Just x <*> g xs

f :: [String] -> [String]
f x = case y of
        Nothing -> "NO":[]
        Just xs -> "YES":xs
  where y = g x

main = do
  _ <- getLine
  interact (unlines . f . lines)

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

process [] _ = putStrLn "NO"

process (s:ss) y | q1 || q2 = do
				putStrLn "YES"
				mapM_ putStrLn $ reverse y
				putStrLn $ if q1 then  ("++"++ (drop 2 s)) else ((take 3 s)++"++")

				mapM_ putStrLn $ ss

		 | otherwise = process ss (s:y)
	 where 	q1=isPrefixOf "OO" s
	 	q2=isSuffixOf "OO" s

main= do
		n<- read <$> getLine ::IO Int
		s<- replicateM n getLine
		process s []

import Control.Applicative
import Control.Monad

fixLine [] = Nothing
fixLine (l:ls) = case l of
  ['O','O', _ , _ , _ ] -> Just $ ("++"++ drop 2 l) : ls
  [ _ , _ , _ ,'O','O'] -> Just $ (take 3 l ++"++") : ls
  _ -> (l:) <$> (fixLine ls)

main = do
    n <- read <$> getLine
    lines <- replicateM n getLine
    case fixLine lines of
      Just x -> do putStrLn "YES"
                   mapM_ putStrLn x
      Nothing -> putStrLn "NO"

--ghc 7.10

import Data.List

findSeat :: [String] -> (Bool, [String])
findSeat [] = (False, [])
findSeat (row:rows)
    | lPair == "OO" = (True, ("++|" ++ rPair) : rows)
    | rPair == "OO" = (True, (lPair ++ "|++") : rows)
    | otherwise = (tr, row:rows')
    where
        (tr,rows') = findSeat rows
        [lPair,c:rPair] = groupBy (\a b -> b /= '|') row

main = do
    nStr <- getLine
    contents <- getContents
    let rows = lines contents
    let (tr,rows') = findSeat rows
    if tr
        then do
            putStrLn "YES"
            putStrLn . unlines $ rows'
        else putStrLn "NO"

calc :: [String] -> ([String], Bool)
calc []                       = ([], False)
calc (['O','O','|',c,d]:rest) = (("++|" ++ [c , d]):rest, True)
calc ([a,b,'|','O','O']:rest) = (([a, b] ++ "|++"):rest, True)
calc (row:rest)               = (row:next, b)
  where
    (next, b) = calc rest

process :: String -> String
process str =
  let (header : body) = lines str
      n               = read header
      bus             = take n body
      (newBus, can)   = calc bus
  in
    if can then "YES\n" ++ unlines newBus else "NO"

main :: IO ()
main = interact process

main :: IO ()
main = do
        _:rows <- getLoS
        putStr $ unlines . printBus . busTransform $ rows

rowTransform :: String -> (Bool, String)
rowTransform ['O','O',a,b,c] = (True, ['+','+',a,b,c])
rowTransform [a,b,c, 'O','O'] = (True, [a,b,c, '+', '+'])
rowTransform row = (False, row)

busTransform :: [String] -> (Bool, [String])
busTransform [] = (False, [])
busTransform (x:xs)
    | success = (True, xTransformed : xs)
    | otherwise = (success', x : xs')
                        where
                            (success, xTransformed) = rowTransform x
                            (success', xs') = busTransform xs

printBus :: (Bool, [String])->[String]
printBus (True, xs) = "YES" : xs
printBus (False, xs) = ["NO"]

-- Boilerplate
getLoS :: IO [String]
getLoS = fmap lines getContents

getMoS :: IO [[String]]
getMoS = fmap (fmap words) getLoS

tokenizeLtM :: [String] -> [[String]]
tokenizeLtM = fmap words

main :: IO ()
main = do
        _ <- getLine
        interact $ unlines . render . busT . lines

busT :: [String] -> Maybe [String]
busT [] = Nothing
busT (x:xs) = case x of
                ['O','O',a,b,c] -> Just $ ['+','+',a,b,c]:xs
                [a,b,c, 'O','O'] -> Just $ [a,b,c, '+', '+']:xs
                _ -> fmap (x:) (busT  xs)

render :: Maybe [String] -> [String]
render (Just xs) = "YES" : xs
render _ = ["NO"]

import Control.Monad
import Data.List (isInfixOf)

rep_f :: [Char] -> [Char]
rep_f ('O':'O':x) = ['+', '+']++x
rep_f (_:x) = rep_f x
rep_f [] = []

print_f :: [[Char]] -> [Bool] -> Bool -> IO ()
print_f (h:t) (True:t2) True = do
  putStrLn (rep_f h)
  print_f t t2 False
print_f (h:t) (_:t2) is_f = do
  putStrLn h
  print_f t t2 is_f
print_f _ _ _ = return ()

main :: IO ()
main = do
  n_s <- getLine
  seats <- replicateM (read n_s) getLine
  let free = (map (\x -> isInfixOf "OO" x) seats)
  if foldr (||) False free
    then do
      putStrLn "YES"
      print_f seats free True
    else putStrLn "NO"

import Control.Monad
import Data.List (isInfixOf)

rep_f :: [Char] -> [Char]
rep_f ('O':'O':x) = ['+', '+']++x
rep_f (_:x) = rep_f x
rep_f [] = []

print_f :: [[Char]] -> [Bool] -> Bool -> IO ()
print_f (h:t) (True:t2) True = do
  putStrLn (rep_f h)
  print_f t t2 False
print_f (h:t) (_:t2) is_f = do
  putStrLn h
  print_f t t2 is_f
print_f _ _ _ = return ()

main :: IO ()
main = do
  n_s <- getLine
  seats <- replicateM (read n_s) getLine
  let free = (map (\x -> isInfixOf "OO" x) seats)
  if foldr (||) False free
    then print_f seats free True
    else putStrLn "NO"

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Data.Functor
import Control.Monad
import Control.Monad.ST.Safe
import Control.Arrow
import Data.Array
import Data.Array.ST.Safe
import Data.STRef
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as C
main=   readsolveprint
readsolveprint::IO()
readsolveprint =  getLine >>= \n -> solve =<< (forM [1..read n] $ \i-> C.splitWith (=='|') <$> C.getLine)
solve xs = mapM_  (\as->C.putStrLn $ C.intercalate (C.singleton '|') as) $ filter (/=[]) $ slv1 $ break (==C.pack "OO") $ concat xs
slv1 (xs,[]) =[[C.pack "NO"]]
slv1 (xs,ys)= let zs = xs++[C.pack "++"]++tail ys in [[C.pack "YES"]]++zipWith (\a b -> if a `mod` 2 /=0 then b else [] ) [1..] (zipWith (\a b -> a:b:[]) zs (tail zs))

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

process2::String->(String,Int)
process2 s | take 2 s =="XX" = ("++" ++ drop 2 s,1)
           | drop 3 s =="XX" = (take 3 s ++ "++" ,1)
           | otherwise = (s,0)

process1::[String]->[String]
process1 s = s3
  where s1 =  map process2 s
        s2 = length $ takeWhile (\z-> snd z <1) s1
        s3 = (take (s2+1)  (map fst s1)) ++ (drop (s2+1) s)

process::[String]->[String]
process s | x==[] && y==[] = ["NO"]
          | otherwise = ["YES"] ++ ( process1 s)
  where x = take 1 $ filter (\z-> take 2 z =="XX" ) s
        y = take 1 $ filter (\z-> drop 3 z =="XX" ) s

main = do
  getLine
  s<- lines <$> getContents
  mapM_ putStrLn $  process s

module Main where

checkRow :: (Bool, [String]) -> String -> (Bool, [String])
checkRow (False, ys) ('O':'O':'|':a:b:"") = (True, ys ++ ['+':'+':'|':a:b:""])
checkRow (False, ys) (a:b:'|':'O':'O':"") = (True, ys ++ [a:b:'|':'+':'+':""])
checkRow (b, ys) s                        = (b, ys ++ [s])

render :: (Bool, [String]) -> String
render (True, ys) = "YES\n" ++ unlines ys
render (False, _) = "NO"

solve :: String -> String
solve input = let
    (header:body) = lines input
    n = read header
    ys = take n body
    in render (False, ys)

main :: IO ()
main = interact solve

import Control.Monad( replicateM)
import Data.List( intercalate)
main = do
    nmRows <- readLn
    let rowseat = getLine >>= return . (read::String->Rowseat)
	rowseat::IO Rowseat
    rowseatS <- replicateM nmRows rowseat
    let tryshit::Pairseat->Pairseat
	tryshit ps = case ps of
		    Empty   -> Selected
		    ps	    -> ps
	tryrow (Rowseat (lp,rp)) = Rowseat (tryshit lp, tryshit rp)
	result = map tryrow rowseatS
	resultBusStr = intercalate "\n" $ map show result
    if elem '+' resultBusStr
	then putStrLn "YES" >> putStr resultBusStr
	else putStr "NO"

data Pairseat = Empty | Full | LEmpty | REmpty | Selected
instance Read Pairseat where
    readsPrec _ str =
	tryParse [("OO",Empty), ("OX",LEmpty),
		    ("XO",REmpty), ("XX",Full)]
      where
	tryParse [] = []
	tryParse ((attempt, result):xs) =
	    if str == attempt
		then [(result, [])]
		else tryParse xs

instance Show Pairseat where
    show Empty = "OO"
    show LEmpty = "OX"
    show REmpty = "XO"
    show Full = "XX"
    show Selected = "++"

data Rowseat = Rowseat (Pairseat,Pairseat)
instance Read Rowseat where
    readsPrec _ str =
	[(Rowseat (read [str!!0,str!!1], read [str!!3,str!!4]), [])]
instance Show Rowseat where
    show (Rowseat (lp,rp)) = show lp ++ "|" ++ show rp

main :: IO ()
main = do
        _ <- getLine
        interact $ unlines . render . busT . lines

busT :: [String] -> Maybe [String]
busT [] = Nothing
busT (x:xs) = case x of
                ['O','O',a,b,c] -> Just $ ['O','O',a,b,c]:xs
                [a,b,c, 'O','O'] -> Just $ [a,b,c, '+', '+']:xs
                _ -> fmap (x:) (busT  xs)

render :: Maybe [String] -> [String]
render (Just xs) = "YES" : xs
render _ = ["NO"]


You are given n points on a line with their coordinates xi. Find the point x so the sum of distances to the given points is minimal.

The first line contains integer n (1 ≤ n ≤ 3·105) — the number of points on the line. The second line contains n integers xi ( - 109 ≤ xi ≤ 109) — the coordinates of the given n points.

Print the only integer x — the position of the optimal point on the line. If there are several optimal points print the position of the leftmost one. It is guaranteed that the answer is always the integer.

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

readIntList = fmap ((map fn) . B.words) B.getLine :: IO [Int]
 where fn x = let Just (y,_) = B.readInt x in y

main = do
    n <- readLn :: IO Int
    a <- fmap sort readIntList
    print $ if even n then a!!((n `div` 2)-1) else a!!(n `div` 2)

import Data.List
import qualified Data.Maybe as M
import qualified Data.ByteString.Char8 as B

f :: [String] -> [Int]
f = map read

main = do
	getLine
	t <- B.getLine
	let l = map (fst . M.fromJust . B.readInt) $ B.words $ t
	let q = sort $ l
	let q2 = if odd (length q)
				then q !! (length q `div` 2)
				else q !! (length q `div` 2 - 1)
	print q2

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

readIntList = fmap ((map fn) . B.words) B.getLine :: IO [Int]
 where fn x = let Just (y,_) = B.readInt x in y

main = do
    [n] <- readIntList
    a <- readIntList
    print $ if even n then a!!((n `div` 2)-1) else a!!(n `div` 2)

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

readIntList = fmap ((map fn) . B.words) B.getLine :: IO [Int]
 where fn x = let Just (y,_) = B.readInt x in y

main = do
    n <- readLn :: IO Int
    a <- readIntList
    print $ if even n then a!!((n `div` 2)-1) else a!!(n `div` 2)

import Data.List

main = do
    n <- readLn :: IO Int
    a <- fmap (sort . (map read) . words) getLine :: IO [Int]
    print $ a!!((n `div` 2)-1)

import Data.List

f :: [String] -> [Int]
f = map read
g :: (Num a) => [a] -> a
g q = sum $ take 2 $ (drop (length q `div` 2 - 1) q)

main = do
	getLine
	t <- getLine
	let q = map fromIntegral $ sort $ f $ words t :: [Double]
	let q2 = if odd (length q)
				then q !! (length q `div` 2)
				else
					g q/2
	print $ round (subtract 0.00000000001 q2)

calc x = round $ sum x / (fromIntegral . length $ x)
toNums = map read . words

main = do
	getLine
	t <- getLine
	print $ calc $ toNums t


A sequence of $$$n$$$ integers is called a permutation if it contains all integers from $$$1$$$ to $$$n$$$ exactly once.Given two integers $$$n$$$ and $$$k$$$, construct a permutation $$$a$$$ of numbers from $$$1$$$ to $$$n$$$ which has exactly $$$k$$$ peaks. An index $$$i$$$ of an array $$$a$$$ of size $$$n$$$ is said to be a peak if $$$1 < i < n$$$ and $$$a_i \gt a_{i-1}$$$ and $$$a_i \gt a_{i+1}$$$. If such permutation is not possible, then print $$$-1$$$.

The first line contains an integer $$$t$$$ ($$$1 \leq t \leq 100$$$) — the number of test cases. Then $$$t$$$ lines follow, each containing two space-separated integers $$$n$$$ ($$$1 \leq n \leq 100$$$) and $$$k$$$ ($$$0 \leq k \leq n$$$) — the length of an array and the required number of peaks.

Output $$$t$$$ lines. For each test case, if there is no permutation with given length and number of peaks, then print $$$-1$$$. Otherwise print a line containing $$$n$$$ space-separated integers which forms a permutation of numbers from $$$1$$$ to $$$n$$$ and contains exactly $$$k$$$ peaks.  If there are multiple answers, print any.

NoteIn the second test case of the example, we have array $$$a = [2,4,1,5,3]$$$. Here, indices $$$i=2$$$ and $$$i=4$$$ are the peaks of the array. This is because $$$(a_{2} \gt a_{1} $$$, $$$a_{2} \gt a_{3})$$$ and $$$(a_{4} \gt a_{3}$$$, $$$a_{4} \gt a_{5})$$$.

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

import qualified Data.Array as A

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

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

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

intNat :: Natural -> Int
intNat = fromInteger . toInteger

solve :: Natural -> Natural -> Maybe [Natural]
solve n k
	| n <= 2*k = Nothing
	| otherwise = Just $ fmap (+1) $ fmap aux [0..(n-1)]
	where
		aux i
			| i == 0 = 0
			| i > 2*k = i
			| mod i 2 == 0 = i - 1
			| mod i 2 == 1 = i + 1

showR :: Maybe [Natural] -> String
showR (Just list) = foldr (\i s -> show i ++ " " ++ s) [] list
showR Nothing = "-1"

main = do
	t <- getLine >>= return . read :: IO Natural
	replicateM (intNat t) $ do
		[n, k] <- getLine >>= return . (fmap read) . words :: IO [Natural]
		putStrLn $ showR $ solve n k

import qualified Data.Set as Set
import Data.List
import Control.Monad
import Data.Char

readInts = fmap (map read.words) getLine :: IO [Int]
printArray [] = ""
printArray (x:xs) = show(x) ++" " ++ printArray xs

combine [] b = b
combine a [] = a
combine (x:a) (y:b) = [x,y] ++ combine a b

printS = do
    [n,k]<-readInts
    if k + 1 > div (n+1) 2 then putStrLn"-1"
    else do
        let a = take (n - k) [1..n]
            b = reverse $ drop (n-k) [1..n]
        putStrLn $ printArray $ combine a b

main = do
    t<-readLn
    replicateM_ t printS

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

import qualified Data.Array as A

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

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

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

intNat :: Natural -> Int
intNat = fromInteger . toInteger

solve :: Natural -> Natural -> Maybe [Natural]
solve n k
	| n < 2*k = Nothing
	| otherwise = Just $ fmap (+1) $ fmap aux [0..(n-1)]
	where
		aux i
			| i == 0 = 0
			| i > 2*k = i
			| mod i 2 == 0 = i - 1
			| mod i 2 == 1 = i + 1

showR :: Maybe [Natural] -> String
showR (Just list) = foldr (\i s -> show i ++ " " ++ s) [] list
showR Nothing = "-1"

main = do
	t <- getLine >>= return . read :: IO Natural
	replicateM (intNat t) $ do
		[n, k] <- getLine >>= return . (fmap read) . words :: IO [Natural]
		putStrLn $ showR $ solve n k

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

import qualified Data.Array as A

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

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

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

intNat :: Natural -> Int
intNat = fromInteger . toInteger

solve :: Natural -> Natural -> Maybe [Natural]
solve n k
	| 2*k >= n = Nothing
	| otherwise = Just $ fmap (+1) $ fmap aux [0..(n-1)]
	where
		aux i
			| i == 0 = 0
			| 2*k >= i = i
			| i == (n-1) = n-1
			| mod i 2 == 0 = i - 1
			| mod i 2 == 1 = i + 1

showR :: Maybe [Natural] -> String
showR (Just list) = foldr (\i s -> show i ++ " " ++ s) [] list
showR Nothing = "-1"

main = do
	t <- getLine >>= return . read :: IO Natural
	replicateM (intNat t) $ do
		[n, k] <- getLine >>= return . (fmap read) . words :: IO [Natural]
		putStrLn $ showR $ solve n k


For the multiset of positive integers $$$s=\{s_1,s_2,\dots,s_k\}$$$, define the Greatest Common Divisor (GCD) and Least Common Multiple (LCM) of $$$s$$$ as follow: $$$\gcd(s)$$$ is the maximum positive integer $$$x$$$, such that all integers in $$$s$$$ are divisible on $$$x$$$. $$$\textrm{lcm}(s)$$$ is the minimum positive integer $$$x$$$, that divisible on all integers from $$$s$$$.For example, $$$\gcd(\{8,12\})=4,\gcd(\{12,18,6\})=6$$$ and $$$\textrm{lcm}(\{4,6\})=12$$$. Note that for any positive integer $$$x$$$, $$$\gcd(\{x\})=\textrm{lcm}(\{x\})=x$$$.Orac has a sequence $$$a$$$ with length $$$n$$$. He come up with the multiset $$$t=\{\textrm{lcm}(\{a_i,a_j\})\ |\ i<j\}$$$, and asked you to find the value of $$$\gcd(t)$$$ for him. In other words, you need to calculate the GCD of LCMs of all pairs of elements in the given sequence.

The first line contains one integer $$$n\ (2\le n\le 100\,000)$$$. The second line contains $$$n$$$ integers, $$$a_1, a_2, \ldots, a_n$$$ ($$$1 \leq a_i \leq 200\,000$$$).

Print one integer: $$$\gcd(\{\textrm{lcm}(\{a_i,a_j\})\ |\ i<j\})$$$.

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

type Long = Integer

primesPE = 2 : sieve [3..] 4 primesPE
    where
        sieve (x:xs) q (p:t)
          | x < q     = x : sieve xs q (p:t)
          | otherwise = sieve [ x |x<-xs,x`mod`p/=0 ] (head t^2) t

primes :: [Int]
primes = take 100 primesPE

calcNum :: IntMap Int -> Long
calcNum factorization =
    case IM.lookupMin factorization of
        Nothing -> 1
        Just (p,pw) -> calcNum (IM.deleteMin factorization) * product (replicate pw (fromIntegral p))

factorize :: Int -> IntMap Int
factorize n
    | remaining == 1    = factorization
    | otherwise         = IM.insert remaining 1 factorization
    where
        powers = [(p, maxPower p n) | p <- primes, maxPower p n > 0]
        factorization = IM.fromList powers
        remaining = n `div` fromIntegral ( calcNum factorization)
        maxPower p n'
            | n' `mod` p == 0   = 1 + maxPower p (n' `div` p)
            | otherwise         = 0

allPrimesUsed :: [IntMap Int] -> IntSet
allPrimesUsed facts = IS.unions $ map (IS.fromAscList . IM.keys) facts

secondMinimum :: [Int] -> (Int,Int)
secondMinimum [] = (1000000,1000000)
secondMinimum (a:rest)
    | a < fmin      = (a, fmin)
    | a < smin      = (fmin, a)
    | otherwise     = (fmin,smin)
    where
        (fmin, smin) = secondMinimum rest

secondMin :: Int -> [Int] -> Int
secondMin n as
    | l == n    = smin
    | l == n-1  = fmin
    | otherwise = 0
    where
        l = length as
        (fmin,smin) = secondMinimum as

pairMerger :: (Int, Int) -> (Int, Int) -> (Int, Int)
pairMerger (a,b) (c,d) = secondMinimum [a,b,c,d]

solve :: Int -> [Int] -> Long
solve n as = calcNum gcdFact
    where
        --gcdFact = IM.fromList [ (p, snd $ secondMinimum [ IM.findWithDefault 0 p factorization | factorization <- facts]) | p <- IS.toList allPrimes]
        facts = map factorize as
        listFacts = map (IM.map (:[])) facts
        gcdPairFact = IM.unionsWith (flip (++)) listFacts
        gcdFact = IM.map (secondMin n) gcdPairFact
        --allPrimes = allPrimesUsed facts

main :: IO ()
main = do
    (n:_) <- readWords
    as <- readWords
    print $ solve n as

test :: Long
test = solve 4 $ map read . words $ "10 24 40 80"

testBig :: Int -> Long
testBig n = solve n $ replicate n 570570

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

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

type Long = Int

primesPE = 2 : sieve [3..] 4 primesPE
    where
        sieve (x:xs) q (p:t)
          | x < q     = x : sieve xs q (p:t)
          | otherwise = sieve [ x |x<-xs,x`mod`p/=0 ] (head t^2) t

primes :: [Int]
primes = take 100 primesPE

calcNum :: IntMap Int -> Int
calcNum factorization =
    case IM.lookupMin factorization of
        Nothing -> 1
        Just (p,pw) -> calcNum (IM.deleteMin factorization) * product (replicate pw p)

factorize :: Int -> IntMap Int
factorize n
    | remaining == 1    = factorization
    | otherwise         = IM.insert remaining 1 factorization
    where
        powers = [(p, maxPower p n) | p <- primes, maxPower p n > 0]
        factorization = IM.fromList powers
        remaining = n `div` calcNum factorization
        maxPower p n'
            | n' `mod` p == 0   = 1 + maxPower p (n' `div` p)
            | otherwise         = 0

allPrimesUsed :: [IntMap Int] -> IntSet
allPrimesUsed facts = IS.unions $ map (IS.fromAscList . IM.keys) facts

secondMinimum :: [Int] -> (Int,Int)
secondMinimum [] = (1000000,1000000)
secondMinimum (a:rest)
    | a < fmin      = (a, fmin)
    | a < smin      = (fmin, a)
    | otherwise     = (fmin,smin)
    where
        (fmin, smin) = secondMinimum rest

secondMin :: Int -> [Int] -> Int
secondMin n as
    | l == n    = smin
    | l == n-1  = fmin
    | otherwise = 0
    where
        l = length as
        (fmin,smin) = secondMinimum as

pairMerger :: (Int, Int) -> (Int, Int) -> (Int, Int)
pairMerger (a,b) (c,d) = secondMinimum [a,b,c,d]

solve :: Int -> [Int] -> Int
solve n as = calcNum gcdFact
    where
        --gcdFact = IM.fromList [ (p, snd $ secondMinimum [ IM.findWithDefault 0 p factorization | factorization <- facts]) | p <- IS.toList allPrimes]
        facts = map factorize as
        listFacts = map (IM.map (:[])) facts
        gcdPairFact = IM.unionsWith (flip (++)) listFacts
        gcdFact = IM.map (secondMin n) gcdPairFact
        --allPrimes = allPrimesUsed facts

main :: IO ()
main = do
    (n:_) <- readWords
    as <- readWords
    print $ solve n as

test :: Int
test = solve 4 $ map read . words $ "10 24 40 80"

testBig :: Int -> Int
testBig n = solve n $ replicate n 570570

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


Vasya adores sport programming. He can't write programs but he loves to watch the contests' progress. Vasya even has a favorite coder and Vasya pays special attention to him.One day Vasya decided to collect the results of all contests where his favorite coder participated and track the progress of his coolness. For each contest where this coder participated, he wrote out a single non-negative number — the number of points his favorite coder earned in the contest. Vasya wrote out the points for the contest in the order, in which the contests run (naturally, no two contests ran simultaneously).Vasya considers a coder's performance in a contest amazing in two situations: he can break either his best or his worst performance record. First, it is amazing if during the contest the coder earns strictly more points that he earned on each past contest. Second, it is amazing if during the contest the coder earns strictly less points that he earned on each past contest. A coder's first contest isn't considered amazing. Now he wants to count the number of amazing performances the coder had throughout his whole history of participating in contests. But the list of earned points turned out long and Vasya can't code... That's why he asks you to help him.

NoteIn the first sample the performances number 2 and 3 are amazing.In the second sample the performances number 2, 4, 9 and 10 are amazing.

module Main (main)
    where

import Data.List (group)

main :: IO ()
main = print . solve . map read . words =<< (getLine >> getLine)
    where solve :: [Int] -> Int
          solve xs = length (mins xs) + length (maxes xs) - 2
          mins  = scanWith min
          maxes = scanWith max
          scanWith f = map head . group . scanl1 f

main = do
    getLine
    x <- getLine
    putStr (solve (map read (words x)))

solve:: [Integer] -> String
solve (x:xs) = show (result 0 x x xs)
result r min max x
    |x==[]                  = r
    |head x>max             = result (r+1) min (head x) (tail x)
    |head x<min             = result (r+1) (head x) max (tail x)
    |otherwise              = result r min max (tail x)

module Main where

import Control.Monad
import Data.List

considerContest (acc, minScore, maxScore) thisScore =
  let
    minScore' = min minScore thisScore
    maxScore' = max maxScore thisScore
    acc' = acc + if thisScore < minScore || thisScore > maxScore
      then 1
      else 0
  in (acc', minScore', maxScore')

main = do
  n <- liftM read getLine :: IO Int
  ss <- liftM ( map read . words ) getLine :: IO [Int]

  let
    (res, _, _) = foldl considerContest (-1, maxBound, minBound) ss

  putStrLn $ show res

main = do
	n<-getLine
	rest<-getLine
	let dat=words rest
	putStrLn $ show $ solve (tail (map read dat)) (read(head dat)) (read(head dat)) 0

solve::[Int]->Int->Int->Int->Int
solve [] _ _ count = count
solve (v:vs) mini maxi count | v > maxi = solve vs mini v (count+1)
                           | v < mini = solve vs v maxi (count+1)
                           | otherwise = solve vs mini maxi count

solve [x] = 0
solve (x:xs) = (solve xs) + c where c = if (all (>x) xs || all (<x) xs) then 1 else 0
main= getLine>>do
        xs <- getLine>>=return . map (read :: String -> Int) . words
        print $ solve $ reverse xs

module Main(main) where
import System.IO
import Data.List

main = interact real_main
real_main inp =
	let (n:nmbs) = map (read::String->Int) . words $ inp
	    (cnt, _, _) = foldl' (\(n, mx, mn) x -> if x > mx then (n + 1, x, mn) else if x < mn then (n + 1, mx, x) else (n, mx, mn)) (0, head nmbs, head nmbs) nmbs
	in show cnt ++ "\n"

fu xs max min ans | null xs = ans | head xs > max = fu ys y min ans+1 | head xs < min = fu ys max y ans+1 | otherwise = fu ys max min ans
    where
          ys = tail xs
          y = head xs
solve :: (Integral a) => [a] -> a
solve xs = fu (tail xs) (xs !! 1) (xs !! 1) 0
main =  interact $ show . solve . map read . words

import Data.List

findAmazing :: [Int] -> Int
findAmazing [_] = 0
findAmazing xs
    | all (< (last xs)) (init xs) = 1 + findAmazing (init xs)
    | all (> (last xs)) (init xs) = 1 + findAmazing (init xs)
    | otherwise = findAmazing (init xs)

main = do
  n <- getLine
  inStr <- getLine
  let points = map (\x -> read x :: Int) . words $ inStr
  print $ findAmazing points

main = do
  getLine
  xs <- fmap (map read . words) getLine :: IO [Int]
  let
    m1 = scanl1 max xs
    m2 = scanl1 min xs

    c1 = length $ filter (\(a, b) -> a > b) $ zip (tail xs) m1
    c2 = length $ filter (\(a, b) -> a < b) $ zip (tail xs) m2

  print $ c1 + c2

import Data.List

boolToInt :: Bool -> Int
boolToInt num | num == True = 1
              | num == False = 0

readNumbers str = map readInt $ words str
    where readInt = read :: String -> Int

run numbers = sum [boolToInt (num < minim || num > maxim) |
                   [num, minim, maxim] <- tail $ transpose [numbers, min_list, max_list]]
-- $ zip min_list max_list]
    where
        lim = 10000
        min_list = scanl min lim numbers
        max_list = scanl max (-lim) numbers

main = do
    getLine
    numbers_str <- getLine
    putStrLn $ show $ run $ readNumbers numbers_str

{-# LANGUAGE BangPatterns #-}

(-->) = flip fmap

solve :: [Int] -> Int
solve [] = 0
solve [a] = 0
solve (a:as) = go a a as 0
  where
    go min max [] !c = c
    go min max (a:as) c
      | a < min = go a max as (c+1)
      | a > max = go min a as (c+1)
      | otherwise = go min max as c

main = do
  n <- getLine --> read :: IO Int
  nums <- getLine --> words --> map read
  print $ solve nums

import Data.List
import qualified Data.Map as M
(|>) x f = f x

main = interact process

process contents = let
  ls = contents |> lines |> map words |> map (map read) :: [[Int]]
  in solve (ls !! 1) |> show

solve nums = solve' (head nums) (head nums) (tail nums)

solve' _ _ [] = 0
solve' minSoFar maxSoFar (x:xs)
  | x < minSoFar = 1 + solve' x maxSoFar xs
  | x > maxSoFar = 1 + solve' minSoFar x xs
  | otherwise = solve' minSoFar maxSoFar xs

main =
  do
    n <- readLn :: IO Int
    s <- getLine
    let list = map read (words s) :: [Int]
    print (f (tail list) (head list) (head list) 0)

f [] a b count = count
f (x:xs) a b count =
  let f1 = max x a
      f2 = min x b
      count1 = if f1 == a then 0 else 1
      count2 = if f2 == b then 0 else 1
  in f xs f1 f2 (count+count1+count2)

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

solve (n:xss) = solve' (-1) (-1) xs 0 where
    xs = take n xss
    solve' (-1) (-1) (x:xs) 0 = solve' x x xs 0
    solve' _    _    []     k = k
    solve' mn   mx   (x:xs) k
        | x < mn    = solve' x  mx xs (k + 1)
        | x > mx    = solve' mn x  xs (k + 1)
        | otherwise = solve' mn mx xs k

main = do
    str <- getLine
    let n = read str
    aux <- getLine
    let xs = map read $ words aux :: [Int]

    let solve = _solve 0 0 where
        _solve i ans
            | i == n = ans
            | i == 0 = _solve (i + 1) ans
            | otherwise = if (xs !! i > maximum (take i xs) || xs !! i < minimum (take i xs)) then _solve (i + 1) (ans + 1) else _solve (i + 1) ans

    print solve

import Control.Applicative

solve :: [Int] -> Int
solve (x:xs) = solve' xs x x
    where solve' []     mn mx = 0
          solve' (x:xs) mn mx = let a = if mn > x then 1 else 0
                                    b = if mx < x then 1 else 0
                                in  a + b + solve' xs (min mn x) (max mx x)

main = do
  n <- getLine
  a <- map read <$> (words <$> getLine)
  print $ solve a

main = getLine >> getLine >>= putStrLn . show . thrd . amazing . map read . words

amazing :: [Int] -> (Int,Int,Int)
amazing (x:xs) = foldl ( svfn ) (x,x,0) xs

thrd (a,b,c) = c;

svfn (mx,mn,n) y =  if y < mn
						then (mx,y,n+1)
						else if y > mx
								then (y,mn,n+1)
								else (mx,mn,n)

import Data.List
import Data.Maybe
import Data.Char
import Data.Function
main=   readsolveprint
readsolveprint::IO()
readsolveprint =  interact $ solve. tail.concat.map (map read.words). take 2. lines
solve :: [Integer]->String
solve (x:xs) = show $ last $ foldl (\[bma,bmi,bre] a->if a>bma then [a,bmi,bre+1]
 else if a<bmi then [bma,a,bre+1] else [bma,bmi,bre]) [x,x,0] (x:xs)

module Main where

main = do
    _ <- getLine
    s <- getLine
    let bs = reverse (map read (words s)) :: [Int]
    print(solve bs)

solve (b:[]) = 0
solve (b:bs)
    | (b > maximum bs) = solve bs + 1
    | (b < minimum bs) = solve bs + 1
    | otherwise = solve bs

main = let solve (x:xs) = (let (_,_,z) = foldl (\(a, b, c) y -> (max a y, min b y, c + (if (y > a) || (y < b) then 1 else 0)) ) (x,x,0) xs in z) in getLine >>= const (fmap (map read . words) getLine :: IO [Int]) >>= (putStrLn . show . solve)

import List

readWords :: IO [String]
readWords = getLine >>= return . words

reads :: Read a => IO [a]
reads = readWords >>= return . (map read)

solve :: [Int] -> Int
solve (x:xs)  =  solve' (x, x) 0 xs
  where
    solve' _ n []  =  n
    solve' (a, b) n (x:xs)
      | x < a      =  solve' (x, b) (n+1) xs
      | b < x      =  solve' (a, x) (n+1) xs
      | otherwise  =  solve' (a, b) n xs

main :: IO ()
main  =  getLine >> Main.reads >>= print . solve

import Control.Applicative

main = do
  _ <- getLine
  (x:xs) <- map read . words <$> getLine :: IO [Int]
  print $ cnt 0 x x xs

cnt a _ _ []     = a
cnt a m n (x:xs) =
  let nc = a + fromEnum (x > m) + fromEnum (x < n)
      nm = max m x
      nn = min n x
  in cnt nc nm nn xs

solve :: [Int] -> Int
solve (x:xs) = let (_, _, ans) = foldl playContest (x, x, 0) xs
               in ans
  where playContest (mn, mx, ans) x
          | mn > x = (x, mx, ans + 1)
          | mx < x = (mn, x, ans + 1)
          | True   = (mn, mx, ans)

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

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

toD :: Int -> Double
toD = fromIntegral

solve1 :: (Int -> Int -> Bool) -> [Int] -> Int
solve1 _ [] = 0
solve1 f (h:t)  = 1 + solve1 f (dropWhile (f h) t)

solve :: [Int] -> Int
solve = subtract 2 . liftM2 (+) (solve1 (<=)) (solve1 (>=))

main :: IO ()
main = getLine >> getIntList >>= print . solve

module Main where

readi :: String -> Int
readi = read

parseSolve x = initSolve $ map readi $ words x

solve :: Int -> Int -> [Int] -> Int
solve _ _ [] = 0
solve xmin xmax (h:t)
    | h < xmin = 1 + (solve h xmax t)
    | h > xmax = 1 + (solve xmin h t)
    | otherwise = (solve xmin xmax t)

initSolve :: [Int] -> Int
initSolve (h:t) = solve h h t

main = do
    _ <- getLine
    line <- getLine
    print $ parseSolve line

import Control.Applicative

process [] _ _ a = a
process (a:as) mi ma co | a<mi = process as a ma (co+1)
                        | a>ma = process as mi a (co+1)
                        | otherwise = process as mi ma co

main=do
     getLine
     q<-  map read <$> words <$> getLine::IO [Int]
     print $ process q (head q) (head q) 0

import Data.List
import Data.Char
import qualified Data.Set as Set
import Control.Monad
import Control.Applicative
main = do
  n <- getLine
  xs <- map read . words <$> getLine
  print (solve xs)

solve (x:xs) = f xs t t 0
  where
    t = fromIntegral x
    f [] _ _ acc = acc
    f (x:xs) min max acc
      | x < min = f xs x max (acc+1)
      | x > max = f xs min x (acc+1)
      | otherwise = f xs min max acc

import Data.List (inits)

main :: IO ()
main = getContents >>= print . solve . map read . words . (!!1) . lines

solve :: [Int] -> Int
solve xs = length $ filter id $ zipWith f (tail xs) (tail $ inits xs)
  where f y ys = y < minimum ys || maximum ys < y

main = print . fst . foldl contest (-1,(minBound,maxBound :: Int)) .
       map read . tail . words =<< getContents
contest (a,(u,l)) s | s > u || s < l = (a+1,(max u s,min l s))
                    | otherwise      = (a,(u,l))

main = getLine >> fmap (map read . words) getLine >>= print . solve
solve :: [Int] -> Int
solve xs = length $ filter isSurprise lists
    where lists = map (\n -> take n xs) [2..length xs]
isSurprise :: [Int] -> Bool
isSurprise xs = all (>current) previous || all (<current) previous
    where current = last xs
          previous = init xs

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

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

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

amazing :: (Int -> Int -> Bool) -> [Int] -> Int
amazing _ [] = 0
amazing f (h:t) = 1 + amazing f (dropWhile (f h) t)

solve :: [Int] -> Int
solve = subtract 2 . liftM2 (+) (amazing (<=)) (amazing (>=))

main :: IO ()
main = getLine >> getIntList >>= print . solve

import Data.List
import Control.Applicative

main = do _ <- getLine
          xs <- map read . words <$> getLine
          print $ solve xs

solve :: [Int] -> Int
solve xxs@(x:xs) = fst $ foldl' f (0,(x,x)) xs

f :: (Int,(Int,Int)) -> Int -> (Int,(Int,Int))
f (i,(x,y)) z
  | z < x = (i+1,(z,y))
  | y < z = (i+1,(x,z))
  | otherwise = (i,(x,y))

main = interact $ show . func . map read . tail . words

func :: [Int] -> Int
func (x:xs) = ct (x,x) xs

ct (a,b) (x:xs) = (if x < a || x > b then 1 else 0) + ct (minimum [a,x], maximum [b,x]) xs
ct _ _ = 0

import Control.Applicative

solve :: [Int] -> Int -> Int -> Int
solve [] _ _ = 0
solve (a:as) mn mx
  | mn > a = 1 + solve as a mx
  | mx < a = 1 + solve as mn a
  | otherwise = solve as mn mx

main = do
  n <- getLine
  (a:as) <- map read <$> (words <$> getLine)
  print $ solve as a a

import Control.Applicative
import Data.List
import qualified Data.ByteString.Char8 as C
import Data.Maybe

process _ _ [] n = n
process a b (c:cs) n | c<a = process c b cs (n+1)
                     | c>b = process a c cs (n+1)
		     | otherwise = process a b cs n
main=do
	getLine
	s<- map (fst.fromJust.C.readInteger). C.words <$>  C.getLine  ::IO [Integer]
	print $ process (head s) ( head s) (tail s) 0

{-
A. I_love_%username%
=====================
time limit per test: 2 seconds
memory limit per test: 256 megabytes
input: standard input
output: standard output

Vasya adores sport programming. He can't write programs but he loves to watch the contests' progress. Vasya even has a favorite coder and Vasya pays special attention to him.

One day Vasya decided to collect the results of all contests where his favorite coder participated and track the progress of his coolness. For each contest where this coder participated, he wrote out a single non-negative number — the number of points his favorite coder earned in the contest. Vasya wrote out the points for the contest in the order, in which the contests run (naturally, no two contests ran simultaneously).

Vasya considers a coder's performance in a contest amazing in two situations: he can break either his best or his worst performance record. First, it is amazing if during the contest the coder earns strictly more points that he earned on each past contest. Second, it is amazing if during the contest the coder earns strictly less points that he earned on each past contest. A coder's first contest isn't considered amazing. Now he wants to count the number of amazing performances the coder had throughout his whole history of participating in contests. But the list of earned points turned out long and Vasya can't code... That's why he asks you to help him.

Input
------
The first line contains the single integer n (1 ≤ n ≤ 1000) — the number of contests where the coder participated.

The next line contains n space-separated non-negative integer numbers — they are the points which the coder has earned. The points are given in the chronological order. All points do not exceed 10000.

Output
------
Print the single number — the number of amazing performances the coder has had during his whole history of participating in the contests.

Sample test(s)
---------------
input
5
100 50 200 150 200
output
2

input
10
4664 6496 5814 7010 5762 5736 6944 4850 3698 7242
output
4

Note
------
In the first sample the performances number 2 and 3 are amazing.

In the second sample the performances number 2, 4, 9 and 10 are amazing.

-}

import Data.List (tails)

countAmazing :: [Int] -> Int
countAmazing xs = length $ filter (\(y:ys) -> y > maximum ys || y < minimum ys) yys
  where yys = (takeWhile ((> 1) . length) . tails . reverse) xs

main = do
  input <- getContents
  let points = (map read . words . last . lines) input
  print $ countAmazing points

main::IO ()
main = do cs <- getContents
          (putStr . show . solve . parse) cs

parse::String->[Int]
parse s = map (\x -> read x::Int) (words k)
            where
              [_,k] = lines s

solve_step::(Int,Int,Int)->Int->(Int,Int,Int)
solve_step (min,max,cnt) i
    | i < min = (i,max,cnt+1)
    | i > max = (min,i,cnt+1)
    | otherwise = (min,max,cnt)

solve :: [Int] -> Int
solve [] = 0;
solve (k:ks) = ret
                 where
                   (_,_,ret) = foldl solve_step (k,k,0) ks

import Data.List
main = getLine >> getLine >>= putStrLn.show.solve.map read.words

solve :: [Int] -> Int
solve [one] = 0
solve many  = sum $ map (flip calc many) [min, max]

calc f = pred.length.nub.scanl1 f

process :: [Int] -> Int
process xs = best + wrst
    where
        best = snd $ foldl (\a@(ax,an) x -> if x > ax then (x,an+1) else a) (minBound,(-1)) xs
        wrst = snd $ foldl (\a@(ax,an) x -> if x < ax then (x,an+1) else a) (maxBound,(-1)) xs

readInt :: String -> Int
readInt = read

main :: IO ()
main = do
    n <- fmap readInt getLine
    xs <- fmap (map readInt.words) getLine
    print $ process xs

main = do
	_ <- getLine
	b_s <- getLine
	let (b:bs) = (map read (words b_s)) :: [Int]
	putStrLn.show $ solve bs [b] [b]

solve [] (h:hs) (l:ls) = length (h:hs) + length (l:ls) - 2
solve (b:bs) (h:hs) (l:ls)
	| (b > h) = solve bs (b:h:hs) (l:ls)
	| (b < l) = solve bs (h:hs) (b:l:ls)
	| otherwise = solve bs (h:hs) (l:ls)

countAmazing :: [Int] -> Int
countAmazing xs = count
    where (_, _, count) =  foldl accumulator (maxBound :: Int, minBound :: Int, 0) xs

accumulator :: (Int, Int, Int) -> Int -> (Int, Int, Int)
accumulator (mi, ma, count) current = (mi', ma', count')
    where mi' = min mi current
          ma' = max ma current
          count' = count + fromEnum ((mi' < mi) /= (ma' > ma))

solve :: String -> String
solve = show . countAmazing . fmap read . tail . words

main :: IO ()
main = interact solve

import Data.List

countAmazing :: [Int] -> Int
countAmazing xs = sum $ fmap (countMutations xs) [min, max]

countMutations :: [Int] -> (Int -> Int -> Int) -> Int
countMutations xs = pred . length . group . (`scanl1` xs)

solve :: String -> String
solve = show . countAmazing . fmap read . tail . words

main :: IO ()
main = interact solve

solve :: [Integer] -> Integer
solve (lh:lt) =
    third . subsolve $ lt
        where third (_, _, x) = x
              funk old@(mx, mn, ac) hd
                   | hd > mx = (hd, mn, ac + 1)
                   | hd < mn = (mx, hd, ac + 1)
                   | otherwise = old
              subsolve = foldl funk (lh, lh, 0)

main = do
  _ <- getLine
  numbers <- getLine
  print $ solve (map read (words numbers))

import Control.Applicative

main = do
  n <- getLine
  xs <- map read . words <$> getLine
  print $ cnt 0 (-1) xs

cnt a _ []     = a
cnt a m (x:xs)
  | x > m     = cnt (a+1) x xs
  | otherwise = cnt a m xs

import Control.Applicative

process [] _ _ a = a
process (a:as) mi ma co | a<mi = process as a ma (co+1)
                        | a>ma = process as mi a (co+1)
                        | otherwise = process as mi ma co

main=do
     getLine
     q<-  map read <$> words <$> getLine::IO [Int]
     print $ process q 100000 0 0

main = print . fst . foldl contest (0,(minBound,maxBound :: Int)) .
       map read . tail . words =<< getContents
contest (a,(u,l)) s | s > u || s < l = (a+1,(max u s,min u l))
                    | otherwise      = (a,(u,l))

main = interact $ show . func . tail . words

func (x:xs) = ct (x,x) xs

ct (a,b) (x:xs) = (if x < a || x > b then 1 else 0) + ct (minimum [a,x], maximum [b,x]) xs
ct _ _ = 0