In BerSoft $$$n$$$ programmers work, the programmer $$$i$$$ is characterized by a skill $$$r_i$$$.A programmer $$$a$$$ can be a mentor of a programmer $$$b$$$ if and only if the skill of the programmer $$$a$$$ is strictly greater than the skill of the programmer $$$b$$$ $$$(r_a > r_b)$$$ and programmers $$$a$$$ and $$$b$$$ are not in a quarrel.You are given the skills of each programmers and a list of $$$k$$$ pairs of the programmers, which are in a quarrel (pairs are unordered). For each programmer $$$i$$$, find the number of programmers, for which the programmer $$$i$$$ can be a mentor.

The first line contains two integers $$$n$$$ and $$$k$$$ $$$(2 \le n \le 2 \cdot 10^5$$$, $$$0 \le k \le \min(2 \cdot 10^5, \frac{n \cdot (n - 1)}{2}))$$$ — total number of programmers and number of pairs of programmers which are in a quarrel. The second line contains a sequence of integers $$$r_1, r_2, \dots, r_n$$$ $$$(1 \le r_i \le 10^{9})$$$, where $$$r_i$$$ equals to the skill of the $$$i$$$-th programmer. Each of the following $$$k$$$ lines contains two distinct integers $$$x$$$, $$$y$$$ $$$(1 \le x, y \le n$$$, $$$x \ne y)$$$ — pair of programmers in a quarrel. The pairs are unordered, it means that if $$$x$$$ is in a quarrel with $$$y$$$ then $$$y$$$ is in a quarrel with $$$x$$$. Guaranteed, that for each pair $$$(x, y)$$$ there are no other pairs $$$(x, y)$$$ and $$$(y, x)$$$ in the input.

Print $$$n$$$ integers, the $$$i$$$-th number should be equal to the number of programmers, for which the $$$i$$$-th programmer can be a mentor. Programmers are numbered in the same order that their skills are given in the input.

NoteIn the first example, the first programmer can not be mentor of any other (because only the second programmer has a skill, lower than first programmer skill, but they are in a quarrel). The second programmer can not be mentor of any other programmer, because his skill is minimal among others. The third programmer can be a mentor of the second programmer. The fourth programmer can be a mentor of the first and of the second programmers. He can not be a mentor of the third programmer, because they are in a quarrel.

import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Array as A
import qualified Data.IntMap.Strict as M
import Data.List
import Data.Maybe
import Data.Ord
import Data.Function

main = do
  inp <- fmap B.lines $ B.getContents
  let [n,k] = map readI $ B.words $ inp!!0
  let ar = A.listArray (1,n) $ map readI $ B.words $ inp!!1
  let qss = map (map readI . B.words) $ drop 2 inp
  putStrLn $ unwords $ map show $ solve n ar qss

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

type Acc = (Int,Int,Int)

solve :: Int -> A.Array Int Int -> [[Int]] -> [Int]
solve n ar qss =
  M.elems $ foldl f2 (fst $ foldl f1 (M.empty,(0,0,0)) ss) rs
  where
    ss = sortBy (comparing (ar A.!)) [1..n]
    rs = groupBy ((==)`on`fst) $ sortBy (comparing ((ar A.!).fst)) $ mapMaybe g qss

    g :: [Int] -> Maybe (Int,Int)
    g [x,y] | ar A.! x == ar A.! y = Nothing
            | ar A.! x >  ar A.! y = Just (x,y)
            | otherwise            = Just (y,x)

    f1 :: (M.IntMap Int, Acc) -> Int -> (M.IntMap Int, Acc)
    f1 (m,(c1,c2,v)) x
        | ar A.! x == v   = (M.insert x c1 m, (c1, c2+1, v))
        |otherwise        = ( M.insert x (c1+c2) m, (c1+c2, 1, ar A.! x))

    f2 :: M.IntMap Int -> [(Int,Int)] -> M.IntMap Int
    f2 m qs@((i,_):_) = M.update (Just . (subtract (length qs))) i m

import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Graph as G
import qualified Data.Array as A
import Data.List
import Data.Ord

main = do
  inp <- fmap B.lines $ B.getContents
  let [n,k] = map readI $ B.words $ inp!!0
  let rs = map readI $ B.words $ inp!!1
  let qss = map (map readI . B.words) $ drop 2 inp
  putStrLn $ unwords $ map show $ solve n rs qss

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

type Acc = (Int,[Int],[Int])

solve :: Int -> [Int] -> [[Int]] -> [Int]
solve n rs qss =
  map g [1..n]
  where
    g i = length [()| k<-ar A.! i, not (G.path gr i k)]

    ss = sortBy (comparing snd) $ zip [1..] rs

    f :: ((Int,[Int]),Acc) -> (Int,Int) -> ((Int,[Int]),Acc)
    f (_,(x0,as,bs)) (i,x)
        | x == x0   = ((i,as),(x0,as,i:bs))
        |otherwise  = let as'=as++bs in ((i,as'),(x,as',[i]))

    ar :: A.Array (Int) [Int]
    ar = A.array (1,n) $ map fst $ tail $ scanl f ((0,[]),(0,[],[])) ss

    gr :: G.Graph
    gr = G.buildG (1,n) $ concat[[(x,y),(y,x)]|[x,y]<-qss]


We are given a rooted tree consisting of $$$n$$$ vertices numbered from $$$1$$$ to $$$n$$$. The root of the tree is the vertex $$$1$$$ and the parent of the vertex $$$v$$$ is $$$p_v$$$.There is a number written on each vertex, initially all numbers are equal to $$$0$$$. Let's denote the number written on the vertex $$$v$$$ as $$$a_v$$$.For each $$$v$$$, we want $$$a_v$$$ to be between $$$l_v$$$ and $$$r_v$$$ $$$(l_v \leq a_v \leq r_v)$$$.In a single operation we do the following:   Choose some vertex $$$v$$$. Let $$$b_1, b_2, \ldots, b_k$$$ be vertices on the path from the vertex $$$1$$$ to vertex $$$v$$$ (meaning $$$b_1 = 1$$$, $$$b_k = v$$$ and $$$b_i = p_{b_{i + 1}}$$$). Choose a non-decreasing array $$$c$$$ of length $$$k$$$ of nonnegative integers: $$$0 \leq c_1 \leq c_2 \leq \ldots \leq c_k$$$. For each $$$i$$$ $$$(1 \leq i \leq k)$$$, increase $$$a_{b_i}$$$ by $$$c_i$$$. What's the minimum number of operations needed to achieve our goal?

The first line contains an integer $$$t$$$ $$$(1\le t\le 1000)$$$  — the number of test cases. The description of the test cases follows. The first line of each test case contains a single integer $$$n$$$ $$$(2\le n\le 2 \cdot 10^5)$$$  — the number of the vertices in the tree. The second line of each test case contains $$$n - 1$$$ integers, $$$p_2, p_3, \ldots, p_n$$$ $$$(1 \leq p_i < i)$$$, where $$$p_i$$$ denotes the parent of the vertex $$$i$$$. The $$$i$$$-th of the following $$$n$$$ lines contains two integers $$$l_i$$$ and $$$r_i$$$ $$$(1 \le l_i \le r_i \le 10^9)$$$. It is guaranteed that the sum of $$$n$$$ over all test cases doesn't exceed $$$2 \cdot 10^5$$$.

For each test case output the minimum number of operations needed.

NoteIn the first test case, we can achieve the goal with a single operation: choose $$$v = 2$$$ and $$$c = [1, 2]$$$, resulting in $$$a_1 = 1, a_2 = 2$$$.In the second test case, we can achieve the goal with two operations: first, choose $$$v = 2$$$ and $$$c = [3, 3]$$$, resulting in $$$a_1 = 3, a_2 = 3, a_3 = 0$$$. Then, choose $$$v = 3, c = [2, 7]$$$, resulting in $$$a_1 = 5, a_2 = 3, a_3 = 7$$$.

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Char (digitToInt)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map (Map, insert, alter, empty, (!), (!?), fromList)
import Data.List (unfoldr)

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

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

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns = print

getPair :: IO Value
getPair = do
  [a, b] <- readChar8
  return (a, b)

buildTree :: Map Int Value -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go n = let value = xs ! n in maybe (Leaf value) (Node value) $ fmap go <$> m !? n

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) = alter (maybe (Just [n]) (Just . (n :))) x $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (_, y)) = (y, 1)
dfs (Node (l, h) xs) = if l > childSum
    then (h, number + 1)
    else (min childSum h, number)
  where
    (childSum, number) = foldl1 addUp $ dfs <$> xs

parse :: IO Domain
parse = do
  [nodeCount] <- readChar8
  parents <- readChar8
  ranges <- fromList . zipWith (,) [1..] <$> replicateM nodeCount getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  [n] <- readChar8
  replicateM_ n (printAns <$> solve =<< parse)

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Char (digitToInt)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.ByteString.Char8 as C
import Data.Map (Map, insert, alter, empty, (!), (!?), fromList)
import qualified Data.Char as C
import Data.List (unfoldr)

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

readChar8 :: IO [Int]
readChar8 = parse <$> C.getLine
  where parse = unfoldr go
        go s = do (n, s1) <- C.readInt s
                  let s2 = C.dropWhile C.isSpace s1
                  return (n, s2)

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns = print

getPair :: IO Value
getPair = do
  [a, b] <- readChar8
  return (a, b)

buildTree :: Map Int Value -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go n = let value = xs ! n in maybe (Leaf value) (Node value) $ fmap go <$> m !? n

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) = alter (maybe (Just [n]) (Just . (n :))) x $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (_, y)) = (y, 1)
dfs (Node (l, h) xs) = if l > childSum
    then (h, number + 1)
    else (min childSum h, number)
  where
    (childSum, number) = foldl1 addUp $ dfs <$> xs

parse :: IO Domain
parse = do
  [nodeCount] <- readChar8
  parents <- readChar8
  ranges <- fromList . zipWith (,) [1..] <$> replicateM nodeCount getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  [n] <- readChar8
  replicateM_ n (printAns <$> solve =<< parse)

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Bits
-- import Debug.Trace
import Data.Char (digitToInt)
import Data.Maybe (fromJust, fromMaybe)
import Data.String ( IsString(fromString) )
import qualified Data.ByteString.Char8 as C
import Data.List (dropWhileEnd)
import Data.Map (Map, insert, alter, empty, (!), (!?))

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

parseInt :: String -> Int
parseInt = fromIntegral . fst . fromJust . C.readInt . fromString

parseIntList :: String -> [Int]
parseIntList = map parseInt . words

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns x = print x

getPair :: IO Value
getPair = do
  [a, b] <- fmap parseInt . words <$> getLine
  return (a, b)

buildTree :: [Value] -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go :: Int -> Tree
    go n = maybe (Leaf value) (Node value) $ fmap go <$> m !? n
      where
        value = xs !! (n-1)

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) = alter (maybe (Just [n]) (Just . (n :))) x $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (_, y)) = (y, 1)
dfs (Node (l, h) xs) = if l > childSum then (h, number + 1) else (childSum, number)
  where
    (childSum, number) = foldl1 addUp $ dfs <$> xs

parse :: IO Domain
parse = do
  nodeCount <- parseInt <$> getLine
  parents <- parseIntList <$> getLine
  ranges <- replicateM (fromIntegral nodeCount) getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  n <- parseInt <$> getLine
  replicateM_ (fromIntegral n) (printAns <$> solve =<< parse)

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Bits
-- import Debug.Trace
import Data.Char (digitToInt)
import Data.Maybe (fromJust, fromMaybe)
import Data.String ( IsString(fromString) )
import qualified Data.ByteString.Char8 as C
import Data.List (dropWhileEnd)
import Data.Map (Map, insert, alter, empty, (!), (!?))

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

parseInt :: String -> Int
parseInt = fromIntegral . fst . fromJust . C.readInt . fromString

parseIntList :: String -> [Int]
parseIntList = map parseInt . words

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns x = print x

getPair :: IO Value
getPair = do
  [a, b] <- fmap parseInt . words <$> getLine
  return (a, b)

buildTree :: [Value] -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go :: Int -> Tree
    go n = maybe (Leaf value) (Node value) $ fmap go <$> m !? n
      where
        value = xs !! (n-1)

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) = alter (maybe (Just [n]) (Just . (n :))) x $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (_, y)) = (y, 1)
dfs (Node (l, h) xs) = (h, number + if l > childSum then 1 else 0)
  where
    (childSum, number) = foldl1 addUp $ dfs <$> xs

parse :: IO Domain
parse = do
  nodeCount <- parseInt <$> getLine
  parents <- parseIntList <$> getLine
  ranges <- replicateM (fromIntegral nodeCount) getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  n <- parseInt <$> getLine
  replicateM_ (fromIntegral n) (printAns <$> solve =<< parse)

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Bits
-- import Debug.Trace
import Data.Char (digitToInt)
import Data.Maybe (fromJust)
import Data.String ( IsString(fromString) )
import qualified Data.ByteString.Char8 as C
import Data.List (dropWhileEnd)
import Data.Map (Map, insert, alter, empty, (!), (!?))

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

parseInt :: String -> Int
parseInt = fromIntegral . fst . fromJust . C.readInt . fromString

parseIntList :: String -> [Int]
parseIntList = map parseInt . words

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns x = print x

getPair :: IO Value
getPair = do
  [a, b] <- fmap parseInt . words <$> getLine
  return (a, b)

buildTree :: [Value] -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go :: Int -> Tree
    go n = case children of
      Just x -> Node value x
      Nothing -> Leaf value
      where
        children = fmap go <$> m !? n
        value = xs !! (n-1)

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) =
  alter
    ( \case
        Nothing -> Just [n]
        Just ys -> Just (n : ys)
    )
    x
    $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (_, y)) = (y, 1)
dfs (Node (l, h) xs) = (h, number + if l > childSum then 1 else 0)
  where
    (childSum, number) = foldl1 addUp $ dfs <$> xs

parse :: IO Domain
parse = do
  nodeCount <- parseInt <$> getLine
  parents <- parseIntList <$> getLine
  ranges <- replicateM (fromIntegral nodeCount) getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  n <- parseInt <$> getLine
  replicateM_ (fromIntegral n) (printAns <$> solve =<< parse)

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad (liftM2, replicateM_, replicateM)
import Data.Bits
-- import Debug.Trace
import Data.Char (digitToInt)
import Data.Maybe (fromJust)
import Data.String ( IsString(fromString) )
import qualified Data.ByteString.Char8 as C
import Data.List (dropWhileEnd)
import Data.Map (Map, insert, alter, empty, (!), (!?))

type Value = (Int, Int)
data Tree = Leaf Value | Node Value [Tree] deriving (Show)
type Domain = Tree
type CoDomain = Int
type Solver  = Domain -> CoDomain

parseInt :: String -> Int
parseInt = fromIntegral . fst . fromJust . C.readInt . fromString

parseIntList :: String -> [Int]
parseIntList = map parseInt . words

solve :: Solver
solve xs = snd $ dfs xs

printAns :: CoDomain -> IO ()
printAns x = print x

getInt :: IO Int
getInt = parseInt <$> getLine

getPair :: IO Value
getPair = do
  [a, b] <- fmap parseInt . words <$> getLine
  return (a, b)

buildTree :: [Value] -> Map Int [Int] -> Tree
buildTree xs m = go 1
  where
    go :: Int -> Tree
    go n = case children of
      Just x -> Node value x
      Nothing -> Leaf value
      where
        children = fmap go <$> m !? n
        value = xs !! (n-1)

parentToChildren :: Int -> [Int] -> Map Int [Int]
parentToChildren _ [] = empty
parentToChildren n (x : xs) =
  alter
    ( \case
        Nothing -> Just [n]
        Just ys -> Just (n : ys)
    )
    x
    $ parentToChildren (n + 1) xs

addUp :: (Int, Int) -> (Int, Int) -> (Int, Int)
addUp (x1, x2) (y1, y2) = (x1 + y1, x2 + y2)

dfs :: Tree -> (Int, Int)
dfs (Leaf (x, y)) = (y, 1)
dfs (Node (l, h) xs) = (h, number + if l > childSum then 1 else 0)
  where
    (childSum, number) = foldl1 addUp $ map dfs xs

parse :: IO Domain
parse = do
  nodeCount <- getInt
  parents <- parseIntList <$> getLine
  ranges <- replicateM (fromIntegral nodeCount) getPair
  return $ (buildTree ranges $ parentToChildren 2 parents)

main :: IO ()
main = do
  n <- parseInt <$> getLine
  replicateM_ (fromIntegral n) (printAns <$> solve =<< parse)


Giant chess is quite common in Geraldion. We will not delve into the rules of the game, we'll just say that the game takes place on an h × w field, and it is painted in two colors, but not like in chess. Almost all cells of the field are white and only some of them are black. Currently Gerald is finishing a game of giant chess against his friend Pollard. Gerald has almost won, and the only thing he needs to win is to bring the pawn from the upper left corner of the board, where it is now standing, to the lower right corner. Gerald is so confident of victory that he became interested, in how many ways can he win?The pawn, which Gerald has got left can go in two ways: one cell down or one cell to the right. In addition, it can not go to the black cells, otherwise the Gerald still loses. There are no other pawns or pieces left on the field, so that, according to the rules of giant chess Gerald moves his pawn until the game is over, and Pollard is just watching this process.

The first line of the input contains three integers: h, w, n — the sides of the board and the number of black cells (1 ≤ h, w ≤ 105, 1 ≤ n ≤ 2000).  Next n lines contain the description of black cells. The i-th of these lines contains numbers ri, ci (1 ≤ ri ≤ h, 1 ≤ ci ≤ w) — the number of the row and column of the i-th cell. It is guaranteed that the upper left and lower right cell are white and all cells in the description are distinct.

Print a single line — the remainder of the number of ways to move Gerald's pawn from the upper left to the lower right corner modulo 109 + 7.

{-# LANGUAGE BangPatterns #-}
import Data.Int (Int64)
import Data.List (sort)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, listArray, (!), amap)

gcd' :: Integral a => a -> a -> (a, a)
gcd' !a !b
    | a `mod` b /= 0 = loop 1 0 0 1 a b
    | otherwise = (0, 1)
    where
    loop !x !y !x' !y' !r !r'
        | r' `mod` r'' == 0 = (x - q * x', y - q * y')
        | otherwise = loop x' y' (x - q * x') (y - q * y') r' r''
        where (q, r'') = r `divMod` r'

solve :: Int64 -> Int64 -> [(Int64, Int64)] -> Int64
solve h w a = snd . head . foldr loop [] $ (1, 1) :(sort a)
    where
    !m = 1000000007 :: Int64

    (*:) !i !j = (i * j) `mod` m
    (+:) !i !j = (i + j) `mod` m
    (-:) !i !j = (`mod` m) . (+ m) . (`mod` m) $ i - j

    fac :: UArray Int64 Int64
    !fac = listArray (0, h + w) $ scanl (*:) 1 [1..h + w]

    ifac :: UArray Int64 Int64
    !ifac = amap inverse fac
        where inverse !a = (`mod` m) . (+ m) . (`mod` m) . fst $ gcd' a m

    count (!i, !j) (!i', !j')
        | i' < i || j' < j = 0
        | otherwise = (fac ! (di + dj)) *: (ifac ! di) *: (ifac ! dj)
        where
        !di = i' - i
        !dj = j' - j

    loop self@(!i, !j) !acc = ((i, j), out):acc
        where
        out = count self (h, w) -: foldr (+:) 0 (count' <$> acc)
        count' ((i', j'), k) = k *: count self (i', j')

wrap :: Int -> Int -> [[Int64]] -> Int64
wrap h w a = solve (fromIntegral h) (fromIntegral w) a'
    where a' = (\[i, j] -> (i, j)) <$> a

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

main = do
    [h, w, n] <- parse <$> B.getLine
    a <- replicateM n (parse <$> B.getLine)
    print $ wrap h w a

{-# LANGUAGE BangPatterns #-}
import Data.Int (Int64)
import Data.List (sort)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, listArray, (!), amap)

gcd' :: Integral a => a -> a -> (a, a)
gcd' !a !b
    | a `mod` b /= 0 = loop 1 0 0 1 a b
    | otherwise = (0, 1)
    where
    loop !x !y !x' !y' !r !r'
        | r' `mod` r'' == 0 = (x - q * x', y - q * y')
        | otherwise = loop x' y' (x - q * x') (y - q * y') r' r''
        where (q, r'') = r `divMod` r'

solve :: Int -> Int -> [(Int, Int)] -> Int64
solve h w a = snd . head . foldr loop [] $ (1, 1) :(sort a)
    where
    !m = 1000000007 :: Int64

    (*:) !i !j = (i * j) `mod` m
    (+:) !i !j = (i + j) `mod` m
    (-:) !i !j = (`mod` m) . (+ m) . (`mod` m) $ i - j

    fac :: UArray Int Int64
    !fac = listArray (0, h + w) $ scanl (*:) 1 [1.. fromIntegral $ h + w]

    ifac :: UArray Int Int64
    !ifac = amap inverse fac
        where inverse !a = (`mod` m) . (+ m) . (`mod` m) . fst $ gcd' a m

    count (!i, !j) (!i', !j')
        | i' < i || j' < j = 0
        | otherwise = (fac ! (di + dj)) *: (ifac ! di) *: (ifac ! dj)
        where
        !di = i' - i
        !dj = j' - j

    loop self@(!i, !j) !acc = ((i, j), out):acc
        where
        !out = count self (h, w) -: foldr (+:) 0 (count' <$> acc)
        count' ((!i', !j'), !k) = k *: count self (i', j')

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

main = do
    [h, w, n] <- parse <$> B.getLine
    a <- replicateM n ((\[i, j] -> (i, j)) . parse <$> B.getLine)
    print $ solve h w a

{-# LANGUAGE BangPatterns #-}
import Data.Int (Int64)
import Data.List (sort)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, listArray, (!), amap)

gcd' :: Integral a => a -> a -> (a, a)
gcd' !a !b
    | a `mod` b /= 0 = loop 1 0 0 1 a b
    | otherwise = (0, 1)
    where
    loop !x !y !x' !y' !r !r'
        | r' `mod` r'' == 0 = (x - q * x', y - q * y')
        | otherwise = loop x' y' (x - q * x') (y - q * y') r' r''
        where (q, r'') = r `divMod` r'

solve :: Int64 -> Int64 -> [(Int64, Int64)] -> Int64
solve h w a = snd . head . foldr loop [] $ (1, 1) :(sort a)
    where
    !m = 1000000007 :: Int64

    (*:) !i !j = (i * j) `mod` m
    (+:) !i !j = (i + j) `mod` m
    (-:) !i !j = (`mod` m) . (+ m) . (`mod` m) $ i - j

    fac :: UArray Int64 Int64
    !fac = listArray (0, h + w) $ scanl (*:) 1 [1..h + w]

    ifac :: UArray Int64 Int64
    !ifac = amap inverse fac
        where inverse !a = (`mod` m) . (+ m) . (`mod` m) . fst $ gcd' a m

    count (!i, !j) (!i', !j')
        | i' < i || j' < j = 0
        | otherwise = (fac ! (di + dj)) *: (ifac ! di) *: (ifac ! dj)
        where
        !di = i' - i
        !dj = j' - j

    loop self@(!i, !j) !acc = ((i, j), out):acc
        where
        !out = count self (h, w) -: foldr (+:) 0 (count' <$> acc)
        count' ((!i', !j'), !k) = k *: count self (i', j')

wrap :: Int -> Int -> [[Int64]] -> Int64
wrap h w a = solve (fromIntegral h) (fromIntegral w) a'
    where a' = (\[i, j] -> (i, j)) <$> a

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

main = do
    [h, w, n] <- parse <$> B.getLine
    a <- replicateM n (parse <$> B.getLine)
    print $ wrap h w a

module Main(main) where

import Control.Monad(replicateM)
import Data.Functor
import Data.List
import Data.Array

isDigit x = x>='0' && x<='9'
split f l@(a:as) lft
	| f a = split f as (a:lft)
	| otherwise = (reverse lft, as)
split _ [] lft = (reverse lft, [])
readInts::String -> [Integer]
readInts [] = []
readInts l@(x:xs)
	| isDigit x = let (a, b) = split isDigit l [] in (read a):(readInts b)
	| otherwise = readInts xs

factorials = go 0 1 where
	go 200001 _ = []
	go i j = (i,j):(go (i+1) ((j*(i+1)) `rem` p))

p::Integer
p = 1000000007
(<**>) x y = (x * y) `rem` p
(<+>) x y = let t = x + y in if t < p then t else t-p
(<->) x y = let t = x - y in if t < 0 then t+p else t
pow x 0 = 1
pow x a = let ll = pow (x<**>x) (a `quot` 2) in if a `rem` 2 > 0 then (ll <**> x) else ll
inverse x = pow x (p-2)
facs = array (0, 200000) factorials
ifacs = array (0, 200000) $ map (\(x,y) -> (x, inverse y)) factorials
choose a b
	| 0<=b && 0<=a = (facs ! (a+b)) <**> (ifacs ! a) <**> (ifacs ! b)
	| otherwise = 0

dp (prev) me@((i, j)) =
	let
		fn (d, (a, b)) = d <**> (choose (i-a) (j-b))
	in
		((choose (i-1) (j-1)) <-> (foldl (<+>) 0 $ map fn prev), me):prev
runDp :: [(Integer, Integer)] -> [Integer]
runDp l = let t = foldl dp ([]) l in map fst t
--runDp (a:as) = let

main = do
	l <- getLine
	let [h, w, n] = readInts l
	let srt = sortBy (\x y -> compare (sum x) (sum y))
	blacks <- ((map (\x->(head x, x!!1))).srt) <$> replicateM (fromInteger n) (readInts <$> getLine)
	let all = blacks ++ [(h, w)]
	putStrLn $ show $ head.runDp $ all

{-# LANGUAGE BangPatterns #-}
import Data.Int (Int64)
import Data.Maybe (fromJust)
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Array.Unboxed (UArray, listArray, (!), amap)

gcd' :: Integral a => a -> a -> (a, a)
gcd' !a !b
    | a `mod` b /= 0 = loop 1 0 0 1 a b
    | otherwise = (0, 1)
    where
    loop !x !y !x' !y' !r !r'
        | r' `mod` r'' == 0 = (x - q * x', y - q * y')
        | otherwise = loop x' y' (x - q * x') (y - q * y') r' r''
        where (q, r'') = r `divMod` r'

solve :: Int64 -> Int64 -> [(Int64, Int64)] -> Int64
solve h w = snd . head . foldr loop [] . ((1, 1):)
    where
    !m = 1000000007 :: Int64
    (*:) !i !j = (i * j) `mod` m
    (+:) !i !j = (i + j) `mod` m
    (-:) !i !j = ((i - j) `mod` m + m) `mod` m

    fac :: UArray Int64 Int64
    !fac = listArray (0, h + w) $ scanl (*:) 1 [1..h + w]

    ifac :: UArray Int64 Int64
    !ifac = amap inverse fac
        where inverse !a = (`mod` m) . (+ m) . (`mod` m) . fst $ gcd' a m

    count (!i, !j) (!i', !j')
        | i' < i || j' < j = 0
        | otherwise = (fac ! (di + dj)) *: (ifac ! di) *: (ifac ! dj)
        where
        !di = i' - i
        !dj = j' - j

    loop self@(!i, !j) !acc = ((i, j), out):acc
        where
        out = count self (h, w) -: foldr (+:) 0 (count' <$> acc)
        count' ((i', j'), k) = k *: count self (i', j')

wrap :: Int -> Int -> [[Int64]] -> Int64
wrap h w a = solve (fromIntegral h) (fromIntegral w) a'
    where a' = (\[i, j] -> (i, j)) <$> a

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

main = do
    [h, w, n] <- parse <$> B.getLine
    a <- replicateM n (parse <$> B.getLine)
    print $ wrap h w a

module Main(main) where

import Control.Monad
import Data.Functor
import Data.List

isDigit x = x>='0' && x<='9'
split f l@(a:as) lft
	| f a = split f as (a:lft)
	| otherwise = (reverse lft, as)
split _ [] lft = (reverse lft, [])
readInts::String -> [Int]
readInts [] = []
readInts l@(x:xs)
	| isDigit x = let (a, b) = split isDigit l [] in (read a):(readInts b)
	| otherwise = readInts xs
readNlines n = go 0 where
	go i = do
			a<-getLine
			go $ i-1

p = 1000000007

main = do
	l <- getLine
	let [h, w, n] = readInts l
	let srt = sortBy (\x y -> compare (sum x) (sum y))
	blacks <- (srt) <$> replicateM n (readInts <$> getLine)
	putStrLn $ show blacks

module Main(main) where

import Control.Monad(replicateM)
import Data.Functor
import Data.List
import Data.Array

isDigit x = x>='0' && x<='9'
split f l@(a:as) lft
	| f a = split f as (a:lft)
	| otherwise = (reverse lft, as)
split _ [] lft = (reverse lft, [])
readInts::String -> [Int]
readInts [] = []
readInts l@(x:xs)
	| isDigit x = let (a, b) = split isDigit l [] in (read a):(readInts b)
	| otherwise = readInts xs

factorials = go 0 1 where
	go 100001 _ = []
	go i j = (i,j):(go (i+1) ((j*(i+1)) `rem` p))

p::Int
p = 1000000007
(<**>) x y = (x * y) `rem` p
(<+>) x y = let t = x + y in if t < p then t else t-p
(<->) x y = let t = x - y in if t < 0 then t+p else t
pow x 0 = 1
pow x a = let ll = pow (x<**>x) (a `quot` 2) in if a `rem` 2 > 0 then (ll <**> x) else ll
inverse x = pow x (p-2)
facs = array (0, 100000) factorials
ifacs = array (0, 100000) $ map (\(x,y) -> (x, inverse y)) factorials
choose a b
	| 0<=b && 0<=a = (facs ! (a+b)) <**> (ifacs ! a) <**> (ifacs ! b)
	| otherwise = 0

dp (prev) me@((i, j)) =
	let
		fn (d, (a, b)) = d <**> (choose (i-a) (j-b))
	in
		prev ++ [((choose (i-1) (j-1)) <-> (foldl (<+>) 0 $ map fn prev), me)]
runDp :: [(Int, Int)] -> [Int]
runDp l = let t = foldl dp ([]) l in map fst t
--runDp (a:as) = let

main = do
	l <- getLine
	let [h, w, n] = readInts l
	let srt = sortBy (\x y -> compare (sum x) (sum y))
	blacks <- ((map (\x->(head x, x!!1))).srt) <$> replicateM n (readInts <$> getLine)
	let all = blacks ++ [(h, w)]
	putStrLn $ show $ head.reverse.runDp $ all


There are two decks of cards lying on the table in front of you, some cards in these decks lay face up, some of them lay face down. You want to merge them into one deck in which each card is face down. You're going to do it in two stages.The first stage is to merge the two decks in such a way that the relative order of the cards from the same deck doesn't change. That is, for any two different cards i and j in one deck, if card i lies above card j, then after the merge card i must also be above card j.The second stage is performed on the deck that resulted from the first stage. At this stage, the executed operation is the turning operation. In one turn you can take a few of the top cards, turn all of them, and put them back. Thus, each of the taken cards gets turned and the order of these cards is reversed. That is, the card that was on the bottom before the turn, will be on top after it.Your task is to make sure that all the cards are lying face down. Find such an order of merging cards in the first stage and the sequence of turning operations in the second stage, that make all the cards lie face down, and the number of turns is minimum.

The first input line contains a single integer n — the number of cards in the first deck (1 ≤ n ≤ 105). The second input line contains n integers, separated by single spaces a1, a2, ..., an (0 ≤ ai ≤ 1). Value ai equals 0, if the i-th card is lying face down, and 1, if the card is lying face up. The cards are given in the order from the topmost one to the bottommost one. The third input line contains integer m — the number of cards in the second deck (1 ≤ m ≤ 105). The fourth input line contains m integers, separated by single spaces b1, b2, ..., bm (0 ≤ bi ≤ 1). Value bi equals 0, if the i-th card is lying face down, and 1, if the card is lying face up. The cards are given in the order from the topmost to the bottommost.

In the first line print n + m space-separated integers — the numbers of the cards in the order, in which they will lie after the first stage. List the cards from top to bottom. The cards from the first deck should match their indexes from 1 to n in the order from top to bottom. The cards from the second deck should match their indexes, increased by n, that is, numbers from n + 1 to n + m in the order from top to bottom. In the second line print a single integer x — the minimum number of turn operations you need to make all cards in the deck lie face down. In the third line print x integers: c1, c2, ..., cx (1 ≤ ci ≤ n + m), each of them represents the number of cards to take from the top of the deck to perform a turn operation. Print the operations in the order, in which they should be performed.  If there are multiple optimal solutions, print any of them. It is guaranteed that the minimum number of operations doesn't exceed 6·105.

import Data.List
import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countSwitch' [] zs last n = (n,zs,last)
countSwitch' (x:xs) _ (-1) _ = countSwitch' xs [1] x 0
countSwitch' (x:xs) (z:zs) last n
    | x==last = countSwitch' xs ((z+1):zs) x n
    | otherwise = countSwitch' xs (1:z:zs) x (n+1)

addTo z start 0 = z
addTo z start end = addTo (show(start):z) (start-1) (end-1)

sum' _ _ partial 0 = [show partial]
sum' [] [] _ _= []
sum' ((a):as) ((b):bs) partial toGo = show (a + b + partial) : (sum' as bs (a + b + partial) (toGo-1))
sum' [] ((b):bs) partial toGo = show (b + partial) : (sum' [] bs (b + partial) (toGo-1))
sum' ((a):as) [] partial toGo = show (a + partial) : (sum' [] as (a + partial) (toGo-1))

countTurns switchA switchB lastA lastB firstA firstB a b
	| switchA > switchB =
		if (lastA == 0)
			then (show (switchA) ++ ("\n" ++ unwords (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ unwords (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((0):b) 0 (switchA+1)))))
	| switchB > switchA = if (lastB == 0)
		then (show (switchB) ++ ("\n" ++ unwords (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ unwords (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((0):a) b 0 (switchB+1)))))
	| lastA==0 && lastB==0 = show(switchA) ++ ("\n" ++ unwords (init(sum' a b 0 switchA)))
	| lastA==1 && lastB==1 = show(switchA+1) ++ ("\n" ++ unwords (init(sum' a b 0 (switchA+1))))
	| lastA==0 && lastB==1 = show(switchA + 1) ++ ("\n" ++ unwords (init(sum' ((0):a) b 0 (switchA+1))))
	| lastA==1 && lastB==0 = show(switchA + 1) ++ ("\n" ++ unwords (init(sum' a ((0):b) 0 (switchA+1))))

buildStack switchA switchB a b n m firstA firstB
	| switchA > switchB = stack a b n (n+m) [] switchA switchB
	| switchB > switchA = stack b a (n+m) n [] switchB switchA
	| firstA==firstB = stack a b n (n+m) [] switchA switchB
	| firstA==0 && firstB==1 = stack a b n (n+m) [] switchA switchB
	| firstA==1 && firstB==0 = stack b a (n+m) n [] switchB switchA

stack [] [] n m z _ _ = z
stack ((b):xs) [] n m z _ _ = stack xs [] (n-b) m (addTo z n b) 0 0
stack [] ((b):ys) n m z _ _ = stack [] ys n (m-b) (addTo z m b) 0 0
stack ((b):xs) ((d):ys) n m z lengthA lengthB
	| (lengthB) > (lengthA) = stack ((b):xs) (ys) n (m-d) (addTo z m d) lengthA (lengthB-1)
	| otherwise =  stack ((d):ys) xs m (n-b) (addTo z n b) lengthB (lengthA-1)

solve n m firstDeck secondDeck =
	let
		firstA = head firstDeck
		firstB = head secondDeck
		(switchA,a,lastA) = countSwitch' firstDeck [] (-1) n
		(switchB,b,lastB) = countSwitch' secondDeck [] (-1) m
	in
		do
	        --print a
			--print b
			(appendFile "output.txt" $ unwords (buildStack switchA switchB a b n m lastA lastB))
			(appendFile "output.txt" ("\n" ++ (countTurns switchA switchB lastA lastB firstA firstB (reverse a) (reverse b))))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     --print $ show (countSwitch firstDeck [] 0)
     --print $ show (countSwitch' firstDeck [] (-1) 0)
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

run line 0 = ([],0,-1,-1)
run line n =
	let Just(elem,line') = readInt line
	in
		let (stack,switches,last',first') = run line' (n-1)
		in
			if(stack==[])
			then (((elem,1):[]),0,elem,elem)
			else
				let ((_,count):s) = stack in
					if (elem == first')
					then (((elem,count+1):s),switches,last',elem)
					else (((elem,1):stack),switches+1,last',elem)
	where readInt s = BSC.readInt (BSC.dropWhile isSpace s)

addTo z start 0 = z
addTo z start end = (start:(addTo z (start+1) (end-1)))

--solve :: Integral a => [(a,a)] -> [(a,a)] -> a -> a -> a -> ([a],[a])
solve [] [] _ _ _ 0 = ([],[])
solve [] [] _ _ _ extra = ([],[extra])
solve [] ((c,d):sStack) n m count extra =
	if (sStack==[] && c==0)
	then
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, (cards))
	else
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, ((count+d):cards))
solve ((a,b):fStack) [] n m count extra =
	if(fStack==[] && a==0)
	then
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), (cards))
	else
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), ((count+b):cards))
solve ((a,b):fStack) ((c,d):sStack) n m count extra
	| a==c =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, (cards))
		else
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, ((count+b+d):cards))
	| otherwise =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in ((addTo (addTo stack m d) n b), ((count+b):cards))
		else
			let
			    (stack, cards) =
			        solve fStack sStack (n+b) (m+d) (count+b+d) (count+b+d)
			in ((addTo (addTo stack m d) n b), ((count+b):cards))

countTurns fSwitch sSwitch fLast sLast
	| fSwitch > sSwitch && fLast==1 = fSwitch + 1
	| fSwitch > sSwitch && fLast==0 = fSwitch
	| sSwitch > fSwitch && sLast==1 = sSwitch + 1
	| sSwitch > fSwitch && sLast==0 = sSwitch
	| fLast==sLast && fLast==0 = fSwitch
	| fLast==sLast && fLast==1 = fSwitch + 1
	| otherwise = fSwitch + 1

toStr array = tail $ foldr (\x y -> (' ':show(x)) ++ y) "" array

solve' fSwitch sSwitch fStack sStack fLast sLast n m
	| fSwitch>sSwitch =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| sSwitch>fSwitch =
		let
			(stack,cards) = solve sStack fStack 1 (m+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| fLast==sLast =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| fLast==0 =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| sLast==0 =
		let
			(stack,cards) = solve sStack fStack 1 (m+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))

main =
  do
     all <- BSC.readFile "input.txt"
     let (n':firstLine:m':secondLine:_) = BSC.lines all
     let Just (n,_) = readInt n'
     let Just (m,_) = readInt m'
     --print n
     --print firstLine
     --print m
     --print secondLine
     let (fStack,fSwitch,fLast,fFirst) = run firstLine n
     let (sStack,sSwitch,sLast,sFirst) = run secondLine m
     solve' fSwitch sSwitch fStack sStack fLast sLast n m

     --print $ run secondLine m
     --let (firstDeck, r2)  = readMany n readInteger r1
     --let Just (m, r3) = readInteger r2
     --let (secondDeck, _) = readMany m readInteger r3
   --  solve n m firstDeck secondDeck
     print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB
	| switchA > switchB = if (firstA == 0) then switchA else switchA+1
	| switchB > switchA = if (firstB == 0) then switchB else switchB+1
	| firstA==0 && firstB==0 = switchA
	| firstA==1 && firstB==1 = switchA + 1
	| otherwise = switchA + 1

addTo z start 0 = z
addTo z start end = addTo ((show(start)++" ")++z) (start-1) (end-1)

buildStack switchA switchB a b n m firstA
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==0 = stack a b n (n+m) []
	| otherwise = stack b a (n+m) n []

stack [] [] n m z = z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) (y:ys) n m z = stack (y:ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				BS.writeFile "output.txt" $ (BSC.pack ((show $ buildStack switchA switchB a b n m firstA) ++ "\n" ++ (show $ countTurns switchA switchB firstA firstB)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB a b
	| switchA > switchB =
		if (firstA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0,0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((1,0):b) 0 (switchA+1)))))
	| switchB > switchA = if (firstB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0,0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((1,0):a) b 0 (switchB+1)))))
	| firstA==0 && firstB==0 = show(switchA) ++ ("\n" ++ (init(sum' a b 0 switchA)))
	| firstA==1 && firstB==1 = show(switchA+1) ++ ("\n" ++ (init(sum' a b 0 (switchA+1))))
	| firstA==0 && firstB==1 = show(switchA + 1)  ++ ("\n" ++ (init(sum' a ((0,0):b) 0 (switchA+1))))
	| firstA==1 && firstB==0 = show(switchA + 1)  ++ ("\n" ++ (init(sum' ((0,0):a) b 0(switchA+1))))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = init z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==0 = stack a b n (n+m) []
	| otherwise = stack b a (n+m) n []

stack [] [] n m z = z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) (y:ys) n m z = stack (y:ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m firstA) ++ "\n" ++ (countTurns switchA switchB firstA firstB a b)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB a b
	| switchA > switchB =
		if (firstA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0,0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((1,0):b) 0 (switchA+1)))))
	| switchB > switchA = if (firstB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0,0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((1,0):a) b 0 (switchB+1)))))
	| firstA==0 && firstB==0 = show(switchA) ++ ("\n" ++ (init(sum' a b 0 switchA)))
	| firstA==1 && firstB==1 = show(switchA+1) ++ ("\n" ++ (init(sum' a b 0 (switchA+1))))
	| firstA==0 && firstB==1 = show(switchA + 1)  ++ ("\n" ++ (init(sum' a ((0,0):b) 0 (switchA+1))))
	| firstA==1 && firstB==0 = show(switchA + 1)  ++ ("\n" ++ (init(sum' ((0,0):a) b 0(switchA+1))))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==0 = stack a b n (n+m) []
	| otherwise = stack b a (n+m) n []

stack [] [] n m z = init z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) (y:ys) n m z = stack (y:ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m firstA) ++ "\n" ++ (countTurns switchA switchB firstA firstB a b)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB lastA lastB firstA firstB a b
	| switchA > switchB =
		if (lastA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0,0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((1,0):b) 0 (switchA+1)))))
	| switchB > switchA = if (lastB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0,0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((1,0):a) b 0 (switchB+1)))))
	| lastA==0 && lastB==0 = show(switchA) ++ ("\n" ++ (init(sum' a b 0 switchA)))
	| lastA==1 && lastB==1 = show(switchA+1) ++ ("\n" ++ (init(sum' a b 0 (switchA+1))))
	| lastA==0 && lastB==1 = show(switchA + 1)  ++ ("\n" ++ (init(sum' a ((0,0):b) 0 (switchA+1))))
	| lastA==1 && lastB==0 = show(switchA + 1)  ++ ("\n" ++ (init(sum' ((0,0):a) b 0(switchA+1))))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA firstB
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==firstB = stack a b n (n+m) []
	| firstA==0 && firstB==1 = stack a b n (n+m) []
	| firstA==1 && firstB==0 = stack b a (n+m) n []

stack [] [] n m z = init z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) ((c,d):ys) n m z
	| (length ys) > (length xs) = stack ((a,b):xs) (ys) n (m-d) (addTo z m d)
	| otherwise =  stack ((c,d):ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		firstA = head firstDeck
		firstB = head secondDeck
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((lastA,_):as) = a
			((lastB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m lastA lastB) ++ "\n" ++ (countTurns switchA switchB lastA lastB firstA firstB (reverse a) (reverse b))))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

run line 0 = ([],0,-1,-1)
run line n =
	let Just(elem,line') = readInt line
	in
		let (stack,switches,last',first') = run line' (n-1)
		in
			if(stack==[])
			then (((elem,1):[]),0,elem,elem)
			else
				let ((_,count):s) = stack in
					if (elem == first')
					then (((elem,count+1):s),switches,last',elem)
					else (((elem,1):stack),switches+1,last',elem)
	where readInt s = BSC.readInt (BSC.dropWhile isSpace s)

addTo z start 0 = z
addTo z start end = (start:(addTo z (start+1) (end-1)))

--solve :: Integral a => [(a,a)] -> [(a,a)] -> a -> a -> a -> ([a],[a])
solve [] [] _ _ _ 0 = ([],[])
solve [] [] _ _ _ extra = ([],[extra])
solve [] ((c,d):sStack) n m count extra =
	let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
	in if(extra==0)
		then (addTo stack m d, ((count+d):cards))
		else (addTo stack m d, ((count+d):extra:cards))
solve ((a,b):fStack) [] n m count extra =
	let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
	in if (extra==0)
		then ((addTo stack n b), ((count+b):cards))
		else ((addTo stack n b), ((count+b):extra:cards))
solve ((a,b):fStack) ((c,d):sStack) n m count extra
	| a==b =
		let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
		in (addTo (addTo stack n b) m d, ((count+b+d):cards))
	| otherwise =
		let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) (count+b+d)
		in ((addTo (addTo stack n b) m d), ((count+d):cards))

countTurns fSwitch sSwitch fLast sLast
	| fSwitch > sSwitch && fLast==1 = fSwitch + 1
	| fSwitch > sSwitch && fLast==0 = fSwitch
	| sSwitch > fSwitch && sLast==1 = sSwitch + 1
	| sSwitch > fSwitch && sLast==0 = sSwitch
	| fLast==sLast && fLast==0 = fSwitch
	| fLast==sLast && fLast==1 = fSwitch + 1
	| otherwise = fSwitch + 1

toStr array = tail $ foldr (\x y -> (' ':show(x)) ++ y) "" array

main =
  do
     all <- BSC.readFile "input.txt"
     let (n':firstLine:m':secondLine:_) = BSC.lines all
     let Just (n,_) = readInt n'
     let Just (m,_) = readInt m'
     --print n
     --print firstLine
     --print m
     --print secondLine
     let (fStack,fSwitch,fLast,fFirst) = run firstLine n
     let (sStack,sSwitch,sLast,sFirst) = run secondLine m
     let (stack,cards) = solve fStack sStack 1 (n+1) 0 0

     BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++ show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++ (toStr cards)))

     --print $ run secondLine m
     --let (firstDeck, r2)  = readMany n readInteger r1
     --let Just (m, r3) = readInteger r2
     --let (secondDeck, _) = readMany m readInteger r3
   --  solve n m firstDeck secondDeck
     print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

run line 0 = ([],0,-1,-1)
run line n =
	let Just(elem,line') = readInt line
	in
		let (stack,switches,last',first') = run line' (n-1)
		in
			if(stack==[])
			then (((elem,1):[]),0,elem,elem)
			else
				let ((_,count):s) = stack in
					if (elem == first')
					then (((elem,count+1):s),switches,last',elem)
					else (((elem,1):stack),switches+1,last',elem)
	where readInt s = BSC.readInt (BSC.dropWhile isSpace s)

addTo z start 0 = z
addTo z start end = (start:(addTo z (start+1) (end-1)))

--solve :: Integral a => [(a,a)] -> [(a,a)] -> a -> a -> a -> ([a],[a])
solve [] [] _ _ _ 0 = ([],[])
solve [] [] _ _ _ extra = ([],[extra])
solve [] ((c,d):sStack) n m count extra =
	if (sStack==[] && c==0)
	then
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, (cards))
	else
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, ((count+d):cards))
solve ((a,b):fStack) [] n m count extra =
	if(fStack==[] && a==0)
	then
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), (cards))
	else
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), ((count+b):cards))
solve ((a,b):fStack) ((c,d):sStack) n m count extra
	| a==c =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, (cards))
		else
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, ((count+b+d):cards))
	| otherwise =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in ((addTo (addTo stack m d) n b), ((count+b):cards))
		else
			let
			    (stack, cards) =
			        solve fStack sStack (n+b) (m+d) (count+b+d) (count+b+d)
			in ((addTo (addTo stack m d) n b), ((count+b):cards))

countTurns fSwitch sSwitch fLast sLast
	| fSwitch > sSwitch && fLast==1 = fSwitch + 1
	| fSwitch > sSwitch && fLast==0 = fSwitch
	| sSwitch > fSwitch && sLast==1 = sSwitch + 1
	| sSwitch > fSwitch && sLast==0 = sSwitch
	| fLast==sLast && fLast==0 = fSwitch
	| fLast==sLast && fLast==1 = fSwitch + 1
	| otherwise = fSwitch + 1

toStr array = tail $ foldr (\x y -> (' ':show(x)) ++ y) "" array

solve' fSwitch sSwitch fStack sStack fLast sLast n m
	| fSwitch>sSwitch =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| sSwitch>fSwitch =
		let
			(stack,cards) = solve sStack fStack (n+1) 1 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| fLast==sLast =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| fLast==0 =
		let
			(stack,cards) = solve fStack sStack 1 (n+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))
	| sLast==0 =
		let
			(stack,cards) = solve sStack fStack 1 (m+1) 0 0
		in
			BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++
			show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++
			(toStr cards)))

main =
  do
     all <- BSC.readFile "input.txt"
     let (n':firstLine:m':secondLine:_) = BSC.lines all
     let Just (n,_) = readInt n'
     let Just (m,_) = readInt m'
     --print n
     --print firstLine
     --print m
     --print secondLine
     let (fStack,fSwitch,fLast,fFirst) = run firstLine n
     let (sStack,sSwitch,sLast,sFirst) = run secondLine m
     solve' fSwitch sSwitch fStack sStack fLast sLast n m

     --print $ run secondLine m
     --let (firstDeck, r2)  = readMany n readInteger r1
     --let Just (m, r3) = readInteger r2
     --let (secondDeck, _) = readMany m readInteger r3
   --  solve n m firstDeck secondDeck
     print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB a b
	| switchA > switchB =
		if (firstA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0,0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((1,0):b) 0 (switchA+1)))))
	| switchB > switchA = if (firstB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0,0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((1,0):a) b 0 (switchB+1)))))
	| firstA==0 && firstB==0 = show(switchA) ++ ("\n" ++ (init(sum' a b 0 switchA)))
	| firstA==1 && firstB==1 = show(switchA+1) ++ ("\n" ++ (init(sum' a b 0 (switchA+1))))
	| firstA==0 && firstB==1 = show(switchA + 1)  ++ ("\n" ++ (init(sum' a ((0,0):b) 0 (switchA+1))))
	| firstA==1 && firstB==0 = show(switchA + 1)  ++ ("\n" ++ (init(sum' ((0,0):a) b 0(switchA+1))))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==0 = stack a b n (n+m) []
	| otherwise = stack b a (n+m) n []

stack [] [] n m z = init z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) (y:ys) n m z = stack (y:ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m firstA) ++ "\n" ++ (countTurns switchA switchB firstA firstB a b)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     BS.writeFile "output.txt" $ BSC.pack "1 2 4 5 6 7 3\n3\n1 2 7"
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB a b
	| switchA > switchB =
		if (firstA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchA) else init (sum' a ((0,0):b) 0 switchA))))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchA+1)) else init(sum' a ((1,0):b) 0 (switchA+1)))))
	| switchB > switchA = if (firstB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 switchB) else init(sum' ((0,0):a) b 0 switchB))))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then init(sum' a b 0 (switchB+1)) else init(sum' ((1,0):a) b 0 (switchB+1)))))
	| firstA==0 && firstB==0 = show(switchA) ++ ("\n" ++ (init(sum' a b 0 switchA)))
	| firstA==1 && firstB==1 = show(switchA+1) ++ ("\n" ++ (init(sum' a b 0 (switchA+1))))
	| firstA==0 && firstB==1 = show(switchA + 1)  ++ ("\n" ++ (init(sum' a ((0,0):b) 0 (switchA+1))))
	| firstA==1 && firstB==0 = show(switchA + 1)  ++ ("\n" ++ (init(sum' ((0,0):a) b 0(switchA+1))))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA firstB
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==firstB = stack a b n (n+m) []
	| firstA==0 && firstB==1 = stack a b n (n+m) []
	| firstA==1 && firstB==0 = stack b a (n+m) n []

stack [] [] n m z = init z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) ((c,d):ys) n m z
	| (length ys) > (length xs) = stack ((a,b):xs) (ys) n (m-d) (addTo z m d)
	| otherwise =  stack ((c,d):ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m firstA firstB) ++ "\n" ++ (countTurns switchA switchB firstA firstB a b)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

run line 0 = ([],0,-1,-1)
run line n =
	let Just(elem,line') = readInt line
	in
		let (stack,switches,last',first') = run line' (n-1)
		in
			if(stack==[])
			then (((elem,1):[]),0,elem,elem)
			else
				let ((_,count):s) = stack in
					if (elem == first')
					then (((elem,count+1):s),switches,last',elem)
					else (((elem,1):stack),switches+1,last',elem)
	where readInt s = BSC.readInt (BSC.dropWhile isSpace s)

addTo z start 0 = z
addTo z start end = (start:(addTo z (start+1) (end-1)))

--solve :: Integral a => [(a,a)] -> [(a,a)] -> a -> a -> a -> ([a],[a])
solve [] [] _ _ _ 0 = ([],[])
solve [] [] _ _ _ extra = ([],[extra])
solve [] ((c,d):sStack) n m count extra =
	if (sStack==[] && c==0)
	then
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, (cards))
	else
		let  (stack, cards) = solve [] sStack n (m+d) (count+d) 0
		in (addTo stack m d, ((count+d):cards))
solve ((a,b):fStack) [] n m count extra =
	if(fStack==[] && a==0)
	then
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), (cards))
	else
		let (stack, cards) = solve fStack [] (n+b) m (count+b) 0
		in ((addTo stack n b), ((count+b):cards))
solve ((a,b):fStack) ((c,d):sStack) n m count extra
	| a==c =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, (cards))
		else
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in (addTo (addTo stack m d) n b, ((count+b+d):cards))
	| otherwise =
		if(fStack==sStack && fStack==[] && c==0)
		then
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) 0
			in ((addTo (addTo stack m d) n b), ((count+b):cards))
		else
			let (stack, cards) = solve fStack sStack (n+b) (m+d) (count+b+d) (count+b+d)
			in ((addTo (addTo stack m d) n b), ((count+b):cards))

countTurns fSwitch sSwitch fLast sLast
	| fSwitch > sSwitch && fLast==1 = fSwitch + 1
	| fSwitch > sSwitch && fLast==0 = fSwitch
	| sSwitch > fSwitch && sLast==1 = sSwitch + 1
	| sSwitch > fSwitch && sLast==0 = sSwitch
	| fLast==sLast && fLast==0 = fSwitch
	| fLast==sLast && fLast==1 = fSwitch + 1
	| otherwise = fSwitch + 1

toStr array = tail $ foldr (\x y -> (' ':show(x)) ++ y) "" array

main =
  do
     all <- BSC.readFile "input.txt"
     let (n':firstLine:m':secondLine:_) = BSC.lines all
     let Just (n,_) = readInt n'
     let Just (m,_) = readInt m'
     --print n
     --print firstLine
     --print m
     --print secondLine
     let (fStack,fSwitch,fLast,fFirst) = run firstLine n
     let (sStack,sSwitch,sLast,sFirst) = run secondLine m
     let (stack,cards) = solve fStack sStack 1 (n+1) 0 0

     BS.writeFile "output.txt" $ (BSC.pack ( (toStr stack) ++ "\n" ++ show(countTurns fSwitch sSwitch fLast sLast) ++ "\n" ++ (toStr cards)))

     --print $ run secondLine m
     --let (firstDeck, r2)  = readMany n readInteger r1
     --let Just (m, r3) = readInteger r2
     --let (secondDeck, _) = readMany m readInteger r3
   --  solve n m firstDeck secondDeck
     print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)

import Data.Char (isSpace)
import Data.Char (intToDigit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

countSwitch :: (Integral a) => [a] -> [(a,a)] -> a -> ([(a,a)],a)
countSwitch [] z n = (z,n)
countSwitch (x:xs) [] _ = countSwitch xs ((x,1):[]) 0
countSwitch (x:xs) ((a,b):zs) n
	| x==a = countSwitch xs ((a,succ b):zs) n
	| otherwise = countSwitch xs ((x,1):(a,b):zs) (n+1)

countTurns switchA switchB firstA firstB a b
	| switchA > switchB =
		if (firstA == 0)
			then (show (switchA) ++ ("\n" ++ (if (firstB==firstA) then sum' a b 0 switchA else sum' a ((0,0):b) 0 switchA)))
			else (show (switchA+1) ++ ("\n" ++ (if (firstB==firstA) then sum' a b 0 (switchA+1) else sum' a ((1,0):b) 0 (switchA+1))))
	| switchB > switchA = if (firstB == 0)
		then (show (switchB) ++ ("\n" ++ (if (firstB==firstA) then sum' a b 0 switchB else sum' ((0,0):a) b 0 switchB)))
		else (show (switchB+1) ++ ("\n" ++ (if (firstB==firstA) then sum' a b 0 (switchB+1) else sum' ((1,0):a) b 0 (switchB+1))))
	| firstA==0 && firstB==0 = show(switchA) ++ ("\n" ++ (sum' a b 0 switchA))
	| firstA==1 && firstB==1 = show(switchA+1) ++ ("\n" ++ (sum' a b 0 (switchA+1)))
	| firstA==0 && firstB==1 = show(switchA + 1)  ++ ("\n" ++ (sum' a ((0,0):b) 0 (switchA+1)))
	| firstA==1 && firstB==0 = show(switchA + 1)  ++ ("\n" ++ (sum' ((0,0):a) b 0(switchA+1)))

sum' _ _ _ 0 = []
sum' [] [] _ _= []
sum' ((_,a):as) ((_,b):bs) partial toGo = show (a + b + partial) ++ (' ' : (sum' as bs (a + b + partial) (toGo-1)))
sum' [] ((_,b):bs) partial toGo = show (b + partial) ++ (' ' : (sum' [] bs (b + partial) (toGo-1)))
sum' ((_,a):as) [] partial toGo = show (a + partial) ++ (' ' : (sum' [] as (a + partial) (toGo-1)))

addTo z start 0 = z
addTo z start end = addTo (show(start)++(' ':z)) (start-1) (end-1)

buildStack switchA switchB a b n m firstA
	| switchA > switchB = stack a b n (n+m) []
	| switchB > switchA = stack b a (n+m) n []
	| firstA==0 = stack a b n (n+m) []
	| otherwise = stack b a (n+m) n []

stack [] [] n m z = z
stack ((a,b):xs) [] n m z = stack xs [] (n-b) m (addTo z n b)
stack [] ((a,b):ys) n m z = stack [] ys n (m-b) (addTo z m b)
stack ((a,b):xs) (y:ys) n m z = stack (y:ys) xs m (n-b) (addTo z n b)

solve n m firstDeck secondDeck =
	let
		(a,switchA) = countSwitch firstDeck [] n
		(b,switchB) = countSwitch secondDeck [] m
	in
		let
			((firstA,_):as) = a
			((firstB,_):bs) = b
		in
			do
				print a
				print b
				BS.writeFile "output.txt" $ (BSC.pack ((buildStack switchA switchB a b n m firstA) ++ "\n" ++ (countTurns switchA switchB firstA firstB a b)))

main =
  do
     all <- BS.readFile "input.txt"
     let Just (n, r1) = readInteger all
     let (firstDeck, r2)  = readMany n readInteger r1
     let Just (m, r3) = readInteger r2
     let (secondDeck, _) = readMany m readInteger r3
     solve n m firstDeck secondDeck
     --print "hi"
  where readInt s = BSC.readInt (BSC.dropWhile isSpace s)
        readInteger s = BSC.readInteger (BSC.dropWhile isSpace s)
        readMany 0 _ s = ([], s)
        readMany n readf s = case readf s of
          Just (x, r) -> let (xs, t) = readMany (n-1) readf r
                         in  (x : xs, t)
          Nothing     -> ([], s)


You are given an array $$$A$$$ of length $$$N$$$ weights of masses $$$A_1$$$, $$$A_2$$$...$$$A_N$$$. No two weights have the same mass. You can put every weight on one side of the balance (left or right). You don't have to put weights in order $$$A_1$$$,...,$$$A_N$$$. There is also a string $$$S$$$ consisting of characters "L" and "R", meaning that after putting the $$$i-th$$$ weight (not $$$A_i$$$, but $$$i-th$$$ weight of your choice) left or right side of the balance should be heavier. Find the order of putting the weights on the balance such that rules of string $$$S$$$ are satisfied.

The first line contains one integer $$$N$$$ ($$$1 \leq N \leq 2*10^5$$$) - the length of the array $$$A$$$ The second line contains $$$N$$$ distinct integers: $$$A_1$$$, $$$A_2$$$,...,$$$A_N$$$ ($$$1 \leq A_i \leq 10^9$$$) - the weights given The third line contains string $$$S$$$ of length $$$N$$$ consisting only of letters "L" and "R" - string determining which side of the balance should be heavier after putting the $$$i-th$$$ weight of your choice

The output contains $$$N$$$ lines. In every line, you should print one integer and one letter - integer representing the weight you are putting on the balance in that move and the letter representing the side of the balance where you are putting the weight. If there is no solution, print $$$-1$$$.

NoteExplanation for the test case:  after the 1st weight: 3 L (left side is heavier)after the 2nd weight: 2 R (left side is heavier)after the 3rd weight: 8 R (right side is heavier)after the 4th weight: 13 L (left side is heavier)after the 5th weight: 7 L (left side is heavier)So, the rules given by string $$$S$$$ are fulfilled and our order of putting the weights is correct.

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

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

apply (s,ans) ('L',x)
    | s - x > 0 = (s-x, ('R':ans))
    | otherwise = (s+x, ('L':ans))
apply (s,ans) ('R',x)
    | s + x < 0 = (s+x, ('L':ans))
    | otherwise = (s-x, ('R':ans))

parts (d:ds) bs (g:gs) =
    let z = length d
        (b1,b2) = splitAt (z-1) bs
    in (g:b1) : parts ds b2 gs
parts _ _ _ = []

main = do
    [n] <- readInts
    arr <- readInts
    expdir <- getLine
    let sorted = sort arr
        blocks = group expdir
        k = length blocks
        (bads, goods) = splitAt (n-k) sorted
        order = parts blocks (reverse bads) goods
        greedy = zip expdir $ concat order
        dirs = reverse $ snd $ foldl' apply (0,"") greedy
    forM_ (zip dirs greedy) $ \(d,(_,x)) -> do
        putStrLn $ show x ++ [' ', d]

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

readIntegers :: IO [Integer]
readIntegers = map (fst . fromJust . B.readInteger) . B.words <$> B.getLine

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

apply (s,ans) ('L',x)
    | s - x > 0 = (s-x, ('R':ans))
    | otherwise = (s+x, ('L':ans))
apply (s,ans) ('R',x)
    | s + x < 0 = (s+x, ('L':ans))
    | otherwise = (s-x, ('R':ans))

parts (d:ds) bs (g:gs) =
    let z = length d
        (b1,b2) = splitAt (z-1) bs
    in (g:b1) : parts ds b2 gs
parts _ _ _ = []

main = do
    [n] <- readInts
    arr <- readIntegers
    expdir <- getLine
    let sorted = sort arr
        blocks = group expdir
        k = length blocks
        (bads, goods) = splitAt (n-k) sorted
        order = parts blocks (reverse bads) goods
        greedy = zip expdir $ concat order
        dirs = reverse $ snd $ foldl' apply (0,"") greedy
    forM_ (zip dirs greedy) $ \(d,(_,x)) -> do
        putStrLn $ show x ++ [' ', d]

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

readIntegers :: IO [Integer]
readIntegers = map (fst . fromJust . B.readInteger) . B.words <$> B.getLine

apply (sl,sr,ans) ('L',x)
    | sr + x < sl = (sl, sr+x, ('R':ans))
    | otherwise = (sl+x,sr, ('L':ans))
apply (sl,sr,ans) ('R',x)
    | sl + x < sr = (sl+x, sr, ('L':ans))
    | otherwise = (sl, sr+x, ('R':ans))

main = do
    getLine
    arr <- readIntegers
    expdir <- getLine
    let sorted = sort arr
        greedy = concat $ map reverse $ groupBy ((==) `on` fst) $ zip expdir sorted
        dirs = reverse $ (\(_,_,x) -> x) $ foldl' apply (0,0,"") greedy
    forM_ (zip dirs greedy) $ \(d,(_,x)) -> do
        putStrLn $ show x ++ [' ', d]


Watchmen are in a danger and Doctor Manhattan together with his friend Daniel Dreiberg should warn them as soon as possible. There are n watchmen on a plane, the i-th watchman is located at point (xi, yi).They need to arrange a plan, but there are some difficulties on their way. As you know, Doctor Manhattan considers the distance between watchmen i and j to be |xi - xj| + |yi - yj|. Daniel, as an ordinary person, calculates the distance using the formula .The success of the operation relies on the number of pairs (i, j) (1 ≤ i < j ≤ n), such that the distance between watchman i and watchmen j calculated by Doctor Manhattan is equal to the distance between them calculated by Daniel. You were asked to compute the number of such pairs.

The first line of the input contains the single integer n (1 ≤ n ≤ 200 000) — the number of watchmen. Each of the following n lines contains two integers xi and yi (|xi|, |yi| ≤ 109). Some positions may coincide.

Print the number of pairs of watchmen such that the distance between them calculated by Doctor Manhattan is equal to the distance calculated by Daniel.

NoteIn the first sample, the distance between watchman 1 and watchman 2 is equal to |1 - 7| + |1 - 5| = 10 for Doctor Manhattan and  for Daniel. For pairs (1, 1), (1, 5) and (7, 5), (1, 5) Doctor Manhattan and Daniel will calculate the same distances.

{-# LANGUAGE TupleSections #-}

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

data SP = SP{
  sfst::{-# UNPACK #-} !Int,
  ssnd:: {-# UNPACK #-} !Int
}deriving (Eq, Ord)

countBy::Eq a=>(b->a)->[b]->Integer
countBy f = walk where
  walk (x:xs) = go x 1 0 xs
  walk []     = 0
  go _ _ acc [] = acc
  go y c acc (x:xs)
    | f x == f y = go x (c+1) (acc + c) xs
    | otherwise  = go x 1     acc       xs

main::IO ()
main = do
  n <-fmap  read getLine
  let lsp [x,y] = SP x y
      lsp _     = undefined
  es <- replicateM n $ fmap  (lsp .map read . words)  getLine::IO [SP]
  let xs = sort                    es
      ys = sortBy (comparing ssnd) xs
  print (countBy sfst xs + countBy ssnd ys - countBy id xs)

{-# LANGUAGE TupleSections #-}

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

data SP = SP{
  sfst::{-# UNPACK #-} !Int,
  ssnd:: {-# UNPACK #-} !Int
}deriving (Eq, Ord)

data ST a = ST !a {-# UNPACK #-} !Int Integer

countBy::Eq a=>(b->a)->[b]->Integer
countBy f = walk where
  thrd (ST _ _ x) = x
  walk (x:xs) = thrd $ foldl' go (ST x 1 0) xs
  walk []     = 0
  go (ST y c acc) x
    | f x == f y = ST x (c+1) (acc + fromIntegral c)
    | otherwise  = ST x 1   acc

main::IO ()
main = do
  n <-fmap  read getLine
  let lsp [x,y] = SP x y
      lsp _     = undefined
  es <- replicateM n $ fmap  (lsp .map read . words)  getLine::IO [SP]
  let xs = sort                    es
      ys = sortBy (comparing ssnd) xs
  print (countBy sfst xs + countBy ssnd ys - countBy id xs)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE BangPatterns #-}
-- {-# LANGUAGE ViewPatterns #-}
-- {-# LANGUAGE TupleSections #-}

import           System.IO hiding (char8)
import           Control.Applicative
import           Control.Monad
import           Data.List
import           Data.Tuple
import           Data.Int
import           Data.Char
import           Data.Function
import           Data.Array
-- import           Data.Array.ST
-- import           Data.Array.Unsafe
import           Data.Maybe
import           Data.Monoid hiding ((<>))
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import           Data.ByteString.Builder
import           Data.Set (Set)
import qualified Data.Set as Set
-- import           Data.Vector.Unboxed ((//), (++), (!), (!?))
-- import qualified Data.Vector.Unboxed as U
-- import           Data.IntMap.Strict (IntMap)
-- import qualified Data.IntMap.Strict as IntMap
-- import           Data.Sequence ((|>), (<|), (><),ViewR((:>)), ViewL((:<)))
-- import qualified Data.Sequence as S

out = stdout

main = do
  n <- readInt1 <$> BS.getLine
  ss <- map readInt2 <$> replicateM n BS.getLine
  print $ solve ss

solve :: [(Int,Int)] -> Integer
solve ss = x + y - z where
  x = sum . map ((flip comb 2).fromIntegral.length) . group . sort . fst . unzip $ ss
  y = sum . map ((flip comb 2).fromIntegral.length) . group . sort . snd . unzip $ ss
  z = sum . map ((flip comb 2).fromIntegral.length) . group . sort $ ss

comb 1 r = 0
comb n r = iterate (scanl1 (+)) [1,1..] !! (n-r) !! r

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

readInt1 :: BS.ByteString -> Int
readInt1 = fst . fromJust . BS.readInt

readInt2 :: BS.ByteString -> (Int,Int)
readInt2 = toTuple . readIntN

readInt3 :: BS.ByteString -> (Int,Int,Int)
readInt3 = toTriple . readIntN

readIntN :: BS.ByteString -> [Int]
readIntN =  map readInt1 . BS.words

toTuple :: [a] -> (a, a)
toTuple [x, y] = (x, y)

toTriple :: [a] -> (a, a, a)
toTriple [x, y, z] =(x, y, z)

fromTuple :: (a, a) -> [a]
fromTuple (x, y) = [x, y]

fromTriple :: (a, a, a) -> [a]
fromTriple (x, y, z) = [x, y, z]

-- if not applying, use "const"

applyTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
applyTuple f g (x, y) = (f x, g y)

applyTriple :: (a -> a') -> (b -> b') -> (c -> c') -> (a, b, c) -> (a', b', c')
applyTriple f g h (x, y, z) = (f x, g y, h z)

-- output functions

data Cell  = ByteStringC BL.ByteString
           | IntC Int
           | Int64C Int64
           deriving( Eq, Ord, Show )

data Row   = ListR [Cell]
           | TupleR (Cell,Cell)
           | TripleR (Cell,Cell,Cell)
           deriving( Eq, Ord, Show )

type Table = [Row]

infixr 4 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend

putAns :: Handle -> Table -> IO ()
putAns o = hPutBuilder o . renderTable

renderTable :: Table -> Builder
renderTable rs = mconcat [renderRow r <> char8 '\n' | r <- rs]

renderRow :: Row -> Builder
renderRow (ListR []) = mempty
renderRow (ListR (c:cs)) = renderCell c <> mconcat [ char8 ' ' <> renderCell c' | c' <- cs ]
renderRow (TupleR (x,y)) = renderCell x <> char8 ' ' <> renderCell y
renderRow (TripleR (x,y,z)) = renderCell x <> char8 ' ' <> renderCell y <> char8 ' ' <> renderCell z

renderCell :: Cell -> Builder
renderCell (ByteStringC cs) = lazyByteString cs
renderCell (IntC i) = intDec i
renderCell (Int64C i) = int64Dec i

import Control.Applicative
import Data.List
import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.Array
import qualified Data.IntMap as I
import qualified Data.Map as M

comb2::Int->Integer

comb2 n = fromIntegral $ div ((fromIntegral n) * (fromIntegral (n-1)) ) 2

process q=   sum $ map comb2  $ filter (>1) $ I.elems $ I.fromListWith (+) $ zip q $ repeat 1

main=do
	s<- getLine
	[t1,t2]<- transpose. map (map (fst.fromJust.C.readInt)). map C.words. C.lines <$> C.getContents ::IO [[Int]]
	let n1 = process t1 + process t2
	let n2 =  sum $ map comb2  $filter (>1) $ map length $ group $ sort (zip t1 t2)
	print $ n1-n2

import Data.List
import Data.Maybe
import Data.Functor
import Data.Function (on)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as B

main :: IO()
main = do
    _ <- getLine
    a <- readAllInts
    print $ solve $ selfZip a

readInt :: B.ByteString -> Int
readInt = fromJust . fmap fst . B.readInt

readAllInts :: IO [Int]
readAllInts = map readInt . B.words <$> B.getContents

count :: [[a]] -> Integer
count a = sum $ map ((\x -> x * (x - 1) `div` 2) . fromIntegral . length) a

solve :: [(Int, Int)] -> Integer
solve a = let sx = sort a
              sy = sortBy (compare `on` snd) a
              gx = groupBy ((==) `on` fst) sx
              gy = groupBy ((==) `on` snd) sy
              gxy = group sx
              cx = count gx
              cy = count gy
              cxy = count gxy
          in cx + cy - cxy

selfZip :: [Int] -> [(Int, Int)]
selfZip [] = []
selfZip (a:b:s) = (a, b):selfZip s

import Control.Monad
import Control.Applicative

import Data.List
import Data.Maybe
import Data.Function(on)
import Data.Tuple(swap)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Char8 as B

main :: IO ()
main = do
    _ <- readLn :: IO Int
    ps <- map l2p <$> readAllInts
    let count f = sum .
                  map ((\x -> x * (x-1) `div` 2) . fromIntegral . length) .
                  groupBy ((==) `on` f) .
                  sortBy (compare `on` f)
    let a,b,c :: Integer
        a = count fst ps
        b = count snd ps
        c = count id  ps
    print $ a + b - c

-- IO
readInt :: B.ByteString -> Int
readInt = fromJust . fmap fst . B.readInt
readAllInts :: IO [[Int]]
readAllInts = map (map readInt . B.words) . B.lines <$> B.getContents

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

import Data.List
import Data.Tree
import Data.Int
import Data.Word
import Data.Maybe
import Data.Char
import Control.Monad
import Control.Monad.ST.Safe
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 =  C.getLine >>= \n -> print.solve =<< (forM [1..(fst.fromJust.C.readInt) n] $ \ i -> C.getLine>>= \js -> return $ map (fst.fromJust.C.readInt) $ C.words js)
solve:: [[Int]] -> Integer
solve xs = (+) (slv1 xs) $ sum $ map (\a->comb2 $ fromIntegral $ length a) $ groupBy (\a b ->(head a) == (head b)) $ sortBy (\ a b -> (head a) `compare` (head b)) xs
slv1 xs = let ys= groupBy (\a b ->(last a) == (last b)) $ sortBy (\ a b -> (last a) `compare` (last b)) xs;
              zs = map ( \ as -> groupBy (\a b ->(head a) == (head b)) $ sortBy (\ a b -> (head a) `compare` (head b)) as ) ys in sum (map (\a->comb2 $  fromIntegral $ length a) ys) -  sum  (map (\ as-> sum $ map (\a->comb2 $  fromIntegral $ length a) as) zs)
comb2 x = (x*(x-1)) `div` 2

{-# LANGUAGE TupleSections #-}

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

countBy::Eq a=>(b->a)->[b]->Integer
countBy f = walk where
  walk (x:xs) = go x 1 0 xs
  walk []     = 0
  go _ _ acc [] = acc
  go y c acc (x:xs)
    | f x == f y = go x (c+1) (acc + c) xs
    | otherwise  = go x 1     acc       xs

main::IO ()
main = do
  n <-fmap  read getLine
  let m = 2^(31::Int)
      lsp [x,y] = x*m+y
      lsp _     = undefined
      sfst x = div x m
      ssnd x = mod x m
  es <- replicateM n $ fmap  (lsp .map read . words)  getLine::IO [Int]
  let xs = sort                    es
      ys = sortBy (comparing ssnd) es
  print (countBy sfst xs + countBy ssnd ys - countBy id xs)

{-# LANGUAGE TupleSections #-}

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

countBy::Eq a=>(b->a)->[b]->Integer
countBy f = walk where
  walk (x:xs) = go x 1 0 xs
  walk []     = 0
  go _ _ acc [] = acc
  go y c acc (x:xs)
    | f x == f y = go x (c+1) (acc + c) xs
    | otherwise  = go x 1     acc       xs

main::IO ()
main = do
  n <-fmap  read getLine
  let m = 2^(31::Int)
      lsp [x,y] = x*m+y
      lsp _     = undefined
      sfst x = div x m
      ssnd x = mod x m
  es <- replicateM n $ fmap  (lsp .map read . words)  getLine::IO [Int64]
  let xs = sort                    es
      ys = sortBy (comparing ssnd) es
  print (countBy sfst xs + countBy ssnd ys - countBy id xs)

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE BangPatterns #-}
-- {-# LANGUAGE ViewPatterns #-}
-- {-# LANGUAGE TupleSections #-}

import           System.IO hiding (char8)
import           Control.Applicative
import           Control.Monad
import           Data.List
import           Data.Tuple
import           Data.Int
import           Data.Char
import           Data.Function
import           Data.Array
-- import           Data.Array.ST
-- import           Data.Array.Unsafe
import           Data.Maybe
import           Data.Monoid hiding ((<>))
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import           Data.ByteString.Builder
import           Data.Set (Set)
import qualified Data.Set as Set
-- import           Data.Vector.Unboxed ((//), (++), (!), (!?))
-- import qualified Data.Vector.Unboxed as U
-- import           Data.IntMap.Strict (IntMap)
-- import qualified Data.IntMap.Strict as IntMap
-- import           Data.Sequence ((|>), (<|), (><),ViewR((:>)), ViewL((:<)))
-- import qualified Data.Sequence as S

out = stdout

main = do
  n <- readInt1 <$> BS.getLine
  ss <- map readInt2 <$> replicateM n BS.getLine
  print $ solve ss

solve :: [(Int,Int)] -> Int
solve ss = x + y - z where
  x = sum . map ((flip comb 2).length) . group . sort . fst . unzip $ ss
  y = sum . map ((flip comb 2).length) . group . sort . snd . unzip $ ss
  z = sum . map ((flip comb 2).length) . group . sort $ ss

comb 1 r = 0
comb n r = iterate (scanl1 (+)) [1,1..] !! (n-r) !! r

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

readInt1 :: BS.ByteString -> Int
readInt1 = fst . fromJust . BS.readInt

readInt2 :: BS.ByteString -> (Int,Int)
readInt2 = toTuple . readIntN

readInt3 :: BS.ByteString -> (Int,Int,Int)
readInt3 = toTriple . readIntN

readIntN :: BS.ByteString -> [Int]
readIntN =  map readInt1 . BS.words

toTuple :: [a] -> (a, a)
toTuple [x, y] = (x, y)

toTriple :: [a] -> (a, a, a)
toTriple [x, y, z] =(x, y, z)

fromTuple :: (a, a) -> [a]
fromTuple (x, y) = [x, y]

fromTriple :: (a, a, a) -> [a]
fromTriple (x, y, z) = [x, y, z]

-- if not applying, use "const"

applyTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
applyTuple f g (x, y) = (f x, g y)

applyTriple :: (a -> a') -> (b -> b') -> (c -> c') -> (a, b, c) -> (a', b', c')
applyTriple f g h (x, y, z) = (f x, g y, h z)

-- output functions

data Cell  = ByteStringC BL.ByteString
           | IntC Int
           | Int64C Int64
           deriving( Eq, Ord, Show )

data Row   = ListR [Cell]
           | TupleR (Cell,Cell)
           | TripleR (Cell,Cell,Cell)
           deriving( Eq, Ord, Show )

type Table = [Row]

infixr 4 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend

putAns :: Handle -> Table -> IO ()
putAns o = hPutBuilder o . renderTable

renderTable :: Table -> Builder
renderTable rs = mconcat [renderRow r <> char8 '\n' | r <- rs]

renderRow :: Row -> Builder
renderRow (ListR []) = mempty
renderRow (ListR (c:cs)) = renderCell c <> mconcat [ char8 ' ' <> renderCell c' | c' <- cs ]
renderRow (TupleR (x,y)) = renderCell x <> char8 ' ' <> renderCell y
renderRow (TripleR (x,y,z)) = renderCell x <> char8 ' ' <> renderCell y <> char8 ' ' <> renderCell z

renderCell :: Cell -> Builder
renderCell (ByteStringC cs) = lazyByteString cs
renderCell (IntC i) = intDec i
renderCell (Int64C i) = int64Dec i

import Control.Applicative
import Data.List
import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.Array
import qualified Data.IntMap as I
import qualified Data.Map as M

comb2 n = div (n*(n-1)) 2

process q=   sum $ map comb2  $ filter (>1) $ I.elems $ I.fromListWith (+) $ zip q $ repeat 1

main=do
	s<- getLine
	[t1,t2]<- transpose. map (map (fst.fromJust.C.readInt)). map C.words. C.lines <$> C.getContents ::IO [[Int]]
	let n1 = process t1 + process t2
	let n2 =  sum $ map comb2  $filter (>1) $ map length $ group $ sort (zip t1 t2)
	print $ n1-n2

import Control.Applicative
import Data.List
import qualified Data.ByteString.Char8 as C
import Data.Maybe
import Data.Array
import qualified Data.IntMap as I
import qualified Data.Map as M

comb2::Int->Integer

comb2 n = fromIntegral (div (n*(n-1)) 2)

process q=   sum $ map comb2  $ filter (>1) $ I.elems $ I.fromListWith (+) $ zip q $ repeat 1

main=do
	s<- getLine
	[t1,t2]<- transpose. map (map (fst.fromJust.C.readInt)). map C.words. C.lines <$> C.getContents ::IO [[Int]]
	let n1 = process t1 + process t2
	let n2 =  sum $ map comb2  $filter (>1) $ map length $ group $ sort (zip t1 t2)
	print $ n1-n2

import Data.List
import Data.Tree
import Data.Int
import Data.Maybe
import Data.Char
import Control.Monad
import Control.Monad.ST.Safe
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 =  C.getLine >>= \n -> putStrLn.solve =<< (forM [1..(fst.fromJust.C.readInt) n] $ \ i -> C.getLine>>= \js -> return $ map (fst.fromJust.C.readInt) $ C.words js)
solve xs = show $ (+) (slv1 xs) $ sum $ map (\a->comb2 $ length a) $ groupBy (\a b ->(head a) == (head b)) $ sortBy (\ a b -> (head a) `compare` (head b)) xs
slv1 xs = let ys= groupBy (\a b ->(last a) == (last b)) $ sortBy (\ a b -> (last a) `compare` (last b)) xs;
              zs = map ( \ as -> groupBy (\a b ->(head a) == (head b)) $ sortBy (\ a b -> (head a) `compare` (head b)) as ) ys in sum (map (\a->comb2 $ length a) ys) -  sum  (map (\ as-> sum $ map (\a->comb2 $ length a) as) zs)
comb2 x = (x*(x-1)) `div` 2